[PATCH 15/25] New macro: with-pointer

[KAction]

From: Dmitry Bogatov <address@hidden>

  * 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.