Test implementation of patch-many

Unfortunately this doesn't work, due to how Guile handles top-level bindings
introducted by macros.

1 files changed, 69 insertions, 1 deletions

diff --git a/guile/nanolight/fixture.scm b/guile/nanolight/fixture.scm
index 9bfa3d9..226c106 100644
--- a/guile/nanolight/fixture.scm
+++ b/guile/nanolight/fixture.scm
@@ -5,7 +5,7 @@
   #:use-module (web http)
   #:use-module (web uri)
   #:export (<fixture> <fixture-attribute>
-             make-output patch-fixture
+             make-output patch-fixture patch-many
              fixture-string fixture-address-string
              percent->dmxval msb lsb chan
              start-addr universe
@@ -234,3 +234,71 @@
           ((add-fixture) add-fixture)
           (else => (error "Invalid method")))
         (cdr args)))))
+
+
+(define (symbol-append a b)
+  (string->symbol
+   (string-append
+    (symbol->string a)
+    (symbol->string b))))
+
+(define (number->symbol n)
+  (string->symbol
+   (number->string n)))
+
+
+(define-syntax patch-many
+  (lambda (x)
+    (syntax-case x ()
+
+      ;; Base case: count = 0
+      ((_ 0
+          base-label
+          offset
+          base-addr
+          fixture-class
+          universe
+          friendly-name)
+       (and
+        (number? (syntax->datum #'offset))
+        (symbol? (syntax->datum #'base-label)))
+       #'(if #f #f))      ; Return unspecified
+
+      ;; General case: count is a number
+      ((_ count
+          base-label
+          offset
+          base-addr
+          fixture-class
+          universe
+          friendly-name)
+
+       (and
+        (number? (syntax->datum #'count))
+        (number? (syntax->datum #'offset))
+        (symbol? (syntax->datum #'base-label)))
+
+       (let ((make-id (lambda (first second)
+                        (datum->syntax
+                         x
+                         (symbol-append (syntax->datum first)
+                                        (number->symbol
+                                         (syntax->datum second))))))
+             (minus-one (lambda (num)
+                           (- (syntax->datum num) 1)))
+
+             (plus-one (lambda (num)
+                          (+ (syntax->datum num) 1))))
+
+         (with-syntax ((fixture-name (make-id #'base-label #'offset))
+                       (next-count (minus-one #'count))
+                       (next-offset (plus-one #'offset)))
+           #'(begin
+               (define fixture-name 'fixture-name)
+               (patch-many next-count
+                           base-label
+                           next-offset
+                           base-addr
+                           fixture-class
+                           universe
+                           friendly-name))))))))