Modify the project structure.

Now the lib directory contains what will eventually end up on the
user's /usr/lib/csc. When I write make install, it will copy all of
the .csc files from lib into the destination lib directory. This means I
can start working on the standard library in lib/scheme.

1 files changed, 801 insertions, 0 deletions

diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc
new file mode 100644
index 0000000..4559991
--- /dev/null
+++ b/lib/csc/macros.csc
@@ -0,0 +1,801 @@
+(define-library (csc macros)
+  (export
+    builtins-environment
+    expand-body
+    macro-syntax-error?
+    macro-transformer?)
+  (import (scheme base)
+          (only (csc assert) assert)
+          (only (csc format) sprintf)
+          (only (csc gensym)
+            gensym
+            gensym=?)
+          (only (csc hash-map)
+            alist->map
+            hash-bytevector
+            insert
+            key-not-found-error?
+            lookup
+            make-comparer
+            make-map
+            map-for-each
+            merge)
+          (only (csc ir1)
+            define-syntax-name
+            define-syntax-transformer
+            define-syntax?
+            lexical-ref-gensym
+            lexical-ref?
+            library-define-expression
+            library-define-ref
+            library-define?
+            library-ref-name
+            library-ref?
+            make-call
+            make-call-builtin
+            make-constant
+            make-define-syntax
+            make-lambda
+            make-letrec
+            make-lexical-ref
+            make-library-define
+            make-library-ref
+            make-sequence
+            sequence-head
+            sequence-tail
+            sequence?)
+          (only (csc list)
+            revappend
+            unzip)
+          (only (csc loop)
+            loop
+            return)
+          (only (csc match) match)
+          (only (csc vec)
+            vec
+            vec-append
+            vec-length
+            vec-ref))
+  (begin
+
+
+    (define-record-type <macro-transformer>
+      (make-macro-transformer transformer)
+      macro-transformer?
+      (transformer transformer-function))
+
+
+    (define-record-type <macro-syntax-error>
+      (make-macro-syntax-error message irritants)
+      macro-syntax-error?
+      (message syntax-error-object-message)
+      (irritants syntax-error-object-irritants))
+
+
+    (define (raise-syntax-error message . irritants)
+      (raise (make-macro-syntax-error message irritants)))
+
+
+    ; symbols is a map with identifiers as keys, and the values can be one of:
+    ; - <lexical-ref>,
+    ; - <library-ref>,
+    ; - or <macro-transformer>.
+    ; The first two correspond to variables bound lexically or from a library,
+    ; and the third represents a macro transformer bound in the
+    ; current context.
+    (define-record-type <environment>
+      (make-environment symbols library)
+      environment?
+      (symbols environment-substitutions)
+      (library environment-library))
+
+
+    (define-record-type <syntax-object>
+      (make-syntax-object expression environment marks)
+      syntax-object?
+      (expression syntax-object-expression)
+      (environment syntax-object-environment)
+      (marks syntax-object-marks))
+
+
+    (define (wrap-syntax expression environment)
+      (if (syntax-object? expression)
+        expression
+        (make-syntax-object expression environment '())))
+
+
+    (define (syntax->expression s)
+      (if (syntax-object? s)
+        (syntax-object-expression s)
+        s))
+
+
+    (define (marks s)
+      (if (syntax-object? s)
+        (syntax-object-marks s)
+        '()))
+
+
+    (define (add-binding identifier binding environment)
+      (make-environment
+        (insert (environment-substitutions environment) identifier binding)
+        (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)
+               (symbol? (syntax-object-expression s)))))
+
+
+    (define (marks=? m1 m2)
+      (and
+        (= (length m1) (length m2))
+        (let loop ((m1 m1)
+                   (m2 m2))
+          (if (null? m1)
+            #t
+            (and (= (car m1) (car m2)) (loop (cdr m1) (cdr m2)))))))
+
+
+    (define (identifier-name s)
+      (if (syntax-object? s)
+        (syntax-object-expression s)
+        s))
+
+
+    (define (bound-identifier=? s1 s2)
+      (and (symbol=? (identifier-name s1) (identifier-name s2))
+           (marks=? (marks s1) (marks s2))))
+
+
+    (define (binding=? b1 b2)
+      (or (and (lexical-ref? b1)
+               (lexical-ref? b2)
+               (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2)))
+          (and (library-ref? b1)
+               (library-ref? b2)
+               (symbol=? (library-ref-name b1) (library-ref-name b2)))
+          (and (macro-transformer? b1)
+               (macro-transformer? b2)
+               (eq? (transformer-function b1) (transformer-function b2)))))
+
+
+    ; free-identifier=? only works on wrapped syntax objects.
+    (define (free-identifier=? s1 s2)
+      (let ((s1-binding (guard (e ((key-not-found-error? e) #f))
+                          (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)
+                 (symbol=? (identifier-name s1) (identifier-name s2)))
+            (binding=? s1-binding s2-binding))))
+
+
+    (define *next-mark* 0)
+
+
+    (define (new-mark)
+      (let ((m *next-mark*))
+        (set! *next-mark* (+ 1 *next-mark*))
+        m))
+
+
+    (define (add-mark mark expression)
+      (make-syntax-object
+        (syntax-object-expression expression)
+        (syntax-object-environment expression)
+        (if (and (pair? (syntax-object-marks expression))
+                 (not (car (syntax-object-marks expression))))  ; Anti-mark.
+          (cdr (syntax-object-marks expression))
+          (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))))))
+
+
+    (define (anti-mark expression)
+      (add-mark #f expression))
+
+
+    (define (decorate marks expression environment)
+      (add-marks marks (wrap-syntax expression environment)))
+
+
+    (define (with-wrap expression parent)
+      (decorate (marks parent) expression (syntax-object-environment parent)))
+
+
+    (define (syntax-map f expr)
+      (with-wrap (f (syntax->expression expr)) expr))
+
+
+    (define-record-type <syntax-case-no-match>
+      (make-syntax-case-no-match)
+      syntax-case-no-match?)
+
+
+    (define-syntax syntax-case-match-pattern
+      (syntax-rules (_ when)
+        ((syntax-case-match-pattern x pattern when condition result result* ...)
+          (syntax-case-match-pattern x pattern
+            (if condition
+              (let () result result* ...)
+              (raise (make-syntax-case-no-match)))))
+        ((syntax-case-match-pattern x _ result result* ...)
+          (let () result result* ...))
+        ((syntax-case-match-pattern x '() result result* ...)
+          (if (null? (syntax->expression x))
+            (let () result result* ...)
+            (raise (make-syntax-case-no-match))))
+        ((syntax-case-match-pattern x (pattern) 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) '() 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* ...))
+              (raise (make-syntax-case-no-match)))))
+        ((syntax-case-match-pattern x ident result result* ...)
+          (let ((ident x)) result result* ...))))
+
+
+    ; Yes, I just defined syntax-case in terms of syntax-rules.
+    ; Are we sure this won't create a black hole?
+    (define-syntax syntax-case
+      (syntax-rules ()
+        ((syntax-case x (arm ...))
+          (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))
+            (guard (e ((syntax-case-no-match? e)
+                        (syntax-case y clause clause* ...)))
+              (syntax-case-match-pattern y arm ...))))))
+
+
+    (define (expand-procedure-call procedure arguments)
+      (let ((expanded-procedure (expand-syntax-object procedure))
+            (expanded-arguments
+              (let loop ((arguments arguments)
+                         (expanded-arguments '()))
+                (syntax-case arguments
+                  ('() (reverse expanded-arguments))
+                  ((argument . rest)
+                    (let ((expanded-argument (expand-syntax-object argument)))
+                      (loop
+                        rest
+                        (cons expanded-argument expanded-arguments))))
+                  (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments))))))
+        (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 (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 (resolve-identifier macro-name)))
+            (if (macro-transformer? macro-body)
+              ((transformer-function macro-body) syntax)
+              (expand-procedure-call macro-name tail))))
+        ((procedure . arguments)
+          (expand-procedure-call procedure arguments))
+        (_ when (identifier? syntax)
+          (let ((binding (resolve-identifier syntax)))
+            (if (macro-transformer? binding)
+              (raise-syntax-error "macro is not allowed in this context" syntax)
+              binding)))
+        (_ when (let ((expr (syntax->expression syntax)))
+                  (or (boolean? expr)
+                      (char? expr)
+                      (number? expr)
+                      (string? expr)
+                      (vector? expr)))
+          (make-constant (syntax->expression syntax)))
+        (_ (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))))
+        ((syntax-object? s) (clean-syntax (syntax->expression s)))
+        (else s)))
+
+
+    (define builtin-quote
+      (make-macro-transformer
+        (lambda (syntax)
+          (syntax-case syntax
+            ((_ datum) (make-constant (clean-syntax datum)))
+            (_ (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))
+      (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)
+      (sprintf "{}" (list (identifier-name i) (marks i))))
+
+
+    (define (hash-identifier i)
+      (hash-bytevector (string->utf8 (identifier-uuid i))))
+
+
+    (define (marks<? m1 m2)
+      (loop for m1* in m1
+            for m2* in m2
+            if (< m1* m2*)
+              return #t
+            else if (> m1* m2*)
+              return #f
+            finally (return (< (length m1) (length m2)))))
+
+
+    (define compare-identifiers
+      (make-comparer
+        hash-identifier
+        (lambda (i1 i2)
+          (cond
+            ((bound-identifier=? i1 i2) 0)
+            ((or (string<? (symbol->string (identifier-name i1)) (symbol->string (identifier-name i2)))
+                 (marks<? (marks i1) (marks i2)))
+              -1)
+            (else 1)))))
+
+
+    (define (alist->substitutions l)
+      (alist->map compare-identifiers l))
+
+
+    (define (is-underscore expression)
+      (and
+        (identifier? expression)
+        (free-identifier=?
+          expression
+          (wrap-syntax
+            '_
+            (make-environment
+              (alist->substitutions
+                (list (cons '_ (make-library-ref '_ '(scheme base)))))
+              '(scheme base))))))
+
+
+    (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 (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 (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)))))
+                  (let ((bindings* (pattern-bindings ellipsis literals p* object)))
+                    (and bindings* (merge bindings bindings*)))))
+              #f)))
+        (underscore when (is-underscore underscore)
+          (alist->substitutions '()))
+        (ident when (identifier? ident)
+          ; 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 '()))
+            (_ #f)))
+        ((p . p*)
+          (syntax-case object
+            ((e . e*)
+              (define pbindings (pattern-bindings ellipsis literals p e))
+              (define p*bindings (pattern-bindings ellipsis literals p* e*))
+              (and pbindings p*bindings (merge pbindings p*bindings)))
+            (_ #f)))
+        (constant
+          (if (equal? (syntax->expression constant) (syntax->expression object))
+            (alist->substitutions '())
+            #f))))
+
+
+    (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 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))
+            (ellipsis-lookup substitutions ellipsis-nesting template)))
+        (_ template)))
+
+
+    (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 all-rules))
+          ((((_ . pattern) template) . tail)
+            (define bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object)))
+            (if bindings
+              ; 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 '... '(scheme base)))))
+          '(scheme base))))
+
+
+    (define builtin-syntax-rules
+      (make-macro-transformer
+        (lambda (syntax-rules-form)
+          (make-macro-transformer
+            (lambda (input-form)
+              (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))))))))
+
+
+    (define builtin-let-syntax
+      (make-macro-transformer
+        (lambda (x)
+          (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))))
+                body))
+            (_ (raise-syntax-error "unexpected form in let-syntax"))))))
+
+
+    (define (split-args-rest formals)
+      (syntax-case formals
+        ('()
+          (values '() #f))
+        ((var . vars) when (identifier? var)
+          (let-values (((args rest) (split-args-rest vars)))
+            (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))))
+
+
+    (define (expand-lambda-body-rest body)
+      (let loop ((body body)
+                 (expanded-body (make-constant #f)))
+        (syntax-case body
+          ('()
+            expanded-body)
+          ((expr . expr*)
+            (define expanded-expr (expand-syntax-object expr))
+            (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))))))
+
+
+    (define (expand-lambda-body body)
+      (let loop ((body body)
+                 (names '())
+                 (gensyms '())
+                 (expressions '()))
+        (syntax-case body
+          ('()
+            (if (null? names)
+              (make-constant #f)
+              (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (make-constant #f))))
+          ((expr . expr*)
+            (define expanded-expr (expand-syntax-object expr))
+            (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))
+                        (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))
+                      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)))))))))
+
+
+    (define builtin-lambda
+      (make-macro-transformer
+        (lambda (x)
+          (syntax-case x
+            ((_ formals . body)
+              (let-values (((args rest) (split-args-rest formals)))
+                (make-lambda
+                  (map (lambda (name)
+                         (make-lexical-ref name (gensym)))
+                       args)
+                  (if rest
+                    (make-lexical-ref rest (gensym))
+                    #f)
+                  (expand-lambda-body body))))
+            (_ (raise-syntax-error "unexpected form in lambda" x))))))
+
+
+    (define builtin-define
+      (make-macro-transformer
+        (lambda (x)
+          (syntax-case x
+            ((_ symbol expression)
+              (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))))))
+
+
+    (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 builtin-call-builtin
+      (make-macro-transformer
+        (lambda (x)
+          (syntax-case x
+            ((_ op . args) when (identifier? op)
+              (make-call-builtin (identifier-name op)
+                                 (let loop ((args args)
+                                            (expanded-args '()))
+                                   (syntax-case args
+                                     ('() (reverse expanded-args))
+                                     ((head . tail)
+                                       (loop tail
+                                             (cons (expand-syntax-object head)
+                                                   expanded-args)))
+                                     (_ (raise-syntax-error "unexpected form in call-builtin"))))))
+            (_ (raise-syntax-error "unexpected form in call-builtin" x))))))
+
+
+    (define builtins-environment
+      (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)
+              (cons 'call-builtin builtin-call-builtin))))
+
+
+    ; 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)
+            if (define-syntax? expanded-expr)
+              do (set! environment
+                   (add-binding
+                     (define-syntax-name expanded-expr)
+                     (define-syntax-transformer expanded-expr)
+                     environment))))))