From: Dmitry Bogatov <kact...@gnu.org> * module/system/foreign/declarative.scm: new macro `define-foreign-function', that allows import from current binary C function with primitive (no strings, no pointers) arguments, that returns primitive type.
* module/system/foreign/declarative.scm: test that `sin' function, imported via `define-foreign-function' behaves same way as built-in one. --- module/system/foreign/declarative.scm | 44 +++++++++++++++++++++++++++++++ test-suite/tests/foreign-declarative.test | 6 +++++ 2 files changed, 50 insertions(+) diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm index 5b84c22..4b9ef02 100644 --- a/module/system/foreign/declarative.scm +++ b/module/system/foreign/declarative.scm @@ -17,7 +17,9 @@ (define-module (system foreign declarative) #:export (make-foreign-type) #:export (define-foreign-type)) +(use-modules (srfi srfi-1)) (use-modules (srfi srfi-9)) +(use-modules (ice-9 match)) (use-modules (system foreign)) (define-record-type <foreign-type> @@ -87,3 +89,45 @@ (mirror-primitive-type float) (mirror-primitive-type double) (mirror-primitive-type '* *:) + +(define-record-type <foreign-argument> + (%make-foreign-argument type) + foreign-argument? + (type fa-type)) + +(define (decode-function-from-pointer pointer return-arg args) + (define (c-type arg) + (ft-type (fa-type arg))) + (define (c-encode arg val) + ((ft-encode-proc (fa-type arg)) val)) + (define (c-decode arg val) + ((ft-decode-proc (fa-type arg)) val)) + (define (decode-return val) + (c-decode return-arg val)) + (define raw-procedure + (pointer->procedure (c-type return-arg) pointer (map c-type args))) + (lambda _values + (define (encode-arg P) + (match P + ((arg value) (c-encode arg value)))) + (decode-return (apply raw-procedure (map encode-arg (zip args _values)))))) + +(define (make-c-function-name symbol) + (define function-name (symbol->string symbol)) + (when (string-prefix? "c-" function-name) + (set! function-name (string-drop function-name 2))) + function-name) + +(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 ...) + (backend-function arg-name ...)))))) diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test index eb2a47c..8353ff5 100644 --- a/test-suite/tests/foreign-declarative.test +++ b/test-suite/tests/foreign-declarative.test @@ -43,3 +43,9 @@ (pass-if-exception "decode-proc correctly defaults to error" '(misc-error . "Unavailable") ((ft-decode-proc bogus:) 'some-value))) + +(define-foreign-function c-sin ((double: x)) :: double:) + +(with-test-prefix "trivial foreign functions" + (pass-if "sin is correct" + (equal? (sin 10.0) (c-sin 10.0)))) -- I may be not subscribed. Please, keep me in carbon copy.