;;;===============================================================================
;;;
;;; R6RS Macros and R6RS libraries:
;;;
;;;   Copyright (c) 2006 Andre van Tonder
;;;
;;;   Copyright statement at http://srfi.schemers.org/srfi-process.html
;;;
;;;   June 22, 2007
;;;
;;;===============================================================================

;;;================================================================================
;;;
;;; PORTING:
;;; --------
;;;
;;; Uncomment whichever is applicable or provide your own.
;;; Compat-*.scm should supply whatever is missing from your implementation of:
;;;
;;;  - SRFI-9.
;;;  - Procedure (ex:unique-token) that provides a GUID string once per run.
;;;  - Procedure (make-parameter init) and syntax (parameterize ((param val) ...) exp ...)
;;;  - Syntax let-values.
;;;  - Procedure pretty-print.
;;;  - Procedures file-exists? and delete-file.
;;;
;;; IMPORTANT:
;;; ----------
;;;
;;; Read HOOKS and R6RS compatibility sections below for a few further
;;; customization issues affecting production systems, including compiler
;;; and REPL integration.
;;;
;;;=================================================================================

(load "compat-mzscheme.scm")
;; (load "compat-larceny.scm")
;; (load "compat-chez.scm")

;;;=================================================================================
;;;
;;; 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:r6rs-eval                 #f)
(define $ex:syntax-violation          #f)

;; System exports:

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

;; Indirect exports:

(define $ex:invalid-form              #f)
(define $ex:uncompress                #f)
(define $ex:register-macro!           #f)
(define $ex:extend-reflected-envs!    #f)
(define $ex:import-libraries          #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)

;;;===============================================================================
;;;
;;; R6RS compatibility:
;;;
;;; These are only partial implementations for specific use cases needed.
;;; They should be removed and fully r6rs-compliant versions
;;; should be provided by host implementation.
;;;
;;;===============================================================================

(define (memp proc ls)
  (cond ((null? ls) #f)
        ((pair? ls) (if (proc (car ls))
                        ls
                        (memp proc (cdr ls))))
        (else (assertion-violation 'memp "Invalid argument" ls))))

(define (filter p? lst)
  (if (null? lst)
      '()
      (if (p? (car lst))
          (cons (car lst)
                (filter p? (cdr lst)))
          (filter p? (cdr lst)))))

(define (for-all proc l . ls)
  (or (null? l)
      (and (apply proc (car l) (map car ls))
           (apply for-all proc (cdr l) (map cdr ls)))))

(define unspecified
  (let ((x (if #f #f)))
    (lambda () x)))

;; Non-exported bindings are "hidden" with the ex: prefix.
;; If you already have letrec* semantics for internal definitions,
;; you may replace begin with let () for better hiding of locals.

(begin

  ;;;===============================================================================
  ;;;
  ;;; 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 feeding result to a compiler.
  ;;
  ;; Example compilation sequences, and REPL example, can be seen in examples.scm

  ;; IMPORTANT:
  ;; ----------
  ;; Generate-guid must return a fresh symbol that has a globally
  ;; unique external representation and is read-write invariant.
  ;; Uniqueness is important for incremental and separate
  ;; expansion.

  ;; The separator character must be disjoint from all characters
  ;; that can appear in identifiers in user programs or system
  ;; primitives.

  (define ex:separator "~")

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

  ;; Used to generate user program toplevel and library names.
  ;;
  ;; IMPORTANT:
  ;; ----------
  ;; Result must be disjoint from all source symbols.
  ;; Result must be disjoint from output of ex:generate-guid

  (define (ex:free-name symbol) (string->symbol (string-append ex:separator (symbol->string symbol))))
  (define ex:free-name?
    (let ((sep-char (string-ref ex:separator 0)))
      (lambda (symbol)
        (char=? (string-ref (symbol->string symbol) 0) sep-char))))

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

  ;; <name>             ::= <symbol>
  ;; <marks>            ::= (<mark> ...)
  ;; <transformer-envs> ::= (<env> ...)
  ;; <level-correction> ::= <integer>
  ;;
  ;; where <name>             : The symbolic name of the identifier in the source.
  ;;       <marks>            : Each time an introduced identifier is renamed, a fresh
  ;;                            mark gets prepended to its <marks>.
  ;;       <transformer-envs> : The environment (car <transformer-envs>) was the usage
  ;;                            environment valid during expansion of the (syntax id*) expression
  ;;                            introducing this identifier, while (cdr <transformer-envs>)
  ;;                            are in turn the <transformer-envs> of id*.
  ;;       <level-correction> : Integer that keeps track of shifts in meta-levels
  ;;                            between introduction and usage sites of identifier.

  (define-record-type ex:identifier
    (ex:make-identifier name marks transformer-envs level-correction)
    ex:identifier?
    (name             ex:identifier-name)
    (marks            ex:identifier-marks)
    (transformer-envs ex:identifier-transformer-envs)
    (level-correction ex:identifier-level-correction))

  (define (ex:bound-identifier=? x y)
    (ex:check x ex:identifier? 'bound-identifier=?)
    (ex:check y ex:identifier? 'bound-identifier=?)
    (and (eq? (ex:identifier-name x)
              (ex:identifier-name y))
         (equal? (ex:identifier-marks x)
                 (ex:identifier-marks y))))

  ;; Since the denotation of a displaced (out of phase) identifier is
  ;; a fresh value, a displaced identifier is not free-identifier=?
  ;; to any identifier, including itself.

  (define (ex:free-identifier=? x y)
    (ex:check x ex:identifier? 'free-identifier=?)
    (ex:check y ex:identifier? 'free-identifier=?)
    (eq? (ex:denotation x)
         (ex:denotation y)))

  (define (ex:free=? x symbol)
    (and (ex:identifier? x)
         (eq? (ex:denotation x) symbol)))

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

  (define (ex:generate-mark)
    (ex:generate-guid 'm))

  (define ex:*mark* (make-parameter (ex:generate-mark)))

  ;; The meta-level for the current expansion step:

  (define ex:*level* (make-parameter 0))

  (define (ex:source-level id)
    (- (ex:*level*)
       (ex:identifier-level-correction id)))

  ;; <binding>      ::= (<binding name> <level> ...)
  ;; <binding name> ::= <symbol>
  ;; <level>        ::= <integer>

  (define ex:make-binding   cons)
  (define ex:binding-name   car)
  (define ex:binding-levels cdr)

  ;; Looks up binding first in usage environment and then
  ;; in attached transformer environments.
  ;; Returns <binding>.

  (define (ex:lookup-binding id)
    (let ((name  (ex:identifier-name id))
          (marks (ex:identifier-marks id)))
      (let loop ((env  (ex:*usage-env*))
                 (envs (ex:identifier-transformer-envs id))
                 (marks marks))
        (or (ex:env-lookup (cons name marks) env #f)
            (and (pair? envs)
                 (loop (car envs)
                       (cdr envs)
                       (cdr marks)))))))

  ;; Returns <binding name> | (displaced . <identifier>)
  ;; where (displaced . <identifier>) is not eq? to any
  ;; previous denotation.  See free-identifier=? for why.

  (define (ex:denotation id)
    (let ((binding (ex:lookup-binding id))
          (level (ex:source-level id)))
      (let ((denotation
             (if binding
                 (if (memv level (ex:binding-levels binding))
                     (ex:binding-name binding)
                     (cons 'displaced id))
                 (if (zero? level)
                     (ex:free-name (ex:identifier-name id))
                     (cons 'displaced id)))))
        (if (symbol? denotation)
            (ex:*used* (cons (cons (cons id denotation)
                                   (car (ex:*used*)))
                             (cdr (ex:*used*)))))
        denotation)))

  ;; For avoiding giving lexically invalid semantics to Scheme expressions
  ;; according to the semantics described in readme.

  (define ex:*used* (make-parameter (list '())))

  ;; Returns <binding name>

  (define (ex:usage-denotation id)
    (let ((denotation (ex:denotation id)))
      (cond ((pair? denotation)
             (ex:displaced-error id))
            ((and (ex:*error-if-free?*) (ex:free-name? denotation))
             (ex:free-error id))
            (else denotation))))

  (define ex:*error-if-free?* (make-parameter #f))

  ;; An environment entry for an identifier binding.
  ;; Returns ((<name> . <marks>) . <binding>)

  (define (ex:make-entry name marks binding)
    (cons (cons name marks) binding))

  ;; Generates a local binding entry at the current meta-level
  ;; that can be added to the usage environment.
  ;; Returns <entry>.

  (define (ex:make-local-entry id)
    (ex:make-entry (ex:identifier-name id)
                   (ex:identifier-marks id)
                   (ex:make-binding (ex:generate-guid (ex:identifier-name id))
                                    (list (ex:source-level id)))))

  ;; Toplevel binding forms use as binding name the free name
  ;; so that source-level forward references will work.
  ;; 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.
  ;; Returns <entry>.

  (define (ex:make-toplevel-entry id)
    (if (null? (ex:identifier-marks id))
        (ex:make-entry (ex:identifier-name id)
                       (ex:identifier-marks id)
                       (ex:make-binding (ex:free-name (ex:identifier-name id))
                                        (list (ex:source-level id))))
        (ex:make-local-entry id)))

  ;; Errors:

  (define (ex:free-error id)
    (ex:syntax-violation "unbound reference"
                         "Identifier must be bound"
                         id))

  (define (ex:displaced-error id)
    (ex:syntax-violation
     "invalid reference"
     (let ((probe (ex:lookup-binding id)))
       (if probe
           (string-append "Attempt to use " (symbol->string (ex:syntax->datum id))
                          " at invalid meta level " (number->string (ex:source-level id))
                          ".  Binding is only available at meta levels: "
                          (apply string-append
                                 (map (lambda (level) (string-append (number->string level) " "))
                                      (ex:binding-levels probe))))
           (string-append "No binding available for " (symbol->string (ex:syntax->datum id))
                          " at meta level " (number->string (ex:source-level id)))))
     id))

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

  ;; An environment consists of a sequence of frames that
  ;; can be destructively extended.
  ;;
  ;; <env>   ::= (<frame> ... <frame0>)
  ;; <frame> ::= (box ((<key> . <object>) ...))
  ;; <key>   ::= a scheme value comparable with equal?

  (define (ex:make-unit-env) (list (ex:make-frame '())))

  ;; Adds a new frame containing entries to env.

  (define (ex:env-extend entries env)
    (cons (ex:make-frame entries) env))

  ;; Destructively extends the leftmost frame in env.

  (define (ex:env-extend! entries env)
    (ex:frame-extend! entries (car env)))

  ;; Returns <object> | default

  (define (ex:env-lookup key env default)
    (cond ((null? env) default)
          ((ex:frame-lookup key (car env)) => cdr)
          (else
           (ex:env-lookup key (cdr env) default))))

  (define (ex:make-frame entries) (ex:box entries))

  ;; Is id already bound in leftmost frame?

  (define (ex:duplicate id env)
    (assoc (cons (ex:identifier-name id)
                 (ex:identifier-marks id))
           (ex:unbox (car env))))

  (define (ex:frame-extend! entries frame)
    (ex:set-box! frame (append entries (ex:unbox frame))))

  (define (ex:frame-lookup key frame)
    (assoc key (ex:unbox frame)))

  (define ex:box      list)
  (define ex:unbox    car)
  (define ex:set-box! set-car!)

  ;;;=========================================================================
  ;;;
  ;;; 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 level computations perform the adjustment of levels in the presence
  ;;; of libraries, where meta-levels may be shifted.
  ;;;
  ;;;=========================================================================

  (define (ex:syntax-reflect id)
    `($ex:syntax-rename ',(ex:identifier-name id)
                        ',(ex:identifier-marks id)
                        ',(ex:reflect-envs id)
                        ;; transformer-expand-time corrected level
                        ,(- (ex:*level*) (ex:identifier-level-correction id) 1)))

  (define (ex:syntax-rename name marks reflected-transformer-envs expand-time-corrected-level)
    (ex:make-identifier name
                        (cons (ex:*mark*) marks)
                        (ex:reify-envs reflected-transformer-envs)
                        ;; transformer-runtime level-correction
                        (- (ex:*level*) expand-time-corrected-level)))

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

  (define (ex:datum->syntax tid datum)
    (ex:check tid ex:identifier? 'datum->syntax)
    (ex:sexp-map (lambda (leaf)
                   (cond ((ex:const? leaf)  leaf)
                         ((symbol? leaf) (ex:make-identifier leaf
                                                             (ex:identifier-marks tid)
                                                             (ex:identifier-transformer-envs tid)
                                                             (ex:identifier-level-correction tid)))
                         (else (assertion-violation 'datum->syntax "Invalid datum" leaf))))
                 datum))

  (define (ex:syntax->datum exp)
    (ex:sexp-map (lambda (leaf)
                   (cond ((ex:const? leaf)      leaf)
                         ((ex:identifier? leaf) (ex:identifier-name leaf))
                         (else
                          (assertion-violation 'syntax->datum "Invalid syntax object" leaf))))
                 exp))

  ;; Fresh identifiers:

  (define (ex:generate-temporaries ls)
    (ex:check ls list? 'generate-temporaries)
    (map (lambda (ignore)
           (ex:rename (ex:generate-guid 'gen)))
         ls))

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

  (define (ex:rename symbol)
    (ex:make-identifier symbol
                        (list (ex:*mark*))
                        (list (ex:env-extend (list (ex:make-entry symbol
                                                                  '()
                                                                  (ex:make-binding symbol '(0))))
                                             (ex:make-unit-env)))
                        (ex:*level*)))

  ;;;=======================================================================
  ;;;
  ;;; Reflecting and reifying transformer environments for
  ;;; inclusion in expanded syntax expressions in object code.
  ;;;
  ;;;=======================================================================

  ;; Table of the form ((<key> . <transformer-envs>) ...)

  (define ex:*reflected-envs* (make-parameter '()))

  ;; Returns a single-symbol representation
  ;; that can be included in object code.

  (define (ex:reflect-envs id)
    (let ((key (ex:generate-guid 'env)))
      (ex:*reflected-envs*
       (cons (cons key
                   (cons (ex:*usage-env*)
                         (ex:identifier-transformer-envs id)))
             (ex:*reflected-envs*)))
      key))

  ;; The inverse of the above.

  (define (ex:reify-envs reflected-envs)
    (cond ((assq reflected-envs (ex:*reflected-envs*)) => cdr)
          (else (error 'reify-envs "Internal error" reflected-envs))))

  (define (ex:extend-reflected-envs! envs)
    (ex:*reflected-envs*
     (append envs (ex:*reflected-envs*))))

  ;; Returns a mark delimiting the environments currently present
  ;; in the reflected environment table.

  (define (ex:current-reflected-envs-mark)
    (ex:*reflected-envs*))

  ;; Returns only relevant reflected environments for
  ;; inclusion in object library.
  ;; This avoids exponentially growing object code when
  ;; imports are chained.

  (define (ex:compress-reflected-envs stop-mark)
    (ex:compress
     (let loop ((tenvs (ex:*reflected-envs*))
                (entries '()))
       (if (eq? tenvs stop-mark)
           entries
           (loop (cdr tenvs)
                 (cons (car tenvs) entries))))))

  ;; Replaces shared nodes in environments by #(<integer>), where
  ;; <integer> denotes another compressed environment.
  ;; Returns (<compressed datum> (<integer> . <compressed datum>) ...)
  ;; This version is aware of the structure of argument because a prior
  ;; generic version was too slow.

  (define (ex:compress reflected-entries)
    (let ((count 0)
          (nodes '()))
      (let loop ((reflected-entries reflected-entries))
        (if (pair? reflected-entries)
            (let ((envs (cdr (car reflected-entries))))
              (for-each (lambda (env)
                          (let loop ((env env))
                            (if (pair? env)
                                (let ((probe (assq env nodes)))
                                  (if probe
                                      (begin
                                        (set-cdr! probe count)
                                        (set! count (+ 1 count)))
                                      (begin
                                        (set! nodes (cons (cons env #f)
                                                          nodes))
                                        (loop (cdr env))))))))
                        envs)
              (loop (cdr reflected-entries)))))
      (let ((nodes (filter cdr nodes)))
        (define (abbreviate env)
          (if (pair? env)
              (let ((probe (assq env nodes)))
                (if probe
                    (vector (cdr probe))
                    (cons (car env)
                          (abbreviate (cdr env)))))
              '()))
        (cons (map (lambda (reflected-entry)
                     (cons (car reflected-entry)
                           (map abbreviate (cdr reflected-entry))))
                   reflected-entries)
              (map (lambda (entry)
                     (cons (cdr entry)
                           (cons (car (car entry))
                                 (abbreviate (cdr (car entry))))))
                   nodes)))))

  (define (ex:uncompress c)
    (let ((datum (car c))
          (table (cdr c)))
      (define (reconstruct env)
        (cond ((vector? env) (reconstruct (cdr (assq (vector-ref env 0) table))))
              ((pair? env)   (cons (car env)
                                   (reconstruct (cdr env))))
              (else env)))
      (map (lambda (reflected-entry)
             (cons (car reflected-entry)
                   (map reconstruct (cdr reflected-entry))))
           datum)))

  ;;;=========================================================================
  ;;;
  ;;; Macros:
  ;;;
  ;;;=========================================================================

  ;; 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-record-type ex:macro (ex:make-macro type proc) ex:macro?
    (type ex:macro-type)
    (proc ex:macro-proc))

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

  (define (ex:make-user-macro obj)
    (if (procedure? obj)
        (ex:make-transformer obj)
        obj))

  (define ex:*macro-toplevel-env* (make-parameter (ex:make-unit-env)))
  (define ex:*macro-usage-env*    (make-parameter (ex:*macro-toplevel-env*)))

  ;; Returns <macro> | #f

  (define (ex:macro-use t)
    (let ((key (if (pair? t)
                   (car t)
                   t)))
      (and (ex:identifier? key)
           (ex:env-lookup (ex:denotation key) (ex:*macro-usage-env*) #f))))

  ;; Registering macro: <maybe-proc> ::= <procedure> | #f
  ;; A #f value indicates that toplevel macro is being shadowed 
  ;; by a later toplevel variable definition.
  
  (define (ex:register-macro! denotation maybe-proc)
    (ex:env-extend! (list (cons denotation (ex:make-user-macro maybe-proc)))
                    (ex:*macro-usage-env*)))

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

  (define (ex:expand t)
    (ex:stacktrace t
                   (lambda ()
                     (cond ((ex:macro-use t) => (lambda (macro)
                                                  (ex:*mark* (ex:generate-mark))
                                                  (let ((expanded-once ((ex:macro-proc macro) t)))
                                                    (case (ex:macro-type macro)
                                                      ((expander) expanded-once)
                                                      (else       (ex:expand expanded-once))))))
                           ((ex:identifier? t)  (ex:usage-denotation t))
                           ((list? t)           (map ex:expand t))
                           ((ex:const? t)       t)
                           (else                (ex:syntax-violation #f "Invalid syntax object" t))))))

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

  (define (ex:head-expand t)
    (ex:stacktrace t
                   (lambda ()
                     (cond
                      ((ex:macro-use t) => (lambda (macro)
                                             (ex:*mark* (ex:generate-mark))
                                             (case (ex:macro-type macro)
                                               ((expander) t)
                                               (else
                                                (ex:head-expand ((ex:macro-proc macro) t))))))
                      (else t)))))

  (define (ex:const? t)
    (or (null?    t)
        (boolean? t)
        (number?  t)
        (string?  t)
        (char?    t)))

  ;;;=========================================================================
  ;;;
  ;;; Quote, if, set!, begin, let-syntax, letrec-syntax:
  ;;;
  ;;;=========================================================================

  (define (ex:expand-quote exp)
    (or (and (list? exp)
             (= (length exp) 2))
        (ex:invalid-form exp))
    (ex:syntax->datum exp))

  (define (ex:expand-if exp)
    (or (and (list? exp)
             (<= 3 (length exp) 4))
        (ex:invalid-form exp))
    `(if ,(ex:expand (cadr exp))
         ,(ex:expand (caddr exp))
         ,@(if (= (length exp) 4)
               (list (ex:expand (cadddr exp)))
               `())))

  (define (ex:expand-set! exp)
    (or (and (list? exp)
             (= (length exp) 3)
             (ex:identifier? (cadr exp)))
        (ex:invalid-form exp))
    (cond ((ex:macro-use (cadr exp))
           => (lambda (macro)
                (case (ex:macro-type macro)
                  ((variable-transformer)
                   (ex:expand ((ex:macro-proc macro) exp)))
                  (else
                   (ex:syntax-violation 'set! "Syntax being set! is not a variable transformer."
                                        exp)))))
          (else `(set! ,(ex:usage-denotation (cadr exp))
                       ,(ex:expand (caddr exp))))))

  ;; Expression begin.

  (define (ex:expand-begin exp)
    (or (and (list? exp)
             (not (null? (cdr exp))))
        (ex:invalid-form exp))
    (ex:scan-sequence 'expression-sequence
                      (ex:*usage-env*)
                      (ex:*macro-usage-env*)
                      #f
                      (cdr exp)
                      (lambda (forms no-syntax-definitions no-bound-variables)
                        `(begin ,@(map cdr forms)))))

  ;; Expression let(rec)-syntax:

  (define (ex:expand-local-syntax t)
    (ex:expand-begin `(,(ex:rename 'begin) ,t)))

  ;; And and or must be primitive, since they are also part of the library
  ;; language, which is primitive.

  (define (ex:expand-and exp)
    (or (list? exp)
        (ex:invalid-form exp))
    (cond ((null? (cdr exp))  #t)
          ((null? (cddr exp)) (ex:expand (cadr exp)))
          (else
           `(if ,(ex:expand (cadr exp))
                ,(ex:expand `(,(ex:rename 'and) ,@(cddr exp)))
                #f))))

  (define (ex:expand-or exp)
    (or (list? exp)
        (ex:invalid-form exp))
    (cond ((null? (cdr exp))  #f)
          ((null? (cddr exp)) (ex:expand (cadr exp)))
          (else
           `(let ((x ,(ex:expand (cadr exp))))
              (if x x ,(ex:expand `(,(ex:rename 'or) ,@(cddr exp))))))))

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

  (define (ex:expand-lambda exp)
    (or (and (pair?    exp)
             (pair?    (cdr exp))
             (ex:formals? (cadr exp))
             (list?    (cddr exp)))
        (ex:invalid-form exp))
    (let ((formals (cadr exp))
          (body    (cddr exp)))
      (parameterize ((ex:*usage-env* (ex:env-extend (map ex:make-local-entry (ex:flatten formals)) (ex:*usage-env*))))
        (let ((formals (ex:dotted-map ex:denotation formals)))
          (parameterize ((ex:*usage-env*       (ex:env-extend '() (ex:*usage-env*)))   ; new scope
                         (ex:*macro-usage-env* (ex:env-extend '() (ex:*macro-usage-env*))))
            (ex:scan-sequence 'lambda
                              (ex:*usage-env*)
                              (ex:*macro-usage-env*)
                              ex:make-local-entry
                              body
                              (lambda (forms syntax-definitions bound-variables)
                                `(lambda ,formals
                                   ((lambda ,bound-variables
                                      ,@(ex:emit-body forms 'set!))
                                    ,@(map (lambda (ignore) `(unspecified))
                                           bound-variables))))))))))

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

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

  ;; R6RS splicing of internal let-syntax and letrec-syntax (and only
  ;; this) requires that we control the bindings visible in each
  ;; expression of the body separately.  This is done by attaching
  ;; any extra bindings that should be visible in the expression
  ;; (over and above the usual bindings) to the expression.
  ;; We call the resulting data structure a wrap.
  ;; Wraps are only used internally in processing of bodies.

  (define-record-type ex:wrap (ex:make-wrap usage-diff macros-diff exp) ex:wrap?
    (usage-diff  ex:wrap-usage-diff)
    (macros-diff ex:wrap-macros-diff)
    (exp         ex:wrap-exp))

  ;; Makes the additional bindings visible and then applies the operation
  ;; to the expression in the wrap.  Here the global fluid parameters become
  ;; a bit inelegant, and I may convert them to ordinary arguments in
  ;; future.

  (define (ex:do-wrap operation w . args)
    (parameterize ((ex:*usage-env*       (ex:env-extend (ex:wrap-usage-diff w)  (ex:*usage-env*)))
                   (ex:*macro-usage-env* (ex:env-extend (ex:wrap-macros-diff w) (ex:*macro-usage-env*))))
      (apply operation (ex:wrap-exp w) args)))

  ;; Copy bindings from w to expression exp.

  (define (ex:copy-wrap w exp)
    (ex:make-wrap (ex:wrap-usage-diff w)
                  (ex:wrap-macros-diff w)
                  exp))

  ;; 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.
  ;; Common-env is shared whose lefmost frame is updated destructively
  ;; as bindings become known:
  ;;
  ;; <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 (only) at toplevel, and so all expressions and
  ;; right hand sides at toplevel must be expanded as they are encountered from
  ;; left to right a la typical r5rs implementation.  This differs from the
  ;; expansion algorithm for libraries, programs and lambda bodies, which
  ;; strictly follows r6rs.

  (define (ex:scan-sequence body-type common-env common-macro-env binder body-forms k)

    ;; Each <form> ::= (<symbol> . <wrap or s-expr>)  (definition)
    ;;              |  (#f       . <wrap or s-expr>)  (expression)

    (define (expand-forms forms)
      (map (lambda (form)
             (cons (car form)
                   (if (ex:wrap? (cdr form))
                       (ex:do-wrap ex:expand (cdr form))
                       (cdr form))))
           forms))

    (let ()
      (ex:*used* (cons '() (ex:*used*)))  ; start new used scope

      (let loop ((ws              (map (lambda (e) (ex:make-wrap '() '() e)) body-forms))
                 (forms           '())
                 (syntax-defs     '())
                 (bound-variables '()))
        (if (null? ws)
            (begin
              (ex:check-expression-body body-type forms body-forms)
              (ex:*used* (cons (append (car (ex:*used*))    ; merge used with parent scope
                                       (cadr (ex:*used*)))
                               (cddr (ex:*used*))))
              (k (reverse (expand-forms forms))
                 (reverse syntax-defs)
                 bound-variables))
            (let* ((w  (ex:copy-wrap (car ws) (ex:do-wrap ex:head-expand (car ws))))
                   (ws (cdr ws))
                   (type (ex:do-wrap (lambda (t)
                                       (and (pair? t)
                                            (ex:identifier? (car t))
                                            (ex:denotation (car t))))
                                     w)))
              (ex:check-expression-sequence body-type type w)
              (case type
                ((import)
                 (ex:check-toplevel body-type type w)
                 (let-values (((imported-libraries imports) (ex:do-wrap ex:scan-imports w)))
                   (parameterize ((ex:*macro-usage-env* common-macro-env))  ; scope for visit
                     (ex:import-libraries imported-libraries 0 'compile))
                   (ex:env-import! (car (ex:wrap-exp w)) imports common-env)
                   (loop ws
                         (cons (cons #f `($ex:import-libraries ',imported-libraries 0 'execute))
                               forms)
                         syntax-defs
                         bound-variables)))
                ((program)
                 (ex:check-toplevel body-type type w)
                 (loop ws
                       (cons (cons #f (ex:do-wrap ex:expand-program w)) forms)
                       syntax-defs
                       bound-variables))
                ((library)
                 (ex:check-toplevel body-type type w)
                 (loop ws
                       (cons (cons #f (ex:do-wrap ex:expand-library w)) forms)
                       syntax-defs
                       bound-variables))
                ((define)
                 (let-values (((id rhs) (ex:do-wrap ex:parse-definition w)))
                   (ex:check-duplicate id common-env body-type w)
                   (ex:check-used      id body-type w)
                   (ex:check-definition-follows-expression body-type forms 'define w)
                   (ex:env-extend! (list (binder id)) common-env)
                   (and (eq? body-type 'toplevel)
                        (ex:macro-use id)
                        ;; shadow previously defined macro with same name
                        (ex:env-extend! (list (cons (ex:denotation id) #f)) common-macro-env))
                   (loop ws
                         (cons (cons (ex:denotation id)
                                     (let ((rhs* (ex:copy-wrap w rhs)))
                                       (if (eq? body-type 'toplevel)
                                           (ex:do-wrap ex:expand rhs*)
                                           rhs*)))
                               forms)
                         syntax-defs
                         (cons (ex:denotation id) bound-variables))))
                ((define-syntax)
                 (let-values (((id rhs) (ex:do-wrap ex:parse-definition w)))
                   (ex:check-duplicate id common-env body-type w)
                   (ex:check-used      id body-type w)
                   (ex:check-definition-follows-expression body-type forms 'define-syntax w)
                   (ex:env-extend! (list (binder id)) common-env)
                   (let ((rhs (parameterize ((ex:*level* (+ 1 (ex:*level*))))
                                (ex:do-wrap ex:expand (ex:copy-wrap w rhs)))))
                     (ex:env-extend! (list (cons (ex:denotation id)
                                                 (ex:make-user-macro (eval rhs))))
                                     common-macro-env)
                     (loop ws
                           forms
                           (cons (cons (ex:denotation id) rhs) syntax-defs)
                           bound-variables))))
                ((begin)
                 (loop (append (map (lambda (exp)
                                      (ex:copy-wrap w exp))
                                    (cdr (ex:wrap-exp w)))
                               ws)
                       forms
                       syntax-defs
                       bound-variables))
                ((let-syntax letrec-syntax)
                 (let-values (((formals vals body) (ex:do-wrap ex:parse-local-syntax w)))
                   (let* ((entries    (map ex:make-local-entry formals))
                          (usage-diff (append entries (ex:wrap-usage-diff w)))
                          (rhs-env    (ex:env-extend usage-diff (ex:*usage-env*)))
                          (macros
                           (map (lambda (val)
                                  (eval (ex:do-wrap (lambda (e)
                                                      (parameterize ((ex:*level* (+ 1 (ex:*level*))))
                                                        (case type
                                                          ((let-syntax) (ex:expand e))
                                                          ((letrec-syntax)
                                                           (parameterize ((ex:*usage-env* rhs-env))
                                                             (ex:expand e))))))
                                                    (ex:copy-wrap w val))))
                                vals))
                          (macros-diff
                           (append (map (lambda (entry macro)
                                          (cons (ex:binding-name (cdr entry))
                                                (ex:make-user-macro macro)))
                                        entries
                                        macros)
                                   (ex:wrap-macros-diff w))))
                     (loop (cons (ex:make-wrap usage-diff
                                               macros-diff
                                               `(,(ex:rename 'begin) . ,body))
                                 ws)
                           forms
                           syntax-defs
                           bound-variables))))
                (else
                 (loop ws
                       (cons (cons #f
                                   (if (eq? body-type 'toplevel)
                                       (ex:do-wrap ex:expand w)
                                       w))
                             forms)
                       syntax-defs
                       bound-variables))))))))

  (define (ex: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 (ex:check-expression-sequence body-type type w)
    (and (eq? body-type 'expression-sequence)
         (memq type '(import program library declare define define-syntax))
         (ex:syntax-violation type "Invalid form in expression sequence"
                              (ex:wrap-exp w))))

  (define (ex:check-toplevel body-type from w)
    (and (not (eq? body-type 'toplevel))
         (ex:syntax-violation from "Expression may only occur at toplevel"
                              (ex:wrap-exp w))))

  (define (ex:check-definition-follows-expression body-type forms from w)
    (and (not (memq body-type `(toplevel program)))
         (not (null? forms))
         (not (symbol? (car (car forms))))
         (ex:syntax-violation from "Definitions may not follow expressions in a body"
                              (ex:wrap-exp w))))

  (define (ex:check-duplicate id env body-type w)
    (and (not (eq? body-type 'toplevel))
         (ex:duplicate id env)
         (ex:syntax-violation 'definition (string-append "Duplicate binding of "
                                                         (symbol->string (ex:syntax->datum id))
                                                         " in body")
                              (ex:wrap-exp w))))

  (define (ex:check-used id body-type w)
    (and (not (eq? body-type 'toplevel))
         (let* ((already-used (car (ex:*used*)))  ; only current scope
                (denotation (ex:denotation id)))  ; this changes *used* and must follow previous
           (if (memp (lambda (entry)
                       (and (eq? denotation (cdr entry))
                            (ex:bound-identifier=? id (car entry))))
                     already-used)
               (ex:syntax-violation 'definition (string-append "Redefinition of identifier "
                                                               (symbol->string (ex:syntax->datum id))
                                                               " that has already been used during expansion of body")
                                    (ex:wrap-exp w))))))

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

  (define (ex:parse-definition t)
    (or (and (pair? t)
             (pair? (cdr t)))
        (ex:syntax-violation #f "Invalid definition format" t))
    (let ((k    (car t))
          (head (cadr t))
          (body (cddr t)))
      (cond ((and (ex:identifier? head)
                  (list? body)
                  (<= (length body) 1))
             (values head (if (null? body)
                              `(,(ex:rename 'unspecified))
                              (car body))))
            ((and (pair? head)
                  (ex:identifier? (car head))
                  (ex:formals? (cdr head)))
             (values (car head)
                     `(,(ex:rename 'lambda) ,(cdr head) . ,body)))
            (else (ex:syntax-violation #f "Invalid definition format" t)))))

  (define (ex:parse-local-syntax t)
    (or (and (pair? t)
             (pair? (cdr t))
             (list? (cadr t))
             (list? (cddr t))
             (for-all (lambda (binding)
                        (and (pair? binding)
                             (ex:identifier? (car binding))
                             (pair? (cdr binding))
                             (null? (cddr binding))))
                      (cadr t)))
        (ex:syntax-violation #f "Invalid form" t))
    (let ((formals (map car (cadr t)))
          (exps    (map cadr (cadr t)))
          (body    (cddr t)))
      (or (ex:formals? formals)
          (ex:syntax-violation #f "Duplicate binding" t))
      (values formals
              exps
              body)))

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

  (define ex:*pvar-env* (make-parameter (ex:make-unit-env)))

  (define (ex:expand-syntax-case exp)
    (if (and (list? exp)
             (>= (length exp) 3))
        (let ((literals (caddr exp))
              (clauses (cdddr exp)))
          (if (and (list? literals)
                   (for-all ex:identifier? literals)
                   (not (memp (lambda (x) (or (ex:free=? x '_)
                                              (ex:free=? x '...)))
                              literals)))
              (let ((input (ex:generate-guid 'input)))
                `(let ((,input ,(ex:expand (cadr exp))))
                   ,(ex:process-clauses clauses input literals)))
              (ex:syntax-violation 'syntax-case "Invalid literals list" exp literals)))
        (ex:invalid-form exp)))

  (define (ex:process-clauses clauses input literals)

    (define (process-match input pattern sk fk)
      (cond
       ((not (symbol? input)) (let ((temp (ex:generate-guid 'temp)))
                                `(let ((,temp ,input))
                                   ,(process-match temp pattern sk fk))))
       ((and (ex:identifier? pattern)
             (memp (lambda (x)
                     (ex:bound-identifier=? x pattern))
                   literals))
        `(if (and ($ex:identifier? ,input)
                  ($ex:free-identifier=? ,input ,(ex:syntax-reflect pattern)))
             ,sk
             ,fk))
       ((ex:ellipses? pattern)       (ex:syntax-violation 'syntax-case "Invalid use of ellipses" pattern))
       ((null? pattern)              `(if (null? ,input) ,sk ,fk))
       ((ex:const? pattern)          `(if (equal? ,input ',pattern) ,sk ,fk))
       ((ex:wildcard? pattern)       sk)
       ((ex:identifier? pattern)     `(let ((,(ex:denotation pattern) ,input)) ,sk))
       ((ex:segment-pattern? pattern)
        (let ((tail-pattern (cddr pattern)))
          (if (null? tail-pattern)
              (let ((mapped-pvars (map ex:denotation (map car (pattern-vars (car pattern) 0)))))
                (if (ex:identifier? (car pattern))                      ; +++
                    `(if (list? ,input)                                 ; +++
                         (let ((,(ex:denotation (car pattern)) ,input)) ; +++
                           ,sk)                                         ; +++
                         ,fk)                                           ; +++
                    (let ((columns (ex:generate-guid 'cols))
                          (rest    (ex:generate-guid 'rest)))
                      `($ex:map-while (lambda (,input)
                                        ,(process-match input
                                                        (car pattern)
                                                        `(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))))))
              (let ((tail-length (ex:dotted-length tail-pattern)))
                `(if (>= ($ex:dotted-length ,input) ,tail-length)
                     ,(process-match `($ex:dotted-butlast ,input ,tail-length)
                                     `(,(car pattern) ,(cadr pattern))
                                     (process-match `($ex:dotted-last ,input ,tail-length)
                                                    (cddr pattern)
                                                    sk
                                                    fk)
                                     fk)
                     ,fk)))))
       ((pair? pattern)   `(if (pair? ,input)
                               ,(process-match `(car ,input)
                                               (car pattern)
                                               (process-match `(cdr ,input) (cdr pattern) sk fk)
                                               fk)
                               ,fk))
       ((vector? pattern) `(if (vector? ,input)
                               ,(process-match `(vector->list ,input)
                                               (vector->list pattern)
                                               sk
                                               fk)
                               ,fk))
       (else (ex:syntax-violation 'syntax-case "Invalid pattern" pattern))))

    (define (pattern-vars pattern level)
      (cond
       ((ex:identifier? pattern)      (if (or (ex:ellipses? pattern)
                                              (ex:wildcard? pattern)
                                              (memp (lambda (x)
                                                      (ex:bound-identifier=? x pattern))
                                                    literals))
                                          '()
                                          (list (cons pattern level))))
       ((ex:segment-pattern? pattern) (append (pattern-vars (car pattern) (+ level 1))
                                              (pattern-vars (cddr pattern) level)))
       ((pair? pattern)               (append (pattern-vars (car pattern) level)
                                              (pattern-vars (cdr pattern) level)))
       ((vector? pattern)             (pattern-vars (vector->list pattern) level))
       (else                          '())))

    (define (process-clause clause input fk)
      (or (and (list? clause)
               (>= (length clause) 2))
          (ex:syntax-violation 'syntax-case "Invalid clause" clause))
      (let* ((pattern  (car clause))
             (template (cdr clause))
             (pvars    (pattern-vars pattern 0)))
        (or (ex:set? (map car pvars) ex:bound-identifier=?)
            (ex:syntax-violation 'syntax-case "Repeated pattern variable" clause (map car pvars)))
        (let ((entries (map ex:make-local-entry (map car pvars))))
          (parameterize ((ex:*usage-env* (ex:env-extend entries (ex:*usage-env*)))
                         (ex:*pvar-env*  (ex:env-extend (map (lambda (entry pvar)
                                                               (cons (ex:binding-name (cdr entry))
                                                                     (cdr pvar)))
                                                             entries
                                                             pvars)
                                                        (ex:*pvar-env*))))
            (process-match input
                           pattern
                           (cond ((null? (cdr template))
                                  (ex:expand (car template)))
                                 ((null? (cddr template))
                                  `(if ,(ex:expand (car template))
                                       ,(ex:expand (cadr template))
                                       ,fk))
                                 (else (ex:syntax-violation 'syntax-case "Invalid clause" clause)))
                           fk)))))

    ;; ex:process-clauses

    (if (null? clauses)
        `($ex:invalid-form ,input)
        (let ((fail  (ex:generate-guid 'fail)))
          `(let ((,fail (lambda () ,(ex:process-clauses (cdr clauses) input literals))))
             ,(process-clause (car clauses) input `(,fail))))))

  (define (ex:wildcard? x) (ex:free=? x '_))

  ;; Ellipsis utilities:

  (define (ex:ellipses? x) (ex:free=? x '...))

  (define (ex:segment-pattern? pattern)
    (and (ex:segment-template? pattern)
         (or (for-all (lambda (p)
                        (not (ex:ellipses? p)))
                      (ex:flatten (cddr pattern)))
             (ex:syntax-violation 'syntax-case "Invalid segment pattern" pattern))))

  (define (ex:segment-template? pattern)
    (and (pair? pattern)
         (pair? (cdr pattern))
         (ex:identifier? (cadr pattern))
         (ex:ellipses? (cadr pattern))))

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

  (define (ex:segment-depth pattern)
    (if (ex:segment-template? pattern)
        (+ 1 (ex:segment-depth (cdr pattern)))
        0))

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

  (define (ex:segment-tail pattern)
    (let loop ((pattern (cdr pattern)))
      (if (and (pair? pattern)
               (ex:identifier? (car pattern))
               (ex:ellipses? (car pattern)))
          (loop (cdr pattern))
          pattern)))

  ;; Ellipses-quote:

  (define (ex:ellipses-quote? template)
    (and (pair? template)
         (ex:ellipses? (car template))
         (pair? (cdr template))
         (null? (cddr template))))

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

  (define (ex:expand-syntax form)
    (or (and (pair? form)
             (pair? (cdr form))
             (null? (cddr form)))
        (ex:invalid-form form))
    (ex:process-template (cadr form) 0 #f))

  (define (ex:process-template template dim quote-ellipses)
    (cond ((and (ex:ellipses? template)
                (not quote-ellipses))
           (ex:syntax-violation 'syntax "Invalid occurrence of ellipses in syntax template" template))
          ((ex:identifier? template)
           (let ((denotation (ex:denotation template)))
             (cond ((ex:env-lookup denotation (ex:*pvar-env*) #f)
                    => (lambda (pdim)
                         (if (<= pdim dim)
                             denotation
                             (ex:syntax-violation 'syntax "Template dimension error (too few ...'s?)"
                                                  template))))
                   (else (ex:syntax-reflect template)))))
          ((ex:ellipses-quote? template)
           (ex:process-template (cadr template) dim #t))
          ((and (ex:segment-template? template)
                (not quote-ellipses))
           (let* ((depth (ex:segment-depth template))
                  (seg-dim (+ dim depth))
                  (vars
                   (map (lambda (id)
                          (ex:usage-denotation id))
                        (ex:free-meta-variables (car template) seg-dim '()))))
             (if (null? vars)
                 (ex:syntax-violation 'syntax "too many ...'s" template)
                 (let* ((x (ex:process-template (car template) seg-dim quote-ellipses))
                        (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? (ex:segment-tail template))
                       gen                                ; +++
                       `(append ,gen ,(ex:process-template (ex:segment-tail template) dim quote-ellipses)))))))
          ((pair? template)
           `(cons ,(ex:process-template (car template) dim quote-ellipses)
                  ,(ex:process-template (cdr template) dim quote-ellipses)))
          ((vector? template)
           `(list->vector ,(ex:process-template (vector->list template) dim quote-ellipses)))
          (else
           `(quote ,(ex:expand template)))))

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

  (define (ex:free-meta-variables template dim free)
    (cond ((ex:identifier? template)
           (if (and (not (memp (lambda (x)
                                 (ex:bound-identifier=? x template))
                               free))
                    (let ((pdim (ex:env-lookup (ex:denotation template) (ex:*pvar-env*) #f)))
                      (and pdim
                           (>= pdim dim))))
               (cons template free)
               free))
          ((ex:segment-template? template)
           (ex:free-meta-variables (car template) dim
                                   (ex:free-meta-variables (cddr template) dim free)))
          ((pair? template)
           (ex:free-meta-variables (car template) dim
                                   (ex:free-meta-variables (cdr template) dim free)))
          (else free)))

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

  (define (ex:expand-program t)
    (ex:expand-library-or-program
     `(,(car t) (,(ex:datum->syntax (car t) (ex:generate-guid 'program)))
       (,(ex:datum->syntax (car t) 'export)) . ,(cdr t))
     'program))

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

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

  (define (ex:expand-library-or-program t library-type)
    (or (and (list? t)
             (>= (length t) 4))
        (ex:syntax-violation 'library "Invalid number of clauses in library" t))

    (let* ((keyword (car t))
           (name    (ex:scan-library-name (cadr t))))

      (let-values (((exports)                    (ex:scan-exports (caddr t)))
                   ((imported-libraries imports) (ex:scan-imports (cadddr t)))
                   ((body)                       (cddddr t)))

        ;; Make sure we start with a clean compilation environment,
        ;; and that we restore any global state afterwards.
        ;; Make sure macros registered when visiting
        ;; imported libraries are removed once we are done.

        (parameterize ((ex:*error-if-free?*  #t)
                       (ex:*reflected-envs*  '())
                       (ex:*pvar-env*        (ex:make-unit-env))
                       (ex:*usage-env*       (ex:make-unit-env))
                       (ex:*macro-usage-env* (ex:env-extend '() ex:primitive-macro-env)))

          (ex:import-libraries imported-libraries 0 'compile)
          (ex:env-import! keyword imports (ex:*usage-env*))

          ;; Obtain a mark so that compress-reflected-envs will know
          ;; which reflected environments are created for use by this
          ;; library and should be included in the object code.

          (let ((stop-mark (ex:current-reflected-envs-mark)))  ; +++

            (ex:scan-sequence library-type
                              (ex:*usage-env*)
                              (ex:*macro-usage-env*)
                              ex:make-local-entry
                              body
                              (lambda (forms syntax-definitions bound-variables)

                                ;; This has to be done here, when all bindings are established.
                                (let* ((exports (map (lambda (entry)
                                                       (cons (ex:identifier-name (car entry))
                                                             (let ((binding (ex:lookup-binding (cadr entry))))
                                                               (or binding
                                                                   (ex:syntax-violation 'library "Unbound export" t
                                                                                        (car entry))))))
                                                     exports))
                                       (expanded-library
                                        (case library-type
                                          ((program) `(begin
                                                        ($ex:import-libraries ',imported-libraries 0 'execute)
                                                        ,@(ex:emit-body forms 'define)))
                                          ((library)
                                           `(begin
                                              (define ,(ex:name-for 'envs    name) ($ex:uncompress ',(ex:compress-reflected-envs stop-mark)))
                                              (define ,(ex:name-for 'exports name) ',exports)
                                              (define ,(ex:name-for 'imports name) ',imported-libraries)

                                              (define (,(ex:name-for 'visit name))
                                                ,@(map (lambda (def)
                                                         `($ex:register-macro! ',(car def) ,(cdr def)))
                                                       syntax-definitions)
                                                (unspecified))

                                              ,@(map (lambda (var)
                                                       `(define ,var (unspecified)))
                                                     bound-variables)

                                              (define (,(ex:name-for 'invoke name))
                                                ,@(ex:emit-body forms 'set!)
                                                (unspecified)))))))

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

                                  expanded-library))))))))

  (define (ex:env-import! keyword imports env)
    (ex:env-extend! (map (lambda (import)
                           (ex:make-entry (car import)
                                          (ex:identifier-marks keyword)
                                          (cdr import)))
                         imports)
                    env))

  ;; session ::= compile | execute

  (define (ex:import-libraries imports level session)

    (define *visited*  '())
    (define *invoked*  '())
    (define *imported* '())

    (define (import-libraries* imports level session)
      (if (not (null? imports))
          (let* ((import (car imports))
                 (name   (car import))
                 (levels (cdr import)))
            (if (null? levels)
                (import-libraries* (cdr imports) level session)
                (begin
                  (import-library name (+ level (car levels)) session)
                  (import-libraries* (cons (cons name (cdr levels))
                                           (cdr imports))
                                     level
                                     session))))))

    (define (import-library name level session)
      (and (not (member (cons name level) *imported*))
           (let ((imports (eval (ex:name-for 'imports name))))
             ;; Do this first so accidental cyclic dependencies will not hang
             (set! *imported* (cons (cons name level) *imported*))
             (import-libraries* imports level session)
             (and (>= level 0)
                  (case session
                    ((compile)
                     (and (>= level 0)
                          (let ((visited? (member name *visited*)))
                            (or visited?
                                (begin
                                  (ex:extend-reflected-envs! (eval (ex:name-for 'envs name)))
                                  (parameterize ((ex:*level* level))
                                    (eval `(,(ex:name-for 'visit name))))
                                  (set! *visited* (cons name *visited*))))))
                     (and (>= level 1)
                          (let ((invoked? (member name *invoked*)))
                            (or invoked?
                                (begin
                                  (parameterize ((ex:*level* level))
                                    (eval `(,(ex:name-for 'invoke name))))
                                  (set! *invoked* (cons name *invoked*)))))))
                    ((execute)
                     (and (= level 0)
                          (eval `(,(ex:name-for 'invoke name))))))))))

    (import-libraries* imports level session))

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

  (define (ex:scan-exports clause)
    (and (pair? clause)
         (ex:free=? (car clause) 'export)
         (list? (cdr clause)))
    (let ((exports (apply append
                          (map ex:scan-export-spec (cdr clause)))))
      (or (ex:set? exports
                   (lambda (x y)
                     (eq? (ex:identifier-name (car x))
                          (ex:identifier-name (car y)))))
          (ex:syntax-violation 'export "Duplicate export" clause))
      exports))

  (define (ex:scan-export-spec spec)
    (let ((levels `(0))               ;; Will be ignored in current implementation, but keep data
          (export-sets (list spec)))  ;; structures and interfaces same in case FOR exports return.
      (map (lambda (rename-pair)
             (cons (car rename-pair)
                   (cons (cdr rename-pair)
                         levels)))
           (apply append (map ex:scan-export-set export-sets)))))

  (define (ex:scan-export-set set)
    (cond ((ex:identifier? set)
           (list (cons set set)))
          ((ex:rename-export-set? set)
           (map (lambda (entry)
                  (cons (cadr entry)
                        (car entry)))
                (cdr set)))
          (else
           (ex:syntax-violation 'export "Invalid export set" set))))

  (define (ex:scan-levels spec)
    (cond ((ex:for-spec? spec)
           (let ((levels
                  (map (lambda (level)
                         (cond ((ex:free=? level 'run)    0)
                               ((ex:free=? level 'expand) 1)
                               ((ex:meta-spec? level)     (cadr level))
                               (else (ex:syntax-violation 'for "Invalid level in for spec" spec level))))
                       (cddr spec))))
             (if (ex:set? levels =)
                 levels
                 (ex:syntax-violation 'for "Repeated level in for spec" spec))))
          (else '(0))))

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

  (define (ex:scan-imports clause)
    (or (and (pair? clause)
             (ex:free=? (car clause) 'import)
             (list?  (cdr clause)))
        (ex:syntax-violation 'import "Invalid import clause" clause))
    (ex:scan-import-specs (cdr clause)))

  (define (ex:scan-import-specs all-specs)
    (let loop ((specs all-specs)
               (imported-libraries '())
               (imports '()))
      (if (null? specs)
          (values imported-libraries (ex:unify-imports imports))
          (let-values (((library-ref levels more-imports) (ex:scan-import-spec (car specs))))
            (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 (ex:scan-import-spec spec)
    (let ((levels (ex:scan-levels spec)))
      (let loop ((import-set (if (ex:for-spec? spec)
                                 (cadr spec)
                                 spec))
                 (renamer (lambda (x) x)))

        ;; Extension for importing unadorned primitives:

        (cond ((ex:primitive-set? import-set)
               (values #f
                       levels
                       ;; renamer will return <symbol> | #f
                       (filter car
                               (map (lambda (name)
                                      (cons name
                                            (ex:make-binding name levels)))
                                    (ex:syntax->datum (cadr import-set))))))
              ((and (list? import-set)
                    (>= (length import-set) 2)
                    (or (ex:only-set? import-set)
                        (ex:except-set? import-set)
                        (ex:prefix-set? import-set)
                        (ex:rename-set? import-set)))
               (loop (cadr import-set)
                     (ex:compose renamer
                                 ;; Remember to correctly propagate if x is #f
                                 (lambda (x)
                                   (cond
                                    ((ex:only-set? import-set)
                                     (and (memq x (ex:syntax->datum (cddr import-set)))
                                          x))
                                    ((ex:except-set? import-set)
                                     (and (not (memq x (ex:syntax->datum (cddr import-set))))
                                          x))
                                    ((ex:prefix-set? import-set)
                                     (and x
                                          (string->symbol
                                           (string-append (symbol->string (ex:syntax->datum (caddr import-set)))
                                                          (symbol->string x)))))
                                    ((ex:rename-set? import-set)
                                     (let ((renames (ex:syntax->datum (cddr import-set))))
                                       (cond ((assq x renames) => cadr)
                                             (else x))))
                                    (else (ex:syntax-violation 'import "Invalid import set" import-set)))))))
              ((ex:library-ref? import-set)
               (let* ((exports (eval (ex:name-for 'exports (ex:syntax->datum import-set))))
                      (imports
                       ;; renamer will return <symbol> | #f
                       (filter car
                               (map (lambda (export)
                                      (cons (renamer (car export))
                                            (ex:make-binding (ex:binding-name (cdr export))
                                                             (ex:compose-levels levels
                                                                                (ex:binding-levels (cdr export))))))
                                    exports)))
                      (all-import-levels (apply ex:unionv
                                                (map (lambda (import)
                                                       (ex:binding-levels (cdr import)))
                                                     imports))))
                 (values (ex:syntax->datum import-set)
                         levels
                         imports)))
              (else (ex:syntax-violation 'import "Invalid import set" import-set))))))

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

  ;; Argument is of the form ((<local name> <binding>) ...)
  ;; where combinations (<local name> (binding-symbol <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> occurs with <binding>s
  ;; whose (binding-symbol <binding>)s are different.

  (define (ex:unify-imports imports)
    (if (null? imports)
        '()
        (let ((first (car imports))
              (rest  (ex:unify-imports (cdr imports))))
          (let loop ((rest rest)
                     (seen '()))
            (cond ((null? rest)
                   (cons first seen))
                  ((eq? (car first) (caar rest))
                   (or (eq? (ex:binding-name (cdr first))
                            (ex:binding-name (cdar rest)))
                       (ex:syntax-violation 'import "Same name imported from different libraries"
                                            (car first)))
                   (cons (cons (car first)
                               (ex:make-binding (ex:binding-name (cdr first))
                                                (ex:unionv (ex:binding-levels (cdr first))
                                                           (ex:binding-levels (cdar rest)))))
                         (append (cdr rest) seen)))
                  (else
                   (loop (cdr rest)
                         (cons (car rest) seen))))))))

  (define (ex:for-spec? spec)
    (and (list? spec)
         (>= (length spec) 3)
         (ex:free=? (car spec) 'for)))

  (define (ex:meta-spec? level)
    (and (list? level)
         (= (length level) 2)
         (ex:free=? (car level) 'meta)
         (integer? (cadr level))))

  (define (ex:only-set? set)
    (and (ex:free=? (car set) 'only)
         (for-all ex:identifier? (cddr set))))

  (define (ex:except-set? set)
    (and (ex:free=? (car set) 'except)
         (for-all ex:identifier? (cddr set))))

  (define (ex:prefix-set? set)
    (and (ex:free=? (car set) 'prefix)
         (= (length set) 3)
         (ex:identifier? (caddr set))))

  (define (ex:rename-set? set)
    (and (ex:free=? (car set) 'rename)
         (ex:rename-list? (cddr set))))

  (define (ex:primitive-set? set)
    (and (list? set)
         (= (length set) 2)
         (ex:free=? (car set) 'primitives)
         (list (cadr set))
         (for-all ex:identifier? (cadr set))))

  (define (ex:rename-export-set? set)
    (and (list? set)
         (>= (length set) 1)
         (ex:free=? (car set) 'rename)
         (ex:rename-list? (cdr set))))

  (define (ex:rename-list? ls)
    (for-all (lambda (e)
               (and (list? e)
                    (= (length e) 2)
                    (for-all ex:identifier? e)))
             ls))

  (define (ex:scan-library-name e)
    (or (ex:library-name? e)
        (ex:syntax-violation 'library "Invalid library name" e))
    (ex:syntax->datum e))

  (define (ex:library-name? e)
    (and (list? e)
         (let ((e (reverse e)))
           (and (for-all ex:identifier? (cdr e))
                (or (ex:identifier? (car e))
                    (and (list? (car e))
                         (for-all ex:subversion? (car e))))))))

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

  (define (ex:library-name->string e)
    (string-append (symbol->string (car e))
                   (apply string-append
                          (map (lambda (e)
                                 (string-append "."
                                                (symbol->string e)))
                               (let ((re (reverse (cdr e))))
                                 (if (and (pair? re)
                                          (list? (car re)))
                                     (reverse (cdr re))
                                     (cdr e)))))))

  (define (ex:library-ref? e)
    (and (list? e)
         (let ((e (reverse e)))
           (and (for-all ex:identifier? (cdr e))
                (or (ex:identifier? (car e))
                    (and (list? (car e))
                         (for-all ex:subversion-reference?
                                  (car e))))))))

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

  (define (ex:subversion-condition? e)
    (and (list? e)
         (pair? e)
         (ex:identifier? (car e))
         (case (ex:denotation (car e))
           ((>= <=)
            (and (= (length e) 2)
                 (ex:subversion? (cadr e))))
           ((and or)
            (for-all ex:subversion-condition? (cdr e)))
           ((not)
            (and (= (length e) 2)
                 (ex:subversion-condition? (cadr e))))
           (else #f))))

  (define ex:library-ref->string ex:library-name->string)

  (define (ex:name-for command name)
    (ex:free-name (string->symbol (string-append (ex:library-ref->string name) ex:separator
                                                 (symbol->string command)))))

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

  ;; Debugging information displayed by syntax-violation.

  (define ex:*backtrace* (make-parameter '()))

  (define (ex:stacktrace term thunk)
    (parameterize ((ex:*backtrace* (cons term (ex:*backtrace*))))
      (thunk)))

  (define (ex:syntax-violation who message form . maybe-subform)
    (newline)
    (display "Syntax violation: ")
    (let ((who (if who
                   who
                   (cond ((ex:identifier? form)
                          (ex:syntax->datum form))
                         ((and (list? form)
                               (ex:identifier? (car form)))
                          (ex: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 (ex:syntax-debug subform))
                 (newline)))
      (display "Form: ")
      (pretty-print (ex:syntax-debug form))
      (newline)
      (display "Backtrace: ")
      (newline)
      (newline)
      (for-each (lambda (exp)
                  (display "  ")
                  (pretty-print (ex:syntax-debug exp))
                  (newline))
                (ex:*backtrace*))
      (error 'syntax-violation "Integrate with host error handling here")))

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

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

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

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

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

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

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

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

  (define (ex:dotted-butlast ls n)
    (let recurse ((ls ls)
                  (length-left (ex: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 (ex:dotted-last ls n)
    (let recurse ((ls ls)
                  (length-left (ex: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 (ex:map-while f lst k)
    (cond ((null? lst) (k '() '()))
          ((pair? lst)
           (let ((head (f (car lst))))
             (if head
                 (ex:map-while f
                               (cdr lst)
                               (lambda (answer rest)
                                 (k (cons head answer)
                                    rest)))
                 (k '() lst))))
          (else  (k '() lst))))

  (define (ex:set? ls =)
    (or (null? ls)
        (and (not (memp (lambda (x)
                          (= x (car ls)))
                        (cdr ls)))
             (ex:set? (cdr ls) =))))

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

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

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

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

  (define ex:syntax-error (ex:make-expander ex:invalid-form))

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

  (define ex:eval-template
    (ex:make-identifier 'eval-template
                        '()
                        '()
                        0))

  (define-record-type ex:r6rs-environment (ex:make-r6rs-environment imported-libraries imports)
    ex:r6rs-environment?
    (imported-libraries ex:r6rs-environment-imported-libraries)
    (imports            ex:r6rs-environment-imports))

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

  (define (ex:r6rs-eval exp env)
    (parameterize ((ex:*usage-env* (ex:make-unit-env)))
      (ex:env-import! ex:eval-template (ex:r6rs-environment-imports env) (ex:*usage-env*))
      (let ((exp (ex:datum->syntax ex:eval-template exp)))
        (ex:import-libraries (ex:r6rs-environment-imported-libraries env) 0 'compile)
        (ex:import-libraries (ex:r6rs-environment-imported-libraries env) 0 'execute)
        (eval (ex:expand exp)))))

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

  (define ex:toplevel-template
    (ex:make-identifier 'toplevel-template
                        '()
                        '()
                        0))

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

  (define ex:*toplevel-env* (make-parameter (ex:make-unit-env)))
  (define ex:*usage-env*    (make-parameter (ex:*toplevel-env*)))

  (define ex:library-language
    (map (lambda (name)
           (cons name (ex:make-binding name '(0))))
         '(library
           program
           import
           export
           for
           run
           expand
           meta
           only
           except
           prefix
           rename
           >=
           <=
           and
           or
           not
           primitives)))

  ;; These are the macros that may be used in libraries and programs.

  (define ex:primitive-macros
    `((lambda        . ,(ex:make-expander ex:expand-lambda))
      (if            . ,(ex:make-expander ex:expand-if))
      (set!          . ,(ex:make-expander ex:expand-set!))
      (begin         . ,(ex:make-expander ex:expand-begin))
      (syntax        . ,(ex:make-expander ex:expand-syntax))
      (quote         . ,(ex:make-expander ex:expand-quote))
      (let-syntax    . ,(ex:make-expander ex:expand-local-syntax))
      (letrec-syntax . ,(ex:make-expander ex:expand-local-syntax))
      (syntax-case   . ,(ex:make-expander ex:expand-syntax-case))
      (and           . ,(ex:make-expander ex:expand-and))
      (or            . ,(ex:make-expander ex:expand-or))
      (define        . ,ex:syntax-error)
      (define-syntax . ,ex:syntax-error)
      (_             . ,ex:syntax-error)
      (...           . ,ex:syntax-error)))

  (define ex:primitive-macro-env (ex:env-extend ex:primitive-macros (ex:make-unit-env)))

  ;; Includes library language.

  (define ex:toplevel-primitive-macros
    (append ex:primitive-macros
            `((program       . ,ex:syntax-error)
              (library       . ,ex:syntax-error)
              (import        . ,ex:syntax-error)
              (for           . ,ex:syntax-error)
              (run           . ,ex:syntax-error)
              (expand        . ,ex:syntax-error)
              (meta          . ,ex:syntax-error)
              (only          . ,ex:syntax-error)
              (except        . ,ex:syntax-error)
              (prefix        . ,ex:syntax-error)
              (rename        . ,ex:syntax-error)
              (primitives    . ,ex:syntax-error)
              ;; >=  already bound to primitive
              ;; <=  ditto
              ;; not ditto
              ;; and ditto
              ;; or  ditto
              )))

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

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

  (define (ex:reset-toplevel!)
    (ex:*backtrace*       '())
    (ex:*error-if-free?*  #f)
    (ex:*level*           0)
    (ex:*used*            (list '()))
    (ex:*mark*            (ex:generate-mark))
    (ex:*pvar-env*        (ex:make-unit-env))
    (ex:*usage-env*       (ex:*toplevel-env*))
    (ex:*macro-usage-env* (ex:*macro-toplevel-env*)))

  (define (ex:expand-toplevel-sequence forms)
    (ex:reset-toplevel!)
    (ex:scan-sequence 'toplevel
                      (ex:*toplevel-env*)
                      (ex:*macro-toplevel-env*)
                      ex:make-toplevel-entry
                      (ex:source->syntax forms)
                      (lambda (forms syntax-definitions bound-variables)
                        (ex:emit-body forms 'define))))

  ;;;==========================================================================
  ;;;
  ;;;  Load and expand-file:
  ;;;
  ;;;==========================================================================

  ;; This may be used as a front end for the compiler:
  ;; The dependencies must list the already expanded files
  ;; containing libraries to be imported.

  (define (ex:expand-file filename target-filename . dependencies)
    (for-each load dependencies)
    (ex:write-file (ex:expand-toplevel-sequence (ex:normalize (ex:read-file filename)))
                   target-filename))

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

  (define (ex:normalize exps)
    (define (error)
      (let ((newline (string #\newline)))
        (ex: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 ex:read-file
    (lambda (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 ex:write-file
    (lambda (exps fn)
      (if (file-exists? fn)
          (delete-file fn))
      (let ((p (open-output-file fn)))
        (for-each (lambda (exp)
                    (write exp p)
                    (newline p)
                    (newline p))
                  exps)
        (close-output-port p))))

  ;; Initial toplevel environments:

  (ex:env-import! ex:toplevel-template ex:library-language (ex:*toplevel-env*))
  (ex:env-extend! ex:toplevel-primitive-macros (ex:*macro-toplevel-env*))

  ;; Exports:

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

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

  (set! $ex:invalid-form              ex:invalid-form)
  (set! $ex:uncompress                ex:uncompress)
  (set! $ex:register-macro!           ex:register-macro!)
  (set! $ex:extend-reflected-envs!    ex:extend-reflected-envs!)
  (set! $ex:import-libraries          ex:import-libraries)
  (set! $ex:syntax-rename             ex:syntax-rename)
  (set! $ex:map-while                 ex:map-while)
  (set! $ex:dotted-length             ex:dotted-length)
  (set! $ex:dotted-butlast            ex:dotted-butlast)
  (set! $ex:dotted-last               ex:dotted-last)

  ) ; Expander

;; TODO - 5.95 import syntax is ambiguous.  Wait for 5.96?
;; TODO - (primitives ()) is ambiguous since () could be version.  Wait for 5.96.
;; TODO - I think 5.95 is wrong on export levels.  Wait for 5.96.
;; TODO - ... and _ should be allowed as literals.  Wait for 5.96.
;; TODO - simpler algorithm idea decoupling environments from identifiers.