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, 0 insertions, 801 deletions

diff --git a/csc/macros.csc b/csc/macros.csc
deleted file mode 100644
index 4559991..0000000
--- a/csc/macros.csc
+++ /dev/null
@@ -1,801 +0,0 @@
-(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))))))