Fix list ellipses pattern matching

A lot of multisyntax was written to use `unwrap-syntax` deliberately, which I
now see as a mistake. Implict unwrapping using `syntax-cxr` (and maybe variants
like `syntax-vector-ref`) is probably less error prone.

7 files changed, 100 insertions, 36 deletions

diff --git a/multisyntax/examples/untyped-lambda-calculus-prelude.scm b/multisyntax/examples/untyped-lambda-calculus-prelude.scm
index ad9d2a1..95952f4 100644
--- a/multisyntax/examples/untyped-lambda-calculus-prelude.scm
+++ b/multisyntax/examples/untyped-lambda-calculus-prelude.scm
@@ -15,6 +15,35 @@
 
 (define I (lambda x x))
 
+(define-syntax ∘
+  ;; function composition
+  (syntax-rules ()
+    ((∘) I)
+    ((∘ f g ...)
+     (f (∘ g ...)))))
+
+(splicing-let-syntax ((define-syntax* define-syntax))
+  (define-syntax* define-syntax
+    (syntax-rules (let-syntax letrec-syntax)
+      ((_ name (let-syntax bindings body))
+       (splicing-let-syntax bindings
+         (define-syntax name body)))
+      ((_ name (letrec-syntax bindings body))
+       (splicing-letrec-syntax bindings
+         (define-syntax name body)))
+      ((_ name body)
+       (define-syntax* name body)))))
+
+(define-syntax ∘←
+  ;; postfix function composition
+  (let-syntax ((R (syntax-rules ()
+                    ((R () (acc ...))
+                     (∘ acc ...))
+                    ((R (head rest ...) (acc ...))
+                     (R (rest ...) (acc ...))))))
+    (syntax-rules ()
+      ((∘← f ...) (R (f ...) ())))))
+
 (splicing-let-syntax ((lambda lambda))
   ;; This binds `lambda` in the global syntatic environment into a
   ;; local, immutable syntatic environment.
diff --git a/multisyntax/examples/untyped-lambda-calculus.scm b/multisyntax/examples/untyped-lambda-calculus.scm
index 899fe48..9d87d3b 100644
--- a/multisyntax/examples/untyped-lambda-calculus.scm
+++ b/multisyntax/examples/untyped-lambda-calculus.scm
@@ -112,18 +112,21 @@
 (define (is? env stx id)
   ;; Return true if `stx` in `env` is `eq?` to `id`.
   (let ((stx (unwrap-syntax stx)))
-    (and (pair? stx) (identifier? (car stx))
+    (and (pair? stx)
+         (identifier? (car stx))
          (let ((resolved (hashmap-ref/default env (resolve (car stx)) #f)))
            (eq? resolved id)))))
 
 (define (identifier-is-transformer env stx)
   ;; Returns transformer if `stx` is a syntax-rules transformer in `env`.
-  (cond
-    ((not (identifier? (syntax-car stx))) #f)
-    ((hashmap-ref/default env (resolve (syntax-car stx)) #f)
-     => (lambda (return)
-          (and (transformer? return) return)))
-    (else #f)))
+  (let ((stx (unwrap-syntax stx)))
+    (cond
+      ((not (pair? stx)) #f)
+      ((not (identifier? (car stx))) #f)
+      ((hashmap-ref/default env (resolve (car stx)) #f)
+       => (lambda (return)
+            (and (transformer? return) return)))
+      (else #f))))
 
 (define (let-syntax-expander env stx K)
   ;; Continuation-passing-style expansion of `let-syntax`. Expands the
@@ -154,25 +157,29 @@
                          old-names
                          new-names))))
 
-(define (eval-transformer tfmr stx)
+(define (eval-transformer name tfmr stx)
   ;; Try to match each pattern in `tfmr`, and when one matches, call the
   ;; producer on the matched data.
   (let loop ((tfmr (unwrap-syntax-rules tfmr)))
     (if (null? tfmr)
-        (error "no matched pattern" stx tfmr)
+        (error "no matched pattern" name stx tfmr)
         (let ((matcher (caar tfmr))
               (producer (cdar tfmr)))
           (cond
-            ((matcher stx) => producer)
+            ((matcher stx)
+             => (lambda (bindings)
+                  (let ((return (producer bindings)))
+                    return)))
             (else (loop (cdr tfmr))))))))
 
-(define (macro-expand-expander env stx tfmr K)
+(define (macro-expand-expander name env stx tfmr K)
   ;; Evaluate the transformer `tfmr` with `stx`, properly adding and
   ;; removing macro expansion timesteps. Pass the result to `K`, which
   ;; is a function of one argument (not two like the `let-syntax-expander`
   ;; procedures).
   (let ((ts (generate-timestamp)))
-    (K (add-timestamp (eval-transformer tfmr
+    (K (add-timestamp (eval-transformer name
+                                        tfmr
                                         (add-timestamp stx ts))
                       ts))))
 
@@ -203,7 +210,8 @@
        (letrec-syntax-expander env stx expand-expr))
       ((identifier-is-transformer env stx)
        => (lambda (tfmr)
-            (macro-expand-expander env
+            (macro-expand-expander (syntax->datum (syntax-car stx))
+                                   env
                                    stx
                                    tfmr
                                    (lambda (stx)
@@ -231,7 +239,8 @@
                                       (list-ref clause 1)
                                       bindings
                                       ellipsis))))
-  (wrap-syntax-rules (map operate (unwrap-list clauses))))
+  (let ((clauses (unwrap-list clauses)))
+    (wrap-syntax-rules (map operate clauses))))
 
 (define (expand-transformer env stx)
   (let ((stx (unwrap-syntax stx)))
@@ -240,7 +249,8 @@
        (hashmap-ref env (resolve stx) (lambda () (error "transformer not found" stx))))
       ((identifier-is-transformer env stx)
        => (lambda (tfmr)
-            (macro-expand-expander env
+            (macro-expand-expander (syntax->datum (syntax-car stx))
+                                   env
                                    stx
                                    tfmr
                                    (lambda (stx)
@@ -256,6 +266,8 @@
                                   #f
                                   (syntax-cxr '(d a) stx)
                                   (syntax-cxr '(d d) stx)))))
+      ;; TODO: remove these, they are definable in terms of the splicing
+      ;; versions.
       ((is? env stx 'let-syntax)
        (let-syntax-expander env stx expand-transformer))
       ((is? env stx 'letrec-syntax)
@@ -300,12 +312,12 @@
       ((is? env stx 'splicing-letrec-syntax)
        (let*-values (((old-names new-names tfmrs body) (on-bindings stx))
                      ((tfmrs) (map (lambda (stx)
-                                    (expand-transformer env
-                                                        (add-substitution
-                                                         stx
-                                                         old-names
-                                                         new-names)))
-                                  tfmrs)))
+                                     (expand-transformer env
+                                                         (add-substitution
+                                                          stx
+                                                          old-names
+                                                          new-names)))
+                                   tfmrs)))
          (accumulate-splicing globalenv
                               (union-names lexenv new-names tfmrs)
                               body)))
@@ -318,7 +330,8 @@
                              expanded-value)))))
       ((identifier-is-transformer env stx)
        => (lambda (tfmr)
-            (macro-expand-expander env
+            (macro-expand-expander (syntax->datum (syntax-car stx))
+                                   env
                                    stx
                                    tfmr
                                    (lambda (stx)
diff --git a/multisyntax/pattern/internal.scm b/multisyntax/pattern/internal.scm
index 68e88f0..38059c8 100644
--- a/multisyntax/pattern/internal.scm
+++ b/multisyntax/pattern/internal.scm
@@ -50,6 +50,7 @@
       (and (identifier? identifier)
            (free-identifier=? identifier ...))))
   (define matches-passed-ellipsis
+    ;; TODO: probably doesn't work?
     (lambda (identifier)
       (and (identifier? identifier)
            (bound-identifier=? identifier ...))))
diff --git a/multisyntax/pattern/matcher.scm b/multisyntax/pattern/matcher.scm
index a291e13..dc3dfb7 100644
--- a/multisyntax/pattern/matcher.scm
+++ b/multisyntax/pattern/matcher.scm
@@ -272,17 +272,19 @@
   (define match-patcddr (compile patcddr))
   (lambda (names stx)
     (let match* ((names (hashmap-union names default-names))
-                 (stx (unwrap-syntax stx)))
-      (cond
-        ((null? stx) names)
-        ((not (pair? stx)) #f)
-        ((match-patcar (empty-map) (car stx))
-         => (lambda (newnames)
-              (cond
-                ((match* (merge-names names newnames) (cdr stx))
-                 => values)
-                (else (match-patcddr names stx)))))
-        (else (match-patcddr names stx))))))
+                 (stx stx))
+      (let ((stx (unwrap-syntax stx)))
+        (cond
+          ((null? stx) names)
+          ((not (pair? stx)) #f)
+          ((match-patcar (empty-map) (car stx))
+           => (lambda (newnames)
+                (cond
+                  ((match* (merge-names names newnames) (cdr stx))
+                   => (lambda (names)
+                        names))
+                  (else (match-patcddr names stx)))))
+          (else (match-patcddr names stx)))))))
 
 (define (compile-actual-pair patcar patcdr)
   ;; Compile a pair that is not an ellipsis pattern. I.e. match `patcar`
@@ -294,7 +296,8 @@
       (cond
         ((not (pair? stx)) #f)
         ((match-patcar names (car stx))
-         => (cute match-patcdr <> (cdr stx)))
+         => (lambda (names)
+              (match-patcdr names (cdr stx))))
         (else #f)))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;
diff --git a/multisyntax/pattern/matcher.sld b/multisyntax/pattern/matcher.sld
index 7a03dad..49c307d 100644
--- a/multisyntax/pattern/matcher.sld
+++ b/multisyntax/pattern/matcher.sld
@@ -19,7 +19,7 @@
           (multisyntax utils) (multisyntax pattern internal)
           (only (multisyntax syntax-object)
                 identifier? bound-identifier=? free-identifier=?
-                unwrap-syntax
+                unwrap-syntax syntax->datum
                 ;; unportable extensions
                 self-syntax?
                 empty-wrap bound-identifier-comparator))
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index f634b81..e4479b2 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -450,6 +450,6 @@
 (define (unwrap-list stx)
   (let ((stx (unwrap-syntax stx)))
     (if (pair? stx)
-        (cons (car stx) (unwrap-syntax (cdr stx)))
+        (cons (car stx) (unwrap-list (cdr stx)))
         stx)))
 
diff --git a/test/run.scm b/test/run.scm
index 201c849..dfcaf97 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -62,6 +62,24 @@
                             (empty-wrap '(let (x (lambda x x)) (x x)))))))
   (display (alpha expanded-list)) (newline))
 
+(let-values (((global-map expanded-list)
+              (expand initial-environment
+                      (list (empty-wrap
+                             '(define-syntax let
+                                (syntax-rules ()
+                                  ((let ((name value)) body)
+                                   ((lambda name body) value)))))
+                            (empty-wrap
+                             '(define-syntax or
+                                (syntax-rules ()
+                                  ((or) false)
+                                  ((or x y ...)
+                                   (let ((tmp x))
+                                     (if tmp x (or y ...)))))))
+                            (empty-wrap
+                             '(or a b tmp c d e))))))
+  (display (alpha expanded-list)) (newline))
+
 #;(begin
   (load "examples/untyped-lambda-calculus.sld")
   (import (multisyntax examples untyped-lambda-calculus test))