[PATCH 08/25] Add keywords for `define-foreign-function' macro

[KAction@gnu.org]

From: Dmitry Bogatov <KAction@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.