From: Dmitry Bogatov <kact...@gnu.org> 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.