Add ellipsis escape form

`(... <template>)` in R6RS+ will escape a single form of ellipses in
the production. I personally do not recommend this: overriding the
ellipsis with a new identifier is the better approach in all circumstances.

5 files changed, 77 insertions, 40 deletions

diff --git a/multisyntax/pattern/internal.scm b/multisyntax/pattern/internal.scm
index dd6b5b4..68e88f0 100644
--- a/multisyntax/pattern/internal.scm
+++ b/multisyntax/pattern/internal.scm
@@ -98,13 +98,21 @@
     (make-parameter #f transformer)))
 
 (define (ellipsis-procedure)
+  ;; Returns the predicate that will check if its first argument is the
+  ;; ellipsis identifier.
   (vector-ref (matcher-input) 0))
 
-(define (literals) (vector-ref (matcher-input) 1))
+(define (literals)
+  ;; Returns the set of literals in dynamic scope.
+  (vector-ref (matcher-input) 1))
+
+(define disable-ellipsis? (make-parameter #f))
 
 (define (actual-ellipsis? identifier)
   ;; Returns `#t` if `id` is an ellipsis, and `#f` otherwise.
-  ((ellipsis-procedure) identifier))
+  (if (disable-ellipsis?)
+      #f
+      ((ellipsis-procedure) identifier)))
 
 (define (is-ellipsis-list patcdr)
   ;; Returns (values has-ellipsis? next). `has-ellipsis?` is true if the
diff --git a/multisyntax/pattern/internal.sld b/multisyntax/pattern/internal.sld
index e81551d..dc4ddd4 100644
--- a/multisyntax/pattern/internal.sld
+++ b/multisyntax/pattern/internal.sld
@@ -19,5 +19,5 @@
   (import (scheme base) (srfi 113) (srfi 146 hash)
           (multisyntax syntax-object))
   (export matcher-input is-ellipsis-list actual-ellipsis? literal?
-          empty-map)
+          empty-map disable-ellipsis?)
   (include "internal.scm"))
diff --git a/multisyntax/pattern/matcher.scm b/multisyntax/pattern/matcher.scm
index 52e58b8..a291e13 100644
--- a/multisyntax/pattern/matcher.scm
+++ b/multisyntax/pattern/matcher.scm
@@ -148,7 +148,8 @@
         (outer-ellipsis-group (ellipsis-group)))
     (parameterize ((nesting-level (+ (nesting-level) 1))
                    (bound-here (box (empty-map)))
-                   (ellipsis-group (generate-unique-integer)))
+                   (ellipsis-group (generate-unique-integer))
+                   (disable-ellipsis? #f))
       (when outer-ellipsis-group
         (set-parameter! ellipsis-group-map
                         (cute hashmap-update!/default
diff --git a/multisyntax/pattern/producer.scm b/multisyntax/pattern/producer.scm
index 9c652b4..ef033c9 100644
--- a/multisyntax/pattern/producer.scm
+++ b/multisyntax/pattern/producer.scm
@@ -148,7 +148,8 @@
     ((literals pattern %bindings)
      (compile-producer literals pattern %bindings #f))
     ((literals pattern %bindings ellipsis)
-     (parameterize ((matcher-input (vector ellipsis literals)))
+     (parameterize ((matcher-input (vector ellipsis literals))
+                    (disable-ellipsis? #f))
        (let-values (((pattern %bindings)
                      (rewrite/temporaries pattern %bindings)))
          (parameterize ((bindings %bindings))
@@ -177,11 +178,15 @@
        (values (lambda (bindings) pattern)
                (empty-map)))
       ((and (identifier? pattern)
-            (hashmap-contains? (bindings) pattern))
-       ;; Return 0 as the PNL of this identifier, because all identifiers
-       ;; have a PNL of 0 to themselves.
-       (values (lambda (bindings) (hashmap-ref bindings pattern))
-               (hashmap bound-identifier-comparator pattern 0)))
+            (hashmap-ref/default (bindings) pattern #f))
+       =>
+       (lambda (PNL)
+         (let ((returned (if (zero? PNL)
+                             (empty-map)
+                             (hashmap bound-identifier-comparator pattern 0))))
+           (values (lambda (bindings)
+                     (hashmap-ref bindings pattern))
+                   returned))))
       ((identifier? pattern)
        (values (lambda (bindings) pattern) (empty-map)))
       (else (error "not syntax" pattern)))))
@@ -196,7 +201,6 @@
   (let loop ((i 0)
              (patcdr patcdr))
     (cond
-      ((null? patcdr) (values i patcdr))
       ((not (pair? patcdr)) (values i patcdr))
       (else
        (let ((patcar (unwrap-syntax (car patcdr))))
@@ -205,10 +209,23 @@
              (values i patcdr)))))))
 
 (define (compile-pair patcar patcdr)
+  (cond
+    ((actual-ellipsis? patcar)
+     (if (not (pair? patcdr))
+         (error "not a pair" patcdr)
+         (let ((patcddr (unwrap-syntax (cdr patcdr)))
+               (patcadr (unwrap-syntax (car patcdr))))
+           (if (not (null? patcddr))
+               (error "invalid form of (... <template>)" patcar patcdr)
+               (parameterize ((disable-ellipsis? #t))
+                 (compile patcadr))))))
+    (else (compile-regular-pair patcar patcdr))))
+
+(define (compile-regular-pair patcar patcdr)
   (let*-values (((number-of-ellipses next) (list-of-ellipses patcdr))
                 ((produce-next open-identifiers-next) (compile next)))
     (if (zero? number-of-ellipses)
-        (let-values (((produce-car open-identifiers) (compile next)))
+        (let-values (((produce-car open-identifiers) (compile patcar)))
           (values
            (lambda (bindings)
              (cons (produce-car bindings) (produce-next bindings)))
@@ -309,11 +326,6 @@
                  (hashmap-remove will-be-closed? open-identifiers)))
     (when (hashmap-empty? open-identifiers)
       (error "ellipsis production does not have open identifiers" patcar))
-    ;; TODO: Need to handle the case of sequential ellipses. They are
-    ;; equivalent to
-    ;;     x ... ... => {append ((x ...) ...)}
-    ;;     x ... ... ... => {append {append (((x ...) ...) ...)}}
-    ;; and so on where `append` is meta-level.
     (letrec ((iterate
               (lambda (bindings acc level)
                 (if (= level number-of-ellipses)
diff --git a/test/pattern/producer.scm b/test/pattern/producer.scm
index 14c130d..96d5176 100644
--- a/test/pattern/producer.scm
+++ b/test/pattern/producer.scm
@@ -15,36 +15,52 @@
 
 (define (test-producers)
   (let ((producer
-           (compile-producer '()
-                             (list (empty-wrap 'x) (empty-wrap '...))
-                             (hashmap bound-identifier-comparator
-                                      (empty-wrap 'x)
-                                      1))))
-      (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)))))
+         (compile-producer '()
+                           (list (empty-wrap 'x) (empty-wrap '...))
+                           (hashmap bound-identifier-comparator
+                                    (empty-wrap 'x)
+                                    1))))
+    (test-equal "x ..."
+                '(1 2 3 4 5)
+                (producer (hashmap bound-identifier-comparator
+                                   (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))))))
+         (compile-producer '()
+                           (list (list (empty-wrap 'x) (empty-wrap '...))
+                                 (empty-wrap '...))
+                           (hashmap bound-identifier-comparator
+                                    (empty-wrap 'x)
+                                    2))))
+    (test-equal "(x ...) ..."
+                '((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 (empty-wrap 'x) (empty-wrap '...) (empty-wrap '...))
                            (hashmap bound-identifier-comparator
                                     (empty-wrap 'x)
                                     2))))
-    (test-equal "appended double ellipsis"
+    (test-equal "x ... ..."
                 '(1 2 3 4 5 6 7 8)
                 (producer (hashmap bound-identifier-comparator
                                    (empty-wrap 'x)
-                                   '((8 7) (6 5) (4 3) (2 1)))))))
+                                   '((8 7) (6 5) (4 3) (2 1))))))
+  (test-group "(... (x ...))"
+    (let* ((producer
+            (compile-producer '()
+                              (list (empty-wrap '...) (list (empty-wrap 'x) (empty-wrap '...)))
+                              (hashmap bound-identifier-comparator
+                                       (empty-wrap 'x)
+                                       0)))
+           (got (producer (hashmap bound-identifier-comparator
+                                   (empty-wrap 'x)
+                                   0))))
+      (test-assert "returned a list" (list? got))
+      (test-eqv "returned the correct length"
+                2
+                (length got))
+      (test-eqv "first value is 0" 0 (car got))
+      (test-assert "second value" (bound-identifier=? (cadr got) (empty-wrap '...))))))