Fix some bugs in macros, and add list constants.

1 files changed, 158 insertions, 57 deletions

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"))))))