Finish the macro expander.

It works!! At least it passes all the test cases.

Next I will:
1. finish the builtins,
2. add a conversion to IR2 in continuation passing style,
3. add a compiler from IR2 to bytecode,
4. and add an option to the frontend compiler to generate a
   standalone executable.

1 files changed, 291 insertions, 83 deletions

diff --git a/csc/macros.csc b/csc/macros.csc
index d8903eb..b4bb66e 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -3,12 +3,14 @@
     expand
     test-environment)
   (import (scheme base)
+          (only (csc assert) assert)
           (only (csc format) sprintf)
           (only (csc gensym)
             gensym
             gensym=?)
           (only (csc hash-map)
             alist->map
+            map-for-each
             hash-bytevector
             insert
             key-not-found-error?
@@ -27,7 +29,12 @@
             make-library-ref)
           (only (csc list) revappend)
           (only (csc match) match)
-          (only (csc strings) join))
+          (only (csc strings) join)
+          (only (csc vec)
+            vec
+            vec-append
+            vec-length
+            vec-ref))
   (begin
 
 
@@ -65,10 +72,6 @@
       (library environment-library))
 
 
-    (define (with-binding environment identifier binding)
-      (make-environment (insert (environment-substitutions environment) identifier binding) (environment-library environment)))
-
-
     (define-record-type <syntax-object>
       (make-syntax-object expression environment marks)
       syntax-object?
@@ -83,10 +86,10 @@
         (make-syntax-object expression environment '())))
 
 
-    (define (identifier? s)
-      (or (symbol? s)
-          (and (syntax-object? s)
-               (symbol? (syntax-object-expression s)))))
+    (define (syntax->expression s)
+      (if (syntax-object? s)
+        (syntax-object-expression s)
+        s))
 
 
     (define (marks s)
@@ -95,6 +98,20 @@
         '()))
 
 
+    (define (with-binding identifier binding syntax)
+      (let ((environment (syntax-object-environment syntax)))
+        (make-syntax-object
+          (syntax->expression syntax)
+          (make-environment (insert (environment-substitutions environment) identifier binding) (environment-library environment))
+          (marks syntax))))
+
+
+    (define (identifier? s)
+      (or (symbol? s)
+          (and (syntax-object? s)
+               (symbol? (syntax-object-expression s)))))
+
+
     (define (marks=? m1 m2)
       (and
         (= (length m1) (length m2))
@@ -135,7 +152,9 @@
                           (lookup (environment-substitutions (syntax-object-environment s1)) s1)))
             (s2-binding (guard (e ((key-not-found-error? e) #f))
                           (lookup (environment-substitutions (syntax-object-environment s2)) s2))))
-        (or (and (not s1-binding) (not s2-binding))
+        (or (and (not s1-binding)
+                 (not s2-binding)
+                 (symbol=? (identifier-name s1) (identifier-name s2)))
             (binding=? s1-binding s2-binding))))
 
 
@@ -202,14 +221,17 @@
             (begin result result* ...)
             (raise (make-syntax-case-no-match))))
         ((syntax-case-match-pattern x (pattern) result result* ...)
-          (if (= 1 (length (syntax->expression x)))
-            (syntax-case-match-pattern (syntax-map car x) pattern result result* ...)
-            (raise (make-syntax-case-no-match))))
+          (let ((y x))
+            (if (pair? (syntax->expression y))
+              (syntax-case-match-pattern (syntax-map car y) pattern
+                (syntax-case-match-pattern (syntax-map cdr y) '() result result* ...))
+              (raise (make-syntax-case-no-match)))))
         ((syntax-case-match-pattern x (pattern . rest) result result* ...)
           (let ((y x))
             (if (pair? (syntax->expression y))
               (syntax-case-match-pattern (syntax-map car y) pattern
-                (syntax-case-match-pattern (syntax-map cdr y) rest result result* ...)))))
+                (syntax-case-match-pattern (syntax-map cdr y) rest result result* ...))
+              (raise (make-syntax-case-no-match)))))
         ((syntax-case-match-pattern x ident result result* ...)
           (let ((ident x)) result result* ...))))
 
@@ -219,7 +241,7 @@
     (define-syntax syntax-case
       (syntax-rules ()
         ((syntax-case x (arm ...))
-          (guard (e ((syntax-case-no-match? e) (if #f #f)))
+          (guard (e ((syntax-case-no-match? e) (error "no match in syntax case")))
             (syntax-case-match-pattern x arm ...)))
         ((syntax-case x (arm ...) clause clause* ...)
           (let ((y x))
@@ -244,27 +266,24 @@
         (make-call expanded-procedure expanded-arguments)))
 
 
-    ; From R6RS:
-    ; Each time the expander encounters a macro use, it applies an antimark to
-    ; the input form, invokes the associated transformer, then applies a fresh
-    ; mark to the output.
-    ;
-    ; In cute scheme, macros compile themselves, and syntax-rules is therefore
-    ; responsible for applying a mark to an expanded expression before
-    ; expanding it with expand-syntax-object.
-    (define (expand-macro-use transformer syntax)
-      ((transformer-function transformer) (anti-mark syntax)))
+    (define (resolve-identifier ident)
+      (let ((substitutions (environment-substitutions (syntax-object-environment ident))))
+        (or
+          ; Check whether the variable is lexically bound to a marked identifier.
+          (guard (e ((key-not-found-error? e) #f))
+            (lookup substitutions ident))
+          ; Check whether the variable is bound to an unmarked identifier.
+          (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" ident)))
+            (lookup substitutions (identifier-name ident))))))
 
 
     (define (expand-syntax-object syntax)
       (syntax-case syntax
         ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax))
         ((macro-name . tail) (when (identifier? macro-name))
-          (let ((macro-body
-                  (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name)))
-                    (lookup (environment-substitutions (syntax-object-environment macro-name)) macro-name))))
+          (let ((macro-body (resolve-identifier macro-name)))
             (if (macro-transformer? macro-body)
-              (expand-macro-use macro-body syntax)
+              ((transformer-function macro-body) syntax)
               (values (expand-procedure-call macro-name tail) (syntax-object-environment syntax)))))
         ((procedure . arguments)
           (values (expand-procedure-call procedure arguments) (syntax-object-environment syntax)))
@@ -282,7 +301,7 @@
                        (string? expr)
                        (vector? expr))))
           (values (make-constant (syntax->expression syntax)) (syntax-object-environment syntax)))
-        (_ (raise-syntax-error "unexpected expression type" syntax))))
+        (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax)))))
 
 
     ; expand can be thought of as a compiler from Scheme to IR1. Macros
@@ -293,33 +312,36 @@
       (expand-syntax-object (wrap-syntax expression environment)))
 
 
+    (define (clean-syntax s)
+      (cond
+        ((pair? s) (cons (clean-syntax (car s)) (clean-syntax (cdr s))))
+        ((syntax-object? s) (clean-syntax (syntax->expression s)))
+        (else s)))
+
+
     (define builtin-quote
       (make-macro-transformer
         (lambda (syntax)
           (syntax-case syntax
-            ((_ datum) (values (make-constant (syntax->expression datum)) (syntax-object-environment syntax)))
-            (_ (raise-syntax-error "invalid form for quote" syntax))))))
-
-
-    (define (syntax->expression s)
-      (if (syntax-object? s)
-        (syntax-object-expression s)
-        s))
+            ((_ datum) (values (make-constant (clean-syntax datum)) (syntax-object-environment syntax)))
+            (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax)))))))
 
 
     (define (matches-literals literals object)
       (unless (list? (syntax->expression literals))
         (raise-syntax-error "invalid form in literals, expecting list" literals))
-      (let ((literal-identifiers
-              (map
-                (lambda (lit) (with-wrap lit literals))
-                (syntax->expression literals))))
-        (let loop ((literal-identifiers literal-identifiers))
-          (match literal-identifiers
-            ('() #f)
-            ((lit . literals)
-              (or (free-identifier=? lit object)
-                  (loop literals)))))))
+      (if (not (identifier? object))
+        #f
+        (let ((literal-identifiers
+                (map
+                  (lambda (lit) (with-wrap lit literals))
+                  (syntax->expression literals))))
+          (let loop ((literal-identifiers literal-identifiers))
+            (match literal-identifiers
+              ('() #f)
+              ((lit . literals)
+                (or (free-identifier=? lit object)
+                    (loop literals))))))))
 
 
     (define (identifier-uuid i)
@@ -343,20 +365,112 @@
 
 
     (define (is-underscore expression)
-      (free-identifier=?
-        expression
-        (wrap-syntax '_ (make-environment (alist->substitutions (list (cons '_ (make-library-ref '(csc builtins) '_ #t)))) '()))))
+      (and
+        (identifier? expression)
+        (free-identifier=?
+          expression
+          (wrap-syntax
+            '_
+            (make-environment
+              (alist->substitutions
+                (list (cons '_ (make-library-ref '(csc builtins) '_ #t))))
+              '())))))
+
+
+    (define (syntax-improper-list-length l)
+      (let loop ((l l)
+                 (n 0))
+        (syntax-case l
+          ('() n)
+          ((_ . rest) (loop rest (+ 1 n)))
+          (_ (+ 1 n)))))
+
+
+    ; objects is an n-dimensional vec, where n is nesting-level.
+    (define-record-type <ellipsis-binding>
+      (make-ellipsis-binding objects nesting-level)
+      ellipsis-binding?
+      (objects ellipsis-binding-objects)
+      (nesting-level ellipsis-binding-nesting-level))
 
 
-    (define (pattern-bindings pattern literals object)
+    (define (merge-bindings x y)
+      (assert (= (ellipsis-binding-nesting-level x) (ellipsis-binding-nesting-level y)))
+      (make-ellipsis-binding
+        (vec-append (ellipsis-binding-objects x) (ellipsis-binding-objects y))
+        (ellipsis-binding-nesting-level x)))
+
+
+    (define (ellipsis-substitutions-merge s1 s2)
+      (map-for-each
+        (lambda (k v)
+          (let-values (((s1-binding ok)
+                         (guard (e ((key-not-found-error? e) (values #f #f)))
+                           (values (lookup s1 k) #t))))
+            (if ok
+              (set! s1 (insert s1 k (merge-bindings s1-binding v)))
+              (set! s1 (insert s1 k v)))))
+        s2)
+      s1)
+
+
+    (define (map-ellipsis-binding substitutions)
+      (let ((res (alist->substitutions '())))
+        (map-for-each
+          (lambda (k v)
+            (if (ellipsis-binding? v)
+              (set! res
+                (insert
+                  res
+                  k
+                  (make-ellipsis-binding
+                    (vec (ellipsis-binding-objects v))
+                    (+ 1 (ellipsis-binding-nesting-level v)))))
+              (set! res
+                (insert
+                  res
+                  k
+                  (make-ellipsis-binding
+                    (vec v)
+                    1)))))
+          substitutions)
+        res))
+
+
+    (define (pattern-bindings ellipsis literals pattern object)
       (syntax-case pattern
-        (lit (when (and (free-identifier=? object lit)
-                        (matches-literals literals object)))
-          (alist->substitutions '()))
+        (lit (when (matches-literals literals lit))
+          (if (and (identifier? object) (free-identifier=? object lit))
+            (alist->substitutions '())
+            #f))
+        ((p ellip . p*) (when (and (identifier? ellip) (not (matches-literals literals ellip)) (free-identifier=? ellipsis ellip)))
+          (let* ((n (syntax-improper-list-length object))
+                 (m (syntax-improper-list-length p*))
+                 (n-m (- n m)))
+            (if (>= n m)
+              (let loop ((i 0)
+                         (object object)
+                         (bindings (alist->substitutions '())))
+                (if (< i n-m)
+                  (let ((binding (pattern-bindings ellipsis literals p (syntax-map car object))))
+                    (and binding
+                         (loop
+                           (+ 1 i)
+                           (syntax-map cdr object)
+                           (ellipsis-substitutions-merge bindings (map-ellipsis-binding binding)))))
+                  (merge
+                    bindings
+                    (pattern-bindings ellipsis literals p* object))))
+              #f)))
         (underscore (when (is-underscore underscore))
           (alist->substitutions '()))
         (ident (when (identifier? ident))
-          (alist->substitutions (list (cons ident object))))
+          ; Each time the expander encounters a macro use, it applies an
+          ; antimark to the input form.
+          ;
+          ; We would apply it earlier, but the antimark breaks
+          ; free-identifier=? to check for literals. -- rose
+          (alist->substitutions (list (cons ident (anti-mark object)))))
         ('()
           (syntax-case object
             ('() (alist->substitutions '()))
@@ -364,65 +478,159 @@
         ((p . p*)
           (syntax-case object
             ((e . e*)
-              (merge (pattern-bindings p literals e)
-                     (pattern-bindings p* literals e*)))
+              (merge (pattern-bindings ellipsis literals p e)
+                     (pattern-bindings ellipsis literals p* e*)))
             (_ #f)))
         (constant
-          (if (equal? constant (syntax->expression object))
+          (if (equal? (syntax->expression constant) (syntax->expression object))
             (alist->substitutions '())
             #f))))
 
 
-    (define (expand-template substitutions template)
+    (define-record-type <ellipsis-out-of-bounds>
+      (make-ellipsis-out-of-bounds)
+      ellipsis-out-of-bounds?)
+
+
+    (define (ellipsis-ref v i)
+      (if (< i (vec-length v))
+        (vec-ref v i)
+        (raise (make-ellipsis-out-of-bounds))))
+
+
+    ; Can raise key-not-found-error? or ellipsis-out-of-bounds?.
+    (define (ellipsis-lookup substitutions ellipsis-nesting key)
+      (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))
+            (let loop ((i 0)
+                       (value (ellipsis-binding-objects n-d-vector)))
+              (if (< i (vec-length ellipsis-nesting))
+                (loop
+                  (+ 1 i)
+                  (ellipsis-ref value (vec-ref ellipsis-nesting i)))
+                value))
+            (raise-syntax-error "reference to pattern variable at incorrect ellipsis nesting level" (clean-syntax key) (vec-length ellipsis-nesting)))
+          n-d-vector)))
+
+
+    (define (syntax-append s1 s2)
+      (syntax-case s1
+        ('() (with-wrap s2 s1))
+        ((head . tail)
+          (with-wrap
+            (cons head
+                  (syntax-append tail s2))
+            s1))))
+
+
+    (define (expand-template ellipsis ellipsis-nesting substitutions template)
       (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))))))))
         ((head . tail)
           (with-wrap
-            (cons (expand-template substitutions head)
-                  (expand-template substitutions tail))
+            (cons (expand-template ellipsis ellipsis-nesting substitutions head)
+                  (expand-template ellipsis ellipsis-nesting substitutions tail))
             template))
         (ident (when (identifier? ident))
           (guard (e ((key-not-found-error? e) template))
-            (lookup substitutions template)))
+            (ellipsis-lookup substitutions ellipsis-nesting template)))
         (_ template)))
 
 
-    (define (syntax-match literals all-rules object)
+    (define (syntax-match ellipsis literals all-rules object)
       (let loop ((rules all-rules))
         (syntax-case rules
-          ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object (map car all-rules)))
+          ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object all-rules))
           ((((_ . pattern) template) . tail)
-            (let ((bindings (pattern-bindings pattern literals (with-wrap (cdr (syntax->expression object)) object))))
+            (let ((bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object))))
               (if bindings
-                ; Each time the expander encounters a macro use,
-                ; it applies an antimark to the input form,
-                ; invokes the associated transformer,
-                ; then applies a fresh mark to the output.
-                ;
-                ; We also call expand-syntax-object immediately,
-                ; since macros are allowed to be recursive -- rose
-                (expand-syntax-object (add-mark (new-mark) (expand-template bindings template)))
+                ; We call expand-syntax-object immediately, since macros are
+                ; allowed to be recursive.
+                (expand-syntax-object
+                  ; Each time the expander encounters a macro use, it applies an
+                  ; antimark to the input form, invokes the associated
+                  ; transformer, then applies a fresh mark to the output.
+                  (add-mark (new-mark) (expand-template ellipsis (vec) bindings template)))
                 (loop tail))))
           (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules)))))
 
 
+    (define default-ellipsis
+      (wrap-syntax
+        '...
+        (make-environment
+          (alist->substitutions
+            (list (cons '_
+                        (make-library-ref '(csc builtins) '_ #t))))
+          '())))
+
+
     (define builtin-syntax-rules
       (make-macro-transformer
         (lambda (syntax-rules-form)
-          (syntax-case syntax-rules-form
-            ((_ literals . rules)
-              (values
-                (make-macro-transformer
-                  (lambda (input-form)
-                    (syntax-match literals rules input-form)))
-                (syntax-object-environment syntax-rules-form)))
-            (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form))))))
+          (values
+            (make-macro-transformer
+              (lambda (input-form)
+                (let-values (((x y)
+                (syntax-case syntax-rules-form
+                  ((_ ellipsis literals . rules) (when (identifier? ellipsis))
+                    (syntax-match ellipsis literals rules input-form))
+                  ((_ literals . rules)
+                    (syntax-match default-ellipsis literals rules input-form))
+                  (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form)))))
+                  (values x y))))
+            (syntax-object-environment syntax-rules-form)))))
+
+
+    (define builtin-let-syntax
+      (make-macro-transformer
+        (lambda (x)
+          (let-values (((x y)
+          (syntax-case x
+            ((_ (ident transformer-form) body-form) (when (identifier? ident))
+              (let*-values (((transformer environment) (expand-syntax-object transformer-form))
+                            ((body environment) (expand-syntax-object (with-binding ident transformer body-form))))
+                (values
+                  body
+                  (syntax-object-environment x))))
+            (_ (raise-syntax-error "unexpected for in let-syntax")))))
+            (values x y)))))
 
 
     (define test-environment
       (make-environment
         (alist->substitutions
           (list (cons 'syntax-rules builtin-syntax-rules)
+                (cons '_ (make-library-ref '(csc builtins) '_ #t))
                 (cons 'quote builtin-quote)
-                (cons '_ (make-library-ref '(csc builtins) '_ #t))))
+                (cons 'builtin-let-syntax builtin-let-syntax)))
         '()))))