[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 08/25] Add keywords for `define-foreign-function' macro
From: |
KAction |
Subject: |
[PATCH 08/25] Add keywords for `define-foreign-function' macro |
Date: |
Mon, 18 Jul 2016 18:17:31 +0300 |
From: Dmitry Bogatov <address@hidden>
* module/system/foreign/declarative.scm(define-foreign-function):
new keywords arguments:
- dynamic-library: dynamic library object where load symbol from
- symbol: explicitly specify underlying C symbol, if automatic
deriving from Scheme function name is not sufficent.
* test-suite/tests/foreign-declarative.test: add tests for
explicit symbol specification.
---
module/system/foreign/declarative.scm | 43 +++++++++++++++++++------------
test-suite/tests/foreign-declarative.test | 5 +++-
2 files changed, 30 insertions(+), 18 deletions(-)
diff --git a/module/system/foreign/declarative.scm
b/module/system/foreign/declarative.scm
index b6221b3..4177bf7 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -20,6 +20,7 @@
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-9))
(use-modules (ice-9 match))
+(use-modules (ice-9 optargs))
(use-modules (system foreign))
(define-record-type <foreign-type>
@@ -138,21 +139,29 @@
(export define-foreign-function)
(define-syntax define-foreign-function
(syntax-rules (::)
- ((_ function-name ((type arg-name) ...) :: return-type)
- (begin
- (define backend-function
- (decode-function-from-pointer
- (dynamic-pointer (make-c-function-name 'function-name)
(dynamic-link))
- (%make-foreign-argument return-type)
- (map %make-foreign-argument (list type ...))))
- (set-procedure-property! backend-function 'name 'function-name)
- (define (function-name arg-name ...)
- (let ((predicate? (ft-predicate-proc type)))
- (unless (predicate? arg-name)
- (throw 'wrong-type-arg
- 'function-name
- "Wrong type argument named `~A' (failed to satisfy
predicate `~A'): ~S"
- (list 'arg-name (procedure-name predicate?) arg-name)
- (list arg-name)))) ...
+ ((_ function-name ((type arg-name) ...) :: return-type kw ...)
+ (define function-name
+ (let-keywords (list kw ...) #f
+ ((dynamic-library (dynamic-link))
+ (symbol (make-c-function-name 'function-name)))
+ (let* ((backend-function
+ (decode-function-from-pointer
+ (dynamic-pointer symbol dynamic-library)
+ (%make-foreign-argument return-type)
+ (map %make-foreign-argument (list type ...))))
+ (frontend-function
+ (lambda (arg-name ...)
+ (let ((predicate? (ft-predicate-proc type)))
+ (unless (predicate? arg-name)
+ (throw
+ 'wrong-type-arg
+ 'function-name
+ "Wrong type argument named `~A' (failed to satisfy
predicate `~A'): ~S"
+ (list 'arg-name (procedure-name predicate?) arg-name)
+ (list arg-name))))
+ ...
+ (backend-function arg-name ...))))
+ (set-procedure-property! backend-function 'name 'function-name)
+ (set-procedure-property! frontend-function 'name 'function-name)
+ frontend-function))))))
- (backend-function arg-name ...))))))
diff --git a/test-suite/tests/foreign-declarative.test
b/test-suite/tests/foreign-declarative.test
index fd3a470..cf285d4 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -45,10 +45,13 @@
((ft-decode-proc bogus:) 'some-value)))
(define-foreign-function c-sin ((double: x)) :: double:)
+(define-foreign-function my-cos ((double: x)) :: double: #:symbol "cos")
(with-test-prefix "trivial foreign functions"
(pass-if "sin is correct"
- (equal? (sin 10.0) (c-sin 10.0))))
+ (equal? (sin 10.0) (c-sin 10.0)))
+ (pass-if "cos with explicit symbol name is correct"
+ (equal? (my-cos 15.0) (cos 15.0))))
(with-test-prefix "wrong usage"
(pass-if "wrong arg contains function name"
--
I may be not subscribed. Please, keep me in carbon copy.
- Foreign-declarative module, KAction, 2016/07/18
- [PATCH 01/25] New module: system/foreign/declarative.scm, KAction, 2016/07/18
- [PATCH 02/25] Define <ffi-type> structure, KAction, 2016/07/18
- [PATCH 03/25] Mirror types from system/foreign as <foreign-type>, KAction, 2016/07/18
- [PATCH 04/25] Write boilerplate for primitive types, KAction, 2016/07/18
- [PATCH 05/25] Fix bug in `default' macro, KAction, 2016/07/18
- [PATCH 06/25] Basic implementation of `define-foreign-function', KAction, 2016/07/18
- [PATCH 07/25] Introduce foreign-type predicates, KAction, 2016/07/18
- [PATCH 08/25] Add keywords for `define-foreign-function' macro,
KAction <=
- [PATCH 10/25] Refactor type validation in `define-foreign-function', KAction, 2016/07/18
- [PATCH 09/25] system/foreign/declarative: rename `predicate' to `validate', KAction, 2016/07/18
- [PATCH 11/25] system/foreign/declarative: new macro, KAction, 2016/07/18
- [PATCH 13/25] system/foreign/declarative.scm: export string foreign type, KAction, 2016/07/18
- [PATCH 12/25] Improve deriving c symbol name from scheme one, KAction, 2016/07/18
- [PATCH 14/25] foreign/declarative: mirror more primitive types, KAction, 2016/07/18
- [PATCH 15/25] New macro: with-pointer, KAction, 2016/07/18
- [PATCH 16/25] Configure emacs file-local indention, KAction, 2016/07/18
- [PATCH 17/25] system/foreign/declarative: unexport internal macro, KAction, 2016/07/18
- [PATCH 18/25] write documentation for (system foreign declarative), KAction, 2016/07/18