Rewrite most of the compiler.

This represents a major step back in terms of functionality, and amount
of code. The latter I think constitutes a major win. Next steps are to
reimplement syntax-rules, call/cc, and call-with-values.

1 files changed, 0 insertions, 976 deletions

diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc
deleted file mode 100644
index 91bcef1..0000000
--- a/lib/csc/macros.csc
+++ /dev/null
@@ -1,976 +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)
-            %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?
-            lexical-ref-gensym
-            lexical-ref-name
-            lexical-ref?
-            library-define-expression
-            library-define-ref
-            library-define?
-            library-ref-library
-            library-ref-name
-            library-ref?
-            make-call
-            make-call-builtin
-            make-constant
-            make-define-syntax
-            make-if
-            make-lambda
-            make-letrec
-            make-lexical-ref
-            make-lexical-set
-            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 (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 s1-binding
-                 s2-binding
-                 (binding=? s1-binding s2-binding))
-            (and (not s1-binding)
-                 (not s2-binding)
-                 (symbol=? (identifier-name s1) (identifier-name s2))))))
-
-
-    (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)))))
-
-
-    ; 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 ms expression environment)
-      (add-marks ms (wrap-syntax expression environment)))
-
-
-    (define (with-wrap expression parent)
-      (if (syntax-object? parent)
-        (decorate (marks parent) expression (syntax-object-environment parent))
-        expression))
-
-
-    (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 env)
-      (let ((expanded-procedure (expand procedure env))
-            (expanded-arguments
-              (let loop ((arguments arguments)
-                         (expanded-arguments '()))
-                (syntax-case arguments
-                  ('() (reverse expanded-arguments))
-                  ((argument . rest)
-                    (let ((expanded-argument (expand argument env)))
-                      (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 (strip-mark ident)
-      (make-syntax-object
-        (identifier-name ident)
-        (syntax-object-environment ident)
-        (cdr (marks ident))))
-
-
-    (define (lookup-complicated ident env)
-      (define e (environment-substitutions env))
-      (or (lookup e ident #f)
-          (and (pair? (marks ident))
-               (lookup-complicated (strip-mark ident) env))))
-
-
-    (define (resolve-identifier ident lexical-env)
-      (or
-        (lookup-complicated ident lexical-env)
-        (and (syntax-object? ident)
-             (lookup-complicated ident (syntax-object-environment ident)))
-        (make-library-ref (identifier-name ident) (environment-library lexical-env))))
-
-
-    (define (expand syntax env)
-      (syntax-case syntax
-        ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)"))
-        ((macro-name . tail) when (identifier? macro-name)
-          (let ((macro-body (resolve-identifier macro-name env)))
-            (if (macro-transformer? macro-body)
-              ((transformer-function macro-body) syntax env)
-              (expand-procedure-call macro-name tail env))))
-        ((procedure . arguments)
-          (expand-procedure-call procedure arguments env))
-        (_ when (identifier? syntax)
-          (let ((binding (resolve-identifier syntax env)))
-            (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 (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 env)
-          (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 (init-template-bindings ellipsis literals pattern)
-      (guard (e (#t (error "fuck" e)))
-      (syntax-case pattern
-        ((p ellip . p*) when (and (identifier? ellip) (not (matches-literals literals ellip)) (free-identifier=? ellipsis ellip))
-          (merge
-            (map-ellipsis-binding (init-template-bindings ellipsis literals p))
-            (init-template-bindings ellipsis literals p*)))
-        ((head . tail) (merge (init-template-bindings ellipsis literals head)
-                              (init-template-bindings ellipsis literals tail)))
-        (ident when (identifier? ident)
-          (alist->substitutions (list (cons ident (make-ellipsis-binding (vec) 1)))))
-        (_ (alist->substitutions '())))))
-
-
-    (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 (init-template-bindings ellipsis literals p)))
-                (if (< i n-m)
-                  (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)))
-        (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 (scan-for-ellipsis-args ellipsis-nesting substitutions template)
-      (syntax-case template
-        ('() #f)
-        (ident when (identifier? ident)
-          (define binding (lookup substitutions ident #f))
-          (and binding
-               (ellipsis-binding? binding)
-               (loop for i from 0 below (vec-length ellipsis-nesting)
-                     with v = (ellipsis-binding-objects binding)
-                     do (set! v (vec-ref v (vec-ref ellipsis-nesting i)))
-                     finally (return (vec-length v)))))
-        ((head . tail)
-          (define n1 (scan-for-ellipsis-args ellipsis-nesting substitutions head))
-          (define n2 (scan-for-ellipsis-args ellipsis-nesting substitutions tail))
-          (or (and n1 n2
-                   (min n1 n2))
-              n1
-              n2))
-        (_ #f)))
-
-
-    (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))
-          (define num-expansions (scan-for-ellipsis-args ellipsis-nesting substitutions head))
-          (unless num-expansions
-            (raise-syntax-error "no ellipsis variables found in ellipsisized expression" (clean-syntax template)))
-          (define-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)))))
-          (loop for i from 0 below num-expansions
-                with expansion = (with-wrap '() template)
-                do (set! expansion
-                     (syntax-append
-                       expansion
-                       (expand-template
-                         ellipsis
-                         (vec-append ellipsis-nesting i)
-                         substitutions
-                         (with-wrap
-                           (cons
-                             head
-                             extra-ellipses)
-                           template))))
-                finally (return
-                          (syntax-append
-                            expansion
-                            (expand-template ellipsis ellipsis-nesting substitutions tail*)))))
-        ((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 env object)
-      (let loop ((rules all-rules))
-        (syntax-case rules
-          ('() (raise-syntax-error "form did not match any patterns in syntax-rules" (clean-syntax object) (clean-syntax all-rules)))
-          ((((_ . pattern) template) . tail)
-            (define bindings (pattern-bindings ellipsis literals pattern (wrap-syntax (syntax-map cdr object) env)))
-            (if bindings
-              ; We call expand immediately, since macros are
-              ; allowed to be recursive.
-              (expand
-                ; 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))
-                env)
-              (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 env1)
-          ; Merge the lexical and toplevel environments.
-          (define toplevel-env (if (syntax-object? syntax-rules-form)
-                                 (environment-substitutions (syntax-object-environment syntax-rules-form))
-                                 (make-map compare-identifiers)))
-          (set! syntax-rules-form
-            (make-syntax-object (syntax->expression syntax-rules-form)
-                                (make-environment
-                                  (merge toplevel-env (environment-substitutions env1))
-                                  (environment-library env1))
-                                (marks syntax-rules-form)))
-          (make-macro-transformer
-            (lambda (input-form env)
-              (syntax-case syntax-rules-form
-                ((_ ellipsis literals . rules) when (identifier? ellipsis)
-                  (syntax-match ellipsis literals rules env input-form))
-                ((_ literals . rules)
-                  (syntax-match default-ellipsis literals rules env input-form))
-                (_ (raise-syntax-error "unexpected form in syntax-rules" (clean-syntax syntax-rules-form)))))))))
-
-
-    (define builtin-let-syntax
-      (make-macro-transformer
-        (lambda (x env)
-          (syntax-case x
-            ((_ 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)
-      (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 continue ((body body)
-                     (env env)
-                     (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 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
-              (continue?
-                (continue (syntax-map cdr body) env names gensyms expressions))
-              ((null? names)
-                (expand-lambda-body-rest body env))
-              (else
-                (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
-      (make-macro-transformer
-        (lambda (x env)
-          (syntax-case x
-            ((_ args . body) when (identifier? args)
-              (define ref (make-lexical-ref (identifier-name args) (gensym)))
-              (set! env (add-binding args ref env))
-              (make-lambda
-                ref
-                (expand-lambda-body body env)))))))
-
-
-    (define builtin-define
-      (make-macro-transformer
-        (lambda (x env)
-          (syntax-case x
-            ((_ symbol expression) when (identifier? symbol)
-              (make-library-define
-                (make-library-ref
-                  (identifier-name symbol)
-                  (environment-library env))
-                (expand expression env)))
-            (_ (raise-syntax-error "unexpected form in builtin-define" (clean-syntax x)))))))
-
-
-    (define builtin-define-syntax
-      (make-macro-transformer
-        (lambda (x env)
-          (syntax-case x
-            ((_ ident transformer-form) when (identifier? ident)
-              (define transformer*
-                (make-macro-transformer
-                  (lambda (x env)
-                    ((transformer-function transformer) x env))))
-              (define transformer
-                (expand transformer-form (add-binding ident transformer* env)))
-              (make-define-syntax (identifier-name ident)
-                transformer))
-            (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x))))))
-
-
-    (define builtin-call-builtin
-      (make-macro-transformer
-        (lambda (x env)
-          (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 head env)
-                                                   expanded-args)))
-                                     (_ (raise-syntax-error "unexpected form in call-builtin"))))))
-            (_ (raise-syntax-error "unexpected form in call-builtin" x))))))
-
-
-    (define builtin-set
-      (make-macro-transformer
-        (lambda (x env)
-          (syntax-case x
-            ((_ var value) when (identifier? var)
-              (define var* (expand var env))
-              (define val* (expand value env))
-              (cond
-                ((lexical-ref? var*)
-                  (make-lexical-set var* val*))
-                ((library-ref? var*)
-                  (make-library-define var* val*))
-                (else
-                  (error "unknown variable form in builtin-set" var*))))
-            (_ (raise-syntax-error "unexpected form in builtin-set" x))))))
-
-
-    (define builtin-if
-      (make-macro-transformer
-        (lambda (x env)
-          (syntax-case x
-            ((_ test true false)
-              (make-if (expand test env)
-                (expand true env)
-                (expand false env)))
-            (_ (raise-syntax-error "unexpected form in builtin-if"))))))
-
-
-    (define builtin-sequence
-      (make-macro-transformer
-        (lambda (x env)
-          (syntax-case x
-            ((_ head tail)
-              (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"))))))
-
-
-    (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 'builtin-lambda builtin-lambda)
-              (cons 'builtin-define builtin-define)
-              (cons 'define-syntax builtin-define-syntax)
-              (cons 'call-builtin builtin-call-builtin)
-              (cons 'set! builtin-set)
-              (cons 'builtin-if builtin-if)
-              (cons 'builtin-sequence builtin-sequence))))
-
-
-    ; 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))
-      (if (null? body)
-        (make-constant #f)
-        (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)))))))