[bpt/guile.git] / module / language / r5rs / psyntax.ss

;;; Portable implementation of syntax-case
;;; Extracted from Chez Scheme Version 6.3
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman

;;; Copyright (c) 1992-2000 Cadence Research Systems
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software
;;; is granted subject to the restriction that all copies made of this
;;; software must include this copyright notice in full.  This software
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER.

;;; Before attempting to port this code to a new implementation of
;;; Scheme, please read the notes below carefully.

;;; This file defines the syntax-case expander, sc-expand, and a set
;;; of associated syntactic forms and procedures.  Of these, the
;;; following are documented in The Scheme Programming Language,
;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996), which can be
;;; found online at http://www.scheme.com.  Most are also documented
;;; in the R4RS and draft R5RS.
;;;
;;;   bound-identifier=?
;;;   datum->syntax-object
;;;   define-syntax
;;;   fluid-let-syntax
;;;   free-identifier=?
;;;   generate-temporaries
;;;   identifier?
;;;   identifier-syntax
;;;   let-syntax
;;;   letrec-syntax
;;;   syntax
;;;   syntax-case
;;;   syntax-object->datum
;;;   syntax-rules
;;;   with-syntax
;;;
;;; All standard Scheme syntactic forms are supported by the expander
;;; or syntactic abstractions defined in this file.  Only the R4RS
;;; delay is omitted, since its expansion is implementation-dependent.

;;; Also defined are three forms that support modules: module, import,
;;; and import-only.  These are documented in the Chez Scheme User's
;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
;;; also be found online at http://www.scheme.com.  They are described
;;; briefly here as well.
;;;
;;; Both are definitions and may appear where and only where other
;;; definitions may appear.  modules may be named:
;;;
;;;   (module id (ex ...) defn ... init ...)
;;;
;;; or anonymous:
;;;
;;;   (module (ex ...) defn ... init ...)
;;;
;;; The latter form is semantically equivalent to:
;;;
;;;   (module T (ex ...) defn ... init ...)
;;;   (import T)
;;;
;;; where T is a fresh identifier.
;;;
;;; In either form, each of the exports in (ex ...) is either an
;;; identifier or of the form (id ex ...).  In the former case, the
;;; single identifier ex is exported.  In the latter, the identifier
;;; id is exported and the exports ex ... are "implicitly" exported.
;;; This listing of implicit exports is useful only when id is a
;;; keyword bound to a transformer that expands into references to
;;; the listed implicit exports.  In the present implementation,
;;; listing of implicit exports is necessary only for top-level
;;; modules and allows the implementation to avoid placing all
;;; identifiers into the top-level environment where subsequent passes
;;; of the compiler will be unable to deal effectively with them.
;;;
;;; Named modules may be referenced in import statements, which
;;; always take one of the forms:
;;;
;;;   (import id)
;;;   (import-only id)
;;;
;;; id must name a module.  Each exported identifier becomes visible
;;; within the scope of the import form.  In the case of import-only,
;;; all other identifiers become invisible in the scope of the
;;; import-only form, except for those established by definitions
;;; that appear textually after the import-only form.

;;; The remaining exports are listed below.  sc-expand, eval-when, and
;;; syntax-error are described in the Chez Scheme User's Guide.
;;;
;;;   (sc-expand datum)
;;;      if datum represents a valid expression, sc-expand returns an
;;;      expanded version of datum in a core language that includes no
;;;      syntactic abstractions.  The core language includes begin,
;;;      define, if, lambda, letrec, quote, and set!.
;;;   (eval-when situations expr ...)
;;;      conditionally evaluates expr ... at compile-time or run-time
;;;      depending upon situations
;;;   (syntax-error object message)
;;;      used to report errors found during expansion
;;;   ($syntax-dispatch e p)
;;;      used by expanded code to handle syntax-case matching
;;;   ($sc-put-cte symbol val)
;;;      used to establish top-level compile-time (expand-time) bindings.

;;; The following nonstandard procedures must be provided by the
;;; implementation for this code to run.
;;;
;;; (void)
;;; returns the implementation's cannonical "unspecified value".  The
;;; following usually works:
;;;
;;; (define void (lambda () (if #f #f))).
;;;
;;; (andmap proc list1 list2 ...)
;;; returns true if proc returns true when applied to each element of list1
;;; along with the corresponding elements of list2 ....  The following
;;; definition works but does no error checking:
;;;
;;; (define andmap
;;;   (lambda (f first . rest)
;;;     (or (null? first)
;;;         (if (null? rest)
;;;             (let andmap ((first first))
;;;               (let ((x (car first)) (first (cdr first)))
;;;                 (if (null? first)
;;;                     (f x)
;;;                     (and (f x) (andmap first)))))
;;;             (let andmap ((first first) (rest rest))
;;;               (let ((x (car first))
;;;                     (xr (map car rest))
;;;                     (first (cdr first))
;;;                     (rest (map cdr rest)))
;;;                 (if (null? first)
;;;                     (apply f (cons x xr))
;;;                     (and (apply f (cons x xr)) (andmap first rest)))))))))
;;;
;;; (ormap proc list1)
;;; returns the first non-false return result of proc applied to
;;; the elements of list1 or false if none.  The following definition
;;; works but does no error checking:
;;;
;;; (define ormap
;;;   (lambda (proc list1)
;;;     (and (not (null? list1))
;;;          (or (proc (car list1)) (ormap proc (cdr list1))))))
;;;
;;; The following nonstandard procedures must also be provided by the
;;; implementation for this code to run using the standard portable
;;; hooks and output constructors.  They are not used by expanded code,
;;; and so need be present only at expansion time.
;;;
;;; (eval x)
;;; where x is always in the form ("noexpand" expr).
;;; returns the value of expr.  the "noexpand" flag is used to tell the
;;; evaluator/expander that no expansion is necessary, since expr has
;;; already been fully expanded to core forms.
;;;
;;; eval will not be invoked during the loading of psyntax.pp.  After
;;; psyntax.pp has been loaded, the expansion of any macro definition,
;;; whether local or global, results in a call to eval.  If, however,
;;; sc-expand has already been registered as the expander to be used
;;; by eval, and eval accepts one argument, nothing special must be done
;;; to support the "noexpand" flag, since it is handled by sc-expand.
;;;
;;; (error who format-string why what)
;;; where who is either a symbol or #f, format-string is always "~a ~s",
;;; why is always a string, and what may be any object.  error should
;;; signal an error with a message something like
;;;
;;;    "error in <who>: <why> <what>"
;;;
;;; (gensym)
;;; returns a unique symbol each time it's called.  In Chez Scheme, gensym
;;; returns a symbol with a "globally" unique name so that gensyms that
;;; end up in the object code of separately compiled files cannot conflict.
;;; This is necessary only if you intend to support compiled files.
;;;
;;; (putprop symbol key value)
;;; (getprop symbol key)
;;; (remprop symbol key)
;;; key is always a symbol; value may be any object.  putprop should
;;; associate the given value with the given symbol and key in some way
;;; that it can be retrieved later with getprop.  getprop should return
;;; #f if no value is associated with the given symbol and key.  remprop
;;; should remove the association between the given symbol and key.

;;; When porting to a new Scheme implementation, you should define the
;;; procedures listed above, load the expanded version of psyntax.ss
;;; (psyntax.pp, which should be available whereever you found
;;; psyntax.ss), and register sc-expand as the current expander (how
;;; you do this depends upon your implementation of Scheme).  You may
;;; change the hooks and constructors defined toward the beginning of
;;; the code below, but to avoid bootstrapping problems, do so only
;;; after you have a working version of the expander.

;;; Chez Scheme allows the syntactic form (syntax <template>) to be
;;; abbreviated to #'<template>, just as (quote <datum>) may be
;;; abbreviated to '<datum>.  The #' syntax makes programs written
;;; using syntax-case shorter and more readable and draws out the
;;; intuitive connection between syntax and quote.  If you have access
;;; to the source code of your Scheme system's reader, you might want
;;; to implement this extension.

;;; If you find that this code loads or runs slowly, consider
;;; switching to faster hardware or a faster implementation of
;;; Scheme.  In Chez Scheme on a 200Mhz Pentium Pro, expanding,
;;; compiling (with full optimization), and loading this file takes
;;; between one and two seconds.

;;; In the expander implementation, we sometimes use syntactic abstractions
;;; when procedural abstractions would suffice.  For example, we define
;;; top-wrap and top-marked? as
;;;   (define-syntax top-wrap (identifier-syntax '((top))))
;;;   (define-syntax top-marked?
;;;     (syntax-rules ()
;;;       ((_ w) (memq 'top (wrap-marks w)))))
;;; rather than
;;;   (define top-wrap '((top)))
;;;   (define top-marked?
;;;     (lambda (w) (memq 'top (wrap-marks w))))
;;; On ther other hand, we don't do this consistently; we define make-wrap,
;;; wrap-marks, and wrap-subst simply as
;;;   (define make-wrap cons)
;;;   (define wrap-marks car)
;;;   (define wrap-subst cdr)
;;; In Chez Scheme, the syntactic and procedural forms of these
;;; abstractions are equivalent, since the optimizer consistently
;;; integrates constants and small procedures.  Some Scheme
;;; implementations, however, may benefit from more consistent use 
;;; of one form or the other.


;;; Implementation notes:

;;; "begin" is treated as a splicing construct at top level and at
;;; the beginning of bodies.  Any sequence of expressions that would
;;; be allowed where the "begin" occurs is allowed.

;;; "let-syntax" and "letrec-syntax" are also treated as splicing
;;; constructs, in violation of the R5RS.  A consequence is that let-syntax
;;; and letrec-syntax do not create local contours, as do let and letrec.
;;; Although the functionality is greater as it is presently implemented,
;;; we will probably change it to conform to the R5RS.  modules provide
;;; similar functionality to nonsplicing letrec-syntax when the latter is
;;; used as a definition.

;;; Objects with no standard print syntax, including objects containing
;;; cycles and syntax objects, are allowed in quoted data as long as they
;;; are contained within a syntax form or produced by datum->syntax-object.
;;; Such objects are never copied.

;;; When the expander encounters a reference to an identifier that has
;;; no global or lexical binding, it treats it as a global-variable
;;; reference.  This allows one to write mutually recursive top-level
;;; definitions, e.g.:
;;;   
;;;   (define f (lambda (x) (g x)))
;;;   (define g (lambda (x) (f x)))
;;;
;;; but may not always yield the intended when the variable in question
;;; is later defined as a keyword.

;;; Top-level variable definitions of syntax keywords are permitted.
;;; In order to make this work, top-level define not only produces a
;;; top-level definition in the core language, but also modifies the
;;; compile-time environment (using $sc-put-cte) to record the fact
;;; that the identifier is a variable.

;;; Top-level definitions of macro-introduced identifiers are visible
;;; only in code produced by the macro.  That is, a binding for a
;;; hidden (generated) identifier is created instead, and subsequent
;;; references within the macro output are renamed accordingly.  For
;;; example:
;;;
;;; (define-syntax a
;;;   (syntax-rules ()
;;;     ((_ var exp)
;;;      (begin
;;;        (define secret exp)
;;;        (define var
;;;          (lambda ()
;;;            (set! secret (+ secret 17))
;;;            secret))))))
;;; (a x 0)
;;; (x) => 17
;;; (x) => 34
;;; secret => Error: variable secret is not bound
;;;
;;; The definition above would fail if the definition for secret
;;; were placed after the definition for var, since the expander would
;;; encounter the references to secret before the definition that
;;; establishes the compile-time map from the identifier secret to
;;; the generated identifier.

;;; Identifiers and syntax objects are implemented as vectors for
;;; portability.  As a result, it is possible to "forge" syntax
;;; objects.

;;; The input to sc-expand may contain "annotations" describing, e.g., the
;;; source file and character position from where each object was read if
;;; it was read from a file.  These annotations are handled properly by
;;; sc-expand only if the annotation? hook (see hooks below) is implemented
;;; properly and the operators make-annotation, annotation-expression,
;;; annotation-source, annotation-stripped, and set-annotation-stripped!
;;; are supplied.  If annotations are supplied, the proper annotation
;;; source is passed to the various output constructors, allowing
;;; implementations to accurately correlate source and expanded code.
;;; Contact one of the authors for details if you wish to make use of
;;; this feature.

;;; Implementation of modules:
;;;
;;; The implementation of modules requires that implicit top-level exports
;;; be listed with the exported macro at some level where both are visible,
;;; e.g.,
;;;
;;;   (module M (alpha (beta b))
;;;     (module ((alpha a) b)
;;;       (define-syntax alpha (identifier-syntax a))
;;;       (define a 'a)
;;;       (define b 'b))
;;;     (define-syntax beta (identifier-syntax b)))
;;;
;;; Listing of implicit imports is not needed for macros that do not make
;;; it out to top level, including all macros that are local to a "body".
;;; (They may be listed in this case, however.)  We need this information
;;; for top-level modules since a top-level module expands into a letrec
;;; for non-top-level variables and top-level definitions (assignments) for
;;; top-level variables.  Because of the general nature of macro
;;; transformers, we cannot determine the set of implicit exports from the
;;; transformer code, so without the user's help, we'd have to put all
;;; variables at top level.
;;; 
;;; Each such top-level identifier is given a generated name (gensym).
;;; When a top-level module is imported at top level, a compile-time
;;; alias is established from the top-level name to the generated name.
;;; The expander follows these aliases transparently.  When any module is
;;; imported anywhere other than at top level, the id-var-name of the
;;; import identifier is set to the id-var-name of the export identifier.
;;; Since we can't determine the actual labels for identifiers defined in
;;; top-level modules until we determine which are placed in the letrec
;;; and which make it to top level, we give each an "indirect" label---a
;;; pair whose car will eventually contain the actual label.  Import does
;;; not follow the indirect, but id-var-name does.
;;;
;;; All identifiers defined within a local module are folded into the
;;; letrec created for the enclosing body.  Visibility is controlled in
;;; this case and for nested top-level modules by introducing a new wrap
;;; for each module.


;;; Bootstrapping:

;;; When changing syntax-object representations, it is necessary to support
;;; both old and new syntax-object representations in id-var-name.  It
;;; should be sufficient to recognize old representations and treat
;;; them as not lexically bound.


(let ()

(define-syntax when
  (syntax-rules ()
    ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
(define-syntax unless
  (syntax-rules ()
    ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
(define-syntax define-structure
  (lambda (x)
    (define construct-name
      (lambda (template-identifier . args)
        (datum->syntax-object
          template-identifier
          (string->symbol
            (apply string-append
                   (map (lambda (x)
                          (if (string? x)
                              x
                              (symbol->string (syntax-object->datum x))))
                        args))))))
    (syntax-case x ()
      ((_ (name id1 ...))
       (andmap identifier? (syntax (name id1 ...)))
       (with-syntax
         ((constructor (construct-name (syntax name) "make-" (syntax name)))
          (predicate (construct-name (syntax name) (syntax name) "?"))
          ((access ...)
           (map (lambda (x) (construct-name x (syntax name) "-" x))
                (syntax (id1 ...))))
          ((assign ...)
           (map (lambda (x)
                  (construct-name x "set-" (syntax name) "-" x "!"))
                (syntax (id1 ...))))
          (structure-length
           (+ (length (syntax (id1 ...))) 1))
          ((index ...)
           (let f ((i 1) (ids (syntax (id1 ...))))
              (if (null? ids)
                  '()
                  (cons i (f (+ i 1) (cdr ids)))))))
         (syntax (begin
                   (define constructor
                     (lambda (id1 ...)
                       (vector 'name id1 ... )))
                   (define predicate
                     (lambda (x)
                       (and (vector? x)
                            (= (vector-length x) structure-length)
                            (eq? (vector-ref x 0) 'name))))
                   (define access
                     (lambda (x)
                       (vector-ref x index)))
                   ...
                   (define assign
                     (lambda (x update)
                       (vector-set! x index update)))
                   ...)))))))

(define noexpand "noexpand")

;;; hooks to nonportable run-time helpers
(begin
(define-syntax fx+ (identifier-syntax +))
(define-syntax fx- (identifier-syntax -))
(define-syntax fx= (identifier-syntax =))
(define-syntax fx< (identifier-syntax <))

(define annotation? (lambda (x) #f))

(define top-level-eval-hook sc-eval)

(define local-eval-hook sc-eval)

(define error-hook (lambda (who why what) (error why what)))

(define-syntax gensym-hook
  (syntax-rules ()
    ((_) (gensym))))

(define put-global-definition-hook
  (lambda (symbol val)
    ($sc-put-cte symbol val)))

(define get-global-definition-hook
  (lambda (symbol)
    (getprop symbol '*sc-expander*)))

(define get-import-binding
  (lambda (symbol token)
    (getprop symbol token)))

(define generate-id
  (let ((b (- 127 32 2)))
   ; session-key should generate a unique integer for each system run
   ; to support separate compilation
    (define session-key (lambda () 0))
    (define make-digit (lambda (x) (integer->char (fx+ x 33))))
    (define fmt
      (lambda (n)
        (let fmt ((n n) (a '()))
          (if (< n b)
              (list->string (cons (make-digit n) a))
              (let ((r (modulo n b)) (rest (quotient n b)))
                (fmt rest (cons (make-digit r) a)))))))
    (let ((prefix (fmt (session-key))) (n -1))
      (lambda (name)
        (set! n (+ n 1))
        (let ((newsym (string->symbol (string-append "#" prefix (fmt n)))))
          newsym)))))
)


;;; output constructors
(begin
(define-syntax build-application
  (syntax-rules ()
    ((_ source fun-exp arg-exps)
     `(,fun-exp . ,arg-exps))))

(define-syntax build-conditional
  (syntax-rules ()
    ((_ source test-exp then-exp else-exp)
     `(if ,test-exp ,then-exp ,else-exp))))

(define-syntax build-lexical-reference
  (syntax-rules ()
    ((_ type source var)
     var)))

(define-syntax build-lexical-assignment
  (syntax-rules ()
    ((_ source var exp)
     `(set! ,var ,exp))))

(define-syntax build-global-reference
  (syntax-rules ()
    ((_ source var)
     var)))

(define-syntax build-global-assignment
  (syntax-rules ()
    ((_ source var exp)
     `(set! ,var ,exp))))

(define-syntax build-global-definition
  (syntax-rules ()
    ((_ source var exp)
     `(define ,var ,exp))))

(define-syntax build-module-definition
 ; should have the effect of a global definition but may not appear at top level
  (identifier-syntax build-global-assignment))

(define-syntax build-cte-install
 ; should build a call that has the same effect as calling the
 ; global definition hook
  (syntax-rules ()
    ((_ sym exp) `($sc-put-cte ',sym ,exp))))
 
(define-syntax build-lambda
  (syntax-rules ()
    ((_ src vars exp)
     `(lambda ,vars ,exp))))

(define-syntax build-primref
  (syntax-rules ()
    ((_ src name) name)
    ((_ src level name) name)))

(define-syntax build-data
  (syntax-rules ()
    ((_ src exp) `',exp)))

(define build-sequence
  (lambda (src exps)
    (if (null? (cdr exps))
        (car exps)
        `(begin ,@exps))))

(define build-letrec
  (lambda (src vars val-exps body-exp)
    (if (null? vars)
        body-exp
        `(letrec ,(map list vars val-exps) ,body-exp))))

(define-syntax build-lexical-var
  (syntax-rules ()
    ((_ src id) (gensym))))

(define-syntax self-evaluating?
  (syntax-rules ()
    ((_ e)
     (let ((x e))
       (or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
)

(define-structure (syntax-object expression wrap))

(define-syntax unannotate
  (syntax-rules ()
    ((_ x)
     (let ((e x))
       (if (annotation? e)
           (annotation-expression e)
           e)))))

(define-syntax no-source (identifier-syntax #f))

(define source-annotation
  (lambda (x)
     (cond
       ((annotation? x) (annotation-source x))
       ((syntax-object? x) (source-annotation (syntax-object-expression x)))
       (else no-source))))

(define-syntax arg-check
  (syntax-rules ()
    ((_ pred? e who)
     (let ((x e))
       (if (not (pred? x)) (error-hook who "invalid argument" x))))))

;;; compile-time environments

;;; wrap and environment comprise two level mapping.
;;;   wrap : id --> label
;;;   env : label --> <element>

;;; environments are represented in two parts: a lexical part and a global
;;; part.  The lexical part is a simple list of associations from labels
;;; to bindings.  The global part is implemented by
;;; {put,get}-global-definition-hook and associates symbols with
;;; bindings.

;;; global (assumed global variable) and displaced-lexical (see below)
;;; do not show up in any environment; instead, they are fabricated by
;;; lookup when it finds no other bindings.

;;; <environment>              ::= ((<label> . <binding>)*)

;;; identifier bindings include a type and a value

;;; <binding> ::= (macro . <procedure>)           macros
;;;               (deferred . <expanded code>)    lazy-evaluation of transformers
;;;               (core . <procedure>)            core forms
;;;               (begin)                         begin
;;;               (define)                        define
;;;               (define-syntax)                 define-syntax
;;;               (local-syntax . rec?)           let-syntax/letrec-syntax
;;;               (eval-when)                     eval-when
;;;               (syntax . (<var> . <level>))    pattern variables
;;;               (global . <symbol>)             assumed global variable
;;;               (lexical . <var>)               lexical variables
;;;               (displaced-lexical . #f)        id-var-name not found in store
;;; <level>   ::= <nonnegative integer>
;;; <var>     ::= variable returned by build-lexical-var

;;; a macro is a user-defined syntactic-form.  a core is a system-defined
;;; syntactic form.  begin, define, define-syntax, and eval-when are
;;; treated specially since they are sensitive to whether the form is
;;; at top-level and (except for eval-when) can denote valid internal
;;; definitions.

;;; a pattern variable is a variable introduced by syntax-case and can
;;; be referenced only within a syntax form.

;;; any identifier for which no top-level syntax definition or local
;;; binding of any kind has been seen is assumed to be a global
;;; variable.

;;; a lexical variable is a lambda- or letrec-bound variable.

;;; a displaced-lexical identifier is a lexical identifier removed from
;;; it's scope by the return of a syntax object containing the identifier.
;;; a displaced lexical can also appear when a letrec-syntax-bound
;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
;;; a displaced lexical should never occur with properly written macros.

(define make-binding (lambda (x y) (cons x y)))
(define binding-type car)
(define binding-value cdr)
(define set-binding-type! set-car!)
(define set-binding-value! set-cdr!)
(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))

(define-syntax null-env (identifier-syntax '()))

(define extend-env
  (lambda (label binding r)
    (cons (cons label binding) r)))

(define extend-env*
  (lambda (labels bindings r) 
    (if (null? labels)
        r
        (extend-env* (cdr labels) (cdr bindings)
          (extend-env (car labels) (car bindings) r)))))

(define extend-var-env*
  ; variant of extend-env* that forms "lexical" binding
  (lambda (labels vars r)
    (if (null? labels)
        r
        (extend-var-env* (cdr labels) (cdr vars)
          (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))

;;; we use a "macros only" environment in expansion of local macro
;;; definitions so that their definitions can use local macros without
;;; attempting to use other lexical identifiers.
;;;
;;; - can make this null-env if we don't want to allow macros to use other
;;;   macros in defining their transformers
;;; - can add a cache here if it pays off
(define transformer-env
  (lambda (r)
    (if (null? r)
        '()
        (let ((a (car r)))
          (if (eq? (cadr a) 'lexical)       ; only strip out lexical so that (transformer x) works
              (transformer-env (cdr r))
              (cons a (transformer-env (cdr r))))))))

(define displaced-lexical-error
  (lambda (id)
    (syntax-error id
      (if (id-var-name id empty-wrap)
          "identifier out of context"
          "identifier not visible"))))

(define lookup*
  ; x may be a label or a symbol
  ; although symbols are usually global, we check the environment first
  ; anyway because a temporary binding may have been established by
  ; fluid-let-syntax
  (lambda (x r)
    (cond
      ((assq x r) => cdr)
      ((symbol? x)
       (or (get-global-definition-hook x) (make-binding 'global x)))
      (else (make-binding 'displaced-lexical #f)))))

(define sanitize-binding
  (lambda (b)
    (cond
      ((procedure? b) (make-binding 'macro b))
      ((binding? b)
       (case (binding-type b)
         ((core macro macro!) (and (procedure? (binding-value b)) b))
         ((module) (and (interface? (binding-value b)) b))
         (else b)))
      (else #f))))

(define lookup
  (lambda (x r)
    (define whack-binding!
      (lambda (b *b)
        (set-binding-type! b (binding-type *b))
        (set-binding-value! b (binding-value *b))))
    (let ((b (lookup* x r)))
      (case (binding-type b)
;        ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
        ((deferred)
         (whack-binding! b
           (let ((*b (local-eval-hook (binding-value b))))
             (or (sanitize-binding *b)
                 (syntax-error *b "invalid transformer"))))
         (case (binding-type b)
;           ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
           (else b)))
        (else b)))))

(define global-extend
  (lambda (type sym val)
    (put-global-definition-hook sym (make-binding type val))))


;;; Conceptually, identifiers are always syntax objects.  Internally,
;;; however, the wrap is sometimes maintained separately (a source of
;;; efficiency and confusion), so that symbols are also considered
;;; identifiers by id?.  Externally, they are always wrapped.

(define nonsymbol-id?
  (lambda (x)
    (and (syntax-object? x)
         (symbol? (unannotate (syntax-object-expression x))))))

(define id?
  (lambda (x)
    (cond
      ((symbol? x) #t)
      ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
      ((annotation? x) (symbol? (annotation-expression x)))
      (else #f))))

(define-syntax id-sym-name
  (syntax-rules ()
    ((_ e)
     (let ((x e))
       (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))

(define id-sym-name&marks
  (lambda (x w)
    (if (syntax-object? x)
        (values
          (unannotate (syntax-object-expression x))
          (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
        (values (unannotate x) (wrap-marks w)))))

;;; syntax object wraps

;;;         <wrap> ::= ((<mark> ...) . (<subst> ...))
;;;        <subst> ::= <ribcage> | <shift>
;;;      <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
;;;                  | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
;;;   <ex-symname> ::= <symname> | <import token> | <barrier>
;;;        <shift> ::= shift
;;;      <barrier> ::= #f                                               ; inserted by import-only
;;; <import token> ::= #<"import-token" <token>>
;;;        <token> ::= <generated id>

(define make-wrap cons)
(define wrap-marks car)
(define wrap-subst cdr)

(define-syntax subst-rename? (identifier-syntax vector?))
(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
(define-syntax make-rename
  (syntax-rules ()
    ((_ old new marks) (vector old new marks))))

;;; labels

;;; simple labels must be comparable with "eq?" and distinct from symbols
;;; and pairs.

;;; indirect labels, which are implemented as pairs, are used to support
;;; import aliasing for identifiers exported (explictly or implicitly) from
;;; top-level modules.  chi-external creates an indirect label for each
;;; defined identifier, import causes the pair to be shared aliases it
;;; establishes, and chi-top-module whacks the pair to hold the top-level
;;; identifier name (symbol) if the id is to be placed at top level, before
;;; expanding the right-hand sides of the definitions in the module.

(define gen-label
  (lambda () (string #\i)))
(define label?
  (lambda (x)
    (or (string? x) ; normal lexical labels
        (symbol? x) ; global labels (symbolic names)
        (indirect-label? x))))

(define gen-labels
  (lambda (ls)
    (if (null? ls)
        '()
        (cons (gen-label) (gen-labels (cdr ls))))))

(define gen-indirect-label
  (lambda () (list (gen-label))))

(define indirect-label? pair?)
(define get-indirect-label car)
(define set-indirect-label! set-car!)

(define-structure (ribcage symnames marks labels))
(define-syntax empty-wrap (identifier-syntax '(())))

(define-syntax top-wrap (identifier-syntax '((top))))

(define-syntax top-marked?
  (syntax-rules ()
    ((_ w) (memq 'top (wrap-marks w)))))

(define-syntax only-top-marked?
  (syntax-rules ()
    ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))

;;; Marks must be comparable with "eq?" and distinct from pairs and
;;; the symbol top.  We do not use integers so that marks will remain
;;; unique even across file compiles.

(define-syntax the-anti-mark (identifier-syntax #f))

(define anti-mark
  (lambda (w)
    (make-wrap (cons the-anti-mark (wrap-marks w))
               (cons 'shift (wrap-subst w)))))

(define-syntax new-mark
  (syntax-rules ()
    ((_) (string #\m))))

(define barrier-marker #f)
(module (make-import-token import-token? import-token-key)
  (define tag 'import-token)
  (define make-import-token (lambda (x) (cons tag x)))
  (define import-token? (lambda (x) (and (pair? x) (eq? (car x) tag))))
  (define import-token-key cdr))

;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;;; internal definitions, in which the ribcages are built incrementally
(define-syntax make-empty-ribcage
  (syntax-rules ()
    ((_) (make-ribcage '() '() '()))))

(define extend-ribcage!
 ; must receive ids with complete wraps
 ; ribcage guaranteed to be list-based
  (lambda (ribcage id label)
    (set-ribcage-symnames! ribcage
      (cons (unannotate (syntax-object-expression id))
            (ribcage-symnames ribcage)))
    (set-ribcage-marks! ribcage
      (cons (wrap-marks (syntax-object-wrap id))
            (ribcage-marks ribcage)))
    (set-ribcage-labels! ribcage
      (cons label (ribcage-labels ribcage)))))

(define extend-ribcage-barrier!
 ; must receive ids with complete wraps
 ; ribcage guaranteed to be list-based
  (lambda (ribcage killer-id)
    (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))

(define extend-ribcage-barrier-help!
  (lambda (ribcage wrap)
    (set-ribcage-symnames! ribcage
      (cons barrier-marker (ribcage-symnames ribcage)))
    (set-ribcage-marks! ribcage
      (cons (wrap-marks wrap) (ribcage-marks ribcage)))))

(define extend-ribcage-subst!
 ; ribcage guaranteed to be list-based
  (lambda (ribcage token)
    (set-ribcage-symnames! ribcage
      (cons (make-import-token token) (ribcage-symnames ribcage)))))

(define lookup-import-binding-name
  (lambda (sym key marks)
    (let ((new (get-import-binding sym key)))
      (and new
           (let f ((new new))
             (cond
               ((pair? new) (or (f (car new)) (f (cdr new))))
               ((same-marks? marks (wrap-marks (syntax-object-wrap new))) new)
               (else #f)))))))

;;; make-binding-wrap creates vector-based ribcages
(define make-binding-wrap
  (lambda (ids labels w)
    (if (null? ids)
        w
        (make-wrap
          (wrap-marks w)
          (cons
            (let ((labelvec (list->vector labels)))
              (let ((n (vector-length labelvec)))
                (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
                  (let f ((ids ids) (i 0))
                    (if (not (null? ids))
                        (call-with-values
                          (lambda () (id-sym-name&marks (car ids) w))
                          (lambda (symname marks)
                            (vector-set! symnamevec i symname)
                            (vector-set! marksvec i marks)
                            (f (cdr ids) (fx+ i 1))))))
                  (make-ribcage symnamevec marksvec labelvec))))
            (wrap-subst w))))))

;;; make-trimmed-syntax-object is used by make-resolved-interface to support
;;; creation of module export lists whose constituent ids do not contain
;;; unnecessary substitutions or marks.
(define make-trimmed-syntax-object
  (lambda (id)
    (call-with-values
      (lambda () (id-var-name&marks id empty-wrap))
      (lambda (tosym marks)
        (unless tosym
          (syntax-error id "identifier not visible for export"))
        (let ((fromsym (id-sym-name id)))
          (make-syntax-object fromsym
            (make-wrap marks
              (list (make-ribcage (vector fromsym) (vector marks) (vector tosym))))))))))

;;; Scheme's append should not copy the first argument if the second is
;;; nil, but it does, so we define a smart version here.
(define smart-append
  (lambda (m1 m2)
    (if (null? m2)
        m1
        (append m1 m2))))

(define join-wraps
  (lambda (w1 w2)
    (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
      (if (null? m1)
          (if (null? s1)
              w2
              (make-wrap
                (wrap-marks w2)
                (smart-append s1 (wrap-subst w2))))
          (make-wrap
            (smart-append m1 (wrap-marks w2))
            (smart-append s1 (wrap-subst w2)))))))

(define join-marks
  (lambda (m1 m2)
    (smart-append m1 m2)))

(define same-marks?
  (lambda (x y)
    (or (eq? x y)
        (and (not (null? x))
             (not (null? y))
             (eq? (car x) (car y))
             (same-marks? (cdr x) (cdr y))))))

(define id-var-name-loc&marks
  (lambda (id w)
    (define search
      (lambda (sym subst marks)
        (if (null? subst)
            (values sym marks)
            (let ((fst (car subst)))
              (if (eq? fst 'shift)
                  (search sym (cdr subst) (cdr marks))
                  (let ((symnames (ribcage-symnames fst)))
                    (if (vector? symnames)
                        (search-vector-rib sym subst marks symnames fst)
                        (search-list-rib sym subst marks symnames fst))))))))
    (define search-list-rib
      (lambda (sym subst marks symnames ribcage)
        (let f ((symnames symnames) (i 0))
          (cond
            ((null? symnames) (search sym (cdr subst) marks))
            ((and (eq? (car symnames) sym)
                  (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
             (values (list-ref (ribcage-labels ribcage) i) marks))
            ((import-token? (car symnames))
             (cond
               ((lookup-import-binding-name sym (import-token-key (car symnames)) marks) =>
                (lambda (id)
                  (if (symbol? id)
                      (values id marks)
                      (id-var-name&marks id empty-wrap))))   ; could be more efficient:  new is a resolved id
               (else (f (cdr symnames) i))))
            ((and (eq? (car symnames) barrier-marker)
                  (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
             (values #f marks))
            (else (f (cdr symnames) (fx+ i 1)))))))
    (define search-vector-rib
      (lambda (sym subst marks symnames ribcage)
        (let ((n (vector-length symnames)))
          (let f ((i 0))
            (cond
              ((fx= i n) (search sym (cdr subst) marks))
              ((and (eq? (vector-ref symnames i) sym)
                    (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
               (values (vector-ref (ribcage-labels ribcage) i) marks))
              (else (f (fx+ i 1))))))))
    (cond
      ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
      ((syntax-object? id)
       (let ((sym (unannotate (syntax-object-expression id)))
             (w1 (syntax-object-wrap id)))
         (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
           (call-with-values (lambda () (search sym (wrap-subst w) marks))
             (lambda (new-id marks)
               (if (eq? new-id sym)
                   (search sym (wrap-subst w1) marks)
                   (values new-id marks)))))))
      ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
      (else (error-hook 'id-var-name "invalid id" id)))))

(define id-var-name&marks
 ; this version follows indirect labels
  (lambda (id w)
    (call-with-values
      (lambda () (id-var-name-loc&marks id w))
      (lambda (label marks)
        (values (if (indirect-label? label) (get-indirect-label label) label) marks)))))

(define id-var-name-loc
 ; this version doesn't follow indirect labels
  (lambda (id w)
    (call-with-values
      (lambda () (id-var-name-loc&marks id w))
      (lambda (label marks) label))))

(define id-var-name
 ; this version follows indirect labels
  (lambda (id w)
    (call-with-values
      (lambda () (id-var-name-loc&marks id w))
      (lambda (label marks)
        (if (indirect-label? label) (get-indirect-label label) label)))))

;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.

(define free-id=?
  (lambda (i j)
    (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
         (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))

(define-syntax literal-id=? (identifier-syntax free-id=?))

;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;;; long as the missing portion of the wrap is common to both of the ids
;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))

(define bound-id=?
  (lambda (i j)
    (if (and (syntax-object? i) (syntax-object? j))
        (and (eq? (unannotate (syntax-object-expression i))
                  (unannotate (syntax-object-expression j)))
             (same-marks? (wrap-marks (syntax-object-wrap i))
                  (wrap-marks (syntax-object-wrap j))))
        (eq? (unannotate i) (unannotate j)))))

;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
;;; as long as the missing portion of the wrap is common to all of the
;;; ids.

(define valid-bound-ids?
  (lambda (ids)
     (and (let all-ids? ((ids ids))
            (or (null? ids)
                (and (id? (car ids))
                     (all-ids? (cdr ids)))))
          (distinct-bound-ids? ids))))

;;; distinct-bound-ids? expects a list of ids and returns #t if there are
;;; no duplicates.  It is quadratic on the length of the id list; long
;;; lists could be sorted to make it more efficient.  distinct-bound-ids?
;;; may be passed unwrapped (or partially wrapped) ids as long as the
;;; missing portion of the wrap is common to all of the ids.

(define distinct-bound-ids?
  (lambda (ids)
    (let distinct? ((ids ids))
      (or (null? ids)
          (and (not (bound-id-member? (car ids) (cdr ids)))
               (distinct? (cdr ids)))))))

(define invalid-ids-error
 ; find first bad one and complain about it
  (lambda (ids exp class)
    (let find ((ids ids) (gooduns '()))
      (if (null? ids)
          (syntax-error exp) ; shouldn't happen
          (if (id? (car ids))
              (if (bound-id-member? (car ids) gooduns)
                  (syntax-error (car ids) "duplicate " class)
                  (find (cdr ids) (cons (car ids) gooduns)))
              (syntax-error (car ids) "invalid " class))))))

(define bound-id-member?
   (lambda (x list)
      (and (not (null? list))
           (or (bound-id=? x (car list))
               (bound-id-member? x (cdr list))))))

;;; wrapping expressions and identifiers

(define wrap
  (lambda (x w)
    (cond
      ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
      ((syntax-object? x)
       (make-syntax-object
         (syntax-object-expression x)
         (join-wraps w (syntax-object-wrap x))))
      ((null? x) x)
      (else (make-syntax-object x w)))))

(define source-wrap
  (lambda (x w s)
    (wrap (if s (make-annotation x s #f) x) w)))

;;; expanding

(define chi-sequence
  (lambda (body r w s)
    (build-sequence s
      (let dobody ((body body) (r r) (w w))
        (if (null? body)
            '()
            (let ((first (chi (car body) r w)))
              (cons first (dobody (cdr body) r w))))))))

(define chi-top-sequence
  (lambda (body r w s m esew ribcage)
    (build-sequence s
      (let dobody ((body body) (r r) (w w) (m m) (esew esew))
        (if (null? body)
            '()
            (let ((first (chi-top (car body) r w m esew ribcage)))
              (cons first (dobody (cdr body) r w m esew))))))))

(define chi-when-list
  (lambda (e when-list w)
    ; when-list is syntax'd version of list of situations
    (let f ((when-list when-list) (situations '()))
      (if (null? when-list)
          situations
          (f (cdr when-list)
             (cons (let ((x (car when-list)))
                     (cond
                       ((literal-id=? x (syntax compile)) 'compile)
                       ((literal-id=? x (syntax load)) 'load)
                       ((literal-id=? x (syntax eval)) 'eval)
                       (else (syntax-error (wrap x w)
                               "invalid eval-when situation"))))
                   situations))))))

;;; syntax-type returns five values: type, value, e, w, and s.  The first
;;; two are described in the table below.
;;;
;;;    type                   value         explanation
;;;    -------------------------------------------------------------------
;;;    begin                  none          begin keyword
;;;    begin-form             none          begin expression
;;;    call                   none          any other call
;;;    constant               none          self-evaluating datum
;;;    core                   procedure     core form (including singleton)
;;;    define                 none          define keyword
;;;    define-form            none          variable definition
;;;    define-syntax          none          define-syntax keyword
;;;    define-syntax-form     none          syntax definition
;;;    displaced-lexical      none          displaced lexical identifier
;;;    eval-when              none          eval-when keyword
;;;    eval-when-form         none          eval-when form
;;;    global                 name          global variable reference
;;;    import                 none          import keyword
;;;    import-form            none          import form
;;;    lexical                name          lexical variable reference
;;;    lexical-call           name          call to lexical variable
;;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
;;;    local-syntax-form      rec?          syntax definition
;;;    module                 none          module keyword
;;;    module-form            none          module definition
;;;    other                  none          anything else
;;;    syntax                 level         pattern variable
;;;
;;; For all forms, e is the form, w is the wrap for e. and s is the source.
;;;
;;; syntax-type expands macros and unwraps as necessary to get to
;;; one of the forms above.

(define syntax-type
  (lambda (e r w s rib)
    (cond
      ((symbol? e)
       (let* ((n (id-var-name e w))
              (b (lookup n r))
              (type (binding-type b)))
         (case type
           ((lexical) (values type (binding-value b) e w s))
          ((global) (values type (binding-value b) e w s))
           ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w s rib) r empty-wrap #f rib))
           (else (values type (binding-value b) e w s)))))
      ((pair? e)
       (let ((first (car e)))
         (if (id? first)
             (let* ((n (id-var-name first w))
                    (b (lookup n r))
                    (type (binding-type b)))
               (case type
                 ((lexical) (values 'lexical-call (binding-value b) e w s))
                 ((macro macro!)
                  (syntax-type (chi-macro (binding-value b) e r w s rib)
                    r empty-wrap #f rib))
                 ((core) (values type (binding-value b) e w s))
                 ((local-syntax)
                  (values 'local-syntax-form (binding-value b) e w s))
                 ((begin) (values 'begin-form #f e w s))
                 ((eval-when) (values 'eval-when-form #f e w s))
                 ((define) (values 'define-form #f e w s))
                 ((define-syntax) (values 'define-syntax-form #f e w s))
                 ((module-key) (values 'module-form #f e w s))
                 ((import) (values 'import-form (and (binding-value b) (wrap first w)) e w s))
                 ((set!) (chi-set! e r w s rib))
                 (else (values 'call #f e w s))))
             (values 'call #f e w s))))
      ((syntax-object? e)
       ;; s can't be valid source if we've unwrapped
       (syntax-type (syntax-object-expression e)
                    r
                    (join-wraps w (syntax-object-wrap e))
                    no-source rib))
      ((annotation? e)
       (syntax-type (annotation-expression e) r w (annotation-source e) rib))
      ((self-evaluating? e) (values 'constant #f e w s))
      (else (values 'other #f e w s)))))

(define chi-top-expr
  (lambda (e r w top-ribcage)
    (call-with-values
      (lambda () (syntax-type e r w no-source top-ribcage))
      (lambda (type value e w s)
        (chi-expr type value e r w s)))))

(define chi-top
  (lambda (e r w m esew top-ribcage)
    (define-syntax eval-if-c&e
      (syntax-rules ()
        ((_ m e)
         (let ((x e))
           (if (eq? m 'c&e) (top-level-eval-hook x))
           x))))
    (call-with-values
      (lambda () (syntax-type e r w no-source top-ribcage))
      (lambda (type value e w s)
        (case type
          ((begin-form)
           (syntax-case e ()
             ((_) (chi-void))
             ((_ e1 e2 ...)
              (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew top-ribcage))))
          ((local-syntax-form)
           (chi-local-syntax value e r w s
             (lambda (body r w s)
               (chi-top-sequence body r w s m esew top-ribcage))))
          ((eval-when-form)
           (syntax-case e ()
             ((_ (x ...) e1 e2 ...)
              (let ((when-list (chi-when-list e (syntax (x ...)) w))
                    (body (syntax (e1 e2 ...))))
                (cond
                  ((eq? m 'e)
                   (if (memq 'eval when-list)
                       (chi-top-sequence body r w s 'e '(eval) top-ribcage)
                       (chi-void)))
                  ((memq 'load when-list)
                   (if (or (memq 'compile when-list)
                           (and (eq? m 'c&e) (memq 'eval when-list)))
                       (chi-top-sequence body r w s 'c&e '(compile load) top-ribcage)
                       (if (memq m '(c c&e))
                           (chi-top-sequence body r w s 'c '(load) top-ribcage)
                           (chi-void))))
                  ((or (memq 'compile when-list)
                       (and (eq? m 'c&e) (memq 'eval when-list)))
                   (top-level-eval-hook
                     (chi-top-sequence body r w s 'e '(eval) top-ribcage))
                   (chi-void))
                  (else (chi-void)))))))
          ((define-syntax-form)
           (parse-define-syntax e w s
             (lambda (id rhs w)
               (let ((id (wrap id w)))
                 (let ((n (id-var-name id empty-wrap)))
                   (let ((b (lookup n r)))
                     (case (binding-type b)
                       ((displaced-lexical) (displaced-lexical-error id)))))
                 (ct-eval/residualize m esew
                   (lambda ()
                     (build-cte-install
                       (let ((sym (id-sym-name id)))
                         (if (only-top-marked? id)
                             sym
                             (let ((marks (wrap-marks (syntax-object-wrap id))))
                               (make-syntax-object sym
                                 (make-wrap marks
                                   (list (make-ribcage (vector sym)
                                           (vector marks) (vector (generate-id sym)))))))))
                       (chi rhs (transformer-env r) w))))))))
          ((define-form)
           (parse-define e w s
             (lambda (id rhs w)
               (let ((id (wrap id w)))
                 (let ((n (id-var-name id empty-wrap)))
                   (let ((b (lookup n r)))
                     (case (binding-type b)
                       ((displaced-lexical) (displaced-lexical-error id)))))
                 (let ((sym (id-sym-name id)))
                   (let ((valsym (if (only-top-marked? id) sym (generate-id sym))))
                     (build-sequence no-source
                       (list
                         (ct-eval/residualize m esew
                           (lambda ()
                             (build-cte-install
                               (if (eq? sym valsym)
                                   sym
                                   (let ((marks (wrap-marks (syntax-object-wrap id))))
                                     (make-syntax-object sym
                                       (make-wrap marks
                                         (list (make-ribcage (vector sym)
                                                 (vector marks) (vector valsym)))))))
                               (build-data no-source (make-binding 'global valsym)))))
                         (eval-if-c&e m (build-global-definition s valsym (chi rhs r w))))))
                  )))))
          ((module-form)
           (let ((r (cons '("top-level module placeholder" . (placeholder)) r))
                 (ribcage (make-empty-ribcage)))
             (parse-module e w s (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))
               (lambda (id exports forms)
                 (if id
                     (begin
                       (let ((n (id-var-name id empty-wrap)))
                         (let ((b (lookup n r)))
                           (case (binding-type b)
                             ((displaced-lexical) (displaced-lexical-error (wrap id w))))))
                       (chi-top-module e r ribcage w s m esew id exports forms))
                     (chi-top-module e r ribcage w s m esew #f exports forms))))))
          ((import-form)
           (parse-import e w s
             (lambda (mid)
               (ct-eval/residualize m esew
                 (lambda ()
                   (when value (syntax-error (source-wrap e w s) "not valid at top-level"))
                   (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
                     (case (binding-type binding)
                       ((module) (do-top-import mid (interface-token (binding-value binding))))
                       ((displaced-lexical) (displaced-lexical-error mid))
                       (else (syntax-error mid "import from unknown module")))))))))
          (else (eval-if-c&e m (chi-expr type value e r w s))))))))

(define flatten-exports
  (lambda (exports)
    (let loop ((exports exports) (ls '()))
      (if (null? exports)
          ls
          (loop (cdr exports)
                (if (pair? (car exports))
                    (loop (car exports) ls)
                    (cons (car exports) ls)))))))


(define-structure (interface exports token))

(define make-trimmed-interface
 ; trim out implicit exports
  (lambda (exports)
    (make-interface
      (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
      #f)))

(define make-resolved-interface
 ; trim out implicit exports & resolve others to actual top-level symbol
  (lambda (exports import-token)
    (make-interface
      (list->vector (map (lambda (x) (make-trimmed-syntax-object (if (pair? x) (car x) x))) exports))
      import-token)))

(define-structure (module-binding type id label imps val))

(define chi-top-module
  (lambda (e r ribcage w s m esew id exports forms)
    (let ((fexports (flatten-exports exports)))
      (chi-external ribcage (source-wrap e w s)
        (map (lambda (d) (cons r d)) forms) r exports fexports m esew
        (lambda (bindings inits)
         ; dvs & des: "defined" (letrec-bound) vars & rhs expressions
         ; svs & ses: "set!" (top-level) vars & rhs expressions
          (let partition ((fexports fexports) (bs bindings) (svs '()) (ses '()) (ctdefs '()))
            (if (null? fexports)
               ; remaining bindings are either local vars or local macros/modules
                (let partition ((bs bs) (dvs '()) (des '()))
                  (if (null? bs)
                      (let ((ses (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) ses))
                            (des (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) des))
                            (inits (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) inits)))
                       ; we wait to do this here so that expansion of des & ses use
                       ; local versions, which in particular, allows us to use macros
                       ; locally even if esew tells us not to eval them
                        (for-each (lambda (x)
                                    (apply (lambda (t label sym val)
                                             (when label (set-indirect-label! label sym)))
                                           x))
                                  ctdefs)
                        (build-sequence no-source
                          (list (ct-eval/residualize m esew
                                  (lambda ()
                                    (if (null? ctdefs)
                                        (chi-void)
                                        (build-sequence no-source
                                          (map (lambda (x)
                                                 (apply (lambda (t label sym val)
                                                          (build-cte-install sym
                                                            (if (eq? t 'define-syntax-form)
                                                                val
                                                                (build-data no-source
                                                                  (make-binding 'module
                                                                    (make-resolved-interface val sym))))))
                                                        x))
                                               ctdefs)))))
                                (ct-eval/residualize m esew
                                  (lambda ()
                                    (let ((n (if id (id-sym-name id) #f)))
                                      (let* ((token (generate-id n))
                                             (b (build-data no-source
                                                  (make-binding 'module
                                                    (make-resolved-interface exports token)))))
                                        (if n
                                            (build-cte-install
                                              (if (only-top-marked? id)
                                                  n
                                                  (let ((marks (wrap-marks (syntax-object-wrap id))))
                                                    (make-syntax-object n
                                                      (make-wrap marks
                                                        (list (make-ribcage (vector n)
                                                                (vector marks) (vector (generate-id n))))))))
                                              b)
                                            (let ((n (generate-id 'tmp)))
                                              (build-sequence no-source
                                                (list (build-cte-install n b)
                                                      (do-top-import n token)))))))))
                              ; Some systems complain when undefined variables are assigned.
                               (build-sequence no-source
                                 (map (lambda (v) (build-global-definition no-source v (chi-void))) svs))
                                (build-letrec no-source
                                  dvs
                                  des
                                  (build-sequence no-source
                                    (list 
                                      (if (null? svs)
                                          (chi-void)
                                          (build-sequence no-source
                                            (map (lambda (v e)
                                                   (build-module-definition no-source v e))
                                                 svs
                                                 ses)))
                                      (if (null? inits)
                                          (chi-void)
                                          (build-sequence no-source inits)))))
                                (chi-void))))
                      (let ((b (car bs)))
                        (case (module-binding-type b)
                          ((define-form)
                           (let ((var (gen-var (module-binding-id b))))
                             (extend-store! r
                               (get-indirect-label (module-binding-label b))
                               (make-binding 'lexical var))
                             (partition (cdr bs) (cons var dvs)
                               (cons (module-binding-val b) des))))
                          ((define-syntax-form module-form) (partition (cdr bs) dvs des))
                          (else (error 'sc-expand-internal "unexpected module binding type"))))))
                (let ((id (car fexports)) (fexports (cdr fexports)))
                  (define pluck-binding
                    (lambda (id bs succ fail)
                      (let loop ((bs bs) (new-bs '()))
                        (if (null? bs)
                            (fail)
                            (if (bound-id=? (module-binding-id (car bs)) id)
                                (succ (car bs) (smart-append (reverse new-bs) (cdr bs)))
                                (loop (cdr bs) (cons (car bs) new-bs)))))))
                  (pluck-binding id bs
                    (lambda (b bs)
                      (let ((t (module-binding-type b))
                            (label (module-binding-label b))
                            (imps (module-binding-imps b)))
                        (let ((fexports (append imps fexports))
                              (sym (generate-id (id-sym-name id))))
                          (case t
                            ((define-form)
                             (set-indirect-label! label sym)
                             (partition fexports bs (cons sym svs)
                               (cons (module-binding-val b) ses)
                               ctdefs))
                            ((define-syntax-form)
                             (partition fexports bs svs ses
                               (cons (list t label sym (module-binding-val b)) ctdefs)))
                            ((module-form)
                             (let ((exports (module-binding-val b)))
                               (partition (append (flatten-exports exports) fexports) bs
                                 svs ses
                                 (cons (list t label sym exports) ctdefs))))
                            (else (error 'sc-expand-internal "unexpected module binding type"))))))
                    (lambda () (partition fexports bs svs ses ctdefs)))))))))))

(define id-set-diff
  (lambda (exports defs)
    (cond
      ((null? exports) '())
      ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
      (else (cons (car exports) (id-set-diff (cdr exports) defs))))))

(define extend-store!
  (lambda (r label binding)
    (set-cdr! r (extend-env label binding (cdr r)))))

(define check-module-exports
  ; After processing the definitions of a module this is called to verify that the
  ; module has defined or imported each exported identifier.  Because ids in fexports are
  ; wrapped with the given ribcage, they will contain substitutions for anything defined
  ; or imported here.  These subsitutions can be used by do-import! and do-import-top! to
  ; provide access to reexported bindings, for example.
  (lambda (source-exp fexports ids)
    (define defined?
      (lambda (e ids)
        (ormap (lambda (x)
                 (if (interface? x)
                     (let ((token (interface-token x)))
                       (if token
                           (lookup-import-binding-name (id-sym-name e) token (wrap-marks (syntax-object-wrap e)))
                           (let ((v (interface-exports x)))
                             (let lp ((i (fx- (vector-length v) 1)))
                               (and (fx>= i 0)
                                    (or (bound-id=? e (vector-ref v i))
                                        (lp (fx- i 1))))))))
                     (bound-id=? e x)))
               ids)))
    (let loop ((fexports fexports) (missing '()))
      (if (null? fexports)
          (unless (null? missing) (syntax-error missing "missing definition for export(s)"))
          (let ((e (car fexports)) (fexports (cdr fexports)))
            (if (defined? e ids) 
                (loop fexports missing)
                (loop fexports (cons e missing))))))))

(define check-defined-ids
  (lambda (source-exp ls)
    (define b-i=?
      ; cope with fat-fingered top-level
      (lambda (x y)
        (if (symbol? x)
            (if (symbol? y)
                (eq? x y)
                (and (eq? x (id-sym-name y))
                     (same-marks? (wrap-marks (syntax-object-wrap y)) (wrap-marks top-wrap))))
            (if (symbol? y)
                (and (eq? y (id-sym-name x))
                     (same-marks? (wrap-marks (syntax-object-wrap x)) (wrap-marks top-wrap)))
                (bound-id=? x y)))))
    (define vfold
      (lambda (v p cls)
        (let ((len (vector-length v)))
          (let lp ((i 0) (cls cls))
            (if (fx= i len)
                cls
                (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
    (define conflicts
      (lambda (x y cls)
        (if (interface? x)
            (if (interface? y)
                (call-with-values
                  (lambda ()
                    (let ((xe (interface-exports x)) (ye (interface-exports y)))
                      (if (fx> (vector-length xe) (vector-length ye))
                          (values x ye)
                          (values y xe))))
                  (lambda (iface exports)
                    (vfold exports (lambda (id cls) (id-iface-conflicts id iface cls)) cls)))
                (id-iface-conflicts y x cls))
            (if (interface? y)
                (id-iface-conflicts x y cls)
                (if (b-i=? x y) (cons x cls) cls)))))
     (define id-iface-conflicts
       (lambda (id iface cls)
         (let ((token (interface-token iface)))
           (if token
               (if (lookup-import-binding-name (id-sym-name id) token
                     (if (symbol? id)
                         (wrap-marks top-wrap)
                         (wrap-marks (syntax-object-wrap id))))
                   (cons id cls)
                   cls)
               (vfold (interface-exports iface)
                      (lambda (*id cls) (if (b-i=? *id id) (cons *id cls) cls))
                      cls)))))
     (unless (null? ls)
       (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
         (if (null? ls)
             (unless (null? cls)
               (let ((cls (syntax-object->datum cls)))
                 (syntax-error source-exp "duplicate definition for "
                  (symbol->string (car cls))
                   " in")))
             (let lp2 ((ls2 ls) (cls cls))
               (if (null? ls2)
                   (lp (car ls) (cdr ls) cls)
                   (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))

(define chi-external
  (lambda (ribcage source-exp body r exports fexports m esew k)
    (define return
      (lambda (bindings ids inits)
        (check-defined-ids source-exp ids)
        (check-module-exports source-exp fexports ids)
        (k bindings inits)))
    (define get-implicit-exports
      (lambda (id)
        (let f ((exports exports))
          (if (null? exports)
              '()
              (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
                  (flatten-exports (cdar exports))
                  (f (cdr exports)))))))
    (define update-imp-exports
      (lambda (bindings exports)
        (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
          (map (lambda (b)
                 (let ((id (module-binding-id b)))
                   (if (not (bound-id-member? id exports))
                       b
                       (make-module-binding
                         (module-binding-type b)
                         id
                         (module-binding-label b)
                         (append (get-implicit-exports id) (module-binding-imps b))
                         (module-binding-val b)))))
               bindings))))
    (let parse ((body body) (ids '()) (bindings '()) (inits '()))
      (if (null? body)
          (return bindings ids inits)
          (let ((e (cdar body)) (er (caar body)))
            (call-with-values
              (lambda () (syntax-type e er empty-wrap no-source ribcage))
              (lambda (type value e w s)
                (case type
                  ((define-form)
                   (parse-define e w s
                     (lambda (id rhs w)
                       (let* ((id (wrap id w))
                              (label (gen-indirect-label))
                              (imps (get-implicit-exports id)))
                         (extend-ribcage! ribcage id label)
                         (parse
                           (cdr body)
                           (cons id ids)
                           (cons (make-module-binding type id label
                                   imps (cons er (wrap rhs w)))
                                 bindings)
                           inits)))))
                  ((define-syntax-form)
                   (parse-define-syntax e w s
                     (lambda (id rhs w)
                       (let* ((id (wrap id w))
                              (label (gen-indirect-label))
                              (imps (get-implicit-exports id))
                              (exp (chi rhs (transformer-env er) w)))
                         ; arrange to evaluate the transformer lazily
                         (extend-store! r (get-indirect-label label) (cons 'deferred exp))
                         (extend-ribcage! ribcage id label)
                         (parse
                           (cdr body)
                           (cons id ids)
                           (cons (make-module-binding type id label imps exp)
                                 bindings)
                           inits)))))
                  ((module-form)
                   (let* ((*ribcage (make-empty-ribcage))
                          (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
                     (parse-module e w s *w
                       (lambda (id *exports forms)
                         (chi-external *ribcage (source-wrap e w s)
                                     (map (lambda (d) (cons er d)) forms)
                                     r *exports (flatten-exports *exports) m esew
                           (lambda (*bindings *inits)
                             (let* ((iface (make-trimmed-interface *exports))
                                    (bindings (append (if id *bindings (update-imp-exports *bindings *exports)) bindings))
                                    (inits (append inits *inits)))
                               (if id
                                   (let ((label (gen-indirect-label))
                                         (imps (get-implicit-exports id)))
                                     (extend-store! r (get-indirect-label label)
                                       (make-binding 'module iface))
                                     (extend-ribcage! ribcage id label)
                                     (parse
                                       (cdr body)
                                       (cons id ids)
                                       (cons (make-module-binding type id label imps *exports) bindings)
                                       inits))
                                   (let ()
                                     (do-import! iface ribcage)
                                     (parse (cdr body) (cons iface ids) bindings inits))))))))))
                 ((import-form)
                  (parse-import e w s
                    (lambda (mid)
                      (let ((mlabel (id-var-name mid empty-wrap)))
                        (let ((binding (lookup mlabel r)))
                          (case (binding-type binding)
                            ((module)
                             (let ((iface (binding-value binding)))
                               (when value (extend-ribcage-barrier! ribcage value))
                               (do-import! iface ribcage)
                               (parse
                                 (cdr body)
                                 (cons iface ids)
                                 (update-imp-exports bindings (vector->list (interface-exports iface)))
                                 inits)))
                            ((displaced-lexical) (displaced-lexical-error mid))
                            (else (syntax-error mid "import from unknown module"))))))))
                  ((begin-form)
                   (syntax-case e ()
                     ((_ e1 ...)
                      (parse (let f ((forms (syntax (e1 ...))))
                               (if (null? forms)
                                   (cdr body)
                                   (cons (cons er (wrap (car forms) w))
                                         (f (cdr forms)))))
                        ids bindings inits))))
                  ((local-syntax-form)
                   (chi-local-syntax value e er w s
                     (lambda (forms er w s)
                       (parse (let f ((forms forms))
                                (if (null? forms)
                                    (cdr body)
                                    (cons (cons er (wrap (car forms) w))
                                          (f (cdr forms)))))
                         ids bindings inits))))
                  (else ; found an init expression
                   (return bindings ids
                     (append inits (cons (cons er (source-wrap e w s)) (cdr body)))))))))))))

(define vmap
  (lambda (fn v)
    (do ((i (fx- (vector-length v) 1) (fx- i 1))
         (ls '() (cons (fn (vector-ref v i)) ls)))
        ((fx< i 0) ls))))

(define vfor-each
  (lambda (fn v)
    (let ((len (vector-length v)))
      (do ((i 0 (fx+ i 1)))
          ((fx= i len))
        (fn (vector-ref v i))))))

(define do-top-import
  (lambda (mid token)
    (build-cte-install mid
      (build-data no-source
        (make-binding 'do-import token)))))

(define ct-eval/residualize
  (lambda (m esew thunk)
    (case m
      ((c) (if (memq 'compile esew)
               (let ((e (thunk)))
                 (top-level-eval-hook e)
                 (if (memq 'load esew) e (chi-void)))
               (if (memq 'load esew) (thunk) (chi-void))))
      ((c&e) (let ((e (thunk))) (top-level-eval-hook e) e))
      (else (if (memq 'eval esew) (top-level-eval-hook (thunk))) (chi-void)))))

(define chi
  (lambda (e r w)
    (call-with-values
      (lambda () (syntax-type e r w no-source #f))
      (lambda (type value e w s)
        (chi-expr type value e r w s)))))

(define chi-expr
  (lambda (type value e r w s)
    (case type
      ((lexical)
       (build-lexical-reference 'value s value))
      ((core) (value e r w s))
      ((lexical-call)
       (chi-application
         (build-lexical-reference 'fun (source-annotation (car e)) value)
         e r w s))
      ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
      ((global) (build-global-reference s value))
      ((call) (chi-application (chi (car e) r w) e r w s))
      ((begin-form)
       (syntax-case e ()
         ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
      ((local-syntax-form)
       (chi-local-syntax value e r w s chi-sequence))
      ((eval-when-form)
       (syntax-case e ()
         ((_ (x ...) e1 e2 ...)
          (let ((when-list (chi-when-list e (syntax (x ...)) w)))
            (if (memq 'eval when-list)
                (chi-sequence (syntax (e1 e2 ...)) r w s)
                (chi-void))))))
      ((define-form define-syntax-form module-form import-form)
       (syntax-error (source-wrap e w s) "invalid context for definition"))
      ((syntax)
       (syntax-error (source-wrap e w s)
         "reference to pattern variable outside syntax form"))
      ((displaced-lexical) (displaced-lexical-error (source-wrap e w s)))
      (else (syntax-error (source-wrap e w s))))))

(define chi-application
  (lambda (x e r w s)
    (syntax-case e ()
      ((e0 e1 ...)
       (build-application s x
         (map (lambda (e) (chi e r w)) (syntax (e1 ...)))))
      (_ (syntax-error (source-wrap e w s))))))

(define chi-set!
  (lambda (e r w s rib)
    (syntax-case e ()
      ((_ id val)
       (id? (syntax id))
       (let ((n (id-var-name (syntax id) w)))
         (let ((b (lookup n r)))
           (case (binding-type b)
             ((macro!)
              (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
                (syntax-type (chi-macro (binding-value b)
                               `(,(syntax set!) ,id ,val)
                               r empty-wrap s rib) r empty-wrap s rib)))
             (else
              (values 'core
                (lambda (e r w s)
                 ; repeat lookup in case we were first expression (init) in
                 ; module or lambda body.  we repeat id-var-name as well,
                 ; although this is only necessary if we allow inits to
                 ; preced definitions
                  (let ((val (chi (syntax val) r w))
                        (n (id-var-name (syntax id) w)))
                    (let ((b (lookup n r)))
                      (case (binding-type b)
                        ((lexical) (build-lexical-assignment s (binding-value b) val))
                        ((global) (build-global-assignment s (binding-value b) val))
                        ((displaced-lexical)
                         (syntax-error (wrap (syntax id) w) "identifier out of context"))
                        (else (syntax-error (source-wrap e w s)))))))
                e w s))))))
      (_ (syntax-error (source-wrap e w s))))))

(define chi-macro
  (lambda (p e r w s rib)
    (define rebuild-macro-output
      (lambda (x m)
        (cond ((pair? x)
               (cons (rebuild-macro-output (car x) m)
                     (rebuild-macro-output (cdr x) m)))
              ((syntax-object? x)
               (let ((w (syntax-object-wrap x)))
                 (let ((ms (wrap-marks w)) (s (wrap-subst w)))
                   (make-syntax-object (syntax-object-expression x)
                     (if (and (pair? ms) (eq? (car ms) the-anti-mark))
                         (make-wrap (cdr ms)
                           (if rib (cons rib (cdr s)) (cdr s)))
                         (make-wrap (cons m ms)
                           (if rib
                               (cons rib (cons 'shift s))
                               (cons 'shift s))))))))
              ((vector? x)
               (let* ((n (vector-length x)) (v (make-vector n)))
                 (do ((i 0 (fx+ i 1)))
                     ((fx= i n) v)
                     (vector-set! v i
                       (rebuild-macro-output (vector-ref x i) m)))))
              ((symbol? x)
               (syntax-error (source-wrap e w s)
                 "encountered raw symbol "
                 (format "~s" x)
                 " in output of macro"))
              (else x))))
    (rebuild-macro-output
      (let ((out (p (source-wrap e (anti-mark w) s))))
        (if (procedure? out)
            (out (lambda (id)
                   (unless (identifier? id)
                     (syntax-error id
                       "environment argument is not an identifier"))
                   (lookup (id-var-name id empty-wrap) r)))
            out))
      (new-mark))))

(define chi-body
  ;; Here we create the empty wrap and new environment with placeholder
  ;; as required by chi-internal.  On return we extend the environment
  ;; to recognize the var-labels as lexical variables and build a letrec
  ;; binding them to the var-vals which we expand here.
  (lambda (body outer-form r w)
    (let* ((r (cons '("placeholder" . (placeholder)) r))
           (ribcage (make-empty-ribcage))
           (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
           (body (map (lambda (x) (cons r (wrap x w))) body)))
      (chi-internal ribcage outer-form body r
        (lambda (exprs ids vars vals inits)
          (when (null? exprs) (syntax-error outer-form "no expressions in body"))
          (build-letrec no-source
            vars
            (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) vals)
            (build-sequence no-source
              (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) (append inits exprs)))))))))

(define chi-internal
  ;; In processing the forms of the body, we create a new, empty wrap.
  ;; This wrap is augmented (destructively) each time we discover that
  ;; the next form is a definition.  This is done:
  ;;
  ;;   (1) to allow the first nondefinition form to be a call to
  ;;       one of the defined ids even if the id previously denoted a
  ;;       definition keyword or keyword for a macro expanding into a
  ;;       definition;
  ;;   (2) to prevent subsequent definition forms (but unfortunately
  ;;       not earlier ones) and the first nondefinition form from
  ;;       confusing one of the bound identifiers for an auxiliary
  ;;       keyword; and
  ;;   (3) so that we do not need to restart the expansion of the
  ;;       first nondefinition form, which is problematic anyway
  ;;       since it might be the first element of a begin that we
  ;;       have just spliced into the body (meaning if we restarted,
  ;;       we'd really need to restart with the begin or the macro
  ;;       call that expanded into the begin, and we'd have to give
  ;;       up allowing (begin <defn>+ <expr>+), which is itself
  ;;       problematic since we don't know if a begin contains only
  ;;       definitions until we've expanded it).
  ;;
  ;; Before processing the body, we also create a new environment
  ;; containing a placeholder for the bindings we will add later and
  ;; associate this environment with each form.  In processing a
  ;; let-syntax or letrec-syntax, the associated environment may be
  ;; augmented with local keyword bindings, so the environment may
  ;; be different for different forms in the body.  Once we have
  ;; gathered up all of the definitions, we evaluate the transformer
  ;; expressions and splice into r at the placeholder the new variable
  ;; and keyword bindings.  This allows let-syntax or letrec-syntax
  ;; forms local to a portion or all of the body to shadow the
  ;; definition bindings.
  ;;
  ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
  ;; into the body.
  ;;
  ;; outer-form is fully wrapped w/source
  (lambda (ribcage source-exp body r k)
    (define return
      (lambda (exprs ids vars vals inits)
        (check-defined-ids source-exp ids)
        (k exprs ids vars vals inits)))
    (let parse ((body body) (ids '()) (vars '()) (vals '()) (inits '()))
      (if (null? body)
          (return body ids vars vals inits)
          (let ((e (cdar body)) (er (caar body)))
            (call-with-values
              (lambda () (syntax-type e er empty-wrap no-source ribcage))
              (lambda (type value e w s)
                (case type
                  ((define-form)
                   (parse-define e w s
                     (lambda (id rhs w)
                       (let ((id (wrap id w)) (label (gen-label)))
                         (let ((var (gen-var id)))
                           (extend-ribcage! ribcage id label)
                           (extend-store! r label (make-binding 'lexical var))
                           (parse
                             (cdr body)
                             (cons id ids)
                             (cons var vars)
                             (cons (cons er (wrap rhs w)) vals)
                             inits))))))
                  ((define-syntax-form)
                   (parse-define-syntax e w s
                     (lambda (id rhs w)
                       (let ((id (wrap id w))
                             (label (gen-label))
                             (exp (chi rhs (transformer-env er) w)))
                         (extend-ribcage! ribcage id label)
                         (extend-store! r label (make-binding 'deferred exp))
                         (parse (cdr body) (cons id ids) vars vals inits)))))
                  ((module-form)
                   (let* ((*ribcage (make-empty-ribcage))
                          (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
                     (parse-module e w s *w
                       (lambda (id exports forms)
                         (chi-internal *ribcage (source-wrap e w s)
                           (map (lambda (d) (cons er d)) forms) r
                           (lambda (*body *ids *vars *vals *inits)
                             ; valid bound ids checked already by chi-internal
                             (check-module-exports source-exp (flatten-exports exports) *ids)
                             (let ((iface (make-trimmed-interface exports))
                                   (vars (append *vars vars))
                                   (vals (append *vals vals))
                                   (inits (append inits *inits *body)))
                               (if id
                                   (let ((label (gen-label)))
                                     (extend-ribcage! ribcage id label)
                                     (extend-store! r label (make-binding 'module iface))
                                     (parse (cdr body) (cons id ids) vars vals inits))
                                   (let ()
                                     (do-import! iface ribcage)
                                     (parse (cdr body) (cons iface ids) vars vals inits))))))))))
                 ((import-form)
                  (parse-import e w s
                    (lambda (mid)
                      (let ((mlabel (id-var-name mid empty-wrap)))
                        (let ((binding (lookup mlabel r)))
                          (case (car binding)
                            ((module)
                             (let ((iface (cdr binding)))
                               (when value (extend-ribcage-barrier! ribcage value))
                               (do-import! iface ribcage)
                               (parse (cdr body) (cons iface ids) vars vals inits)))
                            ((displaced-lexical) (displaced-lexical-error mid))
                            (else (syntax-error mid "import from unknown module"))))))))
                  ((begin-form)
                   (syntax-case e ()
                     ((_ e1 ...)
                      (parse (let f ((forms (syntax (e1 ...))))
                               (if (null? forms)
                                   (cdr body)
                                   (cons (cons er (wrap (car forms) w))
                                         (f (cdr forms)))))
                        ids vars vals inits))))
                  ((local-syntax-form)
                   (chi-local-syntax value e er w s
                     (lambda (forms er w s)
                       (parse (let f ((forms forms))
                                (if (null? forms)
                                    (cdr body)
                                    (cons (cons er (wrap (car forms) w))
                                          (f (cdr forms)))))
                         ids vars vals inits))))
                  (else ; found a non-definition
                   (return (cons (cons er (source-wrap e w s)) (cdr body))
                           ids vars vals inits))))))))))

(define do-import!
  (lambda (interface ribcage)
    (let ((token (interface-token interface)))
      (if token
          (extend-ribcage-subst! ribcage token)
          (vfor-each
            (lambda (id)
              (let ((label1 (id-var-name-loc id empty-wrap)))
                (unless label1
                  (syntax-error id "exported identifier not visible"))
                (extend-ribcage! ribcage id label1)))
            (interface-exports interface))))))

(define parse-module
  (lambda (e w s *w k)
    (define listify
      (lambda (exports)
        (if (null? exports)
            '()
            (cons (syntax-case (car exports) ()
                    ((ex ...) (listify (syntax (ex ...))))
                    (x (if (id? (syntax x))
                           (wrap (syntax x) *w)
                           (syntax-error (source-wrap e w s)
                             "invalid exports list in"))))
                  (listify (cdr exports))))))
    (define return
      (lambda (id exports forms)
        (k id (listify exports) (map (lambda (x) (wrap x *w)) forms))))
    (syntax-case e ()
      ((_ (ex ...) form ...)
       (return #f (syntax (ex ...)) (syntax (form ...))))
      ((_ mid (ex ...) form ...)
       (id? (syntax mid))
      ; id receives old wrap so it won't be confused with id of same name
      ; defined within the module
       (return (wrap (syntax mid) w) (syntax (ex ...)) (syntax (form ...))))
      (_ (syntax-error (source-wrap e w s))))))

(define parse-import
  (lambda (e w s k)
    (syntax-case e ()
      ((_ mid)
       (id? (syntax mid))
       (k (wrap (syntax mid) w)))
      (_ (syntax-error (source-wrap e w s))))))

(define parse-define
  (lambda (e w s k)
    (syntax-case e ()
      ((_ name val)
       (id? (syntax name))
       (k (syntax name) (syntax val) w))
      ((_ (name . args) e1 e2 ...)
       (and (id? (syntax name))
            (valid-bound-ids? (lambda-var-list (syntax args))))
       (k (wrap (syntax name) w)
          (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
          empty-wrap))
      ((_ name)
       (id? (syntax name))
       (k (wrap (syntax name) w) (syntax (void)) empty-wrap))
      (_ (syntax-error (source-wrap e w s))))))

(define parse-define-syntax
  (lambda (e w s k)
    (syntax-case e ()
      ((_ name val)
       (id? (syntax name))
       (k (syntax name) (syntax val) w))
      (_ (syntax-error (source-wrap e w s))))))

(define chi-lambda-clause
  (lambda (e c r w k)
    (syntax-case c ()
      (((id ...) e1 e2 ...)
       (let ((ids (syntax (id ...))))
         (if (not (valid-bound-ids? ids))
             (syntax-error e "invalid parameter list in")
             (let ((labels (gen-labels ids))
                   (new-vars (map gen-var ids)))
               (k new-vars
                  (chi-body (syntax (e1 e2 ...))
                            e
                            (extend-var-env* labels new-vars r)
                            (make-binding-wrap ids labels w)))))))
      ((ids e1 e2 ...)
       (let ((old-ids (lambda-var-list (syntax ids))))
         (if (not (valid-bound-ids? old-ids))
             (syntax-error e "invalid parameter list in")
             (let ((labels (gen-labels old-ids))
                   (new-vars (map gen-var old-ids)))
               (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
                    (if (null? ls1)
                        ls2
                        (f (cdr ls1) (cons (car ls1) ls2))))
                  (chi-body (syntax (e1 e2 ...))
                            e
                            (extend-var-env* labels new-vars r)
                            (make-binding-wrap old-ids labels w)))))))
      (_ (syntax-error e)))))

(define chi-local-syntax
  (lambda (rec? e r w s k)
    (syntax-case e ()
      ((_ ((id val) ...) e1 e2 ...)
       (let ((ids (syntax (id ...))))
         (if (not (valid-bound-ids? ids))
             (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
               (source-wrap e w s)
               "keyword")
             (let ((labels (gen-labels ids)))
               (let ((new-w (make-binding-wrap ids labels w)))
                 (k (syntax (e1 e2 ...))
                    (extend-env*
                      labels
                      (let ((w (if rec? new-w w))
                            (trans-r (transformer-env r)))
                        (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
                      r)
                    new-w
                    s))))))
      (_ (syntax-error (source-wrap e w s))))))

(define chi-void
  (lambda ()
    (build-application no-source (build-primref no-source 'void) '())))

(define ellipsis?
  (lambda (x)
    (and (nonsymbol-id? x)
         (literal-id=? x (syntax (... ...))))))

;;; data

;;; strips all annotations from potentially circular reader output

(define strip-annotation
  (lambda (x parent)
    (cond
      ((pair? x)
       (let ((new (cons #f #f)))
         (when parent (set-annotation-stripped! parent new))
         (set-car! new (strip-annotation (car x) #f))
         (set-cdr! new (strip-annotation (cdr x) #f))
         new))
      ((annotation? x)
       (or (annotation-stripped x)
           (strip-annotation (annotation-expression x) x)))
      ((vector? x)
       (let ((new (make-vector (vector-length x))))
         (when parent (set-annotation-stripped! parent new))
         (let loop ((i (- (vector-length x) 1)))
           (unless (fx< i 0)
             (vector-set! new i (strip-annotation (vector-ref x i) #f))
             (loop (fx- i 1))))
         new))
      (else x))))

;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
;;; on an annotation, strips the annotation as well.
;;; since only the head of a list is annotated by the reader, not each pair
;;; in the spine, we also check for pairs whose cars are annotated in case
;;; we've been passed the cdr of an annotated list

(define strip*
  (lambda (x w fn)
    (if (top-marked? w)
        (fn x)
        (let f ((x x))
          (cond
            ((syntax-object? x)
             (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
            ((pair? x)
             (let ((a (f (car x))) (d (f (cdr x))))
               (if (and (eq? a (car x)) (eq? d (cdr x)))
                   x
                   (cons a d))))
            ((vector? x)
             (let ((old (vector->list x)))
                (let ((new (map f old)))
                   (if (andmap eq? old new) x (list->vector new)))))
            (else x))))))

(define strip
  (lambda (x w)
    (strip* x w
      (lambda (x)
        (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
            (strip-annotation x #f)
            x)))))

;;; lexical variables

(define gen-var
  (lambda (id)
    (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
      (if (annotation? id)
          (build-lexical-var (annotation-source id) (annotation-expression id))
          (build-lexical-var no-source id)))))

(define lambda-var-list
  (lambda (vars)
    (let lvl ((vars vars) (ls '()) (w empty-wrap))
       (cond
         ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
         ((id? vars) (cons (wrap vars w) ls))
         ((null? vars) ls)
         ((syntax-object? vars)
          (lvl (syntax-object-expression vars)
               ls
               (join-wraps w (syntax-object-wrap vars))))
         ((annotation? vars)
          (lvl (annotation-expression vars) ls w))
       ; include anything else to be caught by subsequent error
       ; checking
         (else (cons vars ls))))))


; must precede global-extends

(set! $sc-put-cte
  (lambda (id b)
    (define put-token
      (lambda (id token)
        (define cons-id
          (lambda (id x)
            (if (not x) id (cons id x))))
        (define weed
          (lambda (id x)
            (if (pair? x)
                (if (bound-id=? (car x) id) ; could just check same-marks
                    (weed id (cdr x))
                    (cons-id (car x) (weed id (cdr x))))
                (if (or (not x) (bound-id=? x id))
                    #f
                    x))))
        (let ((sym (id-sym-name id)))
          (let ((x (weed id (getprop sym token))))
            (if (and (not x) (symbol? id))
               ; don't pollute property list when all we have is a plain
               ; top-level binding, since that's what's assumed anyway
                (remprop sym token)
                (putprop sym token (cons-id id x)))))))
    (define sc-put-module
      (lambda (exports token)
        (vfor-each
          (lambda (id) (put-token id token))
          exports)))
    (define (put-cte id binding)
     ;; making assumption here that all macros should be visible to the user and that system
     ;; globals don't come through here (primvars.ss sets up their properties)
      (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
        (putprop sym '*sc-expander* binding)))
    (let ((binding (or (sanitize-binding b) (error 'define-syntax "invalid transformer ~s" b))))
      (case (binding-type binding)
        ((module)
         (let ((iface (binding-value binding)))
           (sc-put-module (interface-exports iface) (interface-token iface)))
         (put-cte id binding))
        ((do-import) ; fake binding: id is module id, binding-value is import token
         (let ((token (binding-value b)))
           (let ((b (lookup (id-var-name id empty-wrap) null-env)))
             (case (binding-type b)
               ((module)
                (let ((iface (binding-value b)))
                  (unless (eq? (interface-token iface) token)
                    (syntax-error id "import mismatch for module"))
                  (sc-put-module (interface-exports iface) '*top*)))
               (else (syntax-error id "import from unknown module"))))))
        (else (put-cte id binding))))))


;;; core transformers

(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)


(global-extend 'core 'fluid-let-syntax
  (lambda (e r w s)
    (syntax-case e ()
      ((_ ((var val) ...) e1 e2 ...)
       (valid-bound-ids? (syntax (var ...)))
       (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
         (for-each
           (lambda (id n)
             (case (binding-type (lookup n r))
               ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
           (syntax (var ...))
           names)
         (chi-body
           (syntax (e1 e2 ...))
           (source-wrap e w s)
           (extend-env*
             names
             (let ((trans-r (transformer-env r)))
               (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
             r)
           w)))
      (_ (syntax-error (source-wrap e w s))))))

(global-extend 'core 'quote
   (lambda (e r w s)
      (syntax-case e ()
         ((_ e) (build-data s (strip (syntax e) w)))
         (_ (syntax-error (source-wrap e w s))))))

(global-extend 'core 'syntax
  (let ()
    (define gen-syntax
      (lambda (src e r maps ellipsis?)
        (if (id? e)
            (let ((label (id-var-name e empty-wrap)))
              (let ((b (lookup label r)))
                (if (eq? (binding-type b) 'syntax)
                    (call-with-values
                      (lambda ()
                        (let ((var.lev (binding-value b)))
                          (gen-ref src (car var.lev) (cdr var.lev) maps)))
                      (lambda (var maps) (values `(ref ,var) maps)))
                    (if (ellipsis? e)
                        (syntax-error src "misplaced ellipsis in syntax form")
                        (values `(quote ,e) maps)))))
            (syntax-case e ()
              ((dots e)
               (ellipsis? (syntax dots))
               (gen-syntax src (syntax e) r maps (lambda (x) #f)))
              ((x dots . y)
               ; this could be about a dozen lines of code, except that we
               ; choose to handle (syntax (x ... ...)) forms
               (ellipsis? (syntax dots))
               (let f ((y (syntax y))
                       (k (lambda (maps)
                            (call-with-values
                              (lambda ()
                                (gen-syntax src (syntax x) r
                                  (cons '() maps) ellipsis?))
                              (lambda (x maps)
                                (if (null? (car maps))
                                    (syntax-error src
                                      "extra ellipsis in syntax form")
                                    (values (gen-map x (car maps))
                                            (cdr maps))))))))
                 (syntax-case y ()
                   ((dots . y)
                    (ellipsis? (syntax dots))
                    (f (syntax y)
                       (lambda (maps)
                         (call-with-values
                           (lambda () (k (cons '() maps)))
                           (lambda (x maps)
                             (if (null? (car maps))
                                 (syntax-error src
                                   "extra ellipsis in syntax form")
                                 (values (gen-mappend x (car maps))
                                         (cdr maps))))))))
                   (_ (call-with-values
                        (lambda () (gen-syntax src y r maps ellipsis?))
                        (lambda (y maps)
                          (call-with-values
                            (lambda () (k maps))
                            (lambda (x maps)
                              (values (gen-append x y) maps)))))))))
              ((x . y)
               (call-with-values
                 (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
                 (lambda (x maps)
                   (call-with-values
                     (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
                     (lambda (y maps) (values (gen-cons x y) maps))))))
              (#(e1 e2 ...)
               (call-with-values
                 (lambda ()
                   (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
                 (lambda (e maps) (values (gen-vector e) maps))))
              (_ (values `(quote ,e) maps))))))

    (define gen-ref
      (lambda (src var level maps)
        (if (fx= level 0)
            (values var maps)
            (if (null? maps)
                (syntax-error src "missing ellipsis in syntax form")
                (call-with-values
                  (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
                  (lambda (outer-var outer-maps)
                    (let ((b (assq outer-var (car maps))))
                      (if b
                          (values (cdr b) maps)
                          (let ((inner-var (gen-var 'tmp)))
                            (values inner-var
                                    (cons (cons (cons outer-var inner-var)
                                                (car maps))
                                          outer-maps)))))))))))

    (define gen-mappend
      (lambda (e map-env)
        `(apply (primitive append) ,(gen-map e map-env))))

    (define gen-map
      (lambda (e map-env)
        (let ((formals (map cdr map-env))
              (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
          (cond
            ((eq? (car e) 'ref)
             ; identity map equivalence:
             ; (map (lambda (x) x) y) == y
             (car actuals))
            ((andmap
                (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
                (cdr e))
             ; eta map equivalence:
             ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
             `(map (primitive ,(car e))
                   ,@(map (let ((r (map cons formals actuals)))
                            (lambda (x) (cdr (assq (cadr x) r))))
                          (cdr e))))
            (else `(map (lambda ,formals ,e) ,@actuals))))))

    (define gen-cons
      (lambda (x y)
        (case (car y)
          ((quote)
           (if (eq? (car x) 'quote)
               `(quote (,(cadr x) . ,(cadr y)))
               (if (eq? (cadr y) '())
                   `(list ,x)
                   `(cons ,x ,y))))
          ((list) `(list ,x ,@(cdr y)))
          (else `(cons ,x ,y)))))

    (define gen-append
      (lambda (x y)
        (if (equal? y '(quote ()))
            x
            `(append ,x ,y))))

    (define gen-vector
      (lambda (x)
        (cond
          ((eq? (car x) 'list) `(vector ,@(cdr x)))
          ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
          (else `(list->vector ,x)))))


    (define regen
      (lambda (x)
        (case (car x)
          ((ref) (build-lexical-reference 'value no-source (cadr x)))
          ((primitive) (build-primref no-source (cadr x)))
          ((quote) (build-data no-source (cadr x)))
          ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
          ((map) (let ((ls (map regen (cdr x))))
                   (build-application no-source
                     (if (fx= (length ls) 2)
                         (build-primref no-source 'map)
                        ; really need to do our own checking here
                         (build-primref no-source 2 'map)) ; require error check
                     ls)))
          (else (build-application no-source
                  (build-primref no-source (car x))
                  (map regen (cdr x)))))))

    (lambda (e r w s)
      (let ((e (source-wrap e w s)))
        (syntax-case e ()
          ((_ x)
           (call-with-values
             (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
             (lambda (e maps) (regen e))))
          (_ (syntax-error e)))))))


(global-extend 'core 'lambda
   (lambda (e r w s)
      (syntax-case e ()
         ((_ . c)
          (chi-lambda-clause (source-wrap e w s) (syntax c) r w
            (lambda (vars body) (build-lambda s vars body)))))))


(global-extend 'core 'letrec
  (lambda (e r w s)
    (syntax-case e ()
      ((_ ((id val) ...) e1 e2 ...)
       (let ((ids (syntax (id ...))))
         (if (not (valid-bound-ids? ids))
             (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
               (source-wrap e w s) "bound variable")
             (let ((labels (gen-labels ids))
                   (new-vars (map gen-var ids)))
               (let ((w (make-binding-wrap ids labels w))
                    (r (extend-var-env* labels new-vars r)))
                 (build-letrec s
                   new-vars
                   (map (lambda (x) (chi x r w)) (syntax (val ...)))
                   (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
      (_ (syntax-error (source-wrap e w s))))))

(global-extend 'core 'if
   (lambda (e r w s)
      (syntax-case e ()
         ((_ test then)
          (build-conditional s
             (chi (syntax test) r w)
             (chi (syntax then) r w)
             (chi-void)))
         ((_ test then else)
          (build-conditional s
             (chi (syntax test) r w)
             (chi (syntax then) r w)
             (chi (syntax else) r w)))
         (_ (syntax-error (source-wrap e w s))))))



(global-extend 'set! 'set! '())

(global-extend 'begin 'begin '())

(global-extend 'module-key 'module '())
(global-extend 'import 'import #f)
(global-extend 'import 'import-only #t)

(global-extend 'define 'define '())

(global-extend 'define-syntax 'define-syntax '())

(global-extend 'eval-when 'eval-when '())

(global-extend 'core 'syntax-case
  (let ()
    (define convert-pattern
      ; accepts pattern & keys
      ; returns syntax-dispatch pattern & ids
      (lambda (pattern keys)
        (let cvt ((p pattern) (n 0) (ids '()))
          (if (id? p)
              (if (bound-id-member? p keys)
                  (values (vector 'free-id p) ids)
                  (values 'any (cons (cons p n) ids)))
              (syntax-case p ()
                ((x dots)
                 (ellipsis? (syntax dots))
                 (call-with-values
                   (lambda () (cvt (syntax x) (fx+ n 1) ids))
                   (lambda (p ids)
                     (values (if (eq? p 'any) 'each-any (vector 'each p))
                             ids))))
                ((x . y)
                 (call-with-values
                   (lambda () (cvt (syntax y) n ids))
                   (lambda (y ids)
                     (call-with-values
                       (lambda () (cvt (syntax x) n ids))
                       (lambda (x ids)
                         (values (cons x y) ids))))))
                (() (values '() ids))
                (#(x ...)
                 (call-with-values
                   (lambda () (cvt (syntax (x ...)) n ids))
                   (lambda (p ids) (values (vector 'vector p) ids))))
                (x (values (vector 'atom (strip p empty-wrap)) ids)))))))

    (define build-dispatch-call
      (lambda (pvars exp y r)
        (let ((ids (map car pvars)) (levels (map cdr pvars)))
          (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
            (build-application no-source
              (build-primref no-source 'apply)
              (list (build-lambda no-source new-vars
                      (chi exp
                         (extend-env*
                             labels
                             (map (lambda (var level)
                                    (make-binding 'syntax `(,var . ,level)))
                                  new-vars
                                  (map cdr pvars))
                             r)
                           (make-binding-wrap ids labels empty-wrap)))
                    y))))))

    (define gen-clause
      (lambda (x keys clauses r pat fender exp)
        (call-with-values
          (lambda () (convert-pattern pat keys))
          (lambda (p pvars)
            (cond
              ((not (distinct-bound-ids? (map car pvars)))
               (invalid-ids-error (map car pvars) pat "pattern variable"))
              ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
               (syntax-error pat
                 "misplaced ellipsis in syntax-case pattern"))
              (else
               (let ((y (gen-var 'tmp)))
                 ; fat finger binding and references to temp variable y
                 (build-application no-source
                   (build-lambda no-source (list y)
                     (let-syntax ((y (identifier-syntax
                                       (build-lexical-reference 'value no-source y))))
                       (build-conditional no-source
                         (syntax-case fender ()
                           (#t y)
                           (_ (build-conditional no-source
                                y
                                (build-dispatch-call pvars fender y r)
                                (build-data no-source #f))))
                         (build-dispatch-call pvars exp y r)
                         (gen-syntax-case x keys clauses r))))
                   (list (if (eq? p 'any)
                             (build-application no-source
                               (build-primref no-source 'list)
                               (list (build-lexical-reference no-source 'value x)))
                             (build-application no-source
                               (build-primref no-source '$syntax-dispatch)
                               (list (build-lexical-reference no-source 'value x)
                                     (build-data no-source p)))))))))))))

    (define gen-syntax-case
      (lambda (x keys clauses r)
        (if (null? clauses)
            (build-application no-source
              (build-primref no-source 'syntax-error)
              (list (build-lexical-reference 'value no-source x)))
            (syntax-case (car clauses) ()
              ((pat exp)
               (if (and (id? (syntax pat))
                        (not (bound-id-member? (syntax pat) keys))
                        (not (ellipsis? (syntax pat))))
                   (let ((label (gen-label))
                         (var (gen-var (syntax pat))))
                     (build-application no-source
                       (build-lambda no-source (list var)
                         (chi (syntax exp)
                              (extend-env label (make-binding 'syntax `(,var . 0)) r)
                              (make-binding-wrap (syntax (pat))
                                (list label) empty-wrap)))
                       (list (build-lexical-reference 'value no-source x))))
                   (gen-clause x keys (cdr clauses) r
                     (syntax pat) #t (syntax exp))))
              ((pat fender exp)
               (gen-clause x keys (cdr clauses) r
                 (syntax pat) (syntax fender) (syntax exp)))
              (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))

    (lambda (e r w s)
      (let ((e (source-wrap e w s)))
        (syntax-case e ()
          ((_ val (key ...) m ...)
           (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
                       (syntax (key ...)))
               (let ((x (gen-var 'tmp)))
                 ; fat finger binding and references to temp variable x
                 (build-application s
                   (build-lambda no-source (list x)
                     (gen-syntax-case x
                       (syntax (key ...)) (syntax (m ...))
                       r))
                   (list (chi (syntax val) r empty-wrap))))
               (syntax-error e "invalid literals list in"))))))))

;;; The portable sc-expand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders
;;; when") with '(eval).  In Chez Scheme, m is set to 'c instead of e
;;; if we are compiling a file, and esew is set to
;;; (eval-syntactic-expanders-when), which defaults to the list
;;; '(compile load eval).  This means that, by default, top-level
;;; syntactic definitions are evaluated immediately after they are
;;; expanded, and the expanded definitions are also residualized into
;;; the object file if we are compiling a file.
(set! sc-expand
  (let ((user-ribcage
         (let ((ribcage (make-empty-ribcage)))
           (extend-ribcage-subst! ribcage '*top*)
           ribcage)))
    (let ((user-top-wrap
           (make-wrap (wrap-marks top-wrap)
             (cons user-ribcage (wrap-subst top-wrap)))))
      (lambda (x)
        (let ((m 'e)
              (esew '(eval)))
          (if (and (pair? x) (equal? (car x) noexpand))
              (cadr x)
              (chi-top x null-env user-top-wrap m esew user-ribcage)))))))

(set! identifier?
  (lambda (x)
    (nonsymbol-id? x)))

(set! datum->syntax-object
  (lambda (id datum)
    (arg-check nonsymbol-id? id 'datum->syntax-object)
    (make-syntax-object datum (syntax-object-wrap id))))

(set! syntax-object->datum
  ; accepts any object, since syntax objects may consist partially
  ; or entirely of unwrapped, nonsymbolic data
  (lambda (x)
    (strip x empty-wrap)))

(set! generate-temporaries
  (lambda (ls)
    (arg-check list? ls 'generate-temporaries)
    (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))

(set! free-identifier=?
   (lambda (x y)
      (arg-check nonsymbol-id? x 'free-identifier=?)
      (arg-check nonsymbol-id? y 'free-identifier=?)
      (free-id=? x y)))

(set! bound-identifier=?
   (lambda (x y)
      (arg-check nonsymbol-id? x 'bound-identifier=?)
      (arg-check nonsymbol-id? y 'bound-identifier=?)
      (bound-id=? x y)))


(set! syntax-error
  (lambda (object . messages)
    (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
    (let ((message (if (null? messages)
                       "invalid syntax"
                       (apply string-append messages))))
      (error-hook #f message (strip object empty-wrap)))))

;;; syntax-dispatch expects an expression and a pattern.  If the expression
;;; matches the pattern a list of the matching expressions for each
;;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
;;; not work on r4rs implementations that violate the ieee requirement
;;; that #f and () be distinct.)

;;; The expression is matched with the pattern as follows:

;;; pattern:                           matches:
;;;   ()                                 empty list
;;;   any                                anything
;;;   (<pattern>1 . <pattern>2)          (<pattern>1 . <pattern>2)
;;;   each-any                           (any*)
;;;   #(free-id <key>)                   <key> with free-identifier=?
;;;   #(each <pattern>)                  (<pattern>*)
;;;   #(vector <pattern>)                (list->vector <pattern>)
;;;   #(atom <object>)                   <object> with "equal?"

;;; Vector cops out to pair under assumption that vectors are rare.  If
;;; not, should convert to:
;;;   #(vector <pattern>*)               #(<pattern>*)

(let ()

(define match-each
  (lambda (e p w)
    (cond
      ((annotation? e)
       (match-each (annotation-expression e) p w))
      ((pair? e)
       (let ((first (match (car e) p w '())))
         (and first
              (let ((rest (match-each (cdr e) p w)))
                 (and rest (cons first rest))))))
      ((null? e) '())
      ((syntax-object? e)
       (match-each (syntax-object-expression e)
                   p
                   (join-wraps w (syntax-object-wrap e))))
      (else #f))))

(define match-each-any
  (lambda (e w)
    (cond
      ((annotation? e)
       (match-each-any (annotation-expression e) w))
      ((pair? e)
       (let ((l (match-each-any (cdr e) w)))
         (and l (cons (wrap (car e) w) l))))
      ((null? e) '())
      ((syntax-object? e)
       (match-each-any (syntax-object-expression e)
                       (join-wraps w (syntax-object-wrap e))))
      (else #f))))

(define match-empty
  (lambda (p r)
    (cond
      ((null? p) r)
      ((eq? p 'any) (cons '() r))
      ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
      ((eq? p 'each-any) (cons '() r))
      (else
       (case (vector-ref p 0)
         ((each) (match-empty (vector-ref p 1) r))
         ((free-id atom) r)
         ((vector) (match-empty (vector-ref p 1) r)))))))

(define match*
  (lambda (e p w r)
    (cond
      ((null? p) (and (null? e) r))
      ((pair? p)
       (and (pair? e) (match (car e) (car p) w
                        (match (cdr e) (cdr p) w r))))
      ((eq? p 'each-any)
       (let ((l (match-each-any e w))) (and l (cons l r))))
      (else
       (case (vector-ref p 0)
         ((each)
          (if (null? e)
              (match-empty (vector-ref p 1) r)
              (let ((l (match-each e (vector-ref p 1) w)))
                (and l
                     (let collect ((l l))
                       (if (null? (car l))
                           r
                           (cons (map car l) (collect (map cdr l)))))))))
         ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
         ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
         ((vector)
          (and (vector? e)
               (match (vector->list e) (vector-ref p 1) w r))))))))

(define match
  (lambda (e p w r)
    (cond
      ((not r) #f)
      ((eq? p 'any) (cons (wrap e w) r))
      ((syntax-object? e)
       (match*
         (unannotate (syntax-object-expression e))
         p
         (join-wraps w (syntax-object-wrap e))
         r))
      (else (match* (unannotate e) p w r)))))

(set! $syntax-dispatch
  (lambda (e p)
    (cond
      ((eq? p 'any) (list e))
      ((syntax-object? e)
       (match* (unannotate (syntax-object-expression e))
         p (syntax-object-wrap e) '()))
      (else (match* (unannotate e) p empty-wrap '())))))
))


(define-syntax with-syntax
   (lambda (x)
      (syntax-case x ()
         ((_ () e1 e2 ...)
          (syntax (begin e1 e2 ...)))
         ((_ ((out in)) e1 e2 ...)
          (syntax (syntax-case in () (out (begin e1 e2 ...)))))
         ((_ ((out in) ...) e1 e2 ...)
          (syntax (syntax-case (list in ...) ()
                     ((out ...) (begin e1 e2 ...))))))))

(define-syntax syntax-rules
  (lambda (x)
    (syntax-case x ()
      ((_ (k ...) ((keyword . pattern) template) ...)
       (syntax (lambda (x)
                (syntax-case x (k ...)
                  ((dummy . pattern) (syntax template))
                  ...)))))))

(define-syntax or
   (lambda (x)
      (syntax-case x ()
         ((_) (syntax #f))
         ((_ e) (syntax e))
         ((_ e1 e2 e3 ...)
          (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))

(define-syntax and
   (lambda (x)
      (syntax-case x ()
         ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
         ((_ e) (syntax e))
         ((_) (syntax #t)))))

(define-syntax let
   (lambda (x)
      (syntax-case x ()
         ((_ ((x v) ...) e1 e2 ...)
          (andmap identifier? (syntax (x ...)))
          (syntax ((lambda (x ...) e1 e2 ...) v ...)))
         ((_ f ((x v) ...) e1 e2 ...)
          (andmap identifier? (syntax (f x ...)))
          (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
                    v ...))))))

(define-syntax let*
  (lambda (x)
    (syntax-case x ()
      ((let* ((x v) ...) e1 e2 ...)
       (andmap identifier? (syntax (x ...)))
       (let f ((bindings (syntax ((x v)  ...))))
         (if (null? bindings)
             (syntax (let () e1 e2 ...))
             (with-syntax ((body (f (cdr bindings)))
                           (binding (car bindings)))
               (syntax (let (binding) body)))))))))

(define-syntax cond
  (lambda (x)
    (syntax-case x ()
      ((_ m1 m2 ...)
       (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
         (if (null? clauses)
             (syntax-case clause (else =>)
               ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
               ((e0) (syntax (let ((t e0)) (if t t))))
               ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
               ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
               (_ (syntax-error x)))
             (with-syntax ((rest (f (car clauses) (cdr clauses))))
               (syntax-case clause (else =>)
                 ((e0) (syntax (let ((t e0)) (if t t rest))))
                 ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
                 ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
                 (_ (syntax-error x))))))))))

(define-syntax do
   (lambda (orig-x)
      (syntax-case orig-x ()
         ((_ ((var init . step) ...) (e0 e1 ...) c ...)
          (with-syntax (((step ...)
                         (map (lambda (v s)
                                 (syntax-case s ()
                                    (() v)
                                    ((e) (syntax e))
                                    (_ (syntax-error orig-x))))
                              (syntax (var ...))
                              (syntax (step ...)))))
             (syntax-case (syntax (e1 ...)) ()
                (() (syntax (let doloop ((var init) ...)
                               (if (not e0)
                                   (begin c ... (doloop step ...))))))
                ((e1 e2 ...)
                 (syntax (let doloop ((var init) ...)
                            (if e0
                                (begin e1 e2 ...)
                                (begin c ... (doloop step ...))))))))))))

(define-syntax quasiquote
   (letrec
     ; these are here because syntax-case uses literal-identifier=?,
     ; and we want the more precise free-identifier=?
      ((isquote? (lambda (x)
                   (and (identifier? x)
                        (free-identifier=? x (syntax quote)))))
       (islist? (lambda (x)
                  (and (identifier? x)
                       (free-identifier=? x (syntax list)))))
       (iscons? (lambda (x)
                  (and (identifier? x)
                       (free-identifier=? x (syntax cons)))))
       (quote-nil? (lambda (x)
                    (syntax-case x ()
                      ((quote? ()) (isquote? (syntax quote?)))
                      (_ #f))))
       (quasilist*
        (lambda (x y)
          (let f ((x x))
            (if (null? x)
                y
                (quasicons (car x) (f (cdr x)))))))
       (quasicons
        (lambda (x y)
          (with-syntax ((x x) (y y))
            (syntax-case (syntax y) ()
              ((quote? dy)
               (isquote? (syntax quote?))
               (syntax-case (syntax x) ()
                 ((quote? dx)
                  (isquote? (syntax quote?))
                  (syntax (quote (dx . dy))))
                 (_ (if (null? (syntax dy))
                        (syntax (list x))
                        (syntax (cons x y))))))
              ((listp . stuff)
               (islist? (syntax listp))
               (syntax (list x . stuff)))
              (else (syntax (cons x y)))))))
       (quasiappend
        (lambda (x y)
          (let ((ls (let f ((x x))
                      (if (null? x)
                          (if (quote-nil? y)
                              '()
                              (list y))
                          (if (quote-nil? (car x))
                              (f (cdr x))
                              (cons (car x) (f (cdr x))))))))
            (cond
              ((null? ls) (syntax (quote ())))
              ((null? (cdr ls)) (car ls))
              (else (with-syntax (((p ...) ls))
                      (syntax (append p ...))))))))
       (quasivector
        (lambda (x)
          (with-syntax ((pat-x x))
            (syntax-case (syntax pat-x) ()
              ((quote? (x ...))
               (isquote? (syntax quote?))
               (syntax (quote #(x ...))))
              (_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls))))
                   (syntax-case x ()
                     ((quote? (x ...))
                      (isquote? (syntax quote?))
                      (k (syntax ((quote x) ...))))
                     ((listp x ...)
                      (islist? (syntax listp))
                      (k (syntax (x ...))))
                     ((cons? x y)
                      (iscons? (syntax cons?))
                      (f (syntax y) (lambda (ls) (k (cons (syntax x) ls)))))
                     (else
                      (syntax (list->vector pat-x))))))))))
       (quasi
        (lambda (p lev)
           (syntax-case p (unquote unquote-splicing quasiquote)
              ((unquote p)
               (if (= lev 0)
                   (syntax p)
                   (quasicons (syntax (quote unquote))
                              (quasi (syntax (p)) (- lev 1)))))
              (((unquote p ...) . q)
               (if (= lev 0)
                   (quasilist* (syntax (p ...)) (quasi (syntax q) lev))
                   (quasicons (quasicons (syntax (quote unquote))
                                         (quasi (syntax (p ...)) (- lev 1)))
                              (quasi (syntax q) lev))))
              (((unquote-splicing p ...) . q)
               (if (= lev 0)
                   (quasiappend (syntax (p ...)) (quasi (syntax q) lev))
                   (quasicons (quasicons (syntax (quote unquote-splicing))
                                         (quasi (syntax (p ...)) (- lev 1)))
                              (quasi (syntax q) lev))))
              ((quasiquote p)
               (quasicons (syntax (quote quasiquote))
                          (quasi (syntax (p)) (+ lev 1))))
              ((p . q)
               (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
              (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
              (p (syntax (quote p)))))))
    (lambda (x)
       (syntax-case x ()
          ((_ e) (quasi (syntax e) 0))))))

(define-syntax include
  (lambda (x)
    (define read-file
      (lambda (fn k)
        (let ((p (open-input-file fn)))
          (let f ()
            (let ((x (read p)))
              (if (eof-object? x)
                  (begin (close-input-port p) '())
                  (cons (datum->syntax-object k x) (f))))))))
    (syntax-case x ()
      ((k filename)
       (let ((fn (syntax-object->datum (syntax filename))))
         (with-syntax (((exp ...) (read-file fn (syntax k))))
           (syntax (begin exp ...))))))))

(define-syntax unquote
  (lambda (x)
    (syntax-case x ()
      ((_ e ...)
       (syntax-error x
         "expression not valid outside of quasiquote")))))

(define-syntax unquote-splicing
  (lambda (x)
    (syntax-case x ()
      ((_ e ...)
       (syntax-error x
         "expression not valid outside of quasiquote")))))

(define-syntax case
  (lambda (x)
    (syntax-case x ()
      ((_ e m1 m2 ...)
       (with-syntax
         ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
                  (if (null? clauses)
                      (syntax-case clause (else)
                        ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
                        (((k ...) e1 e2 ...)
                         (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
                        (_ (syntax-error x)))
                      (with-syntax ((rest (f (car clauses) (cdr clauses))))
                        (syntax-case clause (else)
                          (((k ...) e1 e2 ...)
                           (syntax (if (memv t '(k ...))
                                       (begin e1 e2 ...)
                                       rest)))
                          (_ (syntax-error x))))))))
         (syntax (let ((t e)) body)))))))

(define-syntax identifier-syntax
  (lambda (x)
    (syntax-case x (set!)
      ((_ e)
       (syntax
         (lambda (x)
           (syntax-case x ()
             (id
              (identifier? (syntax id))
              (syntax e))
             ((_ x (... ...))
              (syntax (e x (... ...))))))))
      ((_ (id exp1) ((set! var val) exp2))
       (and (identifier? (syntax id)) (identifier? (syntax var)))
       (syntax
         (cons 'macro!
           (lambda (x)
             (syntax-case x (set!)
               ((set! var val) (syntax exp2))
               ((id x (... ...)) (syntax (exp1 x (... ...))))
               (id (identifier? (syntax id)) (syntax exp1))))))))))