define-fixture: Eliminate need to provide names for get-attr etc

This needed some rearranging, but I think the resulting code is a little
bit more efficient.

1 files changed, 7 insertions, 28 deletions

diff --git a/guile/starlet/fixture.scm b/guile/starlet/fixture.scm
index c6a6edf..8aaccc4 100644
--- a/guile/starlet/fixture.scm
+++ b/guile/starlet/fixture.scm
@@ -31,18 +31,18 @@
             get-fixture-attrs
             find-attr
             fixture?
-            scanout-fixture
 
             attr-continuous
             attr-list
             attr-colour
+            define-fixture
+
             get-attr-type
             get-attr-range
             get-attr-home-val
             continuous-attribute?
             colour-attribute?
-            intensity?
-            define-fixture))
+            intensity?))
 
 
 (define-class <fixture-attribute> (<object>)
@@ -97,9 +97,6 @@
     #:getter get-scanout-func))
 
 
-(define-generic scanout-fixture)
-
-
 (define-syntax attr-continuous
   (syntax-rules ()
     ((_ attr-name attr-range attr-home-value)
@@ -183,32 +180,14 @@
 
 
 (define-syntax define-fixture
-  (syntax-rules ()
-
-    ((_ classname
-        attrs
-        (get-attr set-chan8)
-        scanout-code ...)
-
-     (begin
-       (define-class classname (<fixture>)
-         (attributes #:init-form attrs))
-
-       (define-method (scanout-fixture (fixture classname)
-                                       get-attr set-chan8 dummy)
-
-         scanout-code ...)))
+  (syntax-rules (fixture-attributes)
 
     ((_ classname
-        attrs
-        (get-attr set-chan8 set-chan16)
+        (fixture-attributes attr ...)
         scanout-code ...)
 
      (begin
        (define-class classname (<fixture>)
-         (attributes #:init-form attrs))
-
-       (define-method (scanout-fixture (fixture classname)
-                                       get-attr set-chan8 set-chan16)
-
+         (attributes #:init-form (list attr ...)))
+       (define-method (scanout-fixture (fixture classname))
          scanout-code ...)))))