[PATCH 06/25] Basic implementation of `define-foreign-function'

[KAction]

From: Dmitry Bogatov <address@hidden>

  * 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.