Fix some bugs in macros, and add list constants.

2 files changed, 236 insertions, 94 deletions

diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc
index def474f..2af86b7 100644
--- a/lib/csc/macros-test.csc
+++ b/lib/csc/macros-test.csc
@@ -68,7 +68,19 @@
 
     (test builtin-quote
       (assert-equal
-        (make-constant '(test 1 2 3))
+        (make-call-builtin 'cons
+          (list
+            (make-constant 'test)
+            (make-call-builtin 'cons
+              (list
+                (make-constant 1)
+                (make-call-builtin 'cons
+                  (list
+                    (make-constant 2)
+                    (make-call-builtin 'cons
+                      (list
+                        (make-constant 3)
+                        (make-constant '())))))))))
         (expand-body 'main
           '((quote (test 1 2 3)))
           builtins-environment)
@@ -80,12 +92,12 @@
         (make-constant 1)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules (a b)
                   ((foo a)
                     0)
                   ((foo b)
-                    1)))
+                    1))))
               (foo b)))
           builtins-environment)
         transform-ir1))
@@ -96,9 +108,9 @@
         (make-constant 0)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules ()
-                  ((foo _) 0)))
+                  ((foo _) 0))))
               (foo ignored)))
           builtins-environment)
         transform-ir1))
@@ -109,9 +121,9 @@
         (make-constant 5)
         (expand-body 'main
           '((let-syntax
-              (foo
-                (syntax-rules ()
-                  ((foo x) x)))
+             ((foo
+               (syntax-rules ()
+                 ((foo x) x))))
               (foo 5)))
           builtins-environment)
         transform-ir1))
@@ -122,10 +134,10 @@
         (make-constant 1)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules ()
                   ((foo x) 0)
-                  ((foo) 1)))
+                  ((foo) 1))))
               (foo)))
           builtins-environment)
         transform-ir1))
@@ -136,9 +148,9 @@
         (make-constant 1)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules ()
-                  ((foo a . b) a)))
+                  ((foo a . b) a))))
               (foo 1 2 3)))
           builtins-environment)
         transform-ir1))
@@ -149,9 +161,9 @@
         (make-constant 'a)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules ()
-                  ((foo x) (quote x))))
+                  ((foo x) (quote x)))))
               (foo a)))
           builtins-environment)
         transform-ir1))
@@ -162,11 +174,11 @@
         (make-constant 2)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules ()
                   ((foo "abc") 0)
                   ((foo "def") 1)
-                  ((foo "ghi") 2)))
+                  ((foo "ghi") 2))))
               (foo "ghi")))
           builtins-environment)
         transform-ir1))
@@ -177,9 +189,9 @@
         (make-constant 5)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules ()
-                  ((foo x ...) (x ...))))
+                  ((foo x ...) (x ...)))))
               (foo quote 5)))
           builtins-environment)
         transform-ir1))
@@ -190,9 +202,9 @@
         (make-constant 5)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules ()
-                  ((foo x ... . y) (x ... y))))
+                  ((foo x ... . y) (x ... y)))))
               (foo quote . 5)))
           builtins-environment)
         transform-ir1))
@@ -200,13 +212,19 @@
 
     (test builtin-syntax-rules-ellipsis-zip
       (assert-equal
-        (make-constant '((1 . 3) (2 . 4)))
+        (make-call-builtin 'cons
+          (list
+            (make-call-builtin 'cons (list (make-constant 1) (make-constant 3)))
+            (make-call-builtin 'cons
+              (list
+                (make-call-builtin 'cons (list (make-constant 2) (make-constant 4)))
+                (make-constant '())))))
         (expand-body 'main
           '((let-syntax
-              (zip
+              ((zip
                 (syntax-rules ()
                   ((zip (x ...) (y ...))
-                    (quote ((x . y) ...)))))
+                    (quote ((x . y) ...))))))
               (zip (1 2) (3 4))))
           builtins-environment)
         transform-ir1))
@@ -214,13 +232,28 @@
 
     (test builtin-syntax-rules-ellipsis-nested
       (assert-equal
-        (make-constant '(1 2 3 4 5))
+        (make-call-builtin 'cons
+          (list
+            (make-constant 1)
+            (make-call-builtin 'cons
+              (list
+                (make-constant 2)
+                (make-call-builtin 'cons
+                  (list
+                    (make-constant 3)
+                    (make-call-builtin 'cons
+                      (list
+                        (make-constant 4)
+                        (make-call-builtin 'cons
+                          (list
+                            (make-constant 5)
+                            (make-constant '())))))))))))
         (expand-body 'main
           '((let-syntax
-              (append
+              ((append
                 (syntax-rules ()
                   ((append (x ...) ...)
-                    (quote (x ... ...)))))
+                    (quote (x ... ...))))))
               (append (1 2) (3 4) () (5))))
           builtins-environment)
         transform-ir1))
@@ -231,9 +264,9 @@
         (make-constant 5)
         (expand-body 'main
           '((let-syntax
-              (foo
+              ((foo
                 (syntax-rules ::: ()
-                  ((foo x :::) (x :::))))
+                  ((foo x :::) (x :::)))))
               (foo quote 5)))
           builtins-environment)
         transform-ir1))
@@ -242,13 +275,13 @@
     (test builtin-syntax-rules-define
       (assert-equal
         (make-library-define (make-library-ref 'exit 'main)
-          (make-lambda (test-ref 'args) (make-sequence (make-constant #f) (make-call-builtin 'exit (list (make-library-ref 'code 'main))))))
+          (make-lambda (test-ref 'args) (make-call-builtin 'exit (list (make-library-ref 'code 'main)))))
         (expand-body 'main
           '((let-syntax
-              (define
+              ((define
                 (syntax-rules ()
                   ((define (f) body ...)
-                    (builtin-define f (builtin-lambda args body ...)))))
+                    (builtin-define f (builtin-lambda args body ...))))))
               (define (exit)
                 (call-builtin exit code))))
           builtins-environment)
@@ -262,20 +295,20 @@
     (test builtin-lambda-ref
       (assert-equal
         (make-lambda (test-ref 'args)
-          (make-sequence (make-constant #f) (test-ref 'args)))
+          (test-ref 'args))
         (expand-body 'main
           '((builtin-lambda args args))
           builtins-environment)
         transform-ir1))
 
 
-    (test builtin-case-lambda-defines
+    (test builtin-lambda-defines
       (assert-equal
         (make-lambda (test-ref 'args)
           (make-letrec #t '(a b) (list (gensym) (gensym))
             (list (make-constant 6)
                   (test-ref 'a))
-            (make-sequence (make-constant #f) (make-constant 7))))
+            (make-constant 7)))
         (expand-body 'main
           '((builtin-lambda args
               (builtin-define a (quote 6))
@@ -285,6 +318,16 @@
         transform-ir1))
 
 
+    (test builtin-lambda-empty
+      (assert-equal
+        (make-lambda (test-ref 'args)
+          (make-constant #f))
+        (expand-body 'main
+          '((builtin-lambda args))
+          builtins-environment)
+        transform-ir1))
+
+
     (test builtin-define-syntax
       (assert-equal
         (make-sequence
@@ -311,9 +354,7 @@
     (test builtin-lexical-set
       (assert-equal
         (make-lambda (test-ref 'args)
-          (make-sequence
-            (make-constant #f)
-            (make-lexical-set (test-ref 'args) (make-constant 5))))
+          (make-lexical-set (test-ref 'args) (make-constant 5)))
         (expand-body 'main
           '((builtin-lambda args
               (set! args 5)))
diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc
index e78fc72..f0b4d67 100644
--- a/lib/csc/macros.csc
+++ b/lib/csc/macros.csc
@@ -21,6 +21,18 @@
             map-for-each
             merge)
           (only (csc ir1)
+            %call
+            %call-builtin
+            %constant
+            %define-syntax
+            %if
+            %lambda
+            %letrec
+            %lexical-ref
+            %lexical-set
+            %library-define
+            %library-ref
+            %sequence
             define-syntax-name
             define-syntax-transformer
             define-syntax?
@@ -30,6 +42,7 @@
             library-define-expression
             library-define-ref
             library-define?
+            library-ref-library
             library-ref-name
             library-ref?
             make-call
@@ -197,21 +210,24 @@
           (cons mark (syntax-object-marks expression)))))
 
 
-    (define (add-marks marks expression)
-      (let loop ((marks marks)
-                 (expression expression))
-        (match marks
-          ('() expression)
-          ((mark . marks)
-           (loop marks (add-mark mark expression))))))
+    ; It's worth considering a more efficient algorithm.
+    (define (add-marks ms expression)
+      (loop for m in ms
+            with res = expression
+            unless (loop for m* in (marks res)
+                         if (eqv? m* m)
+                           return #t
+                         finally (return #f))
+              do (set! res (add-mark m res))
+            finally (return res)))
 
 
     (define (anti-mark expression)
       (add-mark #f expression))
 
 
-    (define (decorate marks expression environment)
-      (add-marks marks (wrap-syntax expression environment)))
+    (define (decorate ms expression environment)
+      (add-marks ms (wrap-syntax expression environment)))
 
 
     (define (with-wrap expression parent)
@@ -346,7 +362,11 @@
       (make-macro-transformer
         (lambda (syntax env)
           (syntax-case syntax
-            ((_ datum) (make-constant (clean-syntax datum)))
+            ((_ datum)
+              (let quote-expr ((datum datum))
+                (syntax-case datum
+                  ((head . tail) (make-call-builtin 'cons (list (quote-expr head) (quote-expr tail))))
+                  (_ (make-constant (clean-syntax datum))))))
             (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax)))))))
 
 
@@ -489,12 +509,14 @@
                          (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)))))
+                  (and
+                    (pair? (syntax->expression object))
+                    (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))))))
                   (let ((bindings* (pattern-bindings ellipsis literals p* object)))
                     (and bindings* (merge bindings bindings*)))))
               #f)))
@@ -537,6 +559,10 @@
 
     ; 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))
@@ -562,6 +588,10 @@
 
 
     (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))
@@ -598,7 +628,8 @@
                   (expand-template ellipsis ellipsis-nesting substitutions tail))
             template))
         (ident when (identifier? ident)
-          (guard (e ((key-not-found-error? e) template))
+          (guard (e ((key-not-found-error? e)
+                      template))
             (ellipsis-lookup substitutions ellipsis-nesting template)))
         (_ template)))
 
@@ -659,34 +690,87 @@
       (make-macro-transformer
         (lambda (x env)
           (syntax-case x
-            ((_ (ident transformer-form) body-form) when (identifier? ident)
-              (let* ((transformer (expand transformer-form env))
-                     (body (expand body-form (add-binding ident transformer env))))
-                body))
+            ((_ bindings body-form)
+              (loop with env* = env
+                    for bindings* = bindings
+                                  then (syntax-case bindings*
+                                         ((_)
+                                           (return (expand body-form env*)))
+                                         ((_ . rest) rest)
+                                         (_ (raise-syntax-error "unexpected form in let-syntax loop" (clean-syntax x))))
+                    do (syntax-case bindings*
+                         (((ident transformer-form) . _) when (identifier? ident)
+                           (set! env* (add-binding ident (expand transformer-form env) env*)))
+                         (_ (raise-syntax-error "unexpected form in let-syntax binding" (clean-syntax x))))))
             (_ (raise-syntax-error "unexpected form in let-syntax" (clean-syntax x)))))))
 
 
     (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 expr env))
-            (when (or (library-define? expanded-expr)
-                      (define-syntax? expanded-expr))
-              (raise-syntax-error "define not allowed here" body))
-            (loop (syntax-map cdr body)
-                  (make-sequence expanded-body expanded-expr))))))
+      (syntax-case body
+        ('() (make-constant #f))
+        (_ (loop for body* = body then (syntax-map cdr body*)
+                 for expanded-expr = (expand (syntax-map car body*) env)
+                 for expanded-body = expanded-expr then (make-sequence expanded-body expanded-expr)
+                 finally (return expanded-body)
+                 when (or (library-define? expanded-expr)
+                          (define-syntax? expanded-expr))
+                   do (raise-syntax-error "define not allowed here" body)
+                 until (syntax-case body*
+                         ((_) #t)
+                         (_ #f))))))
+
+
+    (define (library-ref->string r)
+      (sprintf "{}" (list (library-ref-name r) (library-ref-library r))))
+
+
+    (define compare-library-refs
+      (make-comparer
+        (lambda (r)
+          (hash-bytevector (string->utf8 (library-ref->string r))))
+        (lambda (r1 r2)
+          (cond
+            ((and (symbol=? (library-ref-name r1) (library-ref-name r2))
+                  (equal? (library-ref-library r1) (library-ref-library r2)))
+              0)
+            ((string<? (library-ref->string r1) (library-ref->string r2))
+              -1)
+            (else 1)))))
+
+
+    (define (fix-names name-map expr)
+      (let fix ((expr expr))
+        (match expr
+          ((% %library-ref . _)
+            (lookup name-map expr expr))
+          ((% %constant . _) expr)
+          ((% %lexical-ref . _) expr)
+          ((% %lexical-set ref expr)
+            (make-lexical-set ref (fix expr)))
+          ((% %library-define ref expr)
+            (make-library-define ref (fix expr)))
+          ((% %define-syntax . _) expr)
+          ((% %if test a b)
+            (make-if (fix test) (fix a) (fix b)))
+          ((% %call proc args)
+            (make-call (fix proc) (fix args)))
+          ((% %call-builtin op args)
+            (make-call-builtin op (map fix args)))
+          ((% %sequence a b)
+            (make-sequence (fix a) (fix b)))
+          ((% %lambda args body)
+            (make-lambda args (fix body)))
+          ((% %letrec in-order? names gensyms exprs body)
+            (make-letrec in-order? names gensyms (map fix exprs) (fix body)))
+          (_ (error "unexpected form in fix-names" expr)))))
 
 
     (define (expand-lambda-body body env)
-      (let loop ((body body)
-                 (env env)
-                 (names '())
-                 (gensyms '())
-                 (expressions '()))
+      (let continue ((body body)
+                     (env env)
+                     (names '())
+                     (gensyms '())
+                     (expressions '()))
         (syntax-case body
           ('()
             (if (null? names)
@@ -694,25 +778,39 @@
               (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (make-constant #f))))
           ((expr . expr*)
             (define expanded-expr (expand expr env))
+            (define continue?
+              (let add-bindings ((expanded-expr expanded-expr))
+                (match expanded-expr
+                  ((% %library-define (% %library-ref name _) expr)
+                    (define g (gensym))
+                    (set! env (add-binding name (make-lexical-ref name g) env))
+                    (set! names (cons name names))
+                    (set! gensyms (cons g gensyms))
+                    (set! expressions (cons expr expressions))
+                    #t)
+                  ((% %define-syntax name transformer)
+                    (set! env (add-binding name transformer env))
+                    #t)
+                  ((% %sequence head tail)
+                    (and (add-bindings head)
+                         (add-bindings tail)))
+                  (_ #f))))
             (cond
-              ((library-define? expanded-expr)
-                (let ((name (library-ref-name (library-define-ref expanded-expr)))
-                      (g (gensym)))
-                  (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 (syntax-map cdr body)
-                      (add-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) env)
-                      names
-                      gensyms
-                      expressions))
+              (continue?
+                (continue (syntax-map cdr body) env names gensyms expressions))
+              ((null? names)
+                (expand-lambda-body-rest body env))
               (else
-                (if (null? names)
-                  (expand-lambda-body-rest body env)
-                  (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body env)))))))))
+                (let* ((name-map (loop for name in names
+                                       for g in gensyms
+                                       with m = (make-map compare-library-refs)
+                                       do (set! m (insert m (make-library-ref name (environment-library env))
+                                                            (make-lexical-ref name g)))
+                                       finally (return m)))
+                       (fixed-exprs (loop for expr in expressions
+                                          collect (fix-names name-map expr))))
+                  (make-letrec #t (reverse names) (reverse gensyms) (reverse fixed-exprs)
+                               (expand-lambda-body-rest body env)))))))))
 
 
     (define builtin-lambda
@@ -801,8 +899,11 @@
         (lambda (x env)
           (syntax-case x
             ((_ head tail)
-              (make-sequence (expand head env)
-                             (expand tail env)))
+              (define head* (expand head env))
+              (match head*
+                ((% %define-syntax name transformer)
+                  (set! env (add-binding name transformer env))))
+              (make-sequence head* (expand tail env)))
             (_ (raise-syntax-error "unexpected form in builtin-sequence"))))))