guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 08/12: psyntax: Remove a useless level of let


From: Andy Wingo
Subject: [Guile-commits] 08/12: psyntax: Remove a useless level of let
Date: Fri, 15 Nov 2024 10:25:32 -0500 (EST)

wingo pushed a commit to branch main
in repository guile.

commit 4f05d1709b8dbe5f457b220dd2509c5a187f5416
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Nov 15 13:57:57 2024 +0100

    psyntax: Remove a useless level of let
    
    * module/ice-9/psyntax.scm: Remove let around the body.
---
 module/ice-9/psyntax.scm | 5557 +++++++++++++++++++++++-----------------------
 1 file changed, 2778 insertions(+), 2779 deletions(-)

diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 1b5e3a2a9..97e4d8524 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -123,2839 +123,2838 @@
                              fields)))
                    (lp (1+ n))))))))))
 
-  (let ()
-    (define-expansion-constructors)
-    (define-expansion-accessors lambda src meta body)
-
-    (define (top-level-eval x mod)
-      (primitive-eval x))
-
-    (define (local-eval x mod)
-      (primitive-eval x))
-
-    (define (sourcev-filename s) (vector-ref s 0))
-    (define (sourcev-line s) (vector-ref s 1))
-    (define (sourcev-column s) (vector-ref s 2))
-    (define (sourcev->alist sourcev)
-      (define (maybe-acons k v tail) (if v (acons k v tail) tail))
-      (and sourcev
-           (maybe-acons 'filename (sourcev-filename sourcev)
-                        `((line . ,(sourcev-line sourcev))
-                          (column . ,(sourcev-column sourcev))))))
-
-    (define (maybe-name-value name val)
-      (if (lambda? val)
-          (let ((meta (lambda-meta val)))
-            (if (assq 'name meta)
-                val
-                (make-lambda (lambda-src val)
-                             (acons 'name name meta)
-                             (lambda-body val))))
-          val))
-
-    ;; output constructors
-    (define build-void
-      (lambda (sourcev)
-        (make-void sourcev)))
-
-    (define build-call
-      (lambda (sourcev fun-exp arg-exps)
-        (make-call sourcev fun-exp arg-exps)))
+  (define-expansion-constructors)
+  (define-expansion-accessors lambda src meta body)
+
+  (define (top-level-eval x mod)
+    (primitive-eval x))
+
+  (define (local-eval x mod)
+    (primitive-eval x))
+
+  (define (sourcev-filename s) (vector-ref s 0))
+  (define (sourcev-line s) (vector-ref s 1))
+  (define (sourcev-column s) (vector-ref s 2))
+  (define (sourcev->alist sourcev)
+    (define (maybe-acons k v tail) (if v (acons k v tail) tail))
+    (and sourcev
+         (maybe-acons 'filename (sourcev-filename sourcev)
+                      `((line . ,(sourcev-line sourcev))
+                        (column . ,(sourcev-column sourcev))))))
+
+  (define (maybe-name-value name val)
+    (if (lambda? val)
+        (let ((meta (lambda-meta val)))
+          (if (assq 'name meta)
+              val
+              (make-lambda (lambda-src val)
+                           (acons 'name name meta)
+                           (lambda-body val))))
+        val))
+
+  ;; output constructors
+  (define build-void
+    (lambda (sourcev)
+      (make-void sourcev)))
+
+  (define build-call
+    (lambda (sourcev fun-exp arg-exps)
+      (make-call sourcev fun-exp arg-exps)))
   
-    (define build-conditional
-      (lambda (sourcev test-exp then-exp else-exp)
-        (make-conditional sourcev test-exp then-exp else-exp)))
+  (define build-conditional
+    (lambda (sourcev test-exp then-exp else-exp)
+      (make-conditional sourcev test-exp then-exp else-exp)))
   
-    (define build-lexical-reference
-      (lambda (type sourcev name var)
-        (make-lexical-ref sourcev name var)))
+  (define build-lexical-reference
+    (lambda (type sourcev name var)
+      (make-lexical-ref sourcev name var)))
   
-    (define build-lexical-assignment
-      (lambda (sourcev name var exp)
-        (make-lexical-set sourcev name var (maybe-name-value name exp))))
+  (define build-lexical-assignment
+    (lambda (sourcev name var exp)
+      (make-lexical-set sourcev name var (maybe-name-value name exp))))
   
-    (define (analyze-variable mod var modref-cont bare-cont)
-      (if (not mod)
-          (bare-cont #f var)
-          (let ((kind (car mod))
-                (mod (cdr mod)))
-            (case kind
-              ((public) (modref-cont mod var #t))
-              ((private hygiene) (if (equal? mod (module-name 
(current-module)))
-                                     (bare-cont mod var)
-                                     (modref-cont mod var #f)))
-              ((bare) (bare-cont var))
-              ((primitive)
-               (syntax-violation #f "primitive not in operator position" var))
-              (else (syntax-violation #f "bad module kind" var mod))))))
-
-    (define build-global-reference
-      (lambda (sourcev var mod)
+  (define (analyze-variable mod var modref-cont bare-cont)
+    (if (not mod)
+        (bare-cont #f var)
+        (let ((kind (car mod))
+              (mod (cdr mod)))
+          (case kind
+            ((public) (modref-cont mod var #t))
+            ((private hygiene) (if (equal? mod (module-name (current-module)))
+                                   (bare-cont mod var)
+                                   (modref-cont mod var #f)))
+            ((bare) (bare-cont var))
+            ((primitive)
+             (syntax-violation #f "primitive not in operator position" var))
+            (else (syntax-violation #f "bad module kind" var mod))))))
+
+  (define build-global-reference
+    (lambda (sourcev var mod)
+      (analyze-variable
+       mod var
+       (lambda (mod var public?) 
+         (make-module-ref sourcev mod var public?))
+       (lambda (mod var)
+         (make-toplevel-ref sourcev mod var)))))
+
+  (define build-global-assignment
+    (lambda (sourcev var exp mod)
+      (let ((exp (maybe-name-value var exp)))
         (analyze-variable
          mod var
          (lambda (mod var public?) 
-           (make-module-ref sourcev mod var public?))
+           (make-module-set sourcev mod var public? exp))
          (lambda (mod var)
-           (make-toplevel-ref sourcev mod var)))))
-
-    (define build-global-assignment
-      (lambda (sourcev var exp mod)
-        (let ((exp (maybe-name-value var exp)))
-          (analyze-variable
-           mod var
-           (lambda (mod var public?) 
-             (make-module-set sourcev mod var public? exp))
-           (lambda (mod var)
-             (make-toplevel-set sourcev mod var exp))))))
-
-    (define build-global-definition
-      (lambda (sourcev mod var exp)
-        (make-toplevel-define sourcev (and mod (cdr mod)) var
-                              (maybe-name-value var exp))))
-
-    (define build-simple-lambda
-      (lambda (src req rest vars meta exp)
-        (make-lambda src
-                     meta
-                     ;; hah, a case in which kwargs would be nice.
-                     (make-lambda-case
-                      ;; src req opt rest kw inits vars body else
-                      src req #f rest #f '() vars exp #f))))
-
-    (define build-case-lambda
-      (lambda (src meta body)
-        (make-lambda src meta body)))
-
-    (define build-lambda-case
-      ;; req := (name ...)
-      ;; opt := (name ...) | #f
-      ;; rest := name | #f
-      ;; kw := (allow-other-keys? (keyword name var) ...) | #f
-      ;; inits: (init ...)
-      ;; vars: (sym ...)
-      ;; vars map to named arguments in the following order:
-      ;;  required, optional (positional), rest, keyword.
-      ;; the body of a lambda: anything, already expanded
-      ;; else: lambda-case | #f
-      (lambda (src req opt rest kw inits vars body else-case)
-        (make-lambda-case src req opt rest kw inits vars body else-case)))
-
-    (define build-primcall
-      (lambda (src name args)
-        (make-primcall src name args)))
-    
-    (define build-primref
-      (lambda (src name)
-        (make-primitive-ref src name)))
-    
-    (define (build-data src exp)
-      (make-const src exp))
-
-    (define build-sequence
-      (lambda (src exps)
-        (if (null? (cdr exps))
-            (car exps)
-            (make-seq src (car exps) (build-sequence #f (cdr exps))))))
-
-    (define build-let
-      (lambda (src ids vars val-exps body-exp)
-        (let ((val-exps (map maybe-name-value ids val-exps)))
-          (if (null? vars)
-              body-exp
-              (make-let src ids vars val-exps body-exp)))))
-
-    (define build-named-let
-      (lambda (src ids vars val-exps body-exp)
-        (let ((f (car vars))
-              (f-name (car ids))
-              (vars (cdr vars))
-              (ids (cdr ids)))
-          (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
-            (make-letrec
-             src #f
-             (list f-name) (list f) (list (maybe-name-value f-name proc))
-             (build-call src (build-lexical-reference 'fun src f-name f)
-                         (map maybe-name-value ids val-exps)))))))
-
-    (define build-letrec
-      (lambda (src in-order? ids vars val-exps body-exp)
+           (make-toplevel-set sourcev mod var exp))))))
+
+  (define build-global-definition
+    (lambda (sourcev mod var exp)
+      (make-toplevel-define sourcev (and mod (cdr mod)) var
+                            (maybe-name-value var exp))))
+
+  (define build-simple-lambda
+    (lambda (src req rest vars meta exp)
+      (make-lambda src
+                   meta
+                   ;; hah, a case in which kwargs would be nice.
+                   (make-lambda-case
+                    ;; src req opt rest kw inits vars body else
+                    src req #f rest #f '() vars exp #f))))
+
+  (define build-case-lambda
+    (lambda (src meta body)
+      (make-lambda src meta body)))
+
+  (define build-lambda-case
+    ;; req := (name ...)
+    ;; opt := (name ...) | #f
+    ;; rest := name | #f
+    ;; kw := (allow-other-keys? (keyword name var) ...) | #f
+    ;; inits: (init ...)
+    ;; vars: (sym ...)
+    ;; vars map to named arguments in the following order:
+    ;;  required, optional (positional), rest, keyword.
+    ;; the body of a lambda: anything, already expanded
+    ;; else: lambda-case | #f
+    (lambda (src req opt rest kw inits vars body else-case)
+      (make-lambda-case src req opt rest kw inits vars body else-case)))
+
+  (define build-primcall
+    (lambda (src name args)
+      (make-primcall src name args)))
+  
+  (define build-primref
+    (lambda (src name)
+      (make-primitive-ref src name)))
+  
+  (define (build-data src exp)
+    (make-const src exp))
+
+  (define build-sequence
+    (lambda (src exps)
+      (if (null? (cdr exps))
+          (car exps)
+          (make-seq src (car exps) (build-sequence #f (cdr exps))))))
+
+  (define build-let
+    (lambda (src ids vars val-exps body-exp)
+      (let ((val-exps (map maybe-name-value ids val-exps)))
         (if (null? vars)
             body-exp
-            (make-letrec src in-order? ids vars
-                         (map maybe-name-value ids val-exps)
-                         body-exp))))
-
-
-    (define (gen-lexical id)
-      ;; Generate a unique symbol for a lexical variable.  These need to
-      ;; be symbols as they are embedded in Tree-IL.  Lexicals from
-      ;; different separately compiled modules can coexist, for example
-      ;; if a macro defined in module A is used in a separately-compiled
-      ;; module B, so they do need to be unique.  However we assume that
-      ;; generally a module corresponds to a compilation unit, so there
-      ;; is no need to be unique across separately-compiled instances of
-      ;; the same module, and that therefore we can use a deterministic
-      ;; per-module counter instead of the global counter of 'gensym' so
-      ;; that the generated identifier is reproducible.
-      (module-gensym (symbol->string id)))
-
-    (define-syntax no-source (identifier-syntax #f))
-
-    (define (datum-sourcev datum)
-      (let ((props (source-properties datum)))
-        (and (pair? props)
-             (vector (assq-ref props 'filename)
-                     (assq-ref props 'line)
-                     (assq-ref props 'column)))))
-
-    (define source-annotation
-      (lambda (x)
-        ;; Normally X is a syntax object.  However, if it comes from a
-        ;; read hash extension, X might be a plain sexp with source
-        ;; properties.
-        (if (syntax? x)
-            (syntax-sourcev x)
-            (datum-sourcev x))))
-
-    (define-syntax-rule (arg-check pred? e who)
-      (let ((x e))
-        (if (not (pred? x)) (syntax-violation 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
-    ;; Guile's module system 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
-    ;; resolve-identifier when it finds no other bindings.
-
-    ;; <environment>              ::= ((<label> . <binding>)*)
-
-    ;; identifier bindings include a type and a value
-
-    ;; <binding> ::= (macro . <procedure>)           macros
-    ;;               (syntax-parameter . <procedure>) syntax parameters
-    ;;               (core . <procedure>)            core forms
-    ;;               (module-ref . <procedure>)      @ or @@
-    ;;               (begin)                         begin
-    ;;               (define)                        define
-    ;;               (define-syntax)                 define-syntax
-    ;;               (define-syntax-parameter)       define-syntax-parameter
-    ;;               (local-syntax . rec?)           let-syntax/letrec-syntax
-    ;;               (eval-when)                     eval-when
-    ;;               (syntax . (<var> . <level>))    pattern variables
-    ;;               (global)                        assumed global variable
-    ;;               (lexical . <var>)               lexical variables
-    ;;               (ellipsis . <identifier>)       custom ellipsis
-    ;;               (displaced-lexical)             displaced lexicals
-    ;; <level>   ::= <non-negative integer>
-    ;; <var>     ::= symbol returned by gen-lexical
-
-    ;; a macro is a user-defined syntactic-form.  a core is a
-    ;; system-defined syntactic form.  begin, define, define-syntax,
-    ;; define-syntax-parameter, 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.
-
-    ;; an ellipsis binding is introduced by the 'with-ellipsis' special
-    ;; form.
-
-    ;; 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-syntax make-binding
-      (syntax-rules (quote)
-        ((_ type value) (cons type value))
-        ((_ 'type) '(type))
-        ((_ type) (cons type '()))))
-    (define-syntax-rule (binding-type x)
-      (car x))
-    (define-syntax-rule (binding-value x)
-      (cdr x))
-
-    (define-syntax null-env (identifier-syntax '()))
-
-    (define extend-env
-      (lambda (labels bindings r) 
-        (if (null? labels)
-            r
-            (extend-env (cdr labels) (cdr bindings)
-                        (cons (cons (car labels) (car bindings)) r)))))
+            (make-let src ids vars val-exps body-exp)))))
+
+  (define build-named-let
+    (lambda (src ids vars val-exps body-exp)
+      (let ((f (car vars))
+            (f-name (car ids))
+            (vars (cdr vars))
+            (ids (cdr ids)))
+        (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
+          (make-letrec
+           src #f
+           (list f-name) (list f) (list (maybe-name-value f-name proc))
+           (build-call src (build-lexical-reference 'fun src f-name f)
+                       (map maybe-name-value ids val-exps)))))))
+
+  (define build-letrec
+    (lambda (src in-order? ids vars val-exps body-exp)
+      (if (null? vars)
+          body-exp
+          (make-letrec src in-order? ids vars
+                       (map maybe-name-value ids val-exps)
+                       body-exp))))
+
+
+  (define (gen-lexical id)
+    ;; Generate a unique symbol for a lexical variable.  These need to
+    ;; be symbols as they are embedded in Tree-IL.  Lexicals from
+    ;; different separately compiled modules can coexist, for example
+    ;; if a macro defined in module A is used in a separately-compiled
+    ;; module B, so they do need to be unique.  However we assume that
+    ;; generally a module corresponds to a compilation unit, so there
+    ;; is no need to be unique across separately-compiled instances of
+    ;; the same module, and that therefore we can use a deterministic
+    ;; per-module counter instead of the global counter of 'gensym' so
+    ;; that the generated identifier is reproducible.
+    (module-gensym (symbol->string id)))
+
+  (define-syntax no-source (identifier-syntax #f))
+
+  (define (datum-sourcev datum)
+    (let ((props (source-properties datum)))
+      (and (pair? props)
+           (vector (assq-ref props 'filename)
+                   (assq-ref props 'line)
+                   (assq-ref props 'column)))))
+
+  (define source-annotation
+    (lambda (x)
+      ;; Normally X is a syntax object.  However, if it comes from a
+      ;; read hash extension, X might be a plain sexp with source
+      ;; properties.
+      (if (syntax? x)
+          (syntax-sourcev x)
+          (datum-sourcev x))))
+
+  (define-syntax-rule (arg-check pred? e who)
+    (let ((x e))
+      (if (not (pred? x)) (syntax-violation 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
+  ;; Guile's module system 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
+  ;; resolve-identifier when it finds no other bindings.
+
+  ;; <environment>              ::= ((<label> . <binding>)*)
+
+  ;; identifier bindings include a type and a value
+
+  ;; <binding> ::= (macro . <procedure>)           macros
+  ;;               (syntax-parameter . <procedure>) syntax parameters
+  ;;               (core . <procedure>)            core forms
+  ;;               (module-ref . <procedure>)      @ or @@
+  ;;               (begin)                         begin
+  ;;               (define)                        define
+  ;;               (define-syntax)                 define-syntax
+  ;;               (define-syntax-parameter)       define-syntax-parameter
+  ;;               (local-syntax . rec?)           let-syntax/letrec-syntax
+  ;;               (eval-when)                     eval-when
+  ;;               (syntax . (<var> . <level>))    pattern variables
+  ;;               (global)                        assumed global variable
+  ;;               (lexical . <var>)               lexical variables
+  ;;               (ellipsis . <identifier>)       custom ellipsis
+  ;;               (displaced-lexical)             displaced lexicals
+  ;; <level>   ::= <non-negative integer>
+  ;; <var>     ::= symbol returned by gen-lexical
+
+  ;; a macro is a user-defined syntactic-form.  a core is a
+  ;; system-defined syntactic form.  begin, define, define-syntax,
+  ;; define-syntax-parameter, 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.
+
+  ;; an ellipsis binding is introduced by the 'with-ellipsis' special
+  ;; form.
+
+  ;; 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-syntax make-binding
+    (syntax-rules (quote)
+      ((_ type value) (cons type value))
+      ((_ 'type) '(type))
+      ((_ type) (cons type '()))))
+  (define-syntax-rule (binding-type x)
+    (car x))
+  (define-syntax-rule (binding-value x)
+    (cdr x))
+
+  (define-syntax null-env (identifier-syntax '()))
+
+  (define extend-env
+    (lambda (labels bindings r) 
+      (if (null? labels)
+          r
+          (extend-env (cdr labels) (cdr bindings)
+                      (cons (cons (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)
+                          (cons (cons (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.
+  (define macros-only-env
+    (lambda (r)
+      (if (null? r)
+          '()
+          (let ((a (car r)))
+            (if (memq (cadr a) '(macro syntax-parameter ellipsis))
+                (cons a (macros-only-env (cdr r)))
+                (macros-only-env (cdr 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)
-                            (cons (cons (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.
-    (define macros-only-env
-      (lambda (r)
-        (if (null? r)
-            '()
-            (let ((a (car r)))
-              (if (memq (cadr a) '(macro syntax-parameter ellipsis))
-                  (cons a (macros-only-env (cdr r)))
-                  (macros-only-env (cdr r)))))))
-
-    (define global-extend
-      (lambda (type sym val)
-        (module-define! (current-module)
-                        sym
-                        (make-syntax-transformer sym 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? x)
-             (symbol? (syntax-expression x)))))
-
-    (define id?
-      (lambda (x)
-        (cond
-         ((symbol? x) #t)
-         ((syntax? x) (symbol? (syntax-expression x)))
-         (else #f))))
+  (define global-extend
+    (lambda (type sym val)
+      (module-define! (current-module)
+                      sym
+                      (make-syntax-transformer sym type val))))
 
-    (define-syntax-rule (id-sym-name e)
-      (let ((x e))
-        (if (syntax? x)
-            (syntax-expression x)
-            x)))
-
-    (define id-sym-name&marks
-      (lambda (x w)
-        (if (syntax? x)
-            (values
-             (syntax-expression x)
-             (join-marks (wrap-marks w) (wrap-marks (syntax-wrap x))))
-            (values x (wrap-marks w)))))
-
-    ;; syntax object wraps
-
-    ;;      <wrap> ::= ((<mark> ...) . (<subst> ...))
-    ;;     <subst> ::= shift | <subs>
-    ;;      <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
-    ;;                 | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
-
-    (define-syntax make-wrap (identifier-syntax cons))
-    (define-syntax wrap-marks (identifier-syntax car))
-    (define-syntax wrap-subst (identifier-syntax cdr))
-
-    (define* (gen-unique #:optional (module (current-module)))
-      ;; Generate a unique value, used as a mark to identify a scope, or
-      ;; as a label to associate an identifier with a lexical.  They
-      ;; need to be readable and writable, and because of they way they
-      ;; are used as labels and marks, distinct from pairs, syntax, and
-      ;; the symbol `top'.  Unique values from different separately
-      ;; compiled modules can coexist, for example if a macro defined in
-      ;; module A is used in a separately-compiled module B; however we
-      ;; assume that generally a module corresponds to a compilation
-      ;; unit, so there is no need to be unique across
-      ;; separately-compiled instances of the same module, and that
-      ;; therefore we can use a deterministic per-module counter instead
-      ;; of, say, a random number of a long enough length.
-      (if module
-          (vector (module-name module) (module-generate-unique-id! module))
-          (vector '(guile) (gensym "id"))))
-
-    ;; labels must be comparable with "eq?", have read-write invariance,
-    ;; and distinct from symbols.  Pair labels are used for top-level
-    ;; definition placeholders.  These labels are used for proper
-    ;; lexicals.
-    (define (gen-label)
-      (gen-unique))
-
-    (define (gen-labels ls)
-      (if (null? ls)
-          '()
-          (cons (gen-label) (gen-labels (cdr ls)))))
-
-    (define (make-ribcage symnames marks labels)
-      (vector 'ribcage symnames marks labels))
-    (define (ribcage-symnames ribcage) (vector-ref ribcage 1))
-    (define (ribcage-marks ribcage) (vector-ref ribcage 2))
-    (define (ribcage-labels ribcage) (vector-ref ribcage 3))
-    (define (set-ribcage-symnames! ribcage x) (vector-set! ribcage 1 x))
-    (define (set-ribcage-marks! ribcage x) (vector-set! ribcage 2 x))
-    (define (set-ribcage-labels! ribcage x) (vector-set! ribcage 3 x))
-
-    (define-syntax empty-wrap (identifier-syntax '(())))
-    (define-syntax top-wrap (identifier-syntax '((top))))
-
-    ;; 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 (new-mark)
-      (gen-unique))
-
-    ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
-    ;; internal definitions, in which the ribcages are built incrementally
-    (define-syntax-rule (make-empty-ribcage)
-      (make-ribcage '() '() '()))
-
-    (define extend-ribcage!
-      ;; must receive ids with complete wraps
-      (lambda (ribcage id label)
-        (set-ribcage-symnames! ribcage
-                               (cons (syntax-expression id)
-                                     (ribcage-symnames ribcage)))
-        (set-ribcage-marks! ribcage
-                            (cons (wrap-marks (syntax-wrap id))
-                                  (ribcage-marks ribcage)))
-        (set-ribcage-labels! ribcage
-                             (cons label (ribcage-labels ribcage)))))
-
-    ;; make-binding-wrap creates vector-based ribcages
-    (define make-binding-wrap
-      (lambda (ids labels w)
-        (if (null? ids)
-            w
+
+  ;; 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? x)
+           (symbol? (syntax-expression x)))))
+
+  (define id?
+    (lambda (x)
+      (cond
+       ((symbol? x) #t)
+       ((syntax? x) (symbol? (syntax-expression x)))
+       (else #f))))
+
+  (define-syntax-rule (id-sym-name e)
+    (let ((x e))
+      (if (syntax? x)
+          (syntax-expression x)
+          x)))
+
+  (define id-sym-name&marks
+    (lambda (x w)
+      (if (syntax? x)
+          (values
+           (syntax-expression x)
+           (join-marks (wrap-marks w) (wrap-marks (syntax-wrap x))))
+          (values x (wrap-marks w)))))
+
+  ;; syntax object wraps
+
+  ;;      <wrap> ::= ((<mark> ...) . (<subst> ...))
+  ;;     <subst> ::= shift | <subs>
+  ;;      <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
+  ;;                 | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
+
+  (define-syntax make-wrap (identifier-syntax cons))
+  (define-syntax wrap-marks (identifier-syntax car))
+  (define-syntax wrap-subst (identifier-syntax cdr))
+
+  (define* (gen-unique #:optional (module (current-module)))
+    ;; Generate a unique value, used as a mark to identify a scope, or
+    ;; as a label to associate an identifier with a lexical.  They
+    ;; need to be readable and writable, and because of they way they
+    ;; are used as labels and marks, distinct from pairs, syntax, and
+    ;; the symbol `top'.  Unique values from different separately
+    ;; compiled modules can coexist, for example if a macro defined in
+    ;; module A is used in a separately-compiled module B; however we
+    ;; assume that generally a module corresponds to a compilation
+    ;; unit, so there is no need to be unique across
+    ;; separately-compiled instances of the same module, and that
+    ;; therefore we can use a deterministic per-module counter instead
+    ;; of, say, a random number of a long enough length.
+    (if module
+        (vector (module-name module) (module-generate-unique-id! module))
+        (vector '(guile) (gensym "id"))))
+
+  ;; labels must be comparable with "eq?", have read-write invariance,
+  ;; and distinct from symbols.  Pair labels are used for top-level
+  ;; definition placeholders.  These labels are used for proper
+  ;; lexicals.
+  (define (gen-label)
+    (gen-unique))
+
+  (define (gen-labels ls)
+    (if (null? ls)
+        '()
+        (cons (gen-label) (gen-labels (cdr ls)))))
+
+  (define (make-ribcage symnames marks labels)
+    (vector 'ribcage symnames marks labels))
+  (define (ribcage-symnames ribcage) (vector-ref ribcage 1))
+  (define (ribcage-marks ribcage) (vector-ref ribcage 2))
+  (define (ribcage-labels ribcage) (vector-ref ribcage 3))
+  (define (set-ribcage-symnames! ribcage x) (vector-set! ribcage 1 x))
+  (define (set-ribcage-marks! ribcage x) (vector-set! ribcage 2 x))
+  (define (set-ribcage-labels! ribcage x) (vector-set! ribcage 3 x))
+
+  (define-syntax empty-wrap (identifier-syntax '(())))
+  (define-syntax top-wrap (identifier-syntax '((top))))
+
+  ;; 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 (new-mark)
+    (gen-unique))
+
+  ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
+  ;; internal definitions, in which the ribcages are built incrementally
+  (define-syntax-rule (make-empty-ribcage)
+    (make-ribcage '() '() '()))
+
+  (define extend-ribcage!
+    ;; must receive ids with complete wraps
+    (lambda (ribcage id label)
+      (set-ribcage-symnames! ribcage
+                             (cons (syntax-expression id)
+                                   (ribcage-symnames ribcage)))
+      (set-ribcage-marks! ribcage
+                          (cons (wrap-marks (syntax-wrap id))
+                                (ribcage-marks ribcage)))
+      (set-ribcage-labels! ribcage
+                           (cons label (ribcage-labels ribcage)))))
+
+  ;; 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) (1+ i))))))
+                  (make-ribcage symnamevec marksvec labelvec))))
+            (wrap-subst w))))))
+
+  (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
-             (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) (1+ i))))))
-                    (make-ribcage symnamevec marksvec labelvec))))
-              (wrap-subst w))))))
-
-    (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
-      ;; Syntax objects use wraps to associate names with marked
-      ;; identifiers.  This function returns the name corresponding to
-      ;; the given identifier and wrap, or the original identifier if no
-      ;; corresponding name was found.
-      ;;
-      ;; The name may be a string created by gen-label, indicating a
-      ;; lexical binding, or another syntax object, indicating a
-      ;; reference to a top-level definition created during a previous
-      ;; macroexpansion.
-      ;;
-      ;; For lexical variables, finding a label simply amounts to
-      ;; looking for an entry with the same symbolic name and the same
-      ;; marks.  Finding a toplevel definition is the same, except we
-      ;; also have to compare modules, hence the `mod' parameter.
-      ;; Instead of adding a separate entry in the ribcage for modules,
-      ;; which wouldn't be used for lexicals, we arrange for the entry
-      ;; for the name entry to be a pair with the module in its car, and
-      ;; the name itself in the cdr.  So if the name that we find is a
-      ;; pair, we have to check modules.
-      ;;
-      ;; The identifer may be passed in wrapped or unwrapped.  In any
-      ;; case, this routine returns either a symbol, a syntax object, or
-      ;; a string label.
-      ;;
-      (lambda (id w mod)
-        (define-syntax-rule (first e)
-          ;; Rely on Guile's multiple-values truncation.
-          e)
-        (define search
-          (lambda (sym subst marks mod)
-            (if (null? subst)
-                (values #f marks)
-                (let ((fst (car subst)))
-                  (if (eq? fst 'shift)
-                      (search sym (cdr subst) (cdr marks) mod)
-                      (let ((symnames (ribcage-symnames fst)))
-                        (if (vector? symnames)
-                            (search-vector-rib sym subst marks symnames fst 
mod)
-                            (search-list-rib sym subst marks symnames fst 
mod))))))))
-        (define search-list-rib
-          (lambda (sym subst marks symnames ribcage mod)
-            (let f ((symnames symnames)
-                    (rlabels (ribcage-labels ribcage))
-                    (rmarks (ribcage-marks ribcage)))
+             (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
+    ;; Syntax objects use wraps to associate names with marked
+    ;; identifiers.  This function returns the name corresponding to
+    ;; the given identifier and wrap, or the original identifier if no
+    ;; corresponding name was found.
+    ;;
+    ;; The name may be a string created by gen-label, indicating a
+    ;; lexical binding, or another syntax object, indicating a
+    ;; reference to a top-level definition created during a previous
+    ;; macroexpansion.
+    ;;
+    ;; For lexical variables, finding a label simply amounts to
+    ;; looking for an entry with the same symbolic name and the same
+    ;; marks.  Finding a toplevel definition is the same, except we
+    ;; also have to compare modules, hence the `mod' parameter.
+    ;; Instead of adding a separate entry in the ribcage for modules,
+    ;; which wouldn't be used for lexicals, we arrange for the entry
+    ;; for the name entry to be a pair with the module in its car, and
+    ;; the name itself in the cdr.  So if the name that we find is a
+    ;; pair, we have to check modules.
+    ;;
+    ;; The identifer may be passed in wrapped or unwrapped.  In any
+    ;; case, this routine returns either a symbol, a syntax object, or
+    ;; a string label.
+    ;;
+    (lambda (id w mod)
+      (define-syntax-rule (first e)
+        ;; Rely on Guile's multiple-values truncation.
+        e)
+      (define search
+        (lambda (sym subst marks mod)
+          (if (null? subst)
+              (values #f marks)
+              (let ((fst (car subst)))
+                (if (eq? fst 'shift)
+                    (search sym (cdr subst) (cdr marks) mod)
+                    (let ((symnames (ribcage-symnames fst)))
+                      (if (vector? symnames)
+                          (search-vector-rib sym subst marks symnames fst mod)
+                          (search-list-rib sym subst marks symnames fst 
mod))))))))
+      (define search-list-rib
+        (lambda (sym subst marks symnames ribcage mod)
+          (let f ((symnames symnames)
+                  (rlabels (ribcage-labels ribcage))
+                  (rmarks (ribcage-marks ribcage)))
+            (cond
+             ((null? symnames) (search sym (cdr subst) marks mod))
+             ((and (eq? (car symnames) sym) (same-marks? marks (car rmarks)))
+              (let ((n (car rlabels)))
+                (if (pair? n)
+                    (if (equal? mod (car n))
+                        (values (cdr n) marks)
+                        (f (cdr symnames) (cdr rlabels) (cdr rmarks)))
+                    (values n marks))))
+             (else (f (cdr symnames) (cdr rlabels) (cdr rmarks)))))))
+      (define search-vector-rib
+        (lambda (sym subst marks symnames ribcage mod)
+          (let ((n (vector-length symnames)))
+            (let f ((i 0))
               (cond
-               ((null? symnames) (search sym (cdr subst) marks mod))
-               ((and (eq? (car symnames) sym) (same-marks? marks (car rmarks)))
-                (let ((n (car rlabels)))
+               ((= i n) (search sym (cdr subst) marks mod))
+               ((and (eq? (vector-ref symnames i) sym)
+                     (same-marks? marks (vector-ref (ribcage-marks ribcage) 
i)))
+                (let ((n (vector-ref (ribcage-labels ribcage) i)))
                   (if (pair? n)
                       (if (equal? mod (car n))
                           (values (cdr n) marks)
-                          (f (cdr symnames) (cdr rlabels) (cdr rmarks)))
+                          (f (1+ i)))
                       (values n marks))))
-               (else (f (cdr symnames) (cdr rlabels) (cdr rmarks)))))))
-        (define search-vector-rib
-          (lambda (sym subst marks symnames ribcage mod)
-            (let ((n (vector-length symnames)))
-              (let f ((i 0))
-                (cond
-                 ((= i n) (search sym (cdr subst) marks mod))
-                 ((and (eq? (vector-ref symnames i) sym)
-                       (same-marks? marks (vector-ref (ribcage-marks ribcage) 
i)))
-                  (let ((n (vector-ref (ribcage-labels ribcage) i)))
-                    (if (pair? n)
-                        (if (equal? mod (car n))
-                            (values (cdr n) marks)
-                            (f (1+ i)))
-                        (values n marks))))
-                 (else (f (1+ i))))))))
-        (cond
-         ((symbol? id)
-          (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
-         ((syntax? id)
-          (let ((id (syntax-expression id))
-                (w1 (syntax-wrap id))
-                (mod (or (syntax-module id) mod)))
-            (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
-              (call-with-values (lambda () (search id (wrap-subst w) marks 
mod))
-                (lambda (new-id marks)
-                  (or new-id
-                      (first (search id (wrap-subst w1) marks mod))
-                      id))))))
-         (else (syntax-violation 'id-var-name "invalid id" id)))))
-
-    ;; A helper procedure for syntax-locally-bound-identifiers, which
-    ;; itself is a helper for transformer procedures.
-    ;; `locally-bound-identifiers' returns a list of all bindings
-    ;; visible to a syntax object with the given wrap.  They are in
-    ;; order from outer to inner.
-    ;;
-    ;; The purpose of this procedure is to give a transformer procedure
-    ;; references on bound identifiers, that the transformer can then
-    ;; introduce some of them in its output.  As such, the identifiers
-    ;; are anti-marked, so that rebuild-macro-output doesn't apply new
-    ;; marks to them.
-    ;;
-    (define locally-bound-identifiers
-      (lambda (w mod)
-        (define scan
-          (lambda (subst results)
-            (if (null? subst)
-                results
-                (let ((fst (car subst)))
-                  (if (eq? fst 'shift)
-                      (scan (cdr subst) results)
-                      (let ((symnames (ribcage-symnames fst))
-                            (marks (ribcage-marks fst)))
-                        (if (vector? symnames)
-                            (scan-vector-rib subst symnames marks results)
-                            (scan-list-rib subst symnames marks results))))))))
-        (define scan-list-rib
-          (lambda (subst symnames marks results)
-            (let f ((symnames symnames) (marks marks) (results results))
-              (if (null? symnames)
+               (else (f (1+ i))))))))
+      (cond
+       ((symbol? id)
+        (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
+       ((syntax? id)
+        (let ((id (syntax-expression id))
+              (w1 (syntax-wrap id))
+              (mod (or (syntax-module id) mod)))
+          (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
+            (call-with-values (lambda () (search id (wrap-subst w) marks mod))
+              (lambda (new-id marks)
+                (or new-id
+                    (first (search id (wrap-subst w1) marks mod))
+                    id))))))
+       (else (syntax-violation 'id-var-name "invalid id" id)))))
+
+  ;; A helper procedure for syntax-locally-bound-identifiers, which
+  ;; itself is a helper for transformer procedures.
+  ;; `locally-bound-identifiers' returns a list of all bindings
+  ;; visible to a syntax object with the given wrap.  They are in
+  ;; order from outer to inner.
+  ;;
+  ;; The purpose of this procedure is to give a transformer procedure
+  ;; references on bound identifiers, that the transformer can then
+  ;; introduce some of them in its output.  As such, the identifiers
+  ;; are anti-marked, so that rebuild-macro-output doesn't apply new
+  ;; marks to them.
+  ;;
+  (define locally-bound-identifiers
+    (lambda (w mod)
+      (define scan
+        (lambda (subst results)
+          (if (null? subst)
+              results
+              (let ((fst (car subst)))
+                (if (eq? fst 'shift)
+                    (scan (cdr subst) results)
+                    (let ((symnames (ribcage-symnames fst))
+                          (marks (ribcage-marks fst)))
+                      (if (vector? symnames)
+                          (scan-vector-rib subst symnames marks results)
+                          (scan-list-rib subst symnames marks results))))))))
+      (define scan-list-rib
+        (lambda (subst symnames marks results)
+          (let f ((symnames symnames) (marks marks) (results results))
+            (if (null? symnames)
+                (scan (cdr subst) results)
+                (f (cdr symnames) (cdr marks)
+                   (cons (wrap (car symnames)
+                               (anti-mark (make-wrap (car marks) subst))
+                               mod)
+                         results))))))
+      (define scan-vector-rib
+        (lambda (subst symnames marks results)
+          (let ((n (vector-length symnames)))
+            (let f ((i 0) (results results))
+              (if (= i n)
                   (scan (cdr subst) results)
-                  (f (cdr symnames) (cdr marks)
-                     (cons (wrap (car symnames)
-                                 (anti-mark (make-wrap (car marks) subst))
+                  (f (1+ i)
+                     (cons (wrap (vector-ref symnames i)
+                                 (anti-mark (make-wrap (vector-ref marks i) 
subst))
                                  mod)
-                           results))))))
-        (define scan-vector-rib
-          (lambda (subst symnames marks results)
-            (let ((n (vector-length symnames)))
-              (let f ((i 0) (results results))
-                (if (= i n)
-                    (scan (cdr subst) results)
-                    (f (1+ i)
-                       (cons (wrap (vector-ref symnames i)
-                                   (anti-mark (make-wrap (vector-ref marks i) 
subst))
-                                   mod)
-                             results)))))))
-        (scan (wrap-subst w) '())))
-
-    ;; Returns three values: binding type, binding value, and the module
-    ;; (for resolving toplevel vars).
-    (define (resolve-identifier id w r mod resolve-syntax-parameters?)
-      (define (resolve-global var mod)
-        (when (and (not mod) (current-module))
-          (warn "module system is booted, we should have a module" var))
-        (let ((v (and (not (equal? mod '(primitive)))
-                      (module-variable (if mod
-                                           (resolve-module (cdr mod))
-                                           (current-module))
-                                       var))))
-          ;; The expander needs to know when a top-level definition from
-          ;; outside the compilation unit is a macro.
-          ;;
-          ;; Additionally if a macro is actually a syntax-parameter, we
-          ;; might need to resolve its current binding.  If the syntax
-          ;; parameter is locally bound (via syntax-parameterize), then
-          ;; its variable will be present in `r', the expand-time
-          ;; environment.  It's a kind of double lookup: first we see
-          ;; that a name is bound to a syntax parameter, then we look
-          ;; for the current binding of the syntax parameter.
-          ;;
-          ;; We use the variable (box) holding the syntax parameter
-          ;; definition as the key for the second lookup.  We use the
-          ;; variable for two reasons:
-          ;;
-          ;;   1. If the syntax parameter is redefined in parallel
-          ;;   (perhaps via a parallel module compilation), the
-          ;;   redefinition keeps the same variable.  We don't want to
-          ;;   use a "key" that could change during a redefinition.  See
-          ;;   https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27476.
-          ;;
-          ;;   2. Using the variable instead of its (symname, modname)
-          ;;   pair allows for syntax parameters to be renamed or
-          ;;   aliased while preserving the syntax parameter's identity.
-          ;;
-          (if (and v (variable-bound? v) (macro? (variable-ref v)))
-              (let* ((m (variable-ref v))
-                     (type (macro-type m))
-                     (trans (macro-binding m))
-                     (trans (if (pair? trans) (car trans) trans)))
-                (if (eq? type 'syntax-parameter)
-                    (if resolve-syntax-parameters?
-                        (let ((lexical (assq-ref r v)))
-                          ;; A resolved syntax parameter is
-                          ;; indistinguishable from a macro.
-                          (values 'macro
-                                  (if lexical
-                                      (binding-value lexical)
-                                      trans)
-                                  mod))
-                        ;; Return box as value for use in second lookup.
-                        (values type v mod))
-                    (values type trans mod)))
-              (values 'global var mod))))
-      (define (resolve-lexical label mod)
-        (let ((b (assq-ref r label)))
-          (if b
-              (let ((type (binding-type b))
-                    (value (binding-value b)))
-                (if (eq? type 'syntax-parameter)
-                    (if resolve-syntax-parameters?
-                        (values 'macro value mod)
-                        ;; If the syntax parameter was defined within
-                        ;; this compilation unit, use its label as its
-                        ;; lookup key.
-                        (values type label mod))
-                    (values type value mod)))
-              (values 'displaced-lexical #f #f))))
-      (let ((n (id-var-name id w mod)))
+                           results)))))))
+      (scan (wrap-subst w) '())))
+
+  ;; Returns three values: binding type, binding value, and the module
+  ;; (for resolving toplevel vars).
+  (define (resolve-identifier id w r mod resolve-syntax-parameters?)
+    (define (resolve-global var mod)
+      (when (and (not mod) (current-module))
+        (warn "module system is booted, we should have a module" var))
+      (let ((v (and (not (equal? mod '(primitive)))
+                    (module-variable (if mod
+                                         (resolve-module (cdr mod))
+                                         (current-module))
+                                     var))))
+        ;; The expander needs to know when a top-level definition from
+        ;; outside the compilation unit is a macro.
+        ;;
+        ;; Additionally if a macro is actually a syntax-parameter, we
+        ;; might need to resolve its current binding.  If the syntax
+        ;; parameter is locally bound (via syntax-parameterize), then
+        ;; its variable will be present in `r', the expand-time
+        ;; environment.  It's a kind of double lookup: first we see
+        ;; that a name is bound to a syntax parameter, then we look
+        ;; for the current binding of the syntax parameter.
+        ;;
+        ;; We use the variable (box) holding the syntax parameter
+        ;; definition as the key for the second lookup.  We use the
+        ;; variable for two reasons:
+        ;;
+        ;;   1. If the syntax parameter is redefined in parallel
+        ;;   (perhaps via a parallel module compilation), the
+        ;;   redefinition keeps the same variable.  We don't want to
+        ;;   use a "key" that could change during a redefinition.  See
+        ;;   https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27476.
+        ;;
+        ;;   2. Using the variable instead of its (symname, modname)
+        ;;   pair allows for syntax parameters to be renamed or
+        ;;   aliased while preserving the syntax parameter's identity.
+        ;;
+        (if (and v (variable-bound? v) (macro? (variable-ref v)))
+            (let* ((m (variable-ref v))
+                   (type (macro-type m))
+                   (trans (macro-binding m))
+                   (trans (if (pair? trans) (car trans) trans)))
+              (if (eq? type 'syntax-parameter)
+                  (if resolve-syntax-parameters?
+                      (let ((lexical (assq-ref r v)))
+                        ;; A resolved syntax parameter is
+                        ;; indistinguishable from a macro.
+                        (values 'macro
+                                (if lexical
+                                    (binding-value lexical)
+                                    trans)
+                                mod))
+                      ;; Return box as value for use in second lookup.
+                      (values type v mod))
+                  (values type trans mod)))
+            (values 'global var mod))))
+    (define (resolve-lexical label mod)
+      (let ((b (assq-ref r label)))
+        (if b
+            (let ((type (binding-type b))
+                  (value (binding-value b)))
+              (if (eq? type 'syntax-parameter)
+                  (if resolve-syntax-parameters?
+                      (values 'macro value mod)
+                      ;; If the syntax parameter was defined within
+                      ;; this compilation unit, use its label as its
+                      ;; lookup key.
+                      (values type label mod))
+                  (values type value mod)))
+            (values 'displaced-lexical #f #f))))
+    (let ((n (id-var-name id w mod)))
+      (cond
+       ((syntax? n)
         (cond
-         ((syntax? n)
-          (cond
-           ((not (eq? n id))
-            ;; This identifier aliased another; recurse to allow
-            ;; syntax-parameterize to override macro-introduced syntax
-            ;; parameters.
-            (resolve-identifier n w r mod resolve-syntax-parameters?))
-           (else
-            ;; Resolved to a free variable that was introduced by this
-            ;; macro; continue to resolve this global by name.
-            (resolve-identifier (syntax-expression n)
-                                (syntax-wrap n)
-                                r
-                                (or (syntax-module n) mod)
-                                resolve-syntax-parameters?))))
-         ((symbol? n)
-          (resolve-global n (or (and (syntax? id)
-                                     (syntax-module id))
-                                mod)))
+         ((not (eq? n id))
+          ;; This identifier aliased another; recurse to allow
+          ;; syntax-parameterize to override macro-introduced syntax
+          ;; parameters.
+          (resolve-identifier n w r mod resolve-syntax-parameters?))
          (else
-          (resolve-lexical n (or (and (syntax? id)
-                                      (syntax-module id))
-                                 mod))))))
-
-    (define transformer-environment
-      (make-fluid
-       (lambda (k)
-         (error "called outside the dynamic extent of a syntax transformer"))))
-
-    (define (with-transformer-environment k)
-      ((fluid-ref transformer-environment) k))
-
-    ;; 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)
-        (let* ((mi (and (syntax? i) (syntax-module i)))
-               (mj (and (syntax? j) (syntax-module j)))
-               (ni (id-var-name i empty-wrap mi))
-               (nj (id-var-name j empty-wrap mj)))
-          (define (id-module-binding id mod)
-            (module-variable
-             (if mod
-                 ;; The normal case.
-                 (resolve-module (cdr mod))
-                 ;; Either modules have not been booted, or we have a
-                 ;; raw symbol coming in, which is possible.
-                 (current-module))
-             (id-sym-name id)))
-          (cond
-           ((syntax? ni) (free-id=? ni j))
-           ((syntax? nj) (free-id=? i nj))
-           ((symbol? ni)
-            ;; `i' is not lexically bound.  Assert that `j' is free,
-            ;; and if so, compare their bindings, that they are either
-            ;; bound to the same variable, or both unbound and have
-            ;; the same name.
-            (and (eq? nj (id-sym-name j))
-                 (let ((bi (id-module-binding i mi)))
-                   (if bi
-                       (eq? bi (id-module-binding j mj))
-                       (and (not (id-module-binding j mj))
-                            (eq? ni nj))))
-                 (eq? (id-module-binding i mi) (id-module-binding j mj))))
-           (else
-            ;; Otherwise `i' is bound, so check that `j' is bound, and
-            ;; bound to the same thing.
-            (equal? ni nj))))))
-    
-    ;; 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? i) (syntax? j))
-            (and (eq? (syntax-expression i)
-                      (syntax-expression j))
-                 (same-marks? (wrap-marks (syntax-wrap i))
-                              (wrap-marks (syntax-wrap j))))
-            (eq? i 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 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 defmod)
-        (source-wrap x w #f defmod)))
-
-    (define (wrap-syntax x w defmod)
-      (make-syntax (syntax-expression x)
-                   w
-                   (or (syntax-module x) defmod)
-                   (syntax-sourcev x)))
-    (define (source-wrap x w s defmod)
-      (cond
-       ((and (null? (wrap-marks w))
-             (null? (wrap-subst w))
-             (not defmod)
-             (not s))
-        x)
-       ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
-       ((null? x) x)
-       (else (make-syntax x w defmod s))))
-
-    ;; expanding
-
-    (define expand-sequence
-      (lambda (body r w s mod)
-        (build-sequence s
-                        (let dobody ((body body) (r r) (w w) (mod mod))
-                          (if (null? body)
-                              '()
-                              (let ((first (expand (car body) r w mod)))
-                                (cons first (dobody (cdr body) r w mod))))))))
-
-    ;; At top-level, we allow mixed definitions and expressions.  Like
-    ;; expand-body we expand in two passes.
-    ;;
-    ;; First, from left to right, we expand just enough to know what
-    ;; expressions are definitions, syntax definitions, and splicing
-    ;; statements (`begin').  If we anything needs evaluating at
-    ;; expansion-time, it is expanded directly.
-    ;;
-    ;; Otherwise we collect expressions to expand, in thunks, and then
-    ;; expand them all at the end.  This allows all syntax expanders
-    ;; visible in a toplevel sequence to be visible during the
-    ;; expansions of all normal definitions and expressions in the
-    ;; sequence.
-    ;;
-    (define expand-top-sequence
-      (lambda (body r w s m esew mod)
-        (let* ((r (cons '("placeholder" . (placeholder)) r))
-               (ribcage (make-empty-ribcage))
-               (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
-          (define (record-definition! id var)
-            (let ((mod (cons 'hygiene (module-name (current-module)))))
-              ;; Ribcages map symbol+marks to names, mostly for
-              ;; resolving lexicals.  Here to add a mapping for toplevel
-              ;; definitions we also need to match the module.  So, we
-              ;; put it in the name instead, and make id-var-name handle
-              ;; the special case of names that are pairs.  See the
-              ;; comments in id-var-name for more.
-              (extend-ribcage! ribcage id
-                               (cons (or (syntax-module id) mod)
-                                     (wrap var top-wrap mod)))))
-          (define (macro-introduced-identifier? id)
-            (not (equal? (wrap-marks (syntax-wrap id)) '(top))))
-          (define (ensure-fresh-name var)
-            ;; If a macro introduces a top-level identifier, we attempt
-            ;; to give it a fresh name by appending the hash of the
-            ;; expression in which it appears.  However, this can fail
-            ;; for hash collisions, which is more common that one might
-            ;; think: Guile's hash function stops descending into cdr's
-            ;; at some point.  So, within an expansion unit, fall back
-            ;; to appending a uniquifying integer.
-            (define (ribcage-has-var? var)
-              (let lp ((labels (ribcage-labels ribcage)))
-                (and (pair? labels)
-                     (let ((wrapped (cdar labels)))
-                       (or (eq? (syntax-expression wrapped) var)
-                           (lp (cdr labels)))))))
-            (let lp ((unique var) (n 1))
-              (if (ribcage-has-var? unique)
-                  (let ((tail (string->symbol (number->string n))))
-                    (lp (symbol-append var '- tail) (1+ n)))
-                  unique)))
-          (define (fresh-derived-name id orig-form)
-            (ensure-fresh-name
-             (symbol-append
-              (syntax-expression id)
-              '-
-              (string->symbol
-               ;; FIXME: This encodes hash values into the ABI of
-               ;; compiled modules; a problem?
-               (number->string
-                (hash (syntax->datum orig-form) most-positive-fixnum)
-                16)))))
-          (define (parse body r w s m esew mod)
-            (let lp ((body body) (exps '()))
-              (if (null? body)
-                  exps
-                  (lp (cdr body)
-                      (append (parse1 (car body) r w s m esew mod)
-                              exps)))))
-          (define (parse1 x r w s m esew mod)
-            (define (current-module-for-expansion mod)
-              (case (car mod)
-                ;; If the module was just put in place for hygiene, in a
-                ;; top-level `begin' always recapture the current
-                ;; module.  If a user wants to override, then we need to
-                ;; use @@ or similar.
-                ((hygiene) (cons 'hygiene (module-name (current-module))))
-                (else mod)))
-            (call-with-values
-                (lambda ()
-                  (let ((mod (current-module-for-expansion mod)))
-                    (syntax-type x r w (source-annotation x) ribcage mod #f)))
-              (lambda (type value form e w s mod)
-                (case type
-                  ((define-form)
-                   (let* ((id (wrap value w mod))
-                          (var (if (macro-introduced-identifier? id)
-                                   (fresh-derived-name id x)
-                                   (syntax-expression id))))
-                     (record-definition! id var)
-                     (list
-                      (if (eq? m 'c&e)
-                          (let ((x (build-global-definition s mod var (expand 
e r w mod))))
-                            (top-level-eval x mod)
-                            (lambda () x))
-                          (call-with-values
-                              (lambda () (resolve-identifier id empty-wrap r 
mod #t))
-                            (lambda (type* value* mod*)
-                              ;; If the identifier to be bound is currently 
bound to a
-                              ;; macro, then immediately discard that binding.
-                              (if (eq? type* 'macro)
-                                  (top-level-eval (build-global-definition
-                                                   s mod var (build-void s))
-                                                  mod))
-                              (lambda ()
-                                (build-global-definition s mod var (expand e r 
w mod)))))))))
-                  ((define-syntax-form define-syntax-parameter-form)
-                   (let* ((id (wrap value w mod))
-                          (var (if (macro-introduced-identifier? id)
-                                   (fresh-derived-name id x)
-                                   (syntax-expression id))))
-                     (record-definition! id var)
-                     (case m
-                       ((c)
-                        (cond
-                         ((memq 'compile esew)
-                          (let ((e (expand-install-global mod var type (expand 
e r w mod))))
-                            (top-level-eval e mod)
-                            (if (memq 'load esew)
-                                (list (lambda () e))
-                                '())))
-                         ((memq 'load esew)
-                          (list (lambda ()
-                                  (expand-install-global mod var type (expand 
e r w mod)))))
-                         (else '())))
-                       ((c&e)
-                        (let ((e (expand-install-global mod var type (expand e 
r w mod))))
-                          (top-level-eval e mod)
-                          (list (lambda () e))))
-                       (else
-                        (if (memq 'eval esew)
-                            (top-level-eval
-                             (expand-install-global mod var type (expand e r w 
mod))
-                             mod))
-                        '()))))
-                  ((begin-form)
-                   (syntax-case e ()
-                     ((_ e1 ...)
-                      (parse #'(e1 ...) r w s m esew mod))))
-                  ((local-syntax-form)
-                   (expand-local-syntax value e r w s mod
-                                        (lambda (forms r w s mod)
-                                          (parse forms r w s m esew mod))))
-                  ((eval-when-form)
-                   (syntax-case e ()
-                     ((_ (x ...) e1 e2 ...)
-                      (let ((when-list (parse-when-list e #'(x ...)))
-                            (body #'(e1 e2 ...)))
-                        (define (recurse m esew)
-                          (parse body r w s m esew mod))
-                        (cond
-                         ((eq? m 'e)
-                          (if (memq 'eval when-list)
-                              (recurse (if (memq 'expand when-list) 'c&e 'e)
-                                       '(eval))
-                              (begin
-                                (if (memq 'expand when-list)
-                                    (top-level-eval
-                                     (expand-top-sequence body r w s 'e 
'(eval) mod)
-                                     mod))
-                                '())))
-                         ((memq 'load when-list)
-                          (if (or (memq 'compile when-list)
-                                  (memq 'expand when-list)
-                                  (and (eq? m 'c&e) (memq 'eval when-list)))
-                              (recurse 'c&e '(compile load))
-                              (if (memq m '(c c&e))
-                                  (recurse 'c '(load))
-                                  '())))
-                         ((or (memq 'compile when-list)
-                              (memq 'expand when-list)
-                              (and (eq? m 'c&e) (memq 'eval when-list)))
-                          (top-level-eval
-                           (expand-top-sequence body r w s 'e '(eval) mod)
-                           mod)
-                          '())
-                         (else
-                          '()))))))
-                  (else
+          ;; Resolved to a free variable that was introduced by this
+          ;; macro; continue to resolve this global by name.
+          (resolve-identifier (syntax-expression n)
+                              (syntax-wrap n)
+                              r
+                              (or (syntax-module n) mod)
+                              resolve-syntax-parameters?))))
+       ((symbol? n)
+        (resolve-global n (or (and (syntax? id)
+                                   (syntax-module id))
+                              mod)))
+       (else
+        (resolve-lexical n (or (and (syntax? id)
+                                    (syntax-module id))
+                               mod))))))
+
+  (define transformer-environment
+    (make-fluid
+     (lambda (k)
+       (error "called outside the dynamic extent of a syntax transformer"))))
+
+  (define (with-transformer-environment k)
+    ((fluid-ref transformer-environment) k))
+
+  ;; 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)
+      (let* ((mi (and (syntax? i) (syntax-module i)))
+             (mj (and (syntax? j) (syntax-module j)))
+             (ni (id-var-name i empty-wrap mi))
+             (nj (id-var-name j empty-wrap mj)))
+        (define (id-module-binding id mod)
+          (module-variable
+           (if mod
+               ;; The normal case.
+               (resolve-module (cdr mod))
+               ;; Either modules have not been booted, or we have a
+               ;; raw symbol coming in, which is possible.
+               (current-module))
+           (id-sym-name id)))
+        (cond
+         ((syntax? ni) (free-id=? ni j))
+         ((syntax? nj) (free-id=? i nj))
+         ((symbol? ni)
+          ;; `i' is not lexically bound.  Assert that `j' is free,
+          ;; and if so, compare their bindings, that they are either
+          ;; bound to the same variable, or both unbound and have
+          ;; the same name.
+          (and (eq? nj (id-sym-name j))
+               (let ((bi (id-module-binding i mi)))
+                 (if bi
+                     (eq? bi (id-module-binding j mj))
+                     (and (not (id-module-binding j mj))
+                          (eq? ni nj))))
+               (eq? (id-module-binding i mi) (id-module-binding j mj))))
+         (else
+          ;; Otherwise `i' is bound, so check that `j' is bound, and
+          ;; bound to the same thing.
+          (equal? ni nj))))))
+  
+  ;; 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? i) (syntax? j))
+          (and (eq? (syntax-expression i)
+                    (syntax-expression j))
+               (same-marks? (wrap-marks (syntax-wrap i))
+                            (wrap-marks (syntax-wrap j))))
+          (eq? i 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 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 defmod)
+      (source-wrap x w #f defmod)))
+
+  (define (wrap-syntax x w defmod)
+    (make-syntax (syntax-expression x)
+                 w
+                 (or (syntax-module x) defmod)
+                 (syntax-sourcev x)))
+  (define (source-wrap x w s defmod)
+    (cond
+     ((and (null? (wrap-marks w))
+           (null? (wrap-subst w))
+           (not defmod)
+           (not s))
+      x)
+     ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
+     ((null? x) x)
+     (else (make-syntax x w defmod s))))
+
+  ;; expanding
+
+  (define expand-sequence
+    (lambda (body r w s mod)
+      (build-sequence s
+                      (let dobody ((body body) (r r) (w w) (mod mod))
+                        (if (null? body)
+                            '()
+                            (let ((first (expand (car body) r w mod)))
+                              (cons first (dobody (cdr body) r w mod))))))))
+
+  ;; At top-level, we allow mixed definitions and expressions.  Like
+  ;; expand-body we expand in two passes.
+  ;;
+  ;; First, from left to right, we expand just enough to know what
+  ;; expressions are definitions, syntax definitions, and splicing
+  ;; statements (`begin').  If we anything needs evaluating at
+  ;; expansion-time, it is expanded directly.
+  ;;
+  ;; Otherwise we collect expressions to expand, in thunks, and then
+  ;; expand them all at the end.  This allows all syntax expanders
+  ;; visible in a toplevel sequence to be visible during the
+  ;; expansions of all normal definitions and expressions in the
+  ;; sequence.
+  ;;
+  (define expand-top-sequence
+    (lambda (body r w s m esew mod)
+      (let* ((r (cons '("placeholder" . (placeholder)) r))
+             (ribcage (make-empty-ribcage))
+             (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+        (define (record-definition! id var)
+          (let ((mod (cons 'hygiene (module-name (current-module)))))
+            ;; Ribcages map symbol+marks to names, mostly for
+            ;; resolving lexicals.  Here to add a mapping for toplevel
+            ;; definitions we also need to match the module.  So, we
+            ;; put it in the name instead, and make id-var-name handle
+            ;; the special case of names that are pairs.  See the
+            ;; comments in id-var-name for more.
+            (extend-ribcage! ribcage id
+                             (cons (or (syntax-module id) mod)
+                                   (wrap var top-wrap mod)))))
+        (define (macro-introduced-identifier? id)
+          (not (equal? (wrap-marks (syntax-wrap id)) '(top))))
+        (define (ensure-fresh-name var)
+          ;; If a macro introduces a top-level identifier, we attempt
+          ;; to give it a fresh name by appending the hash of the
+          ;; expression in which it appears.  However, this can fail
+          ;; for hash collisions, which is more common that one might
+          ;; think: Guile's hash function stops descending into cdr's
+          ;; at some point.  So, within an expansion unit, fall back
+          ;; to appending a uniquifying integer.
+          (define (ribcage-has-var? var)
+            (let lp ((labels (ribcage-labels ribcage)))
+              (and (pair? labels)
+                   (let ((wrapped (cdar labels)))
+                     (or (eq? (syntax-expression wrapped) var)
+                         (lp (cdr labels)))))))
+          (let lp ((unique var) (n 1))
+            (if (ribcage-has-var? unique)
+                (let ((tail (string->symbol (number->string n))))
+                  (lp (symbol-append var '- tail) (1+ n)))
+                unique)))
+        (define (fresh-derived-name id orig-form)
+          (ensure-fresh-name
+           (symbol-append
+            (syntax-expression id)
+            '-
+            (string->symbol
+             ;; FIXME: This encodes hash values into the ABI of
+             ;; compiled modules; a problem?
+             (number->string
+              (hash (syntax->datum orig-form) most-positive-fixnum)
+              16)))))
+        (define (parse body r w s m esew mod)
+          (let lp ((body body) (exps '()))
+            (if (null? body)
+                exps
+                (lp (cdr body)
+                    (append (parse1 (car body) r w s m esew mod)
+                            exps)))))
+        (define (parse1 x r w s m esew mod)
+          (define (current-module-for-expansion mod)
+            (case (car mod)
+              ;; If the module was just put in place for hygiene, in a
+              ;; top-level `begin' always recapture the current
+              ;; module.  If a user wants to override, then we need to
+              ;; use @@ or similar.
+              ((hygiene) (cons 'hygiene (module-name (current-module))))
+              (else mod)))
+          (call-with-values
+              (lambda ()
+                (let ((mod (current-module-for-expansion mod)))
+                  (syntax-type x r w (source-annotation x) ribcage mod #f)))
+            (lambda (type value form e w s mod)
+              (case type
+                ((define-form)
+                 (let* ((id (wrap value w mod))
+                        (var (if (macro-introduced-identifier? id)
+                                 (fresh-derived-name id x)
+                                 (syntax-expression id))))
+                   (record-definition! id var)
                    (list
                     (if (eq? m 'c&e)
-                        (let ((x (expand-expr type value form e r w s mod)))
+                        (let ((x (build-global-definition s mod var (expand e 
r w mod))))
                           (top-level-eval x mod)
                           (lambda () x))
-                        (lambda ()
-                          (expand-expr type value form e r w s mod)))))))))
-          (let ((exps (map (lambda (x) (x))
-                           (reverse (parse body r w s m esew mod)))))
-            (if (null? exps)
-                (build-void s)
-                (build-sequence s exps))))))
-    
-    (define expand-install-global
-      (lambda (mod name type e)
-        (build-global-definition
-         no-source
-         mod
-         name
-         (build-primcall
-          no-source
-          'make-syntax-transformer
-          (list (build-data no-source name)
-                (build-data no-source
-                            (if (eq? type 'define-syntax-parameter-form)
-                                'syntax-parameter
-                                'macro))
-                e)))))
-    
-    (define parse-when-list
-      (lambda (e when-list)
-        ;; `when-list' is syntax'd version of list of situations.  We
-        ;; could match these keywords lexically, via free-id=?, but then
-        ;; we twingle the definition of eval-when to the bindings of
-        ;; eval, load, expand, and compile, which is totally unintended.
-        ;; So do a symbolic match instead.
-        (let ((result (strip when-list)))
-          (let lp ((l result))
-            (if (null? l)
-                result
-                (if (memq (car l) '(compile load eval expand))
-                    (lp (cdr l))
-                    (syntax-violation 'eval-when "invalid situation" e
-                                      (car l))))))))
-
-    ;; syntax-type returns seven values: type, value, form, e, w, s, and
-    ;; mod. The first two are described in the table below.
-    ;;
-    ;;    type                   value         explanation
-    ;;    -------------------------------------------------------------------
-    ;;    core                   procedure     core singleton
-    ;;    core-form              procedure     core form
-    ;;    module-ref             procedure     @ or @@ singleton
-    ;;    lexical                name          lexical variable reference
-    ;;    global                 name          global variable reference
-    ;;    begin                  none          begin keyword
-    ;;    define                 none          define keyword
-    ;;    define-syntax          none          define-syntax keyword
-    ;;    define-syntax-parameter none         define-syntax-parameter keyword
-    ;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
-    ;;    eval-when              none          eval-when keyword
-    ;;    syntax                 level         pattern variable
-    ;;    displaced-lexical      none          displaced lexical identifier
-    ;;    lexical-call           name          call to lexical variable
-    ;;    global-call            name          call to global variable
-    ;;    primitive-call         name          call to primitive
-    ;;    call                   none          any other call
-    ;;    begin-form             none          begin expression
-    ;;    define-form            id            variable definition
-    ;;    define-syntax-form     id            syntax definition
-    ;;    define-syntax-parameter-form id      syntax parameter definition
-    ;;    local-syntax-form      rec?          syntax definition
-    ;;    eval-when-form         none          eval-when form
-    ;;    constant               none          self-evaluating datum
-    ;;    other                  none          anything else
-    ;;
-    ;; form is the entire form.  For definition forms (define-form,
-    ;; define-syntax-form, and define-syntax-parameter-form), e is the
-    ;; rhs expression.  For all others, e is the entire form.  w is the
-    ;; wrap for both form and e.  s is the source for the entire form.
-    ;; mod is the module for both form and e.
-    ;;
-    ;; syntax-type expands macros and unwraps as necessary to get to one
-    ;; of the forms above.  It also parses definition forms, although
-    ;; perhaps this should be done by the consumer.
-
-    (define syntax-type
-      (lambda (e r w s rib mod for-car?)
-        (cond
-         ((symbol? e)
-          (call-with-values (lambda () (resolve-identifier e w r mod #t))
-            (lambda (type value mod*)
-              (case type
-                ((macro)
-                 (if for-car?
-                     (values type value e e w s mod)
-                     (syntax-type (expand-macro value e r w s rib mod)
-                                  r empty-wrap s rib mod #f)))
+                        (call-with-values
+                            (lambda () (resolve-identifier id empty-wrap r mod 
#t))
+                          (lambda (type* value* mod*)
+                            ;; If the identifier to be bound is currently 
bound to a
+                            ;; macro, then immediately discard that binding.
+                            (if (eq? type* 'macro)
+                                (top-level-eval (build-global-definition
+                                                 s mod var (build-void s))
+                                                mod))
+                            (lambda ()
+                              (build-global-definition s mod var (expand e r w 
mod)))))))))
+                ((define-syntax-form define-syntax-parameter-form)
+                 (let* ((id (wrap value w mod))
+                        (var (if (macro-introduced-identifier? id)
+                                 (fresh-derived-name id x)
+                                 (syntax-expression id))))
+                   (record-definition! id var)
+                   (case m
+                     ((c)
+                      (cond
+                       ((memq 'compile esew)
+                        (let ((e (expand-install-global mod var type (expand e 
r w mod))))
+                          (top-level-eval e mod)
+                          (if (memq 'load esew)
+                              (list (lambda () e))
+                              '())))
+                       ((memq 'load esew)
+                        (list (lambda ()
+                                (expand-install-global mod var type (expand e 
r w mod)))))
+                       (else '())))
+                     ((c&e)
+                      (let ((e (expand-install-global mod var type (expand e r 
w mod))))
+                        (top-level-eval e mod)
+                        (list (lambda () e))))
+                     (else
+                      (if (memq 'eval esew)
+                          (top-level-eval
+                           (expand-install-global mod var type (expand e r w 
mod))
+                           mod))
+                      '()))))
+                ((begin-form)
+                 (syntax-case e ()
+                   ((_ e1 ...)
+                    (parse #'(e1 ...) r w s m esew mod))))
+                ((local-syntax-form)
+                 (expand-local-syntax value e r w s mod
+                                      (lambda (forms r w s mod)
+                                        (parse forms r w s m esew mod))))
+                ((eval-when-form)
+                 (syntax-case e ()
+                   ((_ (x ...) e1 e2 ...)
+                    (let ((when-list (parse-when-list e #'(x ...)))
+                          (body #'(e1 e2 ...)))
+                      (define (recurse m esew)
+                        (parse body r w s m esew mod))
+                      (cond
+                       ((eq? m 'e)
+                        (if (memq 'eval when-list)
+                            (recurse (if (memq 'expand when-list) 'c&e 'e)
+                                     '(eval))
+                            (begin
+                              (if (memq 'expand when-list)
+                                  (top-level-eval
+                                   (expand-top-sequence body r w s 'e '(eval) 
mod)
+                                   mod))
+                              '())))
+                       ((memq 'load when-list)
+                        (if (or (memq 'compile when-list)
+                                (memq 'expand when-list)
+                                (and (eq? m 'c&e) (memq 'eval when-list)))
+                            (recurse 'c&e '(compile load))
+                            (if (memq m '(c c&e))
+                                (recurse 'c '(load))
+                                '())))
+                       ((or (memq 'compile when-list)
+                            (memq 'expand when-list)
+                            (and (eq? m 'c&e) (memq 'eval when-list)))
+                        (top-level-eval
+                         (expand-top-sequence body r w s 'e '(eval) mod)
+                         mod)
+                        '())
+                       (else
+                        '()))))))
+                (else
+                 (list
+                  (if (eq? m 'c&e)
+                      (let ((x (expand-expr type value form e r w s mod)))
+                        (top-level-eval x mod)
+                        (lambda () x))
+                      (lambda ()
+                        (expand-expr type value form e r w s mod)))))))))
+        (let ((exps (map (lambda (x) (x))
+                         (reverse (parse body r w s m esew mod)))))
+          (if (null? exps)
+              (build-void s)
+              (build-sequence s exps))))))
+  
+  (define expand-install-global
+    (lambda (mod name type e)
+      (build-global-definition
+       no-source
+       mod
+       name
+       (build-primcall
+        no-source
+        'make-syntax-transformer
+        (list (build-data no-source name)
+              (build-data no-source
+                          (if (eq? type 'define-syntax-parameter-form)
+                              'syntax-parameter
+                              'macro))
+              e)))))
+  
+  (define parse-when-list
+    (lambda (e when-list)
+      ;; `when-list' is syntax'd version of list of situations.  We
+      ;; could match these keywords lexically, via free-id=?, but then
+      ;; we twingle the definition of eval-when to the bindings of
+      ;; eval, load, expand, and compile, which is totally unintended.
+      ;; So do a symbolic match instead.
+      (let ((result (strip when-list)))
+        (let lp ((l result))
+          (if (null? l)
+              result
+              (if (memq (car l) '(compile load eval expand))
+                  (lp (cdr l))
+                  (syntax-violation 'eval-when "invalid situation" e
+                                    (car l))))))))
+
+  ;; syntax-type returns seven values: type, value, form, e, w, s, and
+  ;; mod. The first two are described in the table below.
+  ;;
+  ;;    type                   value         explanation
+  ;;    -------------------------------------------------------------------
+  ;;    core                   procedure     core singleton
+  ;;    core-form              procedure     core form
+  ;;    module-ref             procedure     @ or @@ singleton
+  ;;    lexical                name          lexical variable reference
+  ;;    global                 name          global variable reference
+  ;;    begin                  none          begin keyword
+  ;;    define                 none          define keyword
+  ;;    define-syntax          none          define-syntax keyword
+  ;;    define-syntax-parameter none         define-syntax-parameter keyword
+  ;;    local-syntax           rec?          letrec-syntax/let-syntax keyword
+  ;;    eval-when              none          eval-when keyword
+  ;;    syntax                 level         pattern variable
+  ;;    displaced-lexical      none          displaced lexical identifier
+  ;;    lexical-call           name          call to lexical variable
+  ;;    global-call            name          call to global variable
+  ;;    primitive-call         name          call to primitive
+  ;;    call                   none          any other call
+  ;;    begin-form             none          begin expression
+  ;;    define-form            id            variable definition
+  ;;    define-syntax-form     id            syntax definition
+  ;;    define-syntax-parameter-form id      syntax parameter definition
+  ;;    local-syntax-form      rec?          syntax definition
+  ;;    eval-when-form         none          eval-when form
+  ;;    constant               none          self-evaluating datum
+  ;;    other                  none          anything else
+  ;;
+  ;; form is the entire form.  For definition forms (define-form,
+  ;; define-syntax-form, and define-syntax-parameter-form), e is the
+  ;; rhs expression.  For all others, e is the entire form.  w is the
+  ;; wrap for both form and e.  s is the source for the entire form.
+  ;; mod is the module for both form and e.
+  ;;
+  ;; syntax-type expands macros and unwraps as necessary to get to one
+  ;; of the forms above.  It also parses definition forms, although
+  ;; perhaps this should be done by the consumer.
+
+  (define syntax-type
+    (lambda (e r w s rib mod for-car?)
+      (cond
+       ((symbol? e)
+        (call-with-values (lambda () (resolve-identifier e w r mod #t))
+          (lambda (type value mod*)
+            (case type
+              ((macro)
+               (if for-car?
+                   (values type value e e w s mod)
+                   (syntax-type (expand-macro value e r w s rib mod)
+                                r empty-wrap s rib mod #f)))
+              ((global)
+               ;; Toplevel definitions may resolve to bindings with
+               ;; different names or in different modules.
+               (values type value e value w s mod*))
+              (else (values type value e e w s mod))))))
+       ((pair? e)
+        (let ((first (car e)))
+          (call-with-values
+              (lambda () (syntax-type first r w s rib mod #t))
+            (lambda (ftype fval fform fe fw fs fmod)
+              (case ftype
+                ((lexical)
+                 (values 'lexical-call fval e e w s mod))
                 ((global)
-                 ;; Toplevel definitions may resolve to bindings with
-                 ;; different names or in different modules.
-                 (values type value e value w s mod*))
-                (else (values type value e e w s mod))))))
-         ((pair? e)
-          (let ((first (car e)))
-            (call-with-values
-                (lambda () (syntax-type first r w s rib mod #t))
-              (lambda (ftype fval fform fe fw fs fmod)
-                (case ftype
-                  ((lexical)
-                   (values 'lexical-call fval e e w s mod))
-                  ((global)
-                   (if (equal? fmod '(primitive))
-                       (values 'primitive-call fval e e w s mod)
-                       ;; If we got here via an (@@ ...) expansion, we
-                       ;; need to make sure the fmod information is
-                       ;; propagated back correctly -- hence this
-                       ;; consing.
-                       (values 'global-call (make-syntax fval w fmod fs)
-                               e e w s mod)))
-                  ((macro)
-                   (syntax-type (expand-macro fval e r w s rib mod)
-                                r empty-wrap s rib mod for-car?))
-                  ((module-ref)
-                   (call-with-values (lambda () (fval e r w mod))
-                     (lambda (e r w s mod)
-                       (syntax-type e r w s rib mod for-car?))))
-                  ((core)
-                   (values 'core-form fval e e w s mod))
-                  ((local-syntax)
-                   (values 'local-syntax-form fval e e w s mod))
-                  ((begin)
-                   (values 'begin-form #f e e w s mod))
-                  ((eval-when)
-                   (values 'eval-when-form #f e e w s mod))
-                  ((define)
-                   (syntax-case e ()
-                     ((_ name val)
-                      (id? #'name)
-                      (values 'define-form #'name e #'val w s mod))
-                     ((_ (name . args) e1 e2 ...)
-                      (and (id? #'name)
-                           (valid-bound-ids? (lambda-var-list #'args)))
-                      ;; need lambda here...
-                      (values 'define-form (wrap #'name w mod)
-                              (wrap e w mod)
-                              (source-wrap
-                               (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
-                               empty-wrap s #f)
-                              empty-wrap s mod))
-                     ((_ name)
-                      (id? #'name)
-                      (values 'define-form (wrap #'name w mod)
-                              (wrap e w mod)
-                              #'(if #f #f)
-                              empty-wrap s mod))))
-                  ((define-syntax)
-                   (syntax-case e ()
-                     ((_ name val)
-                      (id? #'name)
-                      (values 'define-syntax-form #'name e #'val w s mod))))
-                  ((define-syntax-parameter)
-                   (syntax-case e ()
-                     ((_ name val)
-                      (id? #'name)
-                      (values 'define-syntax-parameter-form #'name e #'val w s 
mod))))
-                  (else
-                   (values 'call #f e e w s mod)))))))
-         ((syntax? e)
-          (syntax-type (syntax-expression e)
-                       r
-                       (join-wraps w (syntax-wrap e))
-                       (or (source-annotation e) s) rib
-                       (or (syntax-module e) mod) for-car?))
-         ((self-evaluating? e) (values 'constant #f e e w s mod))
-         (else (values 'other #f e e w s mod)))))
-
-    (define expand
-      (lambda (e r w mod)
-        (call-with-values
-            (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
-          (lambda (type value form e w s mod)
-            (expand-expr type value form e r w s mod)))))
-
-    (define expand-expr
-      (lambda (type value form e r w s mod)
-        (case type
-          ((lexical)
-           (build-lexical-reference 'value s e value))
-          ((core core-form)
-           ;; apply transformer
-           (value e r w s mod))
-          ((module-ref)
-           (call-with-values (lambda () (value e r w mod))
-             (lambda (e r w s mod)
-               (expand e r w mod))))
-          ((lexical-call)
-           (expand-call
-            (let ((id (car e)))
-              (build-lexical-reference 'fun (source-annotation id)
-                                       (if (syntax? id)
-                                           (syntax->datum id)
-                                           id)
-                                       value))
-            e r w s mod))
-          ((global-call)
-           (expand-call
-            (build-global-reference (or (source-annotation (car e)) s)
-                                    (if (syntax? value)
-                                        (syntax-expression value)
-                                        value)
-                                    (or (and (syntax? value)
-                                             (syntax-module value))
-                                        mod))
-            e r w s mod))
-          ((primitive-call)
-           (syntax-case e ()
-             ((_ e ...)
-              (build-primcall s
-                              value
-                              (map (lambda (e) (expand e r w mod))
-                                   #'(e ...))))))
-          ((constant) (build-data s (strip e)))
-          ((global) (build-global-reference s value mod))
-          ((call) (expand-call (expand (car e) r w mod) e r w s mod))
-          ((begin-form)
-           (syntax-case e ()
-             ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
-             ((_)
-              (syntax-violation #f "sequence of zero expressions"
-                                (source-wrap e w s mod)))))
-          ((local-syntax-form)
-           (expand-local-syntax value e r w s mod expand-sequence))
-          ((eval-when-form)
-           (syntax-case e ()
-             ((_ (x ...) e1 e2 ...)
-              (let ((when-list (parse-when-list e #'(x ...))))
-                (if (memq 'eval when-list)
-                    (expand-sequence #'(e1 e2 ...) r w s mod)
-                    (expand-void))))))
-          ((define-form define-syntax-form define-syntax-parameter-form)
-           (syntax-violation #f "definition in expression context, where 
definitions are not allowed,"
-                             (source-wrap form w s mod)))
-          ((syntax)
-           (syntax-violation #f "reference to pattern variable outside syntax 
form"
-                             (source-wrap e w s mod)))
-          ((displaced-lexical)
-           (syntax-violation #f "reference to identifier outside its scope"
-                             (source-wrap e w s mod)))
-          (else (syntax-violation #f "unexpected syntax"
-                                  (source-wrap e w s mod))))))
-
-    (define expand-call
-      (lambda (x e r w s mod)
-        (syntax-case e ()
-          ((e0 e1 ...)
-           (build-call s x
-                       (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
-
-    ;; (What follows is my interpretation of what's going on here -- Andy)
-    ;;
-    ;; A macro takes an expression, a tree, the leaves of which are identifiers
-    ;; and datums. Identifiers are symbols along with a wrap and a module. For
-    ;; efficiency, subtrees that share wraps and modules may be grouped as one
-    ;; syntax object.
+                 (if (equal? fmod '(primitive))
+                     (values 'primitive-call fval e e w s mod)
+                     ;; If we got here via an (@@ ...) expansion, we
+                     ;; need to make sure the fmod information is
+                     ;; propagated back correctly -- hence this
+                     ;; consing.
+                     (values 'global-call (make-syntax fval w fmod fs)
+                             e e w s mod)))
+                ((macro)
+                 (syntax-type (expand-macro fval e r w s rib mod)
+                              r empty-wrap s rib mod for-car?))
+                ((module-ref)
+                 (call-with-values (lambda () (fval e r w mod))
+                   (lambda (e r w s mod)
+                     (syntax-type e r w s rib mod for-car?))))
+                ((core)
+                 (values 'core-form fval e e w s mod))
+                ((local-syntax)
+                 (values 'local-syntax-form fval e e w s mod))
+                ((begin)
+                 (values 'begin-form #f e e w s mod))
+                ((eval-when)
+                 (values 'eval-when-form #f e e w s mod))
+                ((define)
+                 (syntax-case e ()
+                   ((_ name val)
+                    (id? #'name)
+                    (values 'define-form #'name e #'val w s mod))
+                   ((_ (name . args) e1 e2 ...)
+                    (and (id? #'name)
+                         (valid-bound-ids? (lambda-var-list #'args)))
+                    ;; need lambda here...
+                    (values 'define-form (wrap #'name w mod)
+                            (wrap e w mod)
+                            (source-wrap
+                             (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
+                             empty-wrap s #f)
+                            empty-wrap s mod))
+                   ((_ name)
+                    (id? #'name)
+                    (values 'define-form (wrap #'name w mod)
+                            (wrap e w mod)
+                            #'(if #f #f)
+                            empty-wrap s mod))))
+                ((define-syntax)
+                 (syntax-case e ()
+                   ((_ name val)
+                    (id? #'name)
+                    (values 'define-syntax-form #'name e #'val w s mod))))
+                ((define-syntax-parameter)
+                 (syntax-case e ()
+                   ((_ name val)
+                    (id? #'name)
+                    (values 'define-syntax-parameter-form #'name e #'val w s 
mod))))
+                (else
+                 (values 'call #f e e w s mod)))))))
+       ((syntax? e)
+        (syntax-type (syntax-expression e)
+                     r
+                     (join-wraps w (syntax-wrap e))
+                     (or (source-annotation e) s) rib
+                     (or (syntax-module e) mod) for-car?))
+       ((self-evaluating? e) (values 'constant #f e e w s mod))
+       (else (values 'other #f e e w s mod)))))
+
+  (define expand
+    (lambda (e r w mod)
+      (call-with-values
+          (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+        (lambda (type value form e w s mod)
+          (expand-expr type value form e r w s mod)))))
+
+  (define expand-expr
+    (lambda (type value form e r w s mod)
+      (case type
+        ((lexical)
+         (build-lexical-reference 'value s e value))
+        ((core core-form)
+         ;; apply transformer
+         (value e r w s mod))
+        ((module-ref)
+         (call-with-values (lambda () (value e r w mod))
+           (lambda (e r w s mod)
+             (expand e r w mod))))
+        ((lexical-call)
+         (expand-call
+          (let ((id (car e)))
+            (build-lexical-reference 'fun (source-annotation id)
+                                     (if (syntax? id)
+                                         (syntax->datum id)
+                                         id)
+                                     value))
+          e r w s mod))
+        ((global-call)
+         (expand-call
+          (build-global-reference (or (source-annotation (car e)) s)
+                                  (if (syntax? value)
+                                      (syntax-expression value)
+                                      value)
+                                  (or (and (syntax? value)
+                                           (syntax-module value))
+                                      mod))
+          e r w s mod))
+        ((primitive-call)
+         (syntax-case e ()
+           ((_ e ...)
+            (build-primcall s
+                            value
+                            (map (lambda (e) (expand e r w mod))
+                                 #'(e ...))))))
+        ((constant) (build-data s (strip e)))
+        ((global) (build-global-reference s value mod))
+        ((call) (expand-call (expand (car e) r w mod) e r w s mod))
+        ((begin-form)
+         (syntax-case e ()
+           ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
+           ((_)
+            (syntax-violation #f "sequence of zero expressions"
+                              (source-wrap e w s mod)))))
+        ((local-syntax-form)
+         (expand-local-syntax value e r w s mod expand-sequence))
+        ((eval-when-form)
+         (syntax-case e ()
+           ((_ (x ...) e1 e2 ...)
+            (let ((when-list (parse-when-list e #'(x ...))))
+              (if (memq 'eval when-list)
+                  (expand-sequence #'(e1 e2 ...) r w s mod)
+                  (expand-void))))))
+        ((define-form define-syntax-form define-syntax-parameter-form)
+         (syntax-violation #f "definition in expression context, where 
definitions are not allowed,"
+                           (source-wrap form w s mod)))
+        ((syntax)
+         (syntax-violation #f "reference to pattern variable outside syntax 
form"
+                           (source-wrap e w s mod)))
+        ((displaced-lexical)
+         (syntax-violation #f "reference to identifier outside its scope"
+                           (source-wrap e w s mod)))
+        (else (syntax-violation #f "unexpected syntax"
+                                (source-wrap e w s mod))))))
+
+  (define expand-call
+    (lambda (x e r w s mod)
+      (syntax-case e ()
+        ((e0 e1 ...)
+         (build-call s x
+                     (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
+
+  ;; (What follows is my interpretation of what's going on here -- Andy)
+  ;;
+  ;; A macro takes an expression, a tree, the leaves of which are identifiers
+  ;; and datums. Identifiers are symbols along with a wrap and a module. For
+  ;; efficiency, subtrees that share wraps and modules may be grouped as one
+  ;; syntax object.
+  ;;
+  ;; Going into the expansion, the expression is given an anti-mark, which
+  ;; logically propagates to all leaves. Then, in the new expression returned
+  ;; from the transfomer, if we see an expression with an anti-mark, we know it
+  ;; pertains to the original expression; conversely, expressions without the
+  ;; anti-mark are known to be introduced by the transformer.
+  ;;
+  ;; OK, good until now. We know this algorithm does lexical scoping
+  ;; appropriately because it's widely known in the literature, and psyntax is
+  ;; widely used. But what about modules? Here we're on our own. What we do is
+  ;; to mark the module of expressions produced by a macro as pertaining to the
+  ;; module that was current when the macro was defined -- that is, free
+  ;; identifiers introduced by a macro are scoped in the macro's module, not in
+  ;; the expansion's module. Seems to work well.
+  ;;
+  ;; The only wrinkle is when we want a macro to expand to code in another
+  ;; module, as is the case for the r6rs `library' form -- the body expressions
+  ;; should be scoped relative the the new module, the one defined by the 
macro.
+  ;; For that, use `(@@ mod-name body)'.
+  ;;
+  ;; Part of the macro output will be from the site of the macro use and part
+  ;; from the macro definition. We allow source information from the macro use
+  ;; to pass through, but we annotate the parts coming from the macro with the
+  ;; source location information corresponding to the macro use. It would be
+  ;; really nice if we could also annotate introduced expressions with the
+  ;; locations corresponding to the macro definition, but that is not yet
+  ;; possible.
+  (define expand-macro
+    (lambda (p e r w s rib mod)
+      (define (decorate-source x)
+        (source-wrap x empty-wrap s #f))
+      (define (map* f x)
+        (cond
+         ((null? x) x)
+         ((pair? x) (cons (f (car x)) (map* f (cdr x))))
+         (else (f x))))
+      (define rebuild-macro-output
+        (lambda (x m)
+          (cond ((pair? x)
+                 (decorate-source
+                  (map* (lambda (x) (rebuild-macro-output x m)) x)))
+                ((syntax? x)
+                 (let ((w (syntax-wrap x)))
+                   (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
+                     (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+                         ;; output is from original text
+                         (wrap-syntax
+                          x
+                          (make-wrap (cdr ms)
+                                     (if rib
+                                         (cons rib (cdr ss))
+                                         (cdr ss)))
+                          mod)
+                         ;; output introduced by macro
+                         (wrap-syntax
+                          x
+                          (make-wrap (cons m ms)
+                                     (if rib
+                                         (cons rib (cons 'shift ss))
+                                         (cons 'shift ss)))
+                          mod)))))
+                
+                ((vector? x)
+                 (let* ((n (vector-length x))
+                        (v (make-vector n)))
+                   (do ((i 0 (1+ i)))
+                       ((= i n) v)
+                     (vector-set! v i
+                                  (rebuild-macro-output (vector-ref x i) m)))
+                   (decorate-source v)))
+                ((symbol? x)
+                 (syntax-violation #f "encountered raw symbol in macro output"
+                                   (source-wrap e w (wrap-subst w) mod) x))
+                (else (decorate-source x)))))
+      (with-fluids ((transformer-environment
+                     (lambda (k) (k e r w s rib mod))))
+        (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
+                              (new-mark)))))
+
+  (define expand-body
+    ;; 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:
     ;;
-    ;; Going into the expansion, the expression is given an anti-mark, which
-    ;; logically propagates to all leaves. Then, in the new expression returned
-    ;; from the transfomer, if we see an expression with an anti-mark, we know 
it
-    ;; pertains to the original expression; conversely, expressions without the
-    ;; anti-mark are known to be introduced by the transformer.
+    ;;   (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).
     ;;
-    ;; OK, good until now. We know this algorithm does lexical scoping
-    ;; appropriately because it's widely known in the literature, and psyntax 
is
-    ;; widely used. But what about modules? Here we're on our own. What we do 
is
-    ;; to mark the module of expressions produced by a macro as pertaining to 
the
-    ;; module that was current when the macro was defined -- that is, free
-    ;; identifiers introduced by a macro are scoped in the macro's module, not 
in
-    ;; the expansion's module. Seems to work well.
+    ;; 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.
     ;;
-    ;; The only wrinkle is when we want a macro to expand to code in another
-    ;; module, as is the case for the r6rs `library' form -- the body 
expressions
-    ;; should be scoped relative the the new module, the one defined by the 
macro.
-    ;; For that, use `(@@ mod-name body)'.
+    ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
+    ;; into the body.
     ;;
-    ;; Part of the macro output will be from the site of the macro use and part
-    ;; from the macro definition. We allow source information from the macro 
use
-    ;; to pass through, but we annotate the parts coming from the macro with 
the
-    ;; source location information corresponding to the macro use. It would be
-    ;; really nice if we could also annotate introduced expressions with the
-    ;; locations corresponding to the macro definition, but that is not yet
-    ;; possible.
-    (define expand-macro
-      (lambda (p e r w s rib mod)
-        (define (decorate-source x)
-          (source-wrap x empty-wrap s #f))
-        (define (map* f x)
-          (cond
-           ((null? x) x)
-           ((pair? x) (cons (f (car x)) (map* f (cdr x))))
-           (else (f x))))
-        (define rebuild-macro-output
-          (lambda (x m)
-            (cond ((pair? x)
-                   (decorate-source
-                    (map* (lambda (x) (rebuild-macro-output x m)) x)))
-                  ((syntax? x)
-                   (let ((w (syntax-wrap x)))
-                     (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
-                       (if (and (pair? ms) (eq? (car ms) the-anti-mark))
-                           ;; output is from original text
-                           (wrap-syntax
-                            x
-                            (make-wrap (cdr ms)
-                                       (if rib
-                                           (cons rib (cdr ss))
-                                           (cdr ss)))
-                            mod)
-                           ;; output introduced by macro
-                           (wrap-syntax
-                            x
-                            (make-wrap (cons m ms)
-                                       (if rib
-                                           (cons rib (cons 'shift ss))
-                                           (cons 'shift ss)))
-                            mod)))))
-                
-                  ((vector? x)
-                   (let* ((n (vector-length x))
-                          (v (make-vector n)))
-                     (do ((i 0 (1+ i)))
-                         ((= i n) v)
-                       (vector-set! v i
-                                    (rebuild-macro-output (vector-ref x i) m)))
-                     (decorate-source v)))
-                  ((symbol? x)
-                   (syntax-violation #f "encountered raw symbol in macro 
output"
-                                     (source-wrap e w (wrap-subst w) mod) x))
-                  (else (decorate-source x)))))
-        (with-fluids ((transformer-environment
-                       (lambda (k) (k e r w s rib mod))))
-          (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
-                                (new-mark)))))
-
-    (define expand-body
-      ;; 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 (body outer-form r w mod)
-        (let* ((r (cons '("placeholder" . (placeholder)) r))
-               (ribcage (make-empty-ribcage))
-               (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
-          (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
-                      (ids '()) (labels '())
-                      (var-ids '()) (vars '()) (vals '()) (bindings '())
-                      (expand-tail-expr #f))
-            (cond
-             ((null? body)
-              (unless expand-tail-expr
-                (when (null? ids)
-                  (syntax-violation #f "empty body" outer-form))
-                (syntax-violation #f "body should end with an expression" 
outer-form))
-              (unless (valid-bound-ids? ids)
-                (syntax-violation
-                 #f "invalid or duplicate identifier in definition"
-                 outer-form))
-              (set-cdr! r (extend-env labels bindings (cdr r)))
-              (let ((src (source-annotation outer-form)))
-                (let lp ((var-ids var-ids) (vars vars) (vals vals)
-                         (tail (expand-tail-expr)))
-                  (cond
-                   ((null? var-ids) tail)
-                   ((not (car var-ids))
-                    (lp (cdr var-ids) (cdr vars) (cdr vals)
-                        (make-seq src ((car vals)) tail)))
-                   (else
-                    (let ((var-ids (map (lambda (id)
-                                          (if id (syntax->datum id) '_))
-                                        (reverse var-ids)))
-                          (vars (map (lambda (var) (or var (gen-lexical '_)))
-                                     (reverse vars)))
-                          (vals (map (lambda (expand-expr id)
-                                       (if id
-                                           (expand-expr)
-                                           (make-seq src
-                                                     (expand-expr)
-                                                     (build-void src))))
-                                     (reverse vals) (reverse var-ids))))
-                      (build-letrec src #t var-ids vars vals tail)))))))
-             (expand-tail-expr
-              (parse body ids labels
-                     (cons #f var-ids)
-                     (cons #f vars)
-                     (cons expand-tail-expr vals)
-                     bindings #f))
-             (else
-              (let ((e (cdar body)) (er (caar body)) (body (cdr body)))
-                (call-with-values
-                    (lambda () (syntax-type e er empty-wrap (source-annotation 
e) ribcage mod #f))
-                  (lambda (type value form e w s mod)
-                    (case type
-                      ((define-form)
-                       (let ((id (wrap value w mod)) (label (gen-label)))
-                         (let ((var (gen-var id)))
-                           (extend-ribcage! ribcage id label)
-                           (parse body
-                                  (cons id ids) (cons label labels)
-                                  (cons id var-ids)
-                                  (cons var vars)
-                                  (cons (let ((wrapped (source-wrap e w s 
mod)))
-                                          (lambda ()
-                                            (expand wrapped er empty-wrap 
mod)))
-                                        vals)
-                                  (cons (make-binding 'lexical var) bindings)
-                                  #f))))
-                      ((define-syntax-form)
-                       (let ((id (wrap value w mod))
-                             (label (gen-label))
-                             (trans-r (macros-only-env er)))
-                         (extend-ribcage! ribcage id label)
-                         ;; As required by R6RS, evaluate the right-hand-sides 
of internal
-                         ;; syntax definition forms and add their transformers 
to the
-                         ;; compile-time environment immediately, so that the 
newly-defined
-                         ;; keywords may be used in definition context within 
the same
-                         ;; lexical contour.
-                         (set-cdr! r (extend-env
-                                      (list label)
-                                      (list (make-binding
-                                             'macro
-                                             (eval-local-transformer
-                                              (expand e trans-r w mod)
-                                              mod)))
-                                      (cdr r)))
-                         (parse body (cons id ids)
-                                labels var-ids vars vals bindings #f)))
-                      ((define-syntax-parameter-form)
-                       ;; Same as define-syntax-form, different binding type 
though.
-                       (let ((id (wrap value w mod))
-                             (label (gen-label))
-                             (trans-r (macros-only-env er)))
-                         (extend-ribcage! ribcage id label)
-                         (set-cdr! r (extend-env
-                                      (list label)
-                                      (list (make-binding
-                                             'syntax-parameter
-                                             (eval-local-transformer
-                                              (expand e trans-r w mod)
-                                              mod)))
-                                      (cdr r)))
-                         (parse body (cons id ids)
-                                labels var-ids vars vals bindings #f)))
-                      ((begin-form)
-                       (syntax-case e ()
-                         ((_ e1 ...)
-                          (parse (let f ((forms #'(e1 ...)))
-                                   (if (null? forms)
-                                       body
-                                       (cons (cons er (wrap (car forms) w mod))
-                                             (f (cdr forms)))))
-                                 ids labels var-ids vars vals bindings #f))))
-                      ((local-syntax-form)
-                       (expand-local-syntax
-                        value e er w s mod
-                        (lambda (forms er w s mod)
-                          (parse (let f ((forms forms))
-                                   (if (null? forms)
-                                       body
-                                       (cons (cons er (wrap (car forms) w mod))
-                                             (f (cdr forms)))))
-                                 ids labels var-ids vars vals bindings #f))))
-                      (else           ; An expression, not a definition.
-                       (let ((wrapped (source-wrap e w s mod)))
-                         (parse body ids labels var-ids vars vals bindings
-                                (lambda ()
-                                  (expand wrapped er empty-wrap 
mod)))))))))))))))
-
-    (define expand-local-syntax
-      (lambda (rec? e r w s mod k)
-        (syntax-case e ()
-          ((_ ((id val) ...) e1 e2 ...)
-           (let ((ids #'(id ...)))
-             (if (not (valid-bound-ids? ids))
-                 (syntax-violation #f "duplicate bound keyword" e)
-                 (let ((labels (gen-labels ids)))
-                   (let ((new-w (make-binding-wrap ids labels w)))
-                     (k #'(e1 e2 ...)
-                        (extend-env
-                         labels
-                         (let ((w (if rec? new-w w))
-                               (trans-r (macros-only-env r)))
-                           (map (lambda (x)
-                                  (make-binding 'macro
-                                                (eval-local-transformer
-                                                 (expand x trans-r w mod)
-                                                 mod)))
-                                #'(val ...)))
-                         r)
-                        new-w
-                        s
-                        mod))))))
-          (_ (syntax-violation #f "bad local syntax definition"
-                               (source-wrap e w s mod))))))
-
-    (define eval-local-transformer
-      (lambda (expanded mod)
-        (let ((p (local-eval expanded mod)))
-          (if (procedure? p)
-              p
-              (syntax-violation #f "nonprocedure transformer" p)))))
-
-    (define expand-void
-      (lambda ()
-        (build-void no-source)))
-
-    (define ellipsis?
-      (lambda (e r mod)
-        (and (nonsymbol-id? e)
-             ;; If there is a binding for the special identifier
-             ;; #{ $sc-ellipsis }# in the lexical environment of E,
-             ;; and if the associated binding type is 'ellipsis',
-             ;; then the binding's value specifies the custom ellipsis
-             ;; identifier within that lexical environment, and the
-             ;; comparison is done using 'bound-id=?'.
-             (call-with-values
-                 (lambda () (resolve-identifier
-                             (make-syntax '#{ $sc-ellipsis }#
-                                          (syntax-wrap e)
-                                          (or (syntax-module e) mod)
-                                          #f)
-                             empty-wrap r mod #f))
-               (lambda (type value mod)
-                 (if (eq? type 'ellipsis)
-                     (bound-id=? e value)
-                     (free-id=? e #'(... ...))))))))
-
-    (define lambda-formals
-      (lambda (orig-args)
-        (define (req args rreq)
-          (syntax-case args ()
-            (()
-             (check (reverse rreq) #f))
-            ((a . b) (id? #'a)
-             (req #'b (cons #'a rreq)))
-            (r (id? #'r)
-               (check (reverse rreq) #'r))
-            (else
-             (syntax-violation 'lambda "invalid argument list" orig-args 
args))))
-        (define (check req rest)
-          (cond
-           ((distinct-bound-ids? (if rest (cons rest req) req))
-            (values req #f rest #f))
-           (else
-            (syntax-violation 'lambda "duplicate identifier in argument list"
-                              orig-args))))
-        (req orig-args '())))
-
-    (define expand-simple-lambda
-      (lambda (e r w s mod req rest meta body)
-        (let* ((ids (if rest (append req (list rest)) req))
-               (vars (map gen-var ids))
-               (labels (gen-labels ids)))
-          (build-simple-lambda
-           s
-           (map syntax->datum req) (and rest (syntax->datum rest)) vars
-           meta
-           (expand-body body (source-wrap e w s mod)
-                        (extend-var-env labels vars r)
-                        (make-binding-wrap ids labels w)
-                        mod)))))
-
-    (define lambda*-formals
-      (lambda (orig-args)
-        (define (req args rreq)
-          (syntax-case args ()
-            (()
-             (check (reverse rreq) '() #f '()))
-            ((a . b) (id? #'a)
-             (req #'b (cons #'a rreq)))
-            ((a . b) (eq? (syntax->datum #'a) #:optional)
-             (opt #'b (reverse rreq) '()))
-            ((a . b) (eq? (syntax->datum #'a) #:key)
-             (key #'b (reverse rreq) '() '()))
-            ((a b) (eq? (syntax->datum #'a) #:rest)
-             (rest #'b (reverse rreq) '() '()))
-            (r (id? #'r)
-               (rest #'r (reverse rreq) '() '()))
-            (else
-             (syntax-violation 'lambda* "invalid argument list" orig-args 
args))))
-        (define (opt args req ropt)
-          (syntax-case args ()
-            (()
-             (check req (reverse ropt) #f '()))
-            ((a . b) (id? #'a)
-             (opt #'b req (cons #'(a #f) ropt)))
-            (((a init) . b) (id? #'a)
-             (opt #'b req (cons #'(a init) ropt)))
-            ((a . b) (eq? (syntax->datum #'a) #:key)
-             (key #'b req (reverse ropt) '()))
-            ((a b) (eq? (syntax->datum #'a) #:rest)
-             (rest #'b req (reverse ropt) '()))
-            (r (id? #'r)
-               (rest #'r req (reverse ropt) '()))
-            (else
-             (syntax-violation 'lambda* "invalid optional argument list"
-                               orig-args args))))
-        (define (key args req opt rkey)
-          (syntax-case args ()
-            (()
-             (check req opt #f (cons #f (reverse rkey))))
-            ((a . b) (id? #'a)
-             (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
-               (key #'b req opt (cons #'(k a #f) rkey))))
-            (((a init) . b) (id? #'a)
-             (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
-               (key #'b req opt (cons #'(k a init) rkey))))
-            (((a init k) . b) (and (id? #'a)
-                                   (keyword? (syntax->datum #'k)))
-             (key #'b req opt (cons #'(k a init) rkey)))
-            ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
-             (check req opt #f (cons #t (reverse rkey))))
-            ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
-                            (eq? (syntax->datum #'a) #:rest))
-             (rest #'b req opt (cons #t (reverse rkey))))
-            ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
-                            (id? #'r))
-             (rest #'r req opt (cons #t (reverse rkey))))
-            ((a b) (eq? (syntax->datum #'a) #:rest)
-             (rest #'b req opt (cons #f (reverse rkey))))
-            (r (id? #'r)
-               (rest #'r req opt (cons #f (reverse rkey))))
-            (else
-             (syntax-violation 'lambda* "invalid keyword argument list"
-                               orig-args args))))
-        (define (rest args req opt kw)
-          (syntax-case args ()
-            (r (id? #'r)
-               (check req opt #'r kw))
-            (else
-             (syntax-violation 'lambda* "invalid rest argument"
-                               orig-args args))))
-        (define (check req opt rest kw)
-          (cond
-           ((distinct-bound-ids?
-             (append req (map car opt) (if rest (list rest) '())
-                     (if (pair? kw) (map cadr (cdr kw)) '())))
-            (values req opt rest kw))
-           (else
-            (syntax-violation 'lambda* "duplicate identifier in argument list"
-                              orig-args))))
-        (req orig-args '())))
-
-    (define expand-lambda-case
-      (lambda (e r w s mod get-formals clauses)
-        (define (parse-req req opt rest kw body)
-          (let ((vars (map gen-var req))
-                (labels (gen-labels req)))
-            (let ((r* (extend-var-env labels vars r))
-                  (w* (make-binding-wrap req labels w)))
-              (parse-opt (map syntax->datum req)
-                         opt rest kw body (reverse vars) r* w* '() '()))))
-        (define (parse-opt req opt rest kw body vars r* w* out inits)
+    ;; outer-form is fully wrapped w/source
+    (lambda (body outer-form r w mod)
+      (let* ((r (cons '("placeholder" . (placeholder)) r))
+             (ribcage (make-empty-ribcage))
+             (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+        (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
+                    (ids '()) (labels '())
+                    (var-ids '()) (vars '()) (vals '()) (bindings '())
+                    (expand-tail-expr #f))
           (cond
-           ((pair? opt)
-            (syntax-case (car opt) ()
-              ((id i)
-               (let* ((v (gen-var #'id))
-                      (l (gen-labels (list v)))
-                      (r** (extend-var-env l (list v) r*))
-                      (w** (make-binding-wrap (list #'id) l w*)))
-                 (parse-opt req (cdr opt) rest kw body (cons v vars)
-                            r** w** (cons (syntax->datum #'id) out)
-                            (cons (expand #'i r* w* mod) inits))))))
-           (rest
-            (let* ((v (gen-var rest))
-                   (l (gen-labels (list v)))
-                   (r* (extend-var-env l (list v) r*))
-                   (w* (make-binding-wrap (list rest) l w*)))
-              (parse-kw req (if (pair? out) (reverse out) #f)
-                        (syntax->datum rest)
-                        (if (pair? kw) (cdr kw) kw)
-                        body (cons v vars) r* w* 
-                        (if (pair? kw) (car kw) #f)
-                        '() inits)))
+           ((null? body)
+            (unless expand-tail-expr
+              (when (null? ids)
+                (syntax-violation #f "empty body" outer-form))
+              (syntax-violation #f "body should end with an expression" 
outer-form))
+            (unless (valid-bound-ids? ids)
+              (syntax-violation
+               #f "invalid or duplicate identifier in definition"
+               outer-form))
+            (set-cdr! r (extend-env labels bindings (cdr r)))
+            (let ((src (source-annotation outer-form)))
+              (let lp ((var-ids var-ids) (vars vars) (vals vals)
+                       (tail (expand-tail-expr)))
+                (cond
+                 ((null? var-ids) tail)
+                 ((not (car var-ids))
+                  (lp (cdr var-ids) (cdr vars) (cdr vals)
+                      (make-seq src ((car vals)) tail)))
+                 (else
+                  (let ((var-ids (map (lambda (id)
+                                        (if id (syntax->datum id) '_))
+                                      (reverse var-ids)))
+                        (vars (map (lambda (var) (or var (gen-lexical '_)))
+                                   (reverse vars)))
+                        (vals (map (lambda (expand-expr id)
+                                     (if id
+                                         (expand-expr)
+                                         (make-seq src
+                                                   (expand-expr)
+                                                   (build-void src))))
+                                   (reverse vals) (reverse var-ids))))
+                    (build-letrec src #t var-ids vars vals tail)))))))
+           (expand-tail-expr
+            (parse body ids labels
+                   (cons #f var-ids)
+                   (cons #f vars)
+                   (cons expand-tail-expr vals)
+                   bindings #f))
            (else
-            (parse-kw req (if (pair? out) (reverse out) #f) #f
+            (let ((e (cdar body)) (er (caar body)) (body (cdr body)))
+              (call-with-values
+                  (lambda () (syntax-type e er empty-wrap (source-annotation 
e) ribcage mod #f))
+                (lambda (type value form e w s mod)
+                  (case type
+                    ((define-form)
+                     (let ((id (wrap value w mod)) (label (gen-label)))
+                       (let ((var (gen-var id)))
+                         (extend-ribcage! ribcage id label)
+                         (parse body
+                                (cons id ids) (cons label labels)
+                                (cons id var-ids)
+                                (cons var vars)
+                                (cons (let ((wrapped (source-wrap e w s mod)))
+                                        (lambda ()
+                                          (expand wrapped er empty-wrap mod)))
+                                      vals)
+                                (cons (make-binding 'lexical var) bindings)
+                                #f))))
+                    ((define-syntax-form)
+                     (let ((id (wrap value w mod))
+                           (label (gen-label))
+                           (trans-r (macros-only-env er)))
+                       (extend-ribcage! ribcage id label)
+                       ;; As required by R6RS, evaluate the right-hand-sides 
of internal
+                       ;; syntax definition forms and add their transformers 
to the
+                       ;; compile-time environment immediately, so that the 
newly-defined
+                       ;; keywords may be used in definition context within 
the same
+                       ;; lexical contour.
+                       (set-cdr! r (extend-env
+                                    (list label)
+                                    (list (make-binding
+                                           'macro
+                                           (eval-local-transformer
+                                            (expand e trans-r w mod)
+                                            mod)))
+                                    (cdr r)))
+                       (parse body (cons id ids)
+                              labels var-ids vars vals bindings #f)))
+                    ((define-syntax-parameter-form)
+                     ;; Same as define-syntax-form, different binding type 
though.
+                     (let ((id (wrap value w mod))
+                           (label (gen-label))
+                           (trans-r (macros-only-env er)))
+                       (extend-ribcage! ribcage id label)
+                       (set-cdr! r (extend-env
+                                    (list label)
+                                    (list (make-binding
+                                           'syntax-parameter
+                                           (eval-local-transformer
+                                            (expand e trans-r w mod)
+                                            mod)))
+                                    (cdr r)))
+                       (parse body (cons id ids)
+                              labels var-ids vars vals bindings #f)))
+                    ((begin-form)
+                     (syntax-case e ()
+                       ((_ e1 ...)
+                        (parse (let f ((forms #'(e1 ...)))
+                                 (if (null? forms)
+                                     body
+                                     (cons (cons er (wrap (car forms) w mod))
+                                           (f (cdr forms)))))
+                               ids labels var-ids vars vals bindings #f))))
+                    ((local-syntax-form)
+                     (expand-local-syntax
+                      value e er w s mod
+                      (lambda (forms er w s mod)
+                        (parse (let f ((forms forms))
+                                 (if (null? forms)
+                                     body
+                                     (cons (cons er (wrap (car forms) w mod))
+                                           (f (cdr forms)))))
+                               ids labels var-ids vars vals bindings #f))))
+                    (else           ; An expression, not a definition.
+                     (let ((wrapped (source-wrap e w s mod)))
+                       (parse body ids labels var-ids vars vals bindings
+                              (lambda ()
+                                (expand wrapped er empty-wrap 
mod)))))))))))))))
+
+  (define expand-local-syntax
+    (lambda (rec? e r w s mod k)
+      (syntax-case e ()
+        ((_ ((id val) ...) e1 e2 ...)
+         (let ((ids #'(id ...)))
+           (if (not (valid-bound-ids? ids))
+               (syntax-violation #f "duplicate bound keyword" e)
+               (let ((labels (gen-labels ids)))
+                 (let ((new-w (make-binding-wrap ids labels w)))
+                   (k #'(e1 e2 ...)
+                      (extend-env
+                       labels
+                       (let ((w (if rec? new-w w))
+                             (trans-r (macros-only-env r)))
+                         (map (lambda (x)
+                                (make-binding 'macro
+                                              (eval-local-transformer
+                                               (expand x trans-r w mod)
+                                               mod)))
+                              #'(val ...)))
+                       r)
+                      new-w
+                      s
+                      mod))))))
+        (_ (syntax-violation #f "bad local syntax definition"
+                             (source-wrap e w s mod))))))
+
+  (define eval-local-transformer
+    (lambda (expanded mod)
+      (let ((p (local-eval expanded mod)))
+        (if (procedure? p)
+            p
+            (syntax-violation #f "nonprocedure transformer" p)))))
+
+  (define expand-void
+    (lambda ()
+      (build-void no-source)))
+
+  (define ellipsis?
+    (lambda (e r mod)
+      (and (nonsymbol-id? e)
+           ;; If there is a binding for the special identifier
+           ;; #{ $sc-ellipsis }# in the lexical environment of E,
+           ;; and if the associated binding type is 'ellipsis',
+           ;; then the binding's value specifies the custom ellipsis
+           ;; identifier within that lexical environment, and the
+           ;; comparison is done using 'bound-id=?'.
+           (call-with-values
+               (lambda () (resolve-identifier
+                           (make-syntax '#{ $sc-ellipsis }#
+                                        (syntax-wrap e)
+                                        (or (syntax-module e) mod)
+                                        #f)
+                           empty-wrap r mod #f))
+             (lambda (type value mod)
+               (if (eq? type 'ellipsis)
+                   (bound-id=? e value)
+                   (free-id=? e #'(... ...))))))))
+
+  (define lambda-formals
+    (lambda (orig-args)
+      (define (req args rreq)
+        (syntax-case args ()
+          (()
+           (check (reverse rreq) #f))
+          ((a . b) (id? #'a)
+           (req #'b (cons #'a rreq)))
+          (r (id? #'r)
+             (check (reverse rreq) #'r))
+          (else
+           (syntax-violation 'lambda "invalid argument list" orig-args args))))
+      (define (check req rest)
+        (cond
+         ((distinct-bound-ids? (if rest (cons rest req) req))
+          (values req #f rest #f))
+         (else
+          (syntax-violation 'lambda "duplicate identifier in argument list"
+                            orig-args))))
+      (req orig-args '())))
+
+  (define expand-simple-lambda
+    (lambda (e r w s mod req rest meta body)
+      (let* ((ids (if rest (append req (list rest)) req))
+             (vars (map gen-var ids))
+             (labels (gen-labels ids)))
+        (build-simple-lambda
+         s
+         (map syntax->datum req) (and rest (syntax->datum rest)) vars
+         meta
+         (expand-body body (source-wrap e w s mod)
+                      (extend-var-env labels vars r)
+                      (make-binding-wrap ids labels w)
+                      mod)))))
+
+  (define lambda*-formals
+    (lambda (orig-args)
+      (define (req args rreq)
+        (syntax-case args ()
+          (()
+           (check (reverse rreq) '() #f '()))
+          ((a . b) (id? #'a)
+           (req #'b (cons #'a rreq)))
+          ((a . b) (eq? (syntax->datum #'a) #:optional)
+           (opt #'b (reverse rreq) '()))
+          ((a . b) (eq? (syntax->datum #'a) #:key)
+           (key #'b (reverse rreq) '() '()))
+          ((a b) (eq? (syntax->datum #'a) #:rest)
+           (rest #'b (reverse rreq) '() '()))
+          (r (id? #'r)
+             (rest #'r (reverse rreq) '() '()))
+          (else
+           (syntax-violation 'lambda* "invalid argument list" orig-args 
args))))
+      (define (opt args req ropt)
+        (syntax-case args ()
+          (()
+           (check req (reverse ropt) #f '()))
+          ((a . b) (id? #'a)
+           (opt #'b req (cons #'(a #f) ropt)))
+          (((a init) . b) (id? #'a)
+           (opt #'b req (cons #'(a init) ropt)))
+          ((a . b) (eq? (syntax->datum #'a) #:key)
+           (key #'b req (reverse ropt) '()))
+          ((a b) (eq? (syntax->datum #'a) #:rest)
+           (rest #'b req (reverse ropt) '()))
+          (r (id? #'r)
+             (rest #'r req (reverse ropt) '()))
+          (else
+           (syntax-violation 'lambda* "invalid optional argument list"
+                             orig-args args))))
+      (define (key args req opt rkey)
+        (syntax-case args ()
+          (()
+           (check req opt #f (cons #f (reverse rkey))))
+          ((a . b) (id? #'a)
+           (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+             (key #'b req opt (cons #'(k a #f) rkey))))
+          (((a init) . b) (id? #'a)
+           (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+             (key #'b req opt (cons #'(k a init) rkey))))
+          (((a init k) . b) (and (id? #'a)
+                                 (keyword? (syntax->datum #'k)))
+           (key #'b req opt (cons #'(k a init) rkey)))
+          ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
+           (check req opt #f (cons #t (reverse rkey))))
+          ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+                          (eq? (syntax->datum #'a) #:rest))
+           (rest #'b req opt (cons #t (reverse rkey))))
+          ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+                          (id? #'r))
+           (rest #'r req opt (cons #t (reverse rkey))))
+          ((a b) (eq? (syntax->datum #'a) #:rest)
+           (rest #'b req opt (cons #f (reverse rkey))))
+          (r (id? #'r)
+             (rest #'r req opt (cons #f (reverse rkey))))
+          (else
+           (syntax-violation 'lambda* "invalid keyword argument list"
+                             orig-args args))))
+      (define (rest args req opt kw)
+        (syntax-case args ()
+          (r (id? #'r)
+             (check req opt #'r kw))
+          (else
+           (syntax-violation 'lambda* "invalid rest argument"
+                             orig-args args))))
+      (define (check req opt rest kw)
+        (cond
+         ((distinct-bound-ids?
+           (append req (map car opt) (if rest (list rest) '())
+                   (if (pair? kw) (map cadr (cdr kw)) '())))
+          (values req opt rest kw))
+         (else
+          (syntax-violation 'lambda* "duplicate identifier in argument list"
+                            orig-args))))
+      (req orig-args '())))
+
+  (define expand-lambda-case
+    (lambda (e r w s mod get-formals clauses)
+      (define (parse-req req opt rest kw body)
+        (let ((vars (map gen-var req))
+              (labels (gen-labels req)))
+          (let ((r* (extend-var-env labels vars r))
+                (w* (make-binding-wrap req labels w)))
+            (parse-opt (map syntax->datum req)
+                       opt rest kw body (reverse vars) r* w* '() '()))))
+      (define (parse-opt req opt rest kw body vars r* w* out inits)
+        (cond
+         ((pair? opt)
+          (syntax-case (car opt) ()
+            ((id i)
+             (let* ((v (gen-var #'id))
+                    (l (gen-labels (list v)))
+                    (r** (extend-var-env l (list v) r*))
+                    (w** (make-binding-wrap (list #'id) l w*)))
+               (parse-opt req (cdr opt) rest kw body (cons v vars)
+                          r** w** (cons (syntax->datum #'id) out)
+                          (cons (expand #'i r* w* mod) inits))))))
+         (rest
+          (let* ((v (gen-var rest))
+                 (l (gen-labels (list v)))
+                 (r* (extend-var-env l (list v) r*))
+                 (w* (make-binding-wrap (list rest) l w*)))
+            (parse-kw req (if (pair? out) (reverse out) #f)
+                      (syntax->datum rest)
                       (if (pair? kw) (cdr kw) kw)
-                      body vars r* w*
+                      body (cons v vars) r* w* 
                       (if (pair? kw) (car kw) #f)
-                      '() inits))))
-        (define (parse-kw req opt rest kw body vars r* w* aok out inits)
-          (cond
-           ((pair? kw)
-            (syntax-case (car kw) ()
-              ((k id i)
-               (let* ((v (gen-var #'id))
-                      (l (gen-labels (list v)))
-                      (r** (extend-var-env l (list v) r*))
-                      (w** (make-binding-wrap (list #'id) l w*)))
-                 (parse-kw req opt rest (cdr kw) body (cons v vars)
-                           r** w** aok
-                           (cons (list (syntax->datum #'k)
-                                       (syntax->datum #'id)
-                                       v)
-                                 out)
-                           (cons (expand #'i r* w* mod) inits))))))
-           (else
-            (parse-body req opt rest
-                        (if (or aok (pair? out)) (cons aok (reverse out)) #f)
-                        body (reverse vars) r* w* (reverse inits) '()))))
-        (define (parse-body req opt rest kw body vars r* w* inits meta)
-          (syntax-case body ()
-            ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
-             (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
-                         (append meta 
-                                 `((documentation
-                                    . ,(syntax->datum #'docstring))))))
-            ((#((k . v) ...) e1 e2 ...) 
-             (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
-                         (append meta (syntax->datum #'((k . v) ...)))))
-            ((e1 e2 ...)
-             (values meta req opt rest kw inits vars
-                     (expand-body #'(e1 e2 ...) (source-wrap e w s mod)
-                                  r* w* mod)))))
-
-        (syntax-case clauses ()
-          (() (values '() #f))
-          (((args e1 e2 ...) (args* e1* e2* ...) ...)
-           (call-with-values (lambda () (get-formals #'args))
-             (lambda (req opt rest kw)
-               (call-with-values (lambda ()
-                                   (parse-req req opt rest kw #'(e1 e2 ...)))
-                 (lambda (meta req opt rest kw inits vars body)
-                   (call-with-values
-                       (lambda ()
-                         (expand-lambda-case e r w s mod get-formals
-                                             #'((args* e1* e2* ...) ...)))
-                     (lambda (meta* else*)
-                       (values
-                        (append meta meta*)
-                        (build-lambda-case s req opt rest kw inits vars
-                                           body else*))))))))))))
-
-    ;; data
-
-    ;; strips syntax objects, recursively.
-
-    (define (strip x)
-      (define (annotate proc datum)
-        (let ((s (proc x)))
-          (when (and s (supports-source-properties? datum))
-            (set-source-properties! datum (sourcev->alist s)))
-          datum))
-      (cond
-       ((syntax? x)
-        (annotate syntax-sourcev (strip (syntax-expression x))))
-       ((pair? x)
-        (cons (strip (car x)) (strip (cdr x))))
-       ((vector? x)
-        (list->vector (strip (vector->list x))))
-       (else x)))
-
-    ;; lexical variables
-
-    (define gen-var
-      (lambda (id)
-        (let ((id (if (syntax? id) (syntax-expression id) id)))
-          (gen-lexical id))))
-
-    ;; appears to return a reversed list
-    (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 #f) ls) w))
-           ((id? vars) (cons (wrap vars w #f) ls))
-           ((null? vars) ls)
-           ((syntax? vars)
-            (lvl (syntax-expression vars)
-                 ls
-                 (join-wraps w (syntax-wrap vars))))
-           ;; include anything else to be caught by subsequent error
-           ;; checking
-           (else (cons vars ls))))))
-
-    ;; core transformers
-
-    (global-extend 'local-syntax 'letrec-syntax #t)
-    (global-extend 'local-syntax 'let-syntax #f)
-
-    (global-extend
-     'core 'syntax-parameterize
-     (lambda (e r w s mod)
-       (syntax-case e ()
-         ((_ ((var val) ...) e1 e2 ...)
-          (valid-bound-ids? #'(var ...))
-          (let ((names
-                 (map (lambda (x)
-                        (call-with-values
-                            (lambda () (resolve-identifier x w r mod #f))
-                          (lambda (type value mod)
-                            (case type
-                              ((displaced-lexical)
-                               (syntax-violation 'syntax-parameterize
-                                                 "identifier out of context"
-                                                 e
-                                                 (source-wrap x w s mod)))
-                              ((syntax-parameter)
-                               value)
-                              (else
-                               (syntax-violation 'syntax-parameterize
-                                                 "invalid syntax parameter"
-                                                 e
-                                                 (source-wrap x w s mod)))))))
-                      #'(var ...)))
-                (bindings
-                 (let ((trans-r (macros-only-env r)))
-                   (map (lambda (x)
-                          (make-binding
-                           'syntax-parameter
-                           (eval-local-transformer (expand x trans-r w mod) 
mod)))
-                        #'(val ...)))))
-            (expand-body #'(e1 e2 ...)
-                         (source-wrap e w s mod)
-                         (extend-env names bindings r)
-                         w
-                         mod)))
-         (_ (syntax-violation 'syntax-parameterize "bad syntax"
-                              (source-wrap e w s mod))))))
-
-    (global-extend 'core 'quote
-                   (lambda (e r w s mod)
-                     (syntax-case e ()
-                       ((_ e) (build-data s (strip #'e)))
-                       (_ (syntax-violation 'quote "bad syntax"
-                                            (source-wrap e w s mod))))))
-
-    (global-extend 'core 'quote-syntax
-                   (lambda (e r w s mod)
-                     (syntax-case (source-wrap e w s mod) ()
-                       ((_ e) (build-data s #'e))
-                       (e (syntax-violation 'quote "bad syntax" #'e)))))
-
-    (global-extend
-     'core 'syntax
-     (let ()
-       (define gen-syntax
-         (lambda (src e r maps ellipsis? mod)
-           (if (id? e)
-               (call-with-values (lambda ()
-                                   (resolve-identifier e empty-wrap r mod #f))
-                 (lambda (type value mod)
-                   (case type
-                     ((syntax)
+                      '() inits)))
+         (else
+          (parse-kw req (if (pair? out) (reverse out) #f) #f
+                    (if (pair? kw) (cdr kw) kw)
+                    body vars r* w*
+                    (if (pair? kw) (car kw) #f)
+                    '() inits))))
+      (define (parse-kw req opt rest kw body vars r* w* aok out inits)
+        (cond
+         ((pair? kw)
+          (syntax-case (car kw) ()
+            ((k id i)
+             (let* ((v (gen-var #'id))
+                    (l (gen-labels (list v)))
+                    (r** (extend-var-env l (list v) r*))
+                    (w** (make-binding-wrap (list #'id) l w*)))
+               (parse-kw req opt rest (cdr kw) body (cons v vars)
+                         r** w** aok
+                         (cons (list (syntax->datum #'k)
+                                     (syntax->datum #'id)
+                                     v)
+                               out)
+                         (cons (expand #'i r* w* mod) inits))))))
+         (else
+          (parse-body req opt rest
+                      (if (or aok (pair? out)) (cons aok (reverse out)) #f)
+                      body (reverse vars) r* w* (reverse inits) '()))))
+      (define (parse-body req opt rest kw body vars r* w* inits meta)
+        (syntax-case body ()
+          ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+           (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
+                       (append meta 
+                               `((documentation
+                                  . ,(syntax->datum #'docstring))))))
+          ((#((k . v) ...) e1 e2 ...) 
+           (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
+                       (append meta (syntax->datum #'((k . v) ...)))))
+          ((e1 e2 ...)
+           (values meta req opt rest kw inits vars
+                   (expand-body #'(e1 e2 ...) (source-wrap e w s mod)
+                                r* w* mod)))))
+
+      (syntax-case clauses ()
+        (() (values '() #f))
+        (((args e1 e2 ...) (args* e1* e2* ...) ...)
+         (call-with-values (lambda () (get-formals #'args))
+           (lambda (req opt rest kw)
+             (call-with-values (lambda ()
+                                 (parse-req req opt rest kw #'(e1 e2 ...)))
+               (lambda (meta req opt rest kw inits vars body)
+                 (call-with-values
+                     (lambda ()
+                       (expand-lambda-case e r w s mod get-formals
+                                           #'((args* e1* e2* ...) ...)))
+                   (lambda (meta* else*)
+                     (values
+                      (append meta meta*)
+                      (build-lambda-case s req opt rest kw inits vars
+                                         body else*))))))))))))
+
+  ;; data
+
+  ;; strips syntax objects, recursively.
+
+  (define (strip x)
+    (define (annotate proc datum)
+      (let ((s (proc x)))
+        (when (and s (supports-source-properties? datum))
+          (set-source-properties! datum (sourcev->alist s)))
+        datum))
+    (cond
+     ((syntax? x)
+      (annotate syntax-sourcev (strip (syntax-expression x))))
+     ((pair? x)
+      (cons (strip (car x)) (strip (cdr x))))
+     ((vector? x)
+      (list->vector (strip (vector->list x))))
+     (else x)))
+
+  ;; lexical variables
+
+  (define gen-var
+    (lambda (id)
+      (let ((id (if (syntax? id) (syntax-expression id) id)))
+        (gen-lexical id))))
+
+  ;; appears to return a reversed list
+  (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 #f) ls) w))
+         ((id? vars) (cons (wrap vars w #f) ls))
+         ((null? vars) ls)
+         ((syntax? vars)
+          (lvl (syntax-expression vars)
+               ls
+               (join-wraps w (syntax-wrap vars))))
+         ;; include anything else to be caught by subsequent error
+         ;; checking
+         (else (cons vars ls))))))
+
+  ;; core transformers
+
+  (global-extend 'local-syntax 'letrec-syntax #t)
+  (global-extend 'local-syntax 'let-syntax #f)
+
+  (global-extend
+   'core 'syntax-parameterize
+   (lambda (e r w s mod)
+     (syntax-case e ()
+       ((_ ((var val) ...) e1 e2 ...)
+        (valid-bound-ids? #'(var ...))
+        (let ((names
+               (map (lambda (x)
                       (call-with-values
-                          (lambda () (gen-ref src (car value) (cdr value) 
maps))
-                        (lambda (var maps)
-                          (values `(ref ,var) maps))))
-                     (else
-                      (if (ellipsis? e r mod)
-                          (syntax-violation 'syntax "misplaced ellipsis" src)
-                          (values `(quote ,e) maps))))))
-               (syntax-case e ()
-                 ((dots e)
-                  (ellipsis? #'dots r mod)
-                  (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
-                 ((x dots . y)
-                  ;; this could be about a dozen lines of code, except that we
-                  ;; choose to handle #'(x ... ...) forms
-                  (ellipsis? #'dots r mod)
-                  (let f ((y #'y)
-                          (k (lambda (maps)
-                               (call-with-values
-                                   (lambda ()
-                                     (gen-syntax src #'x r
-                                                 (cons '() maps) ellipsis? 
mod))
-                                 (lambda (x maps)
-                                   (if (null? (car maps))
-                                       (syntax-violation 'syntax "extra 
ellipsis"
-                                                         src)
-                                       (values (gen-map x (car maps))
-                                               (cdr maps))))))))
-                    (syntax-case y ()
-                      ((dots . y)
-                       (ellipsis? #'dots r mod)
-                       (f #'y
-                          (lambda (maps)
-                            (call-with-values
-                                (lambda () (k (cons '() maps)))
-                              (lambda (x maps)
-                                (if (null? (car maps))
-                                    (syntax-violation 'syntax "extra ellipsis" 
src)
-                                    (values (gen-mappend x (car maps))
-                                            (cdr maps))))))))
-                      (_ (call-with-values
-                             (lambda () (gen-syntax src y r maps ellipsis? 
mod))
-                           (lambda (y maps)
+                          (lambda () (resolve-identifier x w r mod #f))
+                        (lambda (type value mod)
+                          (case type
+                            ((displaced-lexical)
+                             (syntax-violation 'syntax-parameterize
+                                               "identifier out of context"
+                                               e
+                                               (source-wrap x w s mod)))
+                            ((syntax-parameter)
+                             value)
+                            (else
+                             (syntax-violation 'syntax-parameterize
+                                               "invalid syntax parameter"
+                                               e
+                                               (source-wrap x w s mod)))))))
+                    #'(var ...)))
+              (bindings
+               (let ((trans-r (macros-only-env r)))
+                 (map (lambda (x)
+                        (make-binding
+                         'syntax-parameter
+                         (eval-local-transformer (expand x trans-r w mod) 
mod)))
+                      #'(val ...)))))
+          (expand-body #'(e1 e2 ...)
+                       (source-wrap e w s mod)
+                       (extend-env names bindings r)
+                       w
+                       mod)))
+       (_ (syntax-violation 'syntax-parameterize "bad syntax"
+                            (source-wrap e w s mod))))))
+
+  (global-extend 'core 'quote
+                 (lambda (e r w s mod)
+                   (syntax-case e ()
+                     ((_ e) (build-data s (strip #'e)))
+                     (_ (syntax-violation 'quote "bad syntax"
+                                          (source-wrap e w s mod))))))
+
+  (global-extend 'core 'quote-syntax
+                 (lambda (e r w s mod)
+                   (syntax-case (source-wrap e w s mod) ()
+                     ((_ e) (build-data s #'e))
+                     (e (syntax-violation 'quote "bad syntax" #'e)))))
+
+  (global-extend
+   'core 'syntax
+   (let ()
+     (define gen-syntax
+       (lambda (src e r maps ellipsis? mod)
+         (if (id? e)
+             (call-with-values (lambda ()
+                                 (resolve-identifier e empty-wrap r mod #f))
+               (lambda (type value mod)
+                 (case type
+                   ((syntax)
+                    (call-with-values
+                        (lambda () (gen-ref src (car value) (cdr value) maps))
+                      (lambda (var maps)
+                        (values `(ref ,var) maps))))
+                   (else
+                    (if (ellipsis? e r mod)
+                        (syntax-violation 'syntax "misplaced ellipsis" src)
+                        (values `(quote ,e) maps))))))
+             (syntax-case e ()
+               ((dots e)
+                (ellipsis? #'dots r mod)
+                (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
+               ((x dots . y)
+                ;; this could be about a dozen lines of code, except that we
+                ;; choose to handle #'(x ... ...) forms
+                (ellipsis? #'dots r mod)
+                (let f ((y #'y)
+                        (k (lambda (maps)
                              (call-with-values
-                                 (lambda () (k maps))
+                                 (lambda ()
+                                   (gen-syntax src #'x r
+                                               (cons '() maps) ellipsis? mod))
                                (lambda (x maps)
-                                 (values (gen-append x y) maps)))))))))
-                 ((x . y)
-                  (call-with-values
-                      (lambda () (gen-syntax src #'x r maps ellipsis? mod))
-                    (lambda (x maps)
-                      (call-with-values
-                          (lambda () (gen-syntax src #'y r maps ellipsis? mod))
-                        (lambda (y maps) (values (gen-cons x y) maps))))))
-                 (#(e1 e2 ...)
-                  (call-with-values
-                      (lambda ()
-                        (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
-                    (lambda (e maps) (values (gen-vector e) maps))))
-                 (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps))
-                 (() (values '(quote ()) maps))
-                 (_ (values `(quote ,e) maps))))))
-
-       (define gen-ref
-         (lambda (src var level maps)
-           (if (= level 0)
-               (values var maps)
-               (if (null? maps)
-                   (syntax-violation 'syntax "missing ellipsis" src)
-                   (call-with-values
-                       (lambda () (gen-ref src var (1- level) (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))
-              ((and-map
-                (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)
+                                 (if (null? (car maps))
+                                     (syntax-violation 'syntax "extra ellipsis"
+                                                       src)
+                                     (values (gen-map x (car maps))
+                                             (cdr maps))))))))
+                  (syntax-case y ()
+                    ((dots . y)
+                     (ellipsis? #'dots r mod)
+                     (f #'y
+                        (lambda (maps)
+                          (call-with-values
+                              (lambda () (k (cons '() maps)))
+                            (lambda (x maps)
+                              (if (null? (car maps))
+                                  (syntax-violation 'syntax "extra ellipsis" 
src)
+                                  (values (gen-mappend x (car maps))
+                                          (cdr maps))))))))
+                    (_ (call-with-values
+                           (lambda () (gen-syntax src y r maps ellipsis? mod))
+                         (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 #'x r maps ellipsis? mod))
+                  (lambda (x maps)
+                    (call-with-values
+                        (lambda () (gen-syntax src #'y r maps ellipsis? mod))
+                      (lambda (y maps) (values (gen-cons x y) maps))))))
+               (#(e1 e2 ...)
+                (call-with-values
+                    (lambda ()
+                      (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
+                  (lambda (e maps) (values (gen-vector e) maps))))
+               (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps))
+               (() (values '(quote ()) maps))
+               (_ (values `(quote ,e) maps))))))
+
+     (define gen-ref
+       (lambda (src var level maps)
+         (if (= level 0)
+             (values var maps)
+             (if (null? maps)
+                 (syntax-violation 'syntax "missing ellipsis" src)
+                 (call-with-values
+                     (lambda () (gen-ref src var (1- level) (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 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) (cadr 
x)))
-             ((primitive) (build-primref no-source (cadr x)))
-             ((quote) (build-data no-source (cadr x)))
-             ((lambda)
-              (if (list? (cadr x))
-                  (build-simple-lambda no-source (cadr x) #f (cadr x) '() 
(regen (caddr x)))
-                  (error "how did we get here" x)))
-             (else (build-primcall no-source (car x) (map regen (cdr x)))))))
-
-       (lambda (e r w s mod)
-         (let ((e (source-wrap e w s mod)))
-           (syntax-case e ()
-             ((_ x)
-              (call-with-values
-                  (lambda () (gen-syntax e #'x r '() ellipsis? mod))
-                (lambda (e maps) (regen e))))
-             (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
+            ((eq? (car e) 'ref)
+             ;; identity map equivalence:
+             ;; (map (lambda (x) x) y) == y
+             (car actuals))
+            ((and-map
+              (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) (cadr x)))
+           ((primitive) (build-primref no-source (cadr x)))
+           ((quote) (build-data no-source (cadr x)))
+           ((lambda)
+            (if (list? (cadr x))
+                (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen 
(caddr x)))
+                (error "how did we get here" x)))
+           (else (build-primcall no-source (car x) (map regen (cdr x)))))))
 
-    (global-extend 'core 'lambda
-                   (lambda (e r w s mod)
-                     (syntax-case e ()
-                       ((_ args e1 e2 ...)
-                        (call-with-values (lambda () (lambda-formals #'args))
-                          (lambda (req opt rest kw)
-                            (let lp ((body #'(e1 e2 ...)) (meta '()))
-                              (syntax-case body ()
-                                ((docstring e1 e2 ...) (string? (syntax->datum 
#'docstring))
-                                 (lp #'(e1 e2 ...)
-                                     (append meta
-                                             `((documentation
-                                                . ,(syntax->datum 
#'docstring))))))
-                                ((#((k . v) ...) e1 e2 ...) 
-                                 (lp #'(e1 e2 ...)
-                                     (append meta (syntax->datum #'((k . v) 
...)))))
-                                (_ (expand-simple-lambda e r w s mod req rest 
meta body)))))))
-                       (_ (syntax-violation 'lambda "bad lambda" e)))))
-  
-    (global-extend 'core 'lambda*
-                   (lambda (e r w s mod)
-                     (syntax-case e ()
-                       ((_ args e1 e2 ...)
-                        (call-with-values
-                            (lambda ()
-                              (expand-lambda-case e r w s mod
-                                                  lambda*-formals #'((args e1 
e2 ...))))
-                          (lambda (meta lcase)
-                            (build-case-lambda s meta lcase))))
-                       (_ (syntax-violation 'lambda "bad lambda*" e)))))
+     (lambda (e r w s mod)
+       (let ((e (source-wrap e w s mod)))
+         (syntax-case e ()
+           ((_ x)
+            (call-with-values
+                (lambda () (gen-syntax e #'x r '() ellipsis? mod))
+              (lambda (e maps) (regen e))))
+           (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
 
-    (global-extend 'core 'case-lambda
-                   (lambda (e r w s mod)
-                     (define (build-it meta clauses)
-                       (call-with-values
-                           (lambda ()
-                             (expand-lambda-case e r w s mod
-                                                 lambda-formals
-                                                 clauses))
-                         (lambda (meta* lcase)
-                           (build-case-lambda s (append meta meta*) lcase))))
-                     (syntax-case e ()
-                       ((_ (args e1 e2 ...) ...)
-                        (build-it '() #'((args e1 e2 ...) ...)))
-                       ((_ docstring (args e1 e2 ...) ...)
-                        (string? (syntax->datum #'docstring))
-                        (build-it `((documentation
-                                     . ,(syntax->datum #'docstring)))
-                                  #'((args e1 e2 ...) ...)))
-                       (_ (syntax-violation 'case-lambda "bad case-lambda" 
e)))))
-
-    (global-extend 'core 'case-lambda*
-                   (lambda (e r w s mod)
-                     (define (build-it meta clauses)
-                       (call-with-values
-                           (lambda ()
-                             (expand-lambda-case e r w s mod
-                                                 lambda*-formals
-                                                 clauses))
-                         (lambda (meta* lcase)
-                           (build-case-lambda s (append meta meta*) lcase))))
-                     (syntax-case e ()
-                       ((_ (args e1 e2 ...) ...)
-                        (build-it '() #'((args e1 e2 ...) ...)))
-                       ((_ docstring (args e1 e2 ...) ...)
-                        (string? (syntax->datum #'docstring))
-                        (build-it `((documentation
-                                     . ,(syntax->datum #'docstring)))
-                                  #'((args e1 e2 ...) ...)))
-                       (_ (syntax-violation 'case-lambda "bad case-lambda*" 
e)))))
-
-    (global-extend 'core 'with-ellipsis
-                   (lambda (e r w s mod)
-                     (syntax-case e ()
-                       ((_ dots e1 e2 ...)
-                        (id? #'dots)
-                        (let ((id (if (symbol? #'dots)
-                                      '#{ $sc-ellipsis }#
-                                      (make-syntax '#{ $sc-ellipsis }#
-                                                   (syntax-wrap #'dots)
-                                                   (syntax-module #'dots)
-                                                   (syntax-sourcev #'dots)))))
-                          (let ((ids (list id))
-                                (labels (list (gen-label)))
-                                (bindings (list (make-binding 'ellipsis 
(source-wrap #'dots w s mod)))))
-                            (let ((nw (make-binding-wrap ids labels w))
-                                  (nr (extend-env labels bindings r)))
-                              (expand-body #'(e1 e2 ...) (source-wrap e nw s 
mod) nr nw mod)))))
-                       (_ (syntax-violation 'with-ellipsis "bad syntax"
-                                            (source-wrap e w s mod))))))
-
-    (global-extend 'core 'let
-                   (let ()
-                     (define (expand-let e r w s mod constructor ids vals exps)
-                       (if (not (valid-bound-ids? ids))
-                           (syntax-violation 'let "duplicate bound variable" e)
-                           (let ((labels (gen-labels ids))
-                                 (new-vars (map gen-var ids)))
-                             (let ((nw (make-binding-wrap ids labels w))
-                                   (nr (extend-var-env labels new-vars r)))
-                               (constructor s
-                                            (map syntax->datum ids)
-                                            new-vars
-                                            (map (lambda (x) (expand x r w 
mod)) vals)
-                                            (expand-body exps (source-wrap e 
nw s mod)
-                                                         nr nw mod))))))
-                     (lambda (e r w s mod)
-                       (syntax-case e ()
-                         ((_ ((id val) ...) e1 e2 ...)
-                          (and-map id? #'(id ...))
-                          (expand-let e r w s mod
-                                      build-let
-                                      #'(id ...)
-                                      #'(val ...)
-                                      #'(e1 e2 ...)))
-                         ((_ f ((id val) ...) e1 e2 ...)
-                          (and (id? #'f) (and-map id? #'(id ...)))
-                          (expand-let e r w s mod
-                                      build-named-let
-                                      #'(f id ...)
-                                      #'(val ...)
-                                      #'(e1 e2 ...)))
-                         (_ (syntax-violation 'let "bad let" (source-wrap e w 
s mod)))))))
-
-
-    (global-extend 'core 'letrec
-                   (lambda (e r w s mod)
-                     (syntax-case e ()
-                       ((_ ((id val) ...) e1 e2 ...)
-                        (and-map id? #'(id ...))
-                        (let ((ids #'(id ...)))
-                          (if (not (valid-bound-ids? ids))
-                              (syntax-violation 'letrec "duplicate bound 
variable" e)
-                              (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 #f
-                                                (map syntax->datum ids)
-                                                new-vars
-                                                (map (lambda (x) (expand x r w 
mod)) #'(val ...))
-                                                (expand-body #'(e1 e2 ...) 
-                                                             (source-wrap e w 
s mod) r w mod)))))))
-                       (_ (syntax-violation 'letrec "bad letrec" (source-wrap 
e w s mod))))))
-
-
-    (global-extend 'core 'letrec*
+  (global-extend 'core 'lambda
+                 (lambda (e r w s mod)
+                   (syntax-case e ()
+                     ((_ args e1 e2 ...)
+                      (call-with-values (lambda () (lambda-formals #'args))
+                        (lambda (req opt rest kw)
+                          (let lp ((body #'(e1 e2 ...)) (meta '()))
+                            (syntax-case body ()
+                              ((docstring e1 e2 ...) (string? (syntax->datum 
#'docstring))
+                               (lp #'(e1 e2 ...)
+                                   (append meta
+                                           `((documentation
+                                              . ,(syntax->datum 
#'docstring))))))
+                              ((#((k . v) ...) e1 e2 ...) 
+                               (lp #'(e1 e2 ...)
+                                   (append meta (syntax->datum #'((k . v) 
...)))))
+                              (_ (expand-simple-lambda e r w s mod req rest 
meta body)))))))
+                     (_ (syntax-violation 'lambda "bad lambda" e)))))
+  
+  (global-extend 'core 'lambda*
+                 (lambda (e r w s mod)
+                   (syntax-case e ()
+                     ((_ args e1 e2 ...)
+                      (call-with-values
+                          (lambda ()
+                            (expand-lambda-case e r w s mod
+                                                lambda*-formals #'((args e1 e2 
...))))
+                        (lambda (meta lcase)
+                          (build-case-lambda s meta lcase))))
+                     (_ (syntax-violation 'lambda "bad lambda*" e)))))
+
+  (global-extend 'core 'case-lambda
+                 (lambda (e r w s mod)
+                   (define (build-it meta clauses)
+                     (call-with-values
+                         (lambda ()
+                           (expand-lambda-case e r w s mod
+                                               lambda-formals
+                                               clauses))
+                       (lambda (meta* lcase)
+                         (build-case-lambda s (append meta meta*) lcase))))
+                   (syntax-case e ()
+                     ((_ (args e1 e2 ...) ...)
+                      (build-it '() #'((args e1 e2 ...) ...)))
+                     ((_ docstring (args e1 e2 ...) ...)
+                      (string? (syntax->datum #'docstring))
+                      (build-it `((documentation
+                                   . ,(syntax->datum #'docstring)))
+                                #'((args e1 e2 ...) ...)))
+                     (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
+
+  (global-extend 'core 'case-lambda*
+                 (lambda (e r w s mod)
+                   (define (build-it meta clauses)
+                     (call-with-values
+                         (lambda ()
+                           (expand-lambda-case e r w s mod
+                                               lambda*-formals
+                                               clauses))
+                       (lambda (meta* lcase)
+                         (build-case-lambda s (append meta meta*) lcase))))
+                   (syntax-case e ()
+                     ((_ (args e1 e2 ...) ...)
+                      (build-it '() #'((args e1 e2 ...) ...)))
+                     ((_ docstring (args e1 e2 ...) ...)
+                      (string? (syntax->datum #'docstring))
+                      (build-it `((documentation
+                                   . ,(syntax->datum #'docstring)))
+                                #'((args e1 e2 ...) ...)))
+                     (_ (syntax-violation 'case-lambda "bad case-lambda*" 
e)))))
+
+  (global-extend 'core 'with-ellipsis
+                 (lambda (e r w s mod)
+                   (syntax-case e ()
+                     ((_ dots e1 e2 ...)
+                      (id? #'dots)
+                      (let ((id (if (symbol? #'dots)
+                                    '#{ $sc-ellipsis }#
+                                    (make-syntax '#{ $sc-ellipsis }#
+                                                 (syntax-wrap #'dots)
+                                                 (syntax-module #'dots)
+                                                 (syntax-sourcev #'dots)))))
+                        (let ((ids (list id))
+                              (labels (list (gen-label)))
+                              (bindings (list (make-binding 'ellipsis 
(source-wrap #'dots w s mod)))))
+                          (let ((nw (make-binding-wrap ids labels w))
+                                (nr (extend-env labels bindings r)))
+                            (expand-body #'(e1 e2 ...) (source-wrap e nw s 
mod) nr nw mod)))))
+                     (_ (syntax-violation 'with-ellipsis "bad syntax"
+                                          (source-wrap e w s mod))))))
+
+  (global-extend 'core 'let
+                 (let ()
+                   (define (expand-let e r w s mod constructor ids vals exps)
+                     (if (not (valid-bound-ids? ids))
+                         (syntax-violation 'let "duplicate bound variable" e)
+                         (let ((labels (gen-labels ids))
+                               (new-vars (map gen-var ids)))
+                           (let ((nw (make-binding-wrap ids labels w))
+                                 (nr (extend-var-env labels new-vars r)))
+                             (constructor s
+                                          (map syntax->datum ids)
+                                          new-vars
+                                          (map (lambda (x) (expand x r w mod)) 
vals)
+                                          (expand-body exps (source-wrap e nw 
s mod)
+                                                       nr nw mod))))))
                    (lambda (e r w s mod)
                      (syntax-case e ()
                        ((_ ((id val) ...) e1 e2 ...)
                         (and-map id? #'(id ...))
-                        (let ((ids #'(id ...)))
-                          (if (not (valid-bound-ids? ids))
-                              (syntax-violation 'letrec* "duplicate bound 
variable" e)
-                              (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 #t
-                                                (map syntax->datum ids)
-                                                new-vars
-                                                (map (lambda (x) (expand x r w 
mod)) #'(val ...))
-                                                (expand-body #'(e1 e2 ...) 
-                                                             (source-wrap e w 
s mod) r w mod)))))))
-                       (_ (syntax-violation 'letrec* "bad letrec*" 
(source-wrap e w s mod))))))
-
-
-    (global-extend
-     'core 'set!
-     (lambda (e r w s mod)
-       (syntax-case e ()
-         ((_ id val)
-          (id? #'id)
-          (call-with-values
-              (lambda () (resolve-identifier #'id w r mod #t))
-            (lambda (type value id-mod)
-              (case type
-                ((lexical)
-                 (build-lexical-assignment s (syntax->datum #'id) value
-                                           (expand #'val r w mod)))
-                ((global)
-                 (build-global-assignment s value (expand #'val r w mod) 
id-mod))
-                ((macro)
-                 (if (procedure-property value 'variable-transformer)
-                     ;; As syntax-type does, call expand-macro with
-                     ;; the mod of the expression. Hmm.
-                     (expand (expand-macro value e r w s #f mod) r empty-wrap 
mod)
-                     (syntax-violation 'set! "not a variable transformer"
-                                       (wrap e w mod)
-                                       (wrap #'id w id-mod))))
-                ((displaced-lexical)
-                 (syntax-violation 'set! "identifier out of context"
-                                   (wrap #'id w mod)))
-                (else
-                 (syntax-violation 'set! "bad set!" (source-wrap e w s 
mod)))))))
-         ((_ (head tail ...) val)
-          (call-with-values
-              (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
-            (lambda (type value ee* ee ww ss modmod)
-              (case type
-                ((module-ref)
-                 (let ((val (expand #'val r w mod)))
-                   (call-with-values (lambda () (value #'(head tail ...) r w 
mod))
-                     (lambda (e r w s* mod)
-                       (syntax-case e ()
-                         (e (id? #'e)
-                            (build-global-assignment s (syntax->datum #'e)
-                                                     val mod)))))))
-                (else
-                 (build-call s
-                             (expand #'(setter head) r w mod)
-                             (map (lambda (e) (expand e r w mod))
-                                  #'(tail ... val))))))))
-         (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
-
-    (global-extend 'module-ref '@
-                   (lambda (e r w mod)
+                        (expand-let e r w s mod
+                                    build-let
+                                    #'(id ...)
+                                    #'(val ...)
+                                    #'(e1 e2 ...)))
+                       ((_ f ((id val) ...) e1 e2 ...)
+                        (and (id? #'f) (and-map id? #'(id ...)))
+                        (expand-let e r w s mod
+                                    build-named-let
+                                    #'(f id ...)
+                                    #'(val ...)
+                                    #'(e1 e2 ...)))
+                       (_ (syntax-violation 'let "bad let" (source-wrap e w s 
mod)))))))
+
+
+  (global-extend 'core 'letrec
+                 (lambda (e r w s mod)
+                   (syntax-case e ()
+                     ((_ ((id val) ...) e1 e2 ...)
+                      (and-map id? #'(id ...))
+                      (let ((ids #'(id ...)))
+                        (if (not (valid-bound-ids? ids))
+                            (syntax-violation 'letrec "duplicate bound 
variable" e)
+                            (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 #f
+                                              (map syntax->datum ids)
+                                              new-vars
+                                              (map (lambda (x) (expand x r w 
mod)) #'(val ...))
+                                              (expand-body #'(e1 e2 ...) 
+                                                           (source-wrap e w s 
mod) r w mod)))))))
+                     (_ (syntax-violation 'letrec "bad letrec" (source-wrap e 
w s mod))))))
+
+
+  (global-extend 'core 'letrec*
+                 (lambda (e r w s mod)
+                   (syntax-case e ()
+                     ((_ ((id val) ...) e1 e2 ...)
+                      (and-map id? #'(id ...))
+                      (let ((ids #'(id ...)))
+                        (if (not (valid-bound-ids? ids))
+                            (syntax-violation 'letrec* "duplicate bound 
variable" e)
+                            (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 #t
+                                              (map syntax->datum ids)
+                                              new-vars
+                                              (map (lambda (x) (expand x r w 
mod)) #'(val ...))
+                                              (expand-body #'(e1 e2 ...) 
+                                                           (source-wrap e w s 
mod) r w mod)))))))
+                     (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap 
e w s mod))))))
+
+
+  (global-extend
+   'core 'set!
+   (lambda (e r w s mod)
+     (syntax-case e ()
+       ((_ id val)
+        (id? #'id)
+        (call-with-values
+            (lambda () (resolve-identifier #'id w r mod #t))
+          (lambda (type value id-mod)
+            (case type
+              ((lexical)
+               (build-lexical-assignment s (syntax->datum #'id) value
+                                         (expand #'val r w mod)))
+              ((global)
+               (build-global-assignment s value (expand #'val r w mod) id-mod))
+              ((macro)
+               (if (procedure-property value 'variable-transformer)
+                   ;; As syntax-type does, call expand-macro with
+                   ;; the mod of the expression. Hmm.
+                   (expand (expand-macro value e r w s #f mod) r empty-wrap 
mod)
+                   (syntax-violation 'set! "not a variable transformer"
+                                     (wrap e w mod)
+                                     (wrap #'id w id-mod))))
+              ((displaced-lexical)
+               (syntax-violation 'set! "identifier out of context"
+                                 (wrap #'id w mod)))
+              (else
+               (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
+       ((_ (head tail ...) val)
+        (call-with-values
+            (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
+          (lambda (type value ee* ee ww ss modmod)
+            (case type
+              ((module-ref)
+               (let ((val (expand #'val r w mod)))
+                 (call-with-values (lambda () (value #'(head tail ...) r w 
mod))
+                   (lambda (e r w s* mod)
                      (syntax-case e ()
-                       ((_ (mod ...) id)
-                        (and (and-map id? #'(mod ...)) (id? #'id))
-                        ;; Strip the wrap from the identifier and return 
top-wrap
-                        ;; so that the identifier will not be captured by 
lexicals.
-                        (values (syntax->datum #'id) r top-wrap #f
-                                (syntax->datum
-                                 #'(public mod ...)))))))
-
-    (global-extend 'module-ref '@@
-                   (lambda (e r w mod)
-                     (define remodulate
-                       (lambda (x mod)
-                         (cond ((pair? x)
-                                (cons (remodulate (car x) mod)
-                                      (remodulate (cdr x) mod)))
-                               ((syntax? x)
-                                (make-syntax
-                                 (remodulate (syntax-expression x) mod)
-                                 (syntax-wrap x)
-                                 ;; hither the remodulation
-                                 mod
-                                 (syntax-sourcev x)))
-                               ((vector? x)
-                                (let* ((n (vector-length x)) (v (make-vector 
n)))
-                                  (do ((i 0 (1+ i)))
-                                      ((= i n) v)
-                                    (vector-set! v i (remodulate (vector-ref x 
i) mod)))))
-                               (else x))))
-                     (syntax-case e (@@ primitive)
-                       ((_ primitive id)
-                        (and (id? #'id)
-                             (equal? (cdr (or (and (syntax? #'id)
-                                                   (syntax-module #'id))
-                                              mod))
-                                     '(guile)))
-                        ;; Strip the wrap from the identifier and return 
top-wrap
-                        ;; so that the identifier will not be captured by 
lexicals.
-                        (values (syntax->datum #'id) r top-wrap #f 
'(primitive)))
-                       ((_ (mod ...) id)
-                        (and (and-map id? #'(mod ...)) (id? #'id))
-                        ;; Strip the wrap from the identifier and return 
top-wrap
-                        ;; so that the identifier will not be captured by 
lexicals.
-                        (values (syntax->datum #'id) r top-wrap #f
-                                (syntax->datum
-                                 #'(private mod ...))))
-                       ((_ @@ (mod ...) exp)
-                        (and-map id? #'(mod ...))
-                        ;; This is a special syntax used to support R6RS 
library forms.
-                        ;; Unlike the syntax above, the last item is not 
restricted to
-                        ;; be a single identifier, and the syntax objects are 
kept
-                        ;; intact, with only their module changed.
-                        (let ((mod (syntax->datum #'(private mod ...))))
-                          (values (remodulate #'exp mod)
-                                  r w (source-annotation #'exp)
-                                  mod))))))
+                       (e (id? #'e)
+                          (build-global-assignment s (syntax->datum #'e)
+                                                   val mod)))))))
+              (else
+               (build-call s
+                           (expand #'(setter head) r w mod)
+                           (map (lambda (e) (expand e r w mod))
+                                #'(tail ... val))))))))
+       (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+
+  (global-extend 'module-ref '@
+                 (lambda (e r w mod)
+                   (syntax-case e ()
+                     ((_ (mod ...) id)
+                      (and (and-map id? #'(mod ...)) (id? #'id))
+                      ;; Strip the wrap from the identifier and return top-wrap
+                      ;; so that the identifier will not be captured by 
lexicals.
+                      (values (syntax->datum #'id) r top-wrap #f
+                              (syntax->datum
+                               #'(public mod ...)))))))
+
+  (global-extend 'module-ref '@@
+                 (lambda (e r w mod)
+                   (define remodulate
+                     (lambda (x mod)
+                       (cond ((pair? x)
+                              (cons (remodulate (car x) mod)
+                                    (remodulate (cdr x) mod)))
+                             ((syntax? x)
+                              (make-syntax
+                               (remodulate (syntax-expression x) mod)
+                               (syntax-wrap x)
+                               ;; hither the remodulation
+                               mod
+                               (syntax-sourcev x)))
+                             ((vector? x)
+                              (let* ((n (vector-length x)) (v (make-vector n)))
+                                (do ((i 0 (1+ i)))
+                                    ((= i n) v)
+                                  (vector-set! v i (remodulate (vector-ref x 
i) mod)))))
+                             (else x))))
+                   (syntax-case e (@@ primitive)
+                     ((_ primitive id)
+                      (and (id? #'id)
+                           (equal? (cdr (or (and (syntax? #'id)
+                                                 (syntax-module #'id))
+                                            mod))
+                                   '(guile)))
+                      ;; Strip the wrap from the identifier and return top-wrap
+                      ;; so that the identifier will not be captured by 
lexicals.
+                      (values (syntax->datum #'id) r top-wrap #f '(primitive)))
+                     ((_ (mod ...) id)
+                      (and (and-map id? #'(mod ...)) (id? #'id))
+                      ;; Strip the wrap from the identifier and return top-wrap
+                      ;; so that the identifier will not be captured by 
lexicals.
+                      (values (syntax->datum #'id) r top-wrap #f
+                              (syntax->datum
+                               #'(private mod ...))))
+                     ((_ @@ (mod ...) exp)
+                      (and-map id? #'(mod ...))
+                      ;; This is a special syntax used to support R6RS library 
forms.
+                      ;; Unlike the syntax above, the last item is not 
restricted to
+                      ;; be a single identifier, and the syntax objects are 
kept
+                      ;; intact, with only their module changed.
+                      (let ((mod (syntax->datum #'(private mod ...))))
+                        (values (remodulate #'exp mod)
+                                r w (source-annotation #'exp)
+                                mod))))))
   
-    (global-extend 'core 'if
+  (global-extend 'core 'if
+                 (lambda (e r w s mod)
+                   (syntax-case e ()
+                     ((_ test then)
+                      (build-conditional
+                       s
+                       (expand #'test r w mod)
+                       (expand #'then r w mod)
+                       (build-void no-source)))
+                     ((_ test then else)
+                      (build-conditional
+                       s
+                       (expand #'test r w mod)
+                       (expand #'then r w mod)
+                       (expand #'else r w mod))))))
+
+  (global-extend 'begin 'begin '())
+
+  (global-extend 'define 'define '())
+
+  (global-extend 'define-syntax 'define-syntax '())
+  (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
+
+  (global-extend 'eval-when 'eval-when '())
+
+  (global-extend 'core 'syntax-case
+                 (let ()
+                   (define convert-pattern
+                     ;; accepts pattern & keys
+                     ;; returns $sc-dispatch pattern & ids
+                     (lambda (pattern keys ellipsis?)
+                       (define cvt*
+                         (lambda (p* n ids)
+                           (syntax-case p* ()
+                             ((x . y)
+                              (call-with-values
+                                  (lambda () (cvt* #'y n ids))
+                                (lambda (y ids)
+                                  (call-with-values
+                                      (lambda () (cvt #'x n ids))
+                                    (lambda (x ids)
+                                      (values (cons x y) ids))))))
+                             (_ (cvt p* n ids)))))
+                       
+                       (define (v-reverse x)
+                         (let loop ((r '()) (x x))
+                           (if (not (pair? x))
+                               (values r x)
+                               (loop (cons (car x) r) (cdr x)))))
+
+                       (define cvt
+                         (lambda (p n ids)
+                           (if (id? p)
+                               (cond
+                                ((bound-id-member? p keys)
+                                 (values (vector 'free-id p) ids))
+                                ((free-id=? p #'_)
+                                 (values '_ ids))
+                                (else
+                                 (values 'any (cons (cons p n) ids))))
+                               (syntax-case p ()
+                                 ((x dots)
+                                  (ellipsis? (syntax dots))
+                                  (call-with-values
+                                      (lambda () (cvt (syntax x) (1+ n) ids))
+                                    (lambda (p ids)
+                                      (values (if (eq? p 'any) 'each-any 
(vector 'each p))
+                                              ids))))
+                                 ((x dots . ys)
+                                  (ellipsis? (syntax dots))
+                                  (call-with-values
+                                      (lambda () (cvt* (syntax ys) n ids))
+                                    (lambda (ys ids)
+                                      (call-with-values
+                                          (lambda () (cvt (syntax x) (+ n 1) 
ids))
+                                        (lambda (x ids)
+                                          (call-with-values
+                                              (lambda () (v-reverse ys))
+                                            (lambda (ys e)
+                                              (values `#(each+ ,x ,ys ,e) 
+                                                      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)) ids))))))
+                       (cvt pattern 0 '())))
+
+                   (define build-dispatch-call
+                     (lambda (pvars exp y r mod)
+                       (let ((ids (map car pvars)) (levels (map cdr pvars)))
+                         (let ((labels (gen-labels ids)) (new-vars (map 
gen-var ids)))
+                           (build-primcall
+                            no-source
+                            'apply
+                            (list (build-simple-lambda no-source (map 
syntax->datum ids) #f new-vars '()
+                                                       (expand 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)
+                                                               mod))
+                                  y))))))
+
+                   (define gen-clause
+                     (lambda (x keys clauses r pat fender exp mod)
+                       (call-with-values
+                           (lambda () (convert-pattern pat keys (lambda (e) 
(ellipsis? e r mod))))
+                         (lambda (p pvars)
+                           (cond
+                            ((not (and-map (lambda (x) (not (ellipsis? (car x) 
r mod))) pvars))
+                             (syntax-violation 'syntax-case "misplaced 
ellipsis" pat))
+                            ((not (distinct-bound-ids? (map car pvars)))
+                             (syntax-violation 'syntax-case "duplicate pattern 
variable" pat))
+                            (else
+                             (let ((y (gen-var 'tmp)))
+                               ;; fat finger binding and references to temp 
variable y
+                               (build-call no-source
+                                           (build-simple-lambda no-source 
(list 'tmp) #f (list y) '()
+                                                                (let ((y 
(build-lexical-reference 'value no-source
+                                                                               
                   'tmp y)))
+                                                                  
(build-conditional no-source
+                                                                               
      (syntax-case fender ()
+                                                                               
        (#t y)
+                                                                               
        (_ (build-conditional no-source
+                                                                               
                              y
+                                                                               
                              (build-dispatch-call pvars fender y r mod)
+                                                                               
                              (build-data no-source #f))))
+                                                                               
      (build-dispatch-call pvars exp y r mod)
+                                                                               
      (gen-syntax-case x keys clauses r mod))))
+                                           (list (if (eq? p 'any)
+                                                     (build-primcall no-source 
'list (list x))
+                                                     (build-primcall no-source 
'$sc-dispatch
+                                                                     (list x 
(build-data no-source p)))))))))))))
+
+                   (define gen-syntax-case
+                     (lambda (x keys clauses r mod)
+                       (if (null? clauses)
+                           (build-primcall no-source 'syntax-violation
+                                           (list (build-data no-source #f)
+                                                 (build-data no-source
+                                                             "source 
expression failed to match any pattern")
+                                                 x))
+                           (syntax-case (car clauses) ()
+                             ((pat exp)
+                              (if (and (id? #'pat)
+                                       (and-map (lambda (x) (not (free-id=? 
#'pat x)))
+                                                (cons #'(... ...) keys)))
+                                  (if (free-id=? #'pat #'_)
+                                      (expand #'exp r empty-wrap mod)
+                                      (let ((labels (list (gen-label)))
+                                            (var (gen-var #'pat)))
+                                        (build-call no-source
+                                                    (build-simple-lambda
+                                                     no-source (list 
(syntax->datum #'pat)) #f (list var)
+                                                     '()
+                                                     (expand #'exp
+                                                             (extend-env labels
+                                                                         (list 
(make-binding 'syntax `(,var . 0)))
+                                                                         r)
+                                                             
(make-binding-wrap #'(pat)
+                                                                               
 labels empty-wrap)
+                                                             mod))
+                                                    (list x))))
+                                  (gen-clause x keys (cdr clauses) r
+                                              #'pat #t #'exp mod)))
+                             ((pat fender exp)
+                              (gen-clause x keys (cdr clauses) r
+                                          #'pat #'fender #'exp mod))
+                             (_ (syntax-violation 'syntax-case "invalid clause"
+                                                  (car clauses)))))))
+
                    (lambda (e r w s mod)
-                     (syntax-case e ()
-                       ((_ test then)
-                        (build-conditional
-                         s
-                         (expand #'test r w mod)
-                         (expand #'then r w mod)
-                         (build-void no-source)))
-                       ((_ test then else)
-                        (build-conditional
-                         s
-                         (expand #'test r w mod)
-                         (expand #'then r w mod)
-                         (expand #'else r w mod))))))
-
-    (global-extend 'begin 'begin '())
-
-    (global-extend 'define 'define '())
-
-    (global-extend 'define-syntax 'define-syntax '())
-    (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
-
-    (global-extend 'eval-when 'eval-when '())
-
-    (global-extend 'core 'syntax-case
-                   (let ()
-                     (define convert-pattern
-                       ;; accepts pattern & keys
-                       ;; returns $sc-dispatch pattern & ids
-                       (lambda (pattern keys ellipsis?)
-                         (define cvt*
-                           (lambda (p* n ids)
-                             (syntax-case p* ()
-                               ((x . y)
-                                (call-with-values
-                                     (lambda () (cvt* #'y n ids))
-                                   (lambda (y ids)
-                                     (call-with-values
-                                         (lambda () (cvt #'x n ids))
-                                       (lambda (x ids)
-                                         (values (cons x y) ids))))))
-                               (_ (cvt p* n ids)))))
-                         
-                         (define (v-reverse x)
-                           (let loop ((r '()) (x x))
-                             (if (not (pair? x))
-                                 (values r x)
-                                 (loop (cons (car x) r) (cdr x)))))
-
-                         (define cvt
-                           (lambda (p n ids)
-                             (if (id? p)
-                                 (cond
-                                  ((bound-id-member? p keys)
-                                   (values (vector 'free-id p) ids))
-                                  ((free-id=? p #'_)
-                                   (values '_ ids))
-                                  (else
-                                   (values 'any (cons (cons p n) ids))))
-                                 (syntax-case p ()
-                                   ((x dots)
-                                    (ellipsis? (syntax dots))
-                                    (call-with-values
-                                        (lambda () (cvt (syntax x) (1+ n) ids))
-                                      (lambda (p ids)
-                                        (values (if (eq? p 'any) 'each-any 
(vector 'each p))
-                                                ids))))
-                                   ((x dots . ys)
-                                    (ellipsis? (syntax dots))
-                                    (call-with-values
-                                        (lambda () (cvt* (syntax ys) n ids))
-                                      (lambda (ys ids)
-                                        (call-with-values
-                                            (lambda () (cvt (syntax x) (+ n 1) 
ids))
-                                          (lambda (x ids)
-                                            (call-with-values
-                                                (lambda () (v-reverse ys))
-                                              (lambda (ys e)
-                                                (values `#(each+ ,x ,ys ,e) 
-                                                        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)) 
ids))))))
-                         (cvt pattern 0 '())))
-
-                     (define build-dispatch-call
-                       (lambda (pvars exp y r mod)
-                         (let ((ids (map car pvars)) (levels (map cdr pvars)))
-                           (let ((labels (gen-labels ids)) (new-vars (map 
gen-var ids)))
-                             (build-primcall
-                              no-source
-                              'apply
-                              (list (build-simple-lambda no-source (map 
syntax->datum ids) #f new-vars '()
-                                                         (expand 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)
-                                                              mod))
-                                    y))))))
-
-                     (define gen-clause
-                       (lambda (x keys clauses r pat fender exp mod)
-                         (call-with-values
-                             (lambda () (convert-pattern pat keys (lambda (e) 
(ellipsis? e r mod))))
-                           (lambda (p pvars)
-                             (cond
-                              ((not (and-map (lambda (x) (not (ellipsis? (car 
x) r mod))) pvars))
-                               (syntax-violation 'syntax-case "misplaced 
ellipsis" pat))
-                              ((not (distinct-bound-ids? (map car pvars)))
-                               (syntax-violation 'syntax-case "duplicate 
pattern variable" pat))
-                              (else
-                               (let ((y (gen-var 'tmp)))
-                                 ;; fat finger binding and references to temp 
variable y
-                                 (build-call no-source
-                                             (build-simple-lambda no-source 
(list 'tmp) #f (list y) '()
-                                                                  (let ((y 
(build-lexical-reference 'value no-source
-                                                                               
                     'tmp y)))
-                                                                    
(build-conditional no-source
-                                                                               
        (syntax-case fender ()
-                                                                               
          (#t y)
-                                                                               
          (_ (build-conditional no-source
-                                                                               
                                y
-                                                                               
                                (build-dispatch-call pvars fender y r mod)
-                                                                               
                                (build-data no-source #f))))
-                                                                               
        (build-dispatch-call pvars exp y r mod)
-                                                                               
        (gen-syntax-case x keys clauses r mod))))
-                                             (list (if (eq? p 'any)
-                                                       (build-primcall 
no-source 'list (list x))
-                                                       (build-primcall 
no-source '$sc-dispatch
-                                                                       (list x 
(build-data no-source p)))))))))))))
-
-                     (define gen-syntax-case
-                       (lambda (x keys clauses r mod)
-                         (if (null? clauses)
-                             (build-primcall no-source 'syntax-violation
-                                             (list (build-data no-source #f)
-                                                   (build-data no-source
-                                                               "source 
expression failed to match any pattern")
-                                                   x))
-                             (syntax-case (car clauses) ()
-                               ((pat exp)
-                                (if (and (id? #'pat)
-                                         (and-map (lambda (x) (not (free-id=? 
#'pat x)))
-                                                  (cons #'(... ...) keys)))
-                                    (if (free-id=? #'pat #'_)
-                                        (expand #'exp r empty-wrap mod)
-                                        (let ((labels (list (gen-label)))
-                                              (var (gen-var #'pat)))
-                                          (build-call no-source
-                                                      (build-simple-lambda
-                                                       no-source (list 
(syntax->datum #'pat)) #f (list var)
-                                                       '()
-                                                       (expand #'exp
-                                                            (extend-env labels
-                                                                        (list 
(make-binding 'syntax `(,var . 0)))
-                                                                        r)
-                                                            (make-binding-wrap 
#'(pat)
-                                                                               
labels empty-wrap)
-                                                            mod))
-                                                      (list x))))
-                                    (gen-clause x keys (cdr clauses) r
-                                                #'pat #t #'exp mod)))
-                               ((pat fender exp)
-                                (gen-clause x keys (cdr clauses) r
-                                            #'pat #'fender #'exp mod))
-                               (_ (syntax-violation 'syntax-case "invalid 
clause"
-                                                    (car clauses)))))))
-
-                     (lambda (e r w s mod)
-                       (let ((e (source-wrap e w s mod)))
-                         (syntax-case e ()
-                           ((_ val (key ...) m ...)
-                            (if (and-map (lambda (x) (and (id? x) (not 
(ellipsis? x r mod))))
-                                         #'(key ...))
-                                (let ((x (gen-var 'tmp)))
-                                  ;; fat finger binding and references to temp 
variable x
-                                  (build-call s
-                                              (build-simple-lambda no-source 
(list 'tmp) #f (list x) '()
-                                                                   
(gen-syntax-case (build-lexical-reference 'value no-source
-                                                                               
                              'tmp x)
-                                                                               
     #'(key ...) #'(m ...)
-                                                                               
     r
-                                                                               
     mod))
-                                              (list (expand #'val r empty-wrap 
mod))))
-                                (syntax-violation 'syntax-case "invalid 
literals list" e))))))))
-
-    ;; The portable macroexpand seeds expand-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! macroexpand
-          (lambda* (x #:optional (m 'e) (esew '(eval)))
-            (define (unstrip x)
-              (define (annotate result)
-                (let ((props (source-properties x)))
-                  (if (pair? props)
-                      (datum->syntax #f result #:source props)
-                      result)))
-              (cond
-               ((pair? x)
-                (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
-               ((vector? x)
-                (let ((v (make-vector (vector-length x))))
-                  (annotate (list->vector (map unstrip (vector->list x))))))
-               ((syntax? x) x)
-               (else (annotate x))))
-            (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
-                                 (cons 'hygiene (module-name 
(current-module))))))
-
-    (set! identifier?
-          (lambda (x)
-            (nonsymbol-id? x)))
-
-    (set! datum->syntax
-          (lambda* (id datum #:key source)
-            (define (props->sourcev alist)
-              (and (pair? alist)
-                   (vector (assq-ref alist 'filename)
-                           (assq-ref alist 'line)
-                           (assq-ref alist 'column))))
-            (make-syntax datum
-                         (if id
-                             (syntax-wrap id)
-                             empty-wrap)
-                         (if id
-                             (syntax-module id)
-                             #f)
-                         (cond
-                          ((not source)
-                           (props->sourcev (source-properties datum)))
-                          ((and (list? source) (and-map pair? source))
-                           (props->sourcev source))
-                          ((and (vector? source) (= 3 (vector-length source)))
-                           source)
-                          (else (syntax-sourcev source))))))
-
-    (set! syntax->datum
-          ;; accepts any object, since syntax objects may consist partially
-          ;; or entirely of unwrapped, nonsymbolic data
-          (lambda (x)
-            (strip x)))
-
-    (set! generate-temporaries
-          (lambda (ls)
-            (arg-check list? ls 'generate-temporaries)
-            (let ((mod (cons 'hygiene (module-name (current-module)))))
-              (map (lambda (x)
-                     (wrap (gen-var 't) top-wrap mod))
-                   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-violation
-          (lambda* (who message form #:optional subform)
-            (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
-                       who 'syntax-violation)
-            (arg-check string? message 'syntax-violation)
-            (throw 'syntax-error who message
-                   (sourcev->alist
-                    (or (source-annotation subform)
-                        (source-annotation form)))
-                   (strip form)
-                   (strip subform))))
-
-    (let ()
-      (define (%syntax-module id)
-        (arg-check nonsymbol-id? id 'syntax-module)
-        (let ((mod (syntax-module id)))
-          (and mod
-               (not (equal? mod '(primitive)))
-               (cdr mod))))
-
-      (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
-        (arg-check nonsymbol-id? id 'syntax-local-binding)
-        (with-transformer-environment
-         (lambda (e r w s rib mod)
-           (define (strip-anti-mark w)
-             (let ((ms (wrap-marks w)) (s (wrap-subst w)))
-               (if (and (pair? ms) (eq? (car ms) the-anti-mark))
-                   ;; output is from original text
-                   (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
-                   ;; output introduced by macro
-                   (make-wrap ms (if rib (cons rib s) s)))))
-           (call-with-values (lambda ()
-                               (resolve-identifier
-                                (syntax-expression id)
-                                (strip-anti-mark (syntax-wrap id))
-                                r
-                                (or (syntax-module id) mod)
-                                resolve-syntax-parameters?))
-             (lambda (type value mod)
-               (case type
-                 ((lexical) (values 'lexical value))
-                 ((macro) (values 'macro value))
-                 ((syntax-parameter) (values 'syntax-parameter value))
-                 ((syntax) (values 'pattern-variable value))
-                 ((displaced-lexical) (values 'displaced-lexical #f))
-                 ((global)
-                  (if (equal? mod '(primitive))
-                      (values 'primitive value)
-                      (values 'global (cons value (cdr mod)))))
-                 ((ellipsis)
-                  (values 'ellipsis
-                          (wrap-syntax value (anti-mark (syntax-wrap value))
-                                       mod)))
-                 (else (values 'other #f))))))))
-
-      (define (syntax-locally-bound-identifiers id)
-        (arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers)
-        (locally-bound-identifiers (syntax-wrap id)
-                                   (syntax-module id)))
-
-      ;; Using define! instead of set! to avoid warnings at
-      ;; compile-time, after the variables are stolen away into (system
-      ;; syntax).  See the end of boot-9.scm.
-      ;;
-      (define! '%syntax-module %syntax-module)
-      (define! 'syntax-local-binding syntax-local-binding)
-      (define! 'syntax-locally-bound-identifiers 
syntax-locally-bound-identifiers))
-    
-    ;; $sc-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>*)
-    ;;   #(each+ p1 (p2_1 ... p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
-    ;;   #(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 mod)
-          (cond
-           ((pair? e)
-            (let ((first (match (car e) p w '() mod)))
-              (and first
-                   (let ((rest (match-each (cdr e) p w mod)))
-                     (and rest (cons first rest))))))
-           ((null? e) '())
-           ((syntax? e)
-            (match-each (syntax-expression e)
-                        p
-                        (join-wraps w (syntax-wrap e))
-                        (or (syntax-module e) mod)))
-           (else #f))))
-
-      (define match-each+
-        (lambda (e x-pat y-pat z-pat w r mod)
-          (let f ((e e) (w w))
+                     (let ((e (source-wrap e w s mod)))
+                       (syntax-case e ()
+                         ((_ val (key ...) m ...)
+                          (if (and-map (lambda (x) (and (id? x) (not 
(ellipsis? x r mod))))
+                                       #'(key ...))
+                              (let ((x (gen-var 'tmp)))
+                                ;; fat finger binding and references to temp 
variable x
+                                (build-call s
+                                            (build-simple-lambda no-source 
(list 'tmp) #f (list x) '()
+                                                                 
(gen-syntax-case (build-lexical-reference 'value no-source
+                                                                               
                            'tmp x)
+                                                                               
   #'(key ...) #'(m ...)
+                                                                               
   r
+                                                                               
   mod))
+                                            (list (expand #'val r empty-wrap 
mod))))
+                              (syntax-violation 'syntax-case "invalid literals 
list" e))))))))
+
+  ;; The portable macroexpand seeds expand-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! macroexpand
+        (lambda* (x #:optional (m 'e) (esew '(eval)))
+          (define (unstrip x)
+            (define (annotate result)
+              (let ((props (source-properties x)))
+                (if (pair? props)
+                    (datum->syntax #f result #:source props)
+                    result)))
             (cond
-             ((pair? e)
-              (call-with-values (lambda () (f (cdr e) w))
-                (lambda (xr* y-pat r)
-                  (if r
-                      (if (null? y-pat)
-                          (let ((xr (match (car e) x-pat w '() mod)))
-                            (if xr
-                                (values (cons xr xr*) y-pat r)
-                                (values #f #f #f)))
-                          (values
-                           '()
-                           (cdr y-pat)
-                           (match (car e) (car y-pat) w r mod)))
-                      (values #f #f #f)))))
-             ((syntax? e)
-              (f (syntax-expression e)
-                 (join-wraps w (syntax-wrap e))))
-             (else
-              (values '() y-pat (match e z-pat w r mod)))))))
+             ((pair? x)
+              (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
+             ((vector? x)
+              (let ((v (make-vector (vector-length x))))
+                (annotate (list->vector (map unstrip (vector->list x))))))
+             ((syntax? x) x)
+             (else (annotate x))))
+          (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
+                               (cons 'hygiene (module-name 
(current-module))))))
+
+  (set! identifier?
+        (lambda (x)
+          (nonsymbol-id? x)))
+
+  (set! datum->syntax
+        (lambda* (id datum #:key source)
+          (define (props->sourcev alist)
+            (and (pair? alist)
+                 (vector (assq-ref alist 'filename)
+                         (assq-ref alist 'line)
+                         (assq-ref alist 'column))))
+          (make-syntax datum
+                       (if id
+                           (syntax-wrap id)
+                           empty-wrap)
+                       (if id
+                           (syntax-module id)
+                           #f)
+                       (cond
+                        ((not source)
+                         (props->sourcev (source-properties datum)))
+                        ((and (list? source) (and-map pair? source))
+                         (props->sourcev source))
+                        ((and (vector? source) (= 3 (vector-length source)))
+                         source)
+                        (else (syntax-sourcev source))))))
+
+  (set! syntax->datum
+        ;; accepts any object, since syntax objects may consist partially
+        ;; or entirely of unwrapped, nonsymbolic data
+        (lambda (x)
+          (strip x)))
+
+  (set! generate-temporaries
+        (lambda (ls)
+          (arg-check list? ls 'generate-temporaries)
+          (let ((mod (cons 'hygiene (module-name (current-module)))))
+            (map (lambda (x)
+                   (wrap (gen-var 't) top-wrap mod))
+                 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-violation
+        (lambda* (who message form #:optional subform)
+          (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+                     who 'syntax-violation)
+          (arg-check string? message 'syntax-violation)
+          (throw 'syntax-error who message
+                 (sourcev->alist
+                  (or (source-annotation subform)
+                      (source-annotation form)))
+                 (strip form)
+                 (strip subform))))
 
-      (define match-each-any
-        (lambda (e w mod)
+  (let ()
+    (define (%syntax-module id)
+      (arg-check nonsymbol-id? id 'syntax-module)
+      (let ((mod (syntax-module id)))
+        (and mod
+             (not (equal? mod '(primitive)))
+             (cdr mod))))
+
+    (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
+      (arg-check nonsymbol-id? id 'syntax-local-binding)
+      (with-transformer-environment
+       (lambda (e r w s rib mod)
+         (define (strip-anti-mark w)
+           (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+             (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+                 ;; output is from original text
+                 (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+                 ;; output introduced by macro
+                 (make-wrap ms (if rib (cons rib s) s)))))
+         (call-with-values (lambda ()
+                             (resolve-identifier
+                              (syntax-expression id)
+                              (strip-anti-mark (syntax-wrap id))
+                              r
+                              (or (syntax-module id) mod)
+                              resolve-syntax-parameters?))
+           (lambda (type value mod)
+             (case type
+               ((lexical) (values 'lexical value))
+               ((macro) (values 'macro value))
+               ((syntax-parameter) (values 'syntax-parameter value))
+               ((syntax) (values 'pattern-variable value))
+               ((displaced-lexical) (values 'displaced-lexical #f))
+               ((global)
+                (if (equal? mod '(primitive))
+                    (values 'primitive value)
+                    (values 'global (cons value (cdr mod)))))
+               ((ellipsis)
+                (values 'ellipsis
+                        (wrap-syntax value (anti-mark (syntax-wrap value))
+                                     mod)))
+               (else (values 'other #f))))))))
+
+    (define (syntax-locally-bound-identifiers id)
+      (arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers)
+      (locally-bound-identifiers (syntax-wrap id)
+                                 (syntax-module id)))
+
+    ;; Using define! instead of set! to avoid warnings at
+    ;; compile-time, after the variables are stolen away into (system
+    ;; syntax).  See the end of boot-9.scm.
+    ;;
+    (define! '%syntax-module %syntax-module)
+    (define! 'syntax-local-binding syntax-local-binding)
+    (define! 'syntax-locally-bound-identifiers 
syntax-locally-bound-identifiers))
+  
+  ;; $sc-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>*)
+  ;;   #(each+ p1 (p2_1 ... p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
+  ;;   #(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 mod)
+        (cond
+         ((pair? e)
+          (let ((first (match (car e) p w '() mod)))
+            (and first
+                 (let ((rest (match-each (cdr e) p w mod)))
+                   (and rest (cons first rest))))))
+         ((null? e) '())
+         ((syntax? e)
+          (match-each (syntax-expression e)
+                      p
+                      (join-wraps w (syntax-wrap e))
+                      (or (syntax-module e) mod)))
+         (else #f))))
+
+    (define match-each+
+      (lambda (e x-pat y-pat z-pat w r mod)
+        (let f ((e e) (w w))
           (cond
            ((pair? e)
-            (let ((l (match-each-any (cdr e) w mod)))
-              (and l (cons (wrap (car e) w mod) l))))
-           ((null? e) '())
+            (call-with-values (lambda () (f (cdr e) w))
+              (lambda (xr* y-pat r)
+                (if r
+                    (if (null? y-pat)
+                        (let ((xr (match (car e) x-pat w '() mod)))
+                          (if xr
+                              (values (cons xr xr*) y-pat r)
+                              (values #f #f #f)))
+                        (values
+                         '()
+                         (cdr y-pat)
+                         (match (car e) (car y-pat) w r mod)))
+                    (values #f #f #f)))))
            ((syntax? e)
-            (match-each-any (syntax-expression e)
-                            (join-wraps w (syntax-wrap e))
-                            mod))
-           (else #f))))
-
-      (define match-empty
-        (lambda (p r)
-          (cond
-           ((null? p) r)
-           ((eq? 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))
-              ((each+) (match-empty (vector-ref p 1)
-                                    (match-empty
-                                     (reverse (vector-ref p 2))
-                                     (match-empty (vector-ref p 3) r))))
-              ((free-id atom) r)
-              ((vector) (match-empty (vector-ref p 1) r)))))))
-
-      (define combine
-        (lambda (r* r)
-          (if (null? (car r*))
-              r
-              (cons (map car r*) (combine (map cdr r*) r)))))
-
-      (define match*
-        (lambda (e p w r mod)
-          (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 mod)
-                             mod)))
-           ((eq? p 'each-any)
-            (let ((l (match-each-any e w mod))) (and l (cons l r))))
+            (f (syntax-expression e)
+               (join-wraps w (syntax-wrap e))))
            (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 mod)))
-                     (and l
-                          (let collect ((l l))
-                            (if (null? (car l))
-                                r
-                                (cons (map car l) (collect (map cdr l)))))))))
-              ((each+)
-               (call-with-values
-                   (lambda ()
-                     (match-each+ e (vector-ref p 1) (vector-ref p 2) 
(vector-ref p 3) w r mod))
-                 (lambda (xr* y-pat r)
-                   (and r
-                        (null? y-pat)
-                        (if (null? xr*)
-                            (match-empty (vector-ref p 1) r)
-                            (combine xr* r))))))
-              ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 
1)) r))
-              ((atom) (and (equal? (vector-ref p 1) (strip e)) r))
-              ((vector)
-               (and (vector? e)
-                    (match (vector->list e) (vector-ref p 1) w r mod))))))))
-
-      (define match
-        (lambda (e p w r mod)
-          (cond
-           ((not r) #f)
-           ((eq? p '_) r)
-           ((eq? p 'any) (cons (wrap e w mod) r))
-           ((syntax? e)
-            (match*
-             (syntax-expression e)
-             p
-             (join-wraps w (syntax-wrap e))
-             r
-             (or (syntax-module e) mod)))
-           (else (match* e p w r mod)))))
-
-      (set! $sc-dispatch
-            (lambda (e p)
-              (cond
-               ((eq? p 'any) (list e))
-               ((eq? p '_) '())
-               ((syntax? e)
-                (match* (syntax-expression e)
-                        p (syntax-wrap e) '() (syntax-module e)))
-               (else (match* e p empty-wrap '() #f))))))))
+            (values '() y-pat (match e z-pat w r mod)))))))
+
+    (define match-each-any
+      (lambda (e w mod)
+        (cond
+         ((pair? e)
+          (let ((l (match-each-any (cdr e) w mod)))
+            (and l (cons (wrap (car e) w mod) l))))
+         ((null? e) '())
+         ((syntax? e)
+          (match-each-any (syntax-expression e)
+                          (join-wraps w (syntax-wrap e))
+                          mod))
+         (else #f))))
+
+    (define match-empty
+      (lambda (p r)
+        (cond
+         ((null? p) r)
+         ((eq? 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))
+            ((each+) (match-empty (vector-ref p 1)
+                                  (match-empty
+                                   (reverse (vector-ref p 2))
+                                   (match-empty (vector-ref p 3) r))))
+            ((free-id atom) r)
+            ((vector) (match-empty (vector-ref p 1) r)))))))
+
+    (define combine
+      (lambda (r* r)
+        (if (null? (car r*))
+            r
+            (cons (map car r*) (combine (map cdr r*) r)))))
+
+    (define match*
+      (lambda (e p w r mod)
+        (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 mod)
+                                mod)))
+         ((eq? p 'each-any)
+          (let ((l (match-each-any e w mod))) (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 mod)))
+                   (and l
+                        (let collect ((l l))
+                          (if (null? (car l))
+                              r
+                              (cons (map car l) (collect (map cdr l)))))))))
+            ((each+)
+             (call-with-values
+                 (lambda ()
+                   (match-each+ e (vector-ref p 1) (vector-ref p 2) 
(vector-ref p 3) w r mod))
+               (lambda (xr* y-pat r)
+                 (and r
+                      (null? y-pat)
+                      (if (null? xr*)
+                          (match-empty (vector-ref p 1) r)
+                          (combine xr* r))))))
+            ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 
1)) r))
+            ((atom) (and (equal? (vector-ref p 1) (strip e)) r))
+            ((vector)
+             (and (vector? e)
+                  (match (vector->list e) (vector-ref p 1) w r mod))))))))
+
+    (define match
+      (lambda (e p w r mod)
+        (cond
+         ((not r) #f)
+         ((eq? p '_) r)
+         ((eq? p 'any) (cons (wrap e w mod) r))
+         ((syntax? e)
+          (match*
+           (syntax-expression e)
+           p
+           (join-wraps w (syntax-wrap e))
+           r
+           (or (syntax-module e) mod)))
+         (else (match* e p w r mod)))))
+
+    (set! $sc-dispatch
+          (lambda (e p)
+            (cond
+             ((eq? p 'any) (list e))
+             ((eq? p '_) '())
+             ((syntax? e)
+              (match* (syntax-expression e)
+                      p (syntax-wrap e) '() (syntax-module e)))
+             (else (match* e p empty-wrap '() #f)))))))
 
 
 (define-syntax with-syntax



reply via email to

[Prev in Thread] Current Thread [Next in Thread]