[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 15/25] New macro: with-pointer
From: |
KAction |
Subject: |
[PATCH 15/25] New macro: with-pointer |
Date: |
Mon, 18 Jul 2016 18:17:38 +0300 |
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.
- [PATCH 05/25] Fix bug in `default' macro, (continued)
- [PATCH 05/25] Fix bug in `default' macro, KAction, 2016/07/18
- [PATCH 06/25] Basic implementation of `define-foreign-function', KAction, 2016/07/18
- [PATCH 07/25] Introduce foreign-type predicates, KAction, 2016/07/18
- [PATCH 08/25] Add keywords for `define-foreign-function' macro, KAction, 2016/07/18
- [PATCH 10/25] Refactor type validation in `define-foreign-function', KAction, 2016/07/18
- [PATCH 09/25] system/foreign/declarative: rename `predicate' to `validate', KAction, 2016/07/18
- [PATCH 11/25] system/foreign/declarative: new macro, KAction, 2016/07/18
- [PATCH 13/25] system/foreign/declarative.scm: export string foreign type, KAction, 2016/07/18
- [PATCH 12/25] Improve deriving c symbol name from scheme one, KAction, 2016/07/18
- [PATCH 14/25] foreign/declarative: mirror more primitive types, KAction, 2016/07/18
- [PATCH 15/25] New macro: with-pointer,
KAction <=
- [PATCH 16/25] Configure emacs file-local indention, KAction, 2016/07/18
- [PATCH 17/25] system/foreign/declarative: unexport internal macro, KAction, 2016/07/18
- [PATCH 18/25] write documentation for (system foreign declarative), KAction, 2016/07/18
[PATCH 20/25] Document with-pointer macro, KAction, 2016/07/18
[PATCH 19/25] Document define-foreign-bitmask macro, KAction, 2016/07/18
[PATCH 21/25] new module: (ice-9 xattr), KAction, 2016/07/18