add extra tests and fix temporary generation for renaming

4 files changed, 95 insertions, 27 deletions

diff --git a/multisyntax/pattern/producer.scm b/multisyntax/pattern/producer.scm
index ef033c9..93d6221 100644
--- a/multisyntax/pattern/producer.scm
+++ b/multisyntax/pattern/producer.scm
@@ -104,16 +104,19 @@
 (define (rewrite/temporaries pattern bindings)
   ;; Rewrite `pattern` such that all pattern-bound identifiers occur in
   ;; `pattern` at most once.
-  (define appearances (set bound-identifier-comparator))
+  (define appearances (hashmap bound-identifier-comparator))
   (define (add-appearance! id)
-    (set! appearances (set-adjoin appearances id)))
+    (set! appearances (hashmap-adjoin appearances id '())))
   (define (appears? id)
-    (set-contains? appearances id))
+    (hashmap-contains? appearances id))
   (define (add-temporary! id)
-    (let ((new (generate-identifier (syntax->datum id))))
-      (set! bindings (hashmap-adjoin bindings
-                                     new
-                                     (hashmap-ref bindings id)))
+    (let ((old (hashmap-ref bindings id))
+          (new (generate-identifier (syntax->datum id))))
+      (set! bindings (hashmap-adjoin bindings new old))
+      (set! appearances (hashmap-update appearances
+                                        id
+                                        (lambda (cdr)
+                                          (cons new cdr))))
       new))
   (define (rewrite pattern)
     (let ((pattern (unwrap-syntax pattern)))
@@ -126,12 +129,12 @@
         ((actual-ellipsis? pattern) pattern)
         ((and (identifier? pattern) (appears? pattern))
          (add-temporary! pattern))
-        ((identifier? pattern)
+        ((and (identifier? pattern) (hashmap-contains? bindings pattern))
          (add-appearance! pattern)
          pattern)
         (else pattern))))
   (let ((pattern (rewrite pattern)))
-    (values pattern bindings)))
+    (values pattern bindings appearances)))
 
 (define bindings
   ;; Mapping bound identifiers to their real nesting level.
@@ -139,6 +142,32 @@
 
 (define all-bindings (make-parameter #f))
 
+(define (copy-bindings bindings appearances)
+  ;; Appearances is a map from identifiers to generated identifiers. Each
+  ;; generated identifier must inherit the bindings of the key.
+  (hashmap-fold
+   (lambda (copy-from copy-to-list bindings)
+     (let ((copy-from (hashmap-ref bindings copy-from)))
+       (fold (lambda (copy-to bindings)
+               (hashmap-adjoin bindings copy-to copy-from))
+             bindings
+             copy-to-list)))
+   bindings
+   appearances))
+
+(define (compile/rewrite pattern %bindings)
+  (let-values (((pattern %bindings rebindings)
+                (rewrite/temporaries pattern %bindings)))
+    (parameterize ((bindings %bindings))
+      (let-values (((producer open-bindings)
+                    (compile pattern)))
+        (if (not (hashmap-empty? open-bindings))
+            (error "pattern not closed" pattern)
+            (lambda (bindings)
+              (let ((bindings (copy-bindings bindings rebindings)))
+                (parameterize ((all-bindings bindings))
+                  (producer bindings)))))))))
+
 (define compile-producer
   ;; Enty point into the producer compiler.
   ;; 
@@ -148,18 +177,12 @@
     ((literals pattern %bindings)
      (compile-producer literals pattern %bindings #f))
     ((literals pattern %bindings ellipsis)
+     ;; This part is parameterized outside of the second parameterization
+     ;; in `compile/rewrite` because the rewriter requires access to the
+     ;; literal and ellipsis procedures, which are activated by `matcher-input`.
      (parameterize ((matcher-input (vector ellipsis literals))
                     (disable-ellipsis? #f))
-       (let-values (((pattern %bindings)
-                     (rewrite/temporaries pattern %bindings)))
-         (parameterize ((bindings %bindings))
-           (let-values (((producer open-bindings)
-                         (compile pattern)))
-             (if (not (hashmap-empty? open-bindings))
-                 (error "pattern not closed" pattern)
-                 (lambda (bindings)
-                   (parameterize ((all-bindings bindings))
-                     (producer bindings)))))))))))
+       (compile/rewrite pattern %bindings)))))
 
 (define (compile pattern)
   ;; Returns a procedure that will produce `pattern` given the bindings.
diff --git a/multisyntax/pattern/producer.sld b/multisyntax/pattern/producer.sld
index dadc766..e8266e6 100644
--- a/multisyntax/pattern/producer.sld
+++ b/multisyntax/pattern/producer.sld
@@ -15,7 +15,7 @@
 
 (define-library (multisyntax pattern producer)
   (import (scheme base) (scheme write) (scheme case-lambda)
-          (srfi 26) (srfi 111) (srfi 113) (srfi 146 hash) (srfi 158)
+          (srfi 1) (srfi 26) (srfi 111) (srfi 113) (srfi 146 hash) (srfi 158)
           (srfi 197)
           (multisyntax utils) (multisyntax pattern internal)
           (only (multisyntax syntax-object)
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index 1324182..c55b4e1 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -269,14 +269,21 @@
   ;; previous identifier.
   (case-lambda
     (() (generate-identifier (generate-unique-symbol)))
-    ((symbol) (raw-wrap symbol
-                        (set timestamp-comparator (generate-unique-integer))
-                        (mapping environment-key-comparator)
-                        (mapping environment-key-comparator)))))
+    ((symbol)
+     (when (not (symbol? symbol))
+       (error "generate-symbol requires symbol" symbol))
+     (raw-wrap symbol
+               (set timestamp-comparator (generate-unique-integer))
+               (mapping environment-key-comparator)
+               (mapping environment-key-comparator)))))
 
 (define (generate-temporaries lst)
   ;; Generate a list of identifiers from `generate-identifier`.
-  (map generate-identifier lst))
+  (let loop ((lst (unwrap-syntax lst))
+             (acc '()))
+    (if (null? lst)
+        '()
+        (loop (unwrap-syntax (cdr list)) (cons (generate-identifier) acc)))))
 
 (define (symbolic-identifier=? id1 id2)
   ;; Returns true if the underlying symbol of each identifier is the same.
@@ -342,7 +349,7 @@
     ((pair? stx) (cons (syntax->datum (car stx))
                        (syntax->datum (cdr stx))))
     ((vector? stx) (vector-map syntax->datum stx))
-    ((wrap? stx) (wrap->expr stx))
+    ((wrap? stx) (syntax->datum (wrap->expr stx)))
     (else stx)))
 
 (define (if-contains-wrap operate obj)
diff --git a/test/pattern/producer.scm b/test/pattern/producer.scm
index 714a7e3..e7b9f20 100644
--- a/test/pattern/producer.scm
+++ b/test/pattern/producer.scm
@@ -107,7 +107,45 @@
                           ((3 2) 200)
                           ((1 0) 100))
                          900 800 700 600)
-                  got))))
+                  got)))
+  (test-group "repetition of self-syntax"
+    (let ((producer (compile-producer
+                     '()
+                     (list (list (empty-wrap 'x) 10) (empty-wrap '...))
+                     (idmap (empty-wrap 'x) 1))))
+      (test-equal '((1 10) (2 10) (3 10))
+                  (producer (idmap (empty-wrap 'x) '(3 2 1))))))
+  (test-group "multiple uses of the same identifier"
+    (let ((producer (compile-producer
+                     '()
+                     (list (list (empty-wrap 'x) (empty-wrap '...))
+                           (list (empty-wrap 'x) (empty-wrap '...)))
+                     (idmap (empty-wrap 'x) 1))))
+      (test-equal '((1 2 3) (1 2 3))
+                  (producer (idmap (empty-wrap 'x) '(3 2 1))))))
+  (test-group "excess ellipses"
+    (let ((producer (compile-producer
+                     '()
+                     (list (list (list (empty-wrap 'x) (empty-wrap '...))
+                                 (empty-wrap 'y))
+                           (empty-wrap '...))
+                     (idmap (empty-wrap 'x) 1
+                            (empty-wrap 'y) 1))))
+      (test-equal '(((1 2 3) 10) ((1 2 3) 20) ((1 2 3) 30))
+                  (producer (idmap (empty-wrap 'x) '(3 2 1)
+                                   (empty-wrap 'y) '(30 20 10))))))
+  (test-group "(test2 (1 2) (3 4))"
+    ;; I don't know what the "correct" response for this is, but this
+    ;; should emulate Chez's output.
+    (let* ((pat
+            (list (list (list (empty-wrap 'x)
+                             (list (empty-wrap 'x) (empty-wrap '...)))
+                       (empty-wrap '...))
+                  (empty-wrap '...)))
+           (producer (compile-producer '() pat (idmap (empty-wrap 'x) 2))))
+      (test-equal '(((1 (1 2)) (2 (3 4))) ((3 (1 2)) (4 (3 4))))
+                  (producer (idmap (empty-wrap 'x)
+                                   '((4 3) (2 1))))))))
 
 (define (test-producers)
   (test-group "producers"