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