From: Dmitry Bogatov <kact...@gnu.org>
* module/system/foreign/declarative.scm: new macro
`define-foreign-bitmask' that defines `foreign-type' for bitmask,
with proper encoding, decoding and validation.
---
module/system/foreign/declarative.scm | 46 +++++++++++++++++++++++++++++++
test-suite/tests/foreign-declarative.test | 38 ++++++++++++++++++++++---
2 files changed, 80 insertions(+), 4 deletions(-)
diff --git a/module/system/foreign/declarative.scm
b/module/system/foreign/declarative.scm
index fb949db..b0c31a0 100644
--- a/module/system/foreign/declarative.scm
+++ b/module/system/foreign/declarative.scm
@@ -174,3 +174,49 @@
(set-procedure-property! frontend-function 'name 'function-name)
frontend-function))))))
+(define* (make-foreign-bitmask name #:rest flags)
+ (define-syntax-rule (filter-map-flags (symbol value) stmt stmt* ...)
+ (filter-map (lambda (flag)
+ (match flag
+ ((symbol . value) stmt stmt* ...)))
+ flags))
+ (define (encode-proc obj)
+ (unless (list? obj)
+ (set! obj (list obj)))
+ (apply logior
+ (filter-map-flags (symbol value)
+ (and (member symbol obj)
+ value))))
+ (define (decode-proc int)
+ (filter-map-flags (symbol value)
+ (and (not (zero? (logand int value)))
+ symbol)))
+ (define symbols (map car flags))
+ (define (validate-proc obj)
+ (define (allowed-symbol? x)
+ (member x symbols))
+ (define correct-symbol? (and (symbol? obj)
+ (allowed-symbol? obj)))
+ (define correct-list? (and (list? obj)
+ (every allowed-symbol? obj)))
+ (unless (or correct-list? correct-symbol?)
+ (throw
+ 'wrong-type-arg
+ (*validate-function-name*)
+ "Wrong type argument named `~A'\
+ (expected `~A' bitmask: symbol or list of symbols from ~A): ~S"
+ (list (*validate-argument-name*) name symbols obj)))
+ #t)
+ (make-foreign-type name
+ #:encode-proc encode-proc
+ #:decode-proc decode-proc
+ #:type int
+ #:validate-proc validate-proc))
+
+(export define-foreign-bitmask)
+(define-syntax-rule (define-foreign-bitmask name ((symbol value) ...))
+ (define name (make-foreign-bitmask 'name '(symbol . value) ...)))
+
+;; 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 cf285d4..450c653 100644
--- a/test-suite/tests/foreign-declarative.test
+++ b/test-suite/tests/foreign-declarative.test
@@ -22,10 +22,11 @@
#:use-module (system foreign)
#:use-module (system foreign declarative))
-(define ft-encode-proc (@@ (system foreign declarative) ft-encode-proc))
-(define ft-decode-proc (@@ (system foreign declarative) ft-decode-proc))
-(define ft-clone-proc (@@ (system foreign declarative) ft-clone-proc))
-(define ft-free-proc (@@ (system foreign declarative) ft-free-proc))
+(define ft-encode-proc (@@ (system foreign declarative) ft-encode-proc))
+(define ft-decode-proc (@@ (system foreign declarative) ft-decode-proc))
+(define ft-clone-proc (@@ (system foreign declarative) ft-clone-proc))
+(define ft-validate-proc (@@ (system foreign declarative) ft-validate-proc))
+(define ft-free-proc (@@ (system foreign declarative) ft-free-proc))
(with-test-prefix "foreign-type primitives"
(pass-if "int: encoder is identity"
@@ -61,3 +62,32 @@
(c-sin "string, not number"))
(lambda (key function-name . rest)
(eq? function-name 'c-sin))))))
+
+(define-foreign-bitmask file-permissions:
+ ((read 4) (write 2) (execute 1)))
+
+(with-test-prefix "bitmasks"
+ (pass-if "correctly encodes"
+ (equal? 7 ((ft-encode-proc file-permissions:) '(read write execute))))
+ (pass-if "correctly decodes"
+ (equal? '(read write) ((ft-decode-proc file-permissions:) 6)))
+ (pass-if "validator accepts valid values [1]"
+ ((ft-validate-proc file-permissions:) 'write))
+ (pass-if "validator accepts valid values [2]"
+ ((ft-validate-proc file-permissions:) '(read execute)))
+ (pass-if "validator rejects bogus symbol"
+ (equal?
+ (catch 'wrong-type-arg
+ (lambda ()
+ ((ft-validate-proc file-permissions:) 'bogus)
+ #f)
+ (lambda _args
+ #t))))
+ (pass-if "validator rejects bogus value in list"
+ (equal?
+ (catch 'wrong-type-arg
+ (lambda ()
+ ((ft-validate-proc file-permissions:) '(read write 15))
+ #f)
+ (lambda _args
+ #t)))))
--
I may be not subscribed. Please, keep me in carbon copy.
