path: root/lib/csc/macros.csc

(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?)" syntax))
        ((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 (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)
                  (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)
      (define keys '())
      (map-for-each (lambda (k v)
                      (set! keys (cons (marks k) keys)))
                    substitutions)
      (let ((n-d-vector (lookup substitutions key)))
        (if (ellipsis-binding? n-d-vector)
          (if (= (ellipsis-binding-nesting-level n-d-vector) (vec-length ellipsis-nesting))
            (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)
      (define keys '())
      (map-for-each (lambda (k v)
                      (set! keys (cons (identifier-name k) keys)))
                    substitutions)
      (syntax-case template
        ('() (with-wrap '() template))
        ((head ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis))
          (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 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)
              (make-define-syntax (identifier-name ident)
                (expand transformer-form env)))
            (_ (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)))))))