;;;=================================================================================
;;;
;;; R6RS Macros and R6RS libraries:
;;;
;;;   Copyright (c) 2006 Andre van Tonder
;;;
;;;   Copyright statement at http://srfi.schemers.org/srfi-process.html
;;;
;;;=================================================================================
;;;
;;;=================================================================================
;;;
;;; PORTING COMMENTS:
;;;
;;;=================================================================================
;;;
;;; The file compat-*.scm has to be loaded before loading this expander.
;;;
;;; Compat-*.scm should supply whatever is missing from your implementation of
;;; the following.
;;;
;;; NOTE: A purely r5rs approximation is provided that can be used
;;;       as a customization template.
;;;
;;;  - Procedures assertion-violation, memp, filter, for-all, pretty-print,
;;;    file-exists? and delete-file.
;;;  - Procedures make-record-type-descriptor, make-record-constructor-descriptor,
;;;    record-constructor, record-predicate and record-accessor.
;;;  - Procedure (ex:unique-token) that provides a numeric GUID string once per run.
;;;  - Single-character string ex:guid-prefix.  No builtin may start with this.
;;;  - Single-character string ex:free-prefix.  No builtin may start with this.
;;;  - Value ex:undefined representing the letrec black hole value.
;;;  - Symbol ex:undefined-set! representing the corresponding setter.
;;;
;;; HOOKS:
;;; ------
;;;
;;; For compiler and REPL integration, see the procedures
;;;
;;;   - ex:REPL             : Use this as REPL evaluator
;;;   - ex:EXPAND-FILE      : Use this to expand a file containing libraries and/or
;;;                           toplevel programs before loading into an r5rs-type system
;;;                           or feeding result to an r5rs-type compiler
;;;   - ex:EXPAND-R5RS-FILE : For expanding r5rs-like toplevel files in a given environment.
;;;                           Mainly provided so this expander can expand itself, but may
;;;                           have other uses.  See the documentation below where the
;;;                           procedure is defined.  See also the note below on
;;;                           metacircularity.
;;;
;;; COMPILATION:
;;; ------------
;;;
;;; Example compilation scripts can be seen in examples.scm.
;;; The expander expands everything to r5rs toplevel definitions
;;; and expressions, so the expanded code should be compilable
;;; with an r5rs compiler.
;;;
;;; REPL:
;;; -----
;;;
;;; Example REPL interaction can be seen in examples.scm.
;;;
;;; The REPL goes beyond r6rs to allow incremental development in
;;; a toplevel environment.
;;; The developer can freely change, replace and make new toplevel
;;; definitions, evaluate toplevel expressions, enter libraries and
;;; <toplevel programs> at the prompt, as well as import libraries
;;; into the toplevel environment.
;;;
;;; The appropriate primitive is ex:repl, and an example
;;; session where I do all these things is in examples.scm.
;;; All an integrator would need to do is to automate the call to
;;; ex:repl in the development system so users don't have to type
;;; (ex:repl '( <code> )) at each prompt.
;;;
;;; FORMAT OF EXPANDED CODE:
;;; ------------------------
;;;
;;; We expand internal and library definitions, as well as letrec and letrec*
;;; completely to lambda and set! (or more accurately, whatever ex:undefined-set!
;;; is set to).  This seems to be the preferred input format for Larceny.
;;; It would be very easy to abstract or change, but we don't bother for now
;;; until implementors other than Larceny show a serious interest.
;;;
;;; METACIRCULARITY AND BOOTSTRAPPING:
;;; ----------------------------------
;;;
;;; The expander relies on r5rs syntax-rules and letrec-syntax
;;; and should run in a correct r5rs system, but if the reliance
;;; on macros is a problem for you, don't worry, be metacircular.
;;; In other words, if you don't have r5rs macros, you may use the
;;; provided fully expanded version to bootstrap modifications by
;;; feeding the expander to its expanded self.  Here is how to do
;;; it:
;;;
;;;   (load "runtime.scm")
;;;   (load "standard-libraries.0.exp")  ; expanded version
;;;   (load "expander.0.exp")            ; expanded version
;;;   (ex:expand-file "standard-libraries.scm" "standard-libraries.1.exp")
;;;   (ex:expand-r5rs-file "expander.scm" "expander.1.exp" (ex:environment '(rnrs base)))
;;;
;;; SIZE OF OBJECT CODE:
;;; --------------------
;;;
;;; The minimal runtime prerequisites has been separated into a small
;;; include file runtime.scm, which is all that needs to be present for
;;; executing an expanded program that does not contain runtime
;;; uses the exports of (rnrs syntax-case) or (rnrs eval).
;;; See examples.scm for demonstrations of this.
;;;
;;; Expanded libraries may contain identifier environment information
;;; and visit code that could adversely affect the runtime binary size.
;;; This is not a big problem, for several reasons:
;;; First, note that this information is only present in libraries that
;;; define macros.
;;; Second, the size of the environments saved in the object code can
;;; usually be reduced dramatically by using 'only' imports.
;;; Third, the environments, as well as the visit code, can be discarded
;;; completely from the runtime image of a fully expanded program not
;;; using (rnrs syntax-case) or (rnrs eval) at runtime.  It is very
;;; easy to write a little build script that does this.
;;;
;;; The only reason for including this information now in the object code
;;; of a library is to support separate compilation, so one can expand a
;;; library in one session and use macros from the /expanded/ library to
;;; expand another library or program in a new session.  The customization
;;; to get rid of separate compilation, if desired, would be trivial.

;;=================================================================================
;;
;; IMPORTS:
;;
;;=================================================================================
;;
;; The include file runtime.scm has to be loaded before loading this expander
;;
;;=================================================================================
;;
;; EXPORTS:
;;
;;=================================================================================

;; Direct exports:

(define ex:make-variable-transformer #f)
(define ex:identifier?               #f)
(define ex:bound-identifier=?        #f)
(define ex:free-identifier=?         #f)
(define ex:generate-temporaries      #f)
(define ex:datum->syntax             #f)
(define ex:syntax->datum             #f)
(define ex:environment               #f)
(define ex:environment-bindings      #f)
(define ex:eval                      #f)
(define ex:syntax-violation          #f)

;; System exports:

(define ex:expand-file               #f)
(define ex:repl                      #f)
(define ex:expand-r5rs-file          #f)

;; Indirect exports:

(define ex:invalid-form              #f)
(define ex:register-macro!           #f)
(define ex:syntax-rename             #f)
(define ex:map-while                 #f)
(define ex:dotted-length             #f)
(define ex:dotted-butlast            #f)
(define ex:dotted-last               #f)
(define ex:uncompress                #f)
(define ex:free=?                    #f)

(letrec-syntax
    ;; Not everyone has the same parameter API:

    ((fluid-let
      (syntax-rules ()
        ((fluid-let () be ...)
         (begin be ...))
        ((fluid-let ((p0 e0) (p e) ...) be ...)
         (let ((saved p0))
           (set! p0 e0)
           (call-with-values (lambda ()
                               (fluid-let ((p e) ...) be ...))
             (lambda results
               (set! p0 saved)
               (apply values results)))))))

     ;; A trivial but extremely useful s-expression matcher.
     ;; Implements a subset of Wright's matcher's patterns.
     ;; Includes additional (syntax id) pattern that matches
     ;; if input is identifier? and free=? to 'id.

     (match
      (syntax-rules ()
        ((match (op arg ...) clause ...)
         (let ((x (op arg ...)))
           (match x clause ...)))
        ((match x)
         (ex:invalid-form x))
        ((match x (pat e ...) clause ...)
         (matcher "base" pat "done" x (e ...) (lambda () (match x clause ...))))))

     (matcher
      (syntax-rules (- ..0 ? syntax)
        ((matcher "base" () k arg ...)
         (matcher k (lambda (x sk fk) (if (null? x) (sk) (fk))) () arg ...))
        ((matcher "base" - k arg ...)
         (matcher k (lambda (x sk fk) (sk)) () arg ...))
        ((matcher "base" (syntax id) k arg ...)
         (matcher k
                  (lambda (x sk fk)
                    (if (ex:free=? x 'id) (sk) (fk)))
                  ()
                  arg ...))
        ((matcher "base" (? pred? p) k arg ...)
         (matcher "base" p "predicate" pred? k arg ...))
        ((matcher "predicate" code vars pred? k arg ...)
         (matcher k
                  (lambda (x sk fk)
                    (if (pred? x)
                        (code x sk fk)
                        (fk)))
                  vars
                  arg ...))
        ((matcher "base" (p1 ..0 tailp ...) k arg ...)
         (matcher "base" p1 "ellipses" (tailp ...) k arg ...))
        ((matcher "ellipses" code vars (tailp ...) k arg ...)
         (matcher k
                  (lambda (x sk fk)
                    (let loop ((x x)
                               (result '()))
                      (define (match-tail)
                        (match x
                          ((tailp ...)
                           (apply sk (if (null? result)
                                         (map (lambda (ignore) '()) 'vars)
                                         (apply map list (reverse result)))))
                          (- (fk))))
                      (cond ((null? x) (match-tail))
                            ((pair? x)
                             (code (car x)
                                   (lambda car-vars
                                     (loop (cdr x) (cons car-vars result)))
                                   match-tail))
                            (else (fk)))))
                  vars
                  arg ...))
        ((matcher "base" (p1 . p2) k arg ...)
         (matcher "base" p1 "pair" p2 k arg ...))
        ((matcher "pair" car-code car-vars p2 k arg ...)
         (matcher "base" p2 "pair-done" car-code car-vars k arg ...))
        ((matcher "pair-done" cdr-code (cdr-var ...) car-code (car-var ...) k arg ...)
         (matcher k
                  (lambda (x sk fk)
                    (if (pair? x)
                        (car-code (car x)
                                  (lambda (car-var ...)
                                    (cdr-code (cdr x)
                                              (lambda (cdr-var ...)
                                                (sk car-var ... cdr-var ...))
                                              fk))
                                  fk)
                        (fk)))
                  (car-var ... cdr-var ...)
                  arg ...))
        ((matcher "base" #(p ..0) k arg ...)
         (matcher "base" (p ..0) "vector" k arg ...))
        ((matcher "vector" list-code vars k arg ...)
         (matcher k
                  (lambda (x sk fk)
                    (if (vector? x)
                        (list-code (vector->list x)
                                   sk
                                   fk)
                        (fk)))
                  vars
                  arg ...))
        ((matcher "base" id k arg ...)
         (matcher k (lambda (x sk fk) (sk x)) (id) arg ...))
        ((matcher "done" code vars x (e ...) fk)
         (code x (lambda vars e ...) fk)))))

  (let* (;;==========================================================================
         ;;
         ;; Dynamic parameters:
         ;;
         ;;==========================================================================

         ;; toplevel REPL bindings to be initialized later
         (*toplevel-env*     #f)
         ;; current lexical environment to be initialized later
         (*usage-env*        #f)
         ;; current phase
         (*phase*            0)
         ;; current color for painting identifiers upon renaming to be initialized
         (*color*            #f)
         ;; global table mapping <binding name> of keyword to <macro> object
         (*macro-table*      '())
         ;; maps <symbolic key> of reflected environment to actual <environment>
         (*env-table*        '())
         ;; current library name as list of symbols or '() for toplevel
         (*current-library*  '())
         ;; car of this records bindings already referenced in current body
         ;; for detecting when later definitions may violate lexical scope
         (*used*             (list '()))
         ;; history trace for error reporting
         (*trace*            '())
         ;; whether expanded library introduces identifiers via syntax
         ;; expressions - if not, save lots of space by not including
         ;; env-table in object code
         (*syntax-reflected* #f)

         ;;==========================================================================
         ;;
         ;; Identifiers:
         ;;
         ;;==========================================================================

         ;; <name>             ::= <symbol>
         ;; <colors>           ::= (<color> ...)
         ;; <transformer-envs> ::= (<env> ...)
         ;; <displacement>     ::= <integer>
         ;; <maybe-library>    ::= (<symbol> ...) | #f
         ;;
         ;; where
         ;;   <name>             : The symbolic name of the identifier in the source.
         ;;   <colors>           : Each time an introduced identifier is renamed, a fresh
         ;;                        color gets prepended to its <colors>.
         ;;   <transformer-envs> : List of reflected transformer environments.
         ;;                        The environment (env-reify (car <transformer-envs>)) was the
         ;;                        usage environment valid during expansion of any (syntax id)
         ;;                        expression whose evaluation introduced this identifier, while
         ;;                        (cdr <transformer-envs>) are in turn the reflected
         ;;                        <transformer-envs> of the original id.
         ;;   <displacement>     : Integer that keeps track of shifts in phases
         ;;                        between transformer and usage sites of identifier.
         ;;   <maybe-library>    : Library name if identifier was introduced by evaluation of
         ;;                        a (syntax ...) expression, otherwise #f.
         ;;                        The empty name '() is used for toplevel.

         (:identifier
          (make-record-type-descriptor 'identifier #f #f #f #f
                                       '#((immutable name)
                                          (immutable colors)
                                          (immutable transformer-envs)
                                          (immutable displacement)
                                          (immutable maybe-library))))
         (make-identifier
          (record-constructor (make-record-constructor-descriptor :identifier #f #f))))

    ;; We sequenced stuff in the let* above because r5rs internal
    ;; definitions use letrec semantics and cannot be used for sequencing.

    (define identifier?         (record-predicate :identifier))
    (define id-name             (record-accessor :identifier 0))
    (define id-colors           (record-accessor :identifier 1))
    (define id-transformer-envs (record-accessor :identifier 2))
    (define id-displacement     (record-accessor :identifier 3))
    (define id-maybe-library    (record-accessor :identifier 4))

    (define (id-library id)
      (or (id-maybe-library id)
          *current-library*))

    (define (bound-identifier=? x y)
      (check x identifier? 'bound-identifier=?)
      (check y identifier? 'bound-identifier=?)
      (and (eq? (id-name x)
                (id-name y))
           (equal? (id-colors x)
                   (id-colors y))))

    ;; As required by r6rs, when this returns, the result is #t
    ;; if and only if the two identifiers resolve to the same binding.
    ;; It also treats unbound identifiers specially.
    ;; As allowed by R6RS, included phase checking of arguments.
    ;; An out of phase error is raised if the comparison succeeds but
    ;; either argument is out of phase.  This is sufficient to ensure
    ;; that literals such as ... in syntax-case are used in the correct phase.
    ;; For more dicussion on this choice, see the readme and the examples file.

    (define (free-identifier=? x y)
      (check x identifier? 'free-identifier=?)
      (check y identifier? 'free-identifier=?)
      (let  ((bx (binding x))
             (by (binding y)))
        (let ((result (if bx
                          (and by
                               (eq? (binding-name bx)
                                    (binding-name by)))
                          (and (not by)
                               (eq? (id-name x)
                                    (id-name y))))))
          (and result
               bx
               (begin (check-binding-level x bx)
                      (check-binding-level y by)))
          ;; A later definition in the same body can only change
          ;; #t to #f, so only record usage in that case.
          (and result
               (register-use! x bx)
               (register-use! y by))
          result)))

    ;; For internal use

    (define (free=? x symbol)
      (and (identifier? x)
           (let  ((bx (binding x)))
             (let ((result
                    (and bx
                         (eq? (binding-name bx) symbol))))
               (and result
                    bx
                    (check-binding-level x bx))
               (and result
                    (register-use! x bx))
               result))))

    ;;==========================================================================
    ;;
    ;; Infrastructure for generated names:
    ;;
    ;;==========================================================================

    ;; Generate-guid returns a fresh symbol that has a globally
    ;; unique external representation and is read-write invariant.
    ;; Your local gensym will probably not satisfy both conditions.
    ;; Prefix makes it disjoint from all builtins.
    ;; Uniqueness is important for incremental and separate expansion.

    (define generate-guid
      (let ((token (ex:unique-token))
            (ticks 0))
        (lambda (symbol)
          (set! ticks (+ ticks 1))
          (string->symbol
           (string-append ex:guid-prefix
                          (symbol->string symbol)
                          "~"
                          token
                          "~"
                          (number->string ticks))))))

    ;; Used to generate user program toplevel names.
    ;; Prefix makes it disjoint from all builtins.
    ;; Prefix makes it disjoint from output of generate-guid.
    ;; Must be read-write invariant.

    (define (make-free-name symbol)
      (string->symbol (string-append ex:free-prefix (symbol->string symbol))))

    ;;=========================================================================
    ;;
    ;; Colors to paint identifiers with:
    ;;
    ;;=========================================================================

    ;; Returns <color> ::= globally unique symbol

    (define (generate-color)
      (generate-guid 'c))

    ;;=========================================================================
    ;;
    ;; Bindings:
    ;;
    ;;=========================================================================

    ;; <binding> ::= (variable         <binding-name> (<level> ...) <mutable?>  <library-name>)
    ;;            |  (macro            <binding-name> (<level> ...) #f          <library-name>)
    ;;            |  (pattern-variable <binding-name> (<level> ...) <dimension> <library-name>)
    ;;            |  #f  (out of context binding from another library)
    ;; <mutable> ::= #t | #f
    ;; <dimension> ::= 0 | 1 | 2 | ...
    ;; <binding-name> ::= <symbol> uniquely identifying binding.
    ;; <binding-name> is used for free-identifier=? comparison.
    ;; For variable and pattern variable bindings, it is the same
    ;; as the symbol emitted for the binding in the object code.
    ;; For macro bindings, it is the key for looking up the transformer
    ;; in the global macro table.

    (define (make-binding type name levels content library)
      (list type name levels content library))

    (define (binding-type b)           (car b))
    (define (binding-name b)           (cadr b))
    (define (binding-levels b)         (caddr b))
    (define (binding-mutable? b)       (cadddr b))
    (define (binding-dimension b)      (cadddr b))
    (define (binding-library b)        (car (cddddr b)))
    (define (binding-mutable-set! b x) (set-car! (cdddr b) x))

    ;; Looks up binding first in usage environment and
    ;; then in attached transformer environments.
    ;; Toplevel forward references are treated specially.
    ;; Returns <binding> | #f if unbound.

    (define (binding id)
      (let ((name (id-name id)))
        (let loop ((env    *usage-env*)
                   (envs   (id-transformer-envs id))
                   (colors (id-colors id)))
          (or (env-lookup (cons name colors) env)
              (and (pair? envs)
                   (loop (env-reify (car envs))
                         (cdr envs)
                         (cdr colors)))))))

    ;;=========================================================================
    ;;
    ;; Mapping in environment: ((<name> <color> ...) . <binding>)
    ;;
    ;;=========================================================================

    ;; Generates a local mapping at the current meta-level
    ;; that can be added to the usage environment.

    (define (make-local-mapping type id content)
      (cons (cons (id-name id)
                  (id-colors id))
            (make-binding type
                          (generate-guid (id-name id))
                          (list (source-level id))
                          content
                          *current-library*)))

    ;; Toplevel binding forms use as binding name the free name
    ;; so that source-level forward references will work in REPL.
    ;; If identifier is macro-generated, bind it with a fresh name.
    ;; This ensures that generated toplevel defines are not visible
    ;; from toplevel source code, thus approximating the behaviour
    ;; of generated internal definitions.

    (define (make-toplevel-mapping type id content)
      (if (null? (id-colors id))
          (cons (cons (id-name id)
                      (id-colors id))
                (make-binding type
                              (make-free-name (id-name id))
                              '(0)
                              content
                              *current-library*))
          (make-local-mapping type id content)))

    ;;=========================================================================
    ;;
    ;; Infrastructure for binding levels:
    ;;
    ;;=========================================================================

    (define (source-level id)
      (- *phase* (id-displacement id)))

    (define (check-binding-level id binding)
      (if binding
          (or (memv (source-level id)
                    (binding-levels binding))
              (syntax-violation
               "invalid reference"
               (string-append "Attempt to use binding of " (symbol->string (id-name id))
                              " in library (" (list->string (id-library id) " ")
                              ") at invalid level " (number->string (source-level id))
                              ".  Binding is only available at levels: "
                              (list->string (binding-levels binding) " "))
               id))
          (or (and (null? (id-library id))
                   (= *phase* 0))
              (syntax-violation
               "invalid reference"
               (string-append "No binding available for " (symbol->string (id-name id))
                              " in library (" (list->string (id-library id) " ") ")")

               id))))

    ;;=========================================================================
    ;;
    ;; Environments:
    ;;
    ;;=========================================================================

    ;; An environment is a list of frames.
    ;;
    ;;   <environment> ::= (<frame> ...)
    ;;   <frame>       ::= (list ((<key> . <value>) ...))
    ;;
    ;; Keys must be comparable with equal? and unique in each frame.
    ;; Frames can be added, or the leftmost frame can be destructively
    ;; updated in the case of binding constructs such as bodies where
    ;; definitions are incrementally discovered.

    (define (make-null-env) '())
    (define (make-unit-env) (env-extend '() (make-null-env)))

    ;; Adds a new frame containing mappings to env.

    (define (env-extend mappings env)
      (cons (list mappings) env))

    ;; Destructively extends the leftmost frame in env.

    (define (env-extend! mappings env)
      (let ((frame (car env)))
        (set-car! frame (append mappings (car frame)))))

    ;; Returns <object> | #f

    (define (env-lookup key env)
      (and (pair? env)
           (or (let ((probe (assoc key (caar env))))
                 (and probe
                      (or (cdr probe)
                          (syntax-violation
                           #f "Out of context reference to identifier" (car key)))))
               (env-lookup key (cdr env)))))

    ;; Is id already bound in leftmost frame?

    (define (duplicate? id env)
      (assoc (cons (id-name id)
                   (id-colors id))
             (caar env)))

    ;; Returns a single-symbol <key> representing an
    ;; environment that can be included in object code.

    (define (env-reflect env)
      (cond ((and (not (null? *env-table*))      ; +++
                  (eq? env (cdar *env-table*)))  ; +++
             (caar *env-table*))                 ; +++
            (else
             (let ((key (generate-guid 'env)))
               (set! *env-table*
                     (cons (cons key env)
                           *env-table*))
               key))))

    ;; The inverse of the above.

    (define (env-reify key-or-env)
      (if (symbol? key-or-env)
          (cdr (assq key-or-env *env-table*))
          key-or-env))

    ;; This makes a much smaller external representation of an
    ;; environment table by factoring shared structure.

    (define (compress env-table)
      (let ((frame-table '())
            (count 0))
        (for-each (lambda (entry)
                    (for-each (lambda (frame)
                                (if (not (assq frame frame-table))
                                    (begin
                                      (set! frame-table (cons (cons frame count) frame-table))
                                      (set! count (+ 1 count)))))
                              (cdr entry)))
                  env-table)
        (cons (map (lambda (env-entry)
                     (cons (car env-entry)
                           (map (lambda (frame)
                                  (cdr (assq frame frame-table)))
                                (cdr env-entry))))
                   env-table)
              (map (lambda (frame-entry)
                     (cons (cdr frame-entry)
                           (list (map (lambda (mapping)
                                        (cons (car mapping)
                                              (let ((binding (cdr mapping)))
                                                (case (binding-type binding)
                                                  ;; Pattern variable bindings can never be
                                                  ;; used in client, so don't waste space.
                                                  ;; Should really do the same with all local
                                                  ;; bindings, but there are usually much less
                                                  ;; of them, so don't bother for now.
                                                  ((pattern-variable) #f) ; +++
                                                  (else binding)))))
                                      (caar frame-entry)))))
                   frame-table))))

    (define (uncompress compressed-env-table)
      (map (lambda (env-entry)
             (cons (car env-entry)
                   (map (lambda (frame-abbrev)
                          (cdr (assv frame-abbrev (cdr compressed-env-table))))
                        (cdr env-entry))))
           (car compressed-env-table)))

    ;;=========================================================================
    ;;
    ;; Syntax-reflect and syntax-rename:
    ;;
    ;; This is the basic building block of the implicit renaming mechanism for
    ;; maintaining hygiene.  Syntax-reflect generates the expanded code for
    ;; (syntax id), including the expand-time environment in the
    ;; external representation.  It expands to syntax-rename, which performs
    ;; the implicit renaming when this expanded code is eventually run.
    ;; The displacement computations calculate the difference between the
    ;; usage phase and the transformer phase.
    ;;
    ;;=========================================================================

    (define (syntax-reflect id)
      (set! *syntax-reflected* #t)
      `(ex:syntax-rename ',(id-name id)
                         ',(id-colors id)
                         ',(cons (env-reflect *usage-env*)
                                 (id-transformer-envs id))
                         ,(- *phase* (id-displacement id) 1)
                         ',(id-library id)))

    (define (syntax-rename name colors transformer-envs transformer-phase source-library)
      (make-identifier name
                       (cons *color* colors)
                       transformer-envs
                       (- *phase* transformer-phase)
                       source-library))

    ;;=====================================================================
    ;;
    ;; Capture and sexp <-> syntax conversions:
    ;;
    ;;=====================================================================

    (define (datum->syntax tid datum)
      (check tid identifier? 'datum->syntax)
      (sexp-map (lambda (leaf)
                  (cond ((symbol? leaf)
                         (make-identifier leaf
                                          (id-colors tid)
                                          (id-transformer-envs tid)
                                          (id-displacement tid)
                                          (id-maybe-library tid)))
                        (else leaf)))
                datum))

    (define (syntax->datum exp)
      (sexp-map (lambda (leaf)
                  (cond ((identifier? leaf) (id-name leaf))
                        ((symbol? leaf)
                         (assertion-violation 'syntax->datum "A symbol is not a valid syntax object" leaf))
                        (else leaf)))
                exp))

    ;; Fresh identifiers:

    (define (generate-temporaries ls)
      (check ls list? 'generate-temporaries)
      (map (lambda (ignore)
             (make-identifier 'temp
                              (list (generate-color))
                              (list (make-null-env))
                              *phase*
                              #f))
           ls))

    ;; For use internally as in the explicit renaming system.

    (define (rename type symbol)
      (make-identifier symbol
                       (list *color*)
                       (list (env-extend
                              (list (cons (cons symbol '())
                                          (make-binding type symbol '(0) #f '())))
                              (make-null-env)))
                       *phase*
                       #f))

    ;;=========================================================================
    ;;
    ;; Macro objects:
    ;;
    ;;=========================================================================

    ;; Expanders are system macros that fully expand
    ;; their arguments to core Scheme, while
    ;; transformers and variable transformers are
    ;; user macros.

    ;; <type> ::= expander | transformer | variable-transformer

    (define (make-macro type proc)
      (list type proc))
    (define macro-type car)
    (define macro-proc cadr)

    (define (make-expander proc)             (make-macro 'expander proc))
    (define (make-transformer proc)          (make-macro 'transformer proc))
    (define (make-variable-transformer proc) (make-macro 'variable-transformer proc))

    (define (make-user-macro procedure-or-macro)
      (if (procedure? procedure-or-macro)
          (make-transformer procedure-or-macro)
          procedure-or-macro))

    ;; Returns <macro>.

    (define (binding->macro binding t)
      (cond ((assq (binding-name binding) *macro-table*) => cdr)
            (else
             (syntax-violation
              #f "Reference to macro keyword out of context" t))))

    ;; Registering macro.

    (define (register-macro! binding-name procedure-or-macro)
      (set! *macro-table* (cons (cons binding-name (make-user-macro procedure-or-macro))
                                *macro-table*)))

    ;; Calls a macro with a new color.

    (define (invoke-macro macro t)
      (set! *color* (generate-color))
      ((macro-proc macro) t))

    ;;=========================================================================
    ;;
    ;; Expander dispatch:
    ;;
    ;;=========================================================================

    (define (expand t)
      (fluid-let ((*trace* (cons t *trace*)))
        (let ((binding (operator-binding t)))
          (cond (binding (case (binding-type binding)
                           ((macro)
                            (let ((macro (binding->macro binding t)))
                              (let ((expanded-once (invoke-macro macro t)))
                                (case (macro-type macro)
                                  ((expander) expanded-once)
                                  (else
                                   (expand expanded-once))))))
                           ((variable)
                            (check-implicit-import-of-mutable binding t)
                            (if (list? t)
                                (cons (binding-name binding)
                                      (map expand (cdr t)))
                                (binding-name binding)))
                           ((pattern-variable)
                            (syntax-violation #f "Pattern variable used outside syntax template" t))))
                ((list? t)       (map expand t))
                ((identifier? t) (make-free-name (id-name t)))
                ((pair? t)       (syntax-violation #f "Invalid procedure call syntax" t))
                ((symbol? t)     (syntax-violation #f "Symbol may not appear in syntax object" t))
                (else t)))))

    ;; Only expands while t is a user macro invocation.
    ;; Used by expand-lambda to detect internal definitions.

    (define (head-expand t)
      (fluid-let ((*trace* (cons t *trace*)))
        (let ((binding (operator-binding t)))
          (cond (binding (case (binding-type binding)
                           ((macro)
                            (let ((macro (binding->macro binding t)))
                              (case (macro-type macro)
                                ((expander) (values t binding))
                                (else
                                 (head-expand (invoke-macro macro t))))))
                           (else (values t binding))))
                (else (values t binding))))))

    ;; Returns binding of identifier in operator position | #f if none.
    ;; Singleton identifiers are also considered operators here for
    ;; the purpose of discovering identifier macros and variables.
    ;; Checks level and registers as a use.

    (define (operator-binding t)
      (let ((operator (if (pair? t) (car t) t)))
        (and (identifier? operator)
             (let ((binding (binding operator)))
               (check-binding-level operator binding)
               (register-use! operator binding)
               binding))))

    ;; We cannot implicitly import a mutable variable.

    (define (check-implicit-import-of-mutable binding t)
      (or (equal? (binding-library binding) *current-library*)
          (not (binding-mutable? binding))
          (syntax-violation
           #f
           (string-append "Attempt to implicitly import variable that is mutable in library ("
                          (list->string (binding-library binding) " ") ")")
           t)))

    ;;=========================================================================
    ;;
    ;; Quote, if, set!, expression begin, expression let[rec]-syntax, and, or:
    ;;
    ;;=========================================================================

    (define (expand-quote exp)
      (match exp
        ((- datum) (syntax->datum exp))))

    (define (expand-if exp)
      (match exp
        ((- e1 e2 e3) `(if ,(expand e1) ,(expand e2) ,(expand e3)))
        ((- e1 e2)    `(if ,(expand e1) ,(expand e2)))))

    (define (expand-set! exp)
      (match exp
        ((- (? identifier? id) e)
         (let ((binding (binding id)))
           (check-binding-level id binding)
           (register-use! id binding)
           (case (binding-type binding)
             ((macro)
              (let ((macro (binding->macro binding id)))
                (case (macro-type macro)
                  ((variable-transformer)
                   (expand (invoke-macro macro exp)))
                  (else
                   (syntax-violation
                    'set! "Keyword being set! is not a variable transformer" exp id)))))
             ((variable)
              (or (eq? (binding-library binding) *current-library*)
                  (syntax-violation
                   'set! "Directly or indirectly imported variable cannot be assigned" exp id))
              (binding-mutable-set! binding #t)
              `(set! ,(binding-name binding)
                     ,(expand e)))
             ((pattern-variable)
              (syntax-violation 'set! "Pattern variable used outside syntax template" exp id)))))))

    ;; Expression begin.

    (define (expand-begin exp)
      (match exp
        ((- exps ..0)
         (scan-sequence 'expression-sequence
                        #f
                        exps
                        (lambda (forms no-syntax-definitions no-bound-variables)
                          `(begin ,@(map cdr forms)))))))

    ;; Expression let(rec)-syntax:

    (define (expand-local-syntax exp)
      (expand-begin `(,(rename 'macro 'begin) ,exp)))

    ;; Define and and or as primitives  so we can import them into the repl
    ;; toplevel without spoiling the and and or of the library language.

    (define (expand-and exp)
      (match exp
        ((and) #t)
        ((and e) (expand e))
        ((and e es ..0)
         `(if ,(expand e)
              ,(expand `(,and ,@es))
              #f))))

    (define (expand-or exp)
      (match exp
        ((or) #t)
        ((or e) (expand e))
        ((or e es ..0)
         `(let ((x ,(expand e)))
            (if x x ,(expand `(,or ,@es)))))))

    ;;=========================================================================
    ;;
    ;; Lambda:
    ;;
    ;;=========================================================================

    (define (expand-lambda exp)
      (match exp
        ((- (? formals? formals) body ..0)
         (fluid-let ((*usage-env*
                      (env-extend (map (lambda (formal)
                                         (make-local-mapping 'variable formal #f))
                                       (flatten formals))
                                  *usage-env*)))
           (let ((formals (dotted-map (lambda (formal) (binding-name (binding formal))) formals)))
             ;; Scan-sequence expects the caller to have prepared
             ;; the frame to which to destructively add bindings.
             ;; Lambda bodies need a fresh frame.
             (fluid-let ((*usage-env* (env-extend '() *usage-env*)))
               (scan-sequence 'lambda
                              make-local-mapping
                              body
                              (lambda (forms syntax-definitions bound-variables)
                                `(lambda ,formals
                                   ,@(if (null? bound-variables)                ; +++
                                         (emit-body forms ex:undefined-set!)    ; +++
                                         `(((lambda ,bound-variables
                                              ,@(emit-body forms ex:undefined-set!))
                                            ,@(map (lambda (ignore) `ex:undefined)
                                                   bound-variables)))))))))))))

    (define (formals? s)
      (or (null? s)
          (identifier? s)
          (and (pair? s)
               (identifier? (car s))
               (formals? (cdr s))
               (not (dotted-memp (lambda (x)
                                   (bound-identifier=? x (car s)))
                                 (cdr s))))))

    ;;=========================================================================
    ;;
    ;; Bodies and sequences:
    ;;
    ;;=========================================================================

    ;; R6RS splicing of internal let-syntax and letrec-syntax
    ;; requires that we remember the bindings visible in each
    ;; form for later expansion of deferred right hand sides
    ;; and expressions.  This is done by attaching
    ;; the environment to the expression.
    ;; We call the resulting data structure a wrap.
    ;; Wraps are only used internally in processing of bodies,
    ;; and are never seen by user macros.

    (define (make-wrap env exp)
      (cons env exp))
    (define wrap-env car)
    (define wrap-exp cdr)

    ;; The continuation k is evaluated in the body environment.  This is
    ;; used for example by expand-library to obtain the correct bindings of
    ;; exported identifiers.
    ;;
    ;; <body-type> ::= toplevel | library | program | lambda | expression-sequence
    ;;
    ;; All but TOPLEVEL are as in r6rs.
    ;; TOPLEVEL is meant for the REPL.
    ;; At TOPLEVEL, we may have a sequence of expressions, definitions, macros,
    ;; import declarations, libraries and programs wrapped in (program ---).
    ;; Redefinitions are allowed at toplevel.

    (define (scan-sequence body-type make-map body-forms k)

      ;; Each <form> ::= (<symbol | #f> #t <wrap>)   (deferred rhs)
      ;;              |  (<symbol | #f> #f <s-expr>) (undeferred rhs)
      ;; Returns ((<symbol | #f> . <s-expr>) ...)

      (define (expand-deferred forms)
        (map (lambda (form)
               (cons (car form)
                     (let ((deferred? (cadr form))
                           (exp       (caddr form)))
                       (if deferred?
                           (fluid-let ((*usage-env* (wrap-env exp)))
                             (expand (wrap-exp exp)))
                           exp))))
             forms))

      (let ((common-env *usage-env*))

        ;; Add new frame for keeping track of bindings used
        ;; so we can detect redefinitions violating lexical scope.
        (add-fresh-used-frame!)

        (let loop ((ws (map (lambda (e) (make-wrap common-env e))
                            body-forms))
                   (forms           '())
                   (syntax-defs     '())
                   (bound-variables '()))
          (cond
           ((null? ws)
            (check-expression-body body-type forms body-forms)
            ;; Add denotations used in this frame to those of parent.
            ;; This is just for the optional reporting of shadowing errors.
            (merge-used-with-parent-frame!)
            (k (reverse (expand-deferred forms))
               (reverse syntax-defs)
               bound-variables))
           (else
            (fluid-let ((*usage-env* (wrap-env (car ws))))
              (call-with-values
                  (lambda () (head-expand (wrap-exp (car ws))))
                (lambda (form operator-binding)
                  (let ((type (and operator-binding (binding-name operator-binding))))
                    (check-expression-sequence body-type type form)
                    (check-toplevel            body-type type form)
                    (case type
                      ((import)
                       (match form
                         ((- specs ..0)
                          (call-with-values
                              (lambda () (scan-imports specs))
                            (lambda (imported-libraries imports)
                              (import-libraries-for-expand imported-libraries (map not imported-libraries) 0)
                              (env-import! (car form) imports common-env)
                              (loop (cdr ws)
                                    (cons (list #f #f `(ex:import-libraries-for-run
                                                        ',imported-libraries
                                                        ',(current-builds imported-libraries)
                                                        0))
                                          forms)
                                    syntax-defs
                                    bound-variables))))))
                      ((program)
                       (loop (cdr ws)
                             (cons (list #f #f (expand-program form)) forms)
                             syntax-defs
                             bound-variables))
                      ((library)
                       (loop (cdr ws)
                             (cons (list #f #f (expand-library form)) forms)
                             syntax-defs
                             bound-variables))
                      ((define)
                       (call-with-values
                           (lambda () (parse-definition form))
                         (lambda (id rhs)
                           (check-valid-definition id common-env body-type form forms type)
                           (env-extend! (list (make-map 'variable id #f)) common-env)
                           (loop (cdr ws)
                                 (cons (list (binding-name (binding id))
                                             #t
                                             (make-wrap *usage-env* rhs))
                                       forms)
                                 syntax-defs
                                 (cons (binding-name (binding id)) bound-variables)))))
                      ((define-syntax)
                       (call-with-values
                           (lambda () (parse-definition form))
                         (lambda (id rhs)
                           (check-valid-definition id common-env body-type form forms type)
                           (let ((mapping (make-map 'macro id #f)))
                             (env-extend! (list mapping) common-env)
                             (let ((rhs (fluid-let ((*phase* (+ 1 *phase*)))
                                          (expand rhs))))
                               (register-macro! (binding-name (cdr mapping)) (make-user-macro (eval rhs)))
                               (loop (cdr ws)
                                     forms
                                     (cons (cons (binding-name (binding id)) rhs) syntax-defs)
                                     bound-variables))))))
                      ((begin)
                       (or (list? form)
                           (invalid-form form))
                       (loop (append (map (lambda (exp)
                                            (make-wrap *usage-env* exp))
                                          (cdr form))
                                     (cdr ws))
                             forms
                             syntax-defs
                             bound-variables))
                      ((let-syntax letrec-syntax)
                       (call-with-values
                           (lambda () (parse-local-syntax form))
                         (lambda (formals rhs body)
                           (let* ((original-env *usage-env*)
                                  (usage-diff   (map (lambda (formal)
                                                       (make-local-mapping 'macro formal #f))
                                                     formals))
                                  (extended-env (env-extend usage-diff original-env))
                                  (rhs-expanded
                                   (fluid-let ((*phase* (+ 1 *phase*))
                                               (*usage-env*
                                                (case type
                                                  ((let-syntax)    original-env)
                                                  ((letrec-syntax) extended-env))))
                                     (map expand rhs)))
                                  (macros (map eval rhs-expanded)))
                             (for-each (lambda (mapping macro)
                                         (register-macro! (binding-name (cdr mapping)) (make-user-macro macro)))
                                       usage-diff
                                       macros)
                             (loop (append (map (lambda (form) (make-wrap extended-env form))
                                                body)
                                           (cdr ws))
                                   forms
                                   syntax-defs
                                   bound-variables)))))
                      (else
                       (loop (cdr ws)
                             (cons (list #f #t (make-wrap *usage-env* form))
                                   forms)
                             syntax-defs
                             bound-variables))))))))))))

    (define (emit-body body-forms define-or-set)
      (map (lambda (body-form)
             (if (symbol? (car body-form))
                 `(,define-or-set ,(car body-form) ,(cdr body-form))
                 (cdr body-form)))
           body-forms))

    (define (parse-definition exp)
      (match exp
        ((- (? identifier? id))
         (values id (rename 'variable 'ex:unspecified)))
        ((- (? identifier? id) e)
         (values id e))
        ((- ((? identifier? id) . (? formals? formals)) body ..0)
         (values id `(,(rename 'macro 'lambda) ,formals ,@body)))))

    (define (parse-local-syntax t)
      (match t
        ((- ((x e) ..0) body ..0)
         (or (formals? x)
             (invalid-form t))
         (values x e body))))

    (define (check-expression-sequence body-type type form)
      (and (eq? body-type 'expression-sequence)
           (memq type '(import program library define define-syntax))
           (syntax-violation type "Invalid form in expression sequence" form)))

    (define (check-toplevel body-type type form)
      (and (not (eq? body-type 'toplevel))
           (memq type '(import program library))
           (syntax-violation type "Expression may only occur at toplevel" form)))

    (define (check-valid-definition id common-env body-type form forms type)
      (and (not (eq? body-type 'toplevel))
           (duplicate? id common-env)
           (syntax-violation type "Redefinition of identifier in body" form id))
      (check-used id body-type form)
      (and (not (memq body-type `(toplevel program)))
           (not (null? forms))
           (not (symbol? (car (car forms))))
           (syntax-violation type "Definitions may not follow expressions in a body" form)))

    (define (check-expression-body body-type forms body-forms)
      (and (eq? body-type 'lambda)
           (or (null? forms)
               (symbol? (caar forms)))
           (syntax-violation body-type "Body must be nonempty and end with an expression" body-forms)))

    ;;=========================================================================
    ;;
    ;; Syntax-case:
    ;;
    ;;=========================================================================

    (define (expand-syntax-case exp)
      (define (literal? x)
        (and (identifier? x)
             (not (or (free=? x '_)
                      (free=? x '...)))))
      (match exp
        ((- e ((? literal? literals) ..0) clauses ..0)
         (let ((input (generate-guid 'input)))
           `(let ((,input ,(expand e)))
              ,(process-clauses clauses input literals))))))

    (define (process-clauses clauses input literals)

      (define (literal? pattern)
        (and (identifier? pattern)
             (memp (lambda (x)
                     (bound-identifier=? x pattern))
                   literals)))

      (define (process-match input pattern sk fk)
        (if (not (symbol? input))
            (let ((temp (generate-guid 'temp)))
              `(let ((,temp ,input))
                 ,(process-match temp pattern sk fk)))
            (match pattern
              ((syntax _)            sk)
              ((syntax ...)          (syntax-violation 'syntax-case "Invalid use of ellipses" pattern))
              (()                    `(if (null? ,input) ,sk ,fk))
              ((? literal? id)       `(if (and (ex:identifier? ,input)
                                               (ex:free-identifier=? ,input ,(syntax-reflect id)))
                                          ,sk
                                          ,fk))
              ((? identifier? id) `(let ((,(binding-name (binding id)) ,input)) ,sk))
              ((p (syntax ...))
               (let ((mapped-pvars (map (lambda (pvar) (binding-name (binding pvar)))
                                        (map car (pattern-vars p 0)))))
                 (if (and (identifier? p)                                   ; +++
                          (= (length mapped-pvars) 1))                      ; +++
                     `(if (list? ,input)                                    ; +++
                          (let ((,(car mapped-pvars) ,input))               ; +++
                            ,sk)                                            ; +++
                          ,fk)                                              ; +++
                     (let ((columns (generate-guid 'cols))
                           (rest    (generate-guid 'rest)))
                       `(ex:map-while (lambda (,input)
                                        ,(process-match input
                                                        p
                                                        `(list ,@mapped-pvars)
                                                        #f))
                                      ,input
                                      (lambda (,columns ,rest)
                                        (if (null? ,rest)
                                            (apply (lambda ,mapped-pvars ,sk)
                                                   (if (null? ,columns)
                                                       ',(map (lambda (ignore) '()) mapped-pvars)
                                                       (apply map list ,columns)))
                                            ,fk)))))))
              ((p (syntax ...) . tail)
               (let ((tail-length (dotted-length tail)))
                 `(if (>= (ex:dotted-length ,input) ,tail-length)
                      ,(process-match `(ex:dotted-butlast ,input ,tail-length)
                                      `(,p ,(cadr pattern))
                                      (process-match `(ex:dotted-last ,input ,tail-length)
                                                     tail
                                                     sk
                                                     fk)
                                      fk)
                      ,fk)))
              ((p1 . p2)
               `(if (pair? ,input)
                    ,(process-match `(car ,input)
                                    p1
                                    (process-match `(cdr ,input) p2 sk fk)
                                    fk)
                    ,fk))
              (#(ps ..0)
               `(if (vector? ,input)
                    ,(process-match `(vector->list ,input)
                                    ps
                                    sk
                                    fk)
                    ,fk))
              ((? symbol? -)
               (syntax-violation 'syntax-case "Symbol object may not appear in pattern" pattern))
              (other
               `(if (equal? ,input ',other) ,sk ,fk)))))

      (define (pattern-vars pattern level)
        (match pattern
          ((p (syntax ...) . tail) (append (pattern-vars p (+ level 1))
                                           (pattern-vars tail level)))
          ((p1 . p2)               (append (pattern-vars p1 level)
                                           (pattern-vars p2 level)))
          (#(ps ..0)               (pattern-vars ps level))
          ((syntax ...)            '())
          ((syntax _)              '())
          ((? literal? -)          '())
          ((? identifier? id)      (list (cons id level)))
          (-                       '())))

      (define (process-clause clause input fk)
        (match clause
          ((pattern . rest)
           (let ((pvars    (pattern-vars pattern 0)))
             (check-set? (map car pvars)
                         bound-identifier=?
                         (lambda (dup)
                           (syntax-violation 'syntax-case "Repeated pattern variable" clause dup)))
             (let ((mappings (map (lambda (pvar)
                                    (make-local-mapping 'pattern-variable (car pvar) (cdr pvar)))
                                  pvars)))
               (fluid-let ((*usage-env* (env-extend mappings *usage-env*)))
                 (process-match input
                                pattern
                                (match rest
                                  ((template)
                                   (expand template))
                                  ((fender template)
                                   `(if ,(expand fender)
                                        ,(expand template)
                                        ,fk))
                                  (- (syntax-violation 'syntax-case "Invalid clause" clause)))
                                fk)))))))

      ;; process-clauses

      (match clauses
        (()
         `(ex:invalid-form ,input))
        ((clause clauses ..0)
         (let ((fail  (generate-guid 'fail)))
           `(let ((,fail (lambda () ,(process-clauses clauses input literals))))
              ,(process-clause clause input `(,fail)))))))

    ;;=========================================================================
    ;;
    ;; Syntax:
    ;;
    ;;=========================================================================

    (define (expand-syntax form)
      (match form
        ((- template)
         (process-template template 0 #f))))

    (define (process-template template dim ellipses-quoted?)
      (match template
        ((syntax ...)
         (if (not ellipses-quoted?)
             (syntax-violation 'syntax "Invalid occurrence of ellipses in syntax template" template))
         (syntax-reflect template))
        ((? identifier? id)
         (let ((binding (binding id)))
           (cond ((and binding
                       (eq? (binding-type binding) 'pattern-variable)
                       (binding-dimension binding))
                  => (lambda (pdim)
                       (if (<= pdim dim)
                           (begin
                             (check-binding-level id binding)
                             (register-use! id binding)
                             (binding-name binding))
                           (syntax-violation 'syntax "Template dimension error (too few ...'s?)" id))))
                 (else
                  (syntax-reflect id)))))
        (((syntax ...) p)
         (process-template p dim #t))
        ((? (lambda (_) (not ellipses-quoted?))
            (t (syntax ...) . tail))
         (let* ((depth (segment-depth template))
                (seg-dim (+ dim depth))
                (vars
                 (map (lambda (mapping)
                        (let ((id      (car mapping))
                              (binding (cdr mapping)))
                          (check-binding-level id binding)
                          (register-use! id binding)
                          (binding-name binding)))
                      (free-meta-variables t seg-dim '()))))
           (if (null? vars)
               (syntax-violation 'syntax "Too many ...'s" template)
               (let* ((x (process-template t seg-dim ellipses-quoted?))
                      (gen (if (equal? (list x) vars)   ; +++
                               x                        ; +++
                               `(map (lambda ,vars ,x)
                                     ,@vars)))
                      (gen (do ((d depth (- d 1))
                                (gen gen `(apply append ,gen)))
                               ((= d 1)
                                gen))))
                 (if (null? (segment-tail template))   ; +++
                     gen                               ; +++
                     `(append ,gen ,(process-template (segment-tail template) dim ellipses-quoted?)))))))
        ((t1 . t2)
         `(cons ,(process-template t1 dim ellipses-quoted?)
                ,(process-template t2 dim ellipses-quoted?)))
        (#(ts ..0)
         `(list->vector ,(process-template ts dim ellipses-quoted?)))
        (other
         `(quote ,(expand other)))))

    ;; Return a list of meta-variables of given higher dim

    (define (free-meta-variables template dim free)
      (match template
        ((? identifier? id)
         (if (memp (lambda (x) (bound-identifier=? (car x) id)) free)
             free
             (let ((binding (binding id)))
               (if (and binding
                        (eq? (binding-type binding) 'pattern-variable)
                        (let ((pdim (binding-dimension binding)))
                          (>= pdim dim)))
                   (cons (cons id binding) free)
                   free))))
        ((t (syntax ...) . tail)
         (free-meta-variables t dim (free-meta-variables tail dim free)))
        ((t1 . t2)
         (free-meta-variables t1 dim (free-meta-variables t2 dim free)))
        (#(ts ..0)
         (free-meta-variables ts dim free))
        (- free)))

    ;; Count the number of `...'s in PATTERN.

    (define (segment-depth pattern)
      (match pattern
        ((p (syntax ...) . rest)
         (+ 1 (segment-depth (cdr pattern))))
        (- 0)))

    ;; Get whatever is after the `...'s in PATTERN.

    (define (segment-tail pattern)
      (let loop ((pattern (cdr pattern)))
        (match pattern
          (((syntax ...) . tail)
           (loop tail))
          (- pattern))))

    ;;=========================================================================
    ;;
    ;; Detecting violations of lexical scope.
    ;;
    ;;=========================================================================

    ;; This is r6rs-optional.
    ;; For avoiding giving lexically invalid semantics to body
    ;; sequences according to the following semantics described in r6rs:
    ;; A definition in the sequence of forms must not define any
    ;; identifier whose binding is used to determine the meaning of the
    ;; undeferred portions of the definition or any definition that precedes
    ;; it in the sequence of forms.
    ;; This implementation treats a possble violation of the restriction
    ;; as a syntax violation.

    ;; The parameter *used* keeps track of bindings used so we can
    ;; detect redefinitions violating lexical scope in body sequences.
    ;; The car of *used* contains bindings used in current frame.

    (define (add-fresh-used-frame!)
      (set! *used* (cons '() *used*)))

    (define (register-use! id binding)
      (set! *used* (cons (cons (cons id binding)
                               (car *used*))
                         (cdr *used*))))

    (define (merge-used-with-parent-frame!)
      (set! *used* (cons (append (car  *used*)
                                 (cadr *used*))
                         (cddr *used*))))

    (define (check-used id body-type form)
      (and (not (eq? body-type 'toplevel))
           ;; The car contains bindings for current frame and nested frames
           (let* ((already-used (car *used*))
                  ;; This destructively changes *used* and must follow previous
                  (binding (binding id)))
             (if (memp (lambda (mapping)
                         (and (eq? binding (cdr mapping))
                              (bound-identifier=? id (car mapping))))
                       already-used)
                 (syntax-violation
                  'definition
                  "Definition of identifier that may have already affected meaning of undeferred portions of body"
                  form
                  id)))))

    ;;==========================================================================
    ;;
    ;; Libraries:
    ;;
    ;;==========================================================================

    (define (expand-program t)
      (match t
        ((program import-clause forms ..0)
         (expand-library-or-program
          `(,program (,(datum->syntax program (generate-guid 'program)))
                     (,(datum->syntax program 'export))
                     ,import-clause
                     ,@forms)
          'program))))

    (define (expand-library t)
      (expand-library-or-program t 'library))

    ;; <library-type> ::= library | program

    (define (expand-library-or-program t library-type)
      (match t
        ((keyword name ((syntax export) sets ..0) ((syntax import) specs ..0) body-forms ..0)
         (let ((name (syntax->datum (scan-library-name name))))
           (let ((exports (scan-exports sets)))
             (call-with-values
                 (lambda () (scan-imports specs))
               (lambda (imported-libraries imports)
                 (fluid-let ((*usage-env*        (make-unit-env))
                             (*env-table*        '())
                             (*macro-table*      '())
                             (*current-library*  name)
                             (*syntax-reflected* #f))       ; +++ space

                   (import-libraries-for-expand imported-libraries (map not imported-libraries) 0)
                   (env-import! keyword imports *usage-env*)

                   (let ((initial-env-table *env-table*))   ; +++ space
                     (scan-sequence library-type
                                    make-local-mapping
                                    body-forms
                                    (lambda (forms syntax-definitions bound-variables)
                                      (let* ((exports
                                              (map (lambda (mapping)
                                                     (cons (id-name (car mapping))
                                                           (let ((binding (binding (cadr mapping))))
                                                             (or binding
                                                                 (syntax-violation
                                                                  'library "Unbound export" t (cadr mapping)))
                                                             (if (binding-mutable? binding)
                                                                 (syntax-violation
                                                                  'library "Attempt to export mutable variable" t (cadr mapping)))
                                                             binding)))
                                                   exports))
                                             (expanded-library
                                              (case library-type
                                                ((program)
                                                 `(begin
                                                    (ex:import-libraries-for-run ',imported-libraries
                                                                                 ',(current-builds imported-libraries)
                                                                                 0)
                                                    ,@(emit-body forms 'define)))
                                                ((library)
                                                 `(begin
                                                    ,@(map (lambda (var)
                                                             `(define ,var ex:unspecified))
                                                           bound-variables)
                                                    (ex:register-library!
                                                     (ex:make-library
                                                      ',name
                                                      ;; Store as thunk so that it is not unnecesarily
                                                      ;; uncompressed at runtime
                                                      (lambda ()
                                                        ,(if *syntax-reflected*                     ; +++ space
                                                             `(ex:uncompress                        ; +++ space
                                                               ',(compress (drop-tail
                                                                            *env-table*
                                                                            initial-env-table)))
                                                             `'()))                                 ; +++ space
                                                      ',exports
                                                      ',imported-libraries
                                                      ',(current-builds imported-libraries)
                                                      ;; visit
                                                      (lambda ()
                                                        ,@(map (lambda (def)
                                                                 `(ex:register-macro! ',(car def) ,(cdr def)))
                                                               syntax-definitions)
                                                        (values))
                                                      ;; invoke
                                                      (lambda ()
                                                        ,@(map (lambda (var)
                                                                 `(set! ,var ex:undefined))
                                                               bound-variables)
                                                        ,@(emit-body forms ex:undefined-set!)
                                                        (values))
                                                      ;; build
                                                      ',(generate-guid 'build)))
                                                    (values))))))

                                        ;; Register library for any further expansion.
                                        (if (eq? library-type 'library)
                                            (eval expanded-library))

                                        expanded-library))))))))))))

    (define (env-import! keyword imports env)
      (env-extend! (map (lambda (import)
                          (cons (cons (car import)
                                      (id-colors keyword))
                                (cdr import)))
                        imports)
                   env))

    (define (current-builds imported-libraries)
      (map (lambda (lib-entry)
             (ex:library-build (ex:lookup-library (car lib-entry))))
           imported-libraries))

    (define (import-libraries-for-expand imports builds phase)
      (ex:import-libraries-for
       imports
       builds
       phase
       (lambda (library phase imported)
         (if (>= phase 0)
             (let ((name (ex:library-name library)))
               (if (not (memp (lambda (entry)
                                (and (equal? (car entry) name)
                                     (>= (cdr entry) 0)))
                              imported))
                   (fluid-let ((*phase* phase))
                     (set! *env-table* (append ((ex:library-envs library)) *env-table*))
                     ((ex:library-visiter library))))
               (if (>= phase 1)
                   (if (not (memp (lambda (entry)
                                    (and (equal? (car entry) name)
                                         (>= (cdr entry) 1)))
                                  imported))
                       (fluid-let ((*phase* phase))
                         ((ex:library-invoker library))))))))))

    ;; Returns ((<rename-identifier> <identifier> <level> ...) ...)

    (define (scan-exports sets)
      (let ((exports (apply append (map scan-export-set sets))))
        (check-set? exports
                    (lambda (x y)
                      (eq? (id-name (car x))
                           (id-name (car y))))
                    (lambda (dup) (syntax-violation 'export "Duplicate export" sets dup)))
        exports))

    (define (scan-export-set set)
      (match set
        ((? identifier? x)
         `((,x ,x 0)))
        (((syntax rename) ((? identifier? xs) (? identifier? ys)) ..0)
         (map (lambda (x y) `(,y ,x 0)) xs ys))
        (- (syntax-violation 'export "Invalid export set" set))))

    ;; Returns
    ;;    (values ((<library reference> <level> ...) ....)
    ;;            ((<local name> . <binding>) ...))
    ;; with no repeats.

    (define (scan-imports specs)
      (let loop ((specs specs)
                 (imported-libraries '())
                 (imports '()))
        (if (null? specs)
            (values imported-libraries (unify-imports imports))
            (call-with-values
                (lambda () (scan-import-spec (car specs)))
              (lambda (library-ref levels more-imports)
                (loop (cdr specs)
                      ;; library-ref = #f if primitives spec
                      (if library-ref
                          (cons (cons library-ref levels)
                                imported-libraries)
                          imported-libraries)
                      (append more-imports imports)))))))

    ;; Returns (values <library reference> | #f
    ;;                 (<level> ...)
    ;;                 ((<local name> . <binding>) ...)
    ;; where <level> ::= <integer>
    ;; #f is returned for library name in case of primitives.

    (define (scan-import-spec spec)

      (call-with-values
          (lambda () (scan-levels spec))
        (lambda (levels import-set)
          (let loop ((import-set import-set)
                     (adjuster (lambda (set) set)))

            (define (check-presence names mappings from)
              (for-each (lambda (name)
                          (or (assq name mappings)
                              (syntax-violation from
                                                (string-append "Identifier not in set: "
                                                               (list->string (map car mappings) " "))
                                                import-set
                                                name)))
                        names))

            (match import-set
              (((syntax primitives) (? identifier? xs) ..0)
               (values #f
                       levels
                       (map (lambda (mapping)
                              (cons (car mapping) (make-binding 'variable (cdr mapping) levels #f '())))
                            (adjuster (map (lambda (name) (cons name name))
                                           (syntax->datum xs))))))
              (((syntax only) set (? identifier? xs) ..0)
               (let ((args (syntax->datum xs)))
                 (loop set
                       (compose adjuster (lambda (mappings)
                                           (check-presence args mappings 'only)
                                           (filter (lambda (mapping)
                                                     (memq (car mapping) args))
                                                   mappings))))))
              (((syntax except) set (? identifier? xs) ..0)
               (let ((args (syntax->datum xs)))
                 (loop set
                       (compose adjuster (lambda (mappings)
                                           (check-presence args mappings 'except)
                                           (filter (lambda (mapping)
                                                     (not (memq (car mapping) args)))
                                                   mappings))))))
              (((syntax prefix) set (? identifier? pre))
               (loop set
                     (compose adjuster (lambda (mappings)
                                         (map (lambda (mapping)
                                                (cons (string->symbol
                                                       (string-append
                                                        (symbol->string (syntax->datum pre))
                                                        (symbol->string (car mapping))))
                                                      (cdr mapping)))
                                              mappings)))))
              (((syntax rename) set ((? identifier? xs) (? identifier? ys)) ..0)
               (let ((args (syntax->datum (cddr import-set))))
                 (loop set
                       (compose adjuster
                                (lambda (mappings)
                                  (check-presence (map car args) mappings 'rename)
                                  (map (lambda (mapping)
                                         (cons (cond ((assq (car mapping) args) => cadr)
                                                     (else (car mapping)))
                                               (cdr mapping)))
                                       mappings))))))
              (((syntax primitives) . -) (invalid-form import-set))
              (((syntax only)       . -) (invalid-form import-set))
              (((syntax except)     . -) (invalid-form import-set))
              (((syntax prefix)     . -) (invalid-form import-set))
              (((syntax rename)     . -) (invalid-form import-set))
              (-
               (let ((library-ref (library-ref import-set)))
                 (if library-ref
                     (let* ((library (ex:lookup-library (syntax->datum library-ref)))
                            (exports (ex:library-exports library))
                            (imports
                             (map (lambda (mapping)
                                    (cons (car mapping)
                                          (let ((binding (cdr (assq (cdr mapping) exports))))
                                            (make-binding (binding-type binding)
                                                          (binding-name binding)
                                                          (compose-levels levels (binding-levels binding))
                                                          (binding-mutable? binding)
                                                          (binding-library binding)))))
                                  (adjuster (map (lambda (name) (cons name name))
                                                 (map car exports))))))
                       (values (syntax->datum library-ref)
                               levels
                               imports))
                     (syntax-violation 'import "Invalid import set" import-set)))))))))

    (define (scan-levels spec)
      (match spec
        (((syntax for) set levels ..0)
         (let ((levels
                (map (lambda (level)
                       (match level
                         ((syntax run)                   0)
                         ((syntax expand)                1)
                         (((syntax meta) (? integer? n)) n)
                         (- (syntax-violation 'for "Invalid level in for spec" spec level))))
                     levels)))
           (check-set? levels = (lambda (dup) (syntax-violation 'for "Repeated level in for spec" spec dup)))
           (values levels set)))
        (- (values '(0) spec))))

    (define (compose-levels levels levels*)
      (apply unionv
             (map (lambda (level)
                    (map (lambda (level*)
                           (+ level level*))
                         levels*))
                  levels)))

    ;; Argument is of the form ((<local name> <binding>) ...)
    ;; where combinations (<local name> (binding-name <binding>)) may be repeated.
    ;; Return value is of the same format but with no repeats and
    ;; where union of (binding-levels <binding>)s has been taken for any original repeats.
    ;; An error is signaled if same <local name> occurs with <binding>s
    ;; whose (binding-name <binding>)s are different.

    (define (unify-imports imports)
      (let ((seen '()))
        (let loop ((imports imports))
          (if (null? imports)
              seen
              (let* ((mapping (car imports))
                     (probe (assq (car mapping) seen)))
                (if probe
                    (begin
                      (or (eq? (binding-name (cdr mapping))
                               (binding-name (cdr probe)))
                          (syntax-violation
                           'import
                           (string-append "Different bindings for identifier imported from libraries ("
                                          (list->string (binding-library (cdr mapping)) " ")
                                          ") and ("
                                          (list->string (binding-library (cdr probe)) " ") ")")
                           (car mapping)))
                      (set-cdr! probe
                                (make-binding (binding-type (cdr probe))
                                              (binding-name (cdr probe))
                                              (unionv (binding-levels (cdr probe))
                                                      (binding-levels (cdr mapping)))
                                              (binding-mutable? (cdr probe))
                                              (binding-library (cdr probe)))))
                    (set! seen (cons mapping seen)))
                (loop (cdr imports)))))))

    (define (scan-library-name e)
      (library-ref-helper e version?))

    (define (library-ref e)
      (library-ref-helper
       (match e
         (((syntax library) name) name)
         (((syntax library) . -)  (invalid-form e))
         (- e))
       version-reference?))

    (define (library-ref-helper e version?)
      (match e
        (((? identifier? ids) ..0)                ids)
        (((? identifier? ids) ..0 (? version? -)) ids)
        (- (syntax-violation 'library "Invalid library reference" e))))

    (define (version? e)
      (and (list? e)
           (for-all subversion? e)))

    (define (subversion? x)
      (and (integer? x)
           (>= x 0)))

    (define (version-reference? e)
      (match e
        (((syntax and) (? version-reference? -) ..0) #t)
        (((syntax or)  (? version-reference? -) ..0) #t)
        (((syntax not) (? version-reference? -))     #t)
        (((? subversion-reference? -) ..0)           #t)
        (-                                           #f)))

    (define (subversion-reference? e)
      (or (subversion? e)
          (subversion-condition? e)))

    (define (subversion-condition? e)
      (match e
        (((syntax >=)  (? subversion? -))               #t)
        (((syntax <=)  (? subversion? -))               #t)
        (((syntax not) (? subversion? -))               #t)
        (((syntax and) (? subversion-reference? -) ..0) #t)
        (((syntax or)  (? subversion-reference? -) ..0) #t)
        (-                                              #f)))

    ;;==========================================================================
    ;;
    ;; Debugging facilities:
    ;;
    ;;==========================================================================

    (define (syntax-violation who message form . maybe-subform)
      (newline)
      (display "Syntax violation: ")
      (let ((who (if who
                     who
                     (cond ((identifier? form)
                            (syntax->datum form))
                           ((and (list? form)
                                 (identifier? (car form)))
                            (syntax->datum (car form)))
                           (else ""))))
            (subform (cond ((null? maybe-subform) #f)
                           ((and (pair? maybe-subform)
                                 (null? (cdr maybe-subform)))
                            (car maybe-subform))
                           (else (assertion-violation 'syntax-violation
                                                      "Invalid subform in syntax violation"
                                                      maybe-subform)))))
        (display who)
        (newline)
        (newline)
        (display message)
        (newline)
        (newline)
        (if subform
            (begin (display "Subform: ")
                   (pretty-print (syntax-debug subform))
                   (newline)))
        (display "Form: ")
        (pretty-print (syntax-debug form))
        (newline)
        (display "Trace: ")
        (newline)
        (newline)
        (for-each (lambda (exp)
                    (display "  ")
                    (pretty-print (syntax-debug exp))
                    (newline))
                  *trace*)
        (error 'syntax-violation "Integrate with host error handling here")))

    (define (syntax-debug exp)
      (sexp-map (lambda (leaf)
                  (cond ((identifier? leaf)
                         (id-name leaf))
                        (else leaf)))
                exp))

    ;;==========================================================================
    ;;
    ;;  Eval and environment:
    ;;
    ;;==========================================================================

    (define eval-template
      (make-identifier 'eval-template
                       '()
                       '()
                       0
                       `(anonymous)))

    (define (make-r6rs-environment imported-libraries env)
      (cons imported-libraries env))
    (define r6rs-environment-imported-libraries car)
    (define r6rs-environment-env                cdr)

    (define (environment . import-specs)
      (fluid-let ((*usage-env* (make-unit-env)))
        (env-import! eval-template (make-library-language) *usage-env*)
        (call-with-values
            (lambda () (scan-imports
                        (map (lambda (spec)
                               (datum->syntax eval-template spec))
                             import-specs)))
          (lambda (imported-libraries imports)
            (make-r6rs-environment imported-libraries
                                   (let ((env (make-unit-env)))
                                     (env-import! eval-template imports env)
                                     env))))))

    (define (r6rs-eval exp env)
      (fluid-let ((*usage-env* (r6rs-environment-env env)))
        (let ((exp (datum->syntax eval-template exp))
              (imported-libraries (r6rs-environment-imported-libraries env)))
          (import-libraries-for-expand (r6rs-environment-imported-libraries env) (map not imported-libraries) 0)
          (ex:import-libraries-for-run (r6rs-environment-imported-libraries env) (map not imported-libraries) 0)
          (eval (expand-begin
                 ;; wrap in expression begin so no definition can occur as required by r6rs
                 `(,(rename 'macro 'begin) ,exp))))))

    ;;==========================================================================
    ;;
    ;; Library reflection:
    ;;
    ;;=========================================================================

    (define (environment-bindings r6rs-env)
      (map format-mapping
           (caar (r6rs-environment-env r6rs-env))))

    (define (format-mapping mapping)
      `((name ,(caar mapping))
        (type ,(binding-type (cdr mapping)))
        (from ,(binding-library (cdr mapping)))
        (levels ,(binding-levels (cdr mapping)))))

    ;;=====================================================================
    ;;
    ;; Utilities:
    ;;
    ;;=====================================================================

    (define (flatten l)
      (cond ((null? l) l)
            ((pair? l) (cons (car l)
                             (flatten (cdr l))))
            (else (list l))))

    (define (sexp-map f s)
      (cond ((null? s) '())
            ((pair? s) (cons (sexp-map f (car s))
                             (sexp-map f (cdr s))))
            ((vector? s)
             (apply vector (sexp-map f (vector->list s))))
            (else (f s))))

    (define (dotted-memp proc ls)
      (cond ((null? ls) #f)
            ((pair? ls) (if (proc (car ls))
                            ls
                            (dotted-memp proc (cdr ls))))
            (else (and (proc ls)
                       ls))))

    (define (dotted-map f lst)
      (cond ((null? lst) '())
            ((pair? lst) (cons (f (car lst))
                               (dotted-map f (cdr lst))))
            (else (f lst))))

    ;; Returns 0 also for non-list a la SRFI-1 protest.

    (define (dotted-length dl)
      (cond ((null? dl) 0)
            ((pair? dl) (+ 1 (dotted-length (cdr dl))))
            (else 0)))

    (define (dotted-butlast ls n)
      (let recurse ((ls ls)
                    (length-left (dotted-length ls)))
        (cond ((< length-left n) (assertion-violation 'dotted-butlast "List too short" ls n))
              ((= length-left n) '())
              (else
               (cons (car ls)
                     (recurse (cdr ls)
                              (- length-left 1)))))))

    (define (dotted-last ls n)
      (let recurse ((ls ls)
                    (length-left (dotted-length ls)))
        (cond ((< length-left n) (assertion-violation 'dotted-last "List too short" ls n))
              ((= length-left n) ls)
              (else
               (recurse (cdr ls)
                        (- length-left 1))))))

    (define (map-while f lst k)
      (cond ((null? lst) (k '() '()))
            ((pair? lst)
             (let ((head (f (car lst))))
               (if head
                   (map-while f
                              (cdr lst)
                              (lambda (answer rest)
                                (k (cons head answer)
                                   rest)))
                   (k '() lst))))
            (else  (k '() lst))))

    (define (check-set? ls = fail)
      (or (null? ls)
          (if (memp (lambda (x)
                      (= x (car ls)))
                    (cdr ls))
              (fail (car ls))
              (check-set? (cdr ls) = fail))))

    (define (unionv . sets)
      (cond ((null? sets) '())
            ((null? (car sets))
             (apply unionv (cdr sets)))
            (else
             (let ((rest (apply unionv
                                (cdr (car sets))
                                (cdr sets))))
               (if (memv (car (car sets)) rest)
                   rest
                   (cons (car (car sets)) rest))))))

    (define (drop-tail list tail)
      (cond ((null? list)    '())
            ((eq? list tail) '())
            (else
             (cons (car list)
                   (drop-tail (cdr list) tail)))))

    (define (list->string e separator)
      (define (tostring x)
        (cond ((symbol? x)
               (symbol->string x))
              ((number? x)
               (number->string x))
              (else
               (assertion-violation 'list->string "Invalid argument" e))))
      (if (null? e)
          ""
          (string-append
           (tostring (car e))
           (apply string-append
                  (map (lambda (x)
                         (string-append separator (tostring x)))
                       (cdr e))))))

    (define (compose f g)
      (lambda (x) (f (g x))))

    (define (check x p? from)
      (or (p? x)
          (syntax-violation from "Invalid argument" x)))

    (define (invalid-form exp)
      (syntax-violation #f "Invalid form" exp))

    ;;============================================================================
    ;;
    ;; REPL integration:
    ;;
    ;;============================================================================

    (define (repl exps)
      (reset-toplevel!)
      (for-each (lambda (exp)
                  (for-each (lambda (exp)
                              (for-each (lambda (result)
                                          (display result)
                                          (newline))
                                        (call-with-values
                                            (lambda ()
                                              (eval exp))
                                          list)))
                            (expand-toplevel-sequence (list exp))))
                exps))

    ;; Restores parameters to a consistent state
    ;; in case they were left inconsistent by an error.

    (define (reset-toplevel!)
      (set! *trace*           '())
      (set! *current-library* '())
      (set! *phase*           0)
      (set! *used*            (list '()))
      (set! *color*           (generate-color))
      (set! *usage-env*       *toplevel-env*))

    (define (expand-toplevel-sequence forms)
      (scan-sequence 'toplevel
                     make-toplevel-mapping
                     (source->syntax forms)
                     (lambda (forms syntax-definitions bound-variables)
                       (emit-body forms 'define))))

    ;;==========================================================================
    ;;
    ;;  Expand-file:
    ;;
    ;;==========================================================================

    ;; This may be used as a front end for the compiler.
    ;; It expands a file consisting of a possibly empty sequence
    ;; of libraries optionally followed by a <toplevel program>.
    ;; The result is a sequence of vanilla r5rs-like toplevel
    ;; definitions and expressions.

    (define (expand-file filename target-filename)
      (reset-toplevel!)
      (write-file (expand-toplevel-sequence (normalize (read-file filename)))
                  target-filename))

    ;; This approximates the common r5rs behaviour of
    ;; expanding a toplevel file but treating unbound identifiers
    ;; as bare symbols that may refer to variables in the built-in toplevel
    ;; environment.  The environment argument should import at least the
    ;; macros necessary to expand the file.
    ;; In contrast, expand-file strictly isolates a <toplevel program>
    ;; environment from the builtin environment and strictlu disallows
    ;; unbound identifiers.
    ;; This is provided mainly to be able to self-expand this expander
    ;; metacircularly (see the relevant note at the top of this file).
    ;; The resulting file will need the include file runtime.scm
    ;; and the appropriate libraries that constitute the env argument
    ;; to be preloaded before it can be run.

    (define (expand-r5rs-file filename target-filename r6rs-env)
      (reset-toplevel!)
      (fluid-let ((make-free-name (lambda (symbol) symbol))
                  (*usage-env*    (r6rs-environment-env r6rs-env))
                  (*macro-table*  *macro-table*))
        (let ((imported-libraries (r6rs-environment-imported-libraries r6rs-env)))
          (import-libraries-for-expand (r6rs-environment-imported-libraries r6rs-env) (map not imported-libraries) 0)
          (write-file (cons `(ex:import-libraries-for-run ',(r6rs-environment-imported-libraries r6rs-env)
                                                          ',(current-builds imported-libraries)
                                                          0)
                            (expand-toplevel-sequence (read-file filename)))
                      target-filename))))

    ;; Keeps (<library> ...) the same.
    ;; Converts (<library> ... . <toplevel program>)
    ;; to (<library> ... (program . <toplevel program>))

    (define (normalize exps)
      (define (error)
        (let ((newline (string #\newline)))
          (syntax-violation
           'expand-file
           (string-append
            "File should be of the form:" newline
            "      <library>*" newline
            "    | <library>* <toplevel program>")
           exps)))
      (let loop ((exps exps)
                 (normalized '()))
        (if (null? exps)
            (reverse normalized)
            (if (pair? (car exps))
                (case (caar exps)
                  ((library)
                   (loop (cdr exps)
                         (cons (car exps) normalized)))
                  ((import)
                   (loop '()
                         (cons (cons 'program exps)
                               normalized)))
                  (else (error)))
                (error)))))

    (define (read-file fn)
      (let ((p (open-input-file fn)))
        (let f ((x (read p)))
          (if (eof-object? x)
              (begin (close-input-port p) '())
              (cons x
                    (f (read p)))))))

    (define (write-file exps fn)
      (if (file-exists? fn)
          (delete-file fn))
      (let ((p (open-output-file fn)))
        (for-each (lambda (exp)
                    (write exp p)
                    (newline p))
                  exps)
        (close-output-port p)))

    ;;==========================================================================
    ;;
    ;; Toplevel bootstrap:
    ;;
    ;;==========================================================================

    (define toplevel-template
      (make-identifier 'toplevel-template
                       '()
                       '()
                       0
                       #f))

    (define (source->syntax datum)
      (datum->syntax toplevel-template datum))

    ;;===================================================================
    ;;
    ;; Language for bootstrapping the REPL session and (environment ---):
    ;;
    ;;===================================================================

    (define library-language-names
      `(program library export import for run expand meta only
                except prefix rename primitives >= <= and or not))

    (define (make-library-language)
      (map (lambda (name)
             (cons name (make-binding 'macro name '(0) #f '())))
           library-language-names))

    ;;===================================================================
    ;;
    ;; Bootstrap library containing macros defined in this expander.
    ;;
    ;;===================================================================

    (ex:register-library!
     (let ((primitive-macro-mapping
            `((lambda        . ,expand-lambda)
              (if            . ,expand-if)
              (set!          . ,expand-set!)
              (begin         . ,expand-begin)
              (syntax        . ,expand-syntax)
              (quote         . ,expand-quote)
              (let-syntax    . ,expand-local-syntax)
              (letrec-syntax . ,expand-local-syntax)
              (syntax-case   . ,expand-syntax-case)
              (and           . ,expand-and)
              (or            . ,expand-or)
              (define        . ,invalid-form)
              (define-syntax . ,invalid-form)
              (_             . ,invalid-form)
              (...           . ,invalid-form))))
       (ex:make-library
        '(core primitive-macros)
        ;; envs
        (lambda () '())
        ;; exports
        (map (lambda (mapping)
               (cons (car mapping) (make-binding 'macro (car mapping) '(0) #f '())))
             primitive-macro-mapping)
        ;; imported-libraries
        '()
        ;; builds
        '()
        ;; visit
        (lambda ()
          (for-each (lambda (mapping)
                      (register-macro! (car mapping) (make-expander (cdr mapping))))
                    primitive-macro-mapping)
          (values))
        ;; invoke
        (lambda () (values))
        ;; build
        'system)))

    ;; Initial environments:

    (set! *toplevel-env* (make-unit-env))
    (set! *usage-env*    *toplevel-env*)

    ;; Import only the minimal library language into the toplevel:

    (env-import! toplevel-template (make-library-language) *toplevel-env*)
    (register-macro! 'library (make-expander invalid-form))
    (register-macro! 'program (make-expander invalid-form))
    (register-macro! 'import  (make-expander invalid-form))

    ;;==========================================================================
    ;;
    ;; Exports:
    ;;
    ;;==========================================================================

    (set! ex:make-variable-transformer make-variable-transformer)
    (set! ex:identifier?               identifier?)
    (set! ex:bound-identifier=?        bound-identifier=?)
    (set! ex:free-identifier=?         free-identifier=?)
    (set! ex:generate-temporaries      generate-temporaries)
    (set! ex:datum->syntax             datum->syntax)
    (set! ex:syntax->datum             syntax->datum)
    (set! ex:environment               environment)
    (set! ex:environment-bindings      environment-bindings)
    (set! ex:eval                      r6rs-eval)
    (set! ex:syntax-violation          syntax-violation)

    (set! ex:expand-file               expand-file)
    (set! ex:repl                      repl)
    (set! ex:expand-r5rs-file          expand-r5rs-file)

    (set! ex:invalid-form              invalid-form)
    (set! ex:register-macro!           register-macro!)
    (set! ex:syntax-rename             syntax-rename)
    (set! ex:map-while                 map-while)
    (set! ex:dotted-length             dotted-length)
    (set! ex:dotted-butlast            dotted-butlast)
    (set! ex:dotted-last               dotted-last)
    (set! ex:uncompress                uncompress)
    (set! ex:free=?                    free=?)

    ) ; let
  ) ; letrec-syntax