From: Dmitry Bogatov <kact...@gnu.org> * module/system/foreign/declarative.scm: macro 'with-pointer' simplifies work with input-output and input arguments to C functions. * test-suite/tests/foreign-declarative.test: test 'with-pointer' macro by time(2) function. Value returned via pointer must be equal to value, returned by function itself. --- module/system/foreign/declarative.scm | 97 +++++++++++++++++++++++++++++++ test-suite/tests/foreign-declarative.test | 9 +++ 2 files changed, 106 insertions(+)
diff --git a/module/system/foreign/declarative.scm b/module/system/foreign/declarative.scm index 3dd28d4..66d35a8 100644 --- a/module/system/foreign/declarative.scm +++ b/module/system/foreign/declarative.scm @@ -21,6 +21,7 @@ (use-modules (srfi srfi-9)) (use-modules (ice-9 match)) (use-modules (ice-9 optargs)) +(use-modules (rnrs bytevectors)) (use-modules (system foreign)) (define-record-type <foreign-type> @@ -232,6 +233,102 @@ (define-syntax-rule (define-foreign-bitmask name ((symbol value) ...)) (define name (make-foreign-bitmask 'name '(symbol . value) ...))) + +(define (default-primitive-value prim-type) + (if (eq? prim-type '*) + %null-pointer + 0)) + +;; Call `producer' procedure with single argument -- pointer to +;; value of `type', that have specified, or some default `value'. +;; After that `consumer' is called with two arguments -- value, +;; decoded from mentioned pointer and value, returned by 'producer'. +;; +;; 'call-with-pointer' returns value, returned by 'consumer'. +;; +;; If value is specified, it is assumed to be already validated, +;; since at this stage we do not have information about identifier, +;; bound to this value, and can not provide informational error +;; message anyway. +(define* (call-with-pointer type producer consumer + #:key + (value *unspecified*)) + (let* ((prim-type (ft-type type)) + (prim-value (if (unspecified? value) + (default-primitive-value prim-type) + ((ft-encode-proc type) value))) + (pointer (make-c-struct (list prim-type) (list prim-value))) + (producer-result (producer pointer)) + (new-prim-value (car (parse-c-struct pointer (list prim-type)))) + (new-value ((ft-decode-proc type) new-prim-value))) + (consumer new-value producer-result))) + +;; If 'mem' is integer, pass pointer to 'mem' bytes to 'producer', +;; and then call 'consumer' with two arguments -- memory as bytevector +;; and value, returned by producer. +;; +;; If 'mem' is bytevector memory is not allocated, but is aliased to +;; that bytevector. +(define (call-with-memory mem producer consumer) + (let* ((bv (if (bytevector? mem) + mem + (make-bytevector mem))) + (pointer (bytevector->pointer bv)) + (producer-result (producer pointer))) + (consumer bv producer-result))) + +(eval-when (compile load eval) + (define (with-pointer/get-name x) + (syntax-case x (= *-->) + ((type name = value) + #'name) + ((type name) + #'name) + ((name *--> mem) + #'name)))) + +(define-syntax with-pointer/names + (lambda (x) + (syntax-case x () + ((_ %it (c ...) stmt stmt* ...) + (with-syntax (((n ...) (map with-pointer/get-name #'(c ...)))) + #'(lambda (n ... %it) stmt stmt* ...)))))) + +;; The innermost call-with-* function consumer should be list, +;; other -- cons. +(define-syntax with-pointer/concat + (syntax-rules () + ((_) list) + ((_ c c* ...) cons))) + +(define-syntax %with-pointer + (syntax-rules (= *-->) + ((_ () expr) + expr) + ((_ ((type name = value) c ...) expr) + (call-with-pointer type + (lambda (name) (%with-pointer (c ...) expr)) + (with-pointer/concat c ...) + #:value value)) + ((_ ((type name) c ...) expr) + (%with-pointer ((type name = *unspecified*) c ...) expr)) + ((_ ((name *--> mem) c ...) expr) + (call-with-memory mem + (lambda (name) (%with-pointer (c ...) expr)) + (with-pointer/concat c ...))) + ((_ (c ...) (%it = expr) stmt stmt* ...) + (apply (with-pointer/names %it (c ...) stmt stmt* ...) + (%with-pointer (c ...) expr))) + ((_ (c ...) expr stmt stmt* ...) + (%with-pointer (c ...) (_ignore = expr) stmt stmt* ...)))) + +;; This is the only form end-user should be able to use. Everything +;; else -- volatile implementation detail. +(define-syntax-rule (with-pointer (c ...) expr stmt stmt* ...) + (%with-pointer (c ...) expr stmt stmt* ...)) +(export with-pointer) +(export %with-pointer) + ;; Local Variables: ;; eval: (put (quote filter-map-flags) (quote scheme-indent-function) 1) ;; End: diff --git a/test-suite/tests/foreign-declarative.test b/test-suite/tests/foreign-declarative.test index 450c653..90f05ec 100644 --- a/test-suite/tests/foreign-declarative.test +++ b/test-suite/tests/foreign-declarative.test @@ -91,3 +91,12 @@ #f) (lambda _args #t))))) + +;; FIXME: We need some more robust way to know type +;; of time_t. +(define-foreign-function c-time ((*: t)) :: unsigned-long:) +(with-test-prefix "with-pointer" + (pass-if "time(2)" + (with-pointer ((unsigned-long: t)) + (%it = (c-time t)) + (eqv? t %it)))) -- I may be not subscribed. Please, keep me in carbon copy.