Fix bugs with recursive macros and empty template.

2 files changed, 91 insertions, 38 deletions

diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc
index cce95ac..9c4aced 100644
--- a/lib/csc/macros-test.csc
+++ b/lib/csc/macros-test.csc
@@ -255,6 +255,25 @@
         transform-ir1))
 
 
+    (test builtin-syntax-rules-recursive
+      (assert-equal
+        (make-call-builtin 'add
+          (list (make-constant 1)
+                (make-call-builtin 'add
+                  (list (make-constant 1)
+                        (make-call-builtin 'add (list (make-constant 1) (make-constant 0)))))))
+        (expand-body 'main
+          '((let-syntax
+              ((macro-len
+                (syntax-rules ()
+                  ((macro-len ()) 0)
+                  ((macro-len (_ tail ...))
+                    (call-builtin add 1 (macro-len (tail ...)))))))
+              (macro-len (a b c))))
+          builtins-environment)
+        transform-ir1))
+
+
     (define (test-ref sym)
       (make-lexical-ref sym (gensym)))
 
diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc
index 398f07b..91bcef1 100644
--- a/lib/csc/macros.csc
+++ b/lib/csc/macros.csc
@@ -328,7 +328,7 @@
 
     (define (expand syntax env)
       (syntax-case syntax
-        ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax))
+        ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)"))
         ((macro-name . tail) when (identifier? macro-name)
           (let ((macro-body (resolve-identifier macro-name env)))
             (if (macro-transformer? macro-body)
@@ -490,6 +490,20 @@
         res))
 
 
+    (define (init-template-bindings ellipsis literals pattern)
+      (guard (e (#t (error "fuck" e)))
+      (syntax-case pattern
+        ((p ellip . p*) when (and (identifier? ellip) (not (matches-literals literals ellip)) (free-identifier=? ellipsis ellip))
+          (merge
+            (map-ellipsis-binding (init-template-bindings ellipsis literals p))
+            (init-template-bindings ellipsis literals p*)))
+        ((head . tail) (merge (init-template-bindings ellipsis literals head)
+                              (init-template-bindings ellipsis literals tail)))
+        (ident when (identifier? ident)
+          (alist->substitutions (list (cons ident (make-ellipsis-binding (vec) 1)))))
+        (_ (alist->substitutions '())))))
+
+
     (define (pattern-bindings ellipsis literals pattern object)
       (syntax-case pattern
         (lit when (matches-literals literals lit)
@@ -503,7 +517,7 @@
             (if (>= n m)
               (let loop ((i 0)
                          (object object)
-                         (bindings (alist->substitutions '())))
+                         (bindings (init-template-bindings ellipsis literals p)))
                 (if (< i n-m)
                   (and
                     (pair? (syntax->expression object))
@@ -555,10 +569,6 @@
 
     ; Can raise key-not-found-error? or ellipsis-out-of-bounds?.
     (define (ellipsis-lookup substitutions ellipsis-nesting key)
-      (define keys '())
-      (map-for-each (lambda (k v)
-                      (set! keys (cons (marks k) keys)))
-                    substitutions)
       (let ((n-d-vector (lookup substitutions key)))
         (if (ellipsis-binding? n-d-vector)
           (if (= (ellipsis-binding-nesting-level n-d-vector) (vec-length ellipsis-nesting))
@@ -583,41 +593,59 @@
             s1))))
 
 
+    (define (scan-for-ellipsis-args ellipsis-nesting substitutions template)
+      (syntax-case template
+        ('() #f)
+        (ident when (identifier? ident)
+          (define binding (lookup substitutions ident #f))
+          (and binding
+               (ellipsis-binding? binding)
+               (loop for i from 0 below (vec-length ellipsis-nesting)
+                     with v = (ellipsis-binding-objects binding)
+                     do (set! v (vec-ref v (vec-ref ellipsis-nesting i)))
+                     finally (return (vec-length v)))))
+        ((head . tail)
+          (define n1 (scan-for-ellipsis-args ellipsis-nesting substitutions head))
+          (define n2 (scan-for-ellipsis-args ellipsis-nesting substitutions tail))
+          (or (and n1 n2
+                   (min n1 n2))
+              n1
+              n2))
+        (_ #f)))
+
+
     (define (expand-template ellipsis ellipsis-nesting substitutions template)
-      (define keys '())
-      (map-for-each (lambda (k v)
-                      (set! keys (cons (identifier-name k) keys)))
-                    substitutions)
       (syntax-case template
         ('() (with-wrap '() template))
         ((head ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis))
-          (let-values (((extra-ellipses tail)
-                         (let loop ((tail tail)
-                                    (extra-ellipses '()))
-                           (syntax-case tail
-                             ((ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis))
-                               (loop tail (cons ellip extra-ellipses)))
-                             (_ (values extra-ellipses tail))))))
-            (let loop ((i 0)
-                       (expansion (with-wrap '() template)))
-              (guard (e ((ellipsis-out-of-bounds? e)
-                          (if (= 0 i)
-                            ; Failure was at a higher level.
-                            (raise e)
-                            (syntax-append expansion (expand-template ellipsis ellipsis-nesting substitutions tail)))))
-                (loop
-                  (+ 1 i)
-                  (syntax-append
-                    expansion
-                    (expand-template
-                      ellipsis
-                      (vec-append ellipsis-nesting i)
-                      substitutions
-                      (with-wrap
-                        (cons
-                          head
-                          extra-ellipses)
-                        template))))))))
+          (define num-expansions (scan-for-ellipsis-args ellipsis-nesting substitutions head))
+          (unless num-expansions
+            (raise-syntax-error "no ellipsis variables found in ellipsisized expression" (clean-syntax template)))
+          (define-values (extra-ellipses tail*)
+            (let loop ((tail tail)
+                       (extra-ellipses '()))
+              (syntax-case tail
+                ((ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis))
+                  (loop tail (cons ellip extra-ellipses)))
+                (_ (values extra-ellipses tail)))))
+          (loop for i from 0 below num-expansions
+                with expansion = (with-wrap '() template)
+                do (set! expansion
+                     (syntax-append
+                       expansion
+                       (expand-template
+                         ellipsis
+                         (vec-append ellipsis-nesting i)
+                         substitutions
+                         (with-wrap
+                           (cons
+                             head
+                             extra-ellipses)
+                           template))))
+                finally (return
+                          (syntax-append
+                            expansion
+                            (expand-template ellipsis ellipsis-nesting substitutions tail*)))))
         ((head . tail)
           (with-wrap
             (cons (expand-template ellipsis ellipsis-nesting substitutions head)
@@ -839,8 +867,14 @@
         (lambda (x env)
           (syntax-case x
             ((_ ident transformer-form) when (identifier? ident)
+              (define transformer*
+                (make-macro-transformer
+                  (lambda (x env)
+                    ((transformer-function transformer) x env))))
+              (define transformer
+                (expand transformer-form (add-binding ident transformer* env)))
               (make-define-syntax (identifier-name ident)
-                (expand transformer-form env)))
+                transformer))
             (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x))))))