[PATCH 11/25] system/foreign/declarative: new macro

[KAction]

From: Dmitry Bogatov <address@hidden>

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