Use a better interface for macros.

2 files changed, 140 insertions, 109 deletions

diff --git a/csc/macros-test.csc b/csc/macros-test.csc
index e4451e7..6ee0596 100644
--- a/csc/macros-test.csc
+++ b/csc/macros-test.csc
@@ -28,6 +28,7 @@
             library-define?
             library-ref?
             make-constant
+            make-define-syntax
             make-lambda
             make-letrec
             make-lexical-ref
@@ -54,28 +55,31 @@
         (cons sequence? %sequence)
         (cons lambda? %lambda)
         (cons letrec? %letrec)
-        (cons gensym? (lambda (x) 'gensym))))
+        (cons gensym? (lambda (x) 'gensym))
+        (cons macro-transformer? (lambda (x) 'transformer))))
 
 
     (test builtin-quote
       (assert-equal
         (make-constant '(test 1 2 3))
-        (expand '(quote (test 1 2 3)) builtins-environment)
+        (expand-body 'main
+          '((quote (test 1 2 3)))
+          builtins-environment)
         transform-ir1))
 
 
     (test builtin-syntax-rules-literal
       (assert-equal
         (make-constant 1)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules (a b)
-                 ((foo a)
-                   0)
-                 ((foo b)
-                   1)))
-             (foo b))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules (a b)
+                  ((foo a)
+                    0)
+                  ((foo b)
+                    1)))
+              (foo b)))
           builtins-environment)
         transform-ir1))
 
@@ -83,12 +87,12 @@
     (test builtin-syntax-rules-underscore
       (assert-equal
         (make-constant 0)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ()
-                 ((foo _) 0)))
-             (foo ignored))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ()
+                  ((foo _) 0)))
+              (foo ignored)))
           builtins-environment)
         transform-ir1))
 
@@ -96,12 +100,12 @@
     (test builtin-syntax-rules-substitution
       (assert-equal
         (make-constant 5)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ()
-                 ((foo x) x)))
-             (foo 5))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ()
+                  ((foo x) x)))
+              (foo 5)))
           builtins-environment)
         transform-ir1))
 
@@ -109,13 +113,13 @@
     (test builtin-syntax-rules-nil
       (assert-equal
         (make-constant 1)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ()
-                 ((foo x) 0)
-                 ((foo) 1)))
-             (foo))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ()
+                  ((foo x) 0)
+                  ((foo) 1)))
+              (foo)))
           builtins-environment)
         transform-ir1))
 
@@ -123,12 +127,12 @@
     (test builtin-syntax-rules-improper-list
       (assert-equal
         (make-constant 1)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ()
-                 ((foo a . b) a)))
-             (foo 1 2 3))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ()
+                  ((foo a . b) a)))
+              (foo 1 2 3)))
           builtins-environment)
         transform-ir1))
 
@@ -136,12 +140,12 @@
     (test builtin-syntax-rules-quoted
       (assert-equal
         (make-constant 'a)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ()
-                 ((foo x) (quote x))))
-             (foo a))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ()
+                  ((foo x) (quote x))))
+              (foo a)))
           builtins-environment)
         transform-ir1))
 
@@ -149,14 +153,14 @@
     (test builtin-syntax-rules-constant
       (assert-equal
         (make-constant 2)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ()
-                 ((foo "abc") 0)
-                 ((foo "def") 1)
-                 ((foo "ghi") 2)))
-             (foo "ghi"))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ()
+                  ((foo "abc") 0)
+                  ((foo "def") 1)
+                  ((foo "ghi") 2)))
+              (foo "ghi")))
           builtins-environment)
         transform-ir1))
 
@@ -164,12 +168,12 @@
     (test builtin-syntax-rules-ellipsis
       (assert-equal
         (make-constant 5)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ()
-                 ((foo x ...) (x ...))))
-             (foo quote 5))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ()
+                  ((foo x ...) (x ...))))
+              (foo quote 5)))
           builtins-environment)
         transform-ir1))
 
@@ -177,12 +181,12 @@
     (test builtin-syntax-rules-ellipsis-improper
       (assert-equal
         (make-constant 5)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ()
-                 ((foo x ... . y) (x ... y))))
-             (foo quote . 5))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ()
+                  ((foo x ... . y) (x ... y))))
+              (foo quote . 5)))
           builtins-environment)
         transform-ir1))
 
@@ -190,13 +194,13 @@
     (test builtin-syntax-rules-ellipsis-zip
       (assert-equal
         (make-constant '((1 . 3) (2 . 4)))
-        (expand
-          '(builtin-let-syntax
-             (zip
-               (syntax-rules ()
-                 ((zip (x ...) (y ...))
-                   (quote ((x . y) ...)))))
-             (zip (1 2) (3 4)))
+        (expand-body 'main
+          '((let-syntax
+              (zip
+                (syntax-rules ()
+                  ((zip (x ...) (y ...))
+                    (quote ((x . y) ...)))))
+              (zip (1 2) (3 4))))
           builtins-environment)
         transform-ir1))
 
@@ -204,13 +208,13 @@
     (test builtin-syntax-rules-ellipsis-nested
       (assert-equal
         (make-constant '(1 2 3 4 5))
-        (expand
-          '(builtin-let-syntax
-             (append
-               (syntax-rules ()
-                 ((append (x ...) ...)
-                   (quote (x ... ...)))))
-             (append (1 2) (3 4) () (5)))
+        (expand-body 'main
+          '((let-syntax
+              (append
+                (syntax-rules ()
+                  ((append (x ...) ...)
+                    (quote (x ... ...)))))
+              (append (1 2) (3 4) () (5))))
           builtins-environment)
         transform-ir1))
 
@@ -218,12 +222,12 @@
     (test builtin-syntax-rules-ellipsis-custom
       (assert-equal
         (make-constant 5)
-        (expand
-          '(builtin-let-syntax
-             (foo
-               (syntax-rules ::: ()
-                 ((foo x :::) (x :::))))
-             (foo quote 5))
+        (expand-body 'main
+          '((let-syntax
+              (foo
+                (syntax-rules ::: ()
+                  ((foo x :::) (x :::))))
+              (foo quote 5)))
           builtins-environment)
         transform-ir1))
 
@@ -240,9 +244,9 @@
                        (test-ref 'c))
                      (test-ref 'd)
                      (make-sequence (make-constant #f) (make-constant 5)))
-        (expand
-          '(lambda
-             (a b c . d) (quote 5))
+        (expand-body 'main
+          '((lambda
+              (a b c . d) (quote 5)))
           builtins-environment)
         transform-ir1))
 
@@ -254,10 +258,24 @@
             (list (make-constant 6)
                   (test-ref 'a))
             (make-sequence (make-constant #f) (make-constant 7))))
-        (expand
-          '(lambda (x)
-            (builtin-define a (quote 6))
-            (builtin-define b a)
-            (quote 7))
+        (expand-body 'main
+          '((lambda (x)
+              (builtin-define a (quote 6))
+              (builtin-define b a)
+              (quote 7)))
+          builtins-environment)
+        transform-ir1))
+
+
+    (test builtin-define-syntax
+      (assert-equal
+        (make-sequence
+          (make-define-syntax 'five 'transformer)
+          (make-constant 5))
+        (expand-body 'main
+          '((define-syntax five
+              (syntax-rules ()
+                ((five _) 5)))
+            (five 6))
           builtins-environment)
         transform-ir1))))
diff --git a/csc/macros.csc b/csc/macros.csc
index 859f72d..288865d 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -1,10 +1,9 @@
 (define-library (csc macros)
   (export
     builtins-environment
-    expand
     expand-body
     macro-syntax-error?
-    make-environment)
+    macro-transformer?)
   (import (scheme base)
           (only (csc assert) assert)
           (only (csc format) sprintf)
@@ -18,6 +17,7 @@
             key-not-found-error?
             lookup
             make-comparer
+            make-map
             map-for-each
             merge)
           (only (csc ir1)
@@ -33,6 +33,7 @@
             library-ref?
             make-call
             make-constant
+            make-define-syntax
             make-lambda
             make-letrec
             make-lexical-ref
@@ -325,9 +326,6 @@
         (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax)))))
 
 
-    ; expand can be thought of as a compiler from Scheme to IR1. Macros
-    ; included in the environment can be used to extend the syntax. Returns an
-    ; IR1 expression.
     (define (expand expression environment)
       (expand-syntax-object (wrap-syntax expression environment)))
 
@@ -740,23 +738,38 @@
             (_ (raise-syntax-error "unexpected form in builtin-define" x))))))
 
 
+    (define builtin-define-syntax
+      (make-macro-transformer
+        (lambda (x)
+          (syntax-case x
+            ((_ ident transformer-form) when (identifier? ident)
+              (make-define-syntax (identifier-name ident)
+                (expand-syntax-object transformer-form)))
+            (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x))))))
+
+
     (define builtins-environment
-      (make-environment
-        (alist->substitutions
-          (list (cons 'syntax-rules builtin-syntax-rules)
-                (cons '_ (make-library-ref '_ '(scheme base)))
-                (cons '... (make-library-ref '... '(scheme base)))
-                (cons 'builtin-let-syntax builtin-let-syntax)
-                (cons 'quote builtin-quote)
-                (cons 'lambda builtin-lambda)
-                (cons 'builtin-define builtin-define)))
-        'main))
+      (alist->substitutions
+        (list (cons 'syntax-rules builtin-syntax-rules)
+              (cons '_ (make-library-ref '_ '(scheme base)))
+              (cons '... (make-library-ref '... '(scheme base)))
+              (cons 'let-syntax builtin-let-syntax)
+              (cons 'quote builtin-quote)
+              (cons 'lambda builtin-lambda)
+              (cons 'builtin-define builtin-define)
+              (cons 'define-syntax builtin-define-syntax))))
 
 
-    ; Expands the body of a library, or top level.
-    (define (expand-body body)
-      (loop with environment = (syntax-object-environment body)
-            for expr in (syntax->expression body)
+    ; Expands the body of a library, or top level. expand-body can be thought
+    ; of as a compiler from Scheme to IR1. Macros included in the environment
+    ; can be used to extend the syntax. Returns an IR1 expression.
+    (define (expand-body name body env)
+      (define ident-map (make-map compare-identifiers))
+      (map-for-each (lambda (k v)
+                      (set! ident-map (insert ident-map k v)))
+        env)
+      (define environment (make-environment ident-map name))
+      (loop for expr in body
             for expanded-expr = (expand expr environment)
             for res = expanded-expr then (make-sequence res expanded-expr)
             finally (return res)