From: Dmitry Bogatov <kact...@gnu.org> * 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.