From: Dmitry Bogatov <[email protected]>
* 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.
