switch to set-of-scopes expander

The development history for set-of-scopes is preserved in a "scope"
branch in the main Racket repository, which is commit
 ae88c96f50

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "6.2.0.5")
+(define version "6.2.900.4")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-benchmarks/tests/racket/benchmarks/places/place-processes.rkt

@@ -9,7 +9,8 @@
          racket/serialize
          (for-syntax syntax/parse
                      racket/base
-                     racket/file))
+                     racket/file
+                     syntax/strip-context))
 
 (provide
   dynamic-place
@@ -117,7 +118,7 @@
               new-result)))]))
 
 (define-syntax (place/base stx)
-  (syntax-case stx ()
+  (syntax-case (replace-context #'here stx) ()
     [(_ module-name (name ch) body ...)
      #'(module module-name racket/base
          (require "place-processes.rkt")

pkgs/racket-doc/scribblings/raco/zo-parse.scrbl

@@ -75,3 +75,12 @@ The @racketmodname[compiler/zo-parse] module re-exports
   or @racket[mod] structure indicates the list of global variables and
   quoted syntax that need to be instantiated (and put into an array on
   the stack) before evaluating expressions that might use them.}
+
+
+@defproc[(decode-module-binding [binding module-binding?]
+                                [name symbol?])
+         decoded-module-binding?]{
+
+Given a compact-form representation of a module binding and the name
+from which the binding is mapped, returns a normalized form of the
+binding.}

pkgs/racket-doc/scribblings/raco/zo-struct.scrbl

@@ -1,5 +1,6 @@
 #lang scribble/doc
 @(require scribble/manual
+          scribble/core
           (for-label racket/base
                      racket/contract
                      compiler/zo-structs
@@ -19,6 +20,14 @@ The @racketmodname[compiler/zo-structs] library defines the bytecode
 structures that are produced by @racket[zo-parse] and consumed by
 @racket[decompile] and @racket[zo-marshal].
 
+@nested[#:style 'inset]{
+@elem[#:style (style #f (list (background-color-property "yellow")))]{@bold{Warning:}}
+      The @racketmodname[compiler/zo-structs] library exposes internals
+      of the Racket bytecode abstraction. Unlike other Racket
+      libraries, @racketmodname[compiler/zo-structs] is subject to
+      incompatible changes across Racket versions.}
+
+
 @defstruct+[zo ()]{
   A supertype for all forms that can appear in compiled code.}
 
@@ -41,7 +50,8 @@ structures that are produced by @racket[zo-parse] and consumed by
             ([num-lifts exact-nonnegative-integer?]
              [toplevels (listof (or/c #f symbol? global-bucket?
                                       module-variable?))]
-             [stxs (listof stx?)])]{
+             [stxs (listof (or stx? #f))]
+             [inspector-desc symbol?])]{
   Represents a ``prefix'' that is pushed onto the stack to initiate
   evaluation.  The prefix is an array, where buckets holding the
   values for @racket[toplevels] are first, then the buckets for the
@@ -63,7 +73,16 @@ structures that are produced by @racket[zo-parse] and consumed by
 
   The variable buckets and syntax objects that are recorded in a prefix
   are accessed by @racket[toplevel] and @racket[topsyntax] expression
-  forms.}
+  forms.
+  
+  When an element of @racket[stxs] is @racket[#f], it coresponds to a
+  syntax object that was optimized away at the last minute. The slot
+  must not be referenced vt a @racket[topsyntax] form.
+
+  The @racket[inspector-desc] field provides an inspector name that
+  is used within syntax-object bindings. At run time, the prefix gets
+  an inspector, and bindings that reference the same inspector name are
+  granted access capabilities through that inspector.}
 
 @defstruct+[(global-bucket zo) ([name symbol?])]{
   Represents a top-level variable, and used only in a @racket[prefix].}
@@ -111,8 +130,8 @@ returns.}
 Represents the shape of an expected import as a structure-type
 binding, constructor, etc.}
 
-@defstruct+[(stx zo) ([encoded wrapped?])]{
+@defstruct+[(stx zo) ([content stx-obj?])]{
-  Wraps a syntax object in a @racket[prefix].}
+  Wraps a syntax object as it appears in a @racket[prefix].}
 
 
 @; --------------------------------------------------
@@ -205,6 +224,8 @@ binding, constructor, etc.}
              [dummy toplevel?]
              [lang-info (or/c #f (vector/c module-path? symbol? any/c))]
              [internal-context (or/c #f #t stx? (vectorof stx?))]
+             [binding-names (hash/c exact-integer?
+                                    (hash/c symbol? (or/c #t stx?)))]
              [flags (listof (or/c 'cross-phase))]
              [pre-submodules (listof mod?)]
              [post-submodules (listof mod?)])]{
@@ -247,6 +268,13 @@ binding, constructor, etc.}
   context is computed by re-importing all required modules.  A
   syntax-object value embeds an arbitrary lexical context.
 
+  The @racket[binding-names] value provides additional information to
+  @racket[module->namespace] to correlate symbol names for variables
+  and syntax definitions to identifiers that map to those variables. A
+  separate table of names exists for each phase, and a @racket[#t]
+  mapping for a name indicates that it is mapped but inaccessible
+  (because the relevant scopes are inaccessible).
+
   The @racket[flags] field records certain properties of the module.
   The @racket['cross-phase] flag indicates that the module body is
   evaluated once and the results shared across instances for all phases; such a
@@ -547,127 +575,203 @@ binding, constructor, etc.}
 @; --------------------------------------------------
 @section{Syntax Objects}
 
-@defstruct+[(wrapped zo)
+@defstruct+[(stx-obj zo)
             ([datum any/c]
-             [wraps (listof wrap?)]
+             [wrap wrap?]
              [tamper-status (or/c 'clean 'armed 'tainted)])]{
-  Represents a syntax object, where @racket[wraps] contain the lexical
+  Represents a syntax object, where @racket[wrap] contains lexical
   information and @racket[tamper-status] is taint information. When the
-  @racket[datum] part is itself compound, its pieces are wrapped, too.}
+  @racket[datum] part is itself compound, its pieces are wrapped
+  as @racket[stx-obj]s, too.
 
-@defstruct+[(wrap zo) ()]{
+  The content of @racket[wrap] is typically cyclic, since it includes
-  A supertype for lexical-information elements.}
+  scopes that contain bindings that refer to scopes.}
 
-@defstruct+[(top-level-rename wrap) ([flag boolean?])]{
+@defstruct+[(wrap zo) ([shifts (listof module-shift?)]
-  A top-level renaming.}
+                       [simple-scopes (listof scope?)]
+                       [multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))])]{
+  Lexical information for a syntax object. The @racket[shifts] field
+  allows binding information to be relative to the enclosing module's
+  run-time path. The @racket[simple-scopes] field records scopes that
+  are attached to the syntax object at all phases, and @racket[multi-scopes]
+  records phase-specific scopes (which are always attached as a group)
+  along with a phase shift for every scope within the group).}
 
-@defstruct+[(mark-barrier wrap) ([value symbol?])]{
+@defstruct+[(module-shift zo) ([from (or/c #f module-path-index?)]
-  A mark barrier.}
+                               [to (or/c #f module-path-index?)]
+                               [from-inspector-desc (or/c #f symbol?)]
+                               [to-inspector-desc (or/c #f symbol?)])]{
 
-@defstruct+[(free-id-info zo)
+Records a history of module path index replacements. These replacements
-            ([path0 module-path-index?]
+are applied in reverse order, and a module instantiation typically adds
-             [symbol0 symbol?]
+one more shift to replace the current ``self'' module path index
-             [path1 module-path-index?]
+with a run-time module path. The @racket[from] and @racket[to]
-             [symbol1 symbol?]
+fields should be both @racket[#f] or both non-@racket[#f].
-             [phase0 (or/c exact-integer? #f)]
-             [phase1 (or/c exact-integer? #f)]
-             [phase2 (or/c exact-integer? #f)]
-             [use-current-inspector? boolean?])]{
-  Information about a free identifier.}
 
-@defstruct+[(lexical-rename wrap)
+The @racket[from-inspector-desc] and @racket[to-inspector-desc] fields
-            ([has-free-id-info? boolean?]
+similarly should be both @racket[#f] or both non-@racket[#f]. They
-             [bool2 boolean?]
+record a history of code-inspector replacements.}
-             [alist
-              (listof
-               (cons/c symbol?
-                       (or/c symbol?
-                             (cons/c symbol?
-                                     (or/c (cons/c symbol? (or/c symbol? #f))
-                                           free-id-info?)))))])]{
-  A local-binding mapping from symbols to binding-set names.}
 
 
-@defstruct+[(phase-shift wrap)
+@defstruct+[(scope zo) ([name (or/c 'root exact-nonnegative-integer?)]
-            ([amt (or/c exact-integer? #f)]
+                        [kind symbol?]
-             [src module-path-index?]
+                        [bindings (listof (list/c symbol? (listof scope?) binding?)) #;#:mutable]
-             [dest module-path-index?]
+                        [bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #;#:mutable]
-             [cancel-id (or/c exact-integer? #f)])]{
+                        [multi-owner (or/c #f multi-scope?) #;#:mutable])]{
-  Shifts module bindings later in the wrap set.}
 
-@defstruct+[(module-rename wrap)
+Represents a scope. When @racket[name] is @racket['root] then the
-            ([phase exact-integer?]
+scope represents the unique all-phases scope that is shared among
-             [kind (or/c 'marked 'normal)]
+non-module namespaces. Otherwise, @racket[name] is intended to be
-             [set-id any/c]
+distinct for each @racket[scope] instance within a module or top-level
-             [unmarshals (listof make-all-from-module?)]
+compilation, but the @racket[eq?]-identity of the @racket[scope]
-             [renames (listof module-binding?)]
+instance ultimately determines its identity. The @racket[kind] symbol
-             [mark-renames any/c]
+similarly acts as a debugging hint in the same way as for
-             [plus-kern? boolean?])]{
+@racket[syntax-debug-info].
-  Represents a set of module and import bindings.}
 
-@defstruct+[(all-from-module zo)
+The @racket[bindings] list indicates some bindings that are associated
-            ([path module-path-index?]
+with the scope. Each element of the list includes a symbolic name, a
+list of scopes (including the enclosing one), and the binding for the
+combination of name and scope set. A given symbol can appear in
+multiple elements of @racket[bindings], but the combination of the
+symbol and scope set are unique within @racket[bindings] and across
+all scopes. The mapping of a symbol and scope set to a binding is
+recorded with an arbitrary member of the scope set.
+
+The @racket[bulk-bindings] field lists bindings of all exports from a
+given module, which is an optimization over including each export in
+@racket[bindings]. Elements of @racket[bindings] take precedence over
+elements of @racket[bulk-bindings], and earlier elements of
+@racket[bulk-bindings] take precedence over later elements.
+
+If the @racket[scope] represents a scope at a particular phase for a
+group of phase-specific scopes, @racket[mark-owner] refers to the
+group.}
+
+
+@defstruct+[(multi-scope zo) ([name exact-nonnegative-integer?]
+                              [src-name any/c]
+                              [scopes (listof (list/c (or/c #f exact-integer?) scope?)) #;#:mutable])]{
+
+Represents a set of phase-specific scopes that are added or removed
+from lexical information as a group. As for @racket[scope], the
+@racket[name] field is intended to be distinct for different groups,
+but the @racket[eq?] identity of the @racket[multi-scope] record
+ultimately determines its identity. The @racket[src-name] field
+similarly acts as a debugging hint in the same way as for
+@racket[syntax-debug-info].
+
+Scopes within the group are instantiated at different phases on
+demand. The @racket[scopes] field lists all of the scopes instantiated
+for the group, and the phase at which it is instantiated. Each element
+of @racket[scopes] must have a @racketidfont{multi-owner} field
+value that refers back to the @racket[multi-scope].}
+
+
+@defstruct+[(binding zo) ()]{
+
+A supertype for all binding representations.}
+
+
+@defstruct+[(module-binding binding) ([encoded any/c])]{
+
+Represents a binding to a module or top-level definition. The
+@racket[encoded] field can be unpacked using
+@racket[decode-module-binding], providing the symbol name for which
+the binding is the target (since @racket[encoded] can be relative to
+that name).}
+
+
+@defstruct+[(decoded-module-binding binding) ([path (or/c #f module-path-index?)]
+                                              [name symbol?]
+                                              [phase exact-integer?]
+                                              [nominal-path (or/c #f module-path-index?)]
+                                              [nominal-export-name symbol?]
+                                              [nominal-phase (or/c #f exact-integer?)]
+                                              [import-phase (or/c #f exact-integer?)]
+                                              [inspector-desc (or/c #f symbol?)])]{
+
+ARepresents a binding to a module or top-level definition---like
+@racket[module-binding], but in normalized form:
+
+@itemlist[
+
+ @item{@racket[path]: the referenced module.}
+
+ @item{@racket[name]: the referenced definition within its module.}
+
+ @item{@racket[phase]: the phase of the referenced definition within
+       its module.}
+
+ @item{@racket[nominal-path]: the module that was explicitly imported
+       into the binding context; this path can be different from
+       @racket[path] when a definition is re-exported.}
+
+ @item{@racket[nominal-export-name]: the name of the binding as
+       exported from @racket[nominal-path], which can be different from
+       @racket[name] due to renaming on export.}
+
+ @item{@racket[nominal-phase]: the phase of the export from
+       @racket[nominal-path], which can be different from @racket[phase]
+       due to re-export from a module that imports at a phase level other
+       than @racket[0].}
+
+ @item{@racket[import-phase]: the phase of the import of
+       @racket[nominal-path], which shifted (if non-@racket[0]) the
+       binding phase relative to the export phase from
+       @racket[nominal-path].}
+
+ @item{@racket[inspector-desc]: a name for an inspector (mapped to a
+       specific inspector at run time) that determines access to the
+       definition.}
+
+]}
+
+@defstruct+[(local-binding binding) ([name symbol?])]{
+
+Represents a local binding (i.e., not at the top level or module level).
+Such bindings rarely appear in bytecode, since @racket[quote-syntax]
+prunes them.}
+
+
+@defstruct+[(free-id=?-binding binding) ([base (and/c binding?
+                                                      (not/c free-id=?-binding?))]
+                                         [id stx-obj?]
+                                         [phase (or/c #f exact-integer?)])]{
+
+Represents a binding that includes a @racket[free-identifier=?] alias
+(to an identifier with a particular phase shift) as well as a base binding.}
+
+
+@defstruct+[(all-from-module zo) ([path module-path-index?] 
                                   [phase (or/c exact-integer? #f)] 
                                   [src-phase (or/c exact-integer? #f)]
+                                  [inspector-desc symbol?]
                                   [exceptions (listof symbol?)]
-             [prefix (or/c symbol? #f)]
+                                  [prefix (or/c symbol? #f)])]{
-             [context (or/c (listof exact-integer?) 
-                            (vector/c (listof exact-integer?) any/c) 
-                            #f)])]{
-  Represents a set of simple imports from one module within a
-  @racket[module-rename].}
 
-@defstruct+[(module-binding zo) ()]{
+Describes a bulk import as an optimization over individual imports of
-  A supertype for module bindings.}
+a module's exports:
 
-@defstruct+[(simple-module-binding module-binding)
+@itemlist[
-            ([path module-path-index?])]{
-  Represents a single identifier import within a
-  @racket[module-rename].}
 
-@defstruct+[(phased-module-binding module-binding)
+ @item{@racket[path]: the imported module.}
-            ([path module-path-index?]
-             [phase exact-integer?]
-             [export-name any/c]
-             [nominal-path nominal-path?]
-             [nominal-export-name any/c])]{
-  Represents a single identifier import within a
-  @racket[module-rename].}
  
-@defstruct+[(exported-nominal-module-binding module-binding)
+ @item{@racket[phase]: the phase of the import module's exports.}
-            ([path module-path-index?]
-             [export-name any/c]
-             [nominal-path nominal-path?]
-             [nominal-export-name any/c])]{
-  Represents a single identifier import within a
-  @racket[module-rename].}
 
-@defstruct+[(nominal-module-binding module-binding)
+ @item{@racket[src-phase]: the phase at which @racket[path] was
-            ([path module-path-index?]
+       imported; @racket[src-phase] combined with @racket[phase]
-             [nominal-path nominal-path?])]{
+       determines the phase of the bindings.}
-  Represents a single identifier import within a
-  @racket[module-rename].}
 
-@defstruct+[(exported-module-binding module-binding)
+ @item{@racket[inspector-desc]: a name for an inspector (mapped to a
-            ([path module-path-index?]
+       specific inspector at run time) that determines access to the
-             [export-name any/c])]{
+       definition.}
-  Represents a single identifier import within a
-  @racket[module-rename].}
 
-@defstruct+[(nominal-path zo) ()]{
+ @item{@racket[exceptions]: exports of @racket[path] that are omitted
-  A supertype for nominal paths.}
+       from the bulk import.}
  
-@defstruct+[(simple-nominal-path nominal-path)
+ @item{@racket[prefix]: a prefix, if any, applied (after
-            ([value module-path-index?])]{
+       @racket[exceptions]) to each of the imported names.}
-  Represents a simple nominal path.}
+
+]}
 
-@defstruct+[(imported-nominal-path nominal-path)
-            ([value module-path-index?]
-             [import-phase exact-integer?])]{
-  Represents an imported nominal path.}
  
-@defstruct+[(phased-nominal-path nominal-path)
-            ([value module-path-index?]
-             [import-phase (or/c false/c exact-integer?)]
-             [phase exact-integer?])]{
-  Represents a phased nominal path.}

pkgs/racket-doc/scribblings/reference/define-struct.scrbl

@@ -54,7 +54,7 @@ to @math{4+2n} names:
        @math{m} is the number of @racket[field]s that do not include
        an @racket[#:auto] option.}
 
- @item{@racket[id], a @tech{transformer binding} that encapsulates
+ @item{@racket[id], a @tech{transformer} binding that encapsulates
        information about the structure type declaration. This binding
        is used to define subtypes, and it also works with the
        @racket[shared] and @racket[match] forms. For detailed
@@ -163,8 +163,8 @@ must also be a @tech{prefab} structure type.
   (prefab-point? #s(prefab-point 1 2))
 ]
 
-If @racket[constructor-id] is supplied, then the @tech{transformer
+If @racket[constructor-id] is supplied, then the @tech{transformer}
-binding} of @racket[id] records @racket[constructor-id] as the
+binding of @racket[id] records @racket[constructor-id] as the
 constructor binding; as a result, for example, @racket[struct-out]
 includes @racket[constructor-id] as an export. If
 @racket[constructor-id] is supplied via

pkgs/racket-doc/scribblings/reference/logging.scrbl

@@ -178,7 +178,6 @@ that any event information it receives will never become accessible).
 
 @history[#:changed "6.1.1.3" @elem{Added the @racket[topic] argument.}]}
 
-
 @defproc[(log-max-level [logger logger?]
                         [topic (or/c symbol? #f) #f])
          (or/c #f 'fatal 'error 'warning 'info 'debug)]{

pkgs/racket-doc/scribblings/reference/notation.scrbl

@@ -62,7 +62,7 @@ as in the grammar for @racket[if]:
          (if test-expr then-expr else-expr)]
 ]
 
-Since every @deftech{form} is expressed in terms of @tech{syntax
+Since every @tech{form} is expressed in terms of @tech{syntax
 objects}, parentheses in a grammar specification indicate a @tech{syntax
 object} wrapping a list, and the leading @racket[if] is an identifier
 that starts the list whose @tech{binding} is the @racket[if] binding

pkgs/racket-doc/scribblings/reference/shared.scrbl

@@ -59,12 +59,12 @@ production take precedence over later variants:
 
 The @|maker| identifier above matches three kinds of references. The
 first kind is any binding whose name has @racketidfont{make-} in the
-middle, and where @|typedef| has a @tech{transformer binding} to
+middle, and where @|typedef| has a @tech{transformer} binding to
 structure information with a full set of mutator bindings; see
 @secref["structinfo"]. The second kind is an identifier that itself has a
-@tech{transformer binding} to structure information. The third kind is an
+@tech{transformer} binding to structure information. The third kind is an
 identifier that has a @racket['constructor-for] @tech{syntax property}
-whose value is an identifier with a @tech{transformer binding} to structure
+whose value is an identifier with a @tech{transformer} binding to structure
 information. A @racket[_shell-id], meanwhile, must be one of the
 @racket[id]s bound by the @racket[shared] form to a
 @racket[_shell-expr].

pkgs/racket-doc/scribblings/reference/struct.scrbl

@@ -418,7 +418,7 @@ determined by the corresponding @racket[expr]. If @racket[#:parent]
 is specified, the @racket[parent-id] must be bound to a parent
 structure type of @racket[id].
 
-The @racket[id] must have a @tech{transformer binding} that
+The @racket[id] must have a @tech{transformer} binding that
 encapsulates information about a structure type (i.e., like the
 initial identifier bound by @racket[struct]), and the binding
 must supply a constructor, a predicate, and all field accessors.
@@ -610,7 +610,7 @@ See @racket[make-prefab-struct] for a description of valid key shapes.}
 @section[#:tag "structinfo"]{Structure Type Transformer Binding}
 
 The @racket[struct] form binds the name of a structure type as
-a @tech{transformer binding} that records the other identifiers bound
+a @tech{transformer} binding that records the other identifiers bound
 to the structure type, the constructor procedure, the predicate
 procedure, and the field accessor and mutator procedures. This
 information can be used during the expansion of other expressions via

pkgs/racket-doc/scribblings/reference/stx-ops.scrbl

@@ -381,5 +381,62 @@ context does not include any bindings.}
 
 For backward compatibility only; returns @racket[new-stx].}
 
+
+@defproc[(syntax-debug-info [stx syntax?]
+                            [phase (or/c exact-integer? #f)]
+                            [all-bindings? any/c #f])
+         hash?]{
+
+Produces a hash table that describes the @tech{lexical information} of
+@racket[stx] (not counting components when @racket[(syntax-e stx)]
+would return a compound value). The result can include---but is not
+limited to---the following keys:
+
+@itemlist[
+
+ @item{@racket['name] --- the result of @racket[(syntax-e stx)], if it is a symbol.}
+
+ @item{@racket['context] --- a list of vectors, where each vector represents a scope
+       attached to @racket[stx].
+
+       Each vector starts with a number that is distinct for every
+       scope. A symbol afterward provides a hint at the scope's
+       origin: @racket['module] for a @racket[module] scope,
+       @racket['macro] for a macro-introduction scope,
+       @racket['use-site] for a macro use-site scope, or
+       @racket['local] for a local binding form. In the case of a
+       @racket['module] scope that corresponds to the inside edge, the
+       module's name and a phase (since an inside-edge scope is
+       generated for each phase) are shown.}
+
+  @item{@racket['bindings] --- a list of bindings, each represented by
+        a hash table. A binding table can include---but is not limited
+        to---the following keys:
+
+        @itemlist[
+
+          @item{@racket['name] --- the symbolic name for the binding.}
+
+          @item{@racket['context] --- the scopes, as a list of vectors,
+                for the binding.}
+
+          @item{@racket['local] --- a symbol representing a @tech{local binding};
+                when this key is present, @racket['module] is absent.}
+
+          @item{@racket['module] --- an encoding of a import from another module;
+                when this key is present, @racket['local] is absent.}
+
+          @item{@racket['free-identifier=?] --- a hash table of debugging information
+                from an identifier for which the binding is an alias.}
+
+          ]}
+
+   @item{@racket['fallbacks] --- a list of hash tables like the one
+         produced by @racket[syntax-debug-info] for cross-namespace binding fallbacks.}
+
+]
+
+@history[#:added "6.3"]}
+
 @close-eval[stx-eval]
 

pkgs/racket-doc/scribblings/reference/stx-trans.scrbl

@@ -31,7 +31,7 @@ the @racket[prop:set!-transformer] property, @racket[#f] otherwise.}
 
 Creates an @tech{assignment transformer} that cooperates with
 @racket[set!]. If the result of @racket[make-set!-transformer] is
-bound to @racket[_id] as a @tech{transformer binding}, then
+bound to @racket[_id] as a @tech{transformer} binding, then
 @racket[proc] is applied as a transformer when @racket[_id] is
 used in an expression position, or when it is used as the target of a
 @racket[set!] assignment as @racket[(set! _id _expr)]. When the
@@ -111,13 +111,11 @@ otherwise.
 ]}
 
 
-@defproc[(make-rename-transformer [id-stx syntax?]
+@defproc[(make-rename-transformer [id-stx syntax?])
-                                  [delta-introduce (identifier? . -> . identifier?)
-                                                   (lambda (id) id)])
          rename-transformer?]{
 
 Creates a @tech{rename transformer} that, when used as a
-@tech{transformer binding}, acts as a transformer that inserts the
+@tech{transformer} binding, acts as a transformer that inserts the
 identifier @racket[id-stx] in place of whatever identifier binds the
 transformer, including in non-application positions, in @racket[set!]
 expressions.
@@ -151,8 +149,7 @@ rename transformer:
        property}, then @racket[_id] (or its target) is not exported by
        @racket[all-defined-out].}
 
- @item{The @racket[syntax-local-value] and
+ @item{The @racket[syntax-local-value] function recognizes
-       @racket[syntax-local-make-delta-introducer] functions recognize
        rename-transformer bindings and consult their targets.}
 
 ]
@@ -161,7 +158,9 @@ rename transformer:
   (define-syntax my-or (make-rename-transformer #'or))
   (my-or #f #t)
   (free-identifier=? #'my-or #'or)
-]}
+]
+
+@history[#:changed "6.3" @elem{Removed an optional second argument.}]}
 
 
 @defproc[(rename-transformer-target [transformer rename-transformer?])
@@ -308,8 +307,8 @@ latter can be used in place of the former (perhaps in a larger
 expression produced by a macro transformer), and when the macro
 expander encounters the opaque object, it substitutes the fully
 expanded expression without re-expanding it; the
-@exnraise[exn:fail:syntax] if the expansion context includes bindings
+@exnraise[exn:fail:syntax] if the expansion context includes
-or marks that were not present for the original expansion, in which
+@tech{scopes} that were not present for the original expansion, in which
 case re-expansion might produce different results. Consistent use of
 @racket[syntax-local-expand-expression] and the opaque object thus
 avoids quadratic expansion times when local expansions are nested.
@@ -370,7 +369,8 @@ context}, @racket[#f] otherwise.}
 
 
 @defproc[(syntax-local-make-definition-context
-          [intdef-ctx (or/c internal-definition-context? #f) #f])
+          [intdef-ctx (or/c internal-definition-context? #f) #f]
+          [add-scope? any/c #f])
          internal-definition-context?]{
 
 Creates an opaque @tech{internal-definition context} value to be used
@@ -380,17 +380,25 @@ expanded, and use it when expanding any form whose lexical context
 should include the definitions. After discovering an internal
 @racket[define-values] or @racket[define-syntaxes] form, use
 @racket[syntax-local-bind-syntaxes] to add bindings to the context.
-Finally, the transformer must call
+
-@racket[internal-definition-context-seal] after all bindings have been
+An @tech{internal-definition context} internally creates a
-added; if an unsealed @tech{internal-definition context} is detected
+@tech{scope} to represent the context. Unless @racket[add-scope?] is
-in a fully expanded expression, the @exnraise[exn:fail:contract].
+@racket[#f], the @tech{scope} is added to any form that is expanded
+within the context or that appears as the result of a (partial)
+expansion within the context.
 
 If @racket[intdef-ctx] is not @racket[#f], then the new
-internal-definition context extends the given one. That is, expanding
+internal-definition context extends the given one. An extending
-in the new internal-definition context can use bindings previously
+definition context adds all @tech{scopes} that are added by
-introduced into @racket[intdef-ctx].
+@racket[intdef-ctx], and expanding in the new internal-definition context
+can use bindings previously introduced into @racket[intdef-ctx].
 
-@transform-time[]}
+@transform-time[]
+
+@history[#:changed "6.3" @elem{Added the @racket[add-scope?] argument,
+                               and made calling
+                               @racket[internal-definition-context-seal]
+                               no longer necessary.}]}
 
 
 @defproc[(syntax-local-bind-syntaxes [id-list (listof identifier?)]
@@ -412,12 +420,22 @@ match the number of identifiers, otherwise the
 @transform-time[]}
 
 
+@defproc[(internal-definition-context-introduce [intdef-ctx internal-definition-context?]
+                                                [stx syntax?]
+                                                [mode (or/c 'flip 'add 'remove) 'flip])
+         syntax?]{
+
+Flips, adds, or removes (depending on @racket[mode]) the @tech{scope}
+for @racket[intdef-ctx] for all parts of @racket[stx].
+
+@history[#:added "6.3"]}
+
+
+
 @defproc[(internal-definition-context-seal [intdef-ctx internal-definition-context?])
          void?]{
 
-Indicates that no further bindings will be added to
+For backward compatibility only; has no effect.}
-@racket[intdef-ctx], which must not be sealed already. See also
-@racket[syntax-local-make-definition-context].}
 
 
 @defproc[(identifier-remove-from-definition-context [id-stx identifier?]
@@ -425,19 +443,14 @@ Indicates that no further bindings will be added to
                                                                       (listof internal-definition-context?))])
          identifier?]{
 
-Removes @racket[intdef-ctx] (or each identifier in the list) from the
+Removes all of the @tech{scopes} of @racket[intdef-ctx] (or of each
-@tech{lexical information} of @racket[id-stx]. This operation is
+element in a list @racket[intdef-ctx]) from @racket[id-stx].
-useful for correlating an identifier that is bound in an
-internal-definition context with its binding before the
-internal-definition context was created.
 
-If simply removing the contexts produces a different binding than
+The @racket[identifier-remove-from-definition-context] function is
-completely ignoring the contexts (due to nested internal definition
+provided for backward compatibility; the more general
-contexts, for example), then the resulting identifier is given a
+@racket[internal-definition-context-introduce] function is preferred.
-@tech{syntax mark} to simulate a non-existent lexical context. The
+
-@racket[intdef-ctx] argument can be a list because removing
+@history[#:changed "6.3" @elem{Simplified the operation to @tech{scope} removal.}]}
-internal-definition contexts one at a time can produce a different
-intermediate binding than removing them all at once.}
 
 
 @defproc[(syntax-local-value [id-stx syntax?]
@@ -448,7 +461,7 @@ intermediate binding than removing them all at once.}
                                          #f])
          any]{
 
-Returns the @tech{transformer binding} value of @racket[id-stx] in
+Returns the @tech{transformer} binding value of @racket[id-stx] in
 either the context associated with @racket[intdef-ctx] (if not
 @racket[#f]) or the context of the expression being expanded (if
 @racket[intdef-ctx] is @racket[#f]).  If @racket[intdef-ctx] is
@@ -460,7 +473,7 @@ with @racket[make-rename-transformer], @racket[syntax-local-value]
 effectively calls itself with the target of the rename and returns
 that result, instead of the @tech{rename transformer}.
 
-If @racket[id-stx] has no @tech{transformer binding} (via
+If @racket[id-stx] has no @tech{transformer} binding (via
 @racket[define-syntax], @racket[let-syntax], etc.) in that
 environment, the result is obtained by applying @racket[failure-thunk]
 if not @racket[#f]. If @racket[failure-thunk] is @racket[false], the
@@ -591,7 +604,7 @@ to the top-level or to the top of the module currently being expanded
  or to an enclosing @racket[begin-for-syntax]..
 
 The resulting syntax object is the same as @racket[stx], except that a
-fresh @tech{syntax mark} is added. The same @tech{syntax mark} is
+fresh @tech{scope} is added. The same @tech{scope} is
 added to the lifted @racket[#%require] form, so that the
 @racket[#%require] form can bind uses of imported identifiers in the
 resulting syntax object (assuming that the lexical information of
@@ -698,34 +711,34 @@ expansion context.
 @transform-time[]}
 
 
-@defproc[(syntax-local-get-shadower [id-stx identifier?]) identifier?]{
+@defproc[(syntax-local-get-shadower [id-stx identifier?]
+                                    [only-generated? any/c #f])
+         identifier?]{
 
-Returns @racket[id-stx] if no binding in the current expansion context
+Adds @tech{scopes} to @racket[id-stx] so that it refers to bindings
-shadows @racket[id-stx] (ignoring unsealed @tech{internal-definition
+in the current expansion context or could bind any identifier obtained
-contexts} and identifiers that had the @indexed-racket['unshadowable]
+via @racket[(syntax-local-get-shadower id-stx)] in more nested contexts.
-@tech{syntax property}), if @racket[id-stx] has no module bindings in
+If @racket[only-generated?] is true, the phase-spanning @tech{scope}
-its lexical information, and if the current expansion context is not a
+of the enclosing module or namespace is omitted from the added scopes,
-@tech{module context}.
+however, which limits the bindings that can be referenced (and
+therefore avoids certain ambiguous references).
 
-If a binding of @racket[inner-identifier] shadows @racket[id-stx], the
+This function is intended for the implementation of
-result is the same as @racket[(syntax-local-get-shadower
+@racket[syntax-parameterize] and @racket[local-require].
-inner-identifier)], except that it has the location and properties of
-@racket[id-stx]. When searching for a shadowing binding, bindings from
-unsealed @tech{internal-definition contexts} are ignored.
 
-Otherwise, the result is the same as @racket[id-stx] with its module
+@transform-time[]
-bindings (if any) removed from its lexical information, and the
-lexical information of the current @tech{module context} (if any)
-added.
 
-Thus, the result is an identifier corresponding to the innermost
+@history[#:changed "6.3" @elem{Simplified to the minimal functionality
-shadowing of @racket[id-stx] in the current context if it is shadowed,
+                               needed for @racket[syntax-parameterize]
-and a module-contextless version of @racket[id-stx] otherwise.
+                               and @racket[local-require].}]}
 
-If @racket[id-stx] is @tech{tainted} or @tech{armed}, then the
-resulting identifier is @tech{tainted}.
 
-@transform-time[]}
+@defproc[(syntax-local-make-delta-introducer [id-stx identifier?]) procedure?]{
+
+For (limited) backward compatibility only; raises @racket[exn:fail:supported].
+
+@history[#:changed "6.3" @elem{changed to raise @racket[exn:fail:supported].}]}
+
 
 
 @defproc[(syntax-local-certifier [active? boolean? #f])
@@ -749,77 +762,71 @@ transformer} application by the expander for an expression
 within a @racket[module] form, @racket[#f] otherwise.}
 
 
+@defproc[(syntax-local-identifier-as-binding [id-stx identifier?]) identifier?]{
+
+Returns an identifier like @racket[id-stx], but without @tech{use-site
+scopes} that were previously added to the identifier as part of a
+macro expansion in the current definition context.
+
+In a @tech{syntax transformer} that runs in a non-expression context
+and forces the expansion of subforms with @racket[local-expand], use
+@racket[syntax-local-identifier-as-binding] on an identifier from the
+expansion before moving it into a binding position or comparing with
+with @racket[bound-identifier=?]. Otherwise, the results can be
+inconsistent with the way that @racket[define] works in the same
+definition context.
+
+@transform-time[]
+
+@history[#:added "6.3"]}
+
 @defproc[(syntax-local-introduce [stx syntax?]) syntax?]{
 
-Produces a syntax object that is like @racket[stx], except that a
+Produces a syntax object that is like @racket[stx], except that the
-@tech{syntax mark} for the current expansion is added (possibly
+presence of @tech{scopes} for the current expansion---both the. See
-canceling an existing mark in parts of @racket[stx]). See
+@secref["transformer-model"] for information on @tech{scopes}.
-@secref["transformer-model"] for information on @tech{syntax
-marks}.
 
 @transform-time[]}
 
 
-@defproc[(make-syntax-introducer) (syntax? . -> . syntax?)]{
+@defproc[(make-syntax-introducer) ((syntax?) ((or/c 'flip 'add 'remove)) . ->* . syntax?)]{
+
+Produces a procedure that behaves similar to
+@racket[syntax-local-introduce], but using a fresh @tech{scope},
+and where the action of the scope can be @racket['flip] (the default),
+@racket['add] to add the scope regardless of whether it is present already,
+or @racket['remove] to remove the scope when it is currently present.
+
+Multiple applications of the same
+@racket[make-syntax-introducer] result procedure use the same scope,
+and different result procedures use distinct scopes.
+
+@history[#:changed "6.3" @elem{Added the optional operation argument
+                               in the result procedure.}]}
 
-Produces a procedure that behaves like
-@racket[syntax-local-introduce], but using a fresh @tech{syntax
-mark}. Multiple applications of the same
-@racket[make-syntax-introducer] result procedure use the same mark,
-and different result procedures use distinct marks.}
 
 @defproc[(make-syntax-delta-introducer [ext-stx syntax?] 
                                        [base-stx (or/c syntax? #f)]
                                        [phase-level (or/c #f exact-integer?)
                                                     (syntax-local-phase-level)])
-         (syntax? . -> . syntax?)]{
+         ((syntax?) ((or/c 'flip 'add 'remove)) . ->* . syntax?)]{
 
-Produces a procedure that behaves like
+Produces a procedure that behaves like the result of
-@racket[syntax-local-introduce], but using the @tech{syntax marks} of
+@racket[make-syntax-introducer], but using the @tech{scopes} of
-@racket[ext-stx] that are not shared with @racket[base-stx].  If
+@racket[ext-stx] that are not shared with @racket[base-stx].
-@racket[ext-stx] does not extend the set of marks in @racket[base-stx]
-or if @racket[base-stx] is @racket[#f], and if @racket[ext-stx] has a
-module binding in the @tech{phase level} indicated by
-@racket[phase-level], then any marks of @racket[ext-stx] that would be
-needed to preserve its binding are not transferred in an introduction.
 
 This procedure is potentially useful when @racket[_m-id] has a
 transformer binding that records some @racket[_orig-id], and a use of
 @racket[_m-id] introduces a binding of @racket[_orig-id]. In that
-case, the @tech{syntax marks} in the use of @racket[_m-id] since the
+case, the @tech{scopes} one the use of @racket[_m-id] added since the
 binding of @racket[_m-id] should be transferred to the binding
 instance of @racket[_orig-id], so that it captures uses with the same
 lexical context as the use of @racket[_m-id].
 
-More typically, however, @racket[syntax-local-make-delta-introducer]
-should be used, since it cooperates with @tech{rename transformers}.
-
 If @racket[ext-stx] is @tech{tainted} or @tech{armed}, then an
 identifier result from the created procedure is @tech{tainted}.}
 
 
-@defproc[(syntax-local-make-delta-introducer [id identifier?])
-         (identifier? . -> . identifier?)]{
-
-Determines the binding of @racket[id]. If the binding is not a
-@tech{rename transformer}, the result is an introducer as created by
-@racket[make-syntax-delta-introducer] using @racket[id] and the
-binding of @racket[id] in the environment of expansion. If the binding
-is a @tech{rename transformer}, then the introducer is one composed
-with the target of the @tech{rename transformer} and its
-binding. Furthermore, the @racket[_delta-introduce] functions
-associated with the @tech{rename transformers} (supplied as the second
-argument to @racket[make-rename-transformer]) are composed (in
-first-to-last order) before the introducers created with
-@racket[make-syntax-delta-introducer] (which are composed
-last-to-first).
-
-The @exnraise[exn:fail:contract] if @racket[id] or any identifier in
-its rename-transformer chain has no binding.
-
-@transform-time[]}
-
-
 @defproc[(syntax-local-transforming-module-provides?) boolean?]{
 
 Returns @racket[#t] while a @tech{provide transformer} is running (see
@@ -896,7 +903,7 @@ The @racket[liberal-define-context?] predicate returns @racket[#t] if
 
 @note-lib-only[racket/require-transform]
 
-A @tech{transformer binding} whose value is a structure with the
+A @tech{transformer} binding whose value is a structure with the
 @racket[prop:require-transformer] property implements a derived
 @racket[_require-spec] for @racket[require] as a @deftech{require
 transformer}.
@@ -1059,14 +1066,14 @@ first argument.}
 
 @note-lib-only[racket/provide-transform]
 
-A @tech{transformer binding} whose value is a structure with the
+A @tech{transformer} binding whose value is a structure with the
 @racket[prop:provide-transformer] property implements a derived
 @racket[_provide-spec] for @racket[provide] as a @deftech{provide transformer}.
 A @tech{provide transformer} is applied as part of the last phase of
 a module's expansion, after all other declarations and expressions within
 the module are expanded.
 
-A @tech{transformer binding} whose value is a structure with the
+A @tech{transformer} binding whose value is a structure with the
 @racket[prop:provide-pre-transformer] property implements a derived
 @racket[_provide-spec] for @racket[provide] as a @deftech{provide
 pre-transformer}.  A @tech{provide pre-transformer} is applied as part
@@ -1075,7 +1082,7 @@ first phase, a @tech{provide pre-transformer} can use functions such
 as @racket[syntax-local-lift-expression] to introduce expressions and
 definitions in the enclosing module.
 
-An identifier can have a @tech{transformer binding} to a value that
+An identifier can have a @tech{transformer} binding to a value that
 acts both as a @tech{provide transformer} and @tech{provide
 pre-transformer}. The result of a @tech{provide
 pre-transformer} is @emph{not} automatically re-expanded, so a

pkgs/racket-doc/scribblings/reference/syntax-model.scrbl

@@ -31,51 +31,95 @@ process, and when the @tech{expansion} process encounters a
 new binding information.
 
 @;------------------------------------------------------------------------
-@section[#:tag "id-model"]{Identifiers and Binding}
+@section[#:tag "id-model"]{Identifiers, Binding, and Scopes}
 
 @guideintro["binding"]{binding}
 
 An @deftech{identifier} is a source-program entity. Parsing (i.e.,
 expanding) a Racket program reveals that some @tech{identifiers}
-correspond to @tech{variables}, some refer to syntactic forms, and
+correspond to @tech{variables}, some refer to @tech{syntactic forms}
-some are quoted to produce a symbol or a syntax object.
+(such as @racket[lambda], which is the @tech{syntactic form} for
+functions), some refer to @tech{transformers} for macro expansion, and
+some are quoted to produce @tech{symbols} or @tech{syntax objects}. An
+identifier @deftech{binds} another (i.e., it is a @deftech{binding})
+when the former is parsed as a @tech{variable} or syntactic form and
+the latter is parsed as a @deftech{reference} to the former; the
+latter is @deftech{bound}.
 
-An identifier @deftech{binds} another (i.e., it is a
+For example, as a fragment of source, the text
-@deftech{binding}) when the former is parsed as a @tech{variable} and
-the latter is parsed as a reference to the former; the latter is
-@deftech{bound}. The @deftech{scope} of a @tech{binding} is the set
-of source forms to which it applies. The @deftech{environment} of a
-form is the set of bindings whose @tech{scope} includes the form. A
-binding for a sub-expression @deftech{shadows} any @tech{bindings}
-(i.e., it is @deftech{shadowing}) in its @tech{environment}, so that
-uses of an @tech{identifier} refer to the @tech{shadowing}
-@tech{binding}. 
-
-For example, as a bit of source, the text
 
 @racketblock[(let ([x 5]) x)]
 
 includes two @tech{identifiers}: @racket[let] and @racket[x] (which
-appears twice). When this source is parsed in a typical
+appears twice). When this source is parsed in a context where
-@tech{environment}, @racket[x] turns out to represent a
+@racket[let] has its usual meaning, the first @racket[x] @tech{binds}
-@tech{variable} (unlike @racket[let]). In particular, the first
+the second @racket[x].
-@racket[x] @tech{binds} the second @racket[x].
+
+Bindings and references are determined through @tech{scope sets}. A
+@deftech{scope} corresponds to a region of the program that is either
+in part of the source or synthesized through elaboration of the
+source. Nested binding contexts (such as nested functions) create
+nested @tech{scopes}, while macro expansion creates scopes that
+overlap in more complex ways. Conceptually, each @tech{scope} is
+represented by a unique token, but the token is not directly
+accessible. Instead, each @tech{scope} is represented by a value that
+is internal to the representation of a program.
+
+A @deftech{form} is a fragment of a program, such as an identifier or
+a function call. A @tech{form} is represented as a @tech{syntax
+object}, and each syntax object has an associated set of @tech{scopes}
+(i.e., a @deftech{scope set}). In the above example,
+the representations of the @racket[x]s include the @tech{scope} that
+corresponds to the @racket[let] form.
+
+When a @tech{form} parses as the binding of a particular identifier,
+parsing updates a global table that maps a combination of an
+identifier's @tech{symbol} and @tech{scope set} to it's meaning: a
+@tech{variable}, a @tech{syntactic form}, or a @tech{transformer}. An
+identifier refers to a particular binding when the reference's symbol
+and the identifier's symbol are the same, and when the reference's
+@tech{scope set} is a subset of the binding's
+@tech{scope set}. For a given identifier, multiple bindings may have
+@tech{scope sets} that are subsets of the identifier's; in that case,
+the identifier refers to the binding whose set is a superset of all
+others; if no such binding exists, the reference is ambiguous (and triggers a syntax
+error if it is parsed as an expression). A binding @deftech{shadows}
+any @tech{binding} (i.e., it is @deftech{shadowing} any @tech{binding}) 
+that the same symbol but a subset of scopes.
+
+For example, in
+
+@racketblock[(let ([x 5]) x)]
+
+in a context where @racket[let] corresponds to the usual
+@tech{syntactic form}, the parsing of @racket[let] introduces a new
+scope for the binding of @racket[x]. Since the second @racket[x]
+receives that scope as part of the @racket[let] body, the first
+@racket[x] @tech{binds} the second @racket[x]. In the more complex
+case
+
+@racketblock[(let ([x 5])
+               (let ([x 6])
+                 x))]
+
+the inner @racket[let] creates a second scope for the second
+@racket[x]s, so its @tech{scope set} is a superset of the first
+@racket[x]'s @tech{scope set}---which means that the binding for the
+second @racket[x] @tech{shadows} the one for the first @racket[x], and
+the third @racket[x] refers to the binding created by the second one.
 
 A @deftech{top-level binding} is a @tech{binding} from a definition at
 the top-level; a @deftech{module binding} is a binding from a
-definition in a module; all other bindings are @deftech{local bindings}.
+definition in a module; all other bindings are @deftech{local
-There is no difference between an @deftech{unbound}
+bindings}. Within a module, references to @tech{top-level bindings}
-identifier and one with a @tech{top-level binding}; within a module,
+are disallowed. An identifier without a binding is @deftech{unbound}.
-references to @tech{top-level bindings} are disallowed, and so such
-identifiers are called @tech{unbound} in a module context.
 
 Throughout the documentation, @tech{identifiers} are typeset to
-suggest the way that they are parsed. A black, boldface
+suggest the way that they are parsed. A hyperlinked identifier
-@tech{identifier} like @racket[lambda] indicates a reference to a
+like @racket[lambda] indicates a reference to a syntactic form or
-syntactic form. A plain blue @tech{identifier} like @racketidfont{x}
+variable. A plain identifier like @racketidfont{x} is a
-is a @tech{variable} or a reference to an unspecified @tech{top-level
+@tech{variable} or a reference to an unspecified @tech{top-level
-variable}. A hyperlinked @tech{identifier} @racket[cons] is a
+variable}.
-reference to a specific @tech{top-level variable}.
 
 Every binding has a @deftech{phase level} in which it can be
 referenced, where a @tech{phase level} normally corresponds to an
@@ -95,23 +139,31 @@ correspond to any execution time; it is used to track bindings (e.g.,
 to identifiers within documentation) without implying an execution
 dependency.
 
-If an identifier has a @tech{local binding}, then it is the same for
+An identifier can have different bindings in different @tech{phase
-all phase levels, though the reference is allowed only at a particular
+levels}. More precisely, the @tech{scope set} associated with a
-phase level. Attempting to reference a @tech{local binding} in a
+@tech{form} can be different at different phase levels; a top-level or
-different @tech{phase level} from the binding's context produces a
+module context implies a distinct scope at every phase level, while
-syntax error. If an identifier has a @tech{top-level binding} or
+scopes from macro expansion or other syntactic forms are added to a
-@tech{module binding}, then it can have different such bindings in
+form's @tech{scope sets} at all phases. The context of each binding
-different phase levels.
+and reference determines the @tech{phase level} whose @tech{scope set} is
+relevant.
+
+@history[#:changed "6.3" @elem{Changed local bindings to have a
+                               specific phase level, like top-level
+                               and module bindings.}]
 
 @;------------------------------------------------------------------------
 @section[#:tag "stxobj-model"]{Syntax Objects}
 
 A @deftech{syntax object} combines a simpler Racket value, such as a
-symbol or pair, with @deftech{lexical information} about bindings,
+symbol or pair, with a @tech{scope set} at each @tech{phase level},
 source-location information, @tech{syntax properties}, and
 @tech{tamper status}. In particular, an @tech{identifier} is
-represented as a symbol object that combines a symbol with lexical and
+represented as a syntax object that combines a @tech{symbol} with scope sets
-other information.
+and other information. The @deftech{lexical information} of a
+@tech{syntax object} is its @tech{scope set} combined with the portion
+of the global table of bindings that is relevant to the syntax
+object's set of scopes.
 
 For example, a @racketidfont{car} @tech{identifier} might have
 @tech{lexical information} that designates it as the @racket[car] from
@@ -126,7 +178,8 @@ an @tech{identifier} or simple constant, its internal components can
 be extracted. Even for extracted identifiers, detailed information
 about binding is available mostly indirectly; two identifiers can be
 compared to determine whether they refer to the same binding (i.e.,
-@racket[free-identifier=?]), or whether each identifier would bind the
+@racket[free-identifier=?]), or whether the identifiers have the same
+@tech{scope set} so that each identifier would bind the
 other if one were in a binding position and the other in an expression
 position (i.e., @racket[bound-identifier=?]).
 
@@ -142,7 +195,7 @@ will indicate that the @racket[x]s are the same. In contrast, the
 @racket[bound-identifier=?] to either @racket[x].
 
 The @tech{lexical information} in a @tech{syntax object} is
-independent of the other half, and it can be copied to a new syntax
+independent of the rest of the @tech{syntax object}, and it can be copied to a new syntax
 object in combination with an arbitrary other Racket value. Thus,
 identifier-@tech{binding} information in a @tech{syntax object} is
 predicated on the symbolic name of the @tech{identifier} as well as
@@ -159,9 +212,12 @@ an identifier that is @racket[bound-identifier=?] to both @racket[x]s.
 
 The @racket[quote-syntax] form bridges the evaluation of a program and
 the representation of a program. Specifically, @racket[(quote-syntax
-_datum)] produces a syntax object that preserves all of the lexical
+_datum #:local)] produces a syntax object that preserves all of the
-information that @racket[_datum] had when it was parsed as part of the
+lexical information that @racket[_datum] had when it was parsed as
-@racket[quote-syntax] form.
+part of the @racket[quote-syntax] form. Note that
+@racket[(quote-syntax _datum)] form is similar, but it removes certain
+@tech{scopes} from the @racket[_datum]'s @tech{scope sets};
+see @racket[quote-syntax] for more information.
 
 @;------------------------------------------------------------------------
 @section[#:tag "expansion"]{Expansion@aux-elem{ (Parsing)}}
@@ -229,6 +285,7 @@ the binding (according to @racket[free-identifier=?]) matters.}
       (set! id expr)
       (@#,racket[quote] datum)
       (quote-syntax datum)
+      (quote-syntax datum #:local)
       (with-continuation-mark expr expr expr)
       (#%plain-app expr ...+)
       (#%top . id)
@@ -260,15 +317,32 @@ In a fully expanded program for a namespace whose @tech{base phase} is
 @math{N} if the bindings has @math{N} surrounding
 @racket[begin-for-syntax] and @racket[define-syntaxes] forms---not
 counting any @racket[begin-for-syntax] forms that wrap a
-@racket[module] form for the body of the @racket[module]. The
+@racket[module] or @racket[module*] form for the body of the @racket[module]
-@racket[_datum] in a @racket[quote-syntax] form, however, always
+or @racket[module*], unless a @racket[module*] form as @racket[#f] in place
+of a @racket[_module-path] after the @racket[_id]. The
+@racket[_datum] in a @racket[quote-syntax] form
 preserves its information for all @tech{phase level}s.
 
-In addition to the grammar above, @racket[letrec-syntaxes+values] can
+A reference to a @tech{local binding} in a fully expanded program has
-appear in a fully local-expanded expression, as can
+a @tech{scope set} that matches its binding identifier exactly.
-@racket[#%expression] in any expression position. For example,
+Additional @tech{scopes}, if any, are removed. As a result,
-@racket[letrec-syntaxes+values] and @racket[#%expression] can appear
+@racket[bound-identifier=?] can be used to correlate local binding
-in the result from @racket[local-expand] when the stop list is empty.
+identifiers with reference identifiers, while
+@racket[free-identifier=?] must be used to relate references to
+@tech{module bindings} or @tech{top-level bindings}.
+
+In addition to the grammar above, @racket[#%expression] can appear in
+a fully local-expanded expression position. For example,
+@racket[#%expression] can appear in the result from
+@racket[local-expand] when the stop list is empty.
+Reference-identifier @tech{scope sets} are reduced in local-expanded
+expressions only when the @racket[local-expand] stop list is empty.
+
+@history[#:changed "6.3" @elem{Added the @racket[#:local] variant of
+                               @racket[quote-syntax]; removed
+                               @racket[letrec-syntaxes+values] from
+                               possibly appearing in a fully
+                               local-expanded form.}]
 
 @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 @subsection[#:tag "expand-steps"]{Expansion Steps}
@@ -282,19 +356,21 @@ the @tech{syntax object} being expanded:
  @item{If it is an @tech{identifier} (i.e., a syntax-object symbol),
        then a @tech{binding} is determined by the @tech{identifier}'s
        @tech{lexical information}. If the @tech{identifier} has a
-       @tech{binding} other than as a @tech{top-level variable}, that
+       @tech{binding}, that @tech{binding} is used to continue. If the @tech{identifier}
-       @tech{binding} is used to continue. If the @tech{identifier}
+       is @tech{unbound}, a new @tech{syntax-object} symbol
-       has no @tech{binding}, a new @tech{syntax-object} symbol
        @racket['#%top] is created using the @tech{lexical information}
        of the @tech{identifier}; if this @racketidfont{#%top}
-       @tech{identifier} has no @tech{binding} (other than as a
+       @tech{identifier} has no @tech{binding}, then parsing fails with an
-       @tech{top-level variable}), then parsing fails with an
        @racket[exn:fail:syntax] exception. Otherwise, the new
        @tech{identifier} is combined with the original
        @tech{identifier} in a new @tech{syntax-object} pair (also
        using the same @tech{lexical information} as the original
        @tech{identifier}), and the @racketidfont{#%top} @tech{binding}
-       is used to continue.}
+       is used to continue.
+
+       @history[#:changed "6.3" @elem{Changed the introduction of
+                                      @racket[#%top] in a top-level context
+                                      to @tech{unbound} identifiers only.}]}
 
  @item{If it is a @tech{syntax-object} pair whose first element is an
       @tech{identifier}, and if the @tech{identifier} has a
@@ -331,12 +407,12 @@ things:
 
 @itemize[
 
- @item{A @tech{transformer binding}, such as introduced by
+ @item{A @deftech{transformer}, such as introduced by
        @racket[define-syntax] or @racket[let-syntax]. If the
        associated value is a procedure of one argument, the procedure
        is called as a @tech{syntax transformer} (described below), and
        parsing starts again with the @tech{syntax-object} result. If
-       the @tech{transformer binding} is to any other kind of value,
+       the @tech{transformer} binding is to any other kind of value,
        parsing fails with an @racket[exn:fail:syntax] exception. The
        call to the @tech{syntax transformer} is @racket[parameterize]d
        to set @racket[current-namespace] to a @tech{namespace} that
@@ -407,9 +483,9 @@ core syntactic forms are encountered:
 @itemize[
 
  @item{When a @racket[require] form is encountered at the top level or
-       module level, all lexical information derived from the top
+       module level, each symbol specified by the form is paired with the
-       level or the specific module's level is extended with bindings
+       @tech{scope set} of the specification to introduce new bindings.
-       from the specified modules. If not otherwise indicated in the
+       If not otherwise indicated in the
        @racket[require] form, bindings are introduced at the
        @tech{phase level}s specified by the exporting modules:
        @tech{phase level} 0 for each normal @racket[provide],
@@ -432,11 +508,9 @@ core syntactic forms are encountered:
 
  @item{When a @racket[define], @racket[define-values],
        @racket[define-syntax], or @racket[define-syntaxes] form is
-       encountered at the top level or module level, all lexical
+       encountered at the top level or module level, a binding is
-       information derived from the top level or the specific module's
+       added @tech{phase level} 0 (i.e., the @tech{base environment}
-       level is extended with bindings for the specified identifiers
+       is extended) for each defined identifier.}
-       at @tech{phase level} 0 (i.e., the @tech{base environment} is
-       extended).}
 
  @item{When a @racket[begin-for-syntax] form is encountered at the top
        level or module level, bindings are introduced as for
@@ -448,12 +522,11 @@ core syntactic forms are encountered:
 
  @item{When a @racket[let-values] form is encountered, the body of the
        @racket[let-values] form is extended (by creating new
-       @tech{syntax objects}) with bindings for the specified
+       @tech{syntax objects}) with a fresh @tech{scope}. The @tech{scope} is added to the identifiers
-       identifiers. The same bindings are added to the identifiers
        themselves, so that the identifiers in binding position are
        @racket[bound-identifier=?] to uses in the fully expanded form,
        and so they are not @racket[bound-identifier=?] to other
-       identifiers. The bindings are available for use at the
+       identifiers. The new bindings are at the
        @tech{phase level} at which the @racket[let-values] form is
        expanded.}
 
@@ -461,18 +534,13 @@ core syntactic forms are encountered:
        @racket[letrec-syntaxes+values] form is encountered, bindings
        are added as for @racket[let-values], except that the
        right-hand-side expressions are also extended with the
-       bindings.}
+       new @tech{scope}.}
 
  @item{Definitions in @tech{internal-definition contexts} introduce
-       bindings as described in @secref["intdef-body"].}
+       new scopes and bindings as described in @secref["intdef-body"].}
 
 ]
 
-A new binding in lexical information maps to a new variable. The
-identifiers mapped to this variable are those that currently have the
-same binding (i.e., that are currently @racket[bound-identifier=?]) to
-the identifier associated with the binding.
-
 For example, in
 
 @racketblock[
@@ -480,18 +548,20 @@ For example, in
 ]
 
 the binding introduced for @racket[x] applies to the @racket[x] in the
-body, but not the @racket[y] in the body, because (at the point in
+body, because a fresh @tech{scope} is created and added to both the binding
-expansion where the @racket[let-values] form is encountered) the
+@racket[x] and reference @racket[x]. The same scope is added to the
-binding @racket[x] and the body @racket[y] are not
+@racket[y], but since it has a different symbol than the binding
-@racket[bound-identifier=?].
+@racket[x], it does not refer to the new binding. Any @racket[x]
+outside of this @racket[let-values] form does not receive the fresh
+@tech{scope} and therefore does not refer to the new binding.
 
 @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 @subsection[#:tag "transformer-model"]{Transformer Bindings}
 
 In a @tech{top-level context} or @tech{module context}, when the
 expander encounters a @racket[define-syntaxes] form, the binding that
-it introduces for the defined identifiers is a @deftech{transformer
+it introduces for the defined identifiers is a @tech{transformer}
-binding}. The @tech{value} of the @tech{binding} exists at expansion
+binding. The @tech{value} of the @tech{binding} exists at expansion
 time, rather than run time (though the two times can overlap), though
 the binding itself is introduced with @tech{phase level} 0 (i.e., in
 the @tech{base environment}).
@@ -502,7 +572,7 @@ be @tech{expand}ed (i.e., parsed) before it can be evaluated, and it is
 expanded at @tech{phase level} 1 (i.e., in the @tech{transformer
 environment}) instead of @tech{phase level} 0.
 
-If the resulting @racket[value] is a procedure of one argument or
+If the resulting @tech{value} is a procedure of one argument or
 the result of @racket[make-set!-transformer] on a procedure, then it
 is used as a @deftech{syntax transformer} (a.k.a. @deftech{macro}).
 The procedure is expected to accept a syntax object and return a
@@ -511,19 +581,20 @@ a call of the @tech{syntax transformer} by the expander; see
 @secref["expand-steps"].
 
 Before the expander passes a @tech{syntax object} to a transformer,
-the @tech{syntax object} is extended with a @deftech{syntax mark} (that
+the @tech{syntax object} is extended with a fresh @tech{scope} (that
-applies to all sub-@tech{syntax objects}). The result of the
+applies to all sub-@tech{syntax objects}) to distinguish @tech{syntax objects}
-transformer is similarly extended with the same @tech{syntax
+at the macro's use site from @tech{syntax objects} that are introduced by the macro;
-mark}. When a @tech{syntax object}'s @tech{lexical information}
+in the result of the transformer the presence of the @tech{scope} is
-includes the same mark twice in a row, the marks effectively
+flipped, so that introduced @tech{syntax objects} retain the @tech{scope},
-cancel. Otherwise, two identifiers are @racket[bound-identifier=?]
+and use-site @tech{syntax objects} do not have it. In addition, if
-(that is, one can bind the other) only if they have the same binding
+the use of a transformer is in the same definition context as its binding,
-and if they have the same marks---counting only marks that were added
+the use-site @tech{syntax object} is extended with an additional fresh
-after the binding.
+@deftech{use-site scope} that is not flipped in the transformer's result,
+so that only use-site @tech{syntax objects} have the @tech{use-site scope}.
 
-This marking process helps keep binding in an expanded program
+The @tech{scope}-introduction process for macro expansion helps keep
-consistent with the lexical structure of the source program. For
+binding in an expanded program consistent with the lexical structure
-example, the expanded form of the program
+of the source program. For example, the expanded form of the program
 
 @racketblock[
 (define x 12)
@@ -537,9 +608,7 @@ is
 
 @racketblock[
 (define x 12)
-(define-syntax m
+(define-syntax m ....)
-  (syntax-rules ()
-    [(_ id) (let ([x 10]) id)]))
 (let-values ([(x) 10]) x)
 ]
 
@@ -547,10 +616,61 @@ However, the result of the last expression is @racket[12], not
 @racket[10]. The reason is that the transformer bound to @racket[m]
 introduces the binding @racket[x], but the referencing @racket[x] is
 present in the argument to the transformer. The introduced @racket[x]
-is the one left with a mark, and the reference @racket[x] has no mark,
+is left with one fresh @tech{scope}, while the reference @racket[x] has a different fresh @tech{scope},
 so the binding @racket[x] is not @racket[bound-identifier=?] to the
 body @racket[x].
 
+A @tech{use-site scope} on a binding identifier is ignored when the
+definition is in the same context where the @tech{use-site scope} was
+introduced. This special treatment of @tech{use-site scopes} allows a
+macro to expand to a visible definition. For example, the expanded
+form of the program
+
+@racketblock[
+(define-syntax m
+  (syntax-rules ()
+    [(_ id) (define id 5)]))
+(m x)
+x
+]
+
+is
+
+@racketblock[
+(define-syntax m ....)
+(define x 5)
+x
+]
+
+where the @racket[x] in the @racket[define] form has a @tech{use-site
+scope} that is not present on the final @racket[x]. The final
+@racket[x] nevertheless refers to the definition, because the
+@tech{use-site scope} is effectively removed before installing the
+definition's binding. In contrast, the expansion of
+
+@racketblock[
+(define-syntax m
+  (syntax-rules ()
+    [(_ id) (let ([x 4])
+              (let ([id 5])
+                x))]))
+(m x)
+]
+
+is
+
+@racketblock[
+(define-syntax m ....)
+(let ([x 4])
+  (let ([x 5])
+    x))
+]
+
+where the second @racket[x] has a @tech{use-site scope} that prevents
+it from binding the final @racket[x]. The @tech{use-site scope} is not
+ignored in this case, because the binding is not part of the definition
+context where @racket[(m x)] was expanded.
+
 The @racket[set!] form works with the @racket[make-set!-transformer]
 and @racket[prop:set!-transformer] property to support
 @deftech{assignment transformers} that transform @racket[set!]
@@ -566,17 +686,17 @@ transformer binding's value. When @racket[_id] is bound to a
 @racket[make-rename-transformer], it is replaced with the target
 identifier passed to @racket[make-rename-transformer]. In addition, as
 long as the target identifier does not have a true value for the
-@racket['not-free-identifier=?] @tech{syntax property}, the lexical information that
+@racket['not-free-identifier=?] @tech{syntax property}, the
-contains the binding of @racket[_id] is also enriched so that
+binding table is extended to indicate that @racket[_id] is an alias
-@racket[_id] is @racket[free-identifier=?] to the target identifier,
+for the identifier in the @tech{rename transformer}. The
-@racket[identifier-binding] returns the same results for both
+@racket[free-identifier=?] function follows aliasing chains to determine
-identifiers, and @racket[provide] exports @racket[_id] as the target
+equality of bindings, the @racket[identifier-binding] function
-identifier. Finally, the binding is treated specially by
+similarly follows aliasing chains, and the @racket[provide] form
-@racket[syntax-local-value], and
+exports @racket[_id] as the target identifier. Finally, the
-@racket[syntax-local-make-delta-introducer] as used by @tech{syntax
+@racket[syntax-local-value] function follows @tech{rename transformer}
-transformer}s.
+chains even when binding aliases are not installed.
 
-In addition to using marks to track introduced identifiers, the
+In addition to using scopes to track introduced identifiers, the
 expander tracks the expansion history of a form through @tech{syntax
 properties} such as @racket['origin]. See @secref["stxprops"] for
 more information.
@@ -589,13 +709,13 @@ The expander's handling of @racket[letrec-syntaxes+values] is similar
 to its handling of @racket[define-syntaxes]. A
 @racket[letrec-syntaxes+values] can be expanded in an arbitrary phase
 level @math{n} (not just 0), in which case the expression for the
-@tech{transformer binding} is expanded at @tech{phase level} @math{n+1}.
+@tech{transformer} binding is expanded at @tech{phase level} @math{n+1}.
 
 The expressions in a @racket[begin-for-syntax] form are expanded and
 evaluated in the same way as for @racket[define-syntaxes]. However,
 any introduced bindings from definition within
 @racket[begin-for-syntax] are at @tech{phase level} 1 (not a
-@tech{transformer binding} at @tech{phase level} 0).
+@tech{transformer} binding at @tech{phase level} 0).
 
 @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 @subsection[#:tag "partial-expansion"]{Partial Expansion}
@@ -603,7 +723,7 @@ any introduced bindings from definition within
 In certain contexts, such as an @tech{internal-definition context} or
 @tech{module context}, @deftech{partial expansion} is used to determine
 whether forms represent definitions, expressions, or other declaration
-forms. Partial expansion works by cutting off the normal recursion
+forms. Partial expansion works by cutting off the normal recursive
 expansion when the relevant binding is for a primitive syntactic form.
 
 As a special case, when expansion would otherwise add an
@@ -622,15 +742,15 @@ internal-definition context are equivalent to local binding via
 @racket[letrec-syntaxes+values]; macro expansion converts internal
 definitions to a @racket[letrec-syntaxes+values] form.
 
-Expansion of an internal-definition context relies on @tech{partial
+Expansion of an internal-definition context begins with the
-expansion} of each @racket[_body] in an internal-definition sequence.
+introduction of a fresh @tech{scope} for the context. Thereafter,
-Partial expansion of each @racket[_body] produces a form matching one
+expansion relies on @tech{partial expansion} of each @racket[_body] in
-of the following cases:
+an internal-definition sequence. Partial expansion of each
+@racket[_body] produces a form matching one of the following cases:
 
 @itemize[
 
- @item{A @racket[define-values] form: The lexical context of all
+ @item{A @racket[define-values] form: The binding table is immediately enriched
-       syntax objects for the body sequence is immediately enriched
        with bindings for the @racket[define-values] form.  Further
        expansion of the definition is deferred, and partial expansion
        continues with the rest of the body.}
@@ -639,7 +759,7 @@ of the following cases:
        expanded and evaluated (as for a
        @racket[letrec-syntaxes+values] form), and a transformer
        binding is installed for the body sequence before partial
-       expansion continues with the est of the body.}
+       expansion continues with the rest of the body.}
 
  @item{A primitive expression form other than @racket[begin]: Further
        expansion of the expression is deferred, and partial expansion
@@ -670,7 +790,7 @@ expansion time, but also @deftech{visits} the referenced module when
 it is encountered by the expander. That is, the expander instantiates
 any variables defined in the module within @racket[begin-for-syntax],
 and it also evaluates all expressions for @racket[define-syntaxes]
-@tech{transformer bindings}.
+@tech{transformer} bindings.
 
 Module @tech{visits} propagate through @racket[require]s in the same
 way as module @tech{instantiation}. Moreover, when a module is
@@ -716,9 +836,8 @@ phases at or below the namespace's @tech{base phase}.
 
 When a top-level definition binds an identifier that originates from a
  macro expansion, the definition captures only uses of the identifier
- that are generated by the same expansion. This behavior is consistent
+ that are generated by the same expansion due to the fresh @tech{scope}
- with expansion in @tech{internal-definition contexts}, where the
+ that is generated for the expansion.
- defined identifier turns into a fresh lexical binding.
 
 @examples[
 (define-syntax def-and-use-of-x
@@ -743,8 +862,9 @@ x
 For a top-level definition (outside of a module), the order of
  evaluation affects the binding of a generated definition for a
  generated identifier use. If the use precedes the definition, then
- the use refers to a non-generated binding, just as if the generated
+ the use is resolved with the bindings that are in place that at
- definition were not present. (No such dependency on order occurs
+ point, which will not be a macro-generated binding.
+ (No such dependency on order occurs
  within a module, since a module binding covers the entire module
  body.) To support the declaration of an identifier before its use,
  the @racket[define-syntaxes] form avoids binding an identifier if the
@@ -787,30 +907,31 @@ bucket-2
 (defs-and-uses)
 ]
 
-Macro-generated @racket{require} and @racket{provide}
+Macro-generated @racket[require] and @racket[provide]
- clauses also introduce and reference generation-specific bindings:
+ clauses also introduce and reference generation-specific bindings
+ (due to the added @tech{scope}) with the same ordering effects as
+ for definitions. The bindings depend on the @tech{scope set} attached
+ to specific parts of the form:
 
 @itemize[
 
  @item{In @racket[require], for a @racket[_require-spec] of the form
  @racket[(rename-in [_orig-id _bind-id])] or @racket[(only-in
- .... [_orig-id _bind-id])], the @racket[_bind-id] is bound only for
+ .... [_orig-id _bind-id])], the @racket[_bind-id] supplies the
- uses of the identifier generated by the same macro expansion as
+ @tech{scope set} for the binding. In @racket[require] for other
- @racket[_bind-id]. In @racket[require] for other
  @racket[_require-spec]s, the generator of the @racket[_require-spec]
- determines the scope of the bindings.}
+ determines the @tech{scope set}.}
 
  @item{In @racket[provide], for a @racket[_provide-spec] of the form
  @racket[_id], the exported identifier is the one that binds
- @racket[_id] within the module in a generator-specific way, but the
+ @racket[_id], but the
- external name is the plain @racket[_id]. The exceptions for
+ external name is the plain, symbolic part of @racket[_id]. The exceptions for
- @racket[all-except-out] are similarly determined in a
+ @racket[all-except-out] are similarly determined, as is the @racket[_orig-id] binding of a
- generator-specific way, as is the @racket[_orig-id] binding of a
+ @racket[rename-out] form, and plain symbols are used for the
- @racket[rename-out] form, but plain identifiers are used for the
  external names. For @racket[all-defined-out], only identifiers with
- definitions having the same generator as the
+ definitions having only the scopes of
  @racket[(all-defined-out)] form are exported; the external name is
- the plain identifier from the definition.}
+ the plain symbol from the definition.}
 
 ]
 
@@ -838,49 +959,39 @@ it, compiles it, and evaluates it.
 @margin-note/ref{See @secref["Namespaces"] for functions that
 manipulate namespaces.}
 
-A @deftech{namespace} is a top-level mapping from symbols to binding
+A @deftech{namespace} is both a starting point for parsing and a
-information. It is the starting point for expanding an expression; a
+starting point for running @tech{compiled} code. A @tech{namespace}
-@tech{syntax object} produced by @racket[read-syntax] has no initial
+also has a @deftech{module registry} that maps module names to module
-lexical context; the @tech{syntax object} can be expanded after
+declarations (see @secref["module-eval-model"]). This registry is
-initializing it with the mappings of a particular namespace. A
+shared by all @tech{phase level}s, and it applies both to parsing and
-namespace is also the starting point evaluating expanded code, where
+to running @tech{compiled} code.
-the first step in evaluation is linking the code to specific module
-instances and top-level variables.
 
-For expansion purposes, a namespace maps each symbol in each
+As a starting point for parsing, a @tech{namespace} provides scopes
-@tech{phase level} to one of three possible bindings:
+(one per @tech{phase level}, plus one that spans all @tech{phase
+levels}). Operations such as @racket[namespace-require] create initial
+@tech{bindings} using the namespace's @tech{scopes}, and the further
+expansion and evaluation in the namespace can create additional
+@tech{bindings}. Evaluation of a form with a namespace always adds the
+namespace's phase-specific @tech{scopes} to the form and to any result
+of expanding the top-level form; as a result, every binding identifier
+has at least one @tech{scope}. The namespace's additional scope, which
+is added at all @tech{phase levels}, is added only on request (e.g.,
+by using @racket[eval] as opposed to @racket[eval-syntax]). Except for
+namespaces generated by a module (see @racket[module->namespace]),
+every namespace uses the same @tech{scope} as the one added to all
+@tech{phase levels}, while the @tech{scopes} specific to a @tech{phase
+level} are always distinct.
 
-@itemize[
+As a starting point evaluating @tech{compiled} code, each namespace
-
+encapsulates a distinct set of top-level variables at various
- @item{a particular @tech{module binding} from a particular module}
+@tech{phases}, as well as a potentially distinct set of module
-
+instances in each @tech{phase}. That is, even though module
- @item{a top-level transformer binding named by the symbol}
+declarations are shared for all @tech{phase levels}, module instances
-
+are distinct for each @tech{phase}. Each namespace has a @deftech{base
- @item{a top-level variable named by the symbol}
+phase}, which corresponds to the phase used by reflective operations
-
+such as @racket[eval] and @racket[dynamic-require]. In particular,
-]
+using @racket[eval] on a @racket[require] form @tech{instantiates} a
-
+module in the namespace's @tech{base phase}.
-An ``empty'' namespace maps all symbols to top-level variables.
-Certain evaluations extend a namespace for future expansions;
-importing a module into the top-level adjusts the namespace bindings
-for all of the imported names, and evaluating a top-level
-@racket[define] form updates the namespace's mapping to refer to a
-variable (in addition to installing a value into the variable).
-
-A namespace also has a @deftech{module registry} that maps module
-names to module declarations (see @secref["module-eval-model"]).
-This registry is shared by all @tech{phase level}s.
-
-For evaluation, each namespace encapsulates a distinct set of
-top-level variables at various @tech{phases}, as well as a potentially
-distinct set of module instances in each @tech{phase}. That is, even
-though module declarations are shared for all @tech{phase levels},
-module instances are distinct for each @tech{phase}. Each namespace
-has a @deftech{base phase}, which corresponds to the phase used by
-reflective operations such as @racket[eval] and
-@racket[dynamic-require]. In particular, using @racket[eval] on a
-@racket[require] form @tech{instantiates} a module in the namespace's
-@tech{base phase}.
 
 After a namespace is created, module instances from existing
 namespaces can be attached to the new namespace.  In terms of the
@@ -914,11 +1025,6 @@ and to start evaluating expanded/compiled code.
      (display (eval 'x)))) (code:comment @#,t{displays @racket['new]}))
 ]
 
-A @tech{namespace} is purely a top-level entity, not to be confused
-with an @tech{environment}. In particular, a @tech{namespace} does not
-encapsulate the full @tech{environment} of an expression inside
-local-binding forms.
-
 If an @tech{identifier} is bound to syntax or to an import, then
 defining the @tech{identifier} as a @tech{variable} shadows the syntax
 or import in future uses of the environment. Similarly, if an
@@ -944,6 +1050,17 @@ x
 (f)
 ]
 
+Like a top-level @tech{namespace}, each @racket[module] form has an
+associated @tech{scope} to span all @tech{phase levels} of the
+module's content, plus a @tech{scope} at each @tech{phase level}. The
+latter is added to every form, original or appearing through partial
+macro expansion, within the module's immediate body. Those same scopes
+are propagated to a namespace created by @racket[module->namespace]
+for the module. Meanwhile, parsing of a @racket[module] form begins by
+removing the all scopes that correspond to the enclosing top-level or
+(in the case of @tech{submodules}) @racket[module] and
+@racket[module*] forms.
+
 @;------------------------------------------------------------------------
 @section[#:tag "infernames"]{Inferred Value Names}
 

pkgs/racket-doc/scribblings/reference/syntax.scrbl

@@ -280,21 +280,6 @@ form. See also @racket[module-compiled-language-info],
 @racket[module->language-info], and
 @racketmodname[racket/language-info].
 
-If a @racket[module] form has a single body @racket[form] and if the
-form is a @racket[#%plain-module-begin] form, then the body
-@racket[form] is traversed to find @racket[module] and
-@racket[module*] forms that are either immediate, under
-@racket[begin], or under @racket[begin-for-syntax]. (That is, the 
-body is searched before adding
-any lexical context due to the module's initial @racket[module-path]
-import.) Each such module form is given a @indexed-racket['submodule]
-@tech{syntax property} that whose value is the initial module form.
-Then, when @racket[module] or @racket[module*] is expanded in a
-submodule position, if the form has a @indexed-racket['submodule]
-@tech{syntax property}, the property value is used as the form to
-expand. This protocol avoids the contamination of submodule lexical
-scope when re-expanding @racket[module] forms that contain submodules.
-
 See also @secref["module-eval-model"] and @secref["mod-parse"].
 
 @defexamples[#:eval (syntax-eval)
@@ -309,7 +294,11 @@ See also @secref["module-eval-model"] and @secref["mod-parse"].
 
 @history[#:changed "6.2.0.4" @elem{Changed @racket[define-syntaxes]
                                    and @racket[define-values] to
-                                   shadow any preceding import.}]}
+                                   shadow any preceding import.}
+         #:changed "6.3" @elem{Dropped the use of @racket['submodule]
+                               @tech{syntax property} values on nested
+                               @racket[module] or @racket[module*]
+                               forms.}]}
 
 
 @defform*[((module* id module-path form ...)
@@ -322,13 +311,20 @@ a module, and for submodules that may @racket[require] the enclosing module.
 
 Instead of a @racket[module-path] after @racket[id], @racket[#f]
 indicates that all bindings from the enclosing module are visible in
-the submodule; @racket[begin-for-syntax] forms that wrap the
+the submodule. In that case, @racket[begin-for-syntax] forms that wrap
-@racket[module*] form shift the @tech{phase level} of the enclosing
+the @racket[module*] form shift the @tech{phase level} of the
-module's bindings relative to the submodule.  When a
+enclosing module's bindings relative to the submodule. The macro
-@racket[module*] form has a @racket[module-path], the submodule
+expander handles such nesting by shifting the @tech{phase level} of
-starts with an empty lexical context in the same way as a top-level
+the @racket[module*] form so that it's body starts at @tech{phase
-@racket[module] form, and enclosing @racket[begin-for-syntax] forms
+level} 0, expanding, and then reverting the @tech{phase level} shift;
-have no effect on the submodule.}
+beware that this process can leave @tech{syntax objects} as
+@racket['origin] @tech{syntax property} values out-of-sync with the
+expanded module.
+
+When a @racket[module*] form has a @racket[module-path], the submodule
+expansion starts by removing the @tech{scopes} of the enclosing
+module, the same as the @racket[module] form. No shifting compensates
+for any @racket[begin-for-syntax] forms that may wrap the submodule.}
 
 
 @defform[(module+ id form ...)]{
@@ -389,7 +385,8 @@ Legal only in a @tech{module begin context}, and handled by the
 
 @defform[(#%declare declaration-keyword ...)
          #:grammar
-         ([declaration-keyword #:cross-phase-persistent])]{
+         ([declaration-keyword #:cross-phase-persistent
+                               #:empty-namespace])]{
 
 Declarations that affect run-time or reflective properties of the
 module:
@@ -401,6 +398,12 @@ module:
        error if the module does not meet the import or syntactic
        constraints of a @tech{cross-phase persistent} module.}
 
+@item{@indexed-racket[#:empty-namespace] --- declares that
+       @racket[module->namespace] for this module should produce a
+       namespace with no bindings; limiting namespace support in this
+       way can reduce the @tech{lexical information} that
+       otherwise must be preserved for the module.}
+
 ]
 
 A @racket[#%declare] form must appear in a @tech{module
@@ -408,7 +411,7 @@ context} or a @tech{module-begin context}. Each
 @racket[declaration-keyword] can be declared at most once within a
 @racket[module] body.
 
-}           
+@history[#:changed "6.3" @elem{Added @racket[#:empty-namespace].}]}           
 
 
 @;------------------------------------------------------------------------
@@ -1042,13 +1045,13 @@ as follows.
  @defsubform[(struct-out id)]{Exports the bindings associated with a
  structure type @racket[id]. Typically, @racket[id] is bound with
  @racket[(struct id ....)]; more generally, @racket[id] must have a
- @tech{transformer binding} of structure-type information at the relevant
+ @tech{transformer} binding of structure-type information at the relevant
  @tech{phase level}; see @secref["structinfo"].  Furthermore, for
  each identifier mentioned in the structure-type information, the
  enclosing module must define or import one identifier that is
  @racket[free-identifier=?]. If the structure-type information
  includes a super-type identifier, and if the identifier has a
- @tech{transformer binding} of structure-type information, the
+ @tech{transformer} binding of structure-type information, the
  accessor and mutator bindings of the super-type are @italic{not}
  included by @racket[struct-out] for export.
 
@@ -1603,7 +1606,7 @@ and finishes the expansion.
 
 @defform/none[id]{
 
-Refers to a module-level or local binding, when @racket[id] is
+Refers to a top-level, module-level, or local binding, when @racket[id] is
 not bound as a transformer (see @secref["expansion"]). At run-time,
 the reference evaluates to the value in the @tech{location} associated with
 the binding.
@@ -1621,12 +1624,13 @@ x
 ((lambda (x) x) 2)
 ]}
 
+
 @defform[(#%top . id)]{
 
-Refers to a module-level or top-level definition. If @racket[id] has a
+Equivalent to @racket[id] when @racket[id] is bound to a module-level
-local binding in its context, then @racket[(#%top . id)] refers to a
+or top-level variable. In a top-level context, @racket[(#%top . id)]
-top-level definition, but a reference to a top-level definition is
+always refers to a top-level variable, even if @racket[id] is
-disallowed within a module.
+@tech{unbound} or otherwise bound.
 
 Within a @racket[module] form, @racket[(#%top . id)] expands to just
 @racket[id]---with the obligation that @racket[id] is defined within
@@ -1642,7 +1646,11 @@ introduces @racketidfont{#%top} identifiers.
 @examples[
 (define x 12)
 (let ([x 5]) (#%top . x))
-]}
+]
+
+@history[#:changed "6.3" @elem{Changed the introduction of
+                               @racket[#%top] in a top-level context
+                               to @tech{unbound} identifiers only.}]}
 
 @;------------------------------------------------------------------------
 @section{Locations: @racket[#%variable-reference]}
@@ -2048,7 +2056,7 @@ and in the @racket[body]s.
 
 @margin-note/ref{See also @racket[splicing-let-syntax].}
 
-Creates a @tech{transformer binding} (see
+Creates a @tech{transformer} binding (see
 @secref["transformer-model"]) of each @racket[id] with the value of
 @racket[trans-expr], which is an expression at @tech{phase level} 1
 relative to the surrounding context. (See @secref["id-model"] for
@@ -2098,9 +2106,7 @@ compile-time bindings, since forms like @racket[letrec-syntax] and
 @tech{internal-definition contexts} expand to it. In a fully expanded
 expression (see @secref["fully-expanded"]), the @racket[trans-id]
 bindings are discarded and the form reduces to a combination of
-@racket[letrec-values] or @racket[let-values], but
+@racket[letrec-values] or @racket[let-values].
-@racket[letrec-syntaxes+values] can appear in the result of
-@racket[local-expand] with an empty stop list.
 
 For variables bound by @racket[letrec-syntaxes+values], the
 @tech{location}-creation rules differ slightly from
@@ -2114,7 +2120,10 @@ not refer to any of the clause's @racket[val-id]s, then
 @tech{locations} for the @racket[val-id]s are created @emph{after} the
 @racket[val-expr] is evaluated. Otherwise, @tech{locations} for all
 @racket[val-id]s in a set are created just before the first
-@racket[val-expr] in the set is evaluated.
+@racket[val-expr] in the set is evaluated. For the purposes
+of forming sets, a @racket[(quote-syntax _datum #:local)] form counts
+as a reference to all bindings in the @racket[letrec-syntaxes+values]
+form
 
 The end result of the @tech{location}-creation rules is that scoping
 and evaluation order are the same as for @racket[letrec-values], but
@@ -2435,7 +2444,7 @@ information, and see also @racket[begin-encourage-inline].}
 @defform*[[(define-syntax id expr)
            (define-syntax (head args) body ...+)]]{
 
-The first form creates a @tech{transformer binding} (see
+The first form creates a @tech{transformer} binding (see
 @secref["transformer-model"]) of @racket[id] with the value of
 @racket[expr], which is an expression at @tech{phase level} 1 relative
 to the surrounding context. (See @secref["id-model"] for information
@@ -2468,7 +2477,7 @@ a @racket[define-syntax] form introduces a local binding.
 
 @defform[(define-syntaxes (id ...) expr)]{
 
-Like @racket[define-syntax], but creates a @tech{transformer binding}
+Like @racket[define-syntax], but creates a @tech{transformer} binding
 for each @racket[id].  The @racket[expr] should produce as many values
 as @racket[id]s, and each value is bound to the corresponding
 @racket[id].
@@ -2568,7 +2577,7 @@ procedure that accepts and returns a syntax object representing a
 This form expands to @racket[define-syntax] with a use of
 @racket[make-require-transformer] (see @secref["require-trans"] for
 more information), and the @tech{syntax object} passed to and from the
-macro transformer is marked via @racket[syntax-local-require-introduce].
+macro transformer is adjusted via @racket[syntax-local-require-introduce].
 
 The second form is a shorthand the same as for @racket[define-syntax]; it
 expands to a definition of the first form where the @racket[proc-expr] is a
@@ -2599,7 +2608,7 @@ procedure that accepts and returns a syntax object representing a
 This form expands to @racket[define-syntax] with a use of
 @racket[make-provide-transformer] (see @secref["provide-trans"] for
 more information), and the @tech{syntax object} passed to and from the
-macro transformer is marked via @racket[syntax-local-provide-introduce].
+macro transformer is adjusted via @racket[syntax-local-provide-introduce].
 
 The second form is a shorthand the same as for @racket[define-syntax]; it
 expands to a definition of the first form where the @racket[expr] is a
@@ -2736,12 +2745,12 @@ Equivalent to @racket[(when (not test-expr) body ...+)].
 
 @defform[(set! id expr)]{
 
-If @racket[id] has a @tech{transformer binding} to an @tech{assignment
+If @racket[id] has a @tech{transformer} binding to an @tech{assignment
 transformer}, as produced by @racket[make-set!-transformer] or as an
 instance of a structure type with the @racket[prop:set!-transformer]
 property, then this form is expanded by calling the assignment
 transformer with the full expressions. If @racket[id] has a
-@tech{transformer binding} to a @tech{rename transformer} as produced
+@tech{transformer} binding to a @tech{rename transformer} as produced
 by @racket[make-rename-transformer] or as an instance of a structure
 type with the @racket[prop:rename-transformer] property, then this
 form is expanded by replacing @racket[id] with the target identifier
@@ -2906,12 +2915,21 @@ escape. An @racket[unquote-splicing] form as an expression is a syntax error.}
 @;------------------------------------------------------------------------
 @section{Syntax Quoting: @racket[quote-syntax]}
 
-@defform[(quote-syntax datum)]{
+@defform*[[(quote-syntax datum)
+           (quote-syntax datum #:local)]]{
 
 Similar to @racket[quote], but produces a @tech{syntax object}
 that preserves the @tech{lexical information} and source-location
 information attached to @racket[datum] at expansion time.
 
+When @racket[#:local] is specified, than all @tech{scopes} in the
+syntax object's @tech{lexical information} is preserved. When
+@racket[#:local] is omitted, then the @tech{scope sets} within
+@racket[datum] are pruned to omit the @tech{scope} for any binding
+form that appears between the @racket[quote-syntax] form and the
+enclosing top-level context, module body, or @tech{phase level}
+crossing, whichever is closer.
+
 Unlike @racket[syntax] (@litchar{#'}), @racket[quote-syntax] does
 not substitute pattern variables bound by @racket[with-syntax],
 @racket[syntax-parse], or @racket[syntax-case].
@@ -2921,8 +2939,14 @@ not substitute pattern variables bound by @racket[with-syntax],
 (quote-syntax (1 2 3))
 (with-syntax ([a #'5])
   (quote-syntax (a b c)))
+(free-identifier? (let ([x 1]) (quote-syntax x))
+                  (quote-syntax x))
+(free-identifier? (let ([x 1]) (quote-syntax x #:local))
+                  (quote-syntax x))
 ]
-}
+
+@history[#:changed "6.3" @elem{Added @tech{scope} pruning and support
+                               for @racket[#:local].}]}
 
 @;------------------------------------------------------------------------
 @section[#:tag "#%top-interaction"]{Interaction Wrapper: @racket[#%top-interaction]}

pkgs/racket-test-core/tests/racket/boundmap-test.rktl

@@ -144,11 +144,10 @@
                  (set! l (cons y l))))
               l)))))
 
-(let ()
+(define-syntax name-for-boundmap-test 'dummy)
-  (define-syntax name 'dummy)
+(define-syntax alias-for-boundmap-test (make-rename-transformer #'name-for-boundmap-test))
-  (define-syntax alias (make-rename-transformer #'name))
 (define table (make-free-identifier-mapping))
-  (free-identifier-mapping-put! table #'alias 0)
+(free-identifier-mapping-put! table #'alias-for-boundmap-test 0)
-  (test 0 free-identifier-mapping-get table #'name))
+(test 0 free-identifier-mapping-get table #'name-for-boundmap-test)
 
 (report-errs)

pkgs/racket-test-core/tests/racket/id-table-test.rktl

@@ -11,11 +11,16 @@
 (test #t mutable-bound-id-table? (make-bound-id-table))
 (test #t immutable-bound-id-table? (make-immutable-bound-id-table))
 
+(module module-that-supplies-a-b racket/base
+  (provide b)
+  (define b #'b))
+
 (let ()
-  (define a #'a)
+  (define i (make-syntax-introducer))
-  (define b #'b)
+  (define a (i #'a))
-  (define b2 (let ([b 0]) #'b))
+  (define b (i #'b))
-  (define b3 ((make-syntax-introducer) #'b)) ;; free=? to b
+  (define b2 (dynamic-require ''module-that-supplies-a-b 'b))
+  (define b3 ((make-syntax-introducer) b)) ;; free=? to b
   (define alist (list (cons a 1) (cons b 2) (cons b2 3) (cons b3 4)))
   (test 4 bound-id-table-count (make-bound-id-table alist))
   (test 4 bound-id-table-count (make-immutable-bound-id-table alist))
@@ -329,11 +334,10 @@
 
     ))
 
-(let ()
+(define-syntax name-for-boundmap-test 'dummy)
-  (define-syntax name 'dummy)
+(define-syntax alias-for-boundmap-test (make-rename-transformer #'name-for-boundmap-test))
-  (define-syntax alias (make-rename-transformer #'name))
 (define table (make-free-id-table))
-  (free-id-table-set! table #'alias 0)
+(free-id-table-set! table #'alias-for-boundmap-test 0)
-  (test 0 free-id-table-ref table #'name))
+(test 0 free-id-table-ref table #'name-for-boundmap-test)
 
 (report-errs)

pkgs/racket-test-core/tests/racket/macro.rktl

@@ -232,11 +232,12 @@
 
 (test #t 'free-identifier=?-of-rename-via-shadower
       (let ([y 5])
-        (let-syntax ([m (lambda (stx)
+        (let-syntax ([m (lambda ()
-                          #`(quote-syntax #,(syntax-local-get-shadower #'x)))])
+                          (syntax-local-get-shadower #'x))])
           (let-syntax ([x (make-rename-transformer #'y)])
-            (free-identifier=? (m) #'y)))))
+            (let-syntax ([n (lambda (stx)
-
+                              #`#,(free-identifier=? ((syntax-local-value #'m)) #'y))])
+              (n))))))
 
 (test #t set!-transformer? (make-set!-transformer void))
 (test #t rename-transformer? (make-rename-transformer #'void))
@@ -248,7 +249,7 @@
 
 (arity-test make-set!-transformer 1 1)
 (arity-test set!-transformer? 1 1)
-(arity-test make-rename-transformer 1 2)
+(arity-test make-rename-transformer 1 1)
 (arity-test rename-transformer? 1 1)
 
 ;; Test inheritance of context when . is used in a pattern
@@ -262,9 +263,8 @@
 (test 6 'plus (keep-context + 1 2 3))
 (test 6 'plus (keep-context . (+ 1 2 3)))
 
-(unless building-flat-tests?
 (eval-syntax
-   #'(test 6 'plus (discard-context keep-context . (+ 1 2 3)))))
+ #'(test 6 'plus (discard-context keep-context . (+ 1 2 3))))
 
 (syntax-test #'(discard-context + 1 2 3))
 (syntax-test #'(discard-context . (+ 1 2 3)))
@@ -503,47 +503,60 @@
   (+ 1 2)
   (module* q #f 10) (module* z #f 11))
 
+
+(module uses-internal-definition-context-around-id racket/base
+  (require (for-syntax racket/base
+                       racket/block))
+  
+  (define-syntax (m stx)
+    (let ([x1 #'x]
+          [x2 (block
+               (define x3 #'x)
+               x3)])
+      #`(let ([#,x2 1]) #,x1)))
+  
+  (define v (m))
+  (provide v))
+(test 1 dynamic-require ''uses-internal-definition-context-around-id 'v)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (module rename-transformer-tests racket/base
   (require (for-syntax racket/base))
 
   (define x 12)
-  (define-syntax bar (let ([x 10])
-                       (make-rename-transformer #'x)))
   (define-syntax foo (make-rename-transformer #'x))
   (list foo
         (identifier-binding #'foo)
         (free-identifier=? #'x #'foo))
-  (identifier-binding #'bar)
 
   (begin-for-syntax 
    (define-struct rt (id)
      #:property prop:rename-transformer 0
      #:omit-define-syntaxes))
 
-  (let-syntax ([q (make-rt #'x)])
+  (define-syntax v (make-rt #'x))
-    (list q
+  (list v
-          (identifier-binding #'q)
+        (identifier-binding #'v)
-          (free-identifier=? #'q #'x)))
+        (free-identifier=? #'v #'x))
 
-  (let ([w 11])
+  (define w 11)
-    (letrec-syntax ([q (let ()
+  (define-syntax q (let ()
                      (define-struct rt ()
                        #:property prop:rename-transformer #'w)
-                         (make-rt))])
+                     (make-rt)))
   (list q
         (identifier-binding #'q)
-            (free-identifier=? #'q #'w))))
+        (free-identifier=? #'q #'w))
 
-  (letrec-syntax ([n (make-rename-transformer #'glob)])
+  (define-syntax n1 (make-rename-transformer #'glob))
-    (list (identifier-binding #'n)
+  (list (identifier-binding #'n1)
-          (free-identifier=? #'n #'glob)))
+        (free-identifier=? #'n1 #'glob))
   
-  (letrec-syntax ([i (make-rename-transformer #'glob)])
+  (define-syntax i (make-rename-transformer #'glob))
-    (letrec-syntax ([n (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f))])
+  (define-syntax n2 (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f)))
-      (list (identifier-binding #'n)
+  (list (identifier-binding #'n2)
-            (free-identifier=? #'n #'glob)))))
+        (free-identifier=? #'n2 #'glob)))
 
 (let ([accum null])
   (parameterize ([current-print (lambda (v)
@@ -557,9 +570,8 @@
     (dynamic-require ''rename-transformer-tests #f))
   (test '((#f #t) 
           (#f #t)
-          (11 lexical #t)
+          (11 (mpi w mpi w 0 0 0) #t)
           (12 (mpi x mpi x 0 0 0) #t)
-          lexical
           (12 (mpi x mpi x 0 0 0) #t))
         values accum))
 
@@ -862,32 +874,6 @@
 
 ;; ----------------------------------------
 
-(module check-shadower-in-submodule racket/base
-  (require (for-syntax racket/base))
-  
-  (define-syntax (define-2 stx)
-    (syntax-case stx () 
-      [(_ id)
-       (with-syntax ([new-id
-                      ((make-syntax-introducer)
-                       (datum->syntax #f
-                                      (string->symbol
-                                       (format "~a2" (syntax-e #'id)))))])
-         #'(begin
-             (define new-id 5)
-             (define-syntax (id stx)
-               (syntax-local-get-shadower #'new-id))))]))
-  
-  (module* main #f
-    (provide out)
-    (define-2 f)
-    (define f2 6)
-    (define out f)))
-
-(test 5 dynamic-require '(submod 'check-shadower-in-submodule main) 'out)
-
-;; ----------------------------------------
-
 (parameterize ([current-namespace (make-base-namespace)])
   (define m '(module m racket/base
                (require racket/splicing
@@ -941,7 +927,7 @@
               _
               _
               (#%plain-lambda {one:id}
-                (letrec-syntaxes+values _ _ two:id)))
+                (let-values _ two:id)))
             
             (let ()
               (when (bound-identifier=? #'one #'two)
@@ -959,7 +945,7 @@
         (syntax-parse stx
           [(_ unmarked . body)
            (define/syntax-parse marked
-             (syntax-local-introduce (attribute unmarked)))
+             (datum->syntax #f (syntax->datum (attribute unmarked))))
            #'(#%plain-lambda {marked}
                (define-syntaxes {unmarked}
                  (make-rename-transformer #'marked))
@@ -971,12 +957,14 @@
     (lam x x)))
 
 ;; ----------------------------------------
-;; Check consistency of `free-identifier=?' and binding
+;; Check consistency of `free-identifier=?' and binding;
+;;  the result changed with the new macro system, so
+;;  it's consistent the other way around
 
 (module consistency-free-id-A racket
   (provide g (rename-out [*a a]))
   (define *a 10)
-  (define a 10)
+  (define a 11)
   (define-syntax g #'a))
 
 (module consistency-free-id-B racket
@@ -987,7 +975,7 @@
       [(_ ref)
        (with-syntax ([in (syntax-local-introduce
                           (syntax-local-value #'g))])
-         #'(let ([in 10]) ; BINDING
+         #'(let ([in 12]) ; BINDING
              (list (free-identifier=? #'in #'ref)
                    in
                    ref)))])) ; REFERENCE
@@ -995,7 +983,7 @@
 
 (require 'consistency-free-id-B)
 
-(test (list #t 10 10) consistency-free-id)
+(test (list #f 12 10) consistency-free-id)
 
 ;; ----------------------------------------
 ;; Check `syntax-local-lift...` outside of macro:
@@ -1134,6 +1122,55 @@
        (rename-transformer-target
         (chaperone-struct (foo #'x) foo-id (lambda (f x) x)))))
 
+;; ----------------------------------------
+;; Check that new binding scopes are introduced even for
+;; empty `let` bindings:
+
+(test 1 'empty-let-intro
+      (let ()
+        (define-syntax (m stx)
+          (syntax-case stx ()
+            [(_ def-id id)
+             #`(define-syntax def-id
+                 (make-rename-transformer (quote-syntax #,(syntax-local-introduce
+                                                           (syntax-local-value #'id)))))]))
+        (define-syntax (n stx)
+          (syntax-case stx ()
+            [(_ def-id id)
+             #`(define-syntax def-id (quote-syntax #,(syntax-local-introduce
+                                                      (syntax-local-value #'id))))]))
+
+        (let ()
+          (define x 1)
+          (define-syntax id #'x)
+          (let ()
+            (n id2 id)
+            (define x 2)
+            (let ()
+              (m z id2)
+              z)))))
+
+;; ----------------------------------------
+;; Check that expansion works right for a rename transformer
+;; that redirects to an imported binding
+
+(parameterize ([current-namespace (make-base-namespace)])
+  (void
+   (expand
+    '(module m racket/base
+      (#%plain-module-begin
+       (require (for-syntax racket/base
+                            syntax/parse))
+       
+       (define-syntax (mylam stx)
+         (syntax-parse stx
+           [(_ (xx) body)
+            #'(#%plain-lambda (xx) (letrec-syntaxes+values ([(xx) (make-rename-transformer #'+)])
+                                                           ()
+                                                           body))]))
+       
+       ((mylam (x) (x 1 2)) 'any))))))
+
 ;; ----------------------------------------
 
 (report-errs)

pkgs/racket-test-core/tests/racket/modprot.rktl

@@ -222,7 +222,8 @@
            10
            (prefix 0
                    (list 'dummy)
-                   null)
+                   null
+                   'insp0)
            (mod 'unsafe
                 'unsafe
                 (module-path-index-join #f #f)
@@ -232,7 +233,8 @@
                                                -1
                                                0
                                                #f))
-                        null)
+                        null
+                        'insp0)
                 null
                 null
                 null ; body
@@ -242,6 +244,7 @@
                 (toplevel 0 0 #f #f)
                 #f
                 #f
+                #hash()
                 null
                 null
                 null)))])

pkgs/racket-test-core/tests/racket/module.rktl

@@ -148,7 +148,6 @@
 (test 6 dynamic-require ''defines-car-that-overrides-import/stx 'car)
 ;; Can't redefine multiple times or import after definition:
 (syntax-test #'(module m racket/base (#%require racket/base) (define car 5) (define car 5)))
-(syntax-test #'(module m racket/base (define car 5) (#%require racket/base)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -232,7 +231,10 @@
 	     (require 'e 'b)))
     (test '(d b d b c) values l)
     (eval `(require 'f))
-    (let ([finished '(f b e  a d b  d b d b c)])
+    (let ([finished '(f b e  a  d b d b c)])
+      (test finished values l)
+      (eval '10) ; triggers `d` and `b`
+      (let ([finished (append '(d b) finished)])
         (test finished values l)
         (namespace-attach-module n ''f)
         (test finished values l)
@@ -242,7 +244,9 @@
           (namespace-require 'racket/base)
           (eval `(require 'a))
           (eval `(require 'f))
-	(test (list* 'd 'b finished) values l)))))
+          (test finished values l)
+          (eval '10)
+          (test (list* 'd 'b finished) values l))))))
 
 (let* ([n (make-base-namespace)]
        [l null]
@@ -357,7 +361,6 @@
 	 (module m 'mod_beg2
            3)))
 
-
 (test (void) eval
       '(begin
 	 (module mod_beg2 racket/base
@@ -390,6 +393,60 @@
 
 (define expand-test-use-toplevel? #f)
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check line between macro definition and use:
+
+(module local-binding-produces-identity racket/base
+  (provide proc)
+  
+  (define proc
+    (let ()
+      (define-syntax identity
+        (syntax-rules ()
+          [(_ misc-id)
+           (lambda (x)
+             (let ([misc-id 'other])
+               x))]))
+      
+      (identity x))))
+
+(test 77 (dynamic-require ''local-binding-produces-identity 'proc) 77)
+
+(module module-binding-produces-identity racket/base
+  (define-syntax identity
+    (syntax-rules ()
+      [(_ misc-id)
+       (lambda (x)
+         (let ([misc-id 'other])
+           x))]))
+  (identity x))
+
+(test 79
+      (let ([proc #f])
+        (parameterize ([current-print (lambda (v) (set! proc v))])
+          (dynamic-require ''module-binding-produces-identity #f))
+        proc)
+      79)
+
+(module macro-introduced-binding-produces-identity racket/base
+  (define-syntax-rule (gen)
+    (begin
+      (define-syntax identity
+        (syntax-rules ()
+          [(_ misc-id)
+           (lambda (x)
+             (let ([misc-id 'other])
+               x))]))
+      (identity x)))
+  (gen))
+
+(test 78
+      (let ([proc #f])
+        (parameterize ([current-print (lambda (v) (set! proc v))])
+          (dynamic-require ''macro-introduced-binding-produces-identity #f))
+        proc)
+      78)
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (let ([f1 (make-temporary-file)]
@@ -622,7 +679,7 @@
       (test 5 eval 'five ns)
       (eval p-code ns)
       (eval '(require 'p) ns)
-      (test #f eval 'same? ns)
+      ; (test #f eval 'same? ns)
       (let ([n-ns (eval '(module->namespace ''n) ns)])
         (test 5 eval '(lambda (x) x) n-ns)))))
 
@@ -981,7 +1038,8 @@
         (require (for-syntax racket/base))
         (begin-for-syntax
          (require 'm))))
-    (eval '(require 'n)))
+    (eval '(require 'n))
+    (eval '10))
   (test #"1\n1\n" get-output-bytes o))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1012,7 +1070,7 @@
 
 (module avail-y racket/base
   (require 'avail-z)
-  (eval #'(foo 10)))
+  (eval-syntax #'(foo 10)))
 
 (err/rt-test (dynamic-require ''avail-y #f)
              (lambda (exn) (and (exn? exn)
@@ -1171,6 +1229,12 @@
 ;; the enclosing module work, even though the identifier is missing
 ;; a module context.
 
+#|
+
+I think this was a bad idea. It's trying to make generated identifiers
+"just work", but the hack to provide this behavior only covered the
+case of module-leve bindings; it doesn't cover local bindings.
+
 (let ()
   (define (mk mode wrap?)
     `(module m racket
@@ -1205,6 +1269,8 @@
     (parameterize ([current-namespace (make-base-namespace)])
       (eval (mk m wrap?)))))
 
+|#
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check that module caching doesn't cause submodules
 ;; to be loaded/declared too early

pkgs/racket-test-core/tests/racket/namespac.rktl

@@ -284,11 +284,43 @@
 
 (parameterize ([current-namespace (make-base-namespace)])
   (let ([i (make-syntax-introducer)])
-    (namespace-require (i #'racket/list))
+    (namespace-require (i (datum->syntax #f 'racket/list)))
     (let ([e (namespace-syntax-introduce (datum->syntax #f '(cons? #t)))])
       (err/rt-test (eval e))
       (test #f eval (i e)))))
 
+;; ----------------------------------------
+;; Check cannot-redefine error
+
+(parameterize ([current-namespace (make-base-empty-namespace)])
+  (namespace-require/constant 'racket/base)
+  (err/rt-test (eval '(define + -)) #rx"cannot change constant"))
+
+;; ----------------------------------------
+;; Check that bulk `require` replaces individual bindings
+
+(let ([ns (make-base-empty-namespace)])
+  (parameterize ([current-namespace ns])
+    (namespace-require '(only racket/base)))
+  (eval #`(define #,(datum->syntax #f 'cons) 1) ns)
+  (eval #`(define #,(datum->syntax #f 'extra) 2) ns)
+  (test 1 eval 'cons ns)
+  (eval #`(require #,(datum->syntax #f 'racket/base)) ns)
+  (test cons eval 'cons ns)
+  (test 2 eval 'extra ns))
+
+(let ([ns (make-base-empty-namespace)])
+  (parameterize ([current-namespace ns])
+    ;; To ensure that the namespace ends up with more than
+    ;; `racket/base` individual bindings:
+    (namespace-require/copy 'racket/base))
+  (eval #`(define #,(datum->syntax #f 'cons) 1) ns)
+  (eval #`(define #,(datum->syntax #f 'extra) 2) ns)
+  (test 1 eval 'cons ns)
+  (eval #`(require #,(datum->syntax #f 'racket/base)) ns)
+  (test cons eval 'cons ns)
+  (test 2 eval 'extra ns))
+
 ;; ----------------------------------------
 
 (report-errs)

pkgs/racket-test-core/tests/racket/object.rktl

@@ -1241,9 +1241,8 @@
 (let ([c% (class object%
             (define/public (m . args) this)
             (super-new))])
-  (syntax-test #'(send+ (new c%) (m 5) (m 10)))
+  (syntax-test #'(send+ (new c%) m 5))
-  (syntax-test #'(send+ (new c%) (m . (1 2 3))))
+  (syntax-test #'(send+ (new c%) . 5))
-  (syntax-test #'(send+ (new c%) (m 5) (m . (1 2 3))))
 
   (test #t object? (send+ (new c%) (m 5) (m 15)))
   (test #t object? (send+ (new c%) (m 5) (m . (1 2 3 4)))))

pkgs/racket-test-core/tests/racket/read.rktl

@@ -1010,7 +1010,6 @@
         (read (open-input-string
                "!#hash((apple . (red round)) (banana . (yellow long)))"))))
 
-
 (test #hash((apple . (red round))
             (banana . (yellow long)))
       values

pkgs/racket-test-core/tests/racket/sandbox.rktl

@@ -65,18 +65,22 @@
         (let ([m (exn-message (cadr x))])
           (or (regexp-match? re m) (list 'bad-exception-message: m)))
         x)))
-  (define-syntax thunk (syntax-rules () [(thunk b ...) (lambda () b ...)]))
+  (define-syntax thunk (lambda (stx)
+                         (syntax-case stx ()
+                           [(_ loc b ...)
+                            (syntax/loc #'loc
+                              (lambda () b ...))])))
   (define-syntax t
     (syntax-rules (--eval-- --top-- => <= =err> <err=)
       [(t -?-) (void)]
       [(t -?- --eval-- more ...) (t --eval-- more ...)]
       [(t -?- --top--  more ...) (t --top--  more ...)]
-      [(t --eval-- E)         (test #t            run* (thunk (ev `E)))]
+      [(t --eval-- E)         (test #t            run* (thunk E (ev `E)))]
-      [(t --top--  E)         (test #t            run* (thunk E))]
+      [(t --top--  E)         (test #t            run* (thunk E E))]
-      [(t --eval-- E => R)    (test `(vals: ,R)   run  (thunk (ev `E)))]
+      [(t --eval-- E => R)    (test `(vals: ,R)   run  (thunk E (ev `E)))]
-      [(t --top--  E => R)    (test `(vals: ,R)   run  (thunk E))]
+      [(t --top--  E => R)    (test `(vals: ,R)   run  (thunk E E))]
-      [(t --eval-- E =err> R) (test #t e-match? R run  (thunk (ev `E)))]
+      [(t --eval-- E =err> R) (test #t e-match? R run  (thunk E (ev `E)))]
-      [(t --top--  E =err> R) (test #t e-match? R run  (thunk E))]
+      [(t --top--  E =err> R) (test #t e-match? R run  (thunk E E))]
       [(t -?- E => R more ...)    (begin (t -?- E => R) (t -?- more ...))]
       [(t -?- E =err> R more ...) (begin (t -?- E =err> R) (t -?- more ...))]
       [(t -?- R <= E more ...)    (t -?- E => R more ...)]
@@ -459,6 +463,7 @@
         (load/use-compiled ,test-lib) => (void)
         ;; but the module declaration can't execute due to the inspector:
         (require 'list) =err> "access disallowed by code inspector"
+        #t =err> "access disallowed by code inspector" ; flushes delayed compile-time failure
         (delete-file ,test-zo) => (void)
         (delete-file ,test-lib) =err> "`delete' access denied"
         --top--
@@ -477,6 +482,7 @@
         ;; bytecode from test-lib is bad, even when we can read/write to it
         (load/use-compiled ,test-zo)
         (require 'list) =err> "access disallowed by code inspector"
+        #t =err> "access disallowed by code inspector" ; flushes delayed compile-time failure
         ;; bytecode from test2-lib is explicitly allowed
         (load/use-compiled ,test2-lib)
         (require 'list) => (void))

pkgs/racket-test-core/tests/racket/stx.rktl

@@ -320,7 +320,7 @@
 ;; Check tracking of (formerly) primitive expanders
 
 (test '(let) (tree-map syntax-e) (syntax-property (expand #'(let ([x 10]) x)) 'origin))
-(test '(let*-values let*) (tree-map syntax-e) (syntax-property (expand #'(let* ([x 10]) x)) 'origin))
+(test '((let*) let*-values let*) (tree-map syntax-e) (syntax-property (expand #'(let* ([x 10]) x)) 'origin))
 (test '(let) (tree-map syntax-e) (syntax-property (expand #'(let loop ([x 10]) x)) 'origin))
 (test '(letrec) (tree-map syntax-e) (syntax-property (expand #'(letrec ([x 10]) x)) 'origin))
 (test '(let*-values) (tree-map syntax-e) (syntax-property (expand #'(let*-values ([(x) 10]) x)) 'origin))
@@ -540,6 +540,192 @@
            (parameterize ([read-accept-compiled #t])
              (eval (read i))))))
 
+(module x-with-identifier-binding-of-alt racket/base
+  (define x 1)
+  (define-syntax-rule (m id)
+    (begin
+      (define x 5)
+      (define id #'x)))
+  (m x-id)
+  (provide x-id))
+(let ([b (identifier-binding
+          (dynamic-require ''x-with-identifier-binding-of-alt 'x-id))])
+  (test #f eq? 'x (cadr b))
+  (test 'x cadddr b)
+  (test #t equal? (car b) (caddr b)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; identifier-binding and (nominal) phase reporting
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module ib-mod-1 racket/base
+  (require (for-syntax racket/base
+                       (for-syntax racket/base)))
+  (define extra #f)
+  (provide extra)
+  
+  (define x-1-0 0)
+  (provide x-1-0)
+  
+  (begin-for-syntax
+    (define x-1-1 1)
+    (provide x-1-1)
+    
+    (begin-for-syntax
+      (define x-1-2 2)
+      (provide x-1-2))))
+
+(module ib-mod-2 racket/base
+  (require (for-syntax racket/base
+                       (for-syntax racket/base))
+           'ib-mod-1)
+  
+  (define x-1-0-b (identifier-binding #'x-1-0))
+  (define x-1-0-b+1 (identifier-transformer-binding (syntax-shift-phase-level #'x-1-0 1)))
+  (define x-1-0-b+f (identifier-label-binding (syntax-shift-phase-level #'x-1-0 #f)))
+  (define x-1-1-b (identifier-transformer-binding #'x-1-1))
+  (define x-1-1-b+f (identifier-label-binding (syntax-shift-phase-level #'x-1-1 #f)))
+  (define x-1-2-b (identifier-binding #'x-1-2 2))
+  (provide x-1-0-b
+           x-1-0-b+1
+           x-1-0-b+f
+           x-1-1-b
+           x-1-1-b+f
+           x-1-2-b))
+
+(module ib-mod-2b racket/base
+  (require (for-syntax racket/base
+                       (for-syntax racket/base))
+           (only-in 'ib-mod-1
+                    x-1-1
+                    x-1-0
+                    x-1-2))
+  
+  (define x-1-0-b2 (identifier-binding #'x-1-0))
+  (define x-1-0-b2+1 (identifier-transformer-binding (syntax-shift-phase-level #'x-1-0 1)))
+  (define x-1-0-b2+f (identifier-label-binding (syntax-shift-phase-level #'x-1-0 #f)))
+  (define x-1-1-b2 (identifier-transformer-binding #'x-1-1))
+  (define x-1-2-b2 (identifier-binding #'x-1-2 2))
+  (provide x-1-0-b2
+           x-1-0-b2+1
+           x-1-0-b2+f
+           x-1-1-b2
+           x-1-2-b2))
+
+(module ib-mod-3 racket/base
+  (require (for-syntax racket/base
+                       (for-syntax racket/base))
+           (for-template 'ib-mod-1))
+  (provide (for-template x-1-0)
+           x-1-1
+           (for-syntax x-1-2)
+           extra2)
+  
+  (define extra2 #f)
+  
+  (define x-1-0-b3 (identifier-template-binding #'x-1-0))
+  (define x-1-1-b3 (identifier-binding #'x-1-1))
+  (define x-1-2-b3 (identifier-transformer-binding #'x-1-2))
+  (provide x-1-0-b3
+           x-1-1-b3
+           x-1-2-b3))
+
+(module ib-mod-4 racket/base
+  (require (for-syntax racket/base
+                       (for-syntax racket/base))
+           'ib-mod-3)
+  
+  (define x-1-0-b4 (identifier-template-binding #'x-1-0))
+  (define x-1-1-b4 (identifier-binding #'x-1-1))
+  (define x-1-2-b4 (identifier-transformer-binding #'x-1-2))
+  (provide x-1-0-b4
+           x-1-1-b4
+           x-1-2-b4))
+
+(module ib-mod-5 racket/base
+  (require (for-syntax racket/base
+                       (for-syntax racket/base))
+           (for-syntax 'ib-mod-3))
+  
+  (define x-1-0-b5 (identifier-binding #'x-1-0))
+  (define x-1-1-b5 (identifier-transformer-binding #'x-1-1))
+  (define x-1-2-b5 (identifier-binding #'x-1-2 2))
+  (provide x-1-0-b5
+           x-1-1-b5
+           x-1-2-b5))
+
+(module ib-mod-5b racket/base
+  (require (for-syntax racket/base
+                       (for-syntax racket/base))
+           (for-syntax (only-in 'ib-mod-3
+                                x-1-1
+                                x-1-0
+                                x-1-2)))
+  
+  (define x-1-0-b6 (identifier-binding #'x-1-0))
+  (define x-1-1-b6 (identifier-transformer-binding #'x-1-1))
+  (define x-1-2-b6 (identifier-binding #'x-1-2 2))
+  (provide x-1-0-b6
+           x-1-1-b6
+           x-1-2-b6))
+
+(module ib-mod-7 racket/base
+  (require (for-syntax racket/base
+                       (for-syntax racket/base))
+           (for-label 'ib-mod-1))
+  
+  (define x-1-0-b7 (identifier-label-binding #'x-1-0))
+  (define x-1-1-b7 (identifier-label-binding #'x-1-1))
+  (define x-1-2-b7 (identifier-label-binding #'x-1-2))
+  (provide x-1-0-b7
+           x-1-1-b7
+           x-1-2-b7))
+
+(require 'ib-mod-2
+         'ib-mod-2b
+         'ib-mod-3
+         'ib-mod-4
+         'ib-mod-5
+         'ib-mod-5b
+         'ib-mod-7)
+
+(define (simplify l)
+  (and l
+       (for/list ([v (in-list l)])
+         (if (module-path-index? v)
+             (let-values ([(name base) (module-path-index-split v)])
+               (cadr name))
+             v))))
+
+(test '(ib-mod-1 x-1-0 ib-mod-1 x-1-0 0 0 0) simplify x-1-0-b)
+(test '(ib-mod-1 x-1-0 ib-mod-1 x-1-0 0 0 0) simplify x-1-0-b+1)
+(test '(ib-mod-1 x-1-0 ib-mod-1 x-1-0 0 0 0) simplify x-1-0-b+f)
+(test '(ib-mod-1 x-1-0 ib-mod-1 x-1-0 0 0 0) simplify x-1-0-b2)
+(test '(ib-mod-1 x-1-0 ib-mod-1 x-1-0 0 0 0) simplify x-1-0-b2+1)
+(test '(ib-mod-1 x-1-0 ib-mod-1 x-1-0 0 0 0) simplify x-1-0-b2+f)
+(test '(ib-mod-1 x-1-0 ib-mod-1 x-1-0 0 -1 0) simplify x-1-0-b3)
+(test '(ib-mod-1 x-1-0 ib-mod-3 x-1-0 0 0 -1) simplify x-1-0-b4)
+(test '(ib-mod-1 x-1-0 ib-mod-3 x-1-0 0 1 -1) simplify x-1-0-b5)
+(test '(ib-mod-1 x-1-0 ib-mod-3 x-1-0 0 1 -1) simplify x-1-0-b6)
+(test '(ib-mod-1 x-1-0 ib-mod-1 x-1-0 0 #f 0) simplify x-1-0-b7)
+
+(test '(ib-mod-1 x-1-1 ib-mod-1 x-1-1 1 0 1) simplify x-1-1-b)
+(test '#f                                    simplify x-1-1-b+f)
+(test '(ib-mod-1 x-1-1 ib-mod-1 x-1-1 1 0 1) simplify x-1-1-b2)
+(test '(ib-mod-1 x-1-1 ib-mod-1 x-1-1 1 -1 1) simplify x-1-1-b3)
+(test '(ib-mod-1 x-1-1 ib-mod-3 x-1-1 1 0 0) simplify x-1-1-b4)
+(test '(ib-mod-1 x-1-1 ib-mod-3 x-1-1 1 1 0) simplify x-1-1-b5)
+(test '(ib-mod-1 x-1-1 ib-mod-3 x-1-1 1 1 0) simplify x-1-1-b6)
+(test '(ib-mod-1 x-1-1 ib-mod-1 x-1-1 1 #f 1) simplify x-1-1-b7)
+
+(test '(ib-mod-1 x-1-2 ib-mod-1 x-1-2 2 0 2) simplify x-1-2-b)
+(test '(ib-mod-1 x-1-2 ib-mod-1 x-1-2 2 0 2) simplify x-1-2-b2)
+(test '(ib-mod-1 x-1-2 ib-mod-1 x-1-2 2 -1 2) simplify x-1-2-b3)
+(test '(ib-mod-1 x-1-2 ib-mod-3 x-1-2 2 0 1) simplify x-1-2-b4)
+(test '(ib-mod-1 x-1-2 ib-mod-3 x-1-2 2 1 1) simplify x-1-2-b5)
+(test '(ib-mod-1 x-1-2 ib-mod-3 x-1-2 2 1 1) simplify x-1-2-b6)
+(test '(ib-mod-1 x-1-2 ib-mod-1 x-1-2 2 #f 2) simplify x-1-2-b7)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; eval versus eval-syntax, etc.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -616,11 +802,10 @@
   (test eval 'expand-to-top-form (eval (expand-syntax-to-top-form #'eval)))
   (test #t syntax? (expand-syntax-to-top-form (datum->syntax #f 'eval))))
 
-(let ()
+(define-syntax @$@name 'dummy)
-  (define-syntax name 'dummy)
+(define-syntax @$@alias (make-rename-transformer #'@$@name))
-  (define-syntax alias (make-rename-transformer #'name))
+(test (identifier-binding-symbol #'@$@name)
-  (test (identifier-binding-symbol #'name)
+      identifier-binding-symbol #'@$@alias)
-        identifier-binding-symbol #'alias))
 
 (require (only-in racket/base [add1 increment-by-one]))
 (test (identifier-binding-symbol #'add1)
@@ -760,7 +945,7 @@
                                     (= 1 (length o))
                                     (andmap identifier? db)
                                     (identifier? (car o))
-                                    (ormap (lambda (db) (bound-identifier=? db (car o))) db)))
+                                    (ormap (lambda (db) (free-identifier=? db (car o))) db)))
                           db o))))])))])
   (check-expr #'(let () (letrec-syntaxes+values ([(x) (lambda (stx) #'(quote y))]) () x)))
   (check-expr #'(let () (letrec-syntaxes+values ([(x) (lambda (stx) #'(quote y))]) () (list x))))
@@ -913,15 +1098,18 @@
   (define-syntax (++y-macro stx) (syntax-protect #'++x))
   (define-syntax (++y-macro2 stx) (syntax-protect (datum->syntax stx '++x)))
   (define-syntax (++u-macro stx) (syntax-protect #'++u))
+  (define-syntax (++v-macro stx) (syntax-protect #'++v))
   (define-syntax ++u2 (make-rename-transformer (syntax-protect #'++u)))
-  (define ++u 8) ; unexported
+  (define ++u 8) ; would be unexported, but export of rename transformer exports it
-  (provide ++y ++y-macro ++y-macro2 ++u-macro ++u2))
+  (define ++v 9) ; unexported
+  (provide ++y ++y-macro ++y-macro2 ++u-macro ++u2 ++v-macro))
 (require '++n)
 
 (test 10 values ++y)
 (test 10 values ++y-macro)
 (test 8 values ++u-macro)
 (test 8 values ++u2)
+(test 9 values ++v-macro)
 
 (require '++m)
 
@@ -1232,7 +1420,6 @@
                     (printf "~a ~a\n" a b)))
            (eval '(require 'mm))
            (eval '(current-namespace (module->namespace ''mm)))
-
            (eval '(define$ c 7))
            (test '(1 2 7) eval '(list a b c))
            (eval '(define$ d 8))
@@ -1243,6 +1430,9 @@
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; layers of lexical binding
 
+#|
+ This test is supposed to fail, now: 
+
 (test '(1 2) 'macro-nested-lexical
       (let ()
         (define-syntax (m stx)
@@ -1270,8 +1460,8 @@
   (provide @!$get))
 (require '@!$m)
 (test '(10 20 #t) '@!$get @!$get)
+|#
 
-(unless building-flat-tests?
 (test '(12)
       eval
       (expand
@@ -1281,7 +1471,7 @@
                                    (define #,(syntax-local-introduce #'b) 1)
                                    (define z (list b))
                                    z))])
-               (goo))))))
+             (goo)))))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Test lazy unmarshaling of renamings and module-name resolution
@@ -1319,7 +1509,6 @@
                         (parameterize ([read-accept-compiled #t])
                           (read (open-input-bytes (get-output-bytes p))))))]
             [x-id (parameterize ([current-namespace (make-base-namespace)])
-                    (printf "here\n")
                     (eval a-code)
                     (eval '(require 'a))
                     (eval '#'x))])
@@ -1330,7 +1519,9 @@
         (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
         (eval '(require 'a))
         (test #t eval '(free-identifier=? (f) #'x))
+        ;; check namespace fallbacks:
         (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
+        (test #t free-identifier=? (eval '(f)) x-id)
         (parameterize ([current-namespace (make-base-namespace)])
           (eval '(module a racket/base
                    (provide y)
@@ -1611,7 +1802,7 @@
   (let ([a-b-stx (parameterize ([current-namespace (make-base-namespace)])
                    (eval '(define-syntax-rule (b e)
                             (begin e)))
-                   (expand #'(b 1)))])
+                   (expand '(b 1)))])
     (test #f free-identifier=? #'begin (datum->syntax a-b-stx 'begin))
     (test #t free-identifier=? #'begin (syntax-case a-b-stx ()
                                          [(b . _) (datum->syntax #'b 'begin)]))))
@@ -1849,6 +2040,45 @@
               (read i)))
   (test #t syntax? (cdr (syntax-e (eval s)))))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check interation of bindings across namespaces:
+
+(let ()
+  (define ns1 (make-base-namespace))
+  (define ns2 (make-base-namespace))
+  (eval '(require (only-in racket/base [add1 cons])) ns1)
+  ;; In `ns1`, `cons` refers to `add1`
+  ;; In `ns2`, `cons` refers to `cons`
+  (define cons-id/ns1 (eval '(quote-syntax cons) ns1))
+  (test add1 eval cons-id/ns1 ns2)
+  (eval `(define ,cons-id/ns1 1) ns2)
+  (test 1 eval cons-id/ns1 ns2)
+  (test cons eval 'cons ns2)
+  (test 1 eval (quasiquote (let () (define ,cons-id/ns1 1) ,cons-id/ns1)) ns2))
+
+(module x-id-is-alias-for-plus racket/base
+  (provide x-id)
+  (require (only-in racket/base [+ x]))
+  (define x-id #'x))
+(let ([x-id (dynamic-require ''x-id-is-alias-for-plus 'x-id)])
+  (define ns (make-base-namespace))
+  (eval '(require (only-in racket/base [- x])) ns)
+  (test - eval 'x ns)
+  (test + eval x-id ns))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check that a phase shift also shifts fallback contexts
+
+(let ()
+  (define ns (make-base-namespace))
+  (define (evalx e)
+    (parameterize ([current-namespace ns])
+      (eval-syntax (expand (datum->syntax #f e)))))
+  (evalx '(module m mzscheme (provide e) (define e #'1)))
+  (evalx '(module n mzscheme (require-for-syntax 'm) (provide s) (define-syntax (s stx) e)))
+  (evalx '(require 'n))
+  (err/rt-test (evalx 's) #rx"literal data is not allowed"))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

pkgs/racket-test-core/tests/racket/stxparam.rktl

@@ -19,6 +19,11 @@
 (test 'sub values (splicing-syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))])
                     (inDIRECt)))
 
+(define-syntax-parameter tHaT #f)
+;; Make sure `syntax-parameterize` works at the top level:
+(syntax-parameterize ([tHaT (lambda (stx) #'(quote sub))])
+  (tHaT))
+
 (module check-splicing-stxparam-1 racket/base
   (require (for-syntax racket/base)
            racket/stxparam
@@ -88,6 +93,43 @@
 
 (test 11 dynamic-require ''check-splicing-stxparam-et 'q)
 
+;; ----------------------------------------
+;; Check interaction with internal definition contexts,
+;; both at expression and module levels:
+
+(module stxparam-interaction-with-block racket/base
+  (require racket/stxparam
+           racket/block
+           (for-syntax racket/base))
+
+  (define-syntax-parameter x (lambda (stx) #'10))
+
+  (let ()
+    (block
+     (syntax-parameterize ([x (lambda (stx) #'11)])
+       (let ()
+         x))))
+
+  (block
+   (syntax-parameterize ([x (lambda (stx) #'12)])
+     (let ()
+       x))))
+
+(test "11\n12\n"
+      get-output-string
+      (parameterize ([current-output-port (open-output-string)])
+        (dynamic-require ''stxparam-interaction-with-block #f)
+        (current-output-port)))
+
+;; ----------------------------------------
+;; Make sure a generated name is not ambiguous relative to
+;; a directly imported or defined name:
+
+(module stxparam-generated-name-no-conflict racket/base
+  (require racket/stxparam (for-syntax racket/base))
+  (define-syntax-parameter add (make-rename-transformer #'+))
+  add)
+
 ;; ----------------------------------------
 
 (report-errs)

pkgs/racket-test-core/tests/racket/submodule.rktl

@@ -379,7 +379,9 @@
                       [() 10]))))))
   (eval (syntax-case m ()
           [(md m r/b (m-b cr mod))
-           #`(md m r/b (m-b (begin 10 mod)))])))
+           (with-syntax ([begin (datum->syntax #'m-b 'begin)]
+                         [ten (datum->syntax #'m-b 10)])
+             #`(md m r/b (m-b (begin ten mod))))])))
 
 (parameterize ([current-namespace (make-base-namespace)])
   (eval
@@ -975,6 +977,17 @@
              (regexp-match (regexp-quote "(submod 'variable-error-message-in-submodule m2)")
                            (exn-message x)))))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check that submodule binding works ok with rename transformers
+
+(module has-a-rename-transformer-and-submodule racket/base
+  (require (for-syntax racket/base))
+
+  (begin-for-syntax
+    (define kar (make-rename-transformer #'car)))
+
+  (module+ test))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)

pkgs/racket-test-core/tests/racket/syntax.rktl

@@ -1290,7 +1290,7 @@
 (syntax-test #'#%top)
 (syntax-test #'(#%top 1))
 (syntax-test #'(let ([#%top 5])
-		 x))
+		 an-identifier-that-is-never-defined))
 (err/rt-test (#%top . lambda) exn:fail:contract:variable?)
 (define x 5)
 (test 5 '#%top (#%top . x))
@@ -1528,6 +1528,10 @@
                   x)))
              exn:fail:contract:variable?)
 
+(test 1
+      values
+      (letrec-syntaxes+values () ([(b) 0]) (define x 1) x))
+
 (test 82 'splicing-letrec-syntaxes+values
       (let ()
         (define q 77)
@@ -1599,6 +1603,13 @@
             (define (a) (m)))
           (m))))
 
+(test 105 'splicing-local
+      (let ()
+        (splicing-local
+         [(define x 105)]
+         (define-syntax outer-x (make-rename-transformer #'x)))
+        outer-x))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Check keyword & optionals for define-syntax 
 ;; and define-syntax-for-values:

pkgs/racket-test/tests/generic/syntax-errors.rkt

@@ -168,6 +168,7 @@
       (define stream-empty? empty?)])))
 
 (check-good-syntax
+ (begin
   (module gen racket
     (require racket/generic)
     (provide gen:foo (rename-out [*bar bar]))
@@ -177,4 +178,17 @@
     (require racket/generic (submod ".." gen))
     (struct thing []
       #:methods gen:foo
-      [(define/generic gbar bar)])))
+      [(define/generic gbar bar)]))))
+
+(check-bad-syntax
+ (begin
+   (module gen racket
+     (require racket/generic)
+     (provide gen:foo (rename-out [*bar bar]))
+     (define-generics foo (*bar foo))
+     (define bar *bar))
+   (module impl racket
+     (require racket/generic (submod ".." gen))
+     (struct thing []
+       #:methods gen:foo
+       [(define/generic gbar bar)]))))

pkgs/racket-test/tests/racket/package.rkt

@@ -48,8 +48,18 @@
   (or (fail? e) e))
 
 (define (test-pack-seq* forms expr q-expr result)
+  (test-pack-seq** forms expr q-expr result)
+  (test-pack-seq** (map syntax->datum forms) (syntax->datum expr) q-expr result))
+
+(define (test-pack-seq** forms expr q-expr result)
+  (printf "As ~a: ~s\n"
+          (if (syntax? (car forms))
+              "syntax"
+              "datum")
+          forms)
   (let ([orig (current-namespace)])
     ;; top level
+    (printf "top\n")
     (let ([ns (make-base-namespace)])
       (parameterize ([current-namespace ns])
         (namespace-attach-module orig 'racket/package)
@@ -60,6 +70,7 @@
             (err/rt-test (eval (fail-expr expr)) result)
             (test result q-expr (eval expr)))))
     ;; let
+    (printf "let\n")
     (let ([ns (make-base-namespace)])
       (parameterize ([current-namespace ns])
         (namespace-attach-module orig 'racket/package)
@@ -70,6 +81,7 @@
               (err/rt-test (eval e) result)
               (test result `(let ... ,q-expr) (eval e))))))
     ;; nested let
+    (printf "nested let\n")
     (let ([ns (make-base-namespace)])
       (parameterize ([current-namespace ns])
         (namespace-attach-module orig 'racket/package)
@@ -84,6 +96,7 @@
               (err/rt-test (eval e) result)
               (test result `(let ... ,q-expr) (eval e))))))
     ;; module
+    (printf "module\n")
     (let ([ns (make-base-namespace)])
       (parameterize ([current-namespace ns])
         (namespace-attach-module orig 'racket/package)
@@ -93,6 +106,56 @@
                     (begin . ,forms)
                     (define result ,(fail-expr expr))
                     (provide result))])
+          (if (fail? expr)
+              (err/rt-test (eval m) exn:fail:syntax?)
+              (begin
+                (eval m)
+                (test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))
+    ;; multiple modules
+    (printf "2 modules\n")
+    (let ([ns (make-base-namespace)])
+      (parameterize ([current-namespace ns])
+        (namespace-attach-module orig 'racket/package)
+        (let ([m `(begin
+                   (module m0 racket/base
+                     (require (for-syntax racket/base)
+                              racket/package)
+                     (begin . ,forms)
+                     (provide ,#'(all-defined-out)))
+                   (module m racket/base
+                     (require (for-syntax racket/base)
+                              racket/package
+                              'm0)
+                     (define result ,(fail-expr expr))
+                     (provide result)))])
+          (if (fail? expr)
+              (err/rt-test (eval m) exn:fail:syntax?)
+              (begin
+                (eval m)
+                (test result `(module ... ,q-expr) (dynamic-require ''m 'result)))))))
+    ;; more modules
+    (printf "3 modules\n")
+    (let ([ns (make-base-namespace)])
+      (parameterize ([current-namespace ns])
+        (namespace-attach-module orig 'racket/package)
+        (let ([m `(begin
+                   (module m0 racket/base
+                     (require (for-syntax racket/base)
+                              racket/package)
+                     ,(car forms)
+                     (provide ,#'(all-defined-out)))
+                   (module m1 racket/base
+                     (require (for-syntax racket/base)
+                              racket/package
+                              'm0)
+                     (begin . ,(cdr forms))
+                     (provide ,#'(all-defined-out)))
+                   (module m racket/base
+                     (require (for-syntax racket/base)
+                              racket/package
+                              'm0 'm1)
+                     (define result ,(fail-expr expr))
+                     (provide result)))])
           (if (fail? expr)
               (err/rt-test (eval m) exn:fail:syntax?)
               (begin

pkgs/racket-test/tests/units/test-harness.rkt

@@ -1,7 +1,7 @@
-(module test-harness mzscheme
+(module test-harness racket
   (require syntax/stx)
               
-  (provide (all-defined))
+  (provide (all-defined-out))
 
   (define (lst-bound-id=? x y)
     (andmap bound-identifier=? x y))
@@ -10,18 +10,23 @@
     (cond 
       ((and (syntax? x) (eq? '_ (syntax-e x)))
        #t)
-      ((and (stx-pair? x)
+      ((and (syntax? x)
-            (not (syntax-e (stx-car x)))
+            (vector? (syntax-e x))
-            (identifier? (stx-cdr x)))
+            (= 2 (vector-length (syntax-e x))))
        (and (identifier? y)
-            (not (module-identifier=? (stx-cdr x) y))))
+            (eq? (syntax-e (vector-ref (syntax-e x) 0))
+                 (free-identifier=? (vector-ref (syntax-e x) 1) y))))
       ((and (stx-null? x) (stx-null? y))
        #t)
       ((and (stx-pair? x) (stx-pair? y))
        (and (stx-bound-id=? (stx-car x) (stx-car y))
             (stx-bound-id=? (stx-cdr x) (stx-cdr y))))
       ((and (identifier? x) (identifier? y))
-       (bound-identifier=? x y))
+       (if (bound-identifier=? x y)
+           #t
+           (begin
+             (log-error "Differ:\n  ~s\n  ~s" x y)
+             #f)))
       ((and (syntax? x) (number? (syntax-e x))
             (syntax? y) (number? (syntax-e y)))
        (= (syntax-e x) (syntax-e y)))

pkgs/racket-test/tests/units/test-unit-contracts.rkt

@@ -1,8 +1,8 @@
 #lang racket/load
 
 (require "test-harness.rkt"
-         scheme/unit
+         racket/unit
-         scheme/contract)
+         racket/contract)
 
 (define temp-unit-blame-re "\\(unit temp[0-9]*\\)")
 (define top-level "top-level")
@@ -102,7 +102,7 @@
   (define-signature x ((contracted [(-> number? number?) x]))))
 
 (test-syntax-error "identifier h? not bound anywhere"
-  (module h?-test scheme
+  (module h?-test racket
     (define-signature s^
       ((define-values (f?) (values number?))
        (define-syntaxes (g?) (make-rename-transformer #'number?))
@@ -593,7 +593,7 @@
   (test-contract-error "(unit unit55-1)" "f" "not a number"
     (invoke-unit unit55-2)))
 
-(module m1 scheme
+(module m1 racket
   (define-signature foo^ (x))
   (define-signature bar^ (y))
   (provide foo^ bar^)
@@ -608,7 +608,7 @@
   (provide/contract [U@ (unit/c (import (foo^ [x (-> number? boolean?)]))
                                 (export (bar^ [y (-> symbol? string?)])))]))
 
-(module m2 scheme
+(module m2 racket
   (require 'm1)
   
   (define x zero?)
@@ -664,7 +664,7 @@
 ;; Adding a test to make sure that contracts can refer
 ;; to other parts of the signature.
 
-(module m3 scheme
+(module m3 racket
   (define-signature toy-factory^
     ((contracted
       [build-toys (-> integer? (listof toy?))]
@@ -687,7 +687,7 @@
 
   (provide toy-factory^ simple-factory@))
 
-(module m4 scheme
+(module m4 racket
   (define-signature foo^ (x? (contracted [f (-> x? boolean?)])))
 
   (define-unit U@
@@ -712,7 +712,7 @@
     (define-values/invoke-unit/infer m3:simple-factory@)
     (build-toys #f)))
 
-(module m5 scheme
+(module m5 racket
   (define-signature foo^ (f (contracted [x? (-> any/c boolean?)])))
   
   (define-unit U@
@@ -860,11 +860,11 @@
   (define-unit student@
     (import)
     (export student^)
-    (define-struct student (name id)))
+    (struct student (name id)))
   (define-values/invoke-unit/infer student@)
-  (make-student "foo" 3)
+  (student "foo" 3)
-  (test-contract-error top-level "make-student" "not a string"
+  (test-contract-error top-level "student" "not a string"
-    (make-student 4 3))
+    (student 4 3))
   (test-contract-error top-level "student-id" "not a student"
     (student-id 'a)))
 

pkgs/racket-test/tests/units/test-unit.rkt

@@ -3,7 +3,6 @@
 (require (for-syntax racket/private/unit-compiletime
                      racket/private/unit-syntax))
 (require "test-harness.rkt"
-         ;unit
          scheme/unit)
 
 (define-syntax (lookup-sig-mac stx)
@@ -11,14 +10,17 @@
     (syntax-case stx ()
       ((_ id)
        #`#'#,(let ((s (lookup-signature #'id)))
-               (list (map syntax-local-introduce (signature-vars s))
+               (define (shift-scope member-id)
+                 ((make-syntax-delta-introducer (car (signature-vars s)) member-id)
+                  (datum->syntax #'id (syntax-e member-id))))
+               (list (map shift-scope (signature-vars s))
                        (map (lambda (def)
-                            (cons (map syntax-local-introduce (car def))
+                              (cons (map shift-scope (car def))
-                                  (syntax-local-introduce (cdr def))))
+                                    (cdr def)))
                             (signature-val-defs s))
                        (map (lambda (def)
-                          (cons (map syntax-local-introduce (car def))
+                              (cons (map shift-scope (car def))
-                                (syntax-local-introduce (cdr def))))
+                                    (cdr def)))
                             (signature-stx-defs s))))))))
 
 (define-signature x-sig (x))
@@ -65,7 +67,7 @@
 (test-syntax-error "define-signature-form: missing arguments"
   (define-signature-form (a b)))
 (test-syntax-error "define-signature-form: too many arguments"
-  (define-signature-form (a b c) 1 2))
+  (define-signature-form (a b c d) 1 2))
 (test-syntax-error "define-signature-form: dot"
   (define-signature-form (a b) . c))
 (test-syntax-error "define-signature-form: set!"
@@ -154,7 +156,10 @@
   (define s7 (void))
   (define h (void))
   (define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7))))
-  (test stx-bound-id=? #'((s1 a b f) (((s2 s3) . _) ((c d) . e) ((i) . j)) (((_ _ _ _ _) . _) _ ((g) . #'h)))
+  (test stx-bound-id=?
+        ;; In this pattern, plain identifiers must be bound-id=?, while
+        ;; #(<bool> <id>) checks for an id that is fre-id=? or not depending on <bool>
+        #'((s1 a b f) (((s2 s3) . _) ((c d) . #(#t e)) ((i) . #(#t j))) (((_ _ _ _ _) . _) _ ((g) . (_ #(#t h)))))
         (let ()
           (define-signature x extends super (a b (define-values (c d) e) f
                                                (define-syntaxes (g) #'h)
@@ -166,7 +171,7 @@
   (define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7))))
   (let ((a 1) (g 2) (j 3) (s1 4) (s2 5))
     (test stx-bound-id=?
-          #'((s1 a b f) (((s2 s3) . _) ((c d) . e) ((i) . j)) (((_ _ _ _ _) . _) _ ((g) . #'h)))
+          #'((s1 a b f) (((s2 s3) . _) ((c d) . #(#t e)) ((i) . #(#t j))) (((_ _ _ _ _) . _) _ ((g) . (_ #(#t h)))))
           (let ()
             (define-signature x extends super (a b (define-values (c d) e) f
                                                  (define-syntaxes (g) #'h)
@@ -177,14 +182,14 @@
   (define h (void))
   (define-signature super (s1 (define-values (s2 s3) s4) (define-syntaxes (s5 s6) (values #'s7 #'s7))))
   (test stx-bound-id=?
-        #'((s1 a b f) (((s2 s3) . _) ((c d) . e) ((i) . j)) (((_ _ _ _ _) . _) _ ((g) . #'h)))
+        #'((s1 a b f) (((s2 s3) . _) ((c d) . #(#t e)) ((i) . #(#t j))) (((_ _ _ _ _) . _) _ ((g) . (_ #(#t h)))))
         (let ()
           (define-signature x extends super (a b (define-values (c d) e) f
                                                (define-syntaxes (g) #'h)
                                                (define-values (i) j)))
           (let ((a 1) (g 2) (j 3))
             (lookup-sig-mac x)))))
-(test stx-bound-id=? #'(((#f . a) b f) (((c d) . e) ((i) . (#f . j))) ((((#f . g)) . #'h)))
+(test stx-bound-id=? #'((a b f) (((c d) . #(#t e)) ((i) . #(#t j))) (((g) . (_ #(#t h)))))
       (let ((a 1) (g 2) (j 3))
         (define-signature x (a b (define-values (c d) e) f
                                (define-syntaxes (g) #'h)
@@ -827,7 +832,15 @@
     (test (list 2 123 1) (invoke-unit (compound-unit (import) (export)
                                                      (link (((a : s2)) u2)
                                                            (() u1 a)))))))
-
+(let ([c 50])
+  (define-signature s1 (a (define-values (x y) (values c 2))))
+  (define-signature s2 extends s1 ((define-values (z) (list a x))))
+  (define u1 (unit (import s2) (export) (define c 77) (cons y z)))
+  (define u2 (unit (import) (export s2) (define a 123)))
+  (test (list 2 123 50) (invoke-unit (compound-unit (import) (export)
+                                                   (link (((a : s2)) u2)
+                                                         (() u1 a))))))
+#;
 (let ([c 5])
   (define-signature s1 (a (define-values (x y) (values c 2))))
   (define-signature s2 extends s1 (c (define-values (z) (list a x))))

racket/collects/compiler/private/xform.rkt

@@ -895,6 +895,7 @@
 	       _isnan __isfinited __isnanl __isnan
                __isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf
                __inline_isnanl __inline_isnan
+               __builtin_popcount
                _Generic
                __inline_isinff __inline_isinfl __inline_isinfd __inline_isnanf __inline_isnand __inline_isinf
                floor floorl ceil ceill round roundl fmod fmodl modf modfl fabs fabsl __maskrune _errno __errno

racket/collects/pkg/main.rkt

@@ -11,7 +11,8 @@
          "lib.rkt"
          "commands.rkt"
          (prefix-in setup: setup/setup)
-         (for-syntax racket/base))
+         (for-syntax racket/base
+                     syntax/strip-context))
 
 (define (setup what no-setup? fail-fast? setup-collects jobs)
   (unless (or (eq? setup-collects 'skip)
@@ -136,7 +137,6 @@
          "  given path: ~a")
      clone)]))
 
-(splicing-let ()
   (define-syntax (make-commands stx)
     (syntax-case stx ()
       [(_ #:scope-flags (scope-flags ...)
@@ -144,7 +144,7 @@
           #:trash-flags (trash-flags ...)
           #:catalog-flags (catalog-flags ...)
           #:install-type-flags (install-type-flags ...)
-          #:install-dep-flags (install-dep-flags ...)
+          #:install-dep-flags ((install-dep-flags ... (dep-desc ...)))
           #:install-dep-desc (install-dep-desc ...)
           #:install-force-flags (install-force-flags ...)
           #:install-clone-flags (install-clone-flags ...)
@@ -152,30 +152,8 @@
           #:install-copy-flags (install-copy-flags ...)
           #:install-copy-defns (install-copy-defns ...)
           #:install-copy-checks (install-copy-checks ...))
-       (with-syntax ([([scope-flags ...]
+       (replace-context
-                       [job-flags ...]
+        stx
-                       [trash-flags ...]
-                       [catalog-flags ...]
-                       [install-type-flags ...]
-                       [(install-dep-flags ... (dep-desc ...))]
-                       [install-force-flags ...]
-                       [install-clone-flags ...]
-                       [update-deps-flags ...]
-                       [install-copy-flags ...]
-                       [install-copy-defns ...]
-                       [install-copy-checks ...])
-                      (syntax-local-introduce #'([scope-flags ...]
-                                                 [job-flags ...]
-                                                 [trash-flags ...]
-                                                 [catalog-flags ...]
-                                                 [install-type-flags ...]
-                                                 [install-dep-flags ...]
-                                                 [install-force-flags ...]
-                                                 [install-clone-flags ...]
-                                                 [update-deps-flags ...]
-                                                 [install-copy-flags ...]
-                                                 [install-copy-defns ...]
-                                                 [install-copy-checks ...]))])
          #`(commands
             "This tool is used for managing installed packages."
             "pkg-~a-command"
@@ -644,6 +622,7 @@
               (lambda ()
                 (pkg-empty-trash #:list? list
                                  #:quiet? #f)))]))]))
+
   (make-commands
    #:scope-flags
    ([(#:sym scope [installation user] #f) scope ()
@@ -725,4 +704,4 @@
                                    (cond
                                     [link "link"]
                                     [static-link "static-link"]
-                                    [clone "clone"]))))]))
+                                    [clone "clone"]))))])

racket/collects/racket/block.rkt

@@ -41,12 +41,16 @@
                      (syntax-local-bind-syntaxes
                       (syntax->list #'(id ...))
                       #'rhs def-ctx)
-                     (loop todo (cons #'(define-syntaxes (id ...) rhs) r)))]
+                     (with-syntax ([(id ...) (map syntax-local-identifier-as-binding
+                                                  (syntax->list #'(id ...)))])
+                       (loop todo (cons #'(define-syntaxes (id ...) rhs) r))))]
                   [(define-values (id ...) rhs)
                    (andmap identifier? (syntax->list #'(id ...)))
                    (let ([ids (syntax->list #'(id ...))])
                      (syntax-local-bind-syntaxes ids #f def-ctx)
-                     (loop todo (cons expr r)))]
+                     (with-syntax ([(id ...) (map syntax-local-identifier-as-binding
+                                                    (syntax->list #'(id ...)))])
+                       (loop todo (cons #'(define-values (id ...) rhs) r))))]
                   [else (loop todo (cons expr r))]))))])
     (internal-definition-context-seal def-ctx)
     (let loop ([exprs exprs]

racket/collects/racket/class.rkt

@@ -10,4 +10,5 @@
          "private/class-c-new.rkt")
   
 (provide-public-names)
-(provide generic?)
+(provide class/c ->m ->*m ->dm case->m object/c instanceof/c
+         generic?)

racket/collects/racket/contract/private/provide.rkt

@@ -232,8 +232,9 @@
 ;; the first syntax object is used for source locations
 (define-for-syntax (tl-code-for-one-id/new-name id-for-one-id
                                                 stx id reflect-id ctrct/no-prop user-rename-id
-                                                [mangle-for-maker? #f]
+                                                pos-module-source
-                                                [provide? #t])
+                                                mangle-for-maker?
+                                                provide?)
   (define ex-id (or reflect-id id))
   (define id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?))
   (with-syntax ([ctrct (syntax-property 
@@ -261,7 +262,7 @@
                                                                     id-rename
                                                                     (stx->srcloc-expr srcloc-id)
                                                                     'provide/contract
-                                                                    #'pos-module-source)
+                                                                    pos-module-source)
                              #,@(if provide?
                                     (list #`(provide (rename-out [#,id-rename external-name])))
                                     null)))
@@ -1050,11 +1051,18 @@
           "provide/contract-id"
           (or user-rename-id reflect-id id)))
        
+       (define pos-module-source-id
+         ;; Avoid context on this identifier, since it will be defined
+         ;; in another module, and the definition may have to pull
+         ;; along all context to support `module->namespace`:
+         (datum->syntax #f 'pos-module-source))
+
        (define (code-for-one-id/new-name stx id reflect-id ctrct/no-prop user-rename-id
                                          [mangle-for-maker? #f]
                                          [provide? #t]) 
          (tl-code-for-one-id/new-name id-for-one-id
                                       stx id reflect-id ctrct/no-prop user-rename-id
+                                      pos-module-source-id
                                       mangle-for-maker?
                                       provide?))
 
@@ -1104,10 +1112,11 @@
               [(struct (a b) ((fld ctc) ...) options ...)
                (add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
               [_ (void)]))
-          (with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)])
+          (with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)]
+                        [pos-module-source-id pos-module-source-id])
             (syntax
              (begin
-               (define pos-module-source (quote-module-name))
+               (define pos-module-source-id (quote-module-name))
                bodies ...)))]))]))
 
 

racket/collects/racket/contract/region.rkt

@@ -545,7 +545,7 @@
 #|
  with-contract-helper takes syntax of the form:
 
- (with-contract-helper ((p b e e-expr c c-expr) ...) blame . body)
+ (with-contract-helper ((p b e e-expr c c-expr) ...) m-id um-id blame . body)
 
  where
  p = internal id (transformer binding)
@@ -564,16 +564,19 @@
  requires the contract.  We set up all the transformer bindings
  before calling with-contract-helper, so we don't need definitions
  for p (or marked-p, in the main with-contract macro).
+
+  For identifiers not among the `p`s, use `m-id` and `um-id` to
+  remove a mark.
 |#   
 (define-syntax (with-contract-helper stx)
   (syntax-case stx ()
-    [(_ () blame)
+    [(_ () blame m-id um-id)
      #'(begin)]
-    [(_ ((p0 . rest0) (p . rest) ...) blame)
+    [(_ ((p0 . rest0) (p . rest) ...) m-id um-id blame)
      (raise-syntax-error 'with-contract
                          "no definition found for identifier"
                          #'p0)]
-    [(_ id-info blame body0 body ...)
+    [(_ id-info blame m-id um-id body0 body ...)
      (let ([expanded-body0 (local-expand #'body0
                                          (syntax-local-context)
                                          (cons #'define (kernel-form-identifier-list)))])
@@ -584,7 +587,13 @@
        (define (recreate-ids ids id-pairs)
          (for/list ([id (in-list ids)])
            (let ([id-pair (findf (λ (p) (bound-identifier=? id (car p))) id-pairs)])
-             (if id-pair (cadr id-pair) id))))
+             (if id-pair
+                 (cadr id-pair)
+                 (unmark id)))))
+       (define unmark
+         (let ([f (make-syntax-delta-introducer #'m-id #'um-id)])
+           (lambda (stx)
+             (f stx 'remove))))
        ;; rewrite-define returns:
        ;; * The unused parts of id-info
        ;; * The definition, possibly rewritten to replace certain identifiers
@@ -603,26 +612,26 @@
        (syntax-case expanded-body0 (begin define define-values define-syntaxes)
          [(begin sub ...)
           (syntax/loc stx
-            (with-contract-helper id-info blame sub ... body ...))]
+            (with-contract-helper id-info blame m-id um-id sub ... body ...))]
          [(define rest ...)
           (let-values ([(def-id body-stx) (normalize-definition expanded-body0 #'lambda #t #t)])
             (with-syntax ([(unused-ps def) (rewrite-define #'define-values (list def-id) body-stx)])
               (syntax/loc stx
-                (begin (add-blame-region blame def) (with-contract-helper unused-ps blame body ...)))))]
+                (begin (add-blame-region blame def) (with-contract-helper unused-ps blame m-id um-id body ...)))))]
          [(define-syntaxes (id ...) expr)
           (let ([ids (syntax->list #'(id ...))])
             (with-syntax ([(unused-ps def) (rewrite-define #'define-syntaxes ids #'expr)])
               (syntax/loc stx
-                (begin (add-blame-region blame def) (with-contract-helper unused-ps blame body ...)))))]
+                (begin (add-blame-region blame def) (with-contract-helper unused-ps blame m-id um-id body ...)))))]
          [(define-values (id ...) expr)
           (let ([ids (syntax->list #'(id ...))])
             (with-syntax ([(unused-ps def) (rewrite-define #'define-values ids #'expr)])
               (syntax/loc stx
-                (begin (add-blame-region blame def) (with-contract-helper unused-ps blame body ...)))))]
+                (begin (add-blame-region blame def) (with-contract-helper unused-ps blame m-id um-id body ...)))))]
          [else
           (quasisyntax/loc stx
             (begin (add-blame-region blame #,expanded-body0)
-                   (with-contract-helper id-info blame body ...)))]))]))
+                   (with-contract-helper id-info blame m-id um-id body ...)))]))]))
 
 (define-syntax (with-contract stx)
   (define-splicing-syntax-class region-clause
@@ -666,16 +675,11 @@
     [(_ (~optional :region-clause #:defaults ([region #'region])) blame:id rc:results-clause fv:fvs . body)
      (if (not (eq? (syntax-local-context) 'expression))
          (quasisyntax/loc stx (#%expression #,stx))
-         (let*-values ([(intdef) (syntax-local-make-definition-context)]
+         (let*-values ([(cid-marker) (make-syntax-introducer)]
-                       [(ctx) (list (gensym 'intdef))]
-                       [(cid-marker) (make-syntax-introducer)]
                        [(free-vars free-ctcs)
                         (values (syntax->list #'(fv.var ...))
                                 (syntax->list #'(fv.ctc ...)))])
-           (define (add-context stx)
+           (define add-context (make-syntax-introducer))
-             (internal-definition-context-apply intdef stx))
-           (syntax-local-bind-syntaxes free-vars #f intdef)
-           (internal-definition-context-seal intdef)
            (with-syntax ([blame-stx #''(region blame)]
                          [blame-id (generate-temporary)]
                          [(res ...) (generate-temporaries #'(rc.ctc ...))]
@@ -720,9 +724,7 @@
        (raise-syntax-error 'with-contract
                            "not used in definition context"
                            stx))
-     (let*-values ([(intdef) (syntax-local-make-definition-context)]
+     (let*-values ([(cid-marker) (make-syntax-introducer)]
-                   [(ctx) (list (gensym 'intdef))]
-                   [(cid-marker) (make-syntax-introducer)]
                    [(tid-marker) (make-syntax-introducer)]
                    [(eid-marker) (make-syntax-introducer)]
                    [(free-vars free-ctcs)
@@ -731,11 +733,7 @@
                    [(protected protections)
                     (values (syntax->list #'(ec.var ...))
                             (syntax->list #'(ec.ctc ...)))])
-       (define (add-context stx)
+       (define add-context (make-syntax-introducer))
-         (internal-definition-context-apply intdef stx))
-       (syntax-local-bind-syntaxes protected #f intdef)
-       (syntax-local-bind-syntaxes free-vars #f intdef)
-       (internal-definition-context-seal intdef)
        (with-syntax ([blame-stx #''(region blame)]
                      [blame-id (generate-temporary)]
                      [(free-var ...) free-vars]
@@ -753,7 +751,9 @@
                      [(p ...) protected]
                      [(true-p ...) (map tid-marker protected)]
                      [(ext-id ...) (map eid-marker protected)]
-                     [(marked-p ...) (add-context #`#,protected)])
+                     [(marked-p ...) (add-context #`#,protected)]
+                     [unmarked-id #'here]
+                     [marked-id (add-context #'here)])
          (with-syntax ([new-stx (add-context #'body)])
                (syntax/loc stx
                  (begin
@@ -791,6 +791,7 @@
                                            (verify-contract 'with-contract ctc))
                                           ...)
                                          blame-stx
+                                         marked-id unmarked-id
                                          .
                                          new-stx)
                    (define-syntaxes (p ...)

racket/collects/racket/generic.rkt

@@ -177,7 +177,7 @@
        (define gen-info (syntax-local-value gen-id (lambda () #f)))
        (unless (generic-info? gen-info)
          (wrong-syntax gen-id "expected a name for a generic interface"))
-       (define delta (syntax-local-make-delta-introducer gen-id))
+       (define delta (make-method-delta gen-id (generic-info-name gen-info)))
        (define predicate (generic-info-predicate gen-info))
        (define accessor (generic-info-accessor gen-info))
        (define method-ids (syntax->list #'(method-name ...)))

racket/collects/racket/local.rkt

@@ -5,4 +5,9 @@
 (provide local)
 
 (define-syntax (local stx)
-  (do-local stx #'letrec-syntaxes+values))
+  (do-local stx (lambda (def-ctx expand-context sbindings vbindings bodys)
+                  (quasisyntax/loc stx
+                    (letrec-syntaxes+values
+                     #,sbindings
+                     #,vbindings
+                     #,@bodys)))))

racket/collects/racket/private/class-internal.rkt

@@ -30,8 +30,10 @@
 (provide provide-public-names
          ;; needed for Typed Racket
          (protect-out do-make-object find-method/who))
-(define-syntax-rule (provide-public-names)
+(define-syntax (provide-public-names stx)
-  (provide class class* class/derived
+  (datum->syntax
+   stx
+   '(provide class class* class/derived
             define-serializable-class define-serializable-class*
             class? 
             mixin
@@ -73,7 +75,8 @@
             rename-super rename-inner inherit inherit/super inherit/inner inherit-field
             this this% super inner
             super-make-object super-instantiate super-new
-           inspect absent abstract))
+            inspect absent abstract)
+   stx))
 
 ;;--------------------------------------------------------------------
 ;;  keyword setup
@@ -378,12 +381,16 @@
                                          'expression
                                          null)])
                        (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
-                       (cons #'(define-syntaxes (id ...) rhs) (loop (cdr l)))))]
+                       (with-syntax ([(id ...) (map syntax-local-identifier-as-binding
+                                                    (syntax->list #'(id ...)))])
+                         (cons (syntax/loc e (define-syntaxes (id ...) rhs))
+                               (loop (cdr l))))))]
                   [(define-values (id ...) rhs)
                    (andmap identifier? (syntax->list #'(id ...)))
-                   (begin
+                   (let ([ids (map bind-local-id (syntax->list #'(id ...)))])
-                     (map bind-local-id (syntax->list #'(id ...)))
+                     (with-syntax ([(id ...) ids])
-                     (cons e (loop (cdr l))))]
+                       (cons (datum->syntax e (list #'define-values #'(id ...) #'rhs) e e)
+                             (loop (cdr l)))))]
                   [_else 
                    (cons e (loop (cdr l)))]))))))
     
@@ -419,9 +426,9 @@
                       (if alone
                           (map (lambda (i)
                                  (if (identifier? i)
-                                     (alone i)
+                                     (alone (syntax-local-identifier-as-binding i))
-                                     (cons (stx-car i)
+                                     (cons (syntax-local-identifier-as-binding (stx-car i))
-                                           (stx-car (stx-cdr i)))))
+                                           (syntax-local-identifier-as-binding (stx-car (stx-cdr i))))))
                                l)
                           l)))
                   l)))
@@ -438,8 +445,8 @@
                     (cons (list a a) (stx-cdr i))
                     i))]))
     
-    (define (norm-init/field-iid norm) (stx-car (stx-car norm)))
+    (define (norm-init/field-iid norm) (syntax-local-identifier-as-binding (stx-car (stx-car norm))))
-    (define (norm-init/field-eid norm) (stx-car (stx-cdr (stx-car norm))))
+    (define (norm-init/field-eid norm) (syntax-local-identifier-as-binding (stx-car (stx-cdr (stx-car norm)))))
     
     ;; expands an expression enough that we can check whether it has
     ;; the right form for a method; must use local syntax definitions
@@ -672,7 +679,7 @@
     (define (main stx super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
       (let-values ([(this-id) #'this-id]
                    [(the-obj) (datum->syntax (quote-syntax here) (gensym 'self))]
-                   [(the-finder) (datum->syntax (quote-syntax here) (gensym 'find-self))])
+                   [(the-finder) (datum->syntax #f (gensym 'find-self))])
         
         (let* ([def-ctx (syntax-local-make-definition-context)]
                [localized-map (make-bound-identifier-mapping)]
@@ -682,13 +689,15 @@
                                       (unless (eq? id id2)
                                         (set! any-localized? #t))
                                       id2))]
-               [bind-local-id (lambda (id)
+               [bind-local-id (lambda (orig-id)
-                                (let ([l (localize/set-flag id)])
+                                (let ([l (localize/set-flag orig-id)]
+                                      [id (syntax-local-identifier-as-binding orig-id)])
                                   (syntax-local-bind-syntaxes (list id) #f def-ctx)
                                   (bound-identifier-mapping-put!
                                    localized-map
                                    id
-                                   l)))]
+                                   l)
+                                  id))]
                [lookup-localize (lambda (id)
                                   (bound-identifier-mapping-get
                                    localized-map
@@ -1300,8 +1309,7 @@
                                                      (generate-temporaries (map car inherit/inners)))]
                           [all-inherits (append inherits inherit/supers inherit/inners)]
                           [definify (lambda (l)
-                                      (map bind-local-id l)
+                                      (map bind-local-id l))])
-                                      l)])
 
                       ;; ---- set up field and method mappings ----
                       (with-syntax ([(rename-super-orig ...) (definify (map car rename-supers))]
@@ -1692,8 +1700,6 @@
                                                                              (cdr (syntax-e stx))))))))])
                                                       (letrec-syntaxes+values
                                                           ([(plain-init-name) (make-init-redirect 
-                                                                               (quote-syntax set!)
-                                                                               (quote-syntax #%plain-app)
                                                                                (quote-syntax local-plain-init-name)
                                                                                (quote-syntax plain-init-name-localized))] ...)
                                                         ([(local-plain-init-name) unsafe-undefined] ...)

racket/collects/racket/private/class-undef.rkt

@@ -33,13 +33,17 @@
 ;; A wrapper macro that runs the `need-undeed-check?` analysis
 ;; and adds a boolean argument to a call to `compose-class`:
 (define-syntax (detect-field-unsafe-undefined stx)
+  (cond
+   [(eq? 'expression (syntax-local-context))
     (syntax-case stx ()
       [(_ compose-class arg ... proc final)
        (let-values ([(exp exp-proc) (syntax-local-expand-expression #'proc)])
          (with-syntax ([exp-proc exp-proc]
                        [need-undef? (need-undefined-check? exp)])
            (syntax/loc stx
-           (compose-class arg ... proc need-undef? final))))]))
+             (compose-class arg ... exp-proc need-undef? final))))])]
+   [else
+    #`(#%expression #,stx)]))
 
 ;; Analysis to detect whether any field can be referenced while
 ;; its value is `unsafe-undefined`, based on `declare-...` annotations

racket/collects/racket/private/classidmap.rkt

@@ -52,13 +52,12 @@
   (quasisyntax/loc src-stx (begin '(declare-field-initialization #,id) #,stx)))
 
 (define (make-this-map orig-id the-finder the-obj)
-  (let ([set!-stx (datum->syntax the-finder 'set!)])
+  (let ()
     (mk-set!-trans
      orig-id
      (lambda (stx)
-       (syntax-case stx ()
+       (syntax-case stx (set!)
          [(set! id expr)
-          (free-identifier=? (syntax set!) set!-stx)
           (raise-syntax-error 'class "cannot mutate object identifier" stx)]
          [(id . args)
           (add-declare-this-escapes
@@ -70,12 +69,11 @@
          [id (add-declare-this-escapes stx (find the-finder the-obj stx))])))))
 
 (define (make-this%-map replace-stx the-finder)
-  (let ([set!-stx (datum->syntax the-finder 'set!)])
+  (let ()
     (make-set!-transformer
      (λ (stx)
-       (syntax-case stx ()
+       (syntax-case stx (set!)
          [(set! id expr)
-          (free-identifier=? #'set! set!-stx)
           (raise-syntax-error 'class "cannot mutate this% identifier" stx)]
          [id
           (identifier? #'id)
@@ -85,16 +83,15 @@
 
 (define (make-field-map inherited? the-finder the-obj the-binder the-binder-localized
                         field-accessor field-mutator)
-  (let ([set!-stx (datum->syntax the-finder 'set!)])
+  (let ()
     (define (choose-src a b) (if (syntax-source a) a b))
     (mk-set!-trans
      the-binder-localized
      (lambda (stx)
        (class-syntax-protect
         (with-syntax ([obj-expr (find the-finder the-obj stx)])
-          (syntax-case stx (field-initialization-value)
+          (syntax-case stx (field-initialization-value set!)
             [(set! id (field-initialization-value expr))
-             (free-identifier=? (syntax set!) set!-stx)
              (add-declare-field-initialization
               #'id
               #'id
@@ -107,7 +104,6 @@
                                          ((unsyntax field-mutator) obj id))))])
                 (syntax/loc (choose-src stx #'id) (let* bindings set))))]
             [(set! id expr)
-             (free-identifier=? (syntax set!) set!-stx)
              (add-declare-field-assignment
               #'id
               inherited?
@@ -136,14 +132,13 @@
                 (syntax/loc (choose-src stx #'id) (let* bindings get))))])))))))
 
 (define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor)
-  (let ([set!-stx (datum->syntax the-finder 'set!)])
+  (let ()
     (mk-set!-trans
      the-binder-localized
      (lambda (stx)
        (class-syntax-protect
-        (syntax-case stx ()
+        (syntax-case stx (set!)
           [(set! id expr)
-           (free-identifier=? (syntax set!) set!-stx)
            (raise-syntax-error 'class "cannot mutate method" stx)]
           [(id . args)
            (add-declare-this-escapes
@@ -151,7 +146,7 @@
             (binding
              the-binder (syntax id)
              (datum->syntax 
-              the-finder
+              (quote-syntax here)
               (make-method-apply
                (list method-accessor (find the-finder the-obj stx))
                (find the-finder the-obj stx)
@@ -166,14 +161,13 @@
 ;; For methods that are dirrectly available via their names
 ;;  (e.g., private methods)
 (define (make-direct-method-map the-finder the-obj the-binder the-binder-localized new-name)
-  (let ([set!-stx (datum->syntax the-finder 'set!)])
+  (let ()
     (mk-set!-trans
      the-binder-localized
      (lambda (stx)
        (class-syntax-protect
-        (syntax-case stx ()
+        (syntax-case stx (set!)
           [(set! id expr)
-           (free-identifier=? (syntax set!) set!-stx)
            (raise-syntax-error 'class "cannot mutate method" stx)]
           [(id . args)
            (add-declare-this-escapes
@@ -181,7 +175,7 @@
             (binding
              the-binder (syntax id)
              (datum->syntax 
-              the-finder
+              (quote-syntax here)
               (make-method-apply (find the-finder new-name stx) (find the-finder the-obj stx) (syntax args))
               stx)))]
           [_else
@@ -191,14 +185,13 @@
             stx)]))))))
 
 (define (make-rename-super-map the-finder the-obj the-binder the-binder-localized rename-temp)
-  (let ([set!-stx (datum->syntax the-finder 'set!)])
+  (let ()
     (mk-set!-trans
      the-binder-localized
      (lambda (stx)
        (class-syntax-protect
-        (syntax-case stx ()
+        (syntax-case stx (set!)
           [(set! id expr)
-           (free-identifier=? (syntax set!) set!-stx)
            (raise-syntax-error 'class "cannot mutate super method" stx)]
           [(id . args)
            (add-declare-this-escapes
@@ -206,7 +199,7 @@
             (binding
              the-binder (syntax id)
              (datum->syntax 
-              the-finder
+              (quote-syntax here)
               (make-method-apply (find the-finder rename-temp stx) (find the-finder the-obj stx) (syntax args))
               stx)))]
           [_else
@@ -216,36 +209,31 @@
             stx)]))))))
 
 (define (make-rename-inner-map the-finder the-obj the-binder the-binder-localized rename-temp)
-  (let ([set!-stx (datum->syntax the-finder 'set!)]
+  (let ()
-        [lambda-stx (datum->syntax the-finder 'lambda)])
     (mk-set!-trans
      the-binder-localized
      (lambda (stx)
        (class-syntax-protect
-        (syntax-case stx ()
+        (syntax-case stx (set! lambda)
           [(set! id expr)
-           (free-identifier=? (syntax set!) set!-stx)
            (raise-syntax-error 'class "cannot mutate inner method" stx)]
           [(id (lambda () default) . args)
-           (free-identifier=? (syntax lambda) lambda-stx)
            (let ([target (find the-finder the-obj stx)])
              (add-declare-this-escapes
               stx
               (binding
                the-binder (syntax id)
                (datum->syntax 
-                the-finder
+                (quote-syntax here)
                 (make-method-apply (list (find the-finder rename-temp stx) target #'default)
                                    target (syntax args))
                 stx))))]
           [(id (lambda largs default) . args)
-           (free-identifier=? (syntax lambda) lambda-stx)
            (raise-syntax-error 
             'class 
             "misuse of inner method (lambda for default does not take zero arguments)" 
             stx)]
           [(id (lambda . rest) . args)
-           (free-identifier=? (syntax lambda) lambda-stx)
            (raise-syntax-error 
             'class 
             "misuse of inner method (ill-formed lambda for default)" 
@@ -266,7 +254,7 @@
    stx
    (class-syntax-protect
     (datum->syntax 
-     the-finder
+     (quote-syntax here)
      (make-method-apply (find the-finder rename-temp stx) 
                         (find the-finder the-obj stx) 
                         args)
@@ -277,10 +265,10 @@
    stx
    (class-syntax-protect
     (datum->syntax 
-     the-finder
+     (quote-syntax here)
      (let ([target (find the-finder the-obj stx)])
        (datum->syntax 
-        the-finder
+        (quote-syntax here)
         `(let ([i (,(find the-finder rename-temp stx) ,target)])
            (if i
                ,(make-method-apply 'i target args)
@@ -297,14 +285,13 @@
       "cannot use non-field init variable in a method"
       stx))))
 
-(define (make-init-redirect set!-stx #%app-stx local-id localized-id)
+(define (make-init-redirect local-id localized-id)
   (mk-set!-trans
    localized-id
    (lambda (stx)
      (class-syntax-protect
-      (syntax-case stx ()
+      (syntax-case stx (set!)
         [(set! id expr)
-         (free-identifier=? (syntax set!) set!-stx)
          (with-syntax ([local-id local-id])
            (syntax/loc stx (set! local-id expr)))]
         [(id . args)
@@ -312,11 +299,10 @@
                                   local-id
                                   (syntax-e local-id)
                                   #'id
-                                  #'id)]
+                                  #'id)])
-                       [#%app #%app-stx])
+           (syntax/loc stx (#%plain-app (#%plain-app check-not-unsafe-undefined local-id 'id) . args)))]
-           (syntax/loc stx (#%app (#%app check-not-unsafe-undefined local-id 'id) . args)))]
         [id (quasisyntax/loc stx
-              (#,#%app-stx
+              (#%plain-app
                check-not-unsafe-undefined
                #,(datum->syntax
                   local-id

racket/collects/racket/private/generic-interfaces.rkt

@@ -32,17 +32,23 @@
      (list (cons prop:equal+hash vector->list))))
 
   ;; forgeries of generic functions that don't exist
-  (define (equal-proc a b e) (equal? a b))
+  (define (equal-proc-impl a b e) (equal? a b))
-  (define (hash-proc x h)  (equal-hash-code x))
+  (define (hash-proc-impl x h)  (equal-hash-code x))
-  (define (hash2-proc x h) (equal-secondary-hash-code x))
+  (define (hash2-proc-impl x h) (equal-secondary-hash-code x))
 
   (define-syntax gen:equal+hash
-    (make-generic-info (quote-syntax prop:gen:equal+hash)
+    (make-generic-info (quote-syntax gen:equal+hash)
+                       (quote-syntax prop:gen:equal+hash)
                        (quote-syntax equal+hash?)
                        (quote-syntax gen:equal+hash-acc)
+                       ;; Unbound identifiers will be `free-identifier=?` to unbound in clients:
                        (list (quote-syntax equal-proc)
                              (quote-syntax hash-proc)
-                             (quote-syntax hash2-proc))))
+                             (quote-syntax hash2-proc))
+                       ;; Bound identifiers used for implementations:
+                       (list (quote-syntax equal-proc-impl)
+                             (quote-syntax hash-proc-impl)
+                             (quote-syntax hash2-proc-impl))))
 
 
   (define-values (prop:gen:custom-write gen:custom-write? gen:custom-write-acc)
@@ -60,7 +66,7 @@
      (list (cons prop:custom-write (lambda (v) (vector-ref v 0))))))
 
   ;; see above for equal+hash
-  (define (write-proc v p w)
+  (define (write-proc-impl v p w)
     (case w
       [(#t) (write v p)]
       [(#f) (display v p)]
@@ -68,9 +74,11 @@
       [else (error 'write-proc "internal error; should not happen")]))
 
   (define-syntax gen:custom-write
-    (make-generic-info (quote-syntax prop:gen:custom-write)
+    (make-generic-info (quote-syntax gen:custom-write)
+                       (quote-syntax prop:gen:custom-write)
                        (quote-syntax gen:custom-write?)
                        (quote-syntax gen:custom-write-acc)
-                       (list (quote-syntax write-proc))))
+                       (list (quote-syntax write-proc))
+                       (list (quote-syntax write-proc-impl))))
 
   )

racket/collects/racket/private/generic-methods.rkt

@@ -10,11 +10,14 @@
              generic-method-table
              (for-syntax generic-info?
                          make-generic-info
+                         generic-info-name
                          generic-info-property
                          generic-info-predicate
                          generic-info-accessor
+                         generic-info-method-names
                          generic-info-methods
-                         find-generic-method-index))
+                         find-generic-method-index
+                         make-method-delta))
 
   (begin-for-syntax
 
@@ -23,16 +26,20 @@
                     generic-info?
                     generic-info-get
                     generic-info-set!)
-      (make-struct-type 'generic-info #f 4 0))
+      (make-struct-type 'generic-info #f 6 0))
 
-    (define-values (generic-info-property
+    (define-values (generic-info-name
+                    generic-info-property
                     generic-info-predicate
                     generic-info-accessor
+                    generic-info-method-names
                     generic-info-methods)
-      (values (make-struct-field-accessor generic-info-get 0 'property)
+      (values (make-struct-field-accessor generic-info-get 0 'name)
-              (make-struct-field-accessor generic-info-get 1 'predicate)
+              (make-struct-field-accessor generic-info-get 1 'property)
-              (make-struct-field-accessor generic-info-get 2 'accessor)
+              (make-struct-field-accessor generic-info-get 2 'predicate)
-              (make-struct-field-accessor generic-info-get 3 'methods)))
+              (make-struct-field-accessor generic-info-get 3 'accessor)
+              (make-struct-field-accessor generic-info-get 4 'method-names)
+              (make-struct-field-accessor generic-info-get 5 'methods)))
 
     (define (check-identifier! name ctx stx)
       (unless (identifier? stx)
@@ -87,6 +94,7 @@
 
       (define-values (originals indices)
         (let loop ([original-ids (generic-info-methods gen-info)]
+                   [impl-ids (generic-info-method-names gen-info)]
                    [index 0]
                    [rev-originals '()]
                    [rev-indices '()])
@@ -95,16 +103,17 @@
              (values (reverse rev-originals)
                      (reverse rev-indices))]
             [else
-             (define original-id (car original-ids))
+             (define context-id (delta (car impl-ids)))
-             (define context-id (syntax-local-get-shadower (delta original-id)))
              (cond
                [(free-identifier=? context-id method-id)
                 (loop (cdr original-ids)
+                      (cdr impl-ids)
                       (add1 index)
-                      (cons original-id rev-originals)
+                      (cons (car original-ids) rev-originals)
                       (cons index rev-indices))]
                [else
                 (loop (cdr original-ids)
+                      (cdr impl-ids)
                       (add1 index)
                       rev-originals
                       rev-indices)])])))
@@ -136,9 +145,18 @@
     (define (find-generic-method-original ctx gen-id delta gen-info method-id)
       (find-generic-method 'find-generic-method-index
                            ctx gen-id delta gen-info method-id
-                           (lambda (index original) original))))
+                           (lambda (index original) original)))
 
-  (define-syntax-parameter generic-method-context #f)
+    (define (make-method-delta ref-id orig-id)
+      (lambda (id)
+        ((make-syntax-delta-introducer id orig-id)
+         (datum->syntax ref-id
+                        (syntax-e id)
+                        id
+                        id)))))
+
+  (define-syntax-parameter generic-method-outer-context #f)
+  (define-syntax-parameter generic-method-inner-context #f)
 
   (define-syntax (implementation stx)
     (syntax-case stx ()
@@ -158,16 +176,18 @@
       [(_ gen def ...)
        (let ()
          (define info (get-info 'generic-methods stx #'gen))
-         (define delta (syntax-local-make-delta-introducer #'gen))
+         (define orig-id (generic-info-name info))
-         (define methods (map delta (generic-info-methods info)))
+         (define methods (map (make-method-delta #'gen orig-id)
+                              (generic-info-method-names info)))
          (with-syntax ([(method ...) methods])
            (syntax/loc stx
-             (syntax-parameterize ([generic-method-context #'gen])
+             (syntax-parameterize ([generic-method-outer-context #'gen])
                (letrec-syntaxes+values
                 ([(method) (make-unimplemented 'method)] ...)
                 ()
+                (syntax-parameterize ([generic-method-inner-context #'gen])
                   def ...
-                 (values (implementation method) ...))))))]))
+                  (values (implementation method) ...)))))))]))
 
   (define-syntax (generic-method-table stx)
     (syntax-case stx ()
@@ -175,12 +195,13 @@
        #'(call-with-values (lambda () (generic-methods gen def ...)) vector)]))
 
   (define-syntax (define/generic stx)
-    (define gen-id (syntax-parameter-value #'generic-method-context))
+    (define gen-id (syntax-parameter-value #'generic-method-outer-context))
     (define gen-val
       (and (identifier? gen-id)
            (syntax-local-value gen-id (lambda () #f))))
     (unless (generic-info? gen-val)
       (raise-syntax-error 'define/generic "only allowed inside methods" stx))
+    (define gen-inner-id (syntax-parameter-value #'generic-method-inner-context))
     (syntax-case stx ()
       [(_ bind ref)
        (let ()
@@ -188,8 +209,8 @@
            (raise-syntax-error 'define/generic "expected an identifier" #'bind))
          (unless (identifier? #'ref)
            (raise-syntax-error 'define/generic "expected an identifier" #'ref))
-         (define delta (syntax-local-make-delta-introducer gen-id))
+         (define delta
-         (define methods (generic-info-methods gen-val))
+           (make-method-delta gen-inner-id (generic-info-name gen-val)))
          (define method-id
            (find-generic-method-original stx gen-id delta gen-val #'ref))
          (with-syntax ([method method-id])

racket/collects/racket/private/generic.rkt

@@ -112,9 +112,11 @@
 
        #'(begin
            (define-syntax generic-name
-             (make-generic-info (quote-syntax property-name)
+             (make-generic-info (quote-syntax generic-name)
+                                (quote-syntax property-name)
                                 (quote-syntax prop:pred)
                                 (quote-syntax accessor-name)
+                                (list (quote-syntax method-name) ...)
                                 (list (quote-syntax method-name) ...)))
            (define (prop:guard x info)
              (unless (and (vector? x) (= (vector-length x) 'size))

racket/collects/racket/private/local.rkt

@@ -3,15 +3,16 @@
          (for-syntax syntax/kerncase))
 (provide (for-syntax do-local))
 
-(define-for-syntax (do-local stx letrec-syntaxes+values-id)
+(define-for-syntax (do-local stx combine)
   (syntax-case stx ()
     [(_ (defn ...) body1 body ...)
      (let* ([def-ctx (syntax-local-make-definition-context)]
-            [defs (let ([expand-context (cons (gensym 'intdef)
+            [expand-context (cons (gensym 'intdef)
                                   (let ([orig-ctx (syntax-local-context)])
                                     (if (pair? orig-ctx)
                                         orig-ctx
-                                                    null)))])
+                                        null)))]
+            [defs (let ()
                     (let loop ([defns (syntax->list (syntax (defn ...)))])
                       (apply
                        append
@@ -70,14 +71,18 @@
                                (map (lambda (d)
                                       (syntax-case d (define-values)
                                         [(define-values ids rhs)
-                                         (list #'(ids rhs))]
+                                         (with-syntax ([ids (map syntax-local-identifier-as-binding
+                                                                 (syntax->list #'ids))])
+                                           (list #'(ids rhs)))]
                                         [_ null]))
                                     defs))]
              [sbindings (apply append
                                (map (lambda (d)
                                       (syntax-case d (define-syntaxes)
                                         [(define-syntaxes ids rhs)
-                                         (list #'(ids rhs))]
+                                         (with-syntax ([ids (map syntax-local-identifier-as-binding
+                                                                 (syntax->list #'ids))])
+                                           (list #'(ids rhs)))]
                                         [_ null]))
                                     defs))])
          (let ([dup (check-duplicate-identifier ids)])
@@ -85,19 +90,17 @@
              (raise-syntax-error #f "duplicate identifier" stx dup)))
          (with-syntax ([sbindings sbindings]
                        [vbindings vbindings]
-                       [LSV letrec-syntaxes+values-id]
                        [(body ...)
                         (map (lambda (stx)
-                               ;; add def-ctx:
+                               (internal-definition-context-introduce
-                               (let ([q (local-expand #`(quote #,stx)
+                                def-ctx
-                                                      'expression
+                                stx
-                                                      (list #'quote)
+                                'add))
-                                                      def-ctx)])
-                                 (syntax-case q ()
-                                   [(_ stx) #'stx])))
                              (syntax->list #'(body1 body ...)))])
-           (syntax/loc stx
+           (combine def-ctx
-             (LSV sbindings vbindings
+                    expand-context
-               body ...)))))]
+                    #'sbindings
+                    #'vbindings
+                    #'(body ...)))))]
     [(_ x body1 body ...)
      (raise-syntax-error #f "not a definition sequence" stx (syntax x))]))

racket/collects/racket/private/misc.rkt

@@ -5,7 +5,7 @@
 (module misc '#%kernel
   (#%require '#%utils ; built into racket
              "small-scheme.rkt" "define.rkt"
-             (for-syntax '#%kernel "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt"))
+             (for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt"))
   
   ;; -------------------------------------------------------------------------
 

racket/collects/racket/private/more-scheme.rkt

@@ -7,6 +7,7 @@
              "member.rkt"
              (for-syntax '#%kernel "stx.rkt" "small-scheme.rkt" "stxcase-scheme.rkt" "qqstx.rkt"))
 
+  ;; For `old-case`:
   (define-syntax case-test
     (lambda (x)
       (syntax-case x ()

racket/collects/racket/private/pre-base.rkt

@@ -149,7 +149,7 @@
              stx)
             (raise-syntax-error #f "bad syntax" stx)))))
 
-  (#%provide (all-from-except "more-scheme.rkt" old-case fluid-let)
+  (#%provide (all-from-except "more-scheme.rkt" fluid-let)
              (all-from-except "misc.rkt" collection-path collection-file-path)
              (all-from "define.rkt")
              (all-from-except "letstx-scheme.rkt" -define -define-syntax -define-struct old-cond)

racket/collects/racket/private/qar.rkt

@@ -0,0 +1,501 @@
+
+;;----------------------------------------------------------------------
+;; quasiquote, and, or
+
+(module qq-and-or '#%kernel
+  (#%require (for-syntax "stx.rkt" '#%kernel))
+  
+  (define-syntaxes (let*-values let let* letrec)
+    (let-values ([(lambda-stx) (quote-syntax lambda-stx)]
+                 [(letrec-values-stx) (quote-syntax letrec-values)]
+                 [(check-for-duplicates)
+                  (lambda (new-bindings sel stx)
+                    (define-values (id-in-list?)
+                      (lambda (id l)
+                        (if (null? l)
+                            #f
+                            (if (bound-identifier=? id (car l)) 
+                                #t
+                                (id-in-list? id (cdr l))))))
+                    (if ((length new-bindings) . > . 5)
+                        (let-values ([(ht) (make-hasheq)])
+                          (letrec-values ([(check) (lambda (l)
+                                                     (if (null? l)
+                                                         (void)
+                                                         (let-values ([(id) (sel (car l))])
+                                                           (let-values ([(idl) (hash-ref ht (syntax-e id) null)])
+                                                             (if (id-in-list? id idl)
+                                                                 (raise-syntax-error
+                                                                  #f
+                                                                  "duplicate identifier"
+                                                                  stx
+                                                                  id)
+                                                                 (begin
+                                                                   (hash-set! ht (syntax-e id) (cons id idl))
+                                                                   (check (cdr l))))))))])
+                                         (check new-bindings)))
+                        (letrec-values ([(check) (lambda (l accum)
+                                                   (if (null? l)
+                                                       (void)
+                                                       (let-values ([(id) (sel (car l))])
+                                                         (if (id-in-list? id accum)
+                                                             (raise-syntax-error
+                                                              #f
+                                                              "duplicate identifier"
+                                                              stx
+                                                              id)
+                                                             (check (cdr l) (cons id accum))))))])
+                                       (check new-bindings null))))])
+      (let-values ([(go)
+                    (lambda (stx named? star? target)
+                      (define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
+                      (define-values (stx-2list?)
+                        (lambda (x)
+                          (if (stx-pair? x)
+                              (if (stx-pair? (stx-cdr x))
+                                  (stx-null? (stx-cdr (stx-cdr x)))
+                                  #f)
+                              #f)))
+                      (let-values ([(maybe-msg)
+                                    (if (not (stx-list? stx))
+                                        ""
+                                        (let-values ([(tail1) (stx-cdr stx)])
+                                          (if (stx-null? tail1)
+                                              (if named?
+                                                  "(missing name or binding pairs)"
+                                                  "(missing binding pairs)")
+                                              (if (stx-null? (stx-cdr tail1))
+                                                  (if named?
+                                                      "(missing binding pairs or body)"
+                                                      "(missing body)")
+                                                  (if named?
+                                                      (if (symbol? (syntax-e (stx-car tail1)))
+                                                          (if (stx-null? (stx-cdr (stx-cdr tail1)))
+                                                              "(missing body)"
+                                                              #f)
+                                                          #f)
+                                                      #f)))))])
+                        (if maybe-msg
+                            (raise-syntax-error #f (string-append "bad syntax " maybe-msg) stx)
+                            (void)))
+                      (let-values ([(name) (if named?
+                                               (let-values ([(n) (stx-cadr stx)])
+                                                 (if (symbol? (syntax-e n))
+                                                     n
+                                                     #f))
+                                               #f)])
+                        (let-values ([(bindings) (stx->list (stx-cadr (if name
+                                                                          (stx-cdr stx)
+                                                                          stx)))]
+                                     [(body) (stx-cdr (stx-cdr (if name
+                                                                   (stx-cdr stx)
+                                                                   stx)))])
+                          (if (not bindings)
+                              (raise-syntax-error 
+                               #f 
+                               "bad syntax (not a sequence of identifier--expression bindings)" 
+                               stx
+                               (stx-cadr stx))
+                              (let-values ([(new-bindings)
+                                            (letrec-values ([(loop)
+                                                             (lambda (l)
+                                                               (if (null? l)
+                                                                   null
+                                                                   (let-values ([(binding) (car l)])
+                                                                     (cons
+                                                                      (if (stx-2list? binding)
+                                                                          (if (symbol? (syntax-e (stx-car binding)))
+                                                                              (if name
+                                                                                  (cons (stx-car binding)
+                                                                                        (stx-cadr binding))
+                                                                                  (datum->syntax
+                                                                                   lambda-stx
+                                                                                   (cons (cons (stx-car binding)
+                                                                                               null)
+                                                                                         (stx-cdr binding))
+                                                                                   binding))
+                                                                              (raise-syntax-error 
+                                                                               #f 
+                                                                               "bad syntax (not an identifier)" 
+                                                                               stx
+                                                                               (stx-car binding)))
+                                                                          (raise-syntax-error 
+                                                                           #f 
+                                                                           "bad syntax (not an identifier and expression for a binding)" 
+                                                                           stx
+                                                                           binding))
+                                                                      (loop (cdr l))))))])
+                                              (loop bindings))])
+                                (if star?
+                                    (void)
+                                    (check-for-duplicates new-bindings 
+                                                          (if name
+                                                              car
+                                                              (lambda (v) (stx-car (stx-car v))))
+                                                          stx))
+                                (datum->syntax
+                                 lambda-stx
+                                 (if name
+                                     (apply list
+                                            (list 
+                                             (quote-syntax letrec-values)
+                                             (list
+                                              (list
+                                               (list name)
+                                               (list* (quote-syntax lambda)
+                                                      (apply list (map car new-bindings))
+                                                      body)))
+                                             name)
+                                            (map cdr new-bindings))
+                                     (list* target
+                                            new-bindings
+                                            body))
+                                 stx))))))])
+        (values
+         (lambda (stx)
+           (define-values (bad-syntax)
+             (lambda ()
+               (raise-syntax-error #f "bad syntax" stx)))
+           (define-values (l) (syntax->list stx))
+           (if (not l) (bad-syntax) (void))
+           (if ((length l) . < . 3) (bad-syntax) (void))
+           (define-values (bindings) (syntax->list (cadr l)))
+           (if (not bindings) (raise-syntax-error #f "bad syntax" stx (cadr l)) (void))
+           (for-each (lambda (binding)
+                       (define-values (l) (syntax->list binding))
+                       (if (if (not l)
+                               #t
+                               (not (= 2 (length l))))
+                           (raise-syntax-error #f "bad syntax" stx binding)
+                           (void))
+                       (define-values (vars) (syntax->list (car l)))
+                       (if (not vars) (raise-syntax-error #f "bad syntax" stx (car l)) (void))
+                       (for-each (lambda (var)
+                                   (if (not (symbol? (syntax-e var)))
+                                       (raise-syntax-error 
+                                        #f 
+                                        "bad syntax (not an identifier)" 
+                                        stx
+                                        var)
+                                       (void)))
+                                 vars)
+                       (check-for-duplicates vars values stx))
+                     bindings)
+           (define-values (gen)
+             (lambda (bindings)
+               (if (null? bindings)
+                   (list* (quote-syntax let-values) '() (cddr l))
+                   (list (quote-syntax let-values) (list (car bindings)) (gen (cdr bindings))))))
+           (datum->syntax #f (gen bindings) stx stx))
+         (lambda (stx) (go stx #t #f (quote-syntax let-values)))
+         (lambda (stx) (go stx #f #t (quote-syntax let*-values)))
+         (lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))
+
+  (define-values (qq-append)
+    (lambda (a b)
+      (if (list? a)
+	  (append a b)
+	  (raise-argument-error 'unquote-splicing "list?" a))))
+
+  (define-syntaxes (quasiquote)
+    (let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical
+                 [(unquote-stx) (quote-syntax unquote)]
+                 [(unquote-splicing-stx) (quote-syntax unquote-splicing)])
+      (lambda (in-form)
+	(if (identifier? in-form)
+	    (raise-syntax-error #f "bad syntax" in-form)
+            (void))
+	(let-values
+	    (((form) (if (stx-pair? (stx-cdr in-form))
+			 (if (stx-null? (stx-cdr (stx-cdr in-form)))
+			     (stx-car (stx-cdr in-form))
+			     (raise-syntax-error #f "bad syntax" in-form))
+			 (raise-syntax-error #f "bad syntax" in-form)))
+	     ((normal)
+	      (lambda (x old)
+		(if (eq? x old)
+		    (if (stx-null? x) 
+			(quote-syntax ())
+			(list (quote-syntax quote) x))
+		    x)))
+	     ((apply-cons)
+	      (lambda (a d)
+		(if (stx-null? d)
+		    (list (quote-syntax list) a)
+		    (if (if (pair? d)
+			    (if (free-identifier=? (quote-syntax list) (car d))
+				#t
+				(free-identifier=? (quote-syntax list*) (car d)))
+			    #f)
+			(list* (car d) a (cdr d))
+			(list (quote-syntax list*) a d))))))
+	  (datum->syntax
+	   here
+	   (normal
+	    (letrec-values
+		(((qq)
+		  (lambda (x level)
+		    (let-values
+			(((qq-list)
+			  (lambda (x level)
+			    (let-values
+				(((old-first) (stx-car x)))
+			      (let-values
+				  (((old-second) (stx-cdr x)))
+				(let-values
+				    (((first) (qq old-first level)))
+				  (let-values
+				      (((second) (qq old-second level)))
+				    (let-values
+					()
+				      (if (if (eq? first old-first)
+					      (eq? second old-second)
+					      #f)
+					  x
+					  (apply-cons
+					   (normal first old-first)
+					   (normal second old-second)))))))))))
+		      (if (stx-pair? x)
+			  (let-values
+			      (((first) (stx-car x)))
+			    (if (if (if (identifier? first)
+					(free-identifier=? first unquote-stx)
+					#f)
+				    (stx-list? x)
+				    #f)
+				(let-values
+				    (((rest) (stx-cdr x)))
+				  (if (let-values
+					  (((g35) (not (stx-pair? rest))))
+					(if g35 g35 (not (stx-null? (stx-cdr rest)))))
+				      (raise-syntax-error
+				       'unquote
+				       "expects exactly one expression"
+				       in-form
+				       x)
+                                      (void))
+				  (if (zero? level)
+				      (stx-car rest)
+				      (qq-list x (sub1 level))))
+				(if (if (if (identifier? first)
+					    (free-identifier=? first (quote-syntax quasiquote))
+					    #f)
+					(stx-list? x)
+					#f)
+				    (qq-list x (add1 level))
+				    (if (if (if (identifier? first)
+						(free-identifier=? first unquote-splicing-stx)
+						#f)
+					    (stx-list? x)
+					    #f)
+					(raise-syntax-error
+					 'unquote-splicing
+					 "invalid context within quasiquote"
+					 in-form
+					 x)
+					(if (if (stx-pair? first)
+						(if (identifier? (stx-car first))
+						    (if (free-identifier=? (stx-car first)
+                                                                           unquote-splicing-stx)
+							(stx-list? first)
+							#F)
+						    #f)
+						#f)
+					    (let-values
+						(((rest) (stx-cdr first)))
+					      (if (let-values
+						      (((g34) (not (stx-pair? rest))))
+						    (if g34
+							g34
+							(not (stx-null? (stx-cdr rest)))))
+						  (raise-syntax-error
+						   'unquote
+						   "expects exactly one expression"
+						   in-form
+						   x)
+                                                  (void))
+					      (let-values
+						  (((uqsd) (stx-car rest))
+						   ((old-l) (stx-cdr x))
+						   ((l) (qq (stx-cdr x) level)))
+						(if (zero? level)
+						    (let-values
+							(((l) (normal l old-l)))
+                                                      (if (stx-null? l)
+                                                          uqsd
+                                                          (list (quote-syntax qq-append)
+                                                                uqsd l)))
+						    (let-values
+							(((restx) (qq-list rest (sub1 level))))
+						      (let-values
+							  ()
+							(if (if (eq? l old-l)
+								(eq? restx rest)
+								#f)
+							    x
+							    (apply-cons
+							     (apply-cons
+							      (quote-syntax (quote unquote-splicing))
+							      (normal restx rest))
+							     (normal l old-l))))))))
+					    (qq-list x level))))))
+			  (if (if (syntax? x) 
+				  (vector? (syntax-e x))
+				  #f)
+			      (let-values
+				  (((l) (vector->list (syntax-e x))))
+                                ;; special case: disallow #(unquote <e>)
+                                (if (stx-pair? l)
+                                    (let-values ([(first) (stx-car l)])
+                                      (if (identifier? first)
+                                          (if (free-identifier=? first unquote-stx)
+                                              (raise-syntax-error
+                                               'unquote
+                                               "invalid context within quasiquote"
+                                               in-form
+                                               first)
+                                              (void))
+                                          (void)))
+                                    (void))
+				(let-values
+				    (((l2) (qq l level)))
+                                  (if (eq? l l2)
+                                      x
+                                      (list (quote-syntax list->vector) l2))))
+			      (if (if (syntax? x) (box? (syntax-e x)) #f)
+				  (let-values
+				      (((v) (unbox (syntax-e x))))
+				    (let-values
+					(((qv) (qq v level)))
+				      (if (eq? v qv)
+                                          x
+                                          (list (quote-syntax box) qv))))
+                                  (if (if (syntax? x) 
+                                          (if (struct? (syntax-e x)) 
+                                              (prefab-struct-key (syntax-e x))
+                                              #f)
+                                          #f)
+                                      ;; pre-fab struct
+                                      (let-values
+                                          (((l) (cdr (vector->list (struct->vector (syntax-e x))))))
+                                        (let-values
+                                            (((l2) (qq l level)))
+                                          (if (eq? l l2)
+                                              x
+                                              (list (quote-syntax apply)
+                                                    (quote-syntax make-prefab-struct)
+                                                    (list (quote-syntax quote)
+                                                          (prefab-struct-key (syntax-e x)))
+                                                    l2))))
+                                      ;; hash[eq[v]]
+                                      (if (if (syntax? x)
+                                              (hash? (syntax-e x))
+                                              #f)
+                                          (letrec-values
+                                              (((qq-hash-assocs)
+						(lambda (x level)
+						  (if (null? x)
+						      x
+						      (let-values
+						          (((pair) (car x)))
+                                                        (let-values ([(val)
+                                                                      (qq (datum->syntax here (cdr pair)) level)]
+                                                                     [(rest)
+                                                                      (qq-hash-assocs (cdr x) level)])
+                                                          (if (if (eq? val (cdr pair))
+                                                                  (eq? rest (cdr x))
+                                                                  #f)
+                                                              x
+                                                              (apply-cons
+                                                               (list (quote-syntax list*)
+                                                                     (list (quote-syntax quote)
+                                                                           (datum->syntax here (car pair)))
+                                                                     (if (eq? val (cdr pair))
+                                                                         (list (quote-syntax quote)
+                                                                               val)
+                                                                         val))
+                                                               (if (eq? rest (cdr x))
+                                                                   (list (quote-syntax quote)
+                                                                         rest)
+                                                                   rest)))))))))
+                                            (let-values (((l0) (hash-map (syntax-e x) cons)))
+                                              (let-values
+                                                  (((l) (qq-hash-assocs l0 level)))
+                                                (if (eq? l0 l)
+                                                    x
+                                                    (list (if (hash-eq? (syntax-e x))
+                                                              (quote-syntax make-immutable-hasheq)
+                                                              (if (hash-eqv? (syntax-e x))
+                                                                  (quote-syntax make-immutable-hasheqv)
+                                                                  (quote-syntax make-immutable-hash)))
+                                                          l)))))
+                                          x)))))))))
+	      (qq form 0))
+	    form)
+	   in-form)))))
+
+  (define-syntaxes (and)
+    (let-values ([(here) (quote-syntax here)])
+      (lambda (x)
+	(if (not (stx-list? x))
+	    (raise-syntax-error #f "bad syntax" x)
+            (void))
+	(let-values ([(e) (stx-cdr x)])
+	  (if (stx-null? e)
+	      (quote-syntax #t)
+	      (if (if (stx-pair? e)
+		      (stx-null? (stx-cdr e))
+		      #t)
+                  (datum->syntax
+                   here
+                   (list (quote-syntax #%expression)
+                         (stx-car e))
+                   x)
+		  (datum->syntax
+		   here
+		   (list (quote-syntax if)
+			 (stx-car e)
+			 (cons (quote-syntax and)
+			       (stx-cdr e))
+			 (quote-syntax #f))
+		   x)))))))
+
+  (define-syntaxes (or)
+    (let-values ([(here) (quote-syntax here)])
+      (lambda (x)
+	(if (identifier? x)
+	    (raise-syntax-error #f "bad syntax" x)
+            (void))
+	(let-values ([(e) (stx-cdr x)])
+	  (if (stx-null? e) 
+	      (quote-syntax #f)
+	      (if (if (stx-pair? e)
+		      (stx-null? (stx-cdr e))
+		      #f)
+                  (datum->syntax
+                   here
+                   (list (quote-syntax #%expression)
+                         (stx-car e))
+                   x)
+		  (if (stx-list? e)
+		      (let-values ([(tmp) 'or-part])
+			(datum->syntax
+			 here
+			 (list (quote-syntax let) (list
+						   (list
+						    tmp
+						    (stx-car e)))
+			       (list (quote-syntax if)
+				     tmp
+				     tmp
+				     (cons (quote-syntax or)
+					   (stx-cdr e))))
+			 x))
+		      (raise-syntax-error 
+		       #f
+		       "bad syntax"
+		       x))))))))
+
+  (#%provide let*-values
+             let let* letrec
+             quasiquote and or))

racket/collects/racket/private/qq-and-or.rkt

@@ -5,12 +5,11 @@
 (module qq-and-or '#%kernel
   (#%require (for-syntax "stx.rkt" '#%kernel))
   
-  (define-syntaxes (let let* letrec)
+  (define-syntaxes (let*-values let let* letrec)
     (let-values ([(lambda-stx) (quote-syntax lambda-stx)]
-                 [(letrec-values-stx) (quote-syntax letrec-values)])
+                 [(letrec-values-stx) (quote-syntax letrec-values)]
-      (let-values ([(go)
+                 [(check-for-duplicates)
-                    (lambda (stx named? star? target)
+                  (lambda (new-bindings sel stx)
-                      (define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
                     (define-values (id-in-list?)
                       (lambda (id l)
                         (if (null? l)
@@ -18,6 +17,38 @@
                             (if (bound-identifier=? id (car l)) 
                                 #t
                                 (id-in-list? id (cdr l))))))
+                    (if ((length new-bindings) . > . 5)
+                        (let-values ([(ht) (make-hasheq)])
+                          (letrec-values ([(check) (lambda (l)
+                                                     (if (null? l)
+                                                         (void)
+                                                         (let-values ([(id) (sel (car l))])
+                                                           (let-values ([(idl) (hash-ref ht (syntax-e id) null)])
+                                                             (if (id-in-list? id idl)
+                                                                 (raise-syntax-error
+                                                                  #f
+                                                                  "duplicate identifier"
+                                                                  stx
+                                                                  id)
+                                                                 (begin
+                                                                   (hash-set! ht (syntax-e id) (cons id idl))
+                                                                   (check (cdr l))))))))])
+                                         (check new-bindings)))
+                        (letrec-values ([(check) (lambda (l accum)
+                                                   (if (null? l)
+                                                       (void)
+                                                       (let-values ([(id) (sel (car l))])
+                                                         (if (id-in-list? id accum)
+                                                             (raise-syntax-error
+                                                              #f
+                                                              "duplicate identifier"
+                                                              stx
+                                                              id)
+                                                             (check (cdr l) (cons id accum))))))])
+                                       (check new-bindings null))))])
+      (let-values ([(go)
+                    (lambda (stx named? star? target)
+                      (define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
                       (define-values (stx-2list?)
                         (lambda (x)
                           (if (stx-pair? x)
@@ -97,39 +128,11 @@
                                               (loop bindings))])
                                 (if star?
                                     (void)
-                                    (if ((length new-bindings) . > . 5)
+                                    (check-for-duplicates new-bindings 
-                                        (let-values ([(ht) (make-hasheq)])
+                                                          (if name
-                                          (letrec-values ([(check) (lambda (l)
+                                                              car
-                                                                     (if (null? l)
+                                                              (lambda (v) (stx-car (stx-car v))))
-                                                                         (void)
+                                                          stx))
-                                                                         (let*-values ([(id) (if name
-                                                                                                 (caar l)
-                                                                                                 (stx-car (stx-car (car l))))]
-                                                                                       [(idl) (hash-ref ht (syntax-e id) null)])
-                                                                           (if (id-in-list? id idl)
-                                                                               (raise-syntax-error
-                                                                                #f
-                                                                                "duplicate identifier"
-                                                                                stx
-                                                                                id)
-                                                                               (begin
-                                                                                 (hash-set! ht (syntax-e id) (cons id idl))
-                                                                                 (check (cdr l)))))))])
-                                            (check new-bindings)))
-                                        (letrec-values ([(check) (lambda (l accum)
-                                                                   (if (null? l)
-                                                                       (void)
-                                                                       (let-values ([(id) (if name
-                                                                                              (caar l)
-                                                                                              (stx-car (stx-car (car l))))])
-                                                                         (if (id-in-list? id accum)
-                                                                             (raise-syntax-error
-                                                                              #f
-                                                                              "duplicate identifier"
-                                                                              stx
-                                                                              id)
-                                                                             (check (cdr l) (cons id accum))))))])
-                                          (check new-bindings null))))
                                 (datum->syntax
                                  lambda-stx
                                  (if name
@@ -149,6 +152,44 @@
                                             body))
                                  stx))))))])
         (values
+         (lambda (stx)
+           (define-values (bad-syntax)
+             (lambda ()
+               (raise-syntax-error #f "bad syntax" stx)))
+           (define-values (l) (syntax->list stx))
+           (if (not l) (bad-syntax) (void))
+           (if ((length l) . < . 3) (bad-syntax) (void))
+           (define-values (bindings) (syntax->list (cadr l)))
+           (if (not bindings) (raise-syntax-error #f "bad syntax" stx (cadr l)) (void))
+           (for-each (lambda (binding)
+                       (define-values (l) (syntax->list binding))
+                       (if (if (not l)
+                               #t
+                               (not (= 2 (length l))))
+                           (raise-syntax-error #f "bad syntax" stx binding)
+                           (void))
+                       (define-values (vars) (syntax->list (car l)))
+                       (if (not vars) (raise-syntax-error #f "bad syntax" stx (car l)) (void))
+                       (for-each (lambda (var)
+                                   (if (not (symbol? (syntax-e var)))
+                                       (raise-syntax-error 
+                                        #f 
+                                        "bad syntax (not an identifier)" 
+                                        stx
+                                        var)
+                                       (void)))
+                                 vars)
+                       (check-for-duplicates vars values stx))
+                     bindings)
+           (define-values (gen)
+             (lambda (bindings nested?)
+               (if (null? bindings)
+                   (if nested?
+                       (cddr l)
+                       (list* (quote-syntax let-values) '() (cddr l)))
+                   ((if nested? list values)
+                    (list* (quote-syntax let-values) (list (car bindings)) (gen (cdr bindings) #t))))))
+           (datum->syntax #f (gen bindings #f) stx stx))
          (lambda (stx) (go stx #t #f (quote-syntax let-values)))
          (lambda (stx) (go stx #f #t (quote-syntax let*-values)))
          (lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))
@@ -458,5 +499,6 @@
 		       "bad syntax"
 		       x))))))))
 
-  (#%provide let let* letrec
+  (#%provide let*-values
+             let let* letrec
              quasiquote and or))

racket/collects/racket/private/reqprov.rkt

@@ -322,7 +322,9 @@
                                 in)))]
                        ;; General case:
                        [_ (let-values ([(imports sources) (expand-import in)])
-                            ;; TODO: collapse back to simple cases when possible
+                            ;; Note: in case `in` could be expressed as a simple import form,
+                            ;; the core `#%require` form will collapse back to simple form
+                            ;; in many cases.
                             (cons/syntax-track/form
                              #'(just-meta 0)
                              in
@@ -406,8 +408,13 @@
                                        (current-load-relative-directory))
                                (list prefetches (current-load-relative-directory))
                                #f))
+                (with-syntax ([(req-in ...)
+                               (map (lambda (in)
+                                      (with-syntax ([in in])
+                                        (syntax/loc stx (require in))))
+                                    (syntax->list #'(in ...)))])
                   (syntax/loc stx
-                  (begin (require in) ...)))])))]
+                    (begin req-in ...))))])))]
       [else
        (raise-syntax-error #f
                            "not at module level or top level"

racket/collects/racket/private/stxparam.rkt

@@ -31,7 +31,8 @@
 				    stx
 				    id))
 				 (syntax-local-get-shadower
-				  (syntax-local-introduce (syntax-parameter-target sp)))))
+				  (syntax-local-introduce (syntax-parameter-target sp))
+                                  #t)))
 			     ids)])
 	   (let ([dup (check-duplicate-identifier ids)])
 	     (when dup

racket/collects/racket/private/stxparamkey.rkt

@@ -13,7 +13,7 @@
     (syntax-parameter-ref sp 1))
 
   (define (target-value target)
-    (syntax-local-value (syntax-local-get-shadower target)
+    (syntax-local-value (syntax-local-get-shadower target #t)
                         (lambda ()
                           (syntax-local-value 
                            target

racket/collects/racket/private/submodule.rkt

@@ -68,6 +68,6 @@
             (list*
              #'module* 
              #'the-submodule 
-             #'#f
+             #f ; namespace context is the original context
              (map syntax-local-introduce (reverse (unbox stxs-box))))
             stx))]))))

racket/collects/racket/private/unit-compiletime.rkt

@@ -20,7 +20,9 @@
          process-tagged-import process-tagged-export
          lookup-signature lookup-def-unit make-id-mapper make-id-mappers sig-names sig-int-names sig-ext-names
          map-sig split-requires split-requires* apply-mac complete-exports complete-imports check-duplicate-subs
-         process-spec)
+         process-spec
+         make-relative-introducer
+         bind-at)
 
 (define-syntax (apply-mac stx)
   (syntax-case stx ()
@@ -118,7 +120,7 @@
 ;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier boolean)
 (define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder contracted?)
   (lambda (struct stx) 
-    (with-syntax ((u (unit-info-unit-id struct)))
+    (with-syntax ((u (syntax-local-introduce (unit-info-unit-id struct))))
       (syntax-case stx (set!)
         ((set! x y)
          (if (unit-info-contracted? struct)
@@ -169,12 +171,12 @@
 (define (check-bound-id-subset i1 i2)
   (let ((ht (make-bound-identifier-mapping)))
     (for-each (lambda (id)
-                (bound-identifier-mapping-put! ht id #t))
+                (bound-identifier-mapping-put! ht (syntax-local-identifier-as-binding id) #t))
               i2)
     (for-each
      (lambda (id)
        (check-id id)
-       (unless (bound-identifier-mapping-get ht id (lambda () #f))
+       (unless (bound-identifier-mapping-get ht (syntax-local-identifier-as-binding id) (lambda () #f))
          (raise-stx-err "listed identifier not present in signature specification" id)))
      i1)))
 
@@ -188,14 +190,15 @@
     (for-each
      (lambda (int ext)
        (check-id int)
+       (let ([ext (syntax-local-identifier-as-binding ext)])
          (when (bound-identifier-mapping-get ht ext (lambda () #f))
            (raise-stx-err "duplicate renamings" ext))
-       (bound-identifier-mapping-put! ht ext int))
+         (bound-identifier-mapping-put! ht ext int)))
      (syntax->list internals)
      (syntax->list externals))
     (map-sig
      (lambda (id)
-       (bound-identifier-mapping-get ht id (lambda () id)))
+       (bound-identifier-mapping-get ht (syntax-local-identifier-as-binding id) (lambda () id)))
      (lambda (x) x)
      sig)))
 
@@ -226,8 +229,16 @@
      (lambda (x) x)
      sig)))
 
-;; do-identifier : identifier (box (cons identifier siginfo)) -> sig
+(define (make-relative-introducer ref-id orig-id)
-(define (do-identifier spec res bind? add-prefix)
+  (lambda (id)
+    ((make-syntax-delta-introducer id orig-id)
+     (datum->syntax ref-id
+                    (syntax-e id)
+                    id
+                    id))))
+
+;; do-identifier : identifier syntax-object (box (cons identifier siginfo)) -> sig
+(define (do-identifier spec spec-bind res bind? add-prefix)
   (let* ((sig (lookup-signature spec))
          (vars (signature-vars sig))
          (vals (signature-val-defs sig))
@@ -235,16 +246,14 @@
          (p-vals (signature-post-val-defs sig))
          (ctcs  (signature-ctcs sig))
          (delta-introduce (if bind?
-                              (let ([f (syntax-local-make-delta-introducer
+                              (make-relative-introducer spec-bind
-                                        spec)])
+                                                        (car (siginfo-names (signature-siginfo sig))))
-                                (lambda (id) (syntax-local-introduce (f id))))
+                              (lambda (id)
-                              values)))
+                                (syntax-local-introduce id)))))
     (set-box! res (cons spec (signature-siginfo sig)))
     (map-sig (lambda (id)
-               (syntax-local-introduce 
-                (syntax-local-get-shadower
                (add-prefix
-                  (delta-introduce id)))))
+                (delta-introduce id)))
              syntax-local-introduce
              (list (map cons vars vars)
                    (map 
@@ -313,57 +322,66 @@
 ;; A tagged-import-spec is one of
 ;; - import-spec
 ;; - (tag symbol import-spec)
+;; - (bind-at id tagged-import-spec)
 
 ;; A tagged-export-spec is one of
 ;; - export-spec
 ;; - (tag symbol export-spec)
-
+;; - (bind-at id tagged-export-spec)
 
 ;; process-tagged-import/export : syntax-object boolean -> tagged-sig
 (define (process-tagged-import/export spec import? bind?)
   (define res (box #f))
+  (let loop ([spec spec] [spec-bind #f])
+    (syntax-case spec (bind-at)
+      ((bind-at id spec)
+       (loop #'spec #'id))
+      (_
+       (begin
          (check-tagged-spec-syntax spec import? identifier?)
          (syntax-case spec (tag)
            ((tag sym spec)
-     (let ([s (process-import/export #'spec res bind? values)])
+            (let ([s (process-import/export #'spec spec-bind res bind? values)])
               (list (cons (syntax-e #'sym) (cdr (unbox res)))
                     (cons (syntax-e #'sym) (car (unbox res)))
                     s)))
            ((tag . _)
             (raise-stx-err "expected (tag symbol <import/export-spec>)" spec))
-    (_ (let ([s (process-import/export spec res bind? values)])
+           (_ (let ([s (process-import/export spec spec-bind res bind? values)])
                 (list (cons #f (cdr (unbox res)))
                       (cons #f (car (unbox res)))
-               s)))))
+                      s)))))))))
 
 (define (add-prefixes add-prefix l)
   (map add-prefix (syntax->list l)))
 
-;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig
+;; process-import/export : syntax-object syntax-object (box (cons identifier) siginfo) -> sig
-(define (process-import/export spec res bind? add-prefix)
+(define (process-import/export spec spec-bind res bind? add-prefix)
-  (syntax-case spec (only except prefix rename)
+  (syntax-case spec (only except prefix rename bind-at)
     (_
      (identifier? spec)
-     (do-identifier spec res bind? add-prefix))
+     (do-identifier spec (or spec-bind spec) res bind? add-prefix))
+    ((bind-at spec-bind spec)
+     (process-import/export #'spec #'spec-bind res bind? add-prefix))
     ((only sub-spec id ...)
-     (do-only/except (process-import/export #'sub-spec res bind? add-prefix)
+     (do-only/except (process-import/export #'sub-spec spec-bind res bind? add-prefix)
                      (add-prefixes add-prefix #'(id ...))
                      (lambda (id) id)
                      (lambda (id)
                        (car (generate-temporaries #`(#,id))))))
     ((except sub-spec id ...)
-     (do-only/except (process-import/export #'sub-spec res bind? add-prefix)
+     (do-only/except (process-import/export #'sub-spec spec-bind res bind? add-prefix)
                      (add-prefixes add-prefix #'(id ...))
                      (lambda (id)
                        (car (generate-temporaries #`(#,id))))
                      (lambda (id) id)))
     ((prefix pid sub-spec)
-     (process-import/export #'sub-spec res bind?
+     (process-import/export #'sub-spec spec-bind res bind?
                             (lambda (id)
                               (add-prefix (do-prefix id #'pid)))))
     ((rename sub-spec (internal external) ...)
      (let* ((sig-res
-             (do-rename (process-import/export #'sub-spec res bind? add-prefix)
+             (do-rename (process-import/export #'sub-spec spec-bind res bind? add-prefix)
                         #'(internal ...)
                         (datum->syntax #f (add-prefixes add-prefix #'(external ...)))))
             (dup (check-duplicate-identifier (sig-int-names sig-res))))
@@ -381,7 +399,7 @@
 ;; process-spec : syntax-object -> sig
 (define (process-spec spec)
   (check-tagged-spec-syntax spec #f identifier?)
-  (process-import/export spec (box #f) #t values))
+  (process-import/export spec spec (box #f) #t values))
 
 
 ;  ;; extract-siginfo : (union import-spec export-spec) -> ???

racket/collects/racket/private/unit-syntax.rkt

@@ -5,6 +5,8 @@
   
 (provide (all-defined-out))
 
+(define bind-at #f)
+
 (define error-syntax (make-parameter #f))
 (define raise-stx-err
   (case-lambda
@@ -29,7 +31,10 @@
 ;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
 (define (check-tagged check)
   (λ (o)
-    (syntax-case o (tag)
+    (let loop ([o o])
+      (syntax-case o (bind-at tag)
+        ((bind-at bind o)
+         (loop #'o))
         ((tag . s)
          (syntax-case #'s ()
            ((sym spec) 
@@ -39,7 +44,7 @@
               (cons (syntax-e #'sym) (check #'spec))))
            (_ (raise-stx-err "expected (tag <identifier> <syntax>)" #'s))))
         (_ 
-       (cons #f (check o))))))
+         (cons #f (check o)))))))
 
 ;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
 ;; ensures that clause matches (a : b) or (a : (tag t b))
@@ -76,7 +81,9 @@
       (unless (stx-pair? s)
         (raise-stx-err (format "bad ~a spec" ie) s))
       (checked-syntax->list s)
-      (syntax-case s (prefix rename)
+      (syntax-case s (prefix rename bind-at)
+        ((bind-at any spec)
+         (check-spec-syntax #'spec import? prim-spec?))
         ((key . x)
          (or (free-identifier=? #'key #'only)
              (free-identifier=? #'key #'except))

racket/collects/racket/signature/lang.rkt

@@ -9,7 +9,9 @@
 
 (provide (rename-out [module-begin #%module-begin]
                      [struct~s struct])
-         (except-out (all-from-out racket/base) #%module-begin)
+         (except-out (all-from-out racket/base)
+                     #%module-begin
+                     struct)
          (all-from-out racket/unit)
          (all-from-out racket/contract)
          (for-syntax (all-from-out racket/base)))
@@ -25,7 +27,8 @@
 
 (define-syntax (module-begin stx)
   (parameterize ((error-syntax stx))
-    (with-syntax ((name (make-name (syntax-property stx 'enclosing-module-name))))
+    (with-syntax ((name (datum->syntax stx
+                                       (make-name (syntax-property stx 'enclosing-module-name)))))
       (syntax-case stx ()
         ((_ . x)
          (with-syntax ((((reqs ...) . (body ...))

racket/collects/racket/splicing.rkt

@@ -21,67 +21,38 @@
          splicing-local
          splicing-syntax-parameterize)
 
-(define-for-syntax ((check-id stx) id-stx)
+(define-syntax (splicing-local stx)
-  (unless (identifier? id-stx)
+  (do-local stx (lambda (def-ctx expand-context sbindings vbindings bodys)
-    (raise-syntax-error #f "expected an identifier" stx id-stx))
-  (list id-stx))
-
-(define-for-syntax ((check-ids stx) ids-stx)
-  (let ([ids (syntax->list ids-stx)])
-    (unless ids
-      (raise-syntax-error 
-       #f
-       "expected a parenthesized sequence of identifiers"
-       stx
-       ids-stx))
-    (for-each (check-id stx) ids)
-    ids))
-
-(define-for-syntax (check-dup-binding stx idss)
-  (let ([dup-id (check-duplicate-identifier (apply append idss))])
-    (when dup-id
-      (raise-syntax-error #f "duplicate binding" stx dup-id))))
-
-(define-for-syntax (do-let-syntax stx rec? multi? let-id def-id need-top-decl?)
-  (syntax-case stx ()
-    [(_ ([ids expr] ...) body ...)
-     (let ([all-ids (map ((if multi? check-ids check-id) stx)
-                         (syntax->list #'(ids ...)))])
-       (check-dup-binding stx all-ids)
                   (if (eq? 'expression (syntax-local-context))
-           (with-syntax ([LET let-id])
+                      (quasisyntax/loc stx
-             (syntax/loc stx
+                        (letrec-syntaxes+values
-               (LET ([ids expr] ...)
+                         #,sbindings
-                 (#%expression body)
+                         #,vbindings
-                 ...)))
+                         #,@bodys))
-           (let ([def-ctx (syntax-local-make-definition-context)]
+                      ;; Since we alerady have bindings for the current scopes,
-                 [ctx (list (gensym 'intdef))])
+                      ;; add an extra scope for re-binding:
-             (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
+                      (let ([i (make-syntax-introducer)])
-             (internal-definition-context-seal def-ctx)
+                        (with-syntax ([([s-ids s-rhs] ...) (i sbindings)]
-             (let* ([add-context
+                                      [([(v-id ...) v-rhs] ...) (i vbindings)]
-                     (lambda (expr)
+                                      [(body ...) (i bodys)]
-                       (internal-definition-context-apply def-ctx expr))])
+                                      [(marked-id markless-id)
-               (with-syntax ([((id ...) ...)
+                                       (let ([id #'id])
-                              (map (lambda (ids)
+                                         ;; The marked identifier should have both the extra
-                                     (map add-context ids))
+                                         ;; scope and the intdef scope, to be removed from
-                                   all-ids)]
+                                         ;; definitions expanded from `body`:
-                             [(expr ...)
+                                         (list (i (internal-definition-context-introduce def-ctx id))
-                              (let ([exprs (syntax->list #'(expr ...))])
+                                               id))])
-                                (if rec?
-                                    (map add-context exprs)
-                                    exprs))]
-                             [(body ...)
-                              (map add-context (syntax->list #'(body ...)))]
-                             [DEF def-id])
                           (with-syntax ([(top-decl ...)
-                                (if (and need-top-decl? (equal? 'top-level (syntax-local-context)))
+                                         (if (equal? 'top-level (syntax-local-context))
-                                    #'((define-syntaxes (id ... ...) (values)))
+                                             #'((define-syntaxes (v-id ... ...) (values)))
                                              null)])
-                   #'(begin
+                            (quasisyntax/loc stx
+                              (begin
                                 top-decl ...
-                       (DEF (id ...) expr)
+                                (define-syntaxes s-ids s-rhs) ...
-                       ...
+                                (define-values (v-id ...) v-rhs) ...
-                       body ...)))))))]))
+                                (splicing-let-start/body marked-id markless-id body)
+                                ...)))))))))
 
 (define-syntax (splicing-let-syntax stx)
   (do-let-syntax stx #f #f #'let-syntax #'define-syntaxes #f))
@@ -107,6 +78,146 @@
 (define-syntax (splicing-letrec-values stx)
   (do-let-syntax stx #t #t #'letrec-values #'define-values #t))
 
+(define-for-syntax (do-let-syntax stx rec? multi? let-id def-id need-top-decl?)
+  (syntax-case stx ()
+    [(_ ([ids expr] ...) body ...)
+     (let ([all-ids (map ((if multi? check-ids check-id) stx)
+                         (syntax->list #'(ids ...)))])
+       (check-dup-binding stx all-ids)
+       (if (eq? 'expression (syntax-local-context))
+           (with-syntax ([LET let-id])
+             (syntax/loc stx
+               (LET ([ids expr] ...)
+                 (#%expression body)
+                 ...)))
+           (with-syntax ([((id ...) ...) all-ids]
+                         [DEF def-id]
+                         [rec? rec?]
+                         [(marked-id markless-id)
+                          (let ([id #'id])
+                            (list ((make-syntax-introducer) id)
+                                  id))])
+             (with-syntax ([(top-decl ...)
+                            (if (and need-top-decl? (equal? 'top-level (syntax-local-context)))
+                                #'((define-syntaxes (id ... ...) (values)))
+                                null)])
+               
+               (syntax/loc stx
+                 (begin
+                   (splicing-let-start/def marked-id markless-id #f top-decl) ...
+                   (splicing-let-start/def marked-id markless-id rec? (DEF (id ...) expr))
+                   ...
+                   (splicing-let-start/body marked-id markless-id body)
+                   ...))))))]))
+
+(define-syntax (splicing-let-start/def stx)
+  (syntax-case stx ()
+    [(_ marked-id markless-id rec? (DEF ids rhs))
+     ;; Add the mark to every definition's identifiers; also
+     ;; add to the body, if it's a recursively scoped binding:
+     (let ([i (make-syntax-delta-introducer #'marked-id #'markless-id)])
+       #`(DEF #,(i #'ids) #,(if (syntax-e #'rec?)
+                                (i #'rhs)
+                                #'rhs)))]))
+
+(define-syntax (splicing-let-start/body stx)
+  (syntax-case stx ()
+    [(_ marked-id markless-id body)
+     ;; Tenatively add the mark to the body,; we'll remove it on every
+     ;; bit of syntax that turns out to be a binding:
+     (let ([i (make-syntax-delta-introducer #'marked-id #'markless-id)])
+       #`(splicing-let-body marked-id markless-id #,(i #'body)))]))
+
+(define-syntax (splicing-let-body stx)
+  (syntax-case stx ()
+    [(_ marked-id markless-id body)
+     (let ([unintro (lambda (form)
+                      ((make-syntax-delta-introducer #'marked-id #'markless-id) form 'remove))]
+           [body (local-expand #'body (syntax-local-context) #f)])
+       (syntax-case body (begin
+                           define-values
+                           define-syntaxes
+                           begin-for-syntax
+                           module
+                           module*
+                           #%require
+                           #%provide
+                           #%declare)
+         [(begin form ...)
+          (syntax/loc body
+            (begin (splicing-let-body marked-id markless-id form) ...))]
+         [(define-values ids rhs)
+          (quasisyntax/loc body
+            (define-values #,(unintro #'ids) rhs))]
+         [(define-syntaxes ids rhs)
+          (quasisyntax/loc body
+            (define-syntaxes #,(unintro #'ids) rhs))]
+         [(begin-for-syntax e ...)
+          (syntax/loc body
+            (begin-for-syntax (splicing-let-body/et marked-id markless-id e) ...))]
+         [(module . _) (unintro body)]
+         [(module* . _) body]
+         [(#%require . _) (unintro body)]
+         [(#%provide . _) body]
+         [(#%declare . _) body]
+         [_ body]))]))
+
+(begin-for-syntax
+  (define-syntax (splicing-let-body/et stx)
+    (syntax-case stx ()
+      [(_ marked-id markless-id body)
+       (let ([unintro (lambda (form)
+                      ((make-syntax-delta-introducer #'marked-id #'markless-id) form 'remove))]
+             [body (local-expand #'body (syntax-local-context) #f)])
+         (syntax-case body (begin
+                             define-values
+                             define-syntaxes
+                             begin-for-syntax
+                             module
+                             module*
+                             #%require
+                             #%provide
+                             #%declare)
+           [(begin form ...)
+            (syntax/loc body
+              (begin (splicing-let-body/et marked-id markless-id form) ...))]
+           [(define-values ids rhs)
+            (quasisyntax/loc body
+              (define-values #,(unintro #'ids) rhs))]
+           [(define-syntaxes ids rhs)
+            (quasisyntax/loc body
+              (define-syntaxes #,(unintro #'ids) rhs))]
+           [(begin-for-syntax . es)
+            ;; Give up on splicing definitions at phase level 2 and deeper:
+            body]
+           [(module . _) (unintro body)]
+           [(module* . _) body]
+           [(#%require . _) (unintro body)]
+           [(#%provide . _) body]
+           [(#%declare . _) body]
+           [_ body]))])))
+
+(define-for-syntax ((check-id stx) id-stx)
+  (unless (identifier? id-stx)
+    (raise-syntax-error #f "expected an identifier" stx id-stx))
+  (list id-stx))
+
+(define-for-syntax ((check-ids stx) ids-stx)
+  (let ([ids (syntax->list ids-stx)])
+    (unless ids
+      (raise-syntax-error 
+       #f
+       "expected a parenthesized sequence of identifiers"
+       stx
+       ids-stx))
+    (for-each (check-id stx) ids)
+    ids))
+
+(define-for-syntax (check-dup-binding stx idss)
+  (let ([dup-id (check-duplicate-identifier (apply append idss))])
+    (when dup-id
+      (raise-syntax-error #f "duplicate binding" stx dup-id))))
+
 ;; ----------------------------------------
 
 (define-syntax (splicing-letrec-syntaxes+values stx)
@@ -122,41 +233,23 @@
            (syntax/loc stx
              (letrec-syntaxes+values ([sids sexpr] ...) ([vids vexpr] ...)
                (#%expression body) ...))
-           (let ([def-ctx (syntax-local-make-definition-context)]
+           (with-syntax ([((vid ...) ...) all-vids]
-                 [ctx (list (gensym 'intdef))])
+                         [(marked-id markless-id)
-             (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
+                          (let ([id #'id])
-             (internal-definition-context-seal def-ctx)
+                            (list ((make-syntax-introducer) id)
-             (let* ([add-context
+                                  id))])
-                     (lambda (expr)
+             (with-syntax ([(top-decl ...)
-                       (internal-definition-context-apply def-ctx expr))]
-                    [add-context-to-idss
-                     (lambda (idss)
-                       (map add-context idss))])
-               (with-syntax ([((sid ...) ...)
-                              (map add-context-to-idss all-sids)]
-                             [((vid ...) ...)
-                              (map add-context-to-idss all-vids)]
-                             [(sexpr ...)
-                              (map add-context (syntax->list #'(sexpr ...)))]
-                             [(vexpr ...)
-                              (map add-context (syntax->list #'(vexpr ...)))]
-                             [(body ...)
-                              (map add-context (syntax->list #'(body ...)))])
-                 (with-syntax ([top-decl
                             (if (equal? 'top-level (syntax-local-context))
-                                    #'(define-syntaxes (vid ... ...) (values))
+                                #'((define-syntaxes (vid ... ...) (values)))
-                                    #'(begin))])
+                                null)])
                (syntax/loc stx
                  (begin
-                       top-decl
+                   (splicing-let-start/def marked-id markless-id #f top-decl) ...
-                       (define-syntaxes (sid ...) sexpr) ...
+                   (splicing-let-start/def marked-id markless-id #t (define-syntaxes sids sexpr))
-                       (define-values (vid ...) vexpr) ...
+                   ...
-                       body ...))))))))]))
+                   (splicing-let-start/def marked-id markless-id #t (define-values (vid ...) vexpr))
-
+                   ...
-
+                   (splicing-let-start/body marked-id markless-id body ...)))))))]))
-
-(define-syntax (splicing-local stx)
-  (do-local stx #'splicing-letrec-syntaxes+values))
 
 ;; ----------------------------------------
 
@@ -181,16 +274,20 @@
 (define-syntax (expand-ssp-body stx)
   (syntax-case stx ()
     [(_ (sp-id ...) (temp-id ...) (orig-id ...) body)
-     (let ([body (local-expand #'(letrec-syntaxes/trans ([(sp-id) (syntax-local-value (quote-syntax temp-id))]
+     (let ([ctx (syntax-local-make-definition-context #f #f)])
-                                                         ...)
+       (for ([sp-id (in-list (syntax->list #'(sp-id ...)))]
-                                    (force-expand body))
+             [temp-id (in-list (syntax->list #'(temp-id ...)))])
+         (syntax-local-bind-syntaxes (list sp-id)
+                                     #`(syntax-local-value (quote-syntax #,temp-id))
+                                     ctx))
+       (let ([body (local-expand #'(force-expand body)
                                  (syntax-local-context)
                                  null ;; `force-expand' actually determines stopping places
-                               #f)])
+                                 ctx)])
+         (let ([body
                 ;; Extract expanded body out of `body':
                 (syntax-case body (quote)
-         [(ls _ _ (quote body))
+                  [(quote body) #'body])])
-          (let ([body #'body])
            (syntax-case body ( begin
                                define-values
                                define-syntaxes
@@ -221,7 +318,7 @@
               [(#%declare . _) body]
               [expr (syntax/loc body
                       (letrec-syntaxes ([(sp-id) (syntax-local-value (quote-syntax temp-id))] ...)
-                        expr))]))]))]))
+                        expr))]))))]))
 
 (define-syntax (letrec-syntaxes/trans stx)
   (syntax-case stx ()

racket/collects/racket/stream.rkt

@@ -45,9 +45,13 @@
          stream/c)
 
 (define-syntax gen:stream
-  (make-generic-info (quote-syntax prop:stream)
+  (make-generic-info (quote-syntax gen:stream)
+                     (quote-syntax prop:stream)
                      (quote-syntax stream-via-prop?)
                      (quote-syntax stream-get-generics)
+                     (list (quote-syntax stream-empty?)
+                           (quote-syntax stream-first)
+                           (quote-syntax stream-rest))
                      (list (quote-syntax stream-empty?)
                            (quote-syntax stream-first)
                            (quote-syntax stream-rest))))

racket/collects/racket/trait.rkt

@@ -148,45 +148,52 @@
             [else (let ([e (local-expand (car l)
                                          expand-context
                                          stop-forms)])
+                    (define (check-bindings ids)
+                      (for/list ([id (in-list ids)])
+                        (cond
+                         [(identifier? id) (syntax-local-identifier-as-binding id)]
+                         [else
+                          (syntax-case id ()
+                            [(a b)
+                             (and (identifier? #'a)
+                                  (identifier? #'b))
+                             (syntax/loc id (list (syntax-local-identifier-as-binding #'a)
+                                                  #'b))]
+                            [_
+                             (raise-syntax-error #f
+                                                 "bad syntax"
+                                                 e)])])))
                     (syntax-case e (begin define-values)
                       [(begin expr ...)
                        (loop (append
                               (syntax->list (syntax (expr ...)))
                               (cdr l)))]
-                      [(define-values (id) rhs)
+                      [(dv (id) rhs)
-                       (cons e (loop (cdr l)))]
+                       (free-identifier=? #'define-values #'dv)
+                       (cons (datum->syntax e
+                                            (list #'dv
+                                                  (list (syntax-local-identifier-as-binding #'id))
+                                                  #'rhs)
+                                            e
+                                            e)
+                             (loop (cdr l)))]
                       [(field (id expr) ...)
-                       (if (andmap (lambda (id)
+                       (with-syntax ([(id ...) (check-bindings (syntax->list #'(id ...)))])
-                                     (or (identifier? id)
+                         (cons (syntax/loc e (field (id expr) ...))
-                                         (syntax-case id ()
+                               (loop (cdr l))))]
-                                           [(a b)
+                      [(form . rest)
-                                            (and (identifier? #'a)
+                       (ormap (lambda (x) (free-identifier=? x #'form))
-                                                 (identifier? #'b))]
-                                           [_else #f])))
-                                   (syntax->list #'(id ...)))
-                           (cons e (loop (cdr l)))
-                           (raise-syntax-error
-                            #f
-                            "bad syntax"
-                            e))]
-                      [(id . rest)
-                       (ormap (lambda (x) (free-identifier=? x #'id))
                               (syntax->list
                                #'(public public-final pubment
                                          override override-final augment augment-final augride overment
                                          inherit inherit/super inherit/inner
                                          inherit-field)))
                        (let ([l2 (syntax->list #'rest)])
-                         (if (and l2
+                         (if l2
-                                  (andmap (lambda (i)
+                             (cons (with-syntax ([(id ...) (check-bindings l2)])
-                                            (or (identifier? i)
+                                     (syntax/loc e
-                                                (syntax-case i ()
+                                       (form id ...)))
-                                                  [(a b)
+                                   (loop (cdr l)))
-                                                   (and (identifier? #'a)
-                                                        (identifier? #'b))]
-                                                  [_else #f])))
-                                          l2))
-                             (cons e (loop (cdr l)))
                              (raise-syntax-error
                               #f
                               "bad syntax (inside trait)"
@@ -244,7 +251,7 @@
         (for-each (lambda (clause)
                     (syntax-case clause (define-values field)
                       [(define-values (id) rhs)
-                       (bound-identifier-mapping-put! boundmap #'id #'rhs)]
+                       (bound-identifier-mapping-put! boundmap (syntax-local-identifier-as-binding #'id) #'rhs)]
                       [(field [id expr] ...)
                        (for-each (lambda (id expr)
                                    (bound-identifier-mapping-put! boundmap (internal-name id) expr))
@@ -258,9 +265,10 @@
       (bound-identifier=? (internal-name a) (internal-name b)))
 
     (define (internal-name decl)
+      (syntax-local-identifier-as-binding
        (if (identifier? decl)
            decl
-          (stx-car decl)))
+           (stx-car decl))))
 
     (define (external-name decl)
       (if (identifier? decl)

racket/collects/racket/unit.rkt

@@ -52,7 +52,15 @@
        (check-id #'arg)
        #'(define-syntax name
            (make-set!-transformer
-            (make-signature-form (λ (arg) . val))))))
+            (make-signature-form (λ (arg ignored) . val))))))
+    ((_ (name arg intro-arg) . val)
+     (begin
+       (check-id #'name)
+       (check-id #'arg)
+       (check-id #'intro-arg)
+       #'(define-syntax name
+           (make-set!-transformer
+            (make-signature-form (λ (arg intro-arg) . val))))))
     ((_ . l)
      (let ((l (checked-syntax->list stx)))
        (unless (>= 3 (length l))
@@ -561,21 +569,23 @@
   (do-struct~/ctc stx #f))
 
 ;; build-val+macro-defs : sig -> (list syntax-object^3)
-(define-for-syntax (build-val+macro-defs sig)
+(define-for-syntax ((build-val+macro-defs intro) sig)
   (if (and (null? (cadr sig))
            (null? (caddr sig)))
       ;; No renames needed; this shortcut avoids
       ;; an explosion of renamings, especially with chains
       ;; of `open':
       (list #'(() (values)) #'() #'())
-      ;; Renames and macros needes:
+      ;; Renames and macros needed:
       (with-syntax ([(((int-ivar . ext-ivar) ...)
                       ((((int-vid . ext-vid) ...) . vbody) ...)
                       ((((int-sid . ext-sid) ...) . sbody) ...)
                       _
                       _)
                      (map-sig (lambda (x) x)
-                              (make-syntax-introducer)
+                              (let ([i (make-syntax-introducer)])
+                                (lambda (x)
+                                  (intro (i x))))
                               sig)])
         (list
          #'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
@@ -617,7 +627,7 @@
           make-rename-transformer
           (syntax->list ids))))
 
-(define-signature-form (open stx)
+(define-signature-form (open stx enclosing-intro)
   (define (build-sig-elems sig)
     (map (λ (p c)
            (if c #`(contracted [#,(car p) #,c]) (car p)))
@@ -632,7 +642,7 @@
                        ((renames
                          (((mac-name ...) mac-body) ...) 
                          (((val-name ...) val-body) ...))
-                        (build-val+macro-defs sig))
+                        ((build-val+macro-defs enclosing-intro) sig))
                        ((((e-post-id ...) . _) ...) (list-ref sig 4))
                        ((post-renames (e-post-rhs ...))
                         (build-post-val-defs sig)))
@@ -669,6 +679,13 @@
                     (map syntax-local-introduce
                          (siginfo-rtime-ids super-siginfo))))
           (values '() '() '())))
+    ;; For historical reasons, signature forms are backwards:
+    ;; they're non-hygenic by default, and they accept an optional
+    ;; introducer to mark introduced pieces --- but the end result
+    ;; is flipped around, because we apply `intro` to the whole
+    ;; signature, for the same reason as described below at
+    ;; "INTRODUCED FORMS AND MACROS".
+    (define intro (make-syntax-introducer))
     (let loop ((sig-exprs (if super-sigid
                               (cons #`(open #,super-sigid) ses)
                               ses))
@@ -702,7 +719,8 @@
                  (define signature-tag (gensym))
                  (define-syntax #,sigid
                    (make-set!-transformer
-                    (make-signature
+                    #,(intro
+                     #`(make-signature
                      (make-siginfo (list #'#,sigid #'super-name ...)
                                    (list (quote-syntax signature-tag)
                                          #'super-rtime
@@ -722,7 +740,7 @@
                                          #`(quote-syntax #,c)
                                          #'#f))
                                    all-ctcs))
-                     (quote-syntax #,sigid))))
+                     (quote-syntax #,sigid)))))
                  (define-values ()
                    (begin
                      (λ (var ...)
@@ -793,7 +811,7 @@
                        (raise-stx-err "unknown signature form" #'x))))))
               (unless (signature-form? trans)
                 (raise-stx-err "not a signature form" #'x))
-              (let ((results ((signature-form-f trans) (car sig-exprs))))
+              (let ((results ((signature-form-f trans) (car sig-exprs) intro)))
                 (unless (list? results)
                   (raise-stx-err
                    (format "expected list of results from signature form, got ~e" results)
@@ -916,6 +934,16 @@
        
        (check-unit-ie-sigs import-sigs export-sigs)
 
+       ;; INTRODUCED FORMS AND MACROS:
+       ;; We need to distinguish the original body from any
+       ;; forms that are introduced from signatures 
+       ;; (via `define-values`, etc., in a signature body).
+       ;; The `intro` mark should be added to everything except
+       ;; the introduced parts, which we implement by adding the
+       ;; mark to the introduced parts and then flipping it
+       ;; evenrywehere.
+       (define intro (make-syntax-introducer))
+       
        (with-syntax ((((dept . depr) ...)
                       (map
                        (lambda (tinfo)
@@ -923,7 +951,7 @@
                                (syntax-local-introduce (car (siginfo-rtime-ids (cdr tinfo))))))
                        dep-tagged-siginfos))
                      [((renames (mac ...) (val ...)) ...)
-                      (map build-val+macro-defs import-sigs)]
+                      (map (build-val+macro-defs intro) import-sigs)]
                      [(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)]
                      [(((int-evar . ext-evar) ...) ...) (map car export-sigs)]
                      [((((e-post-id ...) . _) ...) ...) (map (lambda (s) (list-ref s 4)) export-sigs)]
@@ -954,6 +982,7 @@
                                     (lambda (import) (length (car import)))
                                     import-sigs)])
          (values 
+          (intro
            (quasisyntax/loc (error-syntax)
             (make-unit
              'name
@@ -1005,7 +1034,7 @@
                     (unit-export ((export-key ...)
                                   (vector-immutable (λ () (check-not-unsafe-undefined (unbox eloc) 'int-evar))
                                                     ...))
-                                 ...)))))))
+                                 ...))))))))
           import-tagged-sigids
           export-tagged-sigids
           dep-tagged-sigids))))))
@@ -1034,7 +1063,7 @@
                            (free-identifier=? id (quote-syntax define-syntaxes)))))]
               [expanded-body
                (let expand-all ((defns&exprs (syntax->list #'(body ...))))
-                 ;; Also lifted from Matthew, to expand the body enough
+                 ;; Expand the body enough
                  (apply
                   append
                   (map
@@ -1059,12 +1088,16 @@
                                               'expression
                                               null)])
                             (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
-                            (list #'(define-syntaxes (id ...) rhs)))]
+                            (with-syntax ([(id ...) (map syntax-local-identifier-as-binding
+                                                    (syntax->list #'(id ...)))])
+                              (list #'(define-syntaxes (id ...) rhs))))]
                          [(define-values (id ...) rhs)
                           (andmap identifier? (syntax->list #'(id ...)))
                           (begin
                             (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f def-ctx)
-                            (list defn-or-expr))]
+                            (with-syntax ([(id ...) (map syntax-local-identifier-as-binding
+                                                         (syntax->list #'(id ...)))])
+                              (list #'(define-values (id ...) rhs))))]
                          [else (list defn-or-expr)])))
                    defns&exprs)))]
               ;; Get all the defined names, sorting out variable definitions
@@ -1102,7 +1135,7 @@
          (for-each
           (lambda (name loc ctc)
             (let ([v (bound-identifier-mapping-get defined-names-table
-                                                   name
+                                                   (syntax-local-identifier-as-binding name)
                                                    (lambda () #f))])
               (unless v
                 (raise-stx-err (format "undefined export ~a" (syntax-e name))))
@@ -1682,7 +1715,7 @@
                         (((mac-name ...) mac-body) ...) 
                         (((val-name ...) val-body) ...))
                        ...)
-                      (map build-val+macro-defs out-sigs))
+                      (map (build-val+macro-defs values) out-sigs))
                      ((out-names ...)
                       (map (lambda (info) (car (siginfo-names (cdr info))))
                            out-tags))
@@ -2024,9 +2057,7 @@
             [units (map lookup-def-unit us)]
             [import-sigs (map process-signature 
                               (syntax->list #'(import ...)))]
-            [sig-introducers (map (lambda (unit u)
+            [sig-introducers (map (lambda (unit u) values) units us)]
-                                    (make-syntax-delta-introducer u (unit-info-orig-binder unit)))
-                                  units us)]
             [sub-outs
              (map
               (lambda (outs unit sig-introducer)
@@ -2176,7 +2207,7 @@
                          sub-ins))
                        ((unit-id ...) (map 
                                        (lambda (u stx)
-                                         (quasisyntax/loc stx #,(unit-info-unit-id u)))
+                                         (quasisyntax/loc stx #,(syntax-local-introduce (unit-info-unit-id u))))
                                        units (syntax->list #'(u ...)))))
            (build-compound-unit #`((import ...)
                                    #,exports
@@ -2218,9 +2249,8 @@
 (define-for-syntax (build-invoke-unit/infer units define? exports)
   (define (imps/exps-from-unit u)      
     (let* ([ui (lookup-def-unit u)]
-           [unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))])
+           [unprocess (lambda (p)
-                        (lambda (p)
+                        #`(bind-at #,u #,(unprocess-tagged-id (cons (car p) (cdr p)))))]
-                          (unprocess-tagged-id (cons (car p) (i (cdr p))))))]
            [isigs (map unprocess (unit-info-import-sig-ids ui))]
            [esigs (map unprocess (unit-info-export-sig-ids ui))])
       (values isigs esigs)))
@@ -2308,7 +2338,8 @@
                                              (check-compound/infer-syntax
                                               #'((import isig ...)
                                                  (export esig ...)
-                                                 (link unit ...))))]) u)])
+                                                 (link unit ...))))])
+                                u)])
                (if define?
                    (syntax/loc (error-syntax)
                      (define-values/invoke-unit u

racket/collects/setup/setup-cmdline.rkt

@@ -73,6 +73,9 @@
      [("-c" "--clean") "Delete existing compiled files; implies -nxiIFDK"
       (add-flags (append '((clean #t))
                          disable-action-flags))]
+     [("--fast-clean") "Like --clean, but non-bootstrapping (can fail)"
+      (add-flags (append '((clean #t))
+                         disable-action-flags))]
      [("-n" "--no-zo") "Do not create \".zo\" files"
       (add-flags '((make-zo #f)))]
      [("--trust-zos") "Trust existing \".zo\"s (use only with prepackaged \".zo\"s)"

racket/collects/syntax/free-vars.rkt

@@ -62,7 +62,7 @@
             null)]
        [(#%top . id) null]
        [(quote q) null]
-       [(quote-syntax q) null]
+       [(quote-syntax . _) null]
        [(#%plain-lambda formals expr ...)
         (let ([ids (formals->ids #'formals)])
           (for ([id (in-list ids)])

racket/collects/syntax/kerncase.rkt

@@ -6,13 +6,9 @@
   (define-syntax kernel-syntax-case-internal
     (lambda (stx)
       (syntax-case stx ()
-	[(_ stxv phase rel? (extras ...) kernel-context clause ...)
+	[(_ stxv phase rel? (extras ...) kernel-context [pattern . rhs] ...)
-	 (quasisyntax/loc
+         (let ()
-	  stx
+           (define kernel-ids (syntax-e
-	  (syntax-case* stxv (extras ...
-                                     #,@(map
-                                         syntax-local-introduce
-                                         (syntax-e
                                (quote-syntax
                                 (quote 
                                  quote-syntax #%top
@@ -25,7 +21,35 @@
                                  module module*
                                  #%plain-module-begin 
                                  #%require #%provide #%declare 
-                                            #%variable-reference)))))
+                                 #%variable-reference))))
+           (define (replace-same-free-id pat)
+             (cond
+              [(identifier? pat)
+               (or (for/or ([kernel-id (in-list kernel-ids)])
+                     (and (free-identifier=? pat kernel-id)
+                          (datum->syntax kernel-id (syntax-e kernel-id) pat pat)))
+                   pat)]
+              [(pair? pat) (cons (replace-same-free-id (car pat))
+                                 (replace-same-free-id (cdr pat)))]
+              [(vector? pat)
+               (list->vector (map replace-same-free-id (vector->list pat)))]
+              [(box? pat)
+               (box (replace-same-free-id (unbox pat)))]
+              [(prefab-struct-key pat)
+               => (lambda (key)
+                    (apply make-prefab-struct
+                           key
+                           (map replace-same-free-id (cdr (struct->vector pat)))))]
+              [(syntax? pat)
+               (datum->syntax pat (replace-same-free-id (syntax-e pat)) pat pat)]
+              [else pat]))
+           (with-syntax ([(pattern ...)
+                          (map (lambda (pat)
+                                 (replace-same-free-id pat))
+                               (syntax->list #'(pattern ...)))])
+             (quasisyntax/loc
+                 stx
+               (syntax-case* stxv (extras ... #,@kernel-ids)
                              (let ([p phase])
                                (cond
                                 [(and #,(syntax-e #'rel?) (= p 0)) 
@@ -34,7 +58,7 @@
                                  free-transformer-identifier=?]
                                 [else (lambda (a b)
                                         (free-identifier=? a b p '#,(syntax-local-phase-level)))]))
-            clause ...))])))
+                 [pattern . rhs] ...))))])))
   
   (define-syntax kernel-syntax-case
     (lambda (stx)

racket/collects/syntax/parse/private/runtime.rkt

@@ -55,10 +55,10 @@ residual.rkt.
 
 (define-syntax-parameter fail-handler
   (lambda (stx)
-    (wrong-syntax stx "internal error: used out of context")))
+    (wrong-syntax stx "internal error: fail-handler used out of context")))
 (define-syntax-parameter cut-prompt
   (lambda (stx)
-    (wrong-syntax stx "internal error: used out of context")))
+    (wrong-syntax stx "internal error: cut-prompt used out of context")))
 
 (define-syntax-rule (wrap-user-code e)
   (with ([fail-handler #f]

racket/src/configure

@@ -5659,6 +5659,32 @@ $as_echo "$use_large_page_size" >&6; }
 $as_echo "#define MZ_USE_LARGE_PAGE_SIZE 1" >>confdefs.h
 
   fi
+fi
+
+ msg="for __builtin_popcount"
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $msg" >&5
+$as_echo_n "checking $msg... " >&6; }
+cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h.  */
+
+    int main(int argc, char **argv) {
+      unsigned int i = argc;
+      return __builtin_popcount(i);
+    }
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+  has_builtin_popcount=yes
+else
+  has_builtin_popcount=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+    conftest$ac_exeext conftest.$ac_ext
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $has_builtin_popcount" >&5
+$as_echo "$has_builtin_popcount" >&6; }
+if test "${has_builtin_popcount}" = "yes" ; then
+
+$as_echo "#define MZ_HAS_BUILTIN_POPCOUNT 1" >>confdefs.h
+
 fi
 
 if test "${enable_backtrace}" = "yes" ; then

racket/src/racket/configure.ac

@@ -1215,6 +1215,18 @@ if test "${check_page_size}" = "yes" ; then
   fi
 fi
 
+[ msg="for __builtin_popcount" ]
+AC_MSG_CHECKING($msg)
+AC_LINK_IFELSE([AC_LANG_SOURCE([
+    int main(int argc, char **argv) {
+      unsigned int i = argc;
+      return __builtin_popcount(i);
+    }])], has_builtin_popcount=yes, has_builtin_popcount=no)
+AC_MSG_RESULT($has_builtin_popcount)
+if test "${has_builtin_popcount}" = "yes" ; then
+   AC_DEFINE(MZ_HAS_BUILTIN_POPCOUNT,1,[Has __builtin_popcount])
+fi
+
 if test "${enable_backtrace}" = "yes" ; then
   GC2OPTIONS="$GC2OPTIONS -DMZ_GC_BACKTRACE"
 fi

racket/src/racket/gc2/gc2.h

@@ -382,6 +382,7 @@ GC2_EXTERN int GC_is_partial(struct NewGC *gc);
 /* 
    Reports whether the current GC is a non-full collection. */
 
+GC2_EXTERN void GC_mark_no_recur(struct NewGC *gc, int enable);
 GC2_EXTERN void GC_retract_only_mark_stack_entry(void *pf, struct NewGC *gc);
 /*
    Used for very special collaboration with GC. */

racket/src/racket/gc2/gc2_obj.h

@@ -10,7 +10,7 @@
 #endif
 typedef struct objhead {
   /* the type and size of the object */
-  uintptr_t type      : 3;
+  uintptr_t type      : 3; /* if `moved`, then non-0 means moved to gen 1/2 */
   /* these are the various mark bits we use */
   uintptr_t mark      : 1;
   uintptr_t btc_mark  : 1;

racket/src/racket/gc2/mem_account.c

@@ -387,11 +387,10 @@ static void btc_overmem_abort(NewGC *gc)
 static void propagate_accounting_marks(NewGC *gc)
 {
   void *p;
-  Mark2_Proc *mark_table = gc->mark_table;
 
   while(pop_ptr(gc, &p) && !gc->kill_propagation_loop) {
     /* GCDEBUG((DEBUGOUTF, "btc_account: popped off page %p:%p, ptr %p\n", page, page->addr, p)); */
-    propagate_marks_worker(gc, mark_table, p); 
+    propagate_marks_worker(gc, p);
   }
   if(gc->kill_propagation_loop)
     reset_pointer_stack(gc);

racket/src/racket/gc2/newgc.h

@@ -15,24 +15,14 @@ typedef struct mpage {
   void *addr;
   uintptr_t previous_size; /* for med page, place to search for available block; for jit nursery, allocated size */
   uintptr_t size; /* big page size, med page element size, or nursery starting point */
-/*
+  unsigned char generation    :2;
-  unsigned char generation    :1;
   unsigned char back_pointers :1;
-  unsigned char size_cless    :2;
+  unsigned char size_class    :2;  /* 0 => small; 1 => med; 2 => big; 3 => big marked */
   unsigned char page_type     :3; 
   unsigned char marked_on     :1;
+  unsigned char marked_from   :1;
   unsigned char has_new       :1;
   unsigned char mprotected    :1;
-  unsigned char added         :1;
-*/
-  unsigned char generation    ;
-  unsigned char back_pointers ;
-  unsigned char size_class    ; /* 0 => small; 1 => med; 2 => big; 3 => big marked */
-  unsigned char page_type     ; 
-  unsigned char marked_on     ;
-  unsigned char has_new       ;
-  unsigned char mprotected    ;
-  unsigned char added         ;
   unsigned short live_size;
 #ifdef MZ_GC_BACKTRACE
   void **backtrace;
@@ -50,6 +40,12 @@ typedef struct Gen0 {
   uintptr_t page_alloc_size;
 } Gen0;
 
+typedef struct Gen_Half {
+  struct mpage *curr_alloc_page;
+  struct mpage *pages;
+  struct mpage *old_pages;
+} Gen_Half;
+
 typedef struct MsgMemory {
   struct mpage *pages;
   struct mpage *big_pages;
@@ -128,6 +124,7 @@ typedef mpage **PageMap;
 
 typedef struct NewGC {
   Gen0 gen0;
+  Gen_Half gen_half;
   Mark2_Proc  *mark_table;   /* the table of mark procs */
   Fixup2_Proc *fixup_table;  /* the table of repair procs */
   PageMap page_maps;
@@ -144,6 +141,8 @@ typedef struct NewGC {
   Fnl *run_queue;
   Fnl *last_in_queue;
 
+  int mark_depth;
+
   struct NewGC *primoridal_gc;
   uintptr_t max_heap_size;
   uintptr_t max_pages_in_heap;
@@ -168,6 +167,7 @@ typedef struct NewGC {
   unsigned char no_further_modifications     :1;
   unsigned char gc_full                      :1; /* a flag saying if this is a full/major collection */
   unsigned char running_finalizers           :1;
+  unsigned char back_pointers                :1;
 
   /* blame the child */
   unsigned int doing_memory_accounting        :1;
@@ -188,9 +188,14 @@ typedef struct NewGC {
 
   /* These collect information about memory usage, for use in GC_dump. */
   uintptr_t peak_memory_use;
+  uintptr_t peak_pre_memory_use;
   uintptr_t num_minor_collects;
   uintptr_t num_major_collects;
 
+  uintptr_t minor_old_traversed;
+  uintptr_t minor_old_skipped;
+  uintptr_t modified_unprotects;
+  
   /* THREAD_LOCAL variables that need to be saved off */
   MarkSegment  *saved_mark_stack;
   void         *saved_GC_variable_stack;

racket/src/racket/gc2/vm.c

@@ -28,6 +28,9 @@ enum {
 
 #ifdef USE_BLOCK_CACHE
 # define USE_ALLOC_CACHE
+# define QUEUED_MPROTECT_IS_PROMISCUOUS 1
+#else
+# define QUEUED_MPROTECT_IS_PROMISCUOUS 0
 #endif
 
 /* Either USE_ALLOC_CACHE or OS_ALLOCATOR_NEEDS_ALIGNMENT must be

racket/src/racket/gc2/weak.c

@@ -73,9 +73,10 @@ static int fixup_weak_array(void *p, struct NewGC *gc)
 
   data = a->data;
   for (i = a->count; i--; ) {
-    if (data[i])
+    if (data[i]) {
       gcFIXUP2(data[i], gc);
     }
+  }
 
   return gcBYTES_TO_WORDS(sizeof(GC_Weak_Array) 
 			  + ((a->count - 1) * sizeof(void *)));

racket/src/racket/gc2/xform.rkt

@@ -61,7 +61,7 @@
 
       ;; Setup an xform-collects tree for running xform.
       ;; Delete existing xform-collects tree if it's for an old version
-      (begin
+      (let retry ()
         (parameterize ([current-directory rel-dir])
           (unless (and (file-exists? "xform-collects/version.rkt")
                        (equal? (version)
@@ -88,7 +88,8 @@
                                                (sleep 0.1)
                                                (if (file-exists? lock-file)
                                                    (loop)
-                                                   (printf " ... continuing\n"))))
+                                                   (printf " ... continuing\n")))
+                                             (retry))
                                            (raise exn)))))])
                     (dynamic-wind
                         (lambda ()

racket/src/racket/include/mzwin.def

@@ -251,6 +251,7 @@ EXPORTS
  scheme_clone_hash_table
  scheme_clear_hash_table
  scheme_make_hash_tree
+ scheme_make_hash_tree_set
  scheme_hash_tree_set
  scheme_hash_tree_get
  scheme_eq_hash_tree_get

racket/src/racket/include/mzwin3m.def

@@ -266,6 +266,7 @@ EXPORTS
  scheme_clone_hash_table
  scheme_clear_hash_table
  scheme_make_hash_tree
+ scheme_make_hash_tree_set
  scheme_hash_tree_set
  scheme_hash_tree_get
  scheme_eq_hash_tree_get

racket/src/racket/include/racket.exp

@@ -267,6 +267,7 @@ scheme_is_hash_table_eqv
 scheme_clone_hash_table
 scheme_clear_hash_table
 scheme_make_hash_tree
+scheme_make_hash_tree_set
 scheme_hash_tree_set
 scheme_hash_tree_get
 scheme_eq_hash_tree_get

racket/src/racket/include/racket3m.exp

@@ -273,6 +273,7 @@ scheme_is_hash_table_eqv
 scheme_clone_hash_table
 scheme_clear_hash_table
 scheme_make_hash_tree
+scheme_make_hash_tree_set
 scheme_hash_tree_set
 scheme_hash_tree_get
 scheme_eq_hash_tree_get

racket/src/racket/include/scheme.h

@@ -524,7 +524,7 @@ typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_d
 
 #define SCHEME_BUCKTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_bucket_table_type)
 #define SCHEME_HASHTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_table_type)
-#define SCHEME_HASHTRP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_tree_type)
+#define SCHEME_HASHTRP(obj) ((SCHEME_TYPE(obj) >= scheme_hash_tree_type) && (SCHEME_TYPE(obj) <= scheme_hash_tree_indirection_type))
 
 #define SCHEME_VECTORP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_vector_type)
 #define SCHEME_MUTABLE_VECTORP(obj)  (SCHEME_VECTORP(obj) && SCHEME_MUTABLEP(obj))
@@ -906,7 +906,7 @@ typedef struct {
 
 typedef struct Scheme_Hash_Table
 {
-  Scheme_Inclhash_Object iso; /* 0x1 flag => marshal as #t (hack for stxobj bytecode) */
+  Scheme_Inclhash_Object iso; /* 0x1 flag => print as opaque (e.g., exports table); 0x2 => misc (e.g., top-level multi_scopes) */
   intptr_t size; /* power of 2 */
   intptr_t count;
   Scheme_Object **keys;
@@ -943,7 +943,6 @@ typedef struct Scheme_Bucket_Table
 enum {
   SCHEME_hash_string,
   SCHEME_hash_ptr,
-  SCHEME_hash_bound_id,
   SCHEME_hash_weak_ptr,
   SCHEME_hash_late_weak_ptr
 };
@@ -1169,7 +1168,8 @@ typedef struct Scheme_Thread {
   struct Scheme_Overflow *overflow;
 
   struct Scheme_Comp_Env *current_local_env;
-  Scheme_Object *current_local_mark;
+  Scheme_Object *current_local_scope;
+  Scheme_Object *current_local_use_scope;
   Scheme_Object *current_local_name;
   Scheme_Object *current_local_modidx;
   Scheme_Env *current_local_menv;

racket/src/racket/include/schthread.h

@@ -89,6 +89,7 @@ MZ_EXTERN void scheme_init_os_thread(void);
 #define STACK_COPY_CACHE_SIZE 10
 #define BIGNUM_CACHE_SIZE 16
 #define STACK_CACHE_SIZE 32
+#define NUM_MORE_CONSTANT_STXES 24
 
 /* This structure must be 4 words: */
 typedef struct {
@@ -230,15 +231,13 @@ typedef struct Thread_Local_Variables {
   void *stack_copy_cache_[STACK_COPY_CACHE_SIZE];
   intptr_t stack_copy_size_cache_[STACK_COPY_CACHE_SIZE];
   int scc_pos_;
-  struct Scheme_Object *nominal_ipair_cache_;
+  mzlonglong scope_counter_;
-  struct Scheme_Object *mark_id_;
-  struct Scheme_Object *current_rib_timestamp_;
-  struct Scheme_Hash_Table *quick_hash_table_;
   struct Scheme_Object *last_phase_shift_;
-  struct Scheme_Object *unsealed_dependencies_;
+  struct Scheme_Object *nominal_ipair_cache_;
-  struct Scheme_Hash_Table *id_marks_ht_;
+  struct Scheme_Bucket_Table *taint_intern_table_;
-  struct Scheme_Hash_Table *than_id_marks_ht_;
+  struct Binding_Cache_Entry *binding_cache_table_;
-  struct Scheme_Bucket_Table *interned_skip_ribs_;
+  intptr_t binding_cache_pos_;
+  intptr_t binding_cache_len_;
   struct Scheme_Thread *scheme_current_thread_;
   struct Scheme_Thread *scheme_main_thread_;
   struct Scheme_Thread *scheme_first_thread_;
@@ -300,8 +299,6 @@ typedef struct Thread_Local_Variables {
   struct Scheme_Env *initial_modules_env_;
   int num_initial_modules_;
   struct Scheme_Object **initial_modules_;
-  struct Scheme_Object *initial_renames_;
-  struct Scheme_Bucket_Table *initial_toplevel_;
   int generate_lifts_count_;
   int special_is_ok_;
   int scheme_force_port_closed_;
@@ -361,7 +358,6 @@ typedef struct Thread_Local_Variables {
   struct Scheme_Hash_Table *loaded_extensions_;
   struct Scheme_Hash_Table *fullpath_loaded_extensions_;
   Scheme_Sleep_Proc scheme_place_sleep_;
-  struct Scheme_Bucket_Table *taint_intern_table_;
   struct GHBN_Thread_Data *ghbn_thread_data_;
   Scheme_On_Atomic_Timeout_Proc on_atomic_timeout_;
   int atomic_timeout_auto_suspend_;
@@ -370,6 +366,17 @@ typedef struct Thread_Local_Variables {
   struct Scheme_Object *configuration_callback_cache_[2];
   struct FFI_Orig_Place_Call *cached_orig_place_todo_;
   struct Scheme_Hash_Table *ffi_lock_ht_;
+  struct Scheme_Object *scheme_sys_wraps0_;
+  struct Scheme_Object *scheme_sys_wraps1_;
+  struct Scheme_Object *scheme_module_stx_;
+  struct Scheme_Object *scheme_modulestar_stx_;
+  struct Scheme_Object *scheme_module_begin_stx_;
+  struct Scheme_Object *scheme_begin_stx_;
+  struct Scheme_Object *scheme_define_values_stx_;
+  struct Scheme_Object *scheme_define_syntaxes_stx_;
+  struct Scheme_Object *scheme_top_stx_;
+  struct Scheme_Object *scheme_begin_for_syntax_stx_;
+  struct Scheme_Object *more_constant_stxes_[NUM_MORE_CONSTANT_STXES];
 } Thread_Local_Variables;
 
 #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS)
@@ -618,14 +625,12 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define stack_copy_size_cache XOA (scheme_get_thread_local_variables()->stack_copy_size_cache_)
 #define scc_pos XOA (scheme_get_thread_local_variables()->scc_pos_)
 #define nominal_ipair_cache XOA (scheme_get_thread_local_variables()->nominal_ipair_cache_)
-#define mark_id XOA (scheme_get_thread_local_variables()->mark_id_)
+#define scope_counter XOA (scheme_get_thread_local_variables()->scope_counter_)
-#define current_rib_timestamp XOA (scheme_get_thread_local_variables()->current_rib_timestamp_)
-#define quick_hash_table XOA (scheme_get_thread_local_variables()->quick_hash_table_)
 #define last_phase_shift XOA (scheme_get_thread_local_variables()->last_phase_shift_)
-#define unsealed_dependencies XOA (scheme_get_thread_local_variables()->unsealed_dependencies_)
+#define taint_intern_table XOA (scheme_get_thread_local_variables()->taint_intern_table_)
-#define id_marks_ht XOA (scheme_get_thread_local_variables()->id_marks_ht_)
+#define binding_cache_table XOA (scheme_get_thread_local_variables()->binding_cache_table_)
-#define than_id_marks_ht XOA (scheme_get_thread_local_variables()->than_id_marks_ht_)
+#define binding_cache_pos XOA (scheme_get_thread_local_variables()->binding_cache_pos_)
-#define interned_skip_ribs XOA (scheme_get_thread_local_variables()->interned_skip_ribs_)
+#define binding_cache_len XOA (scheme_get_thread_local_variables()->binding_cache_len_)
 #define scheme_current_thread XOA (scheme_get_thread_local_variables()->scheme_current_thread_)
 #define scheme_main_thread XOA (scheme_get_thread_local_variables()->scheme_main_thread_)
 #define scheme_first_thread XOA (scheme_get_thread_local_variables()->scheme_first_thread_)
@@ -687,8 +692,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define initial_modules_env XOA (scheme_get_thread_local_variables()->initial_modules_env_)
 #define num_initial_modules XOA (scheme_get_thread_local_variables()->num_initial_modules_)
 #define initial_modules XOA (scheme_get_thread_local_variables()->initial_modules_)
-#define initial_renames XOA (scheme_get_thread_local_variables()->initial_renames_)
-#define initial_toplevel XOA (scheme_get_thread_local_variables()->initial_toplevel_)
 #define generate_lifts_count XOA (scheme_get_thread_local_variables()->generate_lifts_count_)
 #define special_is_ok XOA (scheme_get_thread_local_variables()->special_is_ok_)
 #define scheme_force_port_closed XOA (scheme_get_thread_local_variables()->scheme_force_port_closed_)
@@ -748,7 +751,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define loaded_extensions XOA (scheme_get_thread_local_variables()->loaded_extensions_)
 #define fullpath_loaded_extensions XOA (scheme_get_thread_local_variables()->fullpath_loaded_extensions_)
 #define scheme_place_sleep XOA (scheme_get_thread_local_variables()->scheme_place_sleep_)
-#define taint_intern_table XOA (scheme_get_thread_local_variables()->taint_intern_table_)
 #define ghbn_thread_data XOA (scheme_get_thread_local_variables()->ghbn_thread_data_)
 #define on_atomic_timeout XOA (scheme_get_thread_local_variables()->on_atomic_timeout_)
 #define atomic_timeout_auto_suspend XOA (scheme_get_thread_local_variables()->atomic_timeout_auto_suspend_)
@@ -757,6 +759,17 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define configuration_callback_cache XOA (scheme_get_thread_local_variables()->configuration_callback_cache_)
 #define cached_orig_place_todo XOA (scheme_get_thread_local_variables()->cached_orig_place_todo_)
 #define ffi_lock_ht XOA (scheme_get_thread_local_variables()->ffi_lock_ht_)
+#define scheme_sys_wraps0 XOA (scheme_get_thread_local_variables()->scheme_sys_wraps0_)
+#define scheme_sys_wraps1 XOA (scheme_get_thread_local_variables()->scheme_sys_wraps1_)
+#define scheme_module_stx XOA (scheme_get_thread_local_variables()->scheme_module_stx_)
+#define scheme_modulestar_stx XOA (scheme_get_thread_local_variables()->scheme_modulestar_stx_)
+#define scheme_module_begin_stx XOA (scheme_get_thread_local_variables()->scheme_module_begin_stx_)
+#define scheme_begin_stx XOA (scheme_get_thread_local_variables()->scheme_begin_stx_)
+#define scheme_define_values_stx XOA (scheme_get_thread_local_variables()->scheme_define_values_stx_)
+#define scheme_define_syntaxes_stx XOA (scheme_get_thread_local_variables()->scheme_define_syntaxes_stx_)
+#define scheme_top_stx XOA (scheme_get_thread_local_variables()->scheme_top_stx_)
+#define scheme_begin_for_syntax_stx XOA (scheme_get_thread_local_variables()->scheme_begin_for_syntax_stx_)
+#define more_constant_stxes XOA (scheme_get_thread_local_variables()->more_constant_stxes_)
 
 /* **************************************** */
 

racket/src/racket/mzconfig.h.in

@@ -71,6 +71,9 @@ typedef unsigned long uintptr_t;
 /* To enable 2^16 page size instead of 2^14: */
 #undef MZ_USE_LARGE_PAGE_SIZE
 
+/* When __builtin_popcount() is available: */
+#undef MZ_HAS_BUILTIN_POPCOUNT
+
 /* Enable futures: */
 #undef MZ_USE_FUTURES
 

racket/src/racket/src/Makefile.in

@@ -211,7 +211,7 @@ future.@LTO@: $(srcdir)/future.c
 gmp.@LTO@: $(srcdir)/gmp/gmp.c $(srcdir)/gmp/gmplonglong.h \
            $(srcdir)/../include/schthread.h $(srcdir)/../sconfig.h
 	$(CC) $(ALL_CFLAGS) -c $(srcdir)/gmp/gmp.c -o gmp.@LTO@
-hash.@LTO@: $(srcdir)/hash.c
+hash.@LTO@: $(srcdir)/hash.c $(srcdir)/hamt_subset.inc
 	$(CC) $(ALL_CFLAGS) -c $(srcdir)/hash.c -o hash.@LTO@
 jit.@LTO@: $(srcdir)/jit.c
 	$(CC) $(ALL_CFLAGS) -c $(srcdir)/jit.c -o jit.@LTO@

racket/src/racket/src/bool.c

@@ -60,6 +60,7 @@ typedef struct Equal_Info {
   Scheme_Object *next, *next_next;
   Scheme_Object *insp;
   intptr_t for_chaperone; /* 3 => for impersonator */
+  intptr_t eq_for_modidx;
 } Equal_Info;
 
 static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
@@ -160,19 +161,25 @@ eqv_prim (int argc, Scheme_Object *argv[])
   return (scheme_eqv(argv[0], argv[1]) ? scheme_true : scheme_false);
 }
 
+XFORM_NONGCING static void init_equal_info(Equal_Info *eql)
+{
+  eql->depth = 1;
+  eql->car_depth = 1;
+  eql->ht = NULL;
+  eql->recur = NULL;
+  eql->next = NULL;
+  eql->next_next = NULL;
+  eql->insp = NULL;
+  eql->for_chaperone = 0;
+  eql->eq_for_modidx = 0;
+}
+
 static Scheme_Object *
 equal_prim (int argc, Scheme_Object *argv[])
 {
   Equal_Info eql;
 
-  eql.depth = 1;
+  init_equal_info(&eql);
-  eql.car_depth = 1;
-  eql.ht = NULL;
-  eql.recur = NULL;
-  eql.next = NULL;
-  eql.next_next = NULL;
-  eql.insp = NULL;
-  eql.for_chaperone = 0;
 
   return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
 }
@@ -184,14 +191,8 @@ equalish_prim (int argc, Scheme_Object *argv[])
 
   scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv);
 
-  eql.depth = 1;
+  init_equal_info(&eql);
-  eql.car_depth = 1;
-  eql.ht = NULL;
-  eql.recur = NULL;
-  eql.next = NULL;
   eql.next_next = argv[2];
-  eql.insp = NULL;
-  eql.for_chaperone = 0;
 
   return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
 }
@@ -317,6 +318,11 @@ XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
       }
     case scheme_char_type:
       return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
+    case scheme_symbol_type:
+    case scheme_keyword_type:
+    case scheme_scope_type:
+      /* `eqv?` requires `eq?` */
+      return 0;
     default:
       return -1;
     }
@@ -418,14 +424,7 @@ int is_slow_equal (Scheme_Object *obj1, Scheme_Object *obj2)
 {
   Equal_Info eql;
 
-  eql.depth = 1;
+  init_equal_info(&eql);
-  eql.car_depth = 1;
-  eql.ht = NULL;
-  eql.recur = NULL;
-  eql.next_next = NULL;
-  eql.next = NULL;
-  eql.insp = NULL;
-  eql.for_chaperone = 0;
 
   return is_equal(obj1, obj2, &eql);
 }
@@ -441,6 +440,16 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
   return is_slow_equal(obj1, obj2);
 }
 
+int scheme_equal_modix_eq (Scheme_Object *obj1, Scheme_Object *obj2)
+{
+  Equal_Info eql;
+
+  init_equal_info(&eql);
+  eql.eq_for_modidx = 1;
+
+  return is_equal(obj1, obj2, &eql);
+}
+
 static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht)
 {
   Scheme_Object *v, *prev = obj1, *prev_prev = obj1;
@@ -581,8 +590,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
       /* for immutable hashes, it's ok for the two objects to not be eq,
          as long as the interpositions are the same and the underlying
          values are `{impersonator,chaperone}-of?`: */
-      if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj1)->val), scheme_hash_tree_type)
+      if (SCHEME_HASHTRP(((Scheme_Chaperone *)obj1)->val)
-          && SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj2)->val), scheme_hash_tree_type)
+          && SCHEME_HASHTRP(((Scheme_Chaperone *)obj2)->val)
           /* eq redirects means redirects were propagated: */
           && SAME_OBJ(((Scheme_Chaperone *)obj1)->redirects,
                       ((Scheme_Chaperone *)obj2)->redirects))
@@ -600,10 +609,16 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
       if (SCHEME_CHAPERONEP(obj1)) {
         obj1 = ((Scheme_Chaperone *)obj1)->val;
         goto top_after_next;
+      } else if (t1 == scheme_hash_tree_indirection_type) {
+        obj1 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj1);
+        goto top_after_next;
       }
       if (SCHEME_CHAPERONEP(obj2)) {
         obj2 = ((Scheme_Chaperone *)obj2)->val;
         goto top_after_next;
+      } else if (t2 == scheme_hash_tree_indirection_type) {
+        obj2 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj2);
+        goto top_after_next;
       }
     }
     return 0;
@@ -810,6 +825,9 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
                                            eql);
       }
     case scheme_hash_tree_type:
+    case scheme_eq_hash_tree_type:
+    case scheme_eqv_hash_tree_type:
+    case scheme_hash_tree_indirection_type:
       {
 #   include "mzeqchk.inc"
         if (union_check(obj1, obj2, eql))
@@ -840,6 +858,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
       }
     case scheme_module_index_type:
       {
+        if (!eql->eq_for_modidx) {
           Scheme_Modidx *midx1, *midx2;
 #   include "mzeqchk.inc"
           midx1 = (Scheme_Modidx *)obj1;
@@ -850,6 +869,18 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
             goto top;
           } else
             return 0;
+        } else
+          return 0;
+      }
+    case scheme_scope_table_type:
+      {
+        Scheme_Scope_Table *mt1 = (Scheme_Scope_Table *)obj1;
+        Scheme_Scope_Table *mt2 = (Scheme_Scope_Table *)obj2;
+        if (!is_equal((Scheme_Object *)mt1->simple_scopes, (Scheme_Object *)mt2->simple_scopes, eql))
+          return 0;
+        obj1 = mt1->multi_scopes;
+        obj2 = mt2->multi_scopes;
+        goto top;
       }
     default:
       if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
@@ -968,13 +999,7 @@ int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
 {
   Equal_Info eql;
 
-  eql.depth = 1;
+  init_equal_info(&eql);
-  eql.car_depth = 1;
-  eql.ht = NULL;
-  eql.recur = NULL;
-  eql.next = NULL;
-  eql.next_next = NULL;
-  eql.insp = NULL;
   eql.for_chaperone = 1;
 
   return is_equal(obj1, obj2, &eql);
@@ -984,13 +1009,7 @@ int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2)
 {
   Equal_Info eql;
 
-  eql.depth = 1;
+  init_equal_info(&eql);
-  eql.car_depth = 1;
-  eql.ht = NULL;
-  eql.recur = NULL;
-  eql.next = NULL;
-  eql.next_next = NULL;
-  eql.insp = NULL;
   eql.for_chaperone = 3;
 
   return is_equal(obj1, obj2, &eql);

racket/src/racket/src/env.c

@@ -47,13 +47,17 @@ THREAD_LOCAL_DECL(int scheme_starting_up);
 
 /* globals READ-ONLY SHARED */
 Scheme_Object *scheme_varref_const_p_proc;
-READ_ONLY static Scheme_Object *kernel_symbol;
 READ_ONLY static Scheme_Env    *kernel_env;
 READ_ONLY static Scheme_Env    *unsafe_env;
 READ_ONLY static Scheme_Env    *flfxnum_env;
 READ_ONLY static Scheme_Env    *extfl_env;
 READ_ONLY static Scheme_Env    *futures_env;
 
+READ_ONLY static Scheme_Object *kernel_symbol;
+READ_ONLY static Scheme_Object *flip_symbol;
+READ_ONLY static Scheme_Object *add_symbol;
+READ_ONLY static Scheme_Object *remove_symbol;
+
 THREAD_LOCAL_DECL(static int intdef_counter);
 
 static int builtin_ref_counter;
@@ -96,10 +100,10 @@ static Scheme_Object *local_context(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[]);
 static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]);
+static Scheme_Object *intdef_context_intro(int argc, Scheme_Object *argv[]);
 static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]);
-static Scheme_Object *local_module_introduce(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_module_exports(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_module_definitions(int argc, Scheme_Object *argv[]);
@@ -114,6 +118,7 @@ static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]);
 static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
 static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]);
+static Scheme_Object *local_binding_id(int argc, Scheme_Object *argv[]);
 static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);
 static Scheme_Object *set_transformer_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *set_transformer_proc(int argc, Scheme_Object *argv[]);
@@ -517,6 +522,10 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr
     scheme_current_thread->name = sym;
   }
 
+  scheme_init_stx_places(initial_main_os_thread);
+
+  scheme_init_syntax_bindings();
+
   scheme_init_module_resolver();
 
 #ifdef TIME_STARTUP_PROCESS
@@ -536,7 +545,6 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr
   scheme_init_eval_places();
   scheme_init_compile_places();
   scheme_init_regexp_places();
-  scheme_init_stx_places(initial_main_os_thread);
   scheme_init_sema_places();
   scheme_init_gmp_places();
   scheme_init_kqueue();
@@ -767,13 +775,15 @@ static void make_kernel_env(void)
   GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env);
-  GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 1, env);
+  GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 2, env);
   GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("internal-definition-context-introduce", intdef_context_intro, 2, 3, env);
   GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env);
-  GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 1, env);
+  GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 2, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env);
+  GLOBAL_PRIM_W_ARITY("syntax-local-identifier-as-binding", local_binding_id, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("syntax-local-make-delta-introducer", local_make_delta_introduce, 1, 1, env);
 
   GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env);
@@ -786,7 +796,7 @@ static void make_kernel_env(void)
   GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env);
 
-  GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 2, env);
+  GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env);
   GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env);
 
@@ -804,6 +814,13 @@ static void make_kernel_env(void)
   REGISTER_SO(kernel_symbol);
   kernel_symbol = scheme_intern_symbol("#%kernel");
 
+  REGISTER_SO(flip_symbol);
+  REGISTER_SO(add_symbol);
+  REGISTER_SO(remove_symbol);
+  flip_symbol = scheme_intern_symbol("flip");
+  add_symbol = scheme_intern_symbol("add");
+  remove_symbol = scheme_intern_symbol("remove");
+
   MARK_START_TIME();
 
   scheme_finish_kernel(env);
@@ -856,18 +873,30 @@ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client
 /*                        namespace constructors                          */
 /*========================================================================*/
 
-void scheme_prepare_env_renames(Scheme_Env *env, int kind)
+void scheme_prepare_env_stx_context(Scheme_Env *env)
 {
-  if (!env->rename_set) {
+  Scheme_Object *mc, *shift, *insp;
-    Scheme_Object *rns, *insp;
+
+  if (env->stx_context) return;
 
   insp = env->access_insp;
   if (!insp)
     insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
 
-    rns = scheme_make_module_rename_set(kind, NULL, insp);
+  if (env->module) {
-    env->rename_set = rns;
+    shift = scheme_make_shift(scheme_make_integer(0),
-  }
+                              NULL, NULL,
+                              env->module_registry->exports,
+                              (env->module->prefix
+                               ? env->module->prefix->src_insp_desc
+                               : env->module->insp),
+                              insp);
+
+    mc = scheme_make_module_context(insp, shift, env->module->modname);
+  } else
+    mc = scheme_make_module_context(insp, NULL, scheme_false);
+
+  env->stx_context = mc;
 }
 
 Scheme_Env *scheme_make_empty_env(void)
@@ -900,6 +929,7 @@ Scheme_Env *make_empty_inited_env(int toplevel_size)
   hash_table = scheme_make_hash_table(SCHEME_hash_ptr);
   reg->loaded = hash_table;
   hash_table = scheme_make_hash_table(SCHEME_hash_ptr);
+  MZ_OPT_HASH_KEY(&(hash_table->iso)) |= 0x1; /* print (for debugging) as opqaue */
   reg->exports = hash_table;
 
   env->label_env = NULL;
@@ -946,6 +976,11 @@ static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size)
   return env;
 }
 
+Scheme_Env *scheme_make_env_like(Scheme_Env *base)
+{
+  return make_env(base, 10);
+}
+
 Scheme_Env *
 scheme_new_module_env(Scheme_Env *env, Scheme_Module *m,
                       int new_exp_module_tree, int new_pre_registry)
@@ -1000,7 +1035,7 @@ void scheme_prepare_exp_env(Scheme_Env *env)
 {
   if (!env->exp_env) {
     Scheme_Env *eenv;
-    Scheme_Object *modchain;
+    Scheme_Object *modchain, *mc;
 
     scheme_prepare_label_env(env);
 
@@ -1031,8 +1066,9 @@ void scheme_prepare_exp_env(Scheme_Env *env)
     eenv->label_env = env->label_env;
     eenv->instance_env = env->instance_env;
 
-    scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
+    scheme_prepare_env_stx_context(env);
-    eenv->rename_set = env->rename_set;
+    mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv));
+    eenv->stx_context = mc;
 
     if (env->disallow_unbound)
       eenv->disallow_unbound = env->disallow_unbound;
@@ -1043,7 +1079,7 @@ void scheme_prepare_template_env(Scheme_Env *env)
 {
   if (!env->template_env) {
     Scheme_Env *eenv;
-    Scheme_Object *modchain;
+    Scheme_Object *modchain, *mc;
 
     scheme_prepare_label_env(env);
 
@@ -1069,8 +1105,9 @@ void scheme_prepare_template_env(Scheme_Env *env)
     }
     eenv->modchain = modchain;
 
-    scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
+    scheme_prepare_env_stx_context(env);
-    eenv->rename_set = env->rename_set;
+    mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv));
+    eenv->stx_context = mc;
 
     env->template_env = eenv;
     eenv->exp_env = env;       
@@ -1115,6 +1152,39 @@ void scheme_prepare_label_env(Scheme_Env *env)
   }
 }
 
+Scheme_Object *scheme_env_phase(Scheme_Env *env)
+{
+  if (env == env->label_env)
+    return scheme_false;
+  else
+    return scheme_make_integer(env->phase);
+}
+
+Scheme_Env *scheme_find_env_at_phase(Scheme_Env *env, Scheme_Object *phase)
+{
+  if (SCHEME_FALSEP(phase)) {
+    scheme_prepare_label_env(env);
+    env = env->label_env;
+  } else {
+    intptr_t ph = SCHEME_INT_VAL(phase) - env->phase;
+    intptr_t j;
+    
+    if (ph > 0) {
+      for (j = 0; j < ph; j++) {
+        scheme_prepare_exp_env(env);
+        env = env->exp_env;
+      }
+    } else if (ph < 0) {
+      for (j = 0; j > ph; j--) {
+        scheme_prepare_template_env(env);
+        env = env->template_env;
+      }
+    }
+  }
+
+  return env;
+}
+
 Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Object *modchain, int clone_phase)
 {
   /* New env should have the same syntax and globals table, but it lives in
@@ -1385,35 +1455,102 @@ scheme_add_global_keyword_symbol(Scheme_Object *name, Scheme_Object *obj,
   scheme_do_add_global_symbol(env, name, obj, 0, 0);
 }
 
-void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo)
+static Scheme_Object *vector_to_ht(Scheme_Object *vec, int kind)
 {
-  Scheme_Object *rn;
+  Scheme_Hash_Tree *ht;
+  Scheme_Object *key, *val;
+  intptr_t i;
 
-  if (!env) return;
+  ht = scheme_make_hash_tree(kind);
 
-  if (env->rename_set) {
+  i = SCHEME_VEC_SIZE(vec);
-    rn = scheme_get_module_rename_from_set(env->rename_set,
+  if (i & 1) return (Scheme_Object *)ht; /* defend against bad bytecode */
-                                           scheme_make_integer(env->phase),
+  
-                                           0);
+  while (i -= 2) {
-    if (rn) {
+    key = SCHEME_VEC_ELS(vec)[i];
-      scheme_remove_module_rename(rn, n);
+    val = SCHEME_VEC_ELS(vec)[i+1];
-      if (env->module) {
+
-        scheme_extend_module_rename(rn,
+    /* defend against bad bytecode here, too: */
-                                    env->module->self_modidx,
+    if (kind) {
-                                    n, n,
+      if (!SCHEME_INTP(key)
-                                    env->module->self_modidx,
+          || !SCHEME_VECTORP(val))
-                                    n,
+        key = NULL;
-                                    env->mod_phase,
+    } else {
-                                    NULL,
+      if (!SCHEME_SYMBOLP(key)
-                                    NULL,
+          || ((!SCHEME_STXP(val)
-                                    0);
+               || !SCHEME_SYMBOLP(SCHEME_STX_VAL(val)))
+              && !SAME_OBJ(val, scheme_true)))
+        key = NULL;
+    }
+    
+    if (key) {
+      if (kind)
+        val = vector_to_ht(val, 0);
+      else if (!SAME_OBJ(val, scheme_true))
+        val = scheme_stx_force_delayed(val);
+
+      ht = scheme_hash_tree_set(ht, key, val);
     }
   }
+
+  return (Scheme_Object *)ht;
+}
+
+void scheme_binding_names_from_module(Scheme_Env *menv)
+{
+  Scheme_Module *m;
+  Scheme_Object *binding_names;
+  
+  if (menv->binding_names
+      || !menv->module
+      || menv->binding_names_need_shift)
+    return;
+
+  m = menv->module;
+
+  if (menv->phase == 0) {
+    binding_names = m->binding_names;
+    if (binding_names && SCHEME_VECTORP(binding_names)) {
+      binding_names = vector_to_ht(binding_names, 0);
+      m->binding_names = binding_names;
+    }
+  } else if (menv->phase == 1) {
+    binding_names = m->et_binding_names;
+    if (binding_names && SCHEME_VECTORP(binding_names)) {
+      binding_names = vector_to_ht(binding_names, 0);
+      m->et_binding_names = binding_names;
+    }
+  } else if (m->other_binding_names) {
+    binding_names = m->other_binding_names;
+    if (binding_names && SCHEME_VECTORP(binding_names)) {
+      binding_names = vector_to_ht(binding_names, 1);
+      m->other_binding_names = binding_names;
+    }
+    if (SCHEME_HASHTP(binding_names))
+      binding_names = scheme_hash_get((Scheme_Hash_Table *)binding_names, scheme_env_phase(menv));
+    else
+      binding_names = scheme_hash_tree_get((Scheme_Hash_Tree *)binding_names, scheme_env_phase(menv));
   } else
-    rn = NULL;
+    binding_names = NULL;
   
-  if (stxtoo) {
+  menv->binding_names = binding_names;
-    if (!env->module || rn) {
+  menv->binding_names_need_shift = 1;
+}
+
+void scheme_shadow(Scheme_Env *env, Scheme_Object *n, Scheme_Object *val, int as_var)
+{
+  Scheme_Object *id;
+
+  if (!as_var)
+    val = SCHEME_PTR_VAL(val); /* remove "is a compile-time binding" wrapper */
+
+  if (!env
+      || (env->module
+          && !env->interactive_bindings
+          && !scheme_is_binding_rename_transformer(val)))
+    return;
+
+  if (as_var) {
     if (!env->shadowed_syntax) {
       Scheme_Hash_Table *ht;
       ht = scheme_make_hash_table(SCHEME_hash_ptr);
@@ -1421,27 +1558,47 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo)
     }
       
     scheme_hash_set(env->shadowed_syntax, n, scheme_true);
-    }
   } else {
     if (env->shadowed_syntax)
       scheme_hash_set(env->shadowed_syntax, n, NULL);
+  }
 
-    if (rn) {
+  scheme_binding_names_from_module(env);
-      /* If the syntax binding is a rename transformer, need to install 
+
-         a mapping. */
+  if (env->binding_names) {
-      Scheme_Object *v;
+    if (SCHEME_HASHTP(env->binding_names))
-      v = scheme_lookup_in_table(env->syntax, (const char *)n);
+      id = scheme_eq_hash_get((Scheme_Hash_Table *)env->binding_names, n);
-      if (v) {
+    else
-        v = SCHEME_PTR_VAL(v);
+      id = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)env->binding_names, n);
-        if (scheme_is_binding_rename_transformer(v)) {
+    if (id && !SCHEME_STXP(id))
-          scheme_install_free_id_rename(n, 
+      id = NULL;
-                                        scheme_rename_transformer_id(v), 
+  } else
-                                        rn, 
+    id = NULL;
-                                        scheme_make_integer(env->phase));
+
-        }
+  if (!id)
-      }
+    return;
-    }
+
+  if (env->binding_names_need_shift) {
+    id = scheme_stx_shift(id, scheme_make_integer(env->phase - env->mod_phase),
+                          env->module->self_modidx, env->link_midx,
+                          env->module_registry->exports,
+                          env->module->prefix->src_insp_desc, env->access_insp);
   }
+
+  scheme_add_module_binding(id, scheme_env_phase(env),
+                            (env->module
+                             ? env->module->self_modidx
+                             : scheme_false),
+                            ((env->module && env->module->prefix)
+                             ? env->module->prefix->src_insp_desc
+                             : env->guard_insp),
+                            n,
+                            scheme_env_phase(env));
+
+  /* If the binding is a rename transformer, also install 
+     a mapping */
+  if (scheme_is_binding_rename_transformer(val))
+    scheme_add_binding_copy(id, scheme_rename_transformer_id(val), scheme_env_phase(env));
 }
 
 /********** Auxilliary tables **********/
@@ -1625,9 +1782,7 @@ namespace_identifier(int argc, Scheme_Object *argv[])
   obj = argv[0];
   obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0);
 
-  /* Renamings: */
+  obj = scheme_stx_add_module_context(obj, genv->stx_context);
-  if (genv->rename_set)
-    obj = scheme_add_rename(obj, genv->rename_set);
 
   return obj;
 }
@@ -1641,7 +1796,7 @@ namespace_module_identifier(int argc, Scheme_Object *argv[])
   if (argc > 0) {
     if (SCHEME_NAMESPACEP(argv[0])) {
       genv = (Scheme_Env *)argv[0];
-      phase = scheme_make_integer(genv->phase);
+      phase = scheme_env_phase(genv);
     } else if (SCHEME_FALSEP(argv[0])) {
       phase = scheme_false;
     } else if (SCHEME_INTP(argv[0]) || SCHEME_BIGNUMP(argv[0])) {
@@ -1652,7 +1807,7 @@ namespace_module_identifier(int argc, Scheme_Object *argv[])
     }
   } else {
     genv = scheme_get_env(NULL);
-    phase = scheme_make_integer(genv->phase);
+    phase = scheme_env_phase(genv);
   }
 
   return scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, 
@@ -1672,7 +1827,7 @@ namespace_base_phase(int argc, Scheme_Object *argv[])
   else
     genv = scheme_get_env(NULL);
 
-  return scheme_make_integer(genv->phase);
+  return scheme_env_phase(genv);
 }
 
 static Scheme_Object *
@@ -1740,7 +1895,19 @@ namespace_set_variable_value(int argc, Scheme_Object *argv[])
   scheme_set_global_bucket("namespace-set-variable-value!", bucket, argv[1], 1);
   
   if ((argc > 2) && SCHEME_TRUEP(argv[2])) {
-    scheme_shadow(env, argv[0], 1);
+    scheme_binding_names_from_module(env);
+    if (!env->binding_names
+        || (SCHEME_HASHTRP(env->binding_names)
+            && !scheme_hash_tree_get((Scheme_Hash_Tree *)env->binding_names, argv[0]))
+        || (SCHEME_HASHTP(env->binding_names)
+            && !scheme_hash_get((Scheme_Hash_Table *)env->binding_names, argv[0]))) {
+      Scheme_Object *id;
+      id = scheme_datum_to_syntax(argv[0], scheme_false, scheme_false, 0, 0);
+      scheme_prepare_env_stx_context(env);
+      id = scheme_stx_add_module_context(id, env->stx_context);
+      (void)scheme_global_binding(id, env);
+    }
+    scheme_shadow(env, argv[0], argv[1], 1);
   }
 
   return scheme_void;
@@ -1814,8 +1981,8 @@ namespace_mapped_symbols(int argc, Scheme_Object *argv[])
     }
   }
 
-  if (env->rename_set)
+  if (env->stx_context)
-    scheme_list_module_rename(env->rename_set, mapped, env->module_registry->exports);
+    scheme_module_context_add_mapped_symbols(env->stx_context, mapped);
 
   l = scheme_null;
   for (i = mapped->size; i--; ) {
@@ -2054,19 +2221,23 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r
     }
   }
 
-  if (scheme_current_thread->current_local_mark)
+  if (scheme_current_thread->current_local_scope)
-    sym = scheme_add_remove_mark(sym, scheme_current_thread->current_local_mark);
+    sym = scheme_stx_flip_scope(sym, scheme_current_thread->current_local_scope,
+                                scheme_env_phase(env->genv));
 
   menv = NULL;
 
   while (1) {
-    v = scheme_lookup_binding(sym, env,
+    v = scheme_compile_lookup(sym, env,
 			      (SCHEME_NULL_FOR_UNBOUND
 			       + SCHEME_RESOLVE_MODIDS
 			       + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
-			       + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST),
+			       + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST
+                               + (!recur ? SCHEME_STOP_AT_FREE_EQ : 0)),
 			      scheme_current_thread->current_local_modidx, 
-			      &menv, NULL, NULL, NULL);
+			      &menv, NULL,
+                              NULL, NULL,
+                              NULL);
 
     SCHEME_EXPAND_OBSERVE_RESOLVE(observer, sym);
 
@@ -2204,7 +2375,7 @@ local_make_intdef_context(int argc, Scheme_Object *argv[])
   Scheme_Object *c, *rib;
   void **d;
 
-  d = MALLOC_N(void*, 3);
+  d = MALLOC_N(void*, 4);
 
   env = scheme_current_thread->current_local_env;
   if (!env)
@@ -2224,8 +2395,12 @@ local_make_intdef_context(int argc, Scheme_Object *argv[])
     d[1] = argv[0];
   }
   d[0] = env;
+  d[3] = env;
 
-  rib = scheme_make_rename_rib();
+  rib = scheme_new_scope(SCHEME_STX_INTDEF_SCOPE);
+  scheme_add_compilation_frame_intdef_scope(env, rib);
+  if ((argc > 1) && SCHEME_FALSEP(argv[1]))
+    rib = scheme_box(rib); /* box means "don't add context" for `local-expand` */
 
   c = scheme_alloc_object();
   c->type = scheme_intdef_context_type;
@@ -2249,14 +2424,39 @@ static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[])
     scheme_wrong_contract("internal-definition-context-seal", 
                           "internal-definition-context?", 0, argc, argv);
   
-  scheme_stx_seal_rib(SCHEME_PTR2_VAL(argv[0]));
   return scheme_void;
 }
 
+static Scheme_Object *intdef_context_intro(int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *res, *phase, *scope;
+  int mode = SCHEME_STX_FLIP;
+  
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type))
+    scheme_wrong_contract("internal-definition-context-introduce",
+                          "internal-definition-context?", 0, argc, argv);
+
+  res = argv[1];
+  if (!SCHEME_STXP(res))
+    scheme_wrong_contract("internal-definition-context-introduce",
+                          "syntax?", 1, argc, argv);
+
+  if (argc > 2)
+    mode = scheme_get_introducer_mode("internal-definition-context-introduce", 2, argc, argv);
+
+  phase = scheme_env_phase((Scheme_Env *)((Scheme_Object **)SCHEME_PTR1_VAL(argv[0]))[0]);
+
+  scope = SCHEME_PTR2_VAL(argv[0]);
+  if (SCHEME_BOXP(scope)) scope = SCHEME_BOX_VAL(scope);
+  res = scheme_stx_adjust_scope(res, scope, phase, mode);
+
+  return res;
+}
+
 static Scheme_Object *
 id_intdef_remove(int argc, Scheme_Object *argv[])
 {
-  Scheme_Object *l, *res, *skips;
+  Scheme_Object *l, *res, *scope, *phase;
 
   if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
     scheme_wrong_contract("identifier-remove-from-definition-context", 
@@ -2280,21 +2480,16 @@ id_intdef_remove(int argc, Scheme_Object *argv[])
     l = scheme_make_pair(l, scheme_null);
 
   res = argv[0];
-  skips = scheme_null;
+  
+  phase = scheme_env_phase((Scheme_Env *)((Scheme_Object **)SCHEME_PTR1_VAL(SCHEME_CAR(l)))[0]);
 
   while (SCHEME_PAIRP(l)) {
-    res = scheme_stx_id_remove_rib(res, SCHEME_PTR2_VAL(SCHEME_CAR(l)));
+    scope = SCHEME_PTR2_VAL(SCHEME_CAR(l));
-    skips = scheme_make_pair(SCHEME_PTR2_VAL(SCHEME_CAR(l)), skips);
+    if (SCHEME_BOXP(scope)) scope = SCHEME_BOX_VAL(scope);
+    res = scheme_stx_remove_scope(res, scope, phase);
     l = SCHEME_CDR(l);
   }
   
-  if (scheme_stx_ribs_matter(res, skips)) {
-    /* Removing ribs leaves the binding for this identifier in limbo, because
-       the rib that binds it depends on the removed ribs. Invent in inaccessible
-       identifier. */
-    res = scheme_add_remove_mark(res, scheme_new_mark());
-  }
-  
   return res;
 }
 
@@ -2312,43 +2507,10 @@ local_introduce(int argc, Scheme_Object *argv[])
   if (!SCHEME_STXP(s))
     scheme_wrong_contract("syntax-local-introduce", "syntax?", 0, argc, argv);
 
-  if (scheme_current_thread->current_local_mark)
+  if (scheme_current_thread->current_local_scope)
-    s = scheme_add_remove_mark(s, scheme_current_thread->current_local_mark);
+    s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_scope, scheme_env_phase(env->genv));
-
+  if (scheme_current_thread->current_local_use_scope)
-  return s;
+    s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_use_scope, scheme_env_phase(env->genv));
-}
-
-static Scheme_Object *
-local_module_introduce(int argc, Scheme_Object *argv[])
-{
-  Scheme_Comp_Env *env;
-  Scheme_Object *s, *v;
-
-  env = scheme_current_thread->current_local_env;
-  if (!env)
-    not_currently_transforming("syntax-local-module-introduce");
-
-  s = argv[0];
-  if (!SCHEME_STXP(s))
-    scheme_wrong_contract("syntax-local-module-introduce", "syntax?", 0, argc, argv);
-
-  v = scheme_stx_source_module(s, 0, 0);
-  if (SCHEME_FALSEP(v)) {
-    if (env->genv->module
-        && env->genv->module->rn_stx
-        && SCHEME_VECTORP(env->genv->module->rn_stx)) {
-      /* This is a submodule, and `rn_stx' has renames for the enclosing modules */
-      int i;
-      for (i = SCHEME_VEC_SIZE(env->genv->module->rn_stx); i-- > 1; ) {
-        v = SCHEME_VEC_ELS(env->genv->module->rn_stx)[i];
-        s = scheme_add_rename(s, scheme_stx_to_rename(v));
-      }
-    }
-    if (env->genv->rename_set)
-      s = scheme_add_rename(s, env->genv->rename_set);
-    if (env->genv->post_ex_rename_set)
-      s = scheme_add_rename(s, env->genv->post_ex_rename_set);
-  }
 
   return s;
 }
@@ -2357,188 +2519,94 @@ static Scheme_Object *
 local_get_shadower(int argc, Scheme_Object *argv[])
 {
   Scheme_Comp_Env *env;
-  Scheme_Object *sym, *sym_marks = NULL, *orig_sym, *uid = NULL, *free_id = NULL;
+  Scheme_Object *sym;
+  int only_generated = 0;
 
   env = scheme_current_thread->current_local_env;
   if (!env)
     not_currently_transforming("syntax-local-get-shadower");
 
   sym = argv[0];
-  orig_sym = sym;
-
   if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym))))
     scheme_wrong_contract("syntax-local-get-shadower", "identifier?", 0, argc, argv);
 
-  sym_marks = scheme_stx_extract_marks(sym);
+  if ((argc > 1) && SCHEME_TRUEP(argv[1]))
+    only_generated = 1;
 
-  uid = scheme_find_local_shadower(sym, sym_marks, env, &free_id);
+  return scheme_get_shadower(sym, env, only_generated);
-
-  if (!uid) {
-    uid = scheme_tl_id_sym(env->genv, sym, NULL, 0, 
-                           scheme_make_integer(env->genv->phase), NULL);
-    if (!SAME_OBJ(uid, SCHEME_STX_VAL(sym))) {
-      /* has a toplevel biding via marks or context; keep it */
-    } else {
-      /* No lexical shadower, but strip module context, if any */
-      sym = scheme_stx_strip_module_context(sym);
-      /* Add current module context, if any */
-      sym = local_module_introduce(1, &sym);
-
-      if (!scheme_stx_is_clean(orig_sym))
-        sym = scheme_stx_taint(sym);
-    }
-
-    return sym;
 }
 
+int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv)
 {
-    Scheme_Object *rn, *result;
+  int mode = SCHEME_STX_FLIP;
 
-    result = scheme_datum_to_syntax(SCHEME_STX_VAL(sym), orig_sym, sym, 0, 0);
+  if (SAME_OBJ(argv[which], flip_symbol))
-    ((Scheme_Stx *)result)->props = ((Scheme_Stx *)orig_sym)->props;
+    mode = SCHEME_STX_FLIP;
+  else if (SAME_OBJ(argv[which], add_symbol))
+    mode = SCHEME_STX_ADD;
+  else if (SAME_OBJ(argv[which], remove_symbol))
+    mode = SCHEME_STX_REMOVE;
+  else
+    scheme_wrong_contract(who, "(or/c 'flip 'add 'remove)", which, argc, argv);
   
-    rn = scheme_make_rename(uid, 1);
+  return mode;
-    scheme_set_rename(rn, 0, result);
-
-    result = scheme_add_rename(result, rn);
-
-    if (free_id)
-      scheme_install_free_id_rename(result, free_id, NULL, scheme_make_integer(0));
-
-    if (!scheme_stx_is_clean(orig_sym))
-      result = scheme_stx_taint(result);
-
-    return result;
-  }
 }
 
 static Scheme_Object *
-introducer_proc(void *mark, int argc, Scheme_Object *argv[])
+introducer_proc(void *info, int argc, Scheme_Object *argv[])
 {
   Scheme_Object *s;
+  int mode = SCHEME_STX_FLIP;
 
   s = argv[0];
-  if (!SCHEME_STXP(s))
+  if (!SCHEME_STXP(s)) {
     scheme_wrong_contract("syntax-introducer", "syntax?", 0, argc, argv);
+    return NULL;
+  }
+  if (argc > 1)
+    mode = scheme_get_introducer_mode("syntax-introducer", 1, argc, argv);
 
-  return scheme_add_remove_mark(s, (Scheme_Object *)mark);
+  return scheme_stx_adjust_scope(s, ((Scheme_Object **)info)[0], ((Scheme_Object **)info)[1], mode);
 }
 
 static Scheme_Object *
 make_introducer(int argc, Scheme_Object *argv[])
 {
-  Scheme_Object *mark;
+  Scheme_Object *scope, **info;
+  Scheme_Env *genv;
 
-  mark = scheme_new_mark();
+  scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE);
+  info = MALLOC_N(Scheme_Object*, 2);
 
-  return scheme_make_closed_prim_w_arity(introducer_proc, mark,
+  info[0] = scope;
-					 "syntax-introducer", 1, 1);
+  if (scheme_current_thread->current_local_env)
+    info[1] = scheme_env_phase(scheme_current_thread->current_local_env->genv);
+  else {
+    genv = (Scheme_Env *)scheme_get_param(scheme_current_config(), MZCONFIG_ENV);
+    info[1] = scheme_env_phase(genv);
   }
 
-static Scheme_Object *
+  return scheme_make_closed_prim_w_arity(introducer_proc, info,
-delta_introducer_proc(void *_i_plus_m, int argc, Scheme_Object *argv[])
+					 "syntax-introducer", 1, 2);
+}
+
+static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[])
 {
-  Scheme_Object *p = (Scheme_Object *)_i_plus_m, *l, *v, *a[1];
+  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "syntax-local-make-delta-introducer: " NOT_SUPPORTED_STR);
-  const char *who = "delta introducer attached to a rename transformer";
+  ESCAPED_BEFORE_HERE;
-
-  v = argv[0];
-  if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) {
-    scheme_wrong_contract(who, "identifier?", 0, argc, argv);
 }
 
-  /* Apply mapping functions: */
+static Scheme_Object *local_binding_id(int argc, Scheme_Object **argv)
-  l = SCHEME_CDR(p);
-  while (SCHEME_PAIRP(l)) {
-    a[0] = v;
-    v = _scheme_apply(SCHEME_CAR(l), 1, a);
-    l = SCHEME_CDR(l);
-  }
-
-  /* Apply delta-introducing functions: */
-  l = SCHEME_CAR(p);
-  while (SCHEME_PAIRP(l)) {
-    a[0] = v;
-    v = _scheme_apply(SCHEME_CAR(l), 1, a);
-    if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) {
-      a[0] = v;
-      scheme_wrong_contract(who, "identifier?", -1, -1, a);
-    }
-    l = SCHEME_CDR(l);
-  }
-
-  return v;
-}
-
-static Scheme_Object *
-local_make_delta_introduce(int argc, Scheme_Object *argv[])
 {
-  Scheme_Object *sym, *binder, *introducer, *a[2], *v;
+  Scheme_Object *a = argv[0];
-  Scheme_Object *introducers = scheme_null, *mappers = scheme_null;
-  int renamed = 0;
-  Scheme_Comp_Env *env;
 
-  env = scheme_current_thread->current_local_env;
+  if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a))
-  if (!env)
+    scheme_wrong_contract("syntax-local-identifier-as-binding", "identifier?", 0, argc, argv);
-    not_currently_transforming("syntax-local-make-delta-introducer");
 
-  if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
+  if (scheme_current_thread->current_local_env)
-    scheme_wrong_contract("syntax-local-make-delta-introducer", "identifier?", 0, argc, argv);
+    return scheme_revert_use_site_scopes(a, scheme_current_thread->current_local_env);
-
+  else
-  sym = argv[0];
+    return a;
-
-  while (1) {
-    binder = NULL;
-
-    v = scheme_lookup_binding(sym, env,
-			      (SCHEME_NULL_FOR_UNBOUND
-			       + SCHEME_RESOLVE_MODIDS
-			       + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
-			       + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST),
-			      scheme_current_thread->current_local_modidx, 
-			      NULL, NULL, &binder, NULL);
-    
-    /* Deref globals */
-    if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type))
-      v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val;
-    
-    if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) {
-      scheme_contract_error("syntax-local-make-delta-introducer",
-                            (renamed 
-                             ? "not defined as syntax (after renaming)"
-                             : "not defined as syntax"),
-                            "identifier", 1, argv[0],
-                            NULL);
-    }
-
-    if (!binder) {
-      /* Not a lexical biding. Tell make-syntax-delta-introducer to
-         use module-binding information. */
-      binder = scheme_false;
-    }
-
-    a[0] = sym;
-    a[1] = binder;
-    introducer = scheme_syntax_make_transfer_intro(2, a);
-    introducers = scheme_make_pair(introducer, introducers);
-    
-    v = SCHEME_PTR_VAL(v);
-    if (scheme_is_rename_transformer(v)) {
-      sym = scheme_rename_transformer_id(v);
-
-      v = SCHEME_PTR2_VAL(v);
-      if (!SCHEME_FALSEP(v))
-        mappers = scheme_make_pair(v, mappers);
-
-      renamed = 1;
-      SCHEME_USE_FUEL(1);
-    } else {
-      /* that's the end of the chain */
-      mappers = scheme_reverse(mappers);
-      return scheme_make_closed_prim_w_arity(delta_introducer_proc, 
-                                             scheme_make_pair(introducers, mappers),
-                                             "syntax-delta-introducer", 1, 1);
-    }
-  }
 }
 
 Scheme_Object *scheme_get_local_inspector()
@@ -2674,57 +2742,57 @@ static Scheme_Object *
 local_lift_end_statement(int argc, Scheme_Object *argv[])
 {
   Scheme_Comp_Env *env;
-  Scheme_Object *local_mark, *expr;
+  Scheme_Object *local_scope, *expr;
 
   expr = argv[0];
   if (!SCHEME_STXP(expr))
     scheme_wrong_contract("syntax-local-lift-module-end-declaration", "syntax?", 0, argc, argv);
 
   env = scheme_current_thread->current_local_env;
-  local_mark = scheme_current_thread->current_local_mark;
+  local_scope = scheme_current_thread->current_local_scope;
 
   if (!env)
     not_currently_transforming("syntax-local-lift-module-end-declaration");
 
-  return scheme_local_lift_end_statement(expr, local_mark, env);
+  return scheme_local_lift_end_statement(expr, local_scope, env);
 }
 
 static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[])
 {
   Scheme_Comp_Env *env;
-  Scheme_Object *local_mark;
+  Scheme_Object *local_scope;
   intptr_t phase;
 
   if (!SCHEME_STXP(argv[1]))
     scheme_wrong_contract("syntax-local-lift-require", "syntax?", 1, argc, argv);
 
   env = scheme_current_thread->current_local_env;
-  local_mark = scheme_current_thread->current_local_mark;
+  local_scope = scheme_current_thread->current_local_scope;
 
   if (!env)
     not_currently_transforming("syntax-local-lift-require");
 
   phase = env->genv->phase;
 
-  return scheme_local_lift_require(argv[0], argv[1], phase, local_mark, env);
+  return scheme_local_lift_require(argv[0], argv[1], phase, local_scope, env);
 }
 
 static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[])
 {
   Scheme_Comp_Env *env;
-  Scheme_Object *form, *local_mark;
+  Scheme_Object *form, *local_scope;
 
   form = argv[0];
   if (!SCHEME_STXP(form))
     scheme_wrong_contract("syntax-local-lift-provide", "syntax?", 1, argc, argv);
 
   env = scheme_current_thread->current_local_env;
-  local_mark = scheme_current_thread->current_local_mark;
+  local_scope = scheme_current_thread->current_local_scope;
 
   if (!env)
     not_currently_transforming("syntax-local-lift-provide");
 
-  return scheme_local_lift_provide(form, local_mark, env);
+  return scheme_local_lift_provide(form, local_scope, env);
 }
 
 static Scheme_Object *
@@ -2766,13 +2834,10 @@ make_rename_transformer(int argc, Scheme_Object *argv[])
   if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
     scheme_wrong_contract("make-rename-transformer", "identifier?", 0, argc, argv);
 
-  if (argc > 1)
-    scheme_check_proc_arity("make-rename-transformer", 1, 1, argc, argv);
-  
   v = scheme_alloc_object();
   v->type = scheme_id_macro_type;
   SCHEME_PTR1_VAL(v) = argv[0];
-  SCHEME_PTR2_VAL(v) = ((argc > 1) ? argv[1] : scheme_false);
+  SCHEME_PTR2_VAL(v) = scheme_false; /* used to be an introducer procedure */
 
   return v;
 }

racket/src/racket/src/error.c

@@ -2230,12 +2230,10 @@ static void do_wrong_syntax(const char *where,
   intptr_t len, vlen, dvlen, blen, plen;
   char *buffer;
   char *v, *dv, *p;
-  Scheme_Object *mod, *nomwho, *who;
+  Scheme_Object *who;
   int show_src;
 
   who = NULL;
-  nomwho = NULL;
-  mod = scheme_false;
 
   if (!s) {
     s = "bad syntax";
@@ -2249,14 +2247,10 @@ static void do_wrong_syntax(const char *where,
     where = NULL;
   } else if (where == scheme_application_stx_string) {
     who = scheme_intern_symbol("#%app");
-    nomwho = who;
-    mod = scheme_intern_symbol("racket");
   } else if ((where == scheme_set_stx_string)
 	     || (where == scheme_var_ref_string)
 	     || (where == scheme_begin_stx_string)) {
     who = scheme_intern_symbol(where);
-    nomwho = who;
-    mod = scheme_intern_symbol("racket");
     if (where == scheme_begin_stx_string)
       where = "begin (possibly implicit)";
   }
@@ -2275,23 +2269,14 @@ static void do_wrong_syntax(const char *where,
       pform = scheme_syntax_to_datum(form, 0, NULL);
 
       /* Try to extract syntax name from syntax */
-      if (!nomwho && (SCHEME_SYMBOLP(SCHEME_STX_VAL(form)) || SCHEME_STX_PAIRP(form))) {
+      if (!who && (SCHEME_SYMBOLP(SCHEME_STX_VAL(form)) || SCHEME_STX_PAIRP(form))) {
 	Scheme_Object *first;
 	if (SCHEME_STX_PAIRP(form))
 	  first = SCHEME_STX_CAR(form);
 	else
 	  first = form;
-	if (SCHEME_SYMBOLP(SCHEME_STX_VAL(first))) {
+	if (SCHEME_SYMBOLP(SCHEME_STX_VAL(first)))
-	  /* Get module and name at source: */
-	  int phase;
 	  who = SCHEME_STX_VAL(first); /* printed name is local name */
-	  /* name in exception is nominal source: */
- 	  if (scheme_current_thread->current_local_env)
-	    phase = scheme_current_thread->current_local_env->genv->phase;
-	  else phase = 0;
-	  scheme_stx_module_name(0, &first, scheme_make_integer(phase), &mod, &nomwho, 
-                                 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
-	}
       }
     } else {
       pform = form;
@@ -2346,8 +2331,6 @@ static void do_wrong_syntax(const char *where,
     else
       who = scheme_false;
   }
-  if (!nomwho)
-    nomwho = who;
 
   if (!where) {
     if (SCHEME_FALSEP(who))
@@ -2382,8 +2365,6 @@ static void do_wrong_syntax(const char *where,
                           where,
                           s, slen);
 
-  /* We don't actually use nomwho and mod, anymore. */
-
   if (SCHEME_FALSEP(form))
     form = extra_sources;
   else {

racket/src/racket/src/eval.c

@@ -869,9 +869,11 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
     }
 
     if (check_access && !SAME_OBJ(menv, env)) {
-      varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL, 
+      varname = scheme_check_accessible_in_module(menv, NULL, varname, NULL, 
-                                                  insp, NULL, pos, 0, NULL, NULL, env, NULL,
+                                                  NULL, insp, 
-                                                  NULL);
+                                                  pos, 0, 
+                                                  NULL, NULL, 
+                                                  env, NULL, NULL);
     }
   }
 
@@ -2002,14 +2004,14 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
 	  SCHEME_PTR_VAL(macro) = values[i];
 
 	  scheme_set_global_bucket("define-syntaxes", b, macro, 1);
-	  scheme_shadow(dm_env, (Scheme_Object *)b->key, 0);
+	  scheme_shadow(dm_env, (Scheme_Object *)b->key, macro, 0);
 	} else {
 	  Scheme_Prefix *toplevels;
 	  toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
 	  b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)];
 	
 	  scheme_set_global_bucket("define-values", b, values[i], 1);
-	  scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, 1);
+	  scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, values[i], 1);
 
 	  if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) {
             if (is_st)
@@ -2037,14 +2039,14 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
       SCHEME_PTR_VAL(macro) = vals;
       
       scheme_set_global_bucket("define-syntaxes", b, macro, 1);
-      scheme_shadow(dm_env, (Scheme_Object *)b->key, 0);
+      scheme_shadow(dm_env, (Scheme_Object *)b->key, macro, 0);
     } else {
       Scheme_Prefix *toplevels;
       toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
       b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)];
 
       scheme_set_global_bucket("define-values", b, vals, 1);
-      scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, 1);
+      scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, vals, 1);
       
       if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) {
         int flags = GLOB_IS_IMMUTATED;
@@ -2377,7 +2379,8 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env)
 
   dummy = SCHEME_VEC_ELS(form)[3];
 
-  rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, SCHEME_TOPLEVEL_FRAME);
+  rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, NULL,
+                                SCHEME_TOPLEVEL_FRAME);
 
   if (!dm_env)
     dm_env = scheme_environment_from_dummy(dummy);
@@ -2395,7 +2398,8 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env)
     scheme_push_continuation_frame(&cframe);
     scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
 
-    scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, dm_env, dm_env->link_midx);
+    scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false,
+                             dm_env, dm_env->link_midx);
 
     if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_syntaxes_type)) {
       (void)define_execute_with_dynamic_state(form, 4, 1, rp, dm_env, &dyn_state);
@@ -3749,7 +3753,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
 	  v = globs->a[i+pos+1];
 	  if (!v) {
 	    v = globs->a[pos];
-	    v = scheme_delayed_rename((Scheme_Object **)v, i);
+	    v = scheme_delayed_shift((Scheme_Object **)v, i);
 	    globs->a[i+pos+1] = v;
 	  }
 
@@ -3891,22 +3895,23 @@ Scheme_Object **scheme_current_argument_stack()
 /*                  eval/compile/expand starting points                   */
 /*========================================================================*/
 
-static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env *genv)
+Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv)
 {
-  if (genv->rename_set) {
+  scheme_prepare_env_stx_context(genv);
+
   if (SCHEME_STX_PAIRP(form)) {
     Scheme_Object *a, *d, *module_stx;
       
     a = SCHEME_STX_CAR(form);
     if (SCHEME_STX_SYMBOLP(a)) {
-	a = scheme_add_rename(a, genv->rename_set);
+      a = scheme_stx_push_module_context(a, genv->stx_context);
-        module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"),
+      module_stx = scheme_datum_to_syntax(module_symbol,
                                           scheme_false, 
                                           scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), 
                                           0, 0);
-	if (scheme_stx_module_eq(a, module_stx, genv->phase)) {
+      if (scheme_stx_free_eq(a, module_stx, genv->phase)) {
-	  /* Don't add renames to the whole module; let the 
+        /* Don't add context to the whole module, since the 
-	     module's language take over. */
+           `module` form will just discard it: */
         d = SCHEME_STX_CDR(form);
         a = scheme_make_pair(a, d);
         form = scheme_datum_to_syntax(a, form, form, 0, 1);
@@ -3914,13 +3919,8 @@ static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env
       }
     }
   } 
-  }
 
-  if (genv->rename_set) {
+  form = scheme_stx_push_module_context(form, genv->stx_context);
-    form = scheme_add_rename(form, genv->rename_set);
-    /* this "phase shift" just attaches the namespace's module registry: */
-    form = scheme_stx_phase_shift(form, NULL, NULL, NULL, genv->module_registry->exports, NULL, NULL);
-  }
 
   return form;
 }
@@ -3963,7 +3963,7 @@ static int get_comp_flags(Scheme_Config *config)
 static void *compile_k(void)
 {
   Scheme_Thread *p = scheme_current_thread;
-  Scheme_Object *form;
+  Scheme_Object *form, *frame_scopes;
   int writeable, for_eval, rename, enforce_consts, comp_flags;
   Scheme_Env *genv;
   Scheme_Compile_Info rec, rec2;
@@ -3991,14 +3991,7 @@ static void *compile_k(void)
 
   /* Renamings for requires: */
   if (rename) {
-    form = add_renames_unless_module(form, genv);
+    form = scheme_top_introduce(form, genv);
-    if (genv->module) {
-      form = scheme_stx_phase_shift(form, NULL, 
-				    genv->module->me->src_modidx, 
-				    genv->module->self_modidx,
-				    genv->module_registry->exports,
-                                    NULL, NULL);
-    }
   }
 
   tl_queue = scheme_null;
@@ -4013,19 +4006,36 @@ static void *compile_k(void)
       comp_flags |= COMP_ENFORCE_CONSTS;
   }
 
+  scheme_prepare_env_stx_context(genv);
+
+  if (genv->stx_context)
+    frame_scopes = scheme_module_context_frame_scopes(genv->stx_context, NULL);
+  else
+    frame_scopes = NULL;
+
+  if (for_eval) {
+    /* For the top-level environment, we "push_introduce" instead of "introduce"
+       to avoid ambiguous binding, especially since push_prefix
+       "push"es. */
+    form = scheme_stx_push_introduce_module_context(form, genv->stx_context);
+  }
+
   while (1) {
     scheme_prepare_compile_env(genv);
 
     rec.comp = 1;
     rec.dont_mark_local_use = 0;
     rec.resolve_module_ids = !writeable && !genv->module;
+    rec.substitute_bindings = 1;
     rec.value_name = scheme_false;
     rec.observer = NULL;
     rec.pre_unwrapped = 0;
     rec.env_already = 0;
     rec.comp_flags = comp_flags;
 
-    cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);
+    cenv = scheme_new_comp_env(genv, insp, frame_scopes,
+                               SCHEME_TOPLEVEL_FRAME
+                               | SCHEME_KEEP_SCOPES_FRAME);
 
     if (for_eval) {
       /* Need to look for top-level `begin', and if we
@@ -4036,10 +4046,11 @@ static void *compile_k(void)
                                     scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false);
 	form = scheme_check_immediate_macro(form,
 					    cenv, &rec, 0,
-					    0, &gval, NULL, NULL,
+					    &gval,
                                             1);
 	if (SAME_OBJ(gval, scheme_begin_syntax)) {
 	  if (scheme_stx_proper_list_length(form) > 1){
+            form = scheme_stx_push_introduce_module_context(form, genv->stx_context);
 	    form = SCHEME_STX_CDR(form);
 	    tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL),
 				     tl_queue);
@@ -4054,12 +4065,15 @@ static void *compile_k(void)
 	  o = scheme_frame_get_lifts(cenv);
 	  if (!SCHEME_NULLP(o)
               || !SCHEME_NULLP(rl)) {
+            o = scheme_named_map_1(NULL, scheme_stx_push_introduce_module_context, o, genv->stx_context);
+            rl = scheme_named_map_1(NULL, scheme_stx_push_introduce_module_context, rl, genv->stx_context);
 	    tl_queue = scheme_make_pair(form, tl_queue);
 	    tl_queue = scheme_append(o, tl_queue);
 	    tl_queue = scheme_append(rl, tl_queue);
 	    form = SCHEME_CAR(tl_queue);
 	    tl_queue = SCHEME_CDR(tl_queue);
-	  }
+	  } else
+            form = scheme_stx_push_introduce_module_context(form, genv->stx_context);
 	  break;
 	}
       }
@@ -4117,7 +4131,7 @@ static void *compile_k(void)
         scheme_optimize_info_never_inline(oi);
       o = scheme_optimize_expr(o, oi, 0);
 
-      rp = scheme_resolve_prefix(0, cenv->prefix, 1);
+      rp = scheme_resolve_prefix(0, cenv->prefix, insp);
       ri = scheme_resolve_info_create(rp);
       scheme_resolve_info_enforce_const(ri, enforce_consts);
       scheme_enable_expression_resolve_lifts(ri);
@@ -4435,8 +4449,12 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *
     result = scheme_make_vector(len - 1, NULL);
 
     for (i = 0; i < len - 1; i++) {
-      s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], scheme_make_integer(shift), orig, modidx, 
+      s = SCHEME_VEC_ELS(expr)[i];
-                                 env->module_registry->exports, NULL, NULL);
+      s = scheme_stx_shift(s,
+                           scheme_make_integer(shift),
+                           orig, modidx, 
+                           env->module_registry->exports,
+                           NULL, NULL);
       SCHEME_VEC_ELS(result)[i] = s;
     }
     
@@ -4483,7 +4501,7 @@ static void *expand_k(void)
 
   if (rename > 0) {
     /* Renamings for requires: */
-    obj = add_renames_unless_module(obj, env->genv);
+    obj = scheme_top_introduce(obj, env->genv);
   }
 
   observer = scheme_get_expand_observe();
@@ -4493,7 +4511,7 @@ static void *expand_k(void)
 
   if (as_local < 0) {
     /* Insert a dummy frame so that `pair_lifted' can add more. */
-    env = scheme_new_compilation_frame(0, 0, env);
+    env = scheme_new_compilation_frame(0, 0, NULL, env);
     ip = MALLOC_N(Scheme_Comp_Env *, 1);
     *ip = env;
   }  else
@@ -4504,12 +4522,13 @@ static void *expand_k(void)
   /* Loop for lifted expressions: */
   while (1) {
     erec1.comp = 0;
-    erec1.depth = depth;
+    erec1.depth = ((depth == -3) ? -2 : depth);
     erec1.value_name = scheme_false;
     erec1.observer = observer;
     erec1.pre_unwrapped = 0;
     erec1.env_already = 0;
     erec1.comp_flags = comp_flags;
+    erec1.substitute_bindings = (depth != -3);
 
     if (catch_lifts_key) {
       Scheme_Object *data;
@@ -4524,7 +4543,7 @@ static void *expand_k(void)
 
     if (just_to_top) {
       Scheme_Object *gval;
-      obj = scheme_check_immediate_macro(obj, env, &erec1, 0, 0, &gval, NULL, NULL, 1);
+      obj = scheme_check_immediate_macro(obj, env, &erec1, 0, &gval, 1);
     } else
       obj = scheme_expand_expr(obj, env, &erec1, 0);
 
@@ -4564,7 +4583,8 @@ static Scheme_Object *r_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
 			       int depth, int rename, int just_to_top, 
 			       Scheme_Object *catch_lifts_key, int eb,
 			       int as_local)
-  /* as_local < 0 => catch lifts to let */
+  /* as_local < 0 => catch lifts to let;
+     depth = -3 => depth = -2, and no substituion of references with bindings */
 {
   Scheme_Thread *p = scheme_current_thread;
 
@@ -4581,7 +4601,9 @@ static Scheme_Object *r_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
 
 Scheme_Object *scheme_expand(Scheme_Object *obj, Scheme_Env *env)
 {
-  return r_expand(obj, scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+  return r_expand(obj, scheme_new_expand_env(env, NULL, scheme_true,
+                                             SCHEME_TOPLEVEL_FRAME
+                                             | SCHEME_KEEP_SCOPES_FRAME),
 		  -1, 1, 0, scheme_false, -1, 0);
 }
 
@@ -4629,7 +4651,7 @@ eval(int argc, Scheme_Object *argv[])
       genv = (Scheme_Env *)argv[1];
     } else
       genv = scheme_get_env(NULL);
-    form = add_renames_unless_module(form, genv);
+    form = scheme_top_introduce(form, genv);
   }
 
   a[0] = form;
@@ -4706,7 +4728,7 @@ top_introduce_stx(int argc, Scheme_Object **argv)
   if (!SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) {
     Scheme_Env *genv;
     genv = (Scheme_Env *)scheme_get_param(scheme_current_config(), MZCONFIG_ENV);
-    form = add_renames_unless_module(form, genv);
+    form = scheme_top_introduce(form, genv);
   }
 
   return form;
@@ -4727,7 +4749,7 @@ compile(int argc, Scheme_Object *argv[])
     form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0);
 
   genv = scheme_get_env(NULL);
-  form = add_renames_unless_module(form, genv);
+  form = scheme_top_introduce(form, genv);
 
   return call_compile_handler(form, 0);
 }
@@ -4755,7 +4777,9 @@ static Scheme_Object *expand(int argc, Scheme_Object **argv)
 
   env = scheme_get_env(NULL);
 
-  return r_expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+  return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true,
+                                                 SCHEME_TOPLEVEL_FRAME
+                                                 | SCHEME_KEEP_SCOPES_FRAME),
 		  -1, 1, 0, scheme_false, 0, 0);
 }
 
@@ -4768,7 +4792,9 @@ static Scheme_Object *expand_stx(int argc, Scheme_Object **argv)
 
   env = scheme_get_env(NULL);
   
-  return r_expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+  return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true,
+                                                 SCHEME_TOPLEVEL_FRAME
+                                                 | SCHEME_KEEP_SCOPES_FRAME),
 		  -1, -1, 0, scheme_false, 0, 0);
 }
 
@@ -4794,10 +4820,10 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_O
 {
   Scheme_Object *l, *ids, *id;
 
-  /* Registers marked ids: */
+  /* Registers scoped ids: */
   for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) {
     id = SCHEME_CAR(ids);
-    scheme_tl_id_sym(env->genv, id, scheme_false, 2, NULL, NULL);
+    (void)scheme_global_binding(id, env->genv);
   }
 
   l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0), 
@@ -4808,23 +4834,17 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_O
   return scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0);
 }
 
-static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming)
+static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming, Scheme_Object *phase)
 {
   Scheme_Object *rl = renaming;
 
   if (SCHEME_PAIRP(renaming)) {
-    int need_delim;
-    need_delim = !SCHEME_NULLP(SCHEME_CDR(rl));
-    if (need_delim)
-      l = scheme_add_rib_delimiter(l, scheme_null);
     while (!SCHEME_NULLP(rl)) {
-      l = scheme_add_rename(l, SCHEME_CAR(rl));
+      l = scheme_stx_add_scope(l, SCHEME_CAR(rl), phase);
       rl = SCHEME_CDR(rl);
     }
-    if (need_delim)
-      l = scheme_add_rib_delimiter(l, renaming);
   } else {
-    l = scheme_add_rename(l, renaming);
+    l = scheme_stx_add_scope(l, renaming, phase);
   }
 
   return l;
@@ -4859,9 +4879,9 @@ static Scheme_Object *
 do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv)
 {
   Scheme_Comp_Env *env, *orig_env, **ip;
-  Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
+  Scheme_Object *l, *local_scope, *renaming = NULL, *orig_l, *exp_expr = NULL;
   int cnt, pos, kind, is_modstar;
-  int bad_sub_env = 0, bad_intdef = 0;
+  int bad_sub_env = 0, bad_intdef = 0, keep_ref_ids = 0;
   Scheme_Object *observer, *catch_lifts_key = NULL;
 
   env = scheme_current_thread->current_local_env;
@@ -4874,7 +4894,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
 
   if (for_stx) {
     scheme_prepare_exp_env(env->genv);
-    env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
+    env = scheme_new_comp_env(env->genv->exp_env, env->insp, NULL, 0);
     scheme_propagate_require_lift_capture(orig_env, env);
   }
   scheme_prepare_compile_env(env->genv);
@@ -4882,16 +4902,16 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
   if (for_expr)
     kind = 0; /* expression */
   else if (!for_stx && SAME_OBJ(argv[1], module_symbol))
-    kind = SCHEME_MODULE_BEGIN_FRAME; /* name is backwards compared to symbol! */
+    kind = SCHEME_MODULE_FRAME | SCHEME_USE_SCOPES_TO_NEXT; /* module body */
   else if (!for_stx && SAME_OBJ(argv[1], module_begin_symbol))
-    kind = SCHEME_MODULE_FRAME; /* name is backwards compared to symbol! */
+    kind = SCHEME_MODULE_BEGIN_FRAME; /* just inside module for expanding to `#%module-begin` */
   else if (SAME_OBJ(argv[1], top_level_symbol)) {
     kind = SCHEME_TOPLEVEL_FRAME;
     if (catch_lifts < 0) catch_lifts = 0;
   } else if (SAME_OBJ(argv[1], expression_symbol))
     kind = 0;
   else if (scheme_proper_list_length(argv[1]) > 0)
-    kind = SCHEME_INTDEF_FRAME;
+    kind = SCHEME_INTDEF_FRAME | SCHEME_USE_SCOPES_TO_NEXT;
   else  {
     scheme_wrong_contract(name,
                           (for_stx
@@ -4908,6 +4928,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
         update_intdef_chain(argv[3]);
 	stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[3]))[0];
 	renaming = SCHEME_PTR2_VAL(argv[3]);
+        if (SCHEME_BOXP(renaming)) /* box means "don't add" */
+          renaming = NULL;
 	if (!scheme_is_sub_env(stx_env, env))
 	  bad_sub_env = 1;
 	env = stx_env;
@@ -4929,13 +4951,17 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
           rl = argv[3];
           update_intdef_chain(SCHEME_CAR(rl));
           env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0];
-          if (SCHEME_NULLP(SCHEME_CDR(rl)))
+          if (SCHEME_NULLP(SCHEME_CDR(rl))) {
             renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl));
-          else {
+            if (SCHEME_BOXP(renaming))
+              renaming = NULL;
+          } else {
             /* reverse and extract: */
             renaming = scheme_null;
             while (!SCHEME_NULLP(rl)) {
-              renaming = cons(SCHEME_PTR2_VAL(SCHEME_CAR(rl)), renaming);
+              l = SCHEME_PTR2_VAL(SCHEME_CAR(rl));
+              if (!SCHEME_BOXP(l))
+                renaming = cons(l, renaming);
               rl = SCHEME_CDR(rl);
             }
           }
@@ -4961,6 +4987,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
   env = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME
 					 | SCHEME_FOR_STOPS
 					 | kind),
+				     NULL,
                                      env);
   if (catch_lifts < 0) {
     /* Note: extra frames can get inserted after env by pair_lifted */
@@ -4969,11 +4996,11 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
   } else
     ip = NULL;
 
-  if (kind == SCHEME_INTDEF_FRAME)
+  if (kind & SCHEME_INTDEF_FRAME)
     env->intdef_name = argv[1];
   env->in_modidx = scheme_current_thread->current_local_modidx;
 
-  local_mark = scheme_current_thread->current_local_mark;
+  local_scope = scheme_current_thread->current_local_scope;
   
   if (for_expr) {
   } else if (SCHEME_TRUEP(argv[2])) {
@@ -4981,7 +5008,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     cnt = scheme_stx_proper_list_length(argv[2]);
 
     if (cnt == 1)
-      is_modstar = scheme_stx_module_eq_x(scheme_modulestar_stx, SCHEME_CAR(argv[2]), env->genv->phase);
+      is_modstar = scheme_stx_free_eq_x(scheme_modulestar_stx, SCHEME_CAR(argv[2]), env->genv->phase);
     else
       is_modstar = 0;
 
@@ -5002,7 +5029,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
       }
     
       if (cnt > 0)
-        scheme_set_local_syntax(pos++, i, scheme_get_stop_expander(), env);
+        scheme_set_local_syntax(pos++, i, scheme_get_stop_expander(), env, 0);
     }
     if (!SCHEME_NULLP(l)) {
       scheme_wrong_contract(name, "(or/c #f (listof identifier?))", 2, argc, argv);
@@ -5025,6 +5052,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
       scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%variable-reference"), env);
       scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%expression"), env);
       scheme_add_core_stop_form(pos++, quote_symbol, env);
+      keep_ref_ids = 1;
     }
   }
 
@@ -5057,14 +5085,14 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     }
   }
 
-  if (local_mark) {
+  if (local_scope) {
     /* Since we have an expression from local context,
-       we need to remove the temporary mark... */
+       we need to remove the temporary scope... */
-    l = scheme_add_remove_mark(l, local_mark);
+    l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv));
   }
 
   if (renaming)
-    l = add_intdef_renamings(l, renaming);
+    l = add_intdef_renamings(l, renaming, scheme_env_phase(env->genv));
 
   SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l);
 
@@ -5093,7 +5121,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
       drec[0].comp_flags = comp_flags;
     }
 
-    xl = scheme_check_immediate_macro(l, env, drec, 0, 0, &gval, NULL, NULL, 1);
+    xl = scheme_check_immediate_macro(l, env, drec, 0, &gval, 1);
 
     if (SAME_OBJ(xl, l) && !for_expr) {
       SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, xl);
@@ -5112,14 +5140,16 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     l = xl;
   } else {
     /* Expand the expression. depth = -2 means expand all the way, but
-       preserve letrec-syntax. */
+       preserve letrec-syntax, while -3 is -2 but also avoid replacing reference ids
-    l = r_expand(l, env, -2, 0, 0, catch_lifts_key, 0, catch_lifts ? catch_lifts : 1);
+       with binding ids. */
+    l = r_expand(l, env, (keep_ref_ids ? -3 : -2), 0, 0, catch_lifts_key, 0,
+                 catch_lifts ? catch_lifts : 1);
   }
 
   SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
 
   if (renaming)
-    l = add_intdef_renamings(l, renaming);
+    l = add_intdef_renamings(l, renaming, scheme_env_phase(env->genv));
 
   if (for_expr) {
     /* Package up expanded expr with the environment. */
@@ -5137,13 +5167,13 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     SCHEME_PTR1_VAL(exp_expr) = l;
     SCHEME_PTR2_VAL(exp_expr) = orig_env;
     exp_expr = scheme_datum_to_syntax(exp_expr, l, scheme_false, 0, 0);
-    if (local_mark)
+    if (local_scope)
-      exp_expr = scheme_add_remove_mark(exp_expr, local_mark);
+      exp_expr = scheme_stx_flip_scope(exp_expr, local_scope, scheme_env_phase(env->genv));
   }
 
-  if (local_mark) {
+  if (local_scope) {
-    /* Put the temporary mark back: */
+    /* Put the temporary scope back: */
-    l = scheme_add_remove_mark(l, local_mark);
+    l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv));
   }
 
   if (for_expr) {
@@ -5155,8 +5185,6 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
     return scheme_values(2, a);
   } else {
     SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
-    if (kind == SCHEME_MODULE_FRAME)
-      l = scheme_annotate_existing_submodules(l, 0);
     return l;
   }
 }
@@ -5199,7 +5227,9 @@ expand_once(int argc, Scheme_Object **argv)
 
   env = scheme_get_env(NULL);
 
-  return r_expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+  return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true,
+                                                 SCHEME_TOPLEVEL_FRAME
+                                                 | SCHEME_KEEP_SCOPES_FRAME), 
 		  1, 1, 0, scheme_false, 0, 0);
 }
 
@@ -5213,7 +5243,9 @@ expand_stx_once(int argc, Scheme_Object **argv)
   
   env = scheme_get_env(NULL);
 
-  return r_expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+  return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true,
+                                                 SCHEME_TOPLEVEL_FRAME
+                                                 | SCHEME_KEEP_SCOPES_FRAME),
 		  1, -1, 0, scheme_false, 0, 0);
 }
 
@@ -5224,7 +5256,9 @@ expand_to_top_form(int argc, Scheme_Object **argv)
 
   env = scheme_get_env(NULL);
 
-  return r_expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+  return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true, 
+                                                 SCHEME_TOPLEVEL_FRAME
+                                                 | SCHEME_KEEP_SCOPES_FRAME),
 		  1, 1, 1, scheme_false, 0, 0);
 }
 
@@ -5238,7 +5272,9 @@ expand_stx_to_top_form(int argc, Scheme_Object **argv)
   
   env = scheme_get_env(NULL);
 
-  return r_expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
+  return r_expand(argv[0], scheme_new_expand_env(env, NULL, scheme_true,
+                                                 SCHEME_TOPLEVEL_FRAME
+                                                 | SCHEME_KEEP_SCOPES_FRAME),
 		  1, -1, 1, scheme_false, 0, 0);
 }
 
@@ -5505,10 +5541,29 @@ enable_break(int argc, Scheme_Object *argv[])
   }
 }
 
+static Scheme_Object *flip_scope_at_phase_and_revert_expr(Scheme_Object *a, Scheme_Object *m_p)
+{
+  Scheme_Comp_Env *env = (Scheme_Comp_Env *)SCHEME_CDR(m_p);
+
+  a = scheme_revert_use_site_scopes(a, env);
+
+  return scheme_stx_flip_scope(a, SCHEME_CAR(m_p), scheme_env_phase(env->genv));
+}
+
+static Scheme_Object *add_scope_at_phase(Scheme_Object *a, Scheme_Object *m_p)
+{
+  return scheme_stx_add_scope(a, SCHEME_CAR(m_p), SCHEME_CDR(m_p));
+}
+
+static Scheme_Object *revert_expr_scopes(Scheme_Object *a, Scheme_Object *env)
+{
+  return scheme_revert_use_site_scopes(a, (Scheme_Comp_Env *)env);
+}
+
 static Scheme_Object *
 local_eval(int argc, Scheme_Object **argv)
 {
-  Scheme_Comp_Env *env, *stx_env, *old_stx_env;
+  Scheme_Comp_Env *env, *stx_env, *init_env;
   Scheme_Object *l, *a, *rib, *expr, *names, *rn_names, *observer;
   int cnt = 0, pos;
 
@@ -5539,13 +5594,9 @@ local_eval(int argc, Scheme_Object **argv)
 
   update_intdef_chain(argv[2]);
   stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0];
+  init_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[3];
   rib = SCHEME_PTR2_VAL(argv[2]);
-
+  if (SCHEME_BOXP(rib)) rib = SCHEME_BOX_VAL(rib);
-  if (*scheme_stx_get_rib_sealed(rib)) {
-    scheme_contract_error("syntax-local-bind-syntaxes",
-                          "given internal-definition context has been sealed",
-                          NULL);
-  }
 
   if (!scheme_is_sub_env(stx_env, env)) {
     scheme_contract_error("syntax-local-bind-syntaxes",
@@ -5553,26 +5604,25 @@ local_eval(int argc, Scheme_Object **argv)
                           NULL);
   }
 
-  old_stx_env = stx_env;
+  stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF | SCHEME_USE_SCOPES_TO_NEXT, rib, stx_env);
-  stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, stx_env);
   scheme_add_local_syntax(cnt, stx_env);
 
-  /* Mark names */
+  /* Scope names */
-  if (scheme_current_thread->current_local_mark)
+  if (scheme_current_thread->current_local_scope)
-    names = scheme_named_map_1(NULL, scheme_add_remove_mark, names,
+    names = scheme_named_map_1(NULL, flip_scope_at_phase_and_revert_expr, names,
-                               scheme_current_thread->current_local_mark);
+                               scheme_make_raw_pair(scheme_current_thread->current_local_scope,
+                                                    (Scheme_Object *)stx_env));
 
   SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer,names);
 
   /* Initialize environment slots to #f, which means "not syntax". */
   cnt = 0;
   for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
-    scheme_set_local_syntax(cnt++, SCHEME_CAR(l), scheme_false, stx_env);
+    a = SCHEME_CAR(l);
+    a = scheme_revert_use_site_scopes(a, init_env);
+    scheme_set_local_syntax(cnt++, a, scheme_false, stx_env, 0);
   }
 	  
-  /* Extend shared rib with renamings */
-  scheme_add_env_renames(rib, stx_env, old_stx_env);
-
   stx_env->in_modidx = scheme_current_thread->current_local_modidx;
   if (!SCHEME_FALSEP(expr)) {
     Scheme_Compile_Expand_Info rec;
@@ -5582,21 +5632,25 @@ local_eval(int argc, Scheme_Object **argv)
     rec.observer = observer;
     rec.pre_unwrapped = 0;
     rec.env_already = 0;
+    rec.substitute_bindings = 1;
     rec.comp_flags = get_comp_flags(NULL);
     
     /* Evaluate and bind syntaxes */
-    if (scheme_current_thread->current_local_mark)
+    if (scheme_current_thread->current_local_scope)
-      expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);
+      expr = scheme_stx_flip_scope(expr, scheme_current_thread->current_local_scope,
+                                  scheme_env_phase(env->genv));
 
     scheme_prepare_exp_env(stx_env->genv);
     scheme_prepare_compile_env(stx_env->genv->exp_env);
     pos = 0;
-    expr = scheme_add_rename_rib(expr, rib);
+    expr = scheme_stx_add_scope(expr, rib, scheme_env_phase(stx_env->genv));
-    rn_names = scheme_named_map_1(NULL, scheme_add_rename_rib, names, rib);
+    rn_names = scheme_named_map_1(NULL, add_scope_at_phase, names,
+                                  scheme_make_pair(rib, scheme_env_phase(stx_env->genv)));
+    rn_names = scheme_named_map_1(NULL, revert_expr_scopes, rn_names, (Scheme_Object *)init_env);
     scheme_bind_syntaxes("local syntax definition", rn_names, expr,
 			 stx_env->genv->exp_env, stx_env->insp, &rec, 0,
 			 stx_env, stx_env,
-			 &pos, rib);
+			 &pos, rib, 1);
   }
 
   /* Remember extended environment */
@@ -5666,8 +5720,7 @@ int scheme_prefix_depth(Resolve_Prefix *rp)
 Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, 
 				   Scheme_Object *src_modidx, Scheme_Object *now_modidx,
 				   int src_phase, int now_phase,
-                                   Scheme_Env *dummy_env,
+                                   Scheme_Env *dummy_env, Scheme_Object *insp)
-                                   Scheme_Object *insp)
 {
   Scheme_Object **rs_save, **rs, *v;
   Scheme_Prefix *pf;
@@ -5706,10 +5759,10 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
       if (insp && SCHEME_FALSEP(insp))
         insp = scheme_get_current_inspector();
       i = rp->num_toplevels;
-      v = scheme_stx_phase_shift_as_rename(scheme_make_integer(now_phase - src_phase), 
+      v = scheme_make_shift(scheme_make_integer(now_phase - src_phase), 
                             src_modidx, now_modidx, 
                             genv ? genv->module_registry->exports : NULL,
-                                           insp, NULL);
+                            rp->src_insp_desc, insp);
       if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) {
 	/* Put lazy-shift info in pf->a[i]: */
         Scheme_Object **ls;
@@ -5819,9 +5872,11 @@ static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC
 #ifdef MZ_GC_BACKTRACE
         GC_set_backpointer_object(pf->backpointer);
 #endif
+        GC_mark_no_recur(gc, 1);
         gcMARK(pf);
         pf = (Scheme_Prefix *)GC_resolve2(pf, gc);
         GC_retract_only_mark_stack_entry(pf, gc);
+        GC_mark_no_recur(gc, 0);
       } else
         pf = (Scheme_Prefix *)GC_resolve2(pf, gc);
 

racket/src/racket/src/fun.c

@@ -1169,7 +1169,8 @@ static Scheme_Prompt *allocate_prompt(Scheme_Prompt **cached_prompt) {
 
 static void save_dynamic_state(Scheme_Thread *thread, Scheme_Dynamic_State *state) {
     state->current_local_env = thread->current_local_env;
-    state->mark              = thread->current_local_mark;
+    state->scope             = thread->current_local_scope;
+    state->use_scope         = thread->current_local_use_scope;
     state->name              = thread->current_local_name;
     state->modidx            = thread->current_local_modidx;
     state->menv              = thread->current_local_menv;
@@ -1177,19 +1178,22 @@ static void save_dynamic_state(Scheme_Thread *thread, Scheme_Dynamic_State *stat
 
 static void restore_dynamic_state(Scheme_Dynamic_State *state, Scheme_Thread *thread) {
     thread->current_local_env     = state->current_local_env;
-    thread->current_local_mark    = state->mark;
+    thread->current_local_scope   = state->scope;
+    thread->current_local_use_scope = state->use_scope;
     thread->current_local_name    = state->name;
     thread->current_local_modidx  = state->modidx;
     thread->current_local_menv    = state->menv;
 }
 
-void scheme_set_dynamic_state(Scheme_Dynamic_State *state, Scheme_Comp_Env *env, Scheme_Object *mark, 
+void scheme_set_dynamic_state(Scheme_Dynamic_State *state, Scheme_Comp_Env *env,
+                              Scheme_Object *scope, Scheme_Object *use_scope,
                               Scheme_Object *name, 
                               Scheme_Env *menv,
                               Scheme_Object *modidx)
 {
   state->current_local_env = env;
-  state->mark              = mark;
+  state->scope             = scope;
+  state->use_scope         = use_scope;
   state->name              = name;
   state->modidx            = modidx;
   state->menv              = menv;
@@ -1826,16 +1830,16 @@ cert_with_specials(Scheme_Object *code,
         name = scheme_stx_taint_disarm(code, NULL);
         name = SCHEME_STX_CAR(name);
 	if (SCHEME_STX_SYMBOLP(name)) {
-	  if (scheme_stx_module_eq_x(scheme_begin_stx, name, phase)
+	  if (scheme_stx_free_eq_x(scheme_begin_stx, name, phase)
-              || scheme_stx_module_eq_x(scheme_module_begin_stx, name, phase)) {
+              || scheme_stx_free_eq_x(scheme_module_begin_stx, name, phase)) {
 	    trans = 1;
 	    next_cadr_deflt = 0;
-	  } else if (scheme_stx_module_eq_x(scheme_begin_for_syntax_stx, name, phase)) {
+	  } else if (scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, name, phase)) {
 	    trans = 1;
 	    next_cadr_deflt = 0;
             phase_delta = 1;
-	  } else if (scheme_stx_module_eq_x(scheme_define_values_stx, name, phase)
+	  } else if (scheme_stx_free_eq_x(scheme_define_values_stx, name, phase)
-		     || scheme_stx_module_eq_x(scheme_define_syntaxes_stx, name, phase)) {
+		     || scheme_stx_free_eq_x(scheme_define_syntaxes_stx, name, phase)) {
 	    trans = 1;
 	    next_cadr_deflt = 1;
 	  }
@@ -1891,19 +1895,20 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
 		   Scheme_Object *rator, Scheme_Object *code,
 		   Scheme_Comp_Env *env, Scheme_Object *boundname,
                    Scheme_Compile_Expand_Info *rec, int drec,
-		   int for_set)
+		   int for_set,
+                   int scope_macro_use)
 {
   Scheme_Object *orig_code = code;
 
   if (scheme_is_rename_transformer(rator)) {
-    Scheme_Object *mark;
+    Scheme_Object *scope;
    
     rator = scheme_rename_transformer_id(rator);
     /* rator is now an identifier */
 
     /* and it's introduced by this expression: */
-    mark = scheme_new_mark();
+    scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE);
-    rator = scheme_add_remove_mark(rator, mark);
+    rator = scheme_stx_flip_scope(rator, scope, scheme_true);
 
     if (for_set) {
       Scheme_Object *tail, *setkw;
@@ -1928,7 +1933,7 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
 
     return code;
   } else {
-    Scheme_Object *mark, *rands_vec[1], *track_code, *pre_code;
+    Scheme_Object *scope, *use_scope, *rands_vec[1], *track_code, *pre_code;
 
     if (scheme_is_set_transformer(rator))
       rator = scheme_set_transformer_proc(rator);
@@ -1946,8 +1951,15 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
     }
     track_code = code;  /* after mode properties are removed */
 
-    mark = scheme_new_mark();
+    scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE);
-    code = scheme_add_remove_mark(code, mark);
+    code = scheme_stx_flip_scope(code, scope, scheme_true);
+
+    if (scope_macro_use) {
+      use_scope = scheme_new_scope(SCHEME_STX_USE_SITE_SCOPE);
+      scheme_add_compilation_frame_use_site_scope(env, use_scope);
+      code = scheme_stx_add_scope(code, use_scope, scheme_true);
+    } else
+      use_scope = NULL;
     
     code = scheme_stx_taint_disarm(code, NULL);
 
@@ -1966,7 +1978,7 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
       scheme_push_continuation_frame(&cframe);
       scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
 
-      scheme_set_dynamic_state(&dyn_state, env, mark, boundname, 
+      scheme_set_dynamic_state(&dyn_state, env, scope, use_scope, boundname, 
                                menv, menv ? menv->link_midx : env->genv->link_midx);
 
       rands_vec[0] = code;
@@ -1985,7 +1997,7 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv,
                        code);
     }
 
-    code = scheme_add_remove_mark(code, mark);
+    code = scheme_stx_flip_scope(code, scope, scheme_true);
 
     code = scheme_stx_track(code, track_code, name);
     

racket/src/racket/src/hamt_subset.inc

@@ -0,0 +1,166 @@
+/* Parameterize subset_of code over the euqality predicate, so that
+   an eq variant (for small enough tables) can be marked as non-GCing */
+
+HAMT_NONGCING static int HAMT_ELEMENT_OF_COLLISION(Scheme_Object *key1, Scheme_Object *val1,
+                                                   Scheme_Hash_Tree *t2,
+                                                   int stype, void *eql_data)
+/* linear search for an element */
+{
+  int i;
+  Scheme_Object *key2;
+  HAMT_IF_VAL(Scheme_Object *val2, );
+  
+  for (i = t2->count; i--; ) {
+    hamt_at_index(t2, i, &key2, HAMT_IF_VAL(&val2, NULL), NULL);
+    if (HAMT_EQUAL_ENTRIES(stype, eql_data,
+                           key1, val1,
+                           key2, HAMT_IF_VAL(val2, NULL)))
+      return 1;
+  }
+
+  return 0;
+}
+
+HAMT_NONGCING static int HAMT_ELEMENT_OF(Scheme_Object *key1, Scheme_Object *val1, uintptr_t code1,
+                                         Scheme_Hash_Tree *t2, int shift,
+                                         int stype, void *eql_data)
+/* search for one element in a subtree */
+{
+  int pos2;
+  
+  t2 = hamt_assoc(t2, code1, &pos2, shift);
+  if (t2) {
+    if (HASHTR_COLLISIONP(t2->els[pos2]))
+      return HAMT_ELEMENT_OF_COLLISION(key1, val1, (Scheme_Hash_Tree *)t2->els[pos2], stype, eql_data);
+    else
+      return HAMT_EQUAL_ENTRIES(stype, eql_data,
+                                key1, val1,
+                                t2->els[pos2], HAMT_IF_VAL(mzHAMT_VAL(t2, pos2), NULL));
+  } else
+    return 0;
+}
+
+HAMT_NONGCING int HAMT_SUBSET_OF(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2, int shift,
+                                 int stype, void *eql_data)
+/* checks wheher `t1` is a subset of `t2`; `t1` and `t2` must be of the same kind */
+{
+  hash_tree_bitmap_t i;
+  int pos1, pos2, index, popcount1, popcount2;
+  Scheme_Object *k1, *k2;
+  
+  if ((t1->bitmap & t2->bitmap) != t1->bitmap)
+    return 0;
+
+  popcount1 = hamt_popcount(t1->bitmap);
+  popcount2 = hamt_popcount(t2->bitmap);
+
+  for (i = t1->bitmap, pos1 = 0, index = 0; i; ) {
+    if (i & 1) {
+      pos2 = hamt_popcount_below(t2->bitmap, index);
+      k1 = t1->els[pos1];
+      k2 = t2->els[pos2];
+      if (SAME_OBJ(k1, k2)) {
+        if (HAMT_IF_VAL(0, 1)
+            || HASHTR_SUBTREEP(k1)
+            || HASHTR_COLLISIONP(k1)) {
+          /* Shared element, subtree, or collision; no need to look further */
+        } else {
+          /* need to compare values */
+          if (!HAMT_EQUAL_ENTRIES(stype, eql_data,
+                                  k1, HAMT_IF_VAL(_mzHAMT_VAL(t1, pos1, popcount1), NULL),
+                                  k2, HAMT_IF_VAL(_mzHAMT_VAL(t2, pos2, popcount2), NULL)))
+            return 0;
+        }
+      } else if (HASHTR_SUBTREEP(k1)) {
+        /* Since a subtree always has at least two items with different
+           hashes, t2 must have a subtree in the same position */
+        if (HASHTR_SUBTREEP(k2)) {
+          if (!HAMT_SUBSET_OF((Scheme_Hash_Tree *)k1,
+                              (Scheme_Hash_Tree *)k2,
+                              shift + mzHAMT_LOG_WORD_SIZE,
+                              stype, eql_data))
+            return 0;
+        } else
+          return 0;
+      } else if (HASHTR_COLLISIONP(k1)) {
+        intptr_t i;
+        Scheme_Object *key;
+        HAMT_IF_VAL(Scheme_Object *val, );
+        
+        if (HASHTR_SUBTREEP(k2)) {
+          /* check each element of collision */
+          for (i = ((Scheme_Hash_Tree *)k1)->count; i--; ) {
+            uintptr_t code;
+            hamt_at_index(((Scheme_Hash_Tree *)k1), i, &key, HAMT_IF_VAL(&val, NULL), &code);
+            if (!HAMT_ELEMENT_OF(key, HAMT_IF_VAL(val, NULL), code,
+                                 (Scheme_Hash_Tree *)k2,
+                                 shift + mzHAMT_LOG_WORD_SIZE,
+                                 stype, eql_data))
+              return 0;
+          }
+        } else if (HASHTR_COLLISIONP(k2)) {
+          /* hash codes of collisions must match */
+          if (_mzHAMT_CODE(t1, pos1, popcount1) != _mzHAMT_CODE(t2, pos2, popcount2))
+            return 0;
+          /* must check each element of t1 in t2 */
+          for (i = ((Scheme_Hash_Tree *)k1)->count; i--; ) {
+            hamt_at_index((Scheme_Hash_Tree *)k1, i, &key, HAMT_IF_VAL(&val, NULL), NULL);
+            if (!HAMT_ELEMENT_OF_COLLISION(key, HAMT_IF_VAL(val, NULL),
+                                           (Scheme_Hash_Tree *)k2,
+                                           stype, eql_data))
+              return 0;
+          }
+        } else {
+          /* A single element in t2 can't cover eveything in the collision */
+          return 0;
+        }
+      } else {
+        if (HASHTR_SUBTREEP(k2)) {
+          if (!HAMT_ELEMENT_OF(k1, HAMT_IF_VAL(_mzHAMT_VAL(t1, pos1, popcount1), NULL),
+                               _mzHAMT_CODE(t1, pos1, popcount1),
+                               (Scheme_Hash_Tree *)k2,
+                               shift + mzHAMT_LOG_WORD_SIZE,
+                               stype, eql_data))
+            return 0;
+        } else {
+          /* two elements or an element and a collision;
+             hash codes much match either way */
+          if (_mzHAMT_CODE(t1, pos1, popcount1) != _mzHAMT_CODE(t2, pos2, popcount2))
+            return 0;
+          if (HASHTR_COLLISIONP(k2)) {
+            /* look for an invidual value in t2: */
+            if (!HAMT_ELEMENT_OF_COLLISION(k1, HAMT_IF_VAL(_mzHAMT_VAL(t1, pos1, popcount1), NULL),
+                                           (Scheme_Hash_Tree *)k2,
+                                           stype, eql_data))
+              return 0;
+          } else {
+            if (!HAMT_EQUAL_ENTRIES(stype, eql_data,
+                                    k1, HAMT_IF_VAL(_mzHAMT_VAL(t1, pos1, popcount1), NULL),
+                                    k2, HAMT_IF_VAL(_mzHAMT_VAL(t2, pos2, popcount2), NULL)))
+              return 0;
+          }
+        }
+      }
+      pos1++;
+      HAMT_USE_FUEL();
+      i >>= 1;
+      index++;
+    } else if (i & 0xFF) {
+      i >>= 1;
+      index++;
+    } else {
+      i >>= 8;
+      index += 8;
+    }
+  }
+
+  return 1;
+}
+
+#undef HAMT_NONGCING
+#undef HAMT_SUBSET_OF
+#undef HAMT_ELEMENT_OF
+#undef HAMT_ELEMENT_OF_COLLISION
+#undef HAMT_EQUAL_ENTRIES
+#undef HAMT_IF_VAL
+#undef HAMT_USE_FUEL

racket/src/racket/src/jit_ts.c

@@ -47,7 +47,7 @@ define_ts_s_v(raise_bad_call_with_values, FSRC_MARKS)
 define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_MARKS)
 define_ts_s_s(call_with_values_from_multiple_result, FSRC_MARKS)
 define_ts_S_s(apply_checked_fail, FSRC_MARKS)
-define_ts_Sl_s(scheme_delayed_rename, FSRC_OTHER)
+define_ts_Sl_s(scheme_delayed_shift, FSRC_OTHER)
 define_ts_b_v(scheme_unbound_global, FSRC_MARKS)
 define_ts_ss_v(scheme_set_box, FSRC_MARKS)
 define_ts_iS_s(scheme_checked_car, FSRC_MARKS)
@@ -177,7 +177,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
 # define ts_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity
 # define ts_call_wrong_return_arity call_wrong_return_arity
 # define ts_scheme_unbound_global scheme_unbound_global
-# define ts_scheme_delayed_rename scheme_delayed_rename
+# define ts_scheme_delayed_shift scheme_delayed_shift
 # define ts_scheme_checked_car scheme_checked_car
 # define ts_scheme_checked_cdr scheme_checked_cdr
 # define ts_scheme_checked_caar scheme_checked_caar

racket/src/racket/src/jitcommon.c

@@ -295,13 +295,13 @@ static int common0(mz_jit_state *jitter, void *_data)
   jit_subi_p(JIT_R1, JIT_R1, WORDS_TO_BYTES(1));
   jit_rshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE);
   CHECK_LIMIT();
-  /* Call scheme_delayed_rename: */
+  /* Call scheme_delayed_shift: */
   JIT_UPDATE_THREAD_RSPTR();
   CHECK_LIMIT();
   mz_prepare(2);
   jit_pusharg_l(JIT_R1);
   jit_pusharg_p(JIT_R0);
-  (void)mz_finish_lwe(ts_scheme_delayed_rename, ref2);
+  (void)mz_finish_lwe(ts_scheme_delayed_shift, ref2);
   CHECK_LIMIT();
   jit_retval(JIT_R0);
   /* Restore global array into JIT_R1, and put computed element at i+p+1: */
@@ -1806,8 +1806,8 @@ static int common4(mz_jit_state *jitter, void *_data)
     (void)mz_bnei_t(reffail, JIT_R0, scheme_stx_type, JIT_R2);
     
     /* It's a syntax object... needs to propagate? */
-    jit_ldxi_l(JIT_R2, JIT_R0, &((Scheme_Stx *)0x0)->u.lazy_prefix);
+    jit_ldxi_l(JIT_R2, JIT_R0, &((Scheme_Stx *)0x0)->u.to_propagate);
-    ref = jit_beqi_l(jit_forward(), JIT_R2, 0x0);
+    ref = jit_beqi_p(jit_forward(), JIT_R2, 0x0);
     CHECK_LIMIT();
 
     /* Maybe needs to propagate; check STX_SUBSTX_FLAG flag */

racket/src/racket/src/list.c

@@ -2030,15 +2030,27 @@ Scheme_Hash_Table *scheme_make_hash_table_equal()
   return t;
 }
 
+static int compare_equal_modidx_eq(void *v1, void *v2)
+{
+  return !scheme_equal_modix_eq((Scheme_Object *)v1, (Scheme_Object *)v2);
+}
+
+Scheme_Hash_Table *scheme_make_hash_table_equal_modix_eq()
+{
+  Scheme_Hash_Table *t;
+
+  t = scheme_make_hash_table_equal();
+  t->compare = compare_equal_modidx_eq;
+
+  return t;
+}
+
 Scheme_Hash_Table *scheme_make_hash_table_eqv()
 {
   Scheme_Hash_Table *t;
-  Scheme_Object *sema;
 
   t = scheme_make_hash_table(SCHEME_hash_ptr);
 
-  sema = scheme_make_sema(1);
-  t->mutex = sema;
   t->compare = compare_eqv;
   t->make_hash_indices = make_hash_indices_for_eqv;
 
@@ -2115,6 +2127,15 @@ static Scheme_Object *hash_table_copy(int argc, Scheme_Object *argv[])
     if (t->mutex) scheme_post_sema(t->mutex);
     return o;
   } else if (SCHEME_HASHTRP(v)) {
+    return scheme_hash_tree_copy(v);
+  } else {
+    scheme_wrong_contract("hash-copy", "hash?", 0, argc, argv);
+    return NULL;
+  }
+}
+
+Scheme_Object *scheme_hash_tree_copy(Scheme_Object *v)
+{
   Scheme_Hash_Tree *t;
   Scheme_Hash_Table *naya;
   mzlonglong i;
@@ -2141,10 +2162,6 @@ static Scheme_Object *hash_table_copy(int argc, Scheme_Object *argv[])
   }
 
   return (Scheme_Object *)naya;
-  } else {
-    scheme_wrong_contract("hash-copy", "hash?", 0, argc, argv);
-    return NULL;
-  }
 }
 
 static Scheme_Object *hash_p(int argc, Scheme_Object *argv[])
@@ -2172,7 +2189,7 @@ Scheme_Object *scheme_hash_eq_p(int argc, Scheme_Object *argv[])
         && (((Scheme_Hash_Table *)o)->compare != compare_eqv))
       return scheme_true;
   } else if (SCHEME_HASHTRP(o)) {
-    if (!(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x3))
+    if (SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(o)))
       return scheme_true;
   } else if (SCHEME_BUCKTP(o)) {
     if ((((Scheme_Bucket_Table *)o)->compare != scheme_compare_equal)
@@ -2196,7 +2213,7 @@ Scheme_Object *scheme_hash_eqv_p(int argc, Scheme_Object *argv[])
     if (((Scheme_Hash_Table *)o)->compare == compare_eqv)
       return scheme_true;
   } else if (SCHEME_HASHTRP(o)) {
-    if (SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x2)
+    if (SAME_TYPE(scheme_eqv_hash_tree_type, SCHEME_HASHTR_TYPE(o)))
       return scheme_true;
   } else if (SCHEME_BUCKTP(o)) {
     if (((Scheme_Bucket_Table *)o)->compare == compare_eqv)
@@ -2219,7 +2236,7 @@ Scheme_Object *scheme_hash_equal_p(int argc, Scheme_Object *argv[])
     if (((Scheme_Hash_Table *)o)->compare == scheme_compare_equal)
       return scheme_true;
   } else if (SCHEME_HASHTRP(o)) {
-    if (SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x1)
+    if (SAME_TYPE(scheme_hash_tree_type, SCHEME_HASHTR_TYPE(o)))
       return scheme_true;
   } else if (SCHEME_BUCKTP(o)) {
     if (((Scheme_Bucket_Table *)o)->compare == scheme_compare_equal)
@@ -2243,7 +2260,7 @@ static Scheme_Object *hash_weak_p(int argc, Scheme_Object *argv[])
   else if (SCHEME_HASHTP(o) || SCHEME_HASHTRP(o))
     return scheme_false;
   
-  scheme_wrong_contract("hash-eq?", "hash?", 0, argc, argv);
+  scheme_wrong_contract("hash-weak?", "hash?", 0, argc, argv);
    
   return NULL;
 }
@@ -2260,12 +2277,12 @@ int scheme_is_hash_table_eqv(Scheme_Object *o)
 
 int scheme_is_hash_tree_equal(Scheme_Object *o)
 {
-  return SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x1;
+  return SAME_TYPE(scheme_hash_tree_type, SCHEME_HASHTR_TYPE(o));
 }
 
 int scheme_is_hash_tree_eqv(Scheme_Object *o)
 {
-  return SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x2;
+  return SAME_TYPE(scheme_eqv_hash_tree_type, SCHEME_HASHTR_TYPE(o));
 }
 
 static Scheme_Object *hash_table_put_bang(int argc, Scheme_Object *argv[])
@@ -2379,7 +2396,7 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
         return hash_failed(argc, argv);
     }
   } else if (SCHEME_HASHTRP(v)) {
-    if (!(SCHEME_HASHTR_FLAGS(((Scheme_Hash_Tree *)v)) & 0x3)) {
+    if (SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(v))) {
       v = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)v, argv[1]);
       if (v)
         return v;
@@ -2517,8 +2534,9 @@ static Scheme_Object *hash_table_clear(int argc, Scheme_Object *argv[])
         v = hash_table_remove_bang(2, a);
       }
     }
-  } else
+  } else {
-    return (Scheme_Object *)scheme_make_hash_tree(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)v) & 0x3);
+    return (Scheme_Object *)scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(v));
+  }
 }
 
 static void no_post_key(const char *name, Scheme_Object *key, int chap)
@@ -3052,7 +3070,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
       else {
         /* mode == 4, hash-clear */
         if (SCHEME_HASHTRP(o)) {
-          o = (Scheme_Object *)scheme_make_hash_tree(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)o) & 0x3);
+          o = (Scheme_Object *)scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(o));
           while (wraps) {
             o = transfer_chaperone(SCHEME_CAR(wraps), o);
             wraps = SCHEME_CDR(wraps);

racket/src/racket/src/marshal.c

@@ -768,6 +768,10 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
   
   if (!ds) {
     mt = scheme_current_thread->current_mt;
+    if (mt->pass < 0) {
+      /* nothing to do, yet */
+      ds = scheme_false;
+    } else {
       if (!mt->pass) {
         int key;
 
@@ -820,6 +824,7 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
         mt->cdata_map[pos] = ds;
       }
     }
+  }
 
   /* Encode data->tl_map as either a fixnum or a vector of 16-bit values */
   if (!data->tl_map)
@@ -1075,6 +1080,22 @@ static Scheme_Object *read_local_unbox(Scheme_Object *obj)
   return do_read_local(scheme_local_unbox_type, obj);
 }
 
+static Scheme_Object *make_delayed_syntax(Scheme_Object *stx)
+{
+  Scheme_Object *ds;
+  Scheme_Marshal_Tables *mt;
+  
+  mt = scheme_current_thread->current_mt;
+  if (mt->pass < 0)
+    return stx;
+
+  ds = scheme_alloc_small_object();
+  ds->type = scheme_delay_syntax_type;
+  SCHEME_PTR_VAL(ds) = stx;
+
+  return ds;
+}
+
 static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
 {
   Resolve_Prefix *rp = (Resolve_Prefix *)obj;
@@ -1092,15 +1113,13 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
   while (i--) {
     if (rp->stxes[i]) {
       if (SCHEME_INTP(rp->stxes[i])) {
-        /* Need to foce this object, so we can write it.
+        /* Need to force this object, so we can write it.
            This should only happen if we're writing back 
            code loaded from bytecode. */
         scheme_load_delayed_syntax(rp, i);
       }
 
-      ds = scheme_alloc_small_object();
+      ds = make_delayed_syntax(rp->stxes[i]);
-      ds->type = scheme_delay_syntax_type;
-      SCHEME_PTR_VAL(ds) = rp->stxes[i];
     } else
       ds = scheme_false;
     SCHEME_VEC_ELS(sv)[i] = ds;
@@ -1109,15 +1128,23 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
   tv = scheme_make_pair(scheme_make_integer(rp->num_lifts), 
                         scheme_make_pair(tv, sv));
 
+  tv = scheme_make_pair(rp->src_insp_desc, tv);
+  
   return tv;
 }
 
 static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
 {
   Resolve_Prefix *rp;
-  Scheme_Object *tv, *sv, **a, *stx, *tl;
+  Scheme_Object *tv, *sv, **a, *stx, *tl, *insp_desc;
   intptr_t i;
 
+  if (!SCHEME_PAIRP(obj)) return NULL;
+  insp_desc = SCHEME_CAR(obj);
+  if (!SCHEME_SYMBOLP(insp_desc))
+    return NULL;
+  obj = SCHEME_CDR(obj);
+
   if (!SCHEME_PAIRP(obj)) return NULL;
   
   if (!SCHEME_INTP(SCHEME_CAR(obj))) {
@@ -1181,9 +1208,70 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
   }
   rp->stxes = a;
 
+  rp->src_insp_desc = insp_desc;
+
   return (Scheme_Object *)rp;
 }
 
+static Scheme_Object *ht_to_vector(Scheme_Object *ht)
+/* recurs for values in hash table; we assume that such nesting is shallow */
+{
+  intptr_t i, j, c;
+  Scheme_Object *k, *val, *vec;
+  
+  if (!ht)
+    return scheme_false;
+  if (SCHEME_VECTORP(ht)) {
+    /* may need to force delayed syntax: */
+    c = SCHEME_VEC_SIZE(ht);
+    for (i = 0; i < c; i += 2) {
+      val = SCHEME_VEC_ELS(ht)[i+1];
+      if (!SAME_OBJ(scheme_true, val)) {
+        k = scheme_stx_force_delayed(val);
+        if (!SAME_OBJ(k, val))
+          SCHEME_VEC_ELS(ht)[i+1] = k;
+      }
+    }
+    return ht;
+  }
+
+  if (SCHEME_HASHTRP(ht))
+    c = ((Scheme_Hash_Tree *)ht)->count;
+  else
+    c = ((Scheme_Hash_Table *)ht)->count;
+
+  vec = scheme_make_vector(2 * c, NULL);
+  j = 0;
+  
+  if (SCHEME_HASHTRP(ht)) {
+    Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)ht;
+    for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) {
+      scheme_hash_tree_index(t, i, &k, &val);
+      if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val))
+        val = ht_to_vector(val);
+      else if (!SAME_OBJ(val, scheme_true))
+        val = make_delayed_syntax(val);
+      SCHEME_VEC_ELS(vec)[j++] = k;
+      SCHEME_VEC_ELS(vec)[j++] = val;
+    }
+  } else {
+    Scheme_Hash_Table *t = (Scheme_Hash_Table *)ht;
+    for (i = t->size; i--; ) {
+      if (t->vals[i]) {
+        val = t->vals[i];
+        if (SCHEME_HASHTRP(val) || SCHEME_HASHTP(val))
+          val = ht_to_vector(val);
+        else if (!SAME_OBJ(val, scheme_true))
+          val = make_delayed_syntax(val);
+        SCHEME_VEC_ELS(vec)[j++] = t->keys[i];
+        SCHEME_VEC_ELS(vec)[j++] = val;
+      }
+    }
+  }
+
+  return vec;
+}
+
 static Scheme_Object *write_module(Scheme_Object *obj)
 {
   Scheme_Module *m = (Scheme_Module *)obj;
@@ -1332,8 +1420,12 @@ static Scheme_Object *write_module(Scheme_Object *obj)
   v = m->rn_stx;
   if (!v)
     v = scheme_false;
-  else if (SCHEME_PAIRP(v))
+  else if (!SAME_OBJ(v, scheme_true)) {
-    v = scheme_list_to_vector(v);
+    v = scheme_stx_force_delayed(v);
+    if (!SAME_OBJ(v, m->rn_stx))
+      m->rn_stx = v;
+    v = make_delayed_syntax(v);
+  }
   l = cons(v, l);
 
   /* previously recorded "functional?" info: */
@@ -1361,7 +1453,11 @@ static Scheme_Object *write_module(Scheme_Object *obj)
 
   l = cons((m->phaseless ? scheme_true : scheme_false), l);
 
+  l = cons(ht_to_vector(m->other_binding_names), l);
+  l = cons(ht_to_vector(m->et_binding_names), l);
+  l = cons(ht_to_vector(m->binding_names), l);
   l = cons(m->me->src_modidx, l);
+  
   l = cons(scheme_resolved_module_path_value(m->modsrc), l);
   l = cons(scheme_resolved_module_path_value(m->modname), l);
 
@@ -1394,7 +1490,7 @@ static int check_requires_ok(Scheme_Object *l)
 static Scheme_Object *read_module(Scheme_Object *obj)
 {
   Scheme_Module *m;
-  Scheme_Object *ie, *nie, **bodies;
+  Scheme_Object *ie, *nie, **bodies, *bns;
   Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
   Scheme_Module_Exports *me;
   Scheme_Module_Phase_Exports *pt;
@@ -1439,6 +1535,30 @@ static Scheme_Object *read_module(Scheme_Object *obj)
   ((Scheme_Modidx *)me->src_modidx)->resolved = m->modname;
   m->self_modidx = me->src_modidx;
 
+  if (!SCHEME_PAIRP(obj)) return_NULL();
+  bns = SCHEME_CAR(obj);
+  if (!SCHEME_FALSEP(bns)) {
+    if (!SCHEME_VECTORP(bns)) return_NULL();
+    m->binding_names = bns;
+  }
+  obj = SCHEME_CDR(obj);
+
+  if (!SCHEME_PAIRP(obj)) return_NULL();
+  bns = SCHEME_CAR(obj);
+  if (!SCHEME_FALSEP(bns)) {
+    if (!SCHEME_VECTORP(bns)) return_NULL();
+    m->et_binding_names = bns;
+  }
+  obj = SCHEME_CDR(obj);
+
+  if (!SCHEME_PAIRP(obj)) return_NULL();
+  bns = SCHEME_CAR(obj);
+  if (!SCHEME_FALSEP(bns)) {
+    if (!SCHEME_VECTORP(bns)) return_NULL();
+    m->other_binding_names = bns;
+  }
+  obj = SCHEME_CDR(obj);
+
   if (!SCHEME_PAIRP(obj)) return_NULL();
   m->phaseless = (SCHEME_TRUEP(SCHEME_CAR(obj)) ? scheme_true : NULL);
   obj = SCHEME_CDR(obj);

racket/src/racket/src/mzmark_compenv.inc

@@ -2,61 +2,55 @@
 
 static int mark_comp_env_SIZE(void *p, struct NewGC *gc) {
   return
-  gcBYTES_TO_WORDS(sizeof(Scheme_Full_Comp_Env));
+  gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
 }
 
 static int mark_comp_env_MARK(void *p, struct NewGC *gc) {
-  Scheme_Full_Comp_Env *e = (Scheme_Full_Comp_Env *)p;
+  Scheme_Comp_Env *e = (Scheme_Comp_Env *)p;
 
-  gcMARK2(e->base.genv, gc);
+  gcMARK2(e->genv, gc);
-  gcMARK2(e->base.insp, gc);
+  gcMARK2(e->insp, gc);
-  gcMARK2(e->base.prefix, gc);
+  gcMARK2(e->prefix, gc);
-  gcMARK2(e->base.next, gc);
+  gcMARK2(e->next, gc);
-  gcMARK2(e->base.values, gc);
+  gcMARK2(e->scopes, gc);
-  gcMARK2(e->base.renames, gc);
+  gcMARK2(e->binders, gc);
-  gcMARK2(e->base.uid, gc);
+  gcMARK2(e->bindings, gc);
-  gcMARK2(e->base.uids, gc);
+  gcMARK2(e->vals, gc);
-  gcMARK2(e->base.dup_check, gc);
+  gcMARK2(e->shadower_deltas, gc);
-  gcMARK2(e->base.intdef_name, gc);
+  gcMARK2(e->dup_check, gc);
-  gcMARK2(e->base.in_modidx, gc);
+  gcMARK2(e->intdef_name, gc);
-  gcMARK2(e->base.skip_table, gc);
+  gcMARK2(e->in_modidx, gc);
+  gcMARK2(e->skip_table, gc);
   
-  gcMARK2(e->data.const_names, gc);
+  gcMARK2(e->use, gc);
-  gcMARK2(e->data.const_vals, gc);
+  gcMARK2(e->lifts, gc);
-  gcMARK2(e->data.const_uids, gc);
-  gcMARK2(e->data.sealed, gc);
-  gcMARK2(e->data.use, gc);
-  gcMARK2(e->data.lifts, gc);
 
   return
-  gcBYTES_TO_WORDS(sizeof(Scheme_Full_Comp_Env));
+  gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
 }
 
 static int mark_comp_env_FIXUP(void *p, struct NewGC *gc) {
-  Scheme_Full_Comp_Env *e = (Scheme_Full_Comp_Env *)p;
+  Scheme_Comp_Env *e = (Scheme_Comp_Env *)p;
 
-  gcFIXUP2(e->base.genv, gc);
+  gcFIXUP2(e->genv, gc);
-  gcFIXUP2(e->base.insp, gc);
+  gcFIXUP2(e->insp, gc);
-  gcFIXUP2(e->base.prefix, gc);
+  gcFIXUP2(e->prefix, gc);
-  gcFIXUP2(e->base.next, gc);
+  gcFIXUP2(e->next, gc);
-  gcFIXUP2(e->base.values, gc);
+  gcFIXUP2(e->scopes, gc);
-  gcFIXUP2(e->base.renames, gc);
+  gcFIXUP2(e->binders, gc);
-  gcFIXUP2(e->base.uid, gc);
+  gcFIXUP2(e->bindings, gc);
-  gcFIXUP2(e->base.uids, gc);
+  gcFIXUP2(e->vals, gc);
-  gcFIXUP2(e->base.dup_check, gc);
+  gcFIXUP2(e->shadower_deltas, gc);
-  gcFIXUP2(e->base.intdef_name, gc);
+  gcFIXUP2(e->dup_check, gc);
-  gcFIXUP2(e->base.in_modidx, gc);
+  gcFIXUP2(e->intdef_name, gc);
-  gcFIXUP2(e->base.skip_table, gc);
+  gcFIXUP2(e->in_modidx, gc);
+  gcFIXUP2(e->skip_table, gc);
   
-  gcFIXUP2(e->data.const_names, gc);
+  gcFIXUP2(e->use, gc);
-  gcFIXUP2(e->data.const_vals, gc);
+  gcFIXUP2(e->lifts, gc);
-  gcFIXUP2(e->data.const_uids, gc);
-  gcFIXUP2(e->data.sealed, gc);
-  gcFIXUP2(e->data.use, gc);
-  gcFIXUP2(e->data.lifts, gc);
 
   return
-  gcBYTES_TO_WORDS(sizeof(Scheme_Full_Comp_Env));
+  gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
 }
 
 #define mark_comp_env_IS_ATOMIC 0