1;;=================================================================================
;;;
;;; 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.  See description below.
;;;   - 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.
;;;                            Suitable for separate compilation.
;;;   - ex:run-r6rs-sequence : Evaluates a sequence of forms of the format
;;;                            <library>* | <library>* <toplevel program>.
;;;                            The <toplevel program> environment is separate from the 
;;;                            interactive REPL environment and does not persist
;;;                            between invocations of run-r6rs-sequence.  
;;;                            For importing and evaluating stuff in the persistent 
;;;                            interactive environment, ex:REPL should be used instead.
;;;   - ex:run-r6rs-program  : Same as ex:run-r6rs-sequence, except that it reads the 
;;;                            input from a file.
;;;   - 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.
;;;    
;;; EX:REPL evaluates a sequence of library definitions, commands, and top-level 
;;; import forms in the interactive environment.  The semantics for 
;;; evaluating libraries in and importing bindings into the interactive 
;;; environment is consistent with the ERR5RS proposal at
;;; http://scheme-punks.cyber-rush.org/wiki/index.php?title=ERR5RS:Libraries.
;;; Bindings in the interactive environment persist between invocations 
;;; of REPL. 
;;;
;;; 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:
;;; ----------------------------------
;;;
;;; This section is mostly of interest for r5rs non-compliant systems.
;;;
;;; The expander relies on r5rs (or r6rs) syntax-rules and letrec-syntax
;;; and should run in a correct r5rs system, but if you don't have 
;;; r5rs macros, you may bootstrap it by expanding the expander itself
;;; first on an R5RS system.
;;; Here is how to do it:
;;;
;;;   (load "compat-mzscheme.scm")   ; for example bootstrapping from mzscheme 
;;;   (load "runtime.scm")
;;;   (load "expander.scm")
;;;   (ex:expand-file "standard-libraries.scm" "standard-libraries.exp")
;;;   (ex:expand-r5rs-file "expander.scm" "expander.exp" (ex:environment '(rnrs base)))
;;; 
;;; The expanded (.exp) files are vanilla Scheme and can then be run on the target
;;; system as follows:
;;;
;;;   (load "compat-chez.scm")       ; for example
;;;   (load "runtime.scm")
;;;   (load "standard-libraries.exp")
;;;   (load "expander.exp")
;;;
;;; 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:
;;
;;=================================================================================
;; Removed by TH:
;; The include file runtime.scm has to be loaded before loading this expander
;;

;;=================================================================================
;;
;; EXPORTS:
;;
;;=================================================================================

(import (guile)
	(rnrs exceptions)
	(rnrs lists)
	(srfi srfi-1)
	(srfi srfi-9)
	(srfi srfi-13)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))

(define gl-x1 '())

(define gl-trace? #f)

(define-hrecord-type <expander> ()
  exporting-names?
  alo-current-exports
  ht-all-exports
  ht-modules
  tup-default-module
  ht-source-exprs
  ht-syntax-source)

(define gl-expander '())

(define (init-expander)
  (let ((expander (make-hrecord <expander>
				#f
				'()
				(make-hash-table gl-i-all-exports-size)
				(make-hash-table gl-i-modules-size)
				'()
				'()
				'())))
    (set! gl-expander expander)))

(init-expander)

(define (init-source-expr-tables)
  (let ((ht-source-exprs (make-hash-table gl-i-source-exprs-size))
	(ht-syntax-source (make-hash-table gl-i-syntax-source-size))
	(ht-var-orig-names (make-hash-table gl-i-orig-names-size)))
    (hfield-set! gl-expander 'ht-source-exprs ht-source-exprs)
    (hfield-set! gl-expander 'ht-syntax-source ht-syntax-source)
    (set! gl-ht-var-orig-names ht-var-orig-names)))

(define (d x) (display "d: ") (display x) (newline))

(define ex:unspecified (if #f #f))

;; Direct exports:

(define gl-id #f)
(define gl-flag1? #f)
(define gl-counter1 0)
(define gl-counter2 0)

(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:load                      #f)
(define ex:syntax-violation          #f)

;; System exports:

;; (define ex:expand-file               #f)
;; (define ex:repl                      #f)
;; (define ex:expand-r5rs-file          #f)
;; (define ex:run-r6rs-sequence         #f)
;; (define ex:run-r6rs-program          #f)

(define ex:expand-toplevel-sequence  #f)
(define ex:expand-toplevel-sequence1 #f)
(define ex:expand                    #f)
;;(define ex:normalize                 #f)
(define ex:read-file                 #f)
(define ex:binding-from-id           #f)
(define ex:make-local-mapping        #f)
(define ex:make-global-mapping2      #f)
(define ex:generate-guid             #f)
(define ex:interpret-core0           #f)
(define ex:interpret-core            #f)
(define ex:get-macro-table           #f)
(define ex:toplevel-env              #f)
(define ex:usage-env                 #f)
(define ex:set-usage-env             #f)
(define ex:al-toplevel-env           #f)
(define ex:test-prog                 #f)
(define ex:source->syntax1           #f)
(define ex:usage-env-extend!         #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)

(define primitive-macro-language     '())
(define core-language                '())
(define al-prim-macros               '())
(define al-prim-procs                '())
(define al-prim-bindings             '())
(define al-prim-language             '())

(define-record-type :identifier
  (make-identifier name colors transformer-envs displacement maybe-library module)
  identifier?
  (name id-name)
  (colors id-colors)
  (transformer-envs id-transformer-envs)
  (displacement id-displacement)
  (maybe-library id-maybe-library)
  (module id-module))


(define (hashq-exists? ht x-key)
  (if (hashq-get-handle ht x-key) #t #f))


(define (get-module0 l-module-name)
  (hash-ref (hfield-ref gl-expander 'ht-modules) l-module-name))

(define (get-module l-module-name)
  (let* ((ht (hfield-ref gl-expander 'ht-modules))
	 (l-prev (hash-ref ht l-module-name)))
    (if l-prev
	l-prev
	(let ((x-module (cons (cons al-prim-bindings '()) '())))
	  (hash-set! ht l-module-name x-module)
	  x-module))))

(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 (- ___ ? 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 ___ 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 ___) k arg ...)
        ;;  (matcher "base" (p ___) "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.
	 )
    ;; TH: old identifier implementation removed.

    (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-from-id x))
             (by (binding-from-id 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-from-id 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.
    ;; TH: The token is not needed for Theme-D.
    (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))))
      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> toplevel? address #f)
    ;;            |  (macro            <binding-name> (<level> ...) #f          <library-name> toplevel? #f macro-obj)
    ;;            |  (pattern-variable <binding-name> (<level> ...) <dimension> <library-name> #f #f #f)
    ;;            |  #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-hrecord-type <macro-binding> ()
      type name levels content library toplevel? address macro)
    
    (define (make-binding0 type name levels content library
			   toplevel? address macro-obj)
      (make-hrecord <macro-binding>
		    type name levels content library toplevel?
		    address macro-obj))
    
    (define (make-binding type name levels content library toplevel?)
      (make-hrecord <macro-binding>
		    type name levels content library toplevel?
		    #f #f))

    (define (binding-type b) (hfield-ref b 'type))
    (define (binding-name b) (hfield-ref b 'name))
    (define (binding-levels b) (hfield-ref b 'levels))
    (define (binding-content b) (hfield-ref b 'content))
    (define (binding-mutable? b) (hfield-ref b 'content))
    (define (binding-dimension b) (hfield-ref b 'content))
    (define (binding-library b) (hfield-ref b 'library))
    (define (binding-toplevel? b) (hfield-ref b 'toplevel?))
    (define (binding-address b) (hfield-ref b 'address))
    (define (binding-macro b) (hfield-ref b 'macro))

    (define (binding-mutable-set! b x) (hfield-set! b 'content x))
    (define (binding-macro-set! b x) (hfield-set! b 'macro x))
    
    (define (is-toplevel-name? s-name)
      (let ((i-len (string-length ex:guid-prefix))
	    (str-name (symbol->string s-name)))
	(or (< (string-length str-name) i-len)
	    (not (string=? (substring str-name 0 i-len) ex:guid-prefix)))))

    ;; 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-from-id id)
      (let ((name (id-name id)))
        (let loop ((env    *usage-env*)
                   (envs   (id-transformer-envs id))
                   (colors (id-colors id)))
          (or
	   (let ((tmp1 (env-lookup (cons name colors) env)))
	     (if (and tmp1 (not (binding-toplevel? tmp1)))
		 tmp1
		 (let* ((env2 (get-module0 (id-module id)))
			(tmp2 (env-lookup (cons name colors) env2)))
		   (cond
		    (tmp2 tmp2)
		    (tmp1 tmp1)
		    (else #f)))))
	   (and (pair? envs)
		(loop (env-reify (car envs))
		      (cdr envs)
		      (cdr colors)))))))

    (define (get-binding-ref binding)
      ;; (d2wl 'cur "get-binding-ref")
      ;; (d2wl 'cur (binding-name binding))
      (let ((address (binding-address binding)))
	(if address
	    (list skw-module-ref
		  (hfield-ref address 'module)
		  (hfield-ref address 'source-name))
	    (binding-name binding))))

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

    (define (add-var-orig-name orig-name new-name)
      (if (not-null? gl-ht-var-orig-names)
	  (hashq-set! gl-ht-var-orig-names new-name orig-name)))

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

    (define (make-local-mapping type id content)
      (let* ((orig-name (id-name id))
	     (new-name (generate-guid orig-name))
	     (result
	      (cons (cons orig-name
			  (id-colors id))
		    (make-binding type
				  new-name
				  (list (source-level id))
				  content
				  *current-library*
				  #f))))
	(add-var-orig-name orig-name new-name)
	result))

    ;; 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 1)
                              content
                              *current-library*
			      #t))
          (make-local-mapping type id content)))

    (define (make-global-mapping type id content)
      (if (null? (id-colors id))
          (cons (cons (id-name id)
                      (id-colors id))
                (make-binding type
                              (id-name id)
                              '(0 1)
                              content
                              *current-library*
			      #t))
          (make-local-mapping type id content)))

    (define (make-global-mapping2 type id content address)
      ;; Not sure if it is necessary to test colors here.
      (if (null? (id-colors id))
          (cons (cons (id-name id)
                      (id-colors id))
                (make-binding0 type
			       (id-name id)
			       '(0 1)
			       content
			       *current-library*
			       #t
			       address
			       #f))
          (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) " ")
			      "\nphase: " (number->string *phase*)
			      "\ndisplacement: " (number->string
						  (id-displacement id)))
               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)
      `($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)
		       ',(id-module id)))

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

    ;;=====================================================================
    ;;
    ;; 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)
					  (id-module tid)))
                        (else leaf)))
                datum))

    (define (datum->syntax1 tid datum)
      (check tid identifier? 'datum->syntax)
      (sexp-map1 (lambda (leaf)
		   (cond ((symbol? leaf)
			  (make-identifier leaf
					   (id-colors tid)
					   (id-transformer-envs tid)
					   (id-displacement tid)
					   (id-maybe-library tid)
					   (hfield-ref gl-expander 'tup-default-module)))
			 (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)
      (let ((toplevel? (is-toplevel-name? symbol)))
	(make-identifier symbol
			 (list *color*)
			 (list (env-extend
				(list (cons (cons symbol '())
					    (make-binding type symbol '(0) #f '()
							  toplevel?)))
				(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 env)
      (list type proc env))
    (define macro-type car)
    (define macro-proc cadr)
    (define macro-module caddr)

    (define (make-expander proc)
      (make-macro 'expander proc (hfield-ref gl-expander 'tup-default-module)))
    (define (make-transformer proc)
      (make-macro 'transformer proc (hfield-ref gl-expander
						'tup-default-module)))
    (define (make-variable-transformer proc)
      (make-macro 'variable-transformer proc
		  (hfield-ref gl-expander 'tup-default-module)))

    (define (make-user-macro impl)
      (if (and (list? impl) (not (null? impl))
	       (eq? (car impl) '$make-variable-transformer))
	  (make-variable-transformer (cadr impl))
	  (make-transformer impl)))

    (define (get-macro-env macro)
      (let* ((x-module (macro-module macro))
	     (env (hash-ref (hfield-ref gl-expander 'ht-modules) x-module)))
	(assert (not (eq? env #f)))
	env))

    (define (core-lambda-proc? x-expr)
      ;; Don't do syntax check here.
      (and
       (list? x-expr)
       (eq? (car x-expr) '$lambda)))

    ;; Returns <macro>.

    (define (binding->macro binding t)
      (binding-macro binding))
    ;; (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 procedure-or-macro)
    ;;                            *macro-table*)))

    ;; Calls a macro with a new color.

    (define (invoke-macro macro t)
      ;; (d2wl 'expand "invoke-macro ENTER")
      ;; (d2wl 'expand macro)
      (set! *color* (generate-color))
      (let* ((proc (macro-proc macro))
	     (result
	      (cond
	       ((procedure? proc) (proc t))
	       (else
		(interpret-core (list proc t))))))
	;; (cond
	;;  ((procedure? proc) (proc t))
	;;  ((core-lambda-proc? proc)
	;; 	(interpret-core (list proc t)))
	;;  (else
	;; 	(syntax-violation #f "invoke-macro: internal error"
	;; 			  'undefined)))))
	(d2wl 'expand "invoke-macro EXIT")
	;; (d2wl 'expand result)
	;;	(d2wl 'expand (hashq result 1000000))
	;;	(newline)
	result))

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

    (define (get-orig-expr x-syntax)
      (d2wl 'scan "get-orig-expr")
      (set! gl-counter1 (+ gl-counter1 1))
      (let ((ht-syntax-source (hfield-ref gl-expander 'ht-syntax-source)))
	(if (not-null? ht-syntax-source)
	    (let ((sexpr (hashq-ref ht-syntax-source x-syntax)))
	      (d2wl 'scan "get-orig-expr/1")
	      (d2wl 'scan x-syntax)
	      (d2wl 'scan sexpr)
	      (d2wl 'scan (eq? x-syntax gl-x1))
	      (d2wl 'scan (equal? x-syntax gl-x1))
	      (if sexpr
		  sexpr
		  (syntax->datum x-syntax)))
	    (syntax->datum x-syntax))))

    (define (add-source-exprs sexpr-result sexpr-orig flag?)
      (if flag? (display "add-source-exprs\n"))
      (if flag? (begin
		  (display sexpr-orig)
		  (newline)
		  (display (source-properties sexpr-orig))
		  (newline)
		  (display sexpr-result)
		  (newline)))
      (let ((ht-source-exprs (hfield-ref gl-expander 'ht-source-exprs)))
	(if (and (not-null? ht-source-exprs)
		 (not-null? (source-properties sexpr-orig)))
	    (begin
	      (if flag? (display "add-source-exprs/1\n"))
	      (if (and (not-null? sexpr-result)
		       (list? sexpr-result)
		       (not (hashq-ref ht-source-exprs sexpr-result)))
		  (begin
		    (if flag? (display "add-source-exprs/2\n"))
		    (for-each (lambda (sexpr-sub)
				(add-source-exprs sexpr-sub sexpr-orig #f))
			      sexpr-result)
		    (hashq-set! ht-source-exprs sexpr-result sexpr-orig)))))))

    (define (add-scanned-source-exprs forms src)
      (if (= (length forms) (length src))
	  (for-each (lambda (result orig)
		      (add-source-exprs (cdr result)
					(get-orig-expr orig)
					#f))
		    forms src)))

    (define (expand t)
      ;; (d2wl 'expand "expand ENTER")
      ;; (d2wl 'expand t)
      (fluid-let ((*trace* (cons t *trace*)))
		 (let ((binding (operator-binding t))
		       (flag? #f))
		   (cond (binding (case (binding-type binding)
				    ((macro)
				     ;; (d2wl 'expand "expand/macro")
				     ;; (d2wl 'expand "binding name: ")
				     ;; (d2wl 'expand (binding-name binding))
				     (let ((macro (binding->macro binding t)))
				       (let* ((expanded-once (invoke-macro macro t))
					      (result
					       (case (macro-type macro)
						 ((expander)
						  ;; (d2wl 'expand "expand/1")
						  expanded-once)
						 (else
						  ;; (d2wl 'expand "expand/2")
						  (let ((x
							 (expand expanded-once)))
						    x)))))
					 (let ((orig-expr (get-orig-expr t)))
					   (add-source-exprs result
							     orig-expr
							     flag?))
					 result)))
				    ((variable)
				     (check-implicit-import-of-mutable binding t)
				     (if (list? t)
					 (let ((result
						(cons (get-binding-ref binding)
						      (map expand (cdr t)))))
					   (add-source-exprs result
							     (get-orig-expr t)
							     #f)
					   result)
					 (get-binding-ref binding)))
				    ((pattern-variable)
				     (syntax-violation #f "Pattern variable used outside syntax template" t))))
			 ((list? t)
			  (let ((result (map expand t)))
			    (add-source-exprs result (get-orig-expr t) #f)
			    result))
			 ((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)
      (d2wl 'expand "operator-binding")
      (set! gl-counter2 (+ gl-counter2 1))
      (d2wl 'expand gl-counter2)
      (let ((operator (if (pair? t) (car t) t)))
        (and (identifier? operator)
             (let ((binding (binding-from-id 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)))

    (define (id-bound? id)
      (if (binding-from-id id) #t #f))

    (define (id-free? id)
      (not (id-bound? id)))

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

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

    (define (expand-if0 exp s-kw)
      (match exp
	     ((- e1 e2 e3) `(,s-kw ,(expand e1) ,(expand e2) ,(expand e3)))
	     ((- e1 e2)    `(,s-kw ,(expand e1) ,(expand e2)))))

    (define (expand-if-object exp)
      (expand-if0 exp skw-if-object))

    (define (expand-if exp)
      (expand-if0 exp skw-if))

    (define (identifier-list? x)
      (and
       (list? x)
       (for-all identifier? x)))

    (define (expand-set!0 exp s-kw)
      (d2wl 'i-s "expand-set!0")
      (d2wl 'i-s exp)
      (match exp
	     ((- (? identifier? id) e)
	      (d2wl 'i-s "expand-set!0/1")
	      (let ((binding (binding-from-id id)))
		(check-binding-level id binding)
		(register-use! id binding)
		(d2wl 'i-s "expand-set!0/1-0")
		(d2wl 'i-s id)
		(d2wl 'i-s binding)
		(if (eq? binding #f)
		    (syntax-violation s-kw "Undefined identifier" exp id)
		    (case (binding-type binding)
		      ((macro)
		       (let ((macro (binding->macro binding id)))
			 (d2wl 'i-s "expand-set!0 HEP")
			 (d2wl 'i-s id)
			 (d2wl 'i-s macro)
			 (case (macro-type macro)
			   ((variable-transformer)
			    (expand (invoke-macro macro exp)))
			   (else
			    (syntax-violation
			     s-kw "Keyword being set! is not a variable transformer" exp id)))))
		      ((variable)
		       (d2wl 'i-s "expand-set!0/1-2")
		       (or (eq? (binding-library binding) *current-library*)
			   (syntax-violation
			    s-kw "Directly or indirectly imported variable cannot be assigned" exp id))
		       (binding-mutable-set! binding #t)
		       (d2wl 'i-s "expand-set!0/1-3")
		       `(,s-kw ,(binding-name binding)
			       ,(expand e)))
		      ((pattern-variable)
		       (d2wl 'i-s "expand-set!0/1-4")
		       (syntax-violation s-kw "Pattern variable used outside syntax template" exp id))))))
	     ((- (@ (? identifier? module) (? identifier? var)) e)
	      (d2wl 'i-s "expand-set!0/2")
	      `(,s-kw (@ ,(id-name module) ,(id-name var))
		      ,(expand e)))
	     ((- (@ (? identifier-list? module) (? identifier? var)) e)
	      (d2wl 'i-s "expand-set!0/3")
	      `(,s-kw (@ ,(map id-name module) ,(id-name var))
		      ,(expand e)))))

    (define (expand-set! exp)
      (expand-set!0 exp 'set!))

    (define (expand-$set! exp)
      (expand-set!0 exp '$set!))

    ;; Expression begin.

    (define (expand-begin exp)
      (d2wl 'expand "expand-begin ENTER")
      (match exp
	     ((- exps ___)
	      (scan-sequence 'expression-sequence
			     #f
			     exps
			     (lambda (forms no-syntax-definitions
					    no-bound-variables)
			       (add-scanned-source-exprs forms exps)
			       `(,skw-begin ,@(map cdr forms)))))))

    ;; Expression let(rec)-syntax:

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

    ;; TH: Removed expand-and and expand-or.

    (define (has-duplicates? l-symbols)
      (let ((dup? #f))
	(do ((l1 l-symbols (cdr l1))) ((or (null? l1) dup?) dup?)
	  (do ((l2 (cdr l1) (cdr l2))) ((or (null? l2) dup?))
	    (if (eq? (car l1) (car l2)) (set! dup? #t))))))

    (define (expand-general-let exp s-keyword)
      (d2wl 'scan "expand-general-let")
      (d2wl 'let1 "let HEP")
      (match exp
	     ((- (? let-bindings? bdg) body ___)
	      (begin
		(let* ((x-names1 (map car bdg))
		       (x-values1 (map last bdg))
		       (x-types1 (map (lambda (x-binding)
					(if (= (length x-binding) 3)
					    (cadr x-binding)
					    '()))
				      bdg)))
		  (d2wl 'let1 "let HEP2")
		  (let* ((x-values2 (map* expand x-values1))
			 (x-types2 (map* (lambda (x-type)
					   (if (not-null? x-type)
					       (expand x-type)
					       '()))
					 x-types1))
			 (result
			  (fluid-let
			   ((*usage-env*
			     (env-extend (map (lambda (formal)
						(make-local-mapping 'variable
								    formal #f))
					      x-names1)
					 *usage-env*)))
			   (let* ((x-names2
				   (map
				    (lambda (x-name)
				      (binding-name (binding-from-id x-name)))
				    x-names1))
				  (x-bindings
				   (map (lambda (s-name x-type x-value)
					  (if (not-null? x-type)
					      (list s-name x-type x-value)
					      (list s-name x-value)))
					x-names2 x-types2 x-values2)))
			     (if (has-duplicates? x-names2)
				 (syntax-violation s-keyword 
						   "duplicate identifier"
						   exp))
			     (fluid-let
			      ((*usage-env* (env-extend '() *usage-env*)))
			      (scan-sequence
			       'let
			       make-local-mapping
			       body
			       (lambda (forms syntax-defs bound-vars)
				 (add-scanned-source-exprs forms body)
				 `(,s-keyword
				   ,x-bindings
				   ,@(emit-body forms ex:undefined-set!)))))))))
		    (d2wl 'scan "expand-general-let EXIT")
		    result))))))

    (define (expand-general-letrec exp s-keyword)
      (match exp
	     ((- (? let-bindings? bdg) body ___)
	      (begin
		(let ((x-names1 (map car bdg)))
		  (fluid-let
		   ((*usage-env*
		     (env-extend (map (lambda (formal)
					(make-local-mapping 'variable
							    formal #f))
				      x-names1)
				 *usage-env*)))
		   (let* ((x-values1 (map last bdg))
			  (x-types1 (map (lambda (x-binding)
					   (if (= (length x-binding) 3)
					       (cadr x-binding)
					       '()))
					 bdg))
			  (x-names2
			   (map
			    (lambda (x-name)
			      (binding-name (binding-from-id x-name)))
			    x-names1)))
		     (if (has-duplicates? x-names2)
			 (syntax-violation s-keyword "duplicate identifier"
					   exp))
		     (let* ((x-values2 (map* expand x-values1))
			    (x-types2 (map* (lambda (x-type)
					      (if (not-null? x-type)
						  (expand x-type)
						  '()))
					    x-types1))
			    (x-bindings (map (lambda (s-name x-type x-value)
					       (if (not-null? x-type)
						   (list s-name x-type x-value)
						   (list s-name x-value)))
					     x-names2 x-types2 x-values2))
			    (result
			     (fluid-let
			      ((*usage-env* (env-extend '() *usage-env*)))
			      (scan-sequence
			       'let
			       make-local-mapping
			       body
			       (lambda (forms syntax-defs bound-vars)
				 (add-scanned-source-exprs forms body)
				 `(,s-keyword
				   ,x-bindings
				   ,@(emit-body forms ex:undefined-set!)))))))
		       result))))))))

    (define (let-bindings? l)
      (and-map? (lambda (x-binding)
		  (and
		   (list? x-binding)
		   (let ((i-len (length x-binding)))
		     (or (= i-len 3) (= i-len 2)))
		   (identifier? (car x-binding))))
		l))

    (define (expand-let exp)
      (expand-general-let exp skw-let))

    (define (expand-letrec exp)
      (expand-general-letrec exp skw-letrec))

    (define (expand-letrec* exp)
      (expand-general-letrec exp skw-letrec*))

    (define (expand-let-mutable exp)
      (expand-general-let exp skw-let-variables))

    (define (expand-letrec-mutable exp)
      (expand-general-letrec exp skw-letrec-variables))

    (define (expand-letrec*-mutable exp)
      (expand-general-letrec exp skw-letrec*-variables))

    (define (expand-let-volatile exp)
      (expand-general-let exp skw-let-volatile))

    (define (expand-letrec-volatile exp)
      (expand-general-letrec exp skw-letrec-volatile))

    (define (expand-letrec*-volatile exp)
      (expand-general-letrec exp skw-letrec*-volatile))

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

    (define (expand-$lambda exp)
      (d2wl 'expand "expand-$lambda")
;;      (d2wl 'expand exp)
;;      (d2wl 'expand "expand-$lambda/1")
;;      (d2wl 'expand *usage-env*)
      (match exp
	     ((- (? formals? formals) body ___)
	      (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-from-id 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)
						       ;; (d2wl 'expand "expand-$lambda/1")
						       ;; (d2wl 'expand bound-variables)
						       ;; (newline)
						       `(,skw-$lambda ,formals
								      ,@(if (null? bound-variables)                ; +++
									    (emit-body forms ex:undefined-set!)    ; +++
									    `((($lambda ,bound-variables
											,@(emit-body forms ex:undefined-set!))
									       ,@(map (lambda (ignore) `$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))))))

    (define (expand-lambda0 formals result-type attributes body id aut?)
      (d2wl 'expand "expand-lambda0")
      (assert (or (identifier? id) (null? id)))
      (let ((l-formal-names (map car formals)))
	(fluid-let ((*usage-env*
		     (env-extend (map (lambda (formal)
					(make-local-mapping 'variable formal #f))
				      ;; Calling flatten is probably not necessary.
				      (flatten l-formal-names))
				 *usage-env*)))
		   (let* ((l-formal-names2
			   (dotted-map
			    (lambda (formal)
			      (binding-name (binding-from-id formal)))
			    l-formal-names))
			  (l-types (map cadr formals))
			  (l-exp-types (map expand l-types))
			  (l-target-formals (map list l-formal-names2 l-exp-types))
			  (l-target-result-type (if (not aut?) (list (expand result-type)) '()))
			  (attributes2 (expand attributes))
			  (l-name (if (not-null? id) (list (id-name id)) '()))
			  (s-kw (if (not aut?) skw-procedure skw-procedure-aut)))
		     (d2wl 'expand "expand-lambda0/1")
		     (d2wl 'expand body)
		     ;; 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)
						 (d2wl 'expand "expand-lambda0/2")
						 (d2wl 'expand forms)
						 (add-scanned-source-exprs forms body)
						 `(,s-kw ,@l-name (,l-target-formals ,@l-target-result-type ,attributes2)
							 ,@(if (null? bound-variables)                ; +++
							       (emit-body forms ex:undefined-set!)    ; +++
							       `((($lambda ,bound-variables
									   ,@(emit-body forms ex:undefined-set!))
								  ,@(map (lambda (ignore) `$undefined)
									 bound-variables))))))))))))

    (define (expand-lambda exp)
      (match exp
	     ((- ((? theme-d-formals? formals) result-type attributes) body ___)
	      (expand-lambda0 formals result-type attributes body '() #f))
	     ((- (? identifier? id-name) ((? theme-d-formals? formals) result-type attributes) body ___)
	      (expand-lambda0 formals result-type attributes body id-name #f))))

    (define (expand-lambda-aut exp)
      (match exp
	     ((- ((? theme-d-formals? formals) attributes) body ___)
	      (expand-lambda0 formals '() attributes body '() #t))
	     ((- (? identifier? id-name) ((? theme-d-formals? formals) attributes) body ___)
	      (expand-lambda0 formals '() attributes body id-name #t))))

    (define (theme-d-formals? l)
      (and-map?
       (lambda (x-formal)
	 (and
	  (list? x-formal)
	  (= (length x-formal) 2)
	  (identifier? (car x-formal))))
       l))

    (define (expand-param-lambda0 params formals result-type attributes body id aut?)
      (assert (or (identifier? id) (null? id)))
      (let ((l-formal-names (map car formals)))
	(fluid-let ((*usage-env*
		     (env-extend
		      (map (lambda (formal)
			     (make-local-mapping 'variable formal #f))
			   ;; Calling flatten is probably not necessary.
			   (append params (flatten l-formal-names)))
		      *usage-env*)))
		   (let* ((l-formal-names2
			   (dotted-map
			    (lambda (formal)
			      (binding-name (binding-from-id formal)))
			    l-formal-names))
			  (l-types (map cadr formals))
			  (l-exp-types (map expand l-types))
			  (l-target-formals (map list l-formal-names2 l-exp-types))
			  (l-target-result-type (if (not aut?) (list (expand result-type)) '()))
			  (attributes2 (expand attributes))
			  (l-name (if (not-null? id) (list (id-name id)) '()))
			  (l-target-params (map expand params))
			  (s-kw (if (not aut?) skw-param-proc skw-param-proc-aut)))
		     ;; 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)
						 (add-scanned-source-exprs forms body)
						 `(,s-kw ,@l-name
							 ,l-target-params
							 (,l-target-formals ,@l-target-result-type ,attributes2)
							 ,@(if (null? bound-variables)                ; +++
							       (emit-body forms ex:undefined-set!)    ; +++
							       `((($lambda ,bound-variables
									   ,@(emit-body forms ex:undefined-set!))
								  ,@(map (lambda (ignore) `$undefined)
									 bound-variables))))))))))))

    (define (param-list? l)
      (and
       (list? l)
       (and-map? identifier? l)))

    (define (expand-param-lambda exp)
      (match exp
	     ((- (? param-list? params) ((? theme-d-formals? formals) result-type attributes) body ___)
	      (expand-param-lambda0 params formals result-type attributes body '() #f))
	     ((- (? identifier? id-name) (? param-list? params) ((? theme-d-formals? formals) result-type attributes) body ___)
	      (expand-param-lambda0 params formals result-type attributes body id-name #f))))

    (define (expand-param-lambda-aut exp)
      (match exp
	     ((- (? param-list? params) ((? theme-d-formals? formals) attributes) body ___)
	      (expand-param-lambda0 params formals '() attributes body '() #t))
	     ((- (? identifier? id-name) (? param-list? params) ((? theme-d-formals? formals) attributes) body ___)
	      (expand-param-lambda0 params formals '() attributes body id-name #t))))

    ;;=========================================================================
    ;;
    ;; Other forms:
    ;;
    ;;=========================================================================

    (define (expand-until exp)
      (match exp
	     ((- (condition result) body ___)
	      (fluid-let
	       ((*usage-env* (env-extend '() *usage-env*)))
	       (let ((x-exp-body
		      (scan-sequence 'until
				     #f
				     body
				     (lambda (forms no-syntax-definitions no-bound-variables)
				       (add-scanned-source-exprs forms body)
				       (map cdr forms)))))
		 `(,skw-until (,(expand condition) ,(expand result)) ,@x-exp-body))))
	     ((- (condition) body ___)
	      (fluid-let
	       ((*usage-env* (env-extend '() *usage-env*)))
	       (let ((x-exp-body
		      (scan-sequence 'until
				     #f
				     body
				     (lambda (forms no-syntax-definitions no-bound-variables)
				       (add-scanned-source-exprs forms body)
				       (map cdr forms)))))
		 `(,skw-until (,(expand condition)) ,@x-exp-body))))))

    (define (expand-proc-class exp s-kw)
      (match exp
	     ((- (arg-type ___) result-type attrs)
	      (let* ((l-target-arg-types (map expand arg-type))
		     (x-target-result-type (expand result-type))
		     (x-target-attrs
		      (if (list? attrs)
			  (map expand attrs)
			  (expand attrs))))
		(list s-kw l-target-arg-types
		      x-target-result-type x-target-attrs)))
	     ((- arg1 ___)
	      (syntax-violation s-kw "Invalid procedure class" exp))
	     ;; Formerly we had ':procedure here.
	     (- s-kw)))

    (define (expand-simple-proc-class exp)
      (expand-proc-class exp ':simple-proc))

    (define (expand-abstract-proc-class exp)
      (expand-proc-class exp ':procedure))

    (define (expand-param-proc-class exp)
      (match exp
	     ((- (param1 param2 ___) (arg-type ___) result-type attrs)
	      (let ((l-params (cons param1 param2)))
		(fluid-let ((*usage-env*
			     (env-extend (map (lambda (formal)
						(make-local-mapping 'variable formal #f))
					      l-params)
					 *usage-env*)))
			   (let* ((l-target-params (map expand l-params))
				  (l-target-arg-types (map expand arg-type))
				  (x-target-result-type (expand result-type))
				  ;; Maybe we could use id-name instead of expand here.
				  (x-target-attrs
				   (if (list? attrs)
				       (map expand attrs)
				       (expand attrs))))
			     (list ':param-proc l-target-params l-target-arg-types
				   x-target-result-type x-target-attrs)))))))

    ;; The identifier is bound here if it has been declared.
    (define (expand-general-define exp s-kw)
      (match exp
	     ((- var-name type value)
	      (identifier? var-name)
	      (begin
		(if (id-free? var-name)
		    (env-extend! (list (make-global-mapping 'variable
							    var-name #f))
				 *usage-env*))
		(list s-kw (id-name var-name) (expand type) (expand value))))
	     ((- var-name value)
	      (identifier? var-name)
	      (begin
		(if (id-free? var-name)
		    (env-extend! (list (make-global-mapping 'variable
							    var-name #f))
				 *usage-env*))
		(list s-kw (id-name var-name) (expand value))))))

    (define (expand-define exp)
      (expand-general-define exp skw-define))

    (define (expand-define-mutable exp)
      (expand-general-define exp skw-define-variable))

    (define (expand-define-volatile exp)
      (expand-general-define exp skw-define-volatile))

    (define (expand-define-param-proc-alt exp)
      (match exp
	     ((- name (param1 param2 ___) body)
	      (and (identifier? name)
		   (and-map? identifier? (cons param1 param2)))
	      (let ((l-params (cons param1 param2)))
		(if (id-free? name)
		    (env-extend!
		     (list (make-global-mapping 'variable name #f))
		     *usage-env*))
		(fluid-let ((*usage-env*
			     (env-extend (map (lambda (formal)
						(make-local-mapping 'variable formal #f))
					      l-params)
					 *usage-env*)))
			   (let ((x-target-body (expand body))
				 (l-target-params (map expand l-params))
				 (s-proc-name (id-name name)))
			     (list skw-def-param-proc-alt
				   s-proc-name
				   l-target-params
				   x-target-body)))))))

    (define (expand-define-gen-proc exp)
      (match exp
	     ((- var-name)
	      (identifier? var-name)
	      (begin
		(if (id-free? var-name)
		    (env-extend! (list (make-global-mapping 'variable
							    var-name #f))
				 *usage-env*))
		(list skw-define-gen-proc (id-name var-name))))))

    (define (expand-general-declare exp s-kw)
      (d2wl 'expand "expand-general-declare\n")
      (match exp
	     ((- var-name type)
	      (identifier? var-name)
	      (begin
		(d2wl 'expand "expand-general-declare/1\n")
		(set! dvar1 exp)
		(set! dvar2 var-name)
		;;		(raise 'stop-exp)
		(if (id-free? var-name)
		    (env-extend! (list (make-global-mapping 'variable
							    var-name #f))
				 *usage-env*))
		(list s-kw (id-name var-name) (expand type))))))

    (define (expand-declare exp)
      (expand-general-declare exp skw-declare))

    (define (expand-declare-mutable exp)
      (expand-general-declare exp skw-declare-mutable))

    (define (expand-declare-volatile exp)
      (expand-general-declare exp skw-declare-volatile))

    (define (expand-declare-method exp)
      (match exp
	     ((- var-name type)
	      (identifier? var-name)
	      (list 'declare-method (id-name var-name) (expand type)))))

    (define (expand-declare-static-method exp)
      (match exp
	     ((- var-name type)
	      (identifier? var-name)
	      (list 'declare-static-method (id-name var-name) (expand type)))))

    (define (expand-field skw fld)
      (if (list? fld)
	  (let ((i-len (length fld)))
	    (if (or (= i-len 4) (= i-len 5))
		(let* ((sx-name (id-name (list-ref fld 0)))
		       (sx-type (expand (list-ref fld 1)))
		       (sx-read-access (id-name (list-ref fld 2)))
		       (sx-write-access (id-name (list-ref fld 3)))
		       (has-init? (= i-len 5))
		       (sx-init (if has-init? (expand (list-ref fld 4)) '())))
		  (if has-init?
		      (list sx-name sx-type sx-read-access sx-write-access
			    sx-init)
		      (list sx-name sx-type sx-read-access sx-write-access)))
		(syntax-violation skw "Invalid field specification" fld)))
	  (syntax-violation skw "Invalid field specification" fld)))

    (define (expand-define-class exp)
      (match exp
	     ((- name superclass inh? imm? ebv? ctr-access zero-value
		 (field-spec ___))
	      (identifier? name)
	      (if (id-free? name)
		  (env-extend! (list (make-global-mapping 'variable
							  name #f))
			       *usage-env*))
	      (let ((name2 (id-name name))
		    (superclass2 (expand superclass))
		    (inh2? (expand inh?))
		    (imm2? (expand imm?))
		    (ebv2? (expand ebv?))
		    (ctr-access2 (expand ctr-access))
		    (zero-value2 (expand zero-value))
		    (l-field-specs
		     (map (lambda (fld) (expand-field skw-define-class fld))
			  field-spec)))
		(list skw-define-class
		      name2
		      superclass2
		      inh2? imm2? ebv2?
		      ctr-access2
		      zero-value2
		      l-field-specs)))))

    (define (expand-define-param-class exp)
      (match exp
	     ((- name (param1 param2 ___)
		 superclass inh? imm? ebv? ctr-access zero-value
		 (field-spec ___))
	      (and (identifier? name)
		   (and-map? identifier? (cons param1 param2)))
	      (if (id-free? name)
		  (env-extend! (list (make-global-mapping 'variable
							  name #f))
			       *usage-env*))
	      (let ((l-params (cons param1 param2)))
		(fluid-let ((*usage-env*
			     (env-extend
			      (map (lambda (formal)
				     (make-local-mapping 'variable formal #f))
				   l-params)
			      *usage-env*)))
			   (let ((name2 (id-name name))
				 (l-params2 (map expand l-params))
				 (superclass2 (expand superclass))
				 (inh2? (expand inh?))
				 (imm2? (expand imm?))
				 (ebv2? (expand ebv?))
				 (ctr-access2 (expand ctr-access))
				 (zero-value2 (expand zero-value))
				 (l-field-specs
				  (map (lambda (fld)
					 (expand-field skw-def-param-class fld))
				       field-spec)))
			     (list skw-def-param-class
				   name2
				   l-params2
				   superclass2
				   inh2? imm2? ebv2?
				   ctr-access2
				   zero-value2
				   l-field-specs)))))))

    (define (expand-def-param-ltype exp)
      (match exp
	     ((- name (param1 param2 ___) type)
	      (and (identifier? name)
		   (and-map? identifier? (cons param1 param2)))
	      (if (id-free? name)
		  (env-extend! (list (make-global-mapping 'variable
							  name #f))
			       *usage-env*))
	      (let ((l-params (cons param1 param2)))
		(fluid-let ((*usage-env*
			     (env-extend
			      (map (lambda (formal)
				     (make-local-mapping 'variable formal #f))
				   l-params)
			      *usage-env*)))
			   (let ((name2 (id-name name))
				 (l-params2 (map expand l-params))
				 (type2 (expand type)))
			     (list skw-def-param-logical-type
				   name2 l-params2 type2)))))))

    ;; The variable name has to be passed to the target environment
    ;; without processing in the primitive definitions.
    (define (expand-gen-prim-proc exp s-kw)
      (match exp
	     ((- name (arg-type ___) result-type attrs)
	      (identifier? name)
	      (let ((s-name2 (id-name name))
		    (l-arg-types (expand arg-type))
		    (x-result-type (expand result-type))
		    (x-target-attrs
		     (if (list? attrs)
			 (map expand attrs)
			 (expand attrs))))
		(list s-kw s-name2 l-arg-types x-result-type
		      x-target-attrs)))))

    (define (expand-checked-prim-proc exp)
      (expand-gen-prim-proc exp skw-primitive-procedure))

    (define (expand-unchecked-prim-proc exp)
      (expand-gen-prim-proc exp skw-unchecked-primitive-procedure))

    (define (expand-gen-param-prim-proc exp s-kw)
      (match exp
	     ((- name (param1 param2 ___) (arg-type ___) result-type attrs)
	      (and (identifier? name)
		   (and-map? identifier? (cons param1 param2)))
	      (let ((l-params (cons param1 param2)))
		(fluid-let ((*usage-env*
			     (env-extend
			      (map (lambda (formal)
				     (make-local-mapping 'variable formal #f))
				   l-params)
			      *usage-env*)))
			   (let ((s-name2 (id-name name))
				 (l-params2 (map expand l-params))
				 (l-arg-types (expand arg-type))
				 (x-result-type (expand result-type))
				 (x-target-attrs
				  (if (list? attrs)
				      (map expand attrs)
				      (expand attrs))))
			     (list s-kw s-name2 l-params2 l-arg-types
				   x-result-type
				   x-target-attrs)))))))

    (define (expand-checked-param-prim-proc exp)
      (expand-gen-param-prim-proc exp skw-param-prim-proc))

    (define (expand-unchecked-param-prim-proc exp)
      (expand-gen-param-prim-proc exp skw-unchecked-param-prim-proc))

    (define (id-or-null? id)
      (or (null? id) (identifier? id)))

    (define (id-name1 id)
      (if (not-null? id) (id-name id) '()))

    (define (expand-define-prim-class exp)
      (match exp
	     ((- name imm? ebv? checked? zero-var
		 pred-member pred-equal pred-equal-objects
		 pred-equal-contents)
	      (and (identifier? name)
		   (identifier? pred-member)
		   (id-or-null? pred-equal)
		   (id-or-null? pred-equal-objects)
		   (id-or-null? pred-equal-contents))
	      (if (id-free? name)
		  (env-extend! (list (make-global-mapping 'variable
							  name #f))
			       *usage-env*))
	      (let ((s-name2 (id-name name))
		    (imm2? (expand imm?))
		    (ebv2? (expand ebv?))
		    (checked2? (expand checked?))
		    (zero-var2 (expand zero-var))
		    (pred-member2 (id-name1 pred-member))
		    (pred-equal2 (id-name1 pred-equal))
		    (pred-equal-objects2 (id-name1 pred-equal-objects))
		    (pred-equal-contents2 (id-name1 pred-equal-contents)))
		(list skw-define-prim-class
		      s-name2 imm2? ebv2? checked2? zero-var2
		      pred-member2 pred-equal2 pred-equal-objects2
		      pred-equal-contents2)))))

    (define (expand-define-goops-class exp)
      (match exp
	     ((- name target-name superclass
		 inh? imm? ebv? checked? zero-var
		 pred-equal
		 pred-equal-contents)
	      (and (identifier? name)
		   (identifier? target-name)
		   (id-or-null? pred-equal)
		   (id-or-null? pred-equal-contents))
	      (if (id-free? name)
		  (env-extend! (list (make-global-mapping 'variable
							  name #f))
			       *usage-env*))
	      (let ((s-name2 (id-name name))
		    ;; The target name must not be processed.
		    (target-name2 (id-name target-name))
		    (superclass2 (expand superclass))
		    (inh2? (expand inh?))
		    (imm2? (expand imm?))
		    (ebv2? (expand ebv?))
		    (checked2? (expand checked?))
		    (zero-var2 (expand zero-var))
		    (pred-equal2 (id-name1 pred-equal))
		    (pred-equal-contents2 (id-name1 pred-equal-contents)))
		(list skw-define-goops-class
		      s-name2 target-name2 superclass2
		      inh2? imm2? ebv2? checked2? zero-var2
		      pred-equal2 pred-equal-contents2)))))

    (define (match-type-valid-clause? l-clause)
      (and
       (list? l-clause)
       (>= (length l-clause) 2)
       (let ((l-head (car l-clause)))
	 (and (list? l-head)
	      (or (= (length l-head) 2) (= (length l-head) 1))))))
    
    (define (check-match-type-clauses skw l-clauses)
      (for-each (lambda (l-clause)
		  (if (not (match-type-valid-clause? l-clause))
		      (syntax-violation skw
					"Invalid clause"
					l-clause)))
		l-clauses))

    (define (expand-list l)
      (map expand l))

    (define (expand-match-type-clause skw l-clause)
      (let* ((l-head (car l-clause))
	     (id-var-name (if (= (length l-head) 2) (car l-head) '())))
	(cond
	 ((identifier? id-var-name)
	  (fluid-let
	   ((*usage-env*
	     (env-extend
	      (list (make-local-mapping 'variable id-var-name #f))
	      *usage-env*)))
	   (cons (expand-list l-head) (expand-list (cdr l-clause)))))
	 ((null? id-var-name)
	  (cons (expand-list l-head) (expand-list (cdr l-clause))))
	 (else
	  (syntax-violation skw "Syntax error" l-clause)))))

    (define (do-expand-match-type skw x-value l-clauses
				  has-else? l-else-clause)
      (let ((x-exp-value (expand x-value))
	    (l-exp-clauses
	     (map* (lambda (l-clause)
		     (expand-match-type-clause skw l-clause))
		   l-clauses))
	    (l-exp-else (expand-list l-else-clause)))
	(if has-else?
	    `(,skw ,x-exp-value ,@l-exp-clauses (else ,@l-exp-else))
	    `(,skw ,x-exp-value ,@l-exp-clauses))))

    (define (expand-match-type-gen skw exp)
      (assert (or (eq? skw skw-match-type) (eq? skw skw-match-type-strong)))
      (if (and (list? exp) (>= (length exp) 2))
	  (let* ((has-else?
		  (let ((x-last (last exp)))
		    (and
		     (list? x-last)
		     ;; Maybe we should compare the length to 2.
		     (not-null? x-last)
		     (identifier? (car x-last))
		     (eq? (id-name (car x-last)) 'else))))
		 (x-value (cadr exp))
		 (l-clauses (if has-else?
				(cddr (drop-right exp 1))
				(cddr exp)))
		 (l-else-clause (if has-else? (cdr (last exp)) '())))
	    (check-match-type-clauses skw l-clauses)
	    (do-expand-match-type skw x-value l-clauses has-else?
				  l-else-clause))
	  (syntax-violation skw "Two few arguments" exp)))

    (define (expand-match-type exp)
      (expand-match-type-gen skw-match-type exp))
    
    (define (expand-match-type-strong exp)
      (expand-match-type-gen skw-match-type-strong exp))

    (define (expand-type-loop exp)
      (match exp
	     ((- iter-var val-to-iter expr)
	      (identifier? iter-var)
	      (let ((val-to-iter2
		     (if (list? val-to-iter)
			 (expand-list val-to-iter)
			 (expand val-to-iter))))
		(fluid-let
		 ((*usage-env*
		   (env-extend
		    (list (make-local-mapping 'variable iter-var #f))
		    *usage-env*)))
		 (let ((iter-var2 (expand iter-var))
		       (expr2 (expand expr)))
		   (list skw-type-loop iter-var2 val-to-iter2 expr2)))))))

    (define (expand-proc-attrs x-attrs)
      (if (list? x-attrs) (expand-list x-attrs) (expand x-attrs)))

    (define (expand-define-signature exp)
      (match exp
	     ((- name supersgn (proc args result-type attrs) ___)
	      (identifier? name)
	      (if (id-free? name)
		  (env-extend! (list (make-global-mapping 'variable
							  name #f))
			       *usage-env*))
	      (let ((name-e (id-name name))
		    (supersgn-e (expand supersgn))
		    (l-procs-e (expand-list proc))
		    (l-args-e (map* expand-list args))
		    (l-result-types-e (expand-list result-type))
		    (l-attrs-e (map expand-proc-attrs attrs)))
		`(,skw-define-signature ,name-e ,supersgn-e
					,@(map list l-procs-e l-args-e l-result-types-e l-attrs-e))))))
    
    (define (expand-define-param-signature exp)
      (match exp
	     ((- name (params ___) supersgn (proc args result-type attrs) ___)
	      (and (identifier? name) (and-map? identifier? params))
	      (if (id-free? name)
		  (env-extend! (list (make-global-mapping 'variable
							  name #f))
			       *usage-env*))
	      (fluid-let
	       ((*usage-env*
		 (env-extend
		  (map (lambda (param)
			 (make-local-mapping 'variable param #f))
		       params)
		  *usage-env*)))
	       (let ((name-e (id-name name))
		     (params-e (expand-list params))
		     (supersgn-e (expand supersgn))
		     (l-procs-e (expand-list proc))
		     (l-args-e (map* expand-list args))
		     (l-result-types-e (expand-list result-type))
		     (l-attrs-e (map expand-proc-attrs attrs)))
		 `(,skw-define-param-signature
		   ,name-e ,params-e ,supersgn-e
		   ,@(map list l-procs-e l-args-e l-result-types-e l-attrs-e)))))))

    (define (expand-param-proc-cond-appl exp)
      (match exp
	     ((- proc (arg-type ___) on-mismatch)
	      (let ((proc-e (expand proc))
		    (l-arg-types-e (expand-list arg-type))
		    (on-mismatch-e (expand on-mismatch)))
		`(,skw-param-proc-cond-appl ,proc-e ,l-arg-types-e
					    ,on-mismatch-e)))))

    (define (expand-generic-proc-dispatch0 s-kw proc l-arg-types l-attrs)
      (let ((proc-e (expand proc))
	    (l-arg-types-e (expand-list l-arg-types))
	    (l-attrs-e (expand-list l-attrs)))
	`(,s-kw ,proc-e ,l-arg-types-e ,l-attrs-e)))

    (define (expand-generic-proc-dispatch1 exp s-kw)
      (match exp
	     ((- proc (arg-type ___))
	      (expand-generic-proc-dispatch0 s-kw proc arg-type '()))
	     ((- proc (arg-type ___) (attr ___))
	      (expand-generic-proc-dispatch0 s-kw proc arg-type attr))))

    (define (expand-generic-proc-dispatch exp)
      (expand-generic-proc-dispatch1 exp skw-generic-proc-dispatch))

    (define (expand-generic-proc-dispatch-without-result exp)
      (expand-generic-proc-dispatch1
       exp skw-generic-proc-dispatch-without-result))

    (define (expand-module-ref exp)
      (match exp
	     ((- (mod1 mod2 ___) var)
	      (and (and-map? identifier? (cons mod1 mod2))
		   (identifier? var))
	      (let ((l-mod-e (expand-list (cons mod1 mod2)))
		    (x-var-e (expand var)))
		`(,skw-module-ref ,l-mod-e ,x-var-e)))
	     ((- mod var)
	      (and (identifier? mod) (identifier? var))
	      (let ((x-mod-e (expand mod))
		    (x-var-e (expand var)))
		`(,skw-module-ref ,x-mod-e ,x-var-e)))))

    (define (expand-prevent-stripping exp)
      (match exp
	     ((- var)
	      (identifier? var)
	      `(,skw-prevent-stripping ,(id-name var)))))

    (define (expand-reexport exp)
      (match exp
	     ((- var)
	      (identifier? var)
	      `(,skw-reexport ,(id-name var)))))

    (define (expand-assert exp)
      (match exp
	     ((- condition)
	      (list skw-do-assert
		    (expand condition)
		    (syntax->datum condition)))))

    (define (expand-strong-assert exp)
      (match exp
	     ((- condition)
	      (list skw-do-strong-assert
		    (expand condition)
		    (syntax->datum condition)))))

    ;;=========================================================================
    ;;
    ;; 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)
	(d2wl 'scan "expand-deferred ENTER")
	(let ((result
	       (map (lambda (form)
;;		      (d2wl 'scan "form:")
;;		      (d2wl 'scan form)
		      (cons (car form)
			    (let ((deferred? (cadr form))
				  (exp       (caddr form)))
;;			      (d2wl 'scan "(wrap-exp exp):")
;;			      (d2wl 'scan (wrap-exp exp))
			      (if deferred?
				  (fluid-let ((*usage-env* (wrap-env exp)))
					     (expand (wrap-exp exp)))
				  exp))))
		    forms)))
	  (d2wl 'scan "expand-deferred EXIT")
	  result))

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

	(d2wl 'scan "scan-sequence/0")
;;	(d2wl 'scan body-forms)
;;	(d2wl 'scan "scan-sequence/0-1")
;;	(d2wl 'scan common-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!)
	    ;; Changed by TH:
            ;; (k (reverse (expand-deferred forms))
            ;;    (reverse syntax-defs)
            ;;    bound-variables))
	    ;; (k (expand-deferred (reverse forms))
	    ;;    (reverse syntax-defs)
	    ;;    bound-variables))
	      (k (expand-deferred (reverse 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))))
			     (d2wl 'scan type)
			     (check-expression-sequence body-type type form)
			     (check-toplevel            body-type type form)
			     (case type
			       ;; TH: Removed import, program, and library.
			       (($define)
			       	(call-with-values
			       	    (lambda () (parse-definition form #f))
			       	  (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-from-id id))
					    #t
					    (make-wrap *usage-env* rhs))
				      forms)
				     syntax-defs
				     (cons (binding-name (binding-from-id id))
					   bound-variables)))))
			       ((define-syntax)
				(call-with-values
				    (lambda () (parse-definition form #t))
				  (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))))
					(binding-macro-set! (cdr mapping) (make-user-macro rhs))
					(let ((alo-current-exports
					       (hfield-ref gl-expander 'alo-current-exports)))
					  (hfield-set! alo-current-exports 'contents
						       (cons mapping (hfield-ref alo-current-exports 'contents))))
					(loop
					 (cdr ws)
					 forms
					 (cons
					  (cons
					   (binding-name (binding-from-id id))
					   rhs)
					  syntax-defs)
					 bound-variables))))))
			       ((begin)
				(or (list? form)
				    (invalid-form form))
				(let ((result
				       (loop (append (map (lambda (exp)
							    (make-wrap *usage-env* exp))
							  (cdr form))
						     (cdr ws))
					     forms
					     syntax-defs
					     bound-variables)))
				  result))
			       ((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))))
				      (for-each (lambda (mapping macro)
						  (binding-macro-set! (cdr mapping) (make-user-macro macro)))
						usage-diff
						rhs-expanded)
				      (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 syntax-def?)
      (match exp
	     ((- (? identifier? id))
	      (values id (rename 'variable 'ex:unspecified)))
	     ((- (? identifier? id) e)
	      (values id e))
	     ((- ((? identifier? id) . (? formals? formals)) body ___)
	      (and syntax-def?
		   (invalid-form exp))
	      (values id `(,(rename 'macro 'lambda) ,formals ,@body)))))

    (define (parse-local-syntax t)
      (match t
	     ((- ((x e) ___) body ___)
	      (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 '...)))))
      (let ((result
	     (match exp
		    ((- e ((? literal? literals) ___) clauses ___)
		     (let ((input (generate-guid 'input)))
		       `($let ((,input ,(expand e)))
			      ,(process-clauses clauses input literals)))))))
	result))

    (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-object ($null? ,input) ,sk ,fk))
		   ((? literal? id)    `(if-object (if-object ($identifier? ,input)
							  ($free-identifier=? ,input ,(syntax-reflect id))
							  #f)
						 ,sk
						 ,fk))
		   ((? identifier? id) `($let ((,(binding-name (binding-from-id id)) ,input)) ,sk))
		   ((p (syntax ...))
		    (let ((mapped-pvars (map (lambda (pvar) (binding-name (binding-from-id pvar)))
					     (map car (pattern-vars p 0)))))
		      (if (and (identifier? p)                                   ; +++
			       (= (length mapped-pvars) 1))                      ; +++
			  `(if-object ($list? ,input)                                    ; +++
				    ($let ((,(car mapped-pvars) ,input))               ; +++
					  ,sk)                                            ; +++
				    ,fk)                                              ; +++
			  (let ((columns (generate-guid 'cols))
				(rest    (generate-guid 'rest)))
			    `($map-while ($lambda (,input)
						  ,(process-match input
								  p
								  `($list ,@mapped-pvars)
								  #f))
					 ,input
					 ($lambda (,columns ,rest)
						  (if-object ($null? ,rest)
							   ($apply ($lambda ,mapped-pvars ,sk)
								   (if-object ($null? ,columns)
									    ',(map (lambda (ignore) '()) mapped-pvars)
									    ($apply $map $list ,columns)))
							   ,fk)))))))
		   ((p (syntax ...) . tail)
		    (let ((tail-length (dotted-length tail)))
		      `(if ($>= ($dotted-length ,input) ,tail-length)
			   ,(process-match `($dotted-butlast ,input ,tail-length)
					   `(,p ,(cadr pattern))
					   (process-match `($dotted-last ,input ,tail-length)
							  tail
							  sk
							  fk)
					   fk)
			   ,fk)))
		   ((p1 . p2)
		    `(if-object ($pair? ,input)
			      ,(process-match `($car ,input)
					      p1
					      (process-match `($cdr ,input) p2 sk fk)
					      fk)
			      ,fk))
		   ;; (#(ps ___)
		   ;;  `(if-object ($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-object ($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 ___)               (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-object ,(expand fender)
								,(expand template)
								,fk))
						     (- (syntax-violation 'syntax-case "Invalid clause" clause)))
					      fk)))))))

      ;; process-clauses

      (match clauses
	     (()
	      `($invalid-form ,input))
	     ((clause clauses ___)
	      (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-from-id 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* ((head (segment-head template)) 
		     (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 head (+ dim 1) '() 0))))
		(if (null? vars)
		    (syntax-violation 'syntax "Too many ...'s" template)
		    (let* ((x (process-template head (+ dim 1) ellipses-quoted?))
			   (gen (if (equal? (list x) vars)   ; +++
				    x                        ; +++
				    (if (= (length vars) 1) 
					`($map ($lambda ,vars ,x)
					       ,@vars)
					`(if-object ($= ,@(map (lambda (var) 
							       `($length ,var))
							     vars))
						  ($map ($lambda ,vars ,x)
							,@vars)
						  ($syntax-violation 
						   'syntax 
						   "Pattern variables denoting lists of unequal length preceding ellipses"
						   ',(syntax->datum template) 
						   ($list ,@vars))))))
			   (gen (if (> (segment-depth template) 1)
				    `($apply $append ,gen)
				    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 ___)
	     ;;  `(list->vector ,(process-template ts dim ellipses-quoted?)))
	     (other
	      `(quote ,(expand other)))))
    
    (define (free-meta-variables template dim free deeper)
      (match template
	     ((? identifier? id)
	      (if (memp (lambda (x) (bound-identifier=? (car x) id)) free)
		  free
		  (let ((binding (binding-from-id id)))
		    (if (and binding
			     (eq? (binding-type binding) 'pattern-variable)
			     (let ((pdim (binding-dimension binding)))
			       (and (> pdim 0) 
				    (not (>= deeper pdim))
				    (<= (- pdim deeper) 
					dim))))
			(cons (cons id binding) free)
			free))))
	     ((t (syntax ...) . rest)
	      (free-meta-variables t 
				   dim 
				   (free-meta-variables (segment-tail template) dim free deeper)
				   (+ deeper (segment-depth template))))  
	     ((t1 . t2)
	      (free-meta-variables t1 dim (free-meta-variables t2 dim free deeper) deeper))
	     ;; (#(ts ___) 
	     ;;  (free-meta-variables ts dim free deeper))
	     (- free)))
    
    ;; Count the number of `...'s in PATTERN.

    (define (segment-depth pattern)
      (match pattern
	     ((p (syntax ...) . rest)
	      (+ 1 (segment-depth (cdr pattern))))
	     (- 0)))
    
    ;; All but the last ellipses
    
    (define (segment-head pattern)
      (let ((head
             (let recur ((pattern pattern))
               (match pattern
		      ((h (syntax ...) (syntax ...) . rest)
		       (cons h (recur (cdr pattern))))
		      ((h (syntax ...) . rest)
		       (list h))))))
        (match head 
	       ((h (syntax ...) . rest)
		head)
	       (- (car head)))))   

    ;; 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-from-id 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 (env-import! keyword imports env)
      (env-extend! (map (lambda (import)
                          (cons (cons (car import)
                                      (id-colors keyword))
                                (cdr import)))
                        imports)
                   env))

    (define (alist-env-import imports)
      (map (lambda (import)
	     (cons (cons (car import) '()) (cdr import)))
	   imports))

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

    (define (get-line-and-column0 sexpr)
      (let* ((al-props (source-properties sexpr))
	     (pr-line (assq 'line al-props))
	     (pr-column (assq 'column al-props)))
	;; Guile seems to give the line number one too small.
	(if (and (not (eq? pr-line #f)) (not (eq? pr-column #f)))
	    (string-append
	     "(line " (number->string (+ (cdr pr-line) 1))
	     ", column " (number->string (cdr pr-column))
	     ")")
	    (if (not (eq? pr-line #f))
		(string-append
		 " (line " (number->string (+ (cdr pr-line) 1)) ")")
		""))))

    (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))
	(let* ((sexpr (get-orig-expr form))
	       (str-loc (get-line-and-column0 sexpr)))
	  (pretty-print sexpr)
	  (newline)
	  (if (not (string-null? str-loc))
	      (begin
		(display str-loc)
		(newline)
		(newline)))
	  ;; If the line numbering information is not available
	  ;; write the trace always.
	  (if (or gl-trace? (string-null? str-loc))
	      (begin
		(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")))
	(raise 'syntax-violation)))

    (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)
		       '()))

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

    (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)
	     (raise 'illegal-vector-constant))
;;	     (apply vector (sexp-map f (vector->list s))))
	    (else (f s))))

    (define (sexp-map1 f s)
      (cond ((null? s) '())
	    ((pair? s)
	     (let ((result
		    (cons (sexp-map1 f (car s))
			  (sexp-map1 f (cdr s))))
		   (ht-syntax-source
		    (hfield-ref gl-expander 'ht-syntax-source)))
	       (if (not-null? ht-syntax-source)
		   (hashq-set! ht-syntax-source result s))
	       result))
	    ((vector? s)
	     (raise 'illegal-vector-constant))
;;	     (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:
    ;;
    ;;============================================================================

    ;; Puts parameters to a consistent state for the toplevel
    ;; Old state is restored afterwards so that things will be
    ;; reentrant. 

    (define with-toplevel-parameters
      (lambda (thunk)
	(fluid-let ((*trace*            '())
		    (*current-library*  '())
		    (*phase*            0)
		    (*used*             (list '()))
		    (*color*            (generate-color))
		    (*usage-env*        *toplevel-env*)
		    (*syntax-reflected* #f))
		   (thunk))))

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

    (define (expand-toplevel-sequence1 forms)
      (d2wl 'expand "expand-toplevel-sequence1")
      (d2wl 'expand forms)
;;      (d2wl 'expand "*usage-env*:")
;;      (d2wl 'expand *usage-env*)
      (scan-sequence 'toplevel
		     make-toplevel-mapping
		     (source->syntax1 forms)
		     ;; Assume that forms contains only a single element.
		     (let ((src (car forms)))
		       (lambda (new-forms syntax-definitions bound-variables)
			 (for-each
			  (lambda (result)
			    (add-source-exprs (cdr result) src #f))
			  new-forms)
			 (emit-body new-forms 'define)))))

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

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

    ;;==========================================================================
    ;;
    ;; Interpreting the core language:
    ;;
    ;;==========================================================================

    (define l-core-forms
      '($lambda $let if-object if begin set! quote))

    ;; (define dvar10 '())

    ;; (define (set-dvar10! x) (set! dvar10 x))

    (define (make-core-var x-value) (vector x-value))

    ;; The following procedure is not exact.
    (define (core-var? x)
      (and (vector? x) (= (vector-length x) 1)))

    (define (set-core-var! x-var x-value)
      (assert (core-var? x-var))
      (vector-set! x-var 0 x-value))

    (define (get-core-var-value x-var)
      (assert (core-var? x-var))
      (vector-ref x-var 0))

    (define ($map proc . l)
      (cond
       ((procedure? proc)
    	(apply map proc l))
       ((core-lambda-proc? proc)
    	(apply map (lambda args
    		     (interpret-core (cons proc args)))
    	       l))
       (else
    	(syntax-violation #f "$map: syntax error"
    			  proc))))

    (define ($apply0 proc l-args)
      (cond
       ((procedure? proc)
    	(apply proc l-args))
       ((core-lambda-proc? proc)
    	(interpret-core `(,proc ,@l-args)))
       (else
    	(syntax-violation #f "$apply0: syntax error"
    			  proc))))

    (define ($apply1 proc arg l-args)
      (cond
       ((procedure? proc)
    	(apply proc arg l-args))
       ((core-lambda-proc? proc)
    	(interpret-core `(,proc ,arg ,@l-args)))
       (else
    	(syntax-violation #f "$apply1: syntax error"
    			  proc))))

    (define (make-apply-arglist l-args)
      (cond
       ;; The following condition may be an error.
       ((null? l-args) '())
       ((null? (cdr l-args)) (car l-args))
       (else
    	(cons (car l-args) (make-apply-arglist (cdr l-args))))))

    (define ($apply proc . l-args)
      ($apply0 proc (make-apply-arglist l-args)))

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

    (define ($call proc . l-args)
      (cond
       ((procedure? proc) (apply proc l-args))
       ((core-lambda-proc? proc)
    	(interpret-core (cons proc l-args)))
       (else
    	(syntax-violation #f "$call: syntax error"
    			  proc))))

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

    (define l-core-procs
      `(($cons . ,cons)
    	($car . ,car)
    	($cdr . ,cdr)
    	($pair? . ,pair?)
    	($null? . ,null?)
    	($list? . ,list?)
    	($list . ,list)
    	($for-all . ,$for-all)
    	($map . ,$map)
    	($apply . ,$apply)
    	($apply0 . ,$apply0)
    	($apply1 . ,$apply1)
	($equal? . ,equal?)
    	($= . ,=)
	($>= . ,>=)
	($> . ,>)
    	($length . ,length)
    	($append . ,append)
	($+ . ,+)
	($- . ,-)
	;; ($vector . ,vector)
	;; ($vector? . ,vector?)
	;; ($vector->list . ,vector->list)
	($dotted-length . ,dotted-length)
	($dotted-last . ,dotted-last)
	($dotted-butlast . ,dotted-butlast)
    	($raise . ,raise)
    	($identifier? . ,identifier?)
    	($free-identifier=? . ,free-identifier=?)
    	;;    (set-dvar10! . ,set-dvar10!)
    	($syntax-rename . ,syntax-rename)
    	($invalid-form . ,invalid-form)
    	($map-while . ,$map-while)
    	($syntax-violation . ,syntax-violation)
    	($generate-temporaries . ,generate-temporaries)
	($make-variable-transformer . ,make-variable-transformer)
    	($undefined . ,ex:undefined)))

    (define al-toplevel-env
      (map (lambda (p-binding)
    	     (let ((s-name (car p-binding)))
    	       (cons s-name (make-core-var (cdr p-binding)))))
	   l-core-procs))

    (define (interpret-sequence x-expr al-env)
      (d2wli 'core-lang "interpret-sequence")
      (d2wli 'core-lang x-expr)
      (let ((result '()))
    	(do ((l-cur x-expr (cdr l-cur))) ((null? l-cur) result)
    	  (set! result (interpret-core0 (car l-cur) al-env)))))

    (define (interpret-lambda x-expr al-env)
      (strong-assert (and (list? x-expr) (>= (length x-expr) 3)
			  (eq? (car x-expr) '$lambda)))
      (let* ((l-arg-names (cadr x-expr))
	     (l-new-variables (map make-core-var l-arg-names))
	     (al-free-vars-new al-env)
	     (l-body0 (cddr x-expr))
	     (proc (lambda l-args
		     (let ((al-env2 (append
				     (map cons
					  l-arg-names (map make-core-var l-args))
				     al-free-vars-new)))
		       (interpret-sequence l-body0 al-env2)))))
	proc))

    (define (interpret-let x-expr al-env)
      ;; Don't allow a $let without a body.
      (strong-assert (and (list? x-expr) (>= (length x-expr) 3)
    			  (eq? (car x-expr) '$let)))
      (let ((l-bindings (cadr x-expr))
    	    (l-body (cddr x-expr)))
    	(strong-assert (and (list? l-bindings)
    			    (and-map? (lambda (l-binding)
    					(and (list? l-binding)
    					     (= (length l-binding) 2)))
    				      l-bindings)))
    	(let ((l-var-names (map car l-bindings)))
    	  (strong-assert (and-map? symbol? l-var-names))
    	  (let ((l-values (map cadr l-bindings)))
    	    (interpret-core0
    	     `(($lambda ,l-var-names ,@l-body) ,@l-values)
    	     al-env)))))

    (define (interpret-if-object x-expr al-env)
      (d2wli 'core-lang "interpret-if-object")
      (d2wli 'core-lang x-expr)
      (let ((i-len (length x-expr)))
    	(assert (or (= i-len 4) (= i-len 3)))
    	(let ((x-cond (interpret-core0 (cadr x-expr) al-env)))
    	  (if x-cond
    	      (interpret-core0 (caddr x-expr) al-env)
    	      (if (= i-len 4)
    		  (interpret-core0 (cadddr x-expr) al-env)
    		  (if #f #f))))))

    (define (interpret-if x-expr al-env)
      (d2wli 'core-lang "interpret-if")
      (d2wli 'core-lang x-expr)
      (let ((i-len (length x-expr)))
    	(assert (or (= i-len 4) (= i-len 3)))
    	(let ((x-cond (interpret-core0 (cadr x-expr) al-env)))
    	  (strong-assert (boolean? x-cond))
    	  (if x-cond
    	      (interpret-core0 (caddr x-expr) al-env)
    	      (if (= i-len 4)
    		  (interpret-core0 (cadddr x-expr) al-env)
    		  (if #f #f))))))

    (define (interpret-set x-expr al-env)
      (assert (= (length x-expr) 3))
      (let* ((s-var-name (cadr x-expr))
    	     (p-binding (assq s-var-name al-env)))
    	(if p-binding
    	    (let ((x-var (cdr p-binding))
    		  (x-value
    		   (interpret-core0 (caddr x-expr) al-env)))
    	      (set-core-var! x-var x-value))
    	    (syntax-violation 'set!
    			      "Unbound identifier"
    			      x-expr))))

    (define (interpret-var-ref x-expr al-env)
      (assert (symbol? x-expr))
      (d2wli 'core-lang "interpret-var-ref")
      (d2wli 'core-lang x-expr)
      (let ((p-binding (assq x-expr al-env)))
    	(if p-binding
    	    (let ((x-var (cdr p-binding)))
	      (if (core-var? x-var)
		  (get-core-var-value x-var)
		  x-var))
    	    (syntax-violation #f "Unbound identifier" x-expr))))

    (define (interpret-core0 x-expr al-env)
      (let ((old-indent gl-indent))
	(set! gl-indent (+ gl-indent 1))
	(let* ((x-result1
		(cond
		 ((or (null? x-expr)
		      (boolean? x-expr)
		      (number? x-expr)
		      (string? x-expr)
		      (char? x-expr)
		      (procedure? x-expr)
		      (ex:identifier? x-expr))
		  x-expr)
		 ((symbol? x-expr)
		  (interpret-var-ref x-expr al-env))
		 ((list? x-expr)
		  (let ((x-first (car x-expr)))
		    (cond
		     ((and
		       (symbol? x-first)
		       (or (memq x-first l-core-forms)
			   (eq? x-first '$$lambda)
			   (eq? x-first 'd)))
		      (case x-first
			(($lambda) (interpret-lambda x-expr al-env))
			(($let) (interpret-let x-expr al-env))
			((if-object) (interpret-if-object x-expr al-env))
			((if) (interpret-if x-expr al-env))
			((begin) (interpret-sequence (cdr x-expr) al-env))
			((set!) (interpret-set x-expr al-env))
			((quote) (cadr x-expr))
			((d) (d (cadr x-expr)))
			(else
			 ;; We should not arrive here.
			 (syntax-violation #f "Unexpected symbol" x-first))))
		     ((procedure? x-first)
		      (let ((l-arguments (map (lambda (x-subexpr)
						(interpret-core0 x-subexpr
								 al-env))
					      (cdr x-expr))))
			(apply x-first l-arguments)))
		     ((or (identifier? x-first)
			  (null? x-first))
		      (let* ((l-arguments (map (lambda (x-subexpr)
						(interpret-core0 x-subexpr
								 al-env))
					       (cdr x-expr)))
			     (ht-syntax-source
			      (hfield-ref gl-expander 'ht-syntax-source))
			     (x-old-orig
			      (if (not-null? ht-syntax-source)
				  (hashq-ref ht-syntax-source x-expr)
				  #f))
			     (x-result2
			      (cons x-first l-arguments)))
			(if x-old-orig
			    (hashq-set! ht-syntax-source x-result2
					x-old-orig))
			x-result2))
		     (else
		      (let ((x-new-first (interpret-core0 x-first
							  al-env)))
			(if (equal? x-new-first x-first)
			    x-expr
			    (let ((x-result
				   (interpret-core0 (cons x-new-first
							  (cdr x-expr))
						    al-env)))
			      x-result)))))))
		 ((pair? x-expr)
		  (cons
		   (interpret-core0 (car x-expr) al-env)
		   (interpret-core0 (cdr x-expr) al-env)))
		 ((vector? x-expr)
		  ;; (vector-map*
		  ;;  (lambda (x-subexpr) (interpret-core0 x-subexpr al-env))
		  ;;  x-expr))
		  (raise 'illegal-vector-constant))
		 (else
		  (syntax-violation #f "Core expression syntax error"
				    x-expr)))))
	  (set! gl-indent old-indent)
	  x-result1)))

    (define (interpret-core x-expr)
      (d2wl 'expand interpret-core)
      (interpret-core0 x-expr l-core-procs))

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

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

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

    (define (source->syntax1 datum)
      (datum->syntax1 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))

    (define (get-toplevel-env) *toplevel-env*)
    (define (get-usage-env) *usage-env*)

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

    ;;     (ex:register-library!
    ;;      (let ((primitive-macro-mapping
    ;;             `((lambda        . ,expand-lambda)
    ;; 	      ($lambda       . ,expand-lambda)
    ;; ;;	      ($let          . ,expand-let)
    ;;               (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)))

    (define (get-macro-table) *macro-table*)

    (define (set-usage-env x-new-env)
      (set! *usage-env* x-new-env))

    (define (get-al-toplevel-env) al-toplevel-env)

    (define (test-prog exp)
      (match exp
	     ((- (name val) ___ else-part)
	      (display name)
	      (newline)
	      (display val)
	      (newline))))

    (define (usage-env-extend! l-mappings)
      (env-extend! l-mappings *usage-env*))

    ;; Initial environments:

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

    (hash-set! (hfield-ref gl-expander 'ht-modules) '() *usage-env*)

    (set! primitive-macro-language
	  (let* ((primitive-macro-mapping
		  `(($lambda              . ,expand-$lambda)
		    (,skw-procedure       . ,expand-lambda)
		    (,skw-procedure-aut   . ,expand-lambda-aut)
		    (,skw-param-proc      . ,expand-param-lambda)
		    (,skw-param-proc-aut  . ,expand-param-lambda-aut)
		    (,skw-define          . ,expand-define)
		    (,skw-define-variable . ,expand-define-mutable)
		    (,skw-define-volatile . ,expand-define-volatile)
		    (,skw-declare         . ,expand-declare)
		    (,skw-declare-mutable . ,expand-declare-mutable)
		    (,skw-declare-volatile . ,expand-declare-volatile)
		    (,skw-declare-method  . ,expand-declare-method)
		    (,skw-declare-static-method  . ,expand-declare-static-method)
		    (,skw-if-object       . ,expand-if-object)
		    (,skw-if              . ,expand-if)
		    (,skw-set             . ,expand-set!)
		    (,skw-begin           . ,expand-begin)
		    (,skw-syntax          . ,expand-syntax)
		    (,skw-quote           . ,expand-quote)
		    (,skw-let-syntax      . ,expand-local-syntax)
		    (,skw-letrec-syntax   . ,expand-local-syntax)
		    (,skw-syntax-case     . ,expand-syntax-case)
		    (,skw-$define         . ,invalid-form)
		    (,skw-define-syntax   . ,invalid-form)
		    (_                    . ,invalid-form)
		    (...                  . ,invalid-form)
		    (,skw-let              . ,expand-let)
		    (,skw-letrec           . ,expand-letrec)
		    (,skw-letrec*          . ,expand-letrec*)
		    (,skw-let-variables    . ,expand-let-mutable)
		    (,skw-letrec-variables . ,expand-letrec-mutable)
		    (,skw-letrec*-variables . ,expand-letrec*-mutable)
		    (,skw-let-volatile     . ,expand-let-volatile)
		    (,skw-letrec-volatile  . ,expand-letrec-volatile)
		    (,skw-letrec*-volatile . ,expand-letrec*-volatile)
		    (,skw-until            . ,expand-until)
		    (:procedure            . ,expand-abstract-proc-class)
		    (:simple-proc          . ,expand-simple-proc-class)
		    (:param-proc           . ,expand-param-proc-class)
		    (,skw-def-param-proc-alt . ,expand-define-param-proc-alt)
		    (,skw-define-class     . ,expand-define-class)
		    (,skw-def-param-class  . ,expand-define-param-class)
		    (,skw-def-param-logical-type . ,expand-def-param-ltype)
		    (,skw-primitive-procedure    . ,expand-checked-prim-proc)
		    (,skw-unchecked-primitive-procedure . ,expand-unchecked-prim-proc)
		    (,skw-param-prim-proc  . ,expand-checked-param-prim-proc)
		    (,skw-unchecked-param-prim-proc .
						    ,expand-unchecked-param-prim-proc)
		    (,skw-define-prim-class      . ,expand-define-prim-class)
		    (,skw-define-goops-class     . ,expand-define-goops-class)
		    (,skw-match-type             . ,expand-match-type)
		    (,skw-match-type-strong      . ,expand-match-type-strong)
		    (,skw-type-loop              . ,expand-type-loop)
		    (,skw-define-signature       . ,expand-define-signature)
		    (,skw-define-param-signature . ,expand-define-param-signature)
		    (,skw-define-gen-proc        . ,expand-define-gen-proc)
		    (,skw-generic-proc-dispatch  . ,expand-generic-proc-dispatch)
		    (,skw-generic-proc-dispatch-without-result
		     .
		     ,expand-generic-proc-dispatch-without-result)
		    (,skw-module-ref             . ,expand-module-ref)
		    (,skw-prevent-stripping      . ,expand-prevent-stripping)
		    (,skw-reexport               . ,expand-reexport)
		    (,skw-assert                 . ,expand-assert)
		    (,skw-strong-assert          . ,expand-strong-assert))))
	    (map (lambda (p)
		   (let ((s-name (car p)))
		     (let ((l-levels
			    (if (eq? s-name skw-set) '(-1 0 1) '(0 1))))
		       (cons s-name (make-binding0 'macro s-name l-levels #f '() #t #f
						   (make-expander (cdr p)))))))
		 primitive-macro-mapping)))

    ;; Forms expanded like procedure calls are also included in the
    ;; following definition.
    (set! core-language
	  (let* ((core-proc-names
		  `($for-all
		    $map
		    $list
		    $cons
		    $car
		    $cdr
		    $pair?
		    $null?
		    $list?
		    $list
		    $apply
		    $apply0
		    $apply1
		    $equal?
		    $=
		    $>=
		    $>
		    $length
		    $append
		    $map-while
		    $+
		    $-
		    ;; $vector
		    ;; $vector?
		    ;; $vector->list
		    $dotted-length
		    $dotted-last
		    $dotted-butlast
		    $raise
		    $syntax-rename
		    $invalid-form
		    make-variable-transformer
		    $make-variable-transformer
		    $identifier?
		    $generate-temporaries
		    bound-identifier=?
		    $free-identifier=?
		    generate-temporaries
		    datum->syntax
		    syntax->datum
		    syntax-violation
		    $syntax-violation
		    environment
		    environment-bindings
		    ;; no eval
		    undefined
		    $undefined
		    ,skw-rest
		    ,skw-splice
		    ,skw-type-join
		    ,skw-cast
		    ,skw-try-cast
		    field-ref
		    field-set!
		    ,skw-constructor
		    ,skw-add-method
		    ,skw-add-static-method
		    ,skw-declare-method
		    ,skw-declare-static-method
		    this
		    ,skw-param-proc-instance
		    ,skw-param-proc-dispatch
		    ,skw-param-proc-cond-appl
		    ,skw-type-list
		    ,skw-zero
		    ,skw-force-pure-expr
		    ,skw-static-type-of
		    ,skw-assert
		    ,skw-strong-assert)))
	    (map (lambda (s-name)
		   (cons s-name
			   (make-binding 'variable s-name '(0 1) #f '() #t)))
		 core-proc-names)))

    ;; 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))

    ;; (env-import! toplevel-template primitive-macro-language
    ;; 		   *toplevel-env*)
    ;; (for-each (lambda (p) (register-macro! (car p) (make-expander (cdr p))))
    ;; 		primitive-macro-mapping))
    (set! al-prim-macros (alist-env-import primitive-macro-language))

    ;;      (env-import! toplevel-template core-language *toplevel-env*))
    (set! al-prim-procs (alist-env-import core-language))

    (set! al-prim-bindings (append al-prim-macros al-prim-procs))

    (set-car! (car *usage-env*) al-prim-bindings)

    (set! al-prim-language (append primitive-macro-language core-language))

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

    (set! gl-id :identifier)

    (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:load                      r6rs-load)
    (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:run-r6rs-sequence         run-r6rs-sequence)
    ;;    (set! ex:run-r6rs-program          run-r6rs-program)

    (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=?)

    (set! ex:expand-toplevel-sequence  expand-toplevel-sequence)
    (set! ex:expand-toplevel-sequence1 expand-toplevel-sequence1)
    (set! ex:expand                    expand)
    ;;    (set! ex:normalize                 normalize)
    (set! ex:read-file                 read-file)
    (set! ex:binding-from-id           binding-from-id)
    (set! ex:make-local-mapping        make-local-mapping)
    (set! ex:make-global-mapping2      make-global-mapping2)
    (set! ex:generate-guid             generate-guid)
    (set! ex:interpret-core0           interpret-core0)
    (set! ex:interpret-core            interpret-core)
    (set! ex:get-macro-table           get-macro-table)
    (set! ex:toplevel-env              get-toplevel-env)
    (set! ex:usage-env                 get-usage-env)
    (set! ex:set-usage-env             set-usage-env)
    (set! ex:al-toplevel-env           get-al-toplevel-env)
    (set! ex:test-prog                 test-prog)
    (set! ex:source->syntax1           source->syntax1)
    (set! ex:usage-env-extend!         usage-env-extend!)
    ) ; let
  ) ; letrec-syntax
