add support for multiple ellipses in a sequence in producers

Adopts behavior such that

    x ... ... => {append ((x ...) ...}
    x ... ... ... => {append {append (((x ...) ...) ...)}}

where `{append ...}` occurs at the meta-level after expanding the
patterns. (In the code this is done with an accumulator.)

2 files changed, 35 insertions, 17 deletions

diff --git a/multisyntax/pattern/producer.scm b/multisyntax/pattern/producer.scm
index 3fcfb52..9c652b4 100644
--- a/multisyntax/pattern/producer.scm
+++ b/multisyntax/pattern/producer.scm
@@ -314,13 +314,20 @@
     ;;     x ... ... => {append ((x ...) ...)}
     ;;     x ... ... ... => {append {append (((x ...) ...) ...)}}
     ;; and so on where `append` is meta-level.
-    (values (lambda (bindings)
-              (do ((iterated (open-bindings open-identifiers bindings)
-                             (next-binding iterated))
-                   (patterns (list-accumulator)))
-                  ((bindings-finished? iterated)
-                   (patterns (eof-object)))
-                (let ((subbindings (union/current-bindings bindings
-                                                           iterated)))
-                  (patterns (produce-part subbindings)))))
-            open-identifiers-to-return)))
+    (letrec ((iterate
+              (lambda (bindings acc level)
+                (if (= level number-of-ellipses)
+                    (acc (produce-part bindings))
+                    (do ((iterated (open-bindings open-identifiers bindings)
+                                   (next-binding iterated)))
+                        ((bindings-finished? iterated))
+                      (let ((subbindings (union/current-bindings bindings
+                                                                 iterated)))
+                        (iterate subbindings
+                                 acc
+                                 (+ level 1))))))))
+      (values (lambda (bindings)
+                (let ((patterns (list-accumulator)))
+                  (iterate bindings patterns 0)
+                  (patterns (eof-object))))
+              open-identifiers-to-return))))
diff --git a/test/pattern/producer.scm b/test/pattern/producer.scm
index 86de709..14c130d 100644
--- a/test/pattern/producer.scm
+++ b/test/pattern/producer.scm
@@ -14,7 +14,7 @@
  |#
 
 (define (test-producers)
-  #;(let ((producer
+  (let ((producer
            (compile-producer '()
                              (list (empty-wrap 'x) (empty-wrap '...))
                              (hashmap bound-identifier-comparator
@@ -23,17 +23,28 @@
       (test-equal "produces x = '(5 4 3 2 1)"
                   '(1 2 3 4 5)
                   (producer (hashmap bound-identifier-comparator
-                                   (empty-wrap 'x)
-                                   '(5 4 3 2 1)))))
+                                     (empty-wrap 'x)
+                                     '(5 4 3 2 1)))))
+  (let ((producer
+           (compile-producer '()
+                             (list (list (empty-wrap 'x) (empty-wrap '...))
+                                   (empty-wrap '...))
+                             (hashmap bound-identifier-comparator
+                                      (empty-wrap 'x)
+                                      2))))
+      (test-equal "double ellipsis"
+                  '((1 2) (3 4) (5 6) (7 8))
+                  (producer (hashmap bound-identifier-comparator
+                                     (empty-wrap 'x)
+                                     '((8 7) (6 5) (4 3) (2 1))))))
   (let ((producer
          (compile-producer '()
-                           (list (list (empty-wrap 'x) (empty-wrap '...))
-                                 (empty-wrap '...))
+                           (list (empty-wrap 'x) (empty-wrap '...) (empty-wrap '...))
                            (hashmap bound-identifier-comparator
                                     (empty-wrap 'x)
                                     2))))
-    (test-equal "double ellipsis"
-                '((1 2) (3 4) (5 6) (7 8))
+    (test-equal "appended double ellipsis"
+                '(1 2 3 4 5 6 7 8)
                 (producer (hashmap bound-identifier-comparator
                                    (empty-wrap 'x)
                                    '((8 7) (6 5) (4 3) (2 1)))))))