[PATCH 07/25] Introduce foreign-type predicates

[KAction]

From: Dmitry Bogatov <address@hidden>

Introduce notion of foreign-type predicates. The following
changed was made:

 * new field `ft-predicate-proc' in <foreign-type> record.
 * new argument to `make-foreign-type' function
 * specify predicates for primitive types, which required
   change of helper `mirror-primitive-type' macro
 * function defined by `define-foreign-function' now checks
   it's arguments aganist predicate of specified type.

All this is required to hide implementation details from user.  If some
module import some foreign function from C library and them exports it,
it behaves not-differently from if it was part of Guile C source code
with aggressive type checking.
---
 module/system/foreign/declarative.scm     | 75 ++++++++++++++++++++-----------
 test-suite/tests/foreign-declarative.test |  9 ++++
 2 files changed, 59 insertions(+), 25 deletions(-)

diff --git a/module/system/foreign/declarative.scm 
b/module/system/foreign/declarative.scm
index 4b9ef02..b6221b3 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -23,12 +23,19 @@
 (use-modules (system foreign))
 
 (define-record-type <foreign-type>
-  (%make-foreign-type name encode-proc decode-proc type clone-proc free-proc)
+  (%make-foreign-type name
+                      encode-proc
+                      decode-proc
+                      type
+                      predicate-proc
+                      clone-proc
+                      free-proc)
   foreign-type?
   (name ft-name)
   (encode-proc ft-encode-proc)
   (decode-proc ft-decode-proc)
   (type ft-type)
+  (predicate-proc ft-predicate-proc)
   (clone-proc ft-clone-proc)
   (free-proc ft-free-proc))
 
@@ -41,6 +48,7 @@
                             encode-proc
                             decode-proc
                             (type '*)
+                            (predicate-proc (lambda (x) #t))
                             clone-proc
                             free-proc)
   (define-syntax-rule (default <arg> <def>)
@@ -55,40 +63,49 @@
   (default-unavailable decode-proc)
   (default-identity clone-proc)
   (default-identity free-proc)
-  (%make-foreign-type name encode-proc decode-proc type clone-proc free-proc))
+  (%make-foreign-type name
+                      encode-proc
+                      decode-proc
+                      type
+                      predicate-proc
+                      clone-proc
+                      free-proc))
 
 (define-syntax-rule (define-foreign-type name args ...)
   (define-public name (make-foreign-type 'name args ...)))
 
 (define-syntax mirror-primitive-type
   (lambda (x)
-    (syntax-case x ()
-      ((_ prim ft)
+    (syntax-case x (<?>)
+      ((_ prim <?> pred)
+       (with-syntax
+           ((ft (datum->syntax x (symbol-append (syntax->datum #'prim) ':))))
+         #'(mirror-primitive-type prim ft #:predicate-proc pred)))
+      ((_ prim ft rest* ...)
        #'(define-foreign-type ft
            #:encode-proc (lambda (x) x)
            #:decode-proc (lambda (x) x)
-           #:type prim))
-      ((_ prim)
-       (with-syntax
-           ((ft (datum->syntax x (symbol-append (syntax->datum #'prim) ':))))
-         #'(mirror-primitive-type prim ft))))))
+           #:type prim
+           rest* ...)))))
 
-(mirror-primitive-type void)
-(mirror-primitive-type size_t)
-(mirror-primitive-type int)
-(mirror-primitive-type long)
-(mirror-primitive-type ptrdiff_t)
-(mirror-primitive-type int8)
-(mirror-primitive-type int16)
-(mirror-primitive-type int32)
-(mirror-primitive-type int64)
-(mirror-primitive-type uint8)
-(mirror-primitive-type uint16)
-(mirror-primitive-type uint32)
-(mirror-primitive-type uint64)
-(mirror-primitive-type float)
-(mirror-primitive-type double)
-(mirror-primitive-type '* *:)
+(define-foreign-type void:
+  #:decode-proc (lambda (x) x)
+  #:type void)
+(mirror-primitive-type size_t    <?> integer?)
+(mirror-primitive-type int       <?> integer?)
+(mirror-primitive-type long      <?> integer?)
+(mirror-primitive-type ptrdiff_t <?> integer?)
+(mirror-primitive-type int8      <?> integer?)
+(mirror-primitive-type int16     <?> integer?)
+(mirror-primitive-type int32     <?> integer?)
+(mirror-primitive-type int64     <?> integer?)
+(mirror-primitive-type uint8     <?> integer?)
+(mirror-primitive-type uint16    <?> integer?)
+(mirror-primitive-type uint32    <?> integer?)
+(mirror-primitive-type uint64    <?> integer?)
+(mirror-primitive-type float     <?> real?)
+(mirror-primitive-type double    <?> real?)
+(mirror-primitive-type '* *: #:predicate-proc pointer?)
 
 (define-record-type <foreign-argument>
   (%make-foreign-argument type)
@@ -130,4 +147,12 @@
           (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)))) ...
+
          (backend-function arg-name ...))))))
diff --git a/test-suite/tests/foreign-declarative.test 
b/test-suite/tests/foreign-declarative.test
index 8353ff5..fd3a470 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -49,3 +49,12 @@
 (with-test-prefix "trivial foreign functions"
   (pass-if "sin is correct"
     (equal? (sin 10.0) (c-sin 10.0))))
+
+(with-test-prefix "wrong usage"
+  (pass-if "wrong arg contains function name"
+    (equal?
+     #t (catch 'wrong-type-arg
+          (lambda ()
+            (c-sin "string, not number"))
+          (lambda (key function-name . rest)
+            (eq? function-name 'c-sin))))))
-- 
I may be not subscribed. Please, keep me in carbon copy.