Fix bugs in the macro expander.

Now I'm following the rule that you should ignore marks that were added
after the binding was defined. I also introduced a lexical environment
to handle lambdas.

2 files changed, 125 insertions, 84 deletions

diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc
index 9b4c128..be573cb 100644
--- a/lib/csc/macros-test.csc
+++ b/lib/csc/macros-test.csc
@@ -37,6 +37,7 @@
             make-letrec
             make-lexical-ref
             make-lexical-set
+            make-library-define
             make-library-ref
             make-sequence
             sequence?)
@@ -238,6 +239,22 @@
         transform-ir1))
 
 
+    (test builtin-syntax-rules-define
+      (assert-equal
+        (make-library-define (make-library-ref 'exit 'main)
+          (make-lambda '() #f (make-sequence (make-constant #f) (make-call-builtin 'exit (list (make-library-ref 'code 'main))))))
+        (expand-body 'main
+          '((let-syntax
+              (define
+                (syntax-rules ()
+                  ((define (f . args) body ...)
+                    (builtin-define f (lambda args body ...)))))
+              (define (exit)
+                (call-builtin exit code))))
+          builtins-environment)
+        transform-ir1))
+
+
     (define (test-ref sym)
       (make-lexical-ref sym (gensym)))
 
@@ -257,6 +274,16 @@
         transform-ir1))
 
 
+    (test builtin-lambda-ref
+      (assert-equal
+        (make-lambda (list (test-ref 'x)) #f
+          (make-sequence (make-constant #f) (test-ref 'x)))
+        (expand-body 'main
+          '((lambda (x) x))
+          builtins-environment)
+        transform-ir1))
+
+
     (test builtin-case-lambda-defines
       (assert-equal
         (make-lambda (list (test-ref 'x)) #f
diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc
index fc8aa79..6278142 100644
--- a/lib/csc/macros.csc
+++ b/lib/csc/macros.csc
@@ -125,13 +125,6 @@
         (environment-library environment)))
 
 
-    (define (with-binding identifier binding syntax)
-      (make-syntax-object
-        (syntax->expression syntax)
-        (add-binding identifier binding (syntax-object-environment syntax))
-        (marks syntax)))
-
-
     (define (identifier? s)
       (or (symbol? s)
           (and (syntax-object? s)
@@ -177,10 +170,12 @@
                           (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)
+        (or (and s1-binding
+                 s2-binding
+                 (binding=? s1-binding s2-binding))
+            (and (not s1-binding)
                  (not s2-binding)
-                 (symbol=? (identifier-name s1) (identifier-name s2)))
-            (binding=? s1-binding s2-binding))))
+                 (symbol=? (identifier-name s1) (identifier-name s2))))))
 
 
     (define *next-mark* 0)
@@ -220,7 +215,9 @@
 
 
     (define (with-wrap expression parent)
-      (decorate (marks parent) expression (syntax-object-environment parent)))
+      (if (syntax-object? parent)
+        (decorate (marks parent) expression (syntax-object-environment parent))
+        expression))
 
 
     (define (syntax-map f expr)
@@ -275,15 +272,15 @@
               (syntax-case-match-pattern y arm ...))))))
 
 
-    (define (expand-procedure-call procedure arguments)
-      (let ((expanded-procedure (expand-syntax-object procedure))
+    (define (expand-procedure-call procedure arguments env)
+      (let ((expanded-procedure (expand procedure env))
             (expanded-arguments
               (let loop ((arguments arguments)
                          (expanded-arguments '()))
                 (syntax-case arguments
                   ('() (reverse expanded-arguments))
                   ((argument . rest)
-                    (let ((expanded-argument (expand-syntax-object argument)))
+                    (let ((expanded-argument (expand argument env)))
                       (loop
                         rest
                         (cons expanded-argument expanded-arguments))))
@@ -291,32 +288,40 @@
         (make-call expanded-procedure expanded-arguments)))
 
 
-    (define (resolve-identifier ident)
-      (let* ((environment (syntax-object-environment ident))
-             (substitutions (environment-substitutions environment)))
-        (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) #f))
-            (lookup substitutions (identifier-name ident)))
-          ; Otherwise insert a library-ref
-          (make-library-ref (identifier-name ident) (environment-library environment)))))
+    (define (strip-mark ident)
+      (make-syntax-object
+        (identifier-name ident)
+        (syntax-object-environment ident)
+        (cdr (marks ident))))
+
+
+    (define (lookup-complicated ident env)
+      (define e (environment-substitutions env))
+      (or (lookup e ident #f)
+          (and (pair? (marks ident))
+               (lookup-complicated (strip-mark ident) env))))
+
+
+    (define (resolve-identifier ident lexical-env)
+      (or
+        (lookup-complicated ident lexical-env)
+        (and (syntax-object? ident)
+             (lookup-complicated ident (syntax-object-environment ident)))
+        (make-library-ref (identifier-name ident) (environment-library lexical-env))))
 
 
-    (define (expand-syntax-object syntax)
+    (define (expand syntax env)
       (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 (resolve-identifier macro-name)))
+          (let ((macro-body (resolve-identifier macro-name env)))
             (if (macro-transformer? macro-body)
-              ((transformer-function macro-body) syntax)
-              (expand-procedure-call macro-name tail))))
+              ((transformer-function macro-body) syntax env)
+              (expand-procedure-call macro-name tail env))))
         ((procedure . arguments)
-          (expand-procedure-call procedure arguments))
+          (expand-procedure-call procedure arguments env))
         (_ when (identifier? syntax)
-          (let ((binding (resolve-identifier syntax)))
+          (let ((binding (resolve-identifier syntax env)))
             (if (macro-transformer? binding)
               (raise-syntax-error "macro is not allowed in this context" syntax)
               binding)))
@@ -330,10 +335,6 @@
         (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax)))))
 
 
-    (define (expand expression environment)
-      (expand-syntax-object (wrap-syntax expression environment)))
-
-
     (define (clean-syntax s)
       (cond
         ((pair? s) (cons (clean-syntax (car s)) (clean-syntax (cdr s))))
@@ -343,7 +344,7 @@
 
     (define builtin-quote
       (make-macro-transformer
-        (lambda (syntax)
+        (lambda (syntax env)
           (syntax-case syntax
             ((_ datum) (make-constant (clean-syntax datum)))
             (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax)))))))
@@ -602,20 +603,21 @@
         (_ template)))
 
 
-    (define (syntax-match ellipsis literals all-rules object)
+    (define (syntax-match ellipsis literals all-rules env object)
       (let loop ((rules all-rules))
         (syntax-case rules
-          ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object all-rules))
+          ('() (raise-syntax-error "form did not match any patterns in syntax-rules" (clean-syntax object) (clean-syntax all-rules)))
           ((((_ . pattern) template) . tail)
-            (define bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object)))
+            (define bindings (pattern-bindings ellipsis literals pattern (wrap-syntax (syntax-map cdr object) env)))
             (if bindings
-              ; We call expand-syntax-object immediately, since macros are
+              ; We call expand immediately, since macros are
               ; allowed to be recursive.
-              (expand-syntax-object
+              (expand
                 ; 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)))
+                (add-mark (new-mark) (expand-template ellipsis (vec) bindings template))
+                env)
               (loop tail)))
           (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules)))))
 
@@ -632,26 +634,36 @@
 
     (define builtin-syntax-rules
       (make-macro-transformer
-        (lambda (syntax-rules-form)
+        (lambda (syntax-rules-form env1)
+          ; Merge the lexical and toplevel environments.
+          (define toplevel-env (if (syntax-object? syntax-rules-form)
+                                 (environment-substitutions (syntax-object-environment syntax-rules-form))
+                                 (make-map compare-identifiers)))
+          (set! syntax-rules-form
+            (make-syntax-object (syntax->expression syntax-rules-form)
+                                (make-environment
+                                  (merge toplevel-env (environment-substitutions env1))
+                                  (environment-library env1))
+                                (marks syntax-rules-form)))
           (make-macro-transformer
-            (lambda (input-form)
+            (lambda (input-form env)
               (syntax-case syntax-rules-form
                 ((_ ellipsis literals . rules) when (identifier? ellipsis)
-                  (syntax-match ellipsis literals rules input-form))
+                  (syntax-match ellipsis literals rules env input-form))
                 ((_ literals . rules)
-                  (syntax-match default-ellipsis literals rules input-form))
-                (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form))))))))
+                  (syntax-match default-ellipsis literals rules env input-form))
+                (_ (raise-syntax-error "unexpected form in syntax-rules" (clean-syntax syntax-rules-form)))))))))
 
 
     (define builtin-let-syntax
       (make-macro-transformer
-        (lambda (x)
+        (lambda (x env)
           (syntax-case x
             ((_ (ident transformer-form) body-form) when (identifier? ident)
-              (let* ((transformer (expand-syntax-object transformer-form))
-                    (body (expand-syntax-object (with-binding ident transformer body-form))))
+              (let* ((transformer (expand transformer-form env))
+                     (body (expand body-form (add-binding ident transformer env))))
                 body))
-            (_ (raise-syntax-error "unexpected form in let-syntax" x))))))
+            (_ (raise-syntax-error "unexpected form in let-syntax" (clean-syntax x)))))))
 
 
     (define (split-args-rest formals)
@@ -663,17 +675,17 @@
             (values (cons (identifier-name var) args) rest)))
         (var when (identifier? var)
           (values '() (identifier-name var)))
-        (_ (raise-syntax-error "unexpected form in split-args-rest" formals))))
+        (_ (raise-syntax-error "unexpected form in split-args-rest" (clean-syntax formals)))))
 
 
-    (define (expand-lambda-body-rest body)
+    (define (expand-lambda-body-rest body env)
       (let loop ((body body)
                  (expanded-body (make-constant #f)))
         (syntax-case body
           ('()
             expanded-body)
           ((expr . expr*)
-            (define expanded-expr (expand-syntax-object expr))
+            (define expanded-expr (expand expr env))
             (when (or (library-define? expanded-expr)
                       (define-syntax? expanded-expr))
               (raise-syntax-error "define not allowed here" body))
@@ -681,8 +693,9 @@
                   (make-sequence expanded-body expanded-expr))))))
 
 
-    (define (expand-lambda-body body)
+    (define (expand-lambda-body body env)
       (let loop ((body body)
+                 (env env)
                  (names '())
                  (gensyms '())
                  (expressions '()))
@@ -692,73 +705,74 @@
               (make-constant #f)
               (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (make-constant #f))))
           ((expr . expr*)
-            (define expanded-expr (expand-syntax-object expr))
+            (define expanded-expr (expand expr env))
             (cond
               ((library-define? expanded-expr)
                 (let ((name (library-ref-name (library-define-ref expanded-expr)))
                       (g (gensym)))
-                  (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body))
+                  (loop (syntax-map cdr body)
+                        (add-binding name (make-lexical-ref name g) env)
                         (cons name names)
                         (cons g gensyms)
                         (cons (library-define-expression expanded-expr) expressions))))
               ((define-syntax? expanded-expr)
-                (loop (with-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) (syntax-map cdr body))
+                (loop (syntax-map cdr body)
+                      (add-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) env)
                       names
                       gensyms
                       expressions))
               (else
                 (if (null? names)
-                  (expand-lambda-body-rest body)
-                  (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body)))))))))
+                  (expand-lambda-body-rest body env)
+                  (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body env)))))))))
 
 
     (define builtin-lambda
       (make-macro-transformer
-        (lambda (x)
+        (lambda (x env)
           (syntax-case x
             ((_ formals . body)
               (let-values (((args rest) (split-args-rest formals)))
                 (define refs (map (lambda (name)
                                     (make-lexical-ref name (gensym)))
                                   args))
-                (define environment (syntax-object-environment body))
                 (loop for ref in refs
-                      do (set! environment (add-binding (lexical-ref-name ref) ref environment)))
+                      do (set! env (add-binding (lexical-ref-name ref) ref env)))
                 (make-lambda
                   refs
                   (if rest
                     (make-lexical-ref rest (gensym))
                     #f)
-                  (expand-lambda-body (make-syntax-object (syntax->expression body) environment (marks body))))))
+                  (expand-lambda-body body env))))
             (_ (raise-syntax-error "unexpected form in lambda" x))))))
 
 
     (define builtin-define
       (make-macro-transformer
-        (lambda (x)
+        (lambda (x env)
           (syntax-case x
-            ((_ symbol expression)
+            ((_ symbol expression) when (identifier? symbol)
               (make-library-define
                 (make-library-ref
                   (identifier-name symbol)
-                  (environment-library (syntax-object-environment x)))
-                (expand-syntax-object expression)))
-            (_ (raise-syntax-error "unexpected form in builtin-define" x))))))
+                  (environment-library env))
+                (expand expression env)))
+            (_ (raise-syntax-error "unexpected form in builtin-define" (clean-syntax x)))))))
 
 
     (define builtin-define-syntax
       (make-macro-transformer
-        (lambda (x)
+        (lambda (x env)
           (syntax-case x
             ((_ ident transformer-form) when (identifier? ident)
               (make-define-syntax (identifier-name ident)
-                (expand-syntax-object transformer-form)))
+                (expand transformer-form env)))
             (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x))))))
 
 
     (define builtin-call-builtin
       (make-macro-transformer
-        (lambda (x)
+        (lambda (x env)
           (syntax-case x
             ((_ op . args) when (identifier? op)
               (make-call-builtin (identifier-name op)
@@ -768,7 +782,7 @@
                                      ('() (reverse expanded-args))
                                      ((head . tail)
                                        (loop tail
-                                             (cons (expand-syntax-object head)
+                                             (cons (expand head env)
                                                    expanded-args)))
                                      (_ (raise-syntax-error "unexpected form in call-builtin"))))))
             (_ (raise-syntax-error "unexpected form in call-builtin" x))))))
@@ -776,11 +790,11 @@
 
     (define builtin-set
       (make-macro-transformer
-        (lambda (x)
+        (lambda (x env)
           (syntax-case x
             ((_ var value) when (identifier? var)
-              (define var* (expand-syntax-object var))
-              (define val* (expand-syntax-object value))
+              (define var* (expand var env))
+              (define val* (expand value env))
               (cond
                 ((lexical-ref? var*)
                   (make-lexical-set var* val*))
@@ -793,22 +807,22 @@
 
     (define builtin-if
       (make-macro-transformer
-        (lambda (x)
+        (lambda (x env)
           (syntax-case x
             ((_ test true false)
-              (make-if (expand-syntax-object test)
-                (expand-syntax-object true)
-                (expand-syntax-object false)))
+              (make-if (expand test env)
+                (expand true env)
+                (expand false env)))
             (_ (raise-syntax-error "unexpected form in builtin-if"))))))
 
 
     (define builtin-sequence
       (make-macro-transformer
-        (lambda (x)
+        (lambda (x env)
           (syntax-case x
             ((_ head tail)
-              (make-sequence (expand-syntax-object head)
-                             (expand-syntax-object tail)))
+              (make-sequence (expand head env)
+                             (expand tail env)))
             (_ (raise-syntax-error "unexpected form in builtin-sequence"))))))