diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 38e189d6db..69f2d6e348 100644 --- a/pkgs/base/info.rkt +++ b/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])) diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/places/place-processes.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/places/place-processes.rkt index 33d53b1a81..040dedc449 100644 --- a/pkgs/racket-benchmarks/tests/racket/benchmarks/places/place-processes.rkt +++ b/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") diff --git a/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl b/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl index 260e42afd2..8f3b305c4b 100644 --- a/pkgs/racket-doc/scribblings/raco/zo-parse.scrbl +++ b/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.} diff --git a/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl b/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl index bd9644c7f9..4abf87bca2 100644 --- a/pkgs/racket-doc/scribblings/raco/zo-struct.scrbl +++ b/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?])]{ - Wraps a syntax object in a @racket[prefix].} +@defstruct+[(stx zo) ([content stx-obj?])]{ + 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) ()]{ - A supertype for lexical-information elements.} + The content of @racket[wrap] is typically cyclic, since it includes + scopes that contain bindings that refer to scopes.} -@defstruct+[(top-level-rename wrap) ([flag boolean?])]{ - A top-level renaming.} +@defstruct+[(wrap zo) ([shifts (listof module-shift?)] + [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?])]{ - A mark barrier.} +@defstruct+[(module-shift zo) ([from (or/c #f module-path-index?)] + [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) - ([path0 module-path-index?] - [symbol0 symbol?] - [path1 module-path-index?] - [symbol1 symbol?] - [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.} +Records a history of module path index replacements. These replacements +are applied in reverse order, and a module instantiation typically adds +one more shift to replace the current ``self'' module path index +with a run-time module path. The @racket[from] and @racket[to] +fields should be both @racket[#f] or both non-@racket[#f]. -@defstruct+[(lexical-rename wrap) - ([has-free-id-info? boolean?] - [bool2 boolean?] - [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.} +The @racket[from-inspector-desc] and @racket[to-inspector-desc] fields +similarly should be both @racket[#f] or both non-@racket[#f]. They +record a history of code-inspector replacements.} -@defstruct+[(phase-shift wrap) - ([amt (or/c exact-integer? #f)] - [src module-path-index?] - [dest module-path-index?] - [cancel-id (or/c exact-integer? #f)])]{ - Shifts module bindings later in the wrap set.} +@defstruct+[(scope zo) ([name (or/c 'root exact-nonnegative-integer?)] + [kind symbol?] + [bindings (listof (list/c symbol? (listof scope?) binding?)) #;#:mutable] + [bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #;#:mutable] + [multi-owner (or/c #f multi-scope?) #;#:mutable])]{ -@defstruct+[(module-rename wrap) - ([phase exact-integer?] - [kind (or/c 'marked 'normal)] - [set-id any/c] - [unmarshals (listof make-all-from-module?)] - [renames (listof module-binding?)] - [mark-renames any/c] - [plus-kern? boolean?])]{ - Represents a set of module and import bindings.} +Represents a scope. When @racket[name] is @racket['root] then the +scope represents the unique all-phases scope that is shared among +non-module namespaces. Otherwise, @racket[name] is intended to be +distinct for each @racket[scope] instance within a module or top-level +compilation, but the @racket[eq?]-identity of the @racket[scope] +instance ultimately determines its identity. The @racket[kind] symbol +similarly acts as a debugging hint in the same way as for +@racket[syntax-debug-info]. -@defstruct+[(all-from-module zo) - ([path module-path-index?] - [phase (or/c exact-integer? #f)] - [src-phase (or/c exact-integer? #f)] - [exceptions (listof symbol?)] - [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].} +The @racket[bindings] list indicates some bindings that are associated +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. -@defstruct+[(module-binding zo) ()]{ - A supertype for module bindings.} +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. -@defstruct+[(simple-module-binding module-binding) - ([path module-path-index?])]{ - Represents a single identifier import within a - @racket[module-rename].} +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+[(phased-module-binding module-binding) - ([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) - ([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+[(multi-scope zo) ([name exact-nonnegative-integer?] + [src-name any/c] + [scopes (listof (list/c (or/c #f exact-integer?) scope?)) #;#:mutable])]{ -@defstruct+[(nominal-module-binding module-binding) - ([path module-path-index?] - [nominal-path nominal-path?])]{ - Represents a single identifier import within a - @racket[module-rename].} +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]. -@defstruct+[(exported-module-binding module-binding) - ([path module-path-index?] - [export-name any/c])]{ - Represents a single identifier import within a - @racket[module-rename].} +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+[(nominal-path zo) ()]{ - A supertype for nominal paths.} -@defstruct+[(simple-nominal-path nominal-path) - ([value module-path-index?])]{ - Represents a simple nominal path.} +@defstruct+[(binding zo) ()]{ -@defstruct+[(imported-nominal-path nominal-path) - ([value module-path-index?] - [import-phase exact-integer?])]{ - Represents an imported nominal path.} +A supertype for all binding representations.} -@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.} + +@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)])]{ + +Describes a bulk import as an optimization over individual imports of +a module's exports: + +@itemlist[ + + @item{@racket[path]: the imported module.} + + @item{@racket[phase]: the phase of the import module's exports.} + + @item{@racket[src-phase]: the phase at which @racket[path] was + imported; @racket[src-phase] combined with @racket[phase] + determines the phase of the bindings.} + + @item{@racket[inspector-desc]: a name for an inspector (mapped to a + specific inspector at run time) that determines access to the + definition.} + + @item{@racket[exceptions]: exports of @racket[path] that are omitted + from the bulk import.} + + @item{@racket[prefix]: a prefix, if any, applied (after + @racket[exceptions]) to each of the imported names.} + +]} + + diff --git a/pkgs/racket-doc/scribblings/reference/define-struct.scrbl b/pkgs/racket-doc/scribblings/reference/define-struct.scrbl index 36d8e4e849..033e301c1d 100644 --- a/pkgs/racket-doc/scribblings/reference/define-struct.scrbl +++ b/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 -binding} of @racket[id] records @racket[constructor-id] as the +If @racket[constructor-id] is supplied, then the @tech{transformer} +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 diff --git a/pkgs/racket-doc/scribblings/reference/logging.scrbl b/pkgs/racket-doc/scribblings/reference/logging.scrbl index a5ed15815a..407298492b 100644 --- a/pkgs/racket-doc/scribblings/reference/logging.scrbl +++ b/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)]{ diff --git a/pkgs/racket-doc/scribblings/reference/notation.scrbl b/pkgs/racket-doc/scribblings/reference/notation.scrbl index 645e213c7b..c1754f057d 100644 --- a/pkgs/racket-doc/scribblings/reference/notation.scrbl +++ b/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 diff --git a/pkgs/racket-doc/scribblings/reference/shared.scrbl b/pkgs/racket-doc/scribblings/reference/shared.scrbl index bb9bac5650..e2fad691e4 100644 --- a/pkgs/racket-doc/scribblings/reference/shared.scrbl +++ b/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]. diff --git a/pkgs/racket-doc/scribblings/reference/struct.scrbl b/pkgs/racket-doc/scribblings/reference/struct.scrbl index 89fc460e86..bf41e7843b 100644 --- a/pkgs/racket-doc/scribblings/reference/struct.scrbl +++ b/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 diff --git a/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl b/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl index 3ccc054c27..9da779d421 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl +++ b/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] diff --git a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl b/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl index e153c38eb9..2c017a3092 100644 --- a/pkgs/racket-doc/scribblings/reference/stx-trans.scrbl +++ b/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?] - [delta-introduce (identifier? . -> . identifier?) - (lambda (id) id)]) +@defproc[(make-rename-transformer [id-stx syntax?]) 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 - @racket[syntax-local-make-delta-introducer] functions recognize + @item{The @racket[syntax-local-value] function recognizes 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 -or marks that were not present for the original expansion, in which +@exnraise[exn:fail:syntax] if the expansion context includes +@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 -added; if an unsealed @tech{internal-definition context} is detected -in a fully expanded expression, the @exnraise[exn:fail:contract]. + +An @tech{internal-definition context} internally creates a +@tech{scope} to represent the context. Unless @racket[add-scope?] is +@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 -in the new internal-definition context can use bindings previously -introduced into @racket[intdef-ctx]. +internal-definition context extends the given one. An extending +definition context adds all @tech{scopes} that are added by +@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 -@racket[intdef-ctx], which must not be sealed already. See also -@racket[syntax-local-make-definition-context].} +For backward compatibility only; has no effect.} @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 -@tech{lexical information} of @racket[id-stx]. This operation is -useful for correlating an identifier that is bound in an -internal-definition context with its binding before the -internal-definition context was created. +Removes all of the @tech{scopes} of @racket[intdef-ctx] (or of each +element in a list @racket[intdef-ctx]) from @racket[id-stx]. -If simply removing the contexts produces a different binding than -completely ignoring the contexts (due to nested internal definition -contexts, for example), then the resulting identifier is given a -@tech{syntax mark} to simulate a non-existent lexical context. The -@racket[intdef-ctx] argument can be a list because removing -internal-definition contexts one at a time can produce a different -intermediate binding than removing them all at once.} +The @racket[identifier-remove-from-definition-context] function is +provided for backward compatibility; the more general +@racket[internal-definition-context-introduce] function is preferred. + +@history[#:changed "6.3" @elem{Simplified the operation to @tech{scope} removal.}]} @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 -shadows @racket[id-stx] (ignoring unsealed @tech{internal-definition -contexts} and identifiers that had the @indexed-racket['unshadowable] -@tech{syntax property}), if @racket[id-stx] has no module bindings in -its lexical information, and if the current expansion context is not a -@tech{module context}. +Adds @tech{scopes} to @racket[id-stx] so that it refers to bindings +in the current expansion context or could bind any identifier obtained +via @racket[(syntax-local-get-shadower id-stx)] in more nested contexts. +If @racket[only-generated?] is true, the phase-spanning @tech{scope} +of the enclosing module or namespace is omitted from the added scopes, +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 -result is the same as @racket[(syntax-local-get-shadower -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. +This function is intended for the implementation of +@racket[syntax-parameterize] and @racket[local-require]. -Otherwise, the result is the same as @racket[id-stx] with its module -bindings (if any) removed from its lexical information, and the -lexical information of the current @tech{module context} (if any) -added. +@transform-time[] -Thus, the result is an identifier corresponding to the innermost -shadowing of @racket[id-stx] in the current context if it is shadowed, -and a module-contextless version of @racket[id-stx] otherwise. +@history[#:changed "6.3" @elem{Simplified to the minimal functionality + needed for @racket[syntax-parameterize] + 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 -@tech{syntax mark} for the current expansion is added (possibly -canceling an existing mark in parts of @racket[stx]). See -@secref["transformer-model"] for information on @tech{syntax -marks}. +Produces a syntax object that is like @racket[stx], except that the +presence of @tech{scopes} for the current expansion---both the. See +@secref["transformer-model"] for information on @tech{scopes}. @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 -@racket[syntax-local-introduce], but using the @tech{syntax marks} of -@racket[ext-stx] that are not shared with @racket[base-stx]. If -@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. +Produces a procedure that behaves like the result of +@racket[make-syntax-introducer], but using the @tech{scopes} of +@racket[ext-stx] that are not shared with @racket[base-stx]. 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 diff --git a/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl b/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl index a7f89fc0db..84c3f5c033 100644 --- a/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl +++ b/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 -some are quoted to produce a symbol or a syntax object. +correspond to @tech{variables}, some refer to @tech{syntactic forms} +(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 -@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 +For example, as a fragment 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 -@tech{environment}, @racket[x] turns out to represent a -@tech{variable} (unlike @racket[let]). In particular, the first -@racket[x] @tech{binds} the second @racket[x]. +appears twice). When this source is parsed in a context where +@racket[let] has its usual meaning, the first @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}. -There is no difference between an @deftech{unbound} -identifier and one with a @tech{top-level binding}; within a module, -references to @tech{top-level bindings} are disallowed, and so such -identifiers are called @tech{unbound} in a module context. +definition in a module; all other bindings are @deftech{local +bindings}. Within a module, references to @tech{top-level bindings} +are disallowed. An identifier without a binding is @deftech{unbound}. Throughout the documentation, @tech{identifiers} are typeset to -suggest the way that they are parsed. A black, boldface -@tech{identifier} like @racket[lambda] indicates a reference to a -syntactic form. A plain blue @tech{identifier} like @racketidfont{x} -is a @tech{variable} or a reference to an unspecified @tech{top-level -variable}. A hyperlinked @tech{identifier} @racket[cons] is a -reference to a specific @tech{top-level variable}. +suggest the way that they are parsed. A hyperlinked identifier +like @racket[lambda] indicates a reference to a syntactic form or +variable. A plain identifier like @racketidfont{x} is a +@tech{variable} or a reference to an unspecified @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 -all phase levels, though the reference is allowed only at a particular -phase level. Attempting to reference a @tech{local binding} in a -different @tech{phase level} from the binding's context produces a -syntax error. If an identifier has a @tech{top-level binding} or -@tech{module binding}, then it can have different such bindings in -different phase levels. +An identifier can have different bindings in different @tech{phase +levels}. More precisely, the @tech{scope set} associated with a +@tech{form} can be different at different phase levels; a top-level or +module context implies a distinct scope at every phase level, while +scopes from macro expansion or other syntactic forms are added to a +form's @tech{scope sets} at all phases. The context of each binding +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 -other information. +represented as a syntax object that combines a @tech{symbol} with scope sets +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 -information that @racket[_datum] had when it was parsed as part of the -@racket[quote-syntax] form. +_datum #:local)] produces a syntax object that preserves all of the +lexical information that @racket[_datum] had when it was parsed as +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[_datum] in a @racket[quote-syntax] form, however, always +@racket[module] or @racket[module*] form for the body of the @racket[module] +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 -appear in a fully local-expanded expression, as can -@racket[#%expression] in any expression position. For example, -@racket[letrec-syntaxes+values] and @racket[#%expression] can appear -in the result from @racket[local-expand] when the stop list is empty. +A reference to a @tech{local binding} in a fully expanded program has +a @tech{scope set} that matches its binding identifier exactly. +Additional @tech{scopes}, if any, are removed. As a result, +@racket[bound-identifier=?] can be used to correlate local binding +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} is used to continue. If the @tech{identifier} - has no @tech{binding}, a new @tech{syntax-object} symbol + @tech{binding}, that @tech{binding} is used to continue. If the @tech{identifier} + is @tech{unbound}, 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{top-level variable}), then parsing fails with an + @tech{identifier} has no @tech{binding}, 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 - level or the specific module's level is extended with bindings - from the specified modules. If not otherwise indicated in the + module level, each symbol specified by the form is paired with the + @tech{scope set} of the specification to introduce new bindings. + 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 - information derived from the top level or the specific module's - level is extended with bindings for the specified identifiers - at @tech{phase level} 0 (i.e., the @tech{base environment} is - extended).} + encountered at the top level or module level, a binding is + added @tech{phase level} 0 (i.e., the @tech{base environment} + is extended) for each defined identifier.} @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 - identifiers. The same bindings are added to the identifiers + @tech{syntax objects}) with a fresh @tech{scope}. The @tech{scope} is 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 -expansion where the @racket[let-values] form is encountered) the -binding @racket[x] and the body @racket[y] are not -@racket[bound-identifier=?]. +body, because a fresh @tech{scope} is created and added to both the binding +@racket[x] and reference @racket[x]. The same scope is added to the +@racket[y], but since it has a different symbol than the binding +@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 -binding}. The @tech{value} of the @tech{binding} exists at expansion +it introduces for the defined identifiers is a @tech{transformer} +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 -applies to all sub-@tech{syntax objects}). The result of the -transformer is similarly extended with the same @tech{syntax -mark}. When a @tech{syntax object}'s @tech{lexical information} -includes the same mark twice in a row, the marks effectively -cancel. Otherwise, two identifiers are @racket[bound-identifier=?] -(that is, one can bind the other) only if they have the same binding -and if they have the same marks---counting only marks that were added -after the binding. +the @tech{syntax object} is extended with a fresh @tech{scope} (that +applies to all sub-@tech{syntax objects}) to distinguish @tech{syntax objects} +at the macro's use site from @tech{syntax objects} that are introduced by the macro; +in the result of the transformer the presence of the @tech{scope} is +flipped, so that introduced @tech{syntax objects} retain the @tech{scope}, +and use-site @tech{syntax objects} do not have it. In addition, if +the use of a transformer is in the same definition context as its binding, +the use-site @tech{syntax object} is extended with an additional fresh +@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 -consistent with the lexical structure of the source program. For -example, the expanded form of the program +The @tech{scope}-introduction process for macro expansion helps keep +binding in an expanded program consistent with the lexical structure +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 - (syntax-rules () - [(_ id) (let ([x 10]) id)])) +(define-syntax m ....) (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 -contains the binding of @racket[_id] is also enriched so that -@racket[_id] is @racket[free-identifier=?] to the target identifier, -@racket[identifier-binding] returns the same results for both -identifiers, and @racket[provide] exports @racket[_id] as the target -identifier. Finally, the binding is treated specially by -@racket[syntax-local-value], and -@racket[syntax-local-make-delta-introducer] as used by @tech{syntax -transformer}s. +@racket['not-free-identifier=?] @tech{syntax property}, the +binding table is extended to indicate that @racket[_id] is an alias +for the identifier in the @tech{rename transformer}. The +@racket[free-identifier=?] function follows aliasing chains to determine +equality of bindings, the @racket[identifier-binding] function +similarly follows aliasing chains, and the @racket[provide] form +exports @racket[_id] as the target identifier. Finally, the +@racket[syntax-local-value] function follows @tech{rename transformer} +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 each @racket[_body] in an internal-definition sequence. -Partial expansion of each @racket[_body] produces a form matching one -of the following cases: +Expansion of an internal-definition context begins with the +introduction of a fresh @tech{scope} for the context. Thereafter, +expansion relies on @tech{partial expansion} of each @racket[_body] in +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 - syntax objects for the body sequence is immediately enriched + @item{A @racket[define-values] form: The binding table 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 - with expansion in @tech{internal-definition contexts}, where the - defined identifier turns into a fresh lexical binding. + that are generated by the same expansion due to the fresh @tech{scope} + that is generated for the expansion. @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 - definition were not present. (No such dependency on order occurs + the use is resolved with the bindings that are in place that at + 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} - clauses also introduce and reference generation-specific bindings: +Macro-generated @racket[require] and @racket[provide] + 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 - uses of the identifier generated by the same macro expansion as - @racket[_bind-id]. In @racket[require] for other + .... [_orig-id _bind-id])], the @racket[_bind-id] supplies the + @tech{scope set} for the binding. 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 - external name is the plain @racket[_id]. The exceptions for - @racket[all-except-out] are similarly determined in a - generator-specific way, as is the @racket[_orig-id] binding of a - @racket[rename-out] form, but plain identifiers are used for the + @racket[_id], but the + external name is the plain, symbolic part of @racket[_id]. The exceptions for + @racket[all-except-out] are similarly determined, as is the @racket[_orig-id] binding of a + @racket[rename-out] form, and plain symbols 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 -information. It is the starting point for expanding an expression; a -@tech{syntax object} produced by @racket[read-syntax] has no initial -lexical context; the @tech{syntax object} can be expanded after -initializing it with the mappings of a particular namespace. A -namespace is also the starting point evaluating expanded code, where -the first step in evaluation is linking the code to specific module -instances and top-level variables. +A @deftech{namespace} is both a starting point for parsing and a +starting point for running @tech{compiled} code. A @tech{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, and it applies both to parsing and +to running @tech{compiled} code. -For expansion purposes, a namespace maps each symbol in each -@tech{phase level} to one of three possible bindings: +As a starting point for parsing, a @tech{namespace} provides scopes +(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[ - - @item{a particular @tech{module binding} from a particular module} - - @item{a top-level transformer binding named by the symbol} - - @item{a top-level variable named by the symbol} - -] - -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}. +As a starting point evaluating @tech{compiled} code, 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} diff --git a/pkgs/racket-doc/scribblings/reference/syntax.scrbl b/pkgs/racket-doc/scribblings/reference/syntax.scrbl index 4cde7ca846..b195d68931 100644 --- a/pkgs/racket-doc/scribblings/reference/syntax.scrbl +++ b/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 -@racket[module*] form shift the @tech{phase level} of the enclosing -module's bindings relative to the submodule. When a -@racket[module*] form has a @racket[module-path], the submodule -starts with an empty lexical context in the same way as a top-level -@racket[module] form, and enclosing @racket[begin-for-syntax] forms -have no effect on the submodule.} +the submodule. In that case, @racket[begin-for-syntax] forms that wrap +the @racket[module*] form shift the @tech{phase level} of the +enclosing module's bindings relative to the submodule. The macro +expander handles such nesting by shifting the @tech{phase level} of +the @racket[module*] form so that it's body starts at @tech{phase +level} 0, expanding, and then reverting the @tech{phase level} shift; +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 -local binding in its context, then @racket[(#%top . id)] refers to a -top-level definition, but a reference to a top-level definition is -disallowed within a module. +Equivalent to @racket[id] when @racket[id] is bound to a module-level +or top-level variable. In a top-level context, @racket[(#%top . id)] +always refers to a top-level variable, even if @racket[id] is +@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-syntaxes+values] can appear in the result of -@racket[local-expand] with an empty stop list. +@racket[letrec-values] or @racket[let-values]. 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]} diff --git a/pkgs/racket-test-core/tests/racket/boundmap-test.rktl b/pkgs/racket-test-core/tests/racket/boundmap-test.rktl index 22a4775009..b3abe71aa0 100644 --- a/pkgs/racket-test-core/tests/racket/boundmap-test.rktl +++ b/pkgs/racket-test-core/tests/racket/boundmap-test.rktl @@ -144,11 +144,10 @@ (set! l (cons y l)))) l))))) -(let () - (define-syntax name 'dummy) - (define-syntax alias (make-rename-transformer #'name)) - (define table (make-free-identifier-mapping)) - (free-identifier-mapping-put! table #'alias 0) - (test 0 free-identifier-mapping-get table #'name)) +(define-syntax name-for-boundmap-test 'dummy) +(define-syntax alias-for-boundmap-test (make-rename-transformer #'name-for-boundmap-test)) +(define table (make-free-identifier-mapping)) +(free-identifier-mapping-put! table #'alias-for-boundmap-test 0) +(test 0 free-identifier-mapping-get table #'name-for-boundmap-test) (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/id-table-test.rktl b/pkgs/racket-test-core/tests/racket/id-table-test.rktl index 1b80ea5f9b..f824b89c6e 100644 --- a/pkgs/racket-test-core/tests/racket/id-table-test.rktl +++ b/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 b #'b) - (define b2 (let ([b 0]) #'b)) - (define b3 ((make-syntax-introducer) #'b)) ;; free=? to b + (define i (make-syntax-introducer)) + (define a (i #'a)) + (define b (i #'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 'dummy) - (define-syntax alias (make-rename-transformer #'name)) - (define table (make-free-id-table)) - (free-id-table-set! table #'alias 0) - (test 0 free-id-table-ref table #'name)) +(define-syntax name-for-boundmap-test 'dummy) +(define-syntax alias-for-boundmap-test (make-rename-transformer #'name-for-boundmap-test)) +(define table (make-free-id-table)) +(free-id-table-set! table #'alias-for-boundmap-test 0) +(test 0 free-id-table-ref table #'name-for-boundmap-test) (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index 4cf34d1bea..8f05db53b8 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/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) - #`(quote-syntax #,(syntax-local-get-shadower #'x)))]) + (let-syntax ([m (lambda () + (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))))) +(eval-syntax + #'(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)]) - (list q - (identifier-binding #'q) - (free-identifier=? #'q #'x))) + (define-syntax v (make-rt #'x)) + (list v + (identifier-binding #'v) + (free-identifier=? #'v #'x)) - (let ([w 11]) - (letrec-syntax ([q (let () - (define-struct rt () - #:property prop:rename-transformer #'w) - (make-rt))]) - (list q - (identifier-binding #'q) - (free-identifier=? #'q #'w)))) + (define w 11) + (define-syntax q (let () + (define-struct rt () + #:property prop:rename-transformer #'w) + (make-rt))) + (list q + (identifier-binding #'q) + (free-identifier=? #'q #'w)) - (letrec-syntax ([n (make-rename-transformer #'glob)]) - (list (identifier-binding #'n) - (free-identifier=? #'n #'glob))) - - (letrec-syntax ([i (make-rename-transformer #'glob)]) - (letrec-syntax ([n (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f))]) - (list (identifier-binding #'n) - (free-identifier=? #'n #'glob))))) + (define-syntax n1 (make-rename-transformer #'glob)) + (list (identifier-binding #'n1) + (free-identifier=? #'n1 #'glob)) + + (define-syntax i (make-rename-transformer #'glob)) + (define-syntax n2 (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f))) + (list (identifier-binding #'n2) + (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) diff --git a/pkgs/racket-test-core/tests/racket/modprot.rktl b/pkgs/racket-test-core/tests/racket/modprot.rktl index aa7bd41d42..1a132cba8b 100644 --- a/pkgs/racket-test-core/tests/racket/modprot.rktl +++ b/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)))]) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index a6238085e8..2542ec806d 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/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,17 +231,22 @@ (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) - (namespace-attach-module n ''f) - (test finished values l) - (parameterize ([current-namespace (make-empty-namespace)]) - (namespace-attach-module n ''f) - (test finished values l) - (namespace-require 'racket/base) - (eval `(require 'a)) - (eval `(require 'f)) - (test (list* 'd 'b 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) + (parameterize ([current-namespace (make-empty-namespace)]) + (namespace-attach-module n ''f) + (test finished values l) + (namespace-require 'racket/base) + (eval `(require 'a)) + (eval `(require 'f)) + (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 diff --git a/pkgs/racket-test-core/tests/racket/namespac.rktl b/pkgs/racket-test-core/tests/racket/namespac.rktl index bf57cbaaaa..809fdaf3d9 100644 --- a/pkgs/racket-test-core/tests/racket/namespac.rktl +++ b/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) diff --git a/pkgs/racket-test-core/tests/racket/object.rktl b/pkgs/racket-test-core/tests/racket/object.rktl index f9b2ddbaed..1a7d6941e4 100644 --- a/pkgs/racket-test-core/tests/racket/object.rktl +++ b/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 . (1 2 3)))) - (syntax-test #'(send+ (new c%) (m 5) (m . (1 2 3)))) + (syntax-test #'(send+ (new c%) m 5)) + (syntax-test #'(send+ (new c%) . 5)) (test #t object? (send+ (new c%) (m 5) (m 15))) (test #t object? (send+ (new c%) (m 5) (m . (1 2 3 4))))) diff --git a/pkgs/racket-test-core/tests/racket/read.rktl b/pkgs/racket-test-core/tests/racket/read.rktl index 8e0d4690af..8348d7783e 100644 --- a/pkgs/racket-test-core/tests/racket/read.rktl +++ b/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 diff --git a/pkgs/racket-test-core/tests/racket/sandbox.rktl b/pkgs/racket-test-core/tests/racket/sandbox.rktl index 0d4a8decab..531fe14940 100644 --- a/pkgs/racket-test-core/tests/racket/sandbox.rktl +++ b/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> R) (test `(vals: ,R) run (thunk (ev `E)))] - [(t --top-- E => R) (test `(vals: ,R) run (thunk E))] - [(t --eval-- E =err> R) (test #t e-match? R run (thunk (ev `E)))] - [(t --top-- E =err> R) (test #t e-match? R run (thunk E))] + [(t --eval-- E) (test #t run* (thunk E (ev `E)))] + [(t --top-- E) (test #t run* (thunk E E))] + [(t --eval-- E => R) (test `(vals: ,R) run (thunk E (ev `E)))] + [(t --top-- E => R) (test `(vals: ,R) run (thunk E 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 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)) diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index 620f1c7d1e..4014ea0f97 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/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 alias (make-rename-transformer #'name)) - (test (identifier-binding-symbol #'name) - identifier-binding-symbol #'alias)) +(define-syntax @$@name 'dummy) +(define-syntax @$@alias (make-rename-transformer #'@$@name)) +(test (identifier-binding-symbol #'@$@name) + 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 - (provide ++y ++y-macro ++y-macro2 ++u-macro ++u2)) + (define ++u 8) ; would be unexported, but export of rename transformer exports it + (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,18 +1460,18 @@ (provide @!$get)) (require '@!$m) (test '(10 20 #t) '@!$get @!$get) +|# -(unless building-flat-tests? - (test '(12) - eval - (expand - #'(let ([b 12]) - (let-syntax ([goo (lambda (stx) - #`(let () - (define #,(syntax-local-introduce #'b) 1) - (define z (list b)) - z))]) - (goo)))))) +(test '(12) + eval + (expand + #'(let ([b 12]) + (let-syntax ([goo (lambda (stx) + #`(let () + (define #,(syntax-local-introduce #'b) 1) + (define z (list b)) + z))]) + (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) diff --git a/pkgs/racket-test-core/tests/racket/stxparam.rktl b/pkgs/racket-test-core/tests/racket/stxparam.rktl index 7ea6853fd0..317614f3b8 100644 --- a/pkgs/racket-test-core/tests/racket/stxparam.rktl +++ b/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) diff --git a/pkgs/racket-test-core/tests/racket/submodule.rktl b/pkgs/racket-test-core/tests/racket/submodule.rktl index ec7660d5a7..900abec956 100644 --- a/pkgs/racket-test-core/tests/racket/submodule.rktl +++ b/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) diff --git a/pkgs/racket-test-core/tests/racket/syntax.rktl b/pkgs/racket-test-core/tests/racket/syntax.rktl index 4e9c04e96a..df46aa278e 100644 --- a/pkgs/racket-test-core/tests/racket/syntax.rktl +++ b/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: diff --git a/pkgs/racket-test/tests/generic/syntax-errors.rkt b/pkgs/racket-test/tests/generic/syntax-errors.rkt index e96cc5b03a..1d4808e4b9 100644 --- a/pkgs/racket-test/tests/generic/syntax-errors.rkt +++ b/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)])))) diff --git a/pkgs/racket-test/tests/racket/package.rkt b/pkgs/racket-test/tests/racket/package.rkt index 9e2d6dda00..4f912c0460 100644 --- a/pkgs/racket-test/tests/racket/package.rkt +++ b/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 diff --git a/pkgs/racket-test/tests/units/test-harness.rkt b/pkgs/racket-test/tests/units/test-harness.rkt index 8e8b598f98..42d5f523b9 100644 --- a/pkgs/racket-test/tests/units/test-harness.rkt +++ b/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) - (not (syntax-e (stx-car x))) - (identifier? (stx-cdr x))) + ((and (syntax? x) + (vector? (syntax-e 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))) diff --git a/pkgs/racket-test/tests/units/test-unit-contracts.rkt b/pkgs/racket-test/tests/units/test-unit-contracts.rkt index f45f4d997e..2113074191 100644 --- a/pkgs/racket-test/tests/units/test-unit-contracts.rkt +++ b/pkgs/racket-test/tests/units/test-unit-contracts.rkt @@ -1,8 +1,8 @@ #lang racket/load (require "test-harness.rkt" - scheme/unit - scheme/contract) + racket/unit + 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) - (test-contract-error top-level "make-student" "not a string" - (make-student 4 3)) + (student "foo" 3) + (test-contract-error top-level "student" "not a string" + (student 4 3)) (test-contract-error top-level "student-id" "not a student" (student-id 'a))) diff --git a/pkgs/racket-test/tests/units/test-unit.rkt b/pkgs/racket-test/tests/units/test-unit.rkt index c2a921c39b..cf52e135a4 100644 --- a/pkgs/racket-test/tests/units/test-unit.rkt +++ b/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,15 +10,18 @@ (syntax-case stx () ((_ id) #`#'#,(let ((s (lookup-signature #'id))) - (list (map syntax-local-introduce (signature-vars s)) - (map (lambda (def) - (cons (map syntax-local-introduce (car def)) - (syntax-local-introduce (cdr def)))) - (signature-val-defs s)) - (map (lambda (def) - (cons (map syntax-local-introduce (car def)) - (syntax-local-introduce (cdr def)))) - (signature-stx-defs 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 shift-scope (car def)) + (cdr def))) + (signature-val-defs s)) + (map (lambda (def) + (cons (map shift-scope (car def)) + (cdr def))) + (signature-stx-defs s)))))))) (define-signature x-sig (x)) (define-signature x-sig2 (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 + ;; #( ) checks for an id that is fre-id=? or not depending on + #'((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)))) diff --git a/racket/collects/compiler/private/xform.rkt b/racket/collects/compiler/private/xform.rkt index 07fa3b9cd6..2e62629570 100644 --- a/racket/collects/compiler/private/xform.rkt +++ b/racket/collects/compiler/private/xform.rkt @@ -876,7 +876,7 @@ return if for while else switch case XFORM_OK_ASSIGN asm __asm __asm__ __volatile __volatile__ volatile __extension__ __typeof sizeof __builtin_object_size - + ;; These don't act like functions: setjmp longjmp _longjmp scheme_longjmp_setjmp scheme_mz_longjmp scheme_jit_longjmp scheme_jit_setjmp_prepare @@ -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 diff --git a/racket/collects/pkg/main.rkt b/racket/collects/pkg/main.rkt index 5921518356..80de6f299c 100644 --- a/racket/collects/pkg/main.rkt +++ b/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 ...] - [job-flags ...] - [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 ...]))]) + (replace-context + stx #`(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"]))))]) diff --git a/racket/collects/racket/block.rkt b/racket/collects/racket/block.rkt index d5c65cf494..5355969605 100644 --- a/racket/collects/racket/block.rkt +++ b/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] diff --git a/racket/collects/racket/class.rkt b/racket/collects/racket/class.rkt index 66472f0073..bbc3cb91e7 100644 --- a/racket/collects/racket/class.rkt +++ b/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?) diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index 2d34f02996..3d2982e1d1 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/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] - [provide? #t]) + pos-module-source + 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))) @@ -1049,12 +1050,19 @@ a:mangle-id) "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 ...)))]))])) diff --git a/racket/collects/racket/contract/region.rkt b/racket/collects/racket/contract/region.rkt index 2b4d92590d..ac92a82878 100644 --- a/racket/collects/racket/contract/region.rkt +++ b/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)] - [(ctx) (list (gensym 'intdef))] - [(cid-marker) (make-syntax-introducer)] + (let*-values ([(cid-marker) (make-syntax-introducer)] [(free-vars free-ctcs) (values (syntax->list #'(fv.var ...)) (syntax->list #'(fv.ctc ...)))]) - (define (add-context stx) - (internal-definition-context-apply intdef stx)) - (syntax-local-bind-syntaxes free-vars #f intdef) - (internal-definition-context-seal intdef) + (define add-context (make-syntax-introducer)) (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)] - [(ctx) (list (gensym 'intdef))] - [(cid-marker) (make-syntax-introducer)] + (let*-values ([(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) - (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) + (define add-context (make-syntax-introducer)) (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 ...) diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index 91abd208d4..5974c3147d 100644 --- a/racket/collects/racket/generic.rkt +++ b/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 ...))) diff --git a/racket/collects/racket/local.rkt b/racket/collects/racket/local.rkt index 11d8bf9e96..d732e2f806 100644 --- a/racket/collects/racket/local.rkt +++ b/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))))) diff --git a/racket/collects/racket/private/class-internal.rkt b/racket/collects/racket/private/class-internal.rkt index 1c4f068543..81958da49b 100644 --- a/racket/collects/racket/private/class-internal.rkt +++ b/racket/collects/racket/private/class-internal.rkt @@ -30,50 +30,53 @@ (provide provide-public-names ;; needed for Typed Racket (protect-out do-make-object find-method/who)) -(define-syntax-rule (provide-public-names) - (provide class class* class/derived - define-serializable-class define-serializable-class* - class? - mixin - interface interface* interface? - object% object? externalizable<%> printable<%> writable<%> equal<%> - object=? object-or-false=? - new make-object instantiate - send send/apply send/keyword-apply send* send+ dynamic-send - class-field-accessor class-field-mutator with-method - get-field set-field! field-bound? field-names - dynamic-get-field dynamic-set-field! - private* public* pubment* - override* overment* - augride* augment* - public-final* override-final* augment-final* - define/private define/public define/pubment - define/override define/overment - define/augride define/augment - define/public-final define/override-final define/augment-final - define-local-member-name define-member-name - member-name-key generate-member-key - member-name-key? member-name-key=? member-name-key-hash-code - generic make-generic send-generic - is-a? subclass? implementation? interface-extension? - object-interface object-info object->vector - object-method-arity-includes? - method-in-interface? interface->method-names class->interface class-info - (struct-out exn:fail:object) - make-primitive-class - class/c ->m ->*m ->dm case->m object/c instanceof/c - dynamic-object/c - class-seal class-unseal +(define-syntax (provide-public-names stx) + (datum->syntax + stx + '(provide class class* class/derived + define-serializable-class define-serializable-class* + class? + mixin + interface interface* interface? + object% object? externalizable<%> printable<%> writable<%> equal<%> + object=? object-or-false=? + new make-object instantiate + send send/apply send/keyword-apply send* send+ dynamic-send + class-field-accessor class-field-mutator with-method + get-field set-field! field-bound? field-names + dynamic-get-field dynamic-set-field! + private* public* pubment* + override* overment* + augride* augment* + public-final* override-final* augment-final* + define/private define/public define/pubment + define/override define/overment + define/augride define/augment + define/public-final define/override-final define/augment-final + define-local-member-name define-member-name + member-name-key generate-member-key + member-name-key? member-name-key=? member-name-key-hash-code + generic make-generic send-generic + is-a? subclass? implementation? interface-extension? + object-interface object-info object->vector + object-method-arity-includes? + method-in-interface? interface->method-names class->interface class-info + (struct-out exn:fail:object) + make-primitive-class + class/c ->m ->*m ->dm case->m object/c instanceof/c + dynamic-object/c + class-seal class-unseal ;; "keywords": - private public override augment - pubment overment augride - public-final override-final augment-final - field init init-field init-rest - 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)) + private public override augment + pubment overment augride + public-final override-final augment-final + field init init-field init-rest + 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) + 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 - (map bind-local-id (syntax->list #'(id ...))) - (cons e (loop (cdr l))))] + (let ([ids (map bind-local-id (syntax->list #'(id ...)))]) + (with-syntax ([(id ...) ids]) + (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) - (cons (stx-car i) - (stx-car (stx-cdr i))))) + (alone (syntax-local-identifier-as-binding i)) + (cons (syntax-local-identifier-as-binding (stx-car 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-eid norm) (stx-car (stx-cdr (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) (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) - (let ([l (localize/set-flag id)]) + [bind-local-id (lambda (orig-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 @@ -708,7 +717,7 @@ (if (syntax? s) (syntax-e s) s)))]) - + ;; ------ Basic syntax checks ----- (for-each (lambda (stx) (syntax-case stx (-init -init-rest -field -init-field -inherit-field @@ -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) - l)]) + (map bind-local-id 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] ...) diff --git a/racket/collects/racket/private/class-undef.rkt b/racket/collects/racket/private/class-undef.rkt index f636a33ed8..8980040d55 100644 --- a/racket/collects/racket/private/class-undef.rkt +++ b/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) - (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))))])) + (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 ... 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 diff --git a/racket/collects/racket/private/classidmap.rkt b/racket/collects/racket/private/classidmap.rkt index f22020e69e..0772052e31 100644 --- a/racket/collects/racket/private/classidmap.rkt +++ b/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!)] - [lambda-stx (datum->syntax the-finder 'lambda)]) + (let () (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)] - [#%app #%app-stx]) - (syntax/loc stx (#%app (#%app check-not-unsafe-undefined local-id 'id) . args)))] + #'id)]) + (syntax/loc stx (#%plain-app (#%plain-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 diff --git a/racket/collects/racket/private/generic-interfaces.rkt b/racket/collects/racket/private/generic-interfaces.rkt index 2c4426dd3d..9e310f0c85 100644 --- a/racket/collects/racket/private/generic-interfaces.rkt +++ b/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 (hash-proc x h) (equal-hash-code x)) - (define (hash2-proc x h) (equal-secondary-hash-code x)) + (define (equal-proc-impl a b e) (equal? a b)) + (define (hash-proc-impl x h) (equal-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)))) ) diff --git a/racket/collects/racket/private/generic-methods.rkt b/racket/collects/racket/private/generic-methods.rkt index c0a5d85f70..5896b34b54 100644 --- a/racket/collects/racket/private/generic-methods.rkt +++ b/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) - (make-struct-field-accessor generic-info-get 1 'predicate) - (make-struct-field-accessor generic-info-get 2 'accessor) - (make-struct-field-accessor generic-info-get 3 'methods))) + (values (make-struct-field-accessor generic-info-get 0 'name) + (make-struct-field-accessor generic-info-get 1 'property) + (make-struct-field-accessor generic-info-get 2 'predicate) + (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 (syntax-local-get-shadower (delta original-id))) + (define context-id (delta (car impl-ids))) (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 methods (map delta (generic-info-methods info))) + (define orig-id (generic-info-name 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)] ...) - () - def ... - (values (implementation method) ...))))))])) + ([(method) (make-unimplemented 'method)] ...) + () + (syntax-parameterize ([generic-method-inner-context #'gen]) + def ... + (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 methods (generic-info-methods gen-val)) + (define delta + (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]) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index 6904f53a24..d8540088f7 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/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)) diff --git a/racket/collects/racket/private/local.rkt b/racket/collects/racket/private/local.rkt index f4852b94ba..6ecc6597b2 100644 --- a/racket/collects/racket/private/local.rkt +++ b/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) - (let ([orig-ctx (syntax-local-context)]) - (if (pair? orig-ctx) - orig-ctx - null)))]) + [expand-context (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + 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: - (let ([q (local-expand #`(quote #,stx) - 'expression - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ stx) #'stx]))) + (internal-definition-context-introduce + def-ctx + stx + 'add)) (syntax->list #'(body1 body ...)))]) - (syntax/loc stx - (LSV sbindings vbindings - body ...)))))] + (combine def-ctx + expand-context + #'sbindings + #'vbindings + #'(body ...)))))] [(_ x body1 body ...) (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) diff --git a/racket/collects/racket/private/misc.rkt b/racket/collects/racket/private/misc.rkt index 7f6512e365..14da5b91e9 100644 --- a/racket/collects/racket/private/misc.rkt +++ b/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")) ;; ------------------------------------------------------------------------- diff --git a/racket/collects/racket/private/more-scheme.rkt b/racket/collects/racket/private/more-scheme.rkt index 9dafcee29a..7f110c5fbd 100644 --- a/racket/collects/racket/private/more-scheme.rkt +++ b/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 () @@ -53,7 +54,7 @@ #f "bad syntax (illegal use of `.')" x)))) - + ;; From Dybvig: (define-syntax do (lambda (orig-x) diff --git a/racket/collects/racket/private/pre-base.rkt b/racket/collects/racket/private/pre-base.rkt index 8336f08866..1baea41129 100644 --- a/racket/collects/racket/private/pre-base.rkt +++ b/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) diff --git a/racket/collects/racket/private/qar.rkt b/racket/collects/racket/private/qar.rkt new file mode 100644 index 0000000000..0a0bcc5da5 --- /dev/null +++ b/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 ) + (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)) diff --git a/racket/collects/racket/private/qq-and-or.rkt b/racket/collects/racket/private/qq-and-or.rkt index b13a565576..03199e18e7 100644 --- a/racket/collects/racket/private/qq-and-or.rkt +++ b/racket/collects/racket/private/qq-and-or.rkt @@ -5,19 +5,50 @@ (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)] + [(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 (id-in-list?) - (lambda (id l) - (if (null? l) - #f - (if (bound-identifier=? id (car l)) - #t - (id-in-list? id (cdr l)))))) (define-values (stx-2list?) (lambda (x) (if (stx-pair? x) @@ -97,39 +128,11 @@ (loop bindings))]) (if star? (void) - (if ((length new-bindings) . > . 5) - (let-values ([(ht) (make-hasheq)]) - (letrec-values ([(check) (lambda (l) - (if (null? l) - (void) - (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)))) + (check-for-duplicates new-bindings + (if name + car + (lambda (v) (stx-car (stx-car v)))) + stx)) (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)) diff --git a/racket/collects/racket/private/reqprov.rkt b/racket/collects/racket/private/reqprov.rkt index a32387889c..2ce62e5325 100644 --- a/racket/collects/racket/private/reqprov.rkt +++ b/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)) - (syntax/loc stx - (begin (require in) ...)))])))] + (with-syntax ([(req-in ...) + (map (lambda (in) + (with-syntax ([in in]) + (syntax/loc stx (require in)))) + (syntax->list #'(in ...)))]) + (syntax/loc stx + (begin req-in ...))))])))] [else (raise-syntax-error #f "not at module level or top level" diff --git a/racket/collects/racket/private/stxparam.rkt b/racket/collects/racket/private/stxparam.rkt index bc69e27c78..f9af1c8e9b 100644 --- a/racket/collects/racket/private/stxparam.rkt +++ b/racket/collects/racket/private/stxparam.rkt @@ -30,8 +30,9 @@ "not bound as a syntax parameter" stx id)) - (syntax-local-get-shadower - (syntax-local-introduce (syntax-parameter-target sp))))) + (syntax-local-get-shadower + (syntax-local-introduce (syntax-parameter-target sp)) + #t))) ids)]) (let ([dup (check-duplicate-identifier ids)]) (when dup diff --git a/racket/collects/racket/private/stxparamkey.rkt b/racket/collects/racket/private/stxparamkey.rkt index d2be47f863..14884d6443 100644 --- a/racket/collects/racket/private/stxparamkey.rkt +++ b/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 diff --git a/racket/collects/racket/private/submodule.rkt b/racket/collects/racket/private/submodule.rkt index 8aef98f6e9..1e81ac19a3 100644 --- a/racket/collects/racket/private/submodule.rkt +++ b/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))])))) diff --git a/racket/collects/racket/private/unit-compiletime.rkt b/racket/collects/racket/private/unit-compiletime.rkt index 3ae8b87b45..c1b66fd30f 100644 --- a/racket/collects/racket/private/unit-compiletime.rkt +++ b/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) - (when (bound-identifier-mapping-get ht ext (lambda () #f)) - (raise-stx-err "duplicate renamings" ext)) - (bound-identifier-mapping-put! ht ext 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))) (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 (do-identifier spec res bind? add-prefix) +(define (make-relative-introducer ref-id orig-id) + (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 - spec)]) - (lambda (id) (syntax-local-introduce (f id)))) - values))) + (make-relative-introducer spec-bind + (car (siginfo-names (signature-siginfo sig)))) + (lambda (id) + (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))))) + (add-prefix + (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)) - (check-tagged-spec-syntax spec import? identifier?) - (syntax-case spec (tag) - ((tag sym spec) - (let ([s (process-import/export #'spec 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 )" spec)) - (_ (let ([s (process-import/export spec res bind? values)]) - (list (cons #f (cdr (unbox res))) - (cons #f (car (unbox res))) - s))))) + (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 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 )" spec)) + (_ (let ([s (process-import/export spec spec-bind res bind? values)]) + (list (cons #f (cdr (unbox res))) + (cons #f (car (unbox res))) + s))))))))) (define (add-prefixes add-prefix l) (map add-prefix (syntax->list l))) -;; process-import/export : syntax-object (box (cons identifier) siginfo) -> sig -(define (process-import/export spec res bind? add-prefix) - (syntax-case spec (only except prefix rename) +;; process-import/export : syntax-object syntax-object (box (cons identifier) siginfo) -> sig +(define (process-import/export spec spec-bind res bind? add-prefix) + (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) -> ??? diff --git a/racket/collects/racket/private/unit-syntax.rkt b/racket/collects/racket/private/unit-syntax.rkt index 9792737081..71e50c3391 100644 --- a/racket/collects/racket/private/unit-syntax.rkt +++ b/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,17 +31,20 @@ ;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X) (define (check-tagged check) (λ (o) - (syntax-case o (tag) - ((tag . s) - (syntax-case #'s () - ((sym spec) - (begin - (unless (symbol? (syntax-e #'sym)) - (raise-stx-err "tag must be a symbol" #'sym)) - (cons (syntax-e #'sym) (check #'spec)))) - (_ (raise-stx-err "expected (tag )" #'s)))) - (_ - (cons #f (check o)))))) + (let loop ([o o]) + (syntax-case o (bind-at tag) + ((bind-at bind o) + (loop #'o)) + ((tag . s) + (syntax-case #'s () + ((sym spec) + (begin + (unless (symbol? (syntax-e #'sym)) + (raise-stx-err "tag must be a symbol" #'sym)) + (cons (syntax-e #'sym) (check #'spec)))) + (_ (raise-stx-err "expected (tag )" #'s)))) + (_ + (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)) diff --git a/racket/collects/racket/signature/lang.rkt b/racket/collects/racket/signature/lang.rkt index 532ed95b54..86aeb76414 100644 --- a/racket/collects/racket/signature/lang.rkt +++ b/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 ...)) diff --git a/racket/collects/racket/splicing.rkt b/racket/collects/racket/splicing.rkt index fcf2f0b3ca..24d4942810 100644 --- a/racket/collects/racket/splicing.rkt +++ b/racket/collects/racket/splicing.rkt @@ -21,67 +21,38 @@ splicing-local splicing-syntax-parameterize) -(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-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) - ...))) - (let ([def-ctx (syntax-local-make-definition-context)] - [ctx (list (gensym 'intdef))]) - (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) - (internal-definition-context-seal def-ctx) - (let* ([add-context - (lambda (expr) - (internal-definition-context-apply def-ctx expr))]) - (with-syntax ([((id ...) ...) - (map (lambda (ids) - (map add-context ids)) - all-ids)] - [(expr ...) - (let ([exprs (syntax->list #'(expr ...))]) - (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))) - #'((define-syntaxes (id ... ...) (values))) - null)]) - #'(begin - top-decl ... - (DEF (id ...) expr) - ... - body ...)))))))])) +(define-syntax (splicing-local stx) + (do-local stx (lambda (def-ctx expand-context sbindings vbindings bodys) + (if (eq? 'expression (syntax-local-context)) + (quasisyntax/loc stx + (letrec-syntaxes+values + #,sbindings + #,vbindings + #,@bodys)) + ;; Since we alerady have bindings for the current scopes, + ;; add an extra scope for re-binding: + (let ([i (make-syntax-introducer)]) + (with-syntax ([([s-ids s-rhs] ...) (i sbindings)] + [([(v-id ...) v-rhs] ...) (i vbindings)] + [(body ...) (i bodys)] + [(marked-id markless-id) + (let ([id #'id]) + ;; The marked identifier should have both the extra + ;; scope and the intdef scope, to be removed from + ;; definitions expanded from `body`: + (list (i (internal-definition-context-introduce def-ctx id)) + id))]) + (with-syntax ([(top-decl ...) + (if (equal? 'top-level (syntax-local-context)) + #'((define-syntaxes (v-id ... ...) (values))) + null)]) + (quasisyntax/loc stx + (begin + top-decl ... + (define-syntaxes s-ids s-rhs) ... + (define-values (v-id ...) v-rhs) ... + (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)] - [ctx (list (gensym 'intdef))]) - (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) - (internal-definition-context-seal def-ctx) - (let* ([add-context - (lambda (expr) - (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)) - #'(begin))]) - (syntax/loc stx - (begin - top-decl - (define-syntaxes (sid ...) sexpr) ... - (define-values (vid ...) vexpr) ... - body ...))))))))])) - - - -(define-syntax (splicing-local stx) - (do-local stx #'splicing-letrec-syntaxes+values)) + (with-syntax ([((vid ...) ...) all-vids] + [(marked-id markless-id) + (let ([id #'id]) + (list ((make-syntax-introducer) id) + id))]) + (with-syntax ([(top-decl ...) + (if (equal? 'top-level (syntax-local-context)) + #'((define-syntaxes (vid ... ...) (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 #t (define-syntaxes sids sexpr)) + ... + (splicing-let-start/def marked-id markless-id #t (define-values (vid ...) vexpr)) + ... + (splicing-let-start/body marked-id markless-id body ...)))))))])) ;; ---------------------------------------- @@ -181,25 +274,29 @@ (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))] - ...) - (force-expand body)) - (syntax-local-context) - null ;; `force-expand' actually determines stopping places - #f)]) - ;; Extract expanded body out of `body': - (syntax-case body (quote) - [(ls _ _ (quote body)) - (let ([body #'body]) - (syntax-case body ( begin - define-values - define-syntaxes - begin-for-syntax - module - module* - #%require - #%provide - #%declare ) + (let ([ctx (syntax-local-make-definition-context #f #f)]) + (for ([sp-id (in-list (syntax->list #'(sp-id ...)))] + [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 + ctx)]) + (let ([body + ;; Extract expanded body out of `body': + (syntax-case body (quote) + [(quote body) #'body])]) + (syntax-case body ( begin + define-values + define-syntaxes + begin-for-syntax + module + module* + #%require + #%provide + #%declare ) [(begin expr ...) (syntax/loc body (begin (expand-ssp-body (sp-id ...) (temp-id ...) (orig-id ...) expr) ...))] @@ -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 () diff --git a/racket/collects/racket/stream.rkt b/racket/collects/racket/stream.rkt index 32dc6f6e48..18d0b17bf7 100644 --- a/racket/collects/racket/stream.rkt +++ b/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)))) diff --git a/racket/collects/racket/trait.rkt b/racket/collects/racket/trait.rkt index c21601edee..4d7eb0525b 100644 --- a/racket/collects/racket/trait.rkt +++ b/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) - (cons e (loop (cdr l)))] + [(dv (id) rhs) + (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) - (or (identifier? id) - (syntax-case id () - [(a b) - (and (identifier? #'a) - (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)) + (with-syntax ([(id ...) (check-bindings (syntax->list #'(id ...)))]) + (cons (syntax/loc e (field (id expr) ...)) + (loop (cdr l))))] + [(form . rest) + (ormap (lambda (x) (free-identifier=? x #'form)) (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 - (andmap (lambda (i) - (or (identifier? i) - (syntax-case i () - [(a b) - (and (identifier? #'a) - (identifier? #'b))] - [_else #f]))) - l2)) - (cons e (loop (cdr l))) + (if l2 + (cons (with-syntax ([(id ...) (check-bindings l2)]) + (syntax/loc e + (form id ...))) + (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) - (if (identifier? decl) - decl - (stx-car decl))) + (syntax-local-identifier-as-binding + (if (identifier? decl) + decl + (stx-car decl)))) (define (external-name decl) (if (identifier? decl) diff --git a/racket/collects/racket/unit.rkt b/racket/collects/racket/unit.rkt index 01564cb593..6dbbb48e14 100644 --- a/racket/collects/racket/unit.rkt +++ b/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) @@ -915,6 +933,16 @@ (check-duplicate-subs export-tagged-infos esig) (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 @@ -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,7 +982,8 @@ (lambda (import) (length (car import))) import-sigs)]) (values - (quasisyntax/loc (error-syntax) + (intro + (quasisyntax/loc (error-syntax) (make-unit 'name (vector-immutable (cons 'import-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) - (make-syntax-delta-introducer u (unit-info-orig-binder unit))) - units us)] + [sig-introducers (map (lambda (unit u) values) 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))]) - (lambda (p) - (unprocess-tagged-id (cons (car p) (i (cdr p))))))] + [unprocess (lambda (p) + #`(bind-at #,u #,(unprocess-tagged-id (cons (car p) (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 diff --git a/racket/collects/setup/setup-cmdline.rkt b/racket/collects/setup/setup-cmdline.rkt index 097a0694c2..135124732a 100644 --- a/racket/collects/setup/setup-cmdline.rkt +++ b/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)" diff --git a/racket/collects/syntax/free-vars.rkt b/racket/collects/syntax/free-vars.rkt index 2202985932..9ced2c1e71 100644 --- a/racket/collects/syntax/free-vars.rkt +++ b/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)]) diff --git a/racket/collects/syntax/kerncase.rkt b/racket/collects/syntax/kerncase.rkt index 0901874784..2c67a32761 100644 --- a/racket/collects/syntax/kerncase.rkt +++ b/racket/collects/syntax/kerncase.rkt @@ -6,35 +6,59 @@ (define-syntax kernel-syntax-case-internal (lambda (stx) (syntax-case stx () - [(_ stxv phase rel? (extras ...) kernel-context clause ...) - (quasisyntax/loc - stx - (syntax-case* stxv (extras ... - #,@(map - syntax-local-introduce - (syntax-e - (quote-syntax - (quote - quote-syntax #%top - #%plain-lambda case-lambda - let-values letrec-values letrec-syntaxes+values - begin begin0 set! - with-continuation-mark - if #%plain-app #%expression - define-values define-syntaxes begin-for-syntax - module module* - #%plain-module-begin - #%require #%provide #%declare - #%variable-reference))))) - (let ([p phase]) - (cond - [(and #,(syntax-e #'rel?) (= p 0)) - free-identifier=?] - [(and #,(syntax-e #'rel?) (= p 1)) - free-transformer-identifier=?] - [else (lambda (a b) - (free-identifier=? a b p '#,(syntax-local-phase-level)))])) - clause ...))]))) + [(_ stxv phase rel? (extras ...) kernel-context [pattern . rhs] ...) + (let () + (define kernel-ids (syntax-e + (quote-syntax + (quote + quote-syntax #%top + #%plain-lambda case-lambda + let-values letrec-values letrec-syntaxes+values + begin begin0 set! + with-continuation-mark + if #%plain-app #%expression + define-values define-syntaxes begin-for-syntax + module module* + #%plain-module-begin + #%require #%provide #%declare + #%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)) + free-identifier=?] + [(and #,(syntax-e #'rel?) (= p 1)) + free-transformer-identifier=?] + [else (lambda (a b) + (free-identifier=? a b p '#,(syntax-local-phase-level)))])) + [pattern . rhs] ...))))]))) (define-syntax kernel-syntax-case (lambda (stx) diff --git a/racket/collects/syntax/parse/private/runtime.rkt b/racket/collects/syntax/parse/private/runtime.rkt index f07ba0d8f2..e463388510 100644 --- a/racket/collects/syntax/parse/private/runtime.rkt +++ b/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] diff --git a/racket/src/configure b/racket/src/configure index cc41f20eef..31475b26c4 100755 --- a/racket/src/configure +++ b/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 diff --git a/racket/src/racket/configure.ac b/racket/src/racket/configure.ac index dc9a3b5ae8..71ce6cdfe7 100644 --- a/racket/src/racket/configure.ac +++ b/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 diff --git a/racket/src/racket/gc2/gc2.h b/racket/src/racket/gc2/gc2.h index b28f2107f2..84e6cfb3a9 100644 --- a/racket/src/racket/gc2/gc2.h +++ b/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. */ diff --git a/racket/src/racket/gc2/gc2_obj.h b/racket/src/racket/gc2/gc2_obj.h index 6061e8ab50..9a28cf294f 100644 --- a/racket/src/racket/gc2/gc2_obj.h +++ b/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; diff --git a/racket/src/racket/gc2/mem_account.c b/racket/src/racket/gc2/mem_account.c index 7578c46246..df0067c481 100644 --- a/racket/src/racket/gc2/mem_account.c +++ b/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); diff --git a/racket/src/racket/gc2/newgc.c b/racket/src/racket/gc2/newgc.c index 26bead23d7..3b2b468996 100644 --- a/racket/src/racket/gc2/newgc.c +++ b/racket/src/racket/gc2/newgc.c @@ -6,23 +6,9 @@ Search for "FIXME" for known improvement points This is a hybrid copying/mark-compact collector. The nursery - (generation 0) is copied into the old generation (generation 1), - but the old generation compacts. This yields a nice combination - of performance, scalability and memory efficiency. - - The following page map invariants are required: - - Outside of collection, only pages in the older generation should - be in the gc->page_maps. - - During the mark phase of collection, only pages which contain - objects which may be marked should be in the page map. This means - that during minor collections, only pages in the nursery should - be in the map. - - During the rest of collection, only pages which contain the past - locations of moved data should be in the page map. This means only - the nursery and pages being compacted. + (generation 0) is copied into an intermediate nursery (generation + 1/2) and then to the old generation (generation 1). The old + generation eventually compacts. */ /* #define GC_MP_CNT */ @@ -41,20 +27,19 @@ intptr_t mp_prev_compact_cnt; intptr_t mp_compact_cnt; intptr_t mp_bc_freed; intptr_t mp_ac_freed; -#define GC_MP_CNT_INC(x) ((x)++) +# define GC_MP_CNT_INC(x) ((x)++) #else -#define GC_MP_CNT_INC(x) /* empty */ +# define GC_MP_CNT_INC(x) /* empty */ #endif #if 0 -#define POINTER_OWNERSHIP_CHECK +# define POINTER_OWNERSHIP_CHECK #endif #define MZ_PRECISE_GC /* required for mz includes to work right */ #include #include #include -#include #include "platforms.h" #include "../src/schpriv.h" #include "gc2.h" @@ -76,6 +61,7 @@ intptr_t mp_ac_freed; #endif #if 0 +# include # define GC_ASSERT(x) assert(x) #else # define GC_ASSERT(x) /* empty */ @@ -131,6 +117,11 @@ enum { MMU_PROTECTABLE = 1, }; +enum { + AGE_GEN_0 = 0, + AGE_GEN_HALF = 1, + AGE_GEN_1 = 2 +}; static const char *type_name[PAGE_TYPES] = { "tagged", @@ -177,17 +168,21 @@ struct Log_Master_Info { int ran, full; intptr_t pre_used, post_used, pre_admin, post_admin; }; + +# define PLACES_AND(v) v #else # define premaster_or_master_gc(gc) 1 # define premaster_or_place_gc(gc) 1 # define postmaster_and_master_gc(gc) 0 # define postmaster_and_place_gc(gc) 1 +# define PLACES_AND(v) 0 #endif inline static size_t real_page_size(mpage* page); inline static int page_mmu_type(mpage *page); inline static int page_mmu_protectable(mpage *page); static void free_mpage(mpage *page); +static void gen_half_free_mpage(NewGC *gc, mpage *work); #if defined(MZ_USE_PLACES) && defined(GC_DEBUG_PAGES) static FILE* gcdebugOUT(NewGC *gc) { @@ -251,6 +246,11 @@ MAYBE_UNUSED static void GCVERBOSEprintf(NewGC *gc, const char *fmt, ...) { #define GEN0_MAX_SIZE (32 * 1024 * 1024) #define GEN0_PAGE_SIZE (1 * 1024 * 1024) +/* Whether to use a little aging, moving gen-0 objects to a + gen-1/2 space; by default, enabled when memory use is high + enough: */ +#define AGE_GEN_0_TO_GEN_HALF(gc) ((gc)->memory_in_use > (GEN0_MAX_SIZE * 8)) + /* Conservatively force a major GC after a certain number of minor GCs. It should be ok to set this value arbitraily high. An earlier value of 100, meanwhile, @@ -283,6 +283,9 @@ MAYBE_UNUSED static void GCVERBOSEprintf(NewGC *gc, const char *fmt, ...) { #define HALF_PAGE_SIZE (1 << (LOG_APAGE_SIZE - 1)) #define GENERATIONS 1 +/* Use a mark stack when recurring this deep or more: */ +#define MAX_RECUR_MARK_DEPTH 5 + /* the externals */ void (*GC_out_of_memory)(void); void (*GC_report_out_of_memory)(void); @@ -655,8 +658,10 @@ static void dump_page_map(NewGC *gc, const char *when) printf(" "); skips--; } - if (!page->generation) + if (page->generation == AGE_GEN_0) kind = '0'; + else if (page->generation == AGE_GEN_HALF) + kind = '%'; else { switch (page->page_type) { case PAGE_TAGGED: @@ -839,7 +844,7 @@ static const char *zero_sized[4]; /* all 0-sized allocs get this */ inline static size_t real_page_size(mpage *page) { switch (page->size_class) { case 0: /* SMALL_PAGE , GEN0_PAGE */ - if (page->generation) { return APAGE_SIZE; } + if (page->generation >= AGE_GEN_1) { return APAGE_SIZE; } else { return GEN0_ALLOC_SIZE(page); } case 1: /* MED PAGE */ return APAGE_SIZE; @@ -1335,7 +1340,7 @@ inline static void gen0_sync_page_size_from_globals(NewGC *gc) { } inline static void gen0_allocate_and_setup_new_page(NewGC *gc) { - mpage *new_mpage = gen0_create_new_nursery_mpage(gc, gc->gen0.page_alloc_size); + mpage *new_mpage = gen0_create_new_nursery_mpage(gc, GEN0_PAGE_SIZE); /* push page */ new_mpage->prev = gc->gen0.curr_alloc_page; @@ -1646,6 +1651,32 @@ int GC_allocate_phantom_bytes(intptr_t request_size_bytes) return 1; } +inline static void gen_half_allocate_and_setup_new_page(NewGC *gc) { + mpage *new_mpage = gen0_create_new_nursery_mpage(gc, GEN0_PAGE_SIZE); + + new_mpage->generation = AGE_GEN_HALF; + + /* push page */ + new_mpage->prev = gc->gen_half.curr_alloc_page; + if (new_mpage->prev) + new_mpage->prev->next = new_mpage; + + gc->gen_half.curr_alloc_page = new_mpage; + if (!gc->gen_half.pages) + gc->gen_half.pages = new_mpage; +} + +inline static size_t gen_half_size_in_use(NewGC *gc) { + mpage *work = gc->gen_half.pages; + size_t total = 0; + while(work) { + mpage *next = work->next; + total += work->size; + work = next; + } + return total; +} + void GC_create_message_allocator() { NewGC *gc = GC_get_GC(); Allocator *a; @@ -1848,7 +1879,6 @@ inline static void resize_gen0(NewGC *gc, uintptr_t new_size) mpage *prev = NULL; uintptr_t alloced_size = 0; - /* first, make sure the big pages pointer is clean */ GC_ASSERT(gc->gen0.big_pages == NULL); @@ -1926,13 +1956,34 @@ inline static void reset_nursery(NewGC *gc) resize_gen0(gc, new_gen0_size); } -inline static mpage *pagemap_find_page_for_marking(NewGC *gc, const void *p, int fixup) { - mpage *page; - page = pagemap_find_page(gc->page_maps, p); - if (page && !gc->gc_full && page->generation && (fixup || !page->marked_on)) return NULL; - return page; +inline static void move_gen_half_pages_to_old(NewGC *gc) +{ + GC_ASSERT(!gc->gen_half.curr_alloc_page); + gc->gen_half.old_pages = gc->gen_half.pages; + gc->gen_half.pages = NULL; } +inline static void clean_gen_half(NewGC *gc) +{ + mpage *work = gc->gen_half.old_pages, *next; + + while (work) { + next = work->next; + gen_half_free_mpage(gc, work); + work = next; + } + + gc->gen_half.old_pages = NULL; + gc->gen_half.curr_alloc_page = NULL; +} + + +inline static mpage *pagemap_find_page_for_marking(NewGC *gc, const void *p) { + mpage *page; + page = pagemap_find_page(gc->page_maps, p); + if (page && !gc->gc_full && (page->generation >= AGE_GEN_1)) return NULL; + return page; +} /* This procedure fundamentally returns true if a pointer is marked, and false if it isn't. This function assumes that you're talking, at this @@ -1944,12 +1995,12 @@ inline static int marked(NewGC *gc, const void *p) mpage *page; if(!p) return 0; - if(!(page = pagemap_find_page_for_marking(gc, p, 0))) return 1; + if(!(page = pagemap_find_page_for_marking(gc, p))) return 1; switch(page->size_class) { case SIZE_CLASS_BIG_PAGE_MARKED: return 1; case SIZE_CLASS_SMALL_PAGE: - if (page->generation) { + if (page->generation >= AGE_GEN_1) { if((NUM(page->addr) + page->previous_size) > NUM(p)) return 1; } @@ -2068,14 +2119,21 @@ static void dump_heap(NewGC *gc) static void backtrace_new_page(NewGC *gc, mpage *page) { - /* This is a little wastefull for big pages, because we'll + /* This is a little wasteful for big pages, because we'll only use the first few words: */ page->backtrace = (void **)malloc_pages(gc, APAGE_SIZE, APAGE_SIZE, MMU_ZEROED, MMU_BIG_MED, MMU_NON_PROTECTABLE, &page->backtrace_page_src, 1); } -# define backtrace_new_page_if_needed(gc, page) if (!page->backtrace) backtrace_new_page(gc, page) +#define backtrace_new_page_if_needed(gc, page) if (!page->backtrace) backtrace_new_page(gc, page) + +static void backtrace_new_gen_half_page(NewGC *gc, mpage *page) +{ + page->backtrace = (void **)malloc_pages(gc, GEN0_PAGE_SIZE, GEN0_PAGE_SIZE, + MMU_ZEROED, MMU_BIG_MED, MMU_NON_PROTECTABLE, + &page->backtrace_page_src, 1); +} static void free_backtrace(mpage *page) { @@ -2085,6 +2143,14 @@ static void free_backtrace(mpage *page) &page->backtrace_page_src); } +static void free_gen_half_backtrace(mpage *page) +{ + if (page->backtrace) + free_pages(GC_instance, page->backtrace, GEN0_PAGE_SIZE, + MMU_BIG_MED, MMU_NON_PROTECTABLE, + &page->backtrace_page_src); +} + static void set_backtrace_source(NewGC *gc, void *source, int type) { gc->bt_source = source; @@ -2148,7 +2214,9 @@ static void *get_backtrace(mpage *page, void *ptr, int *kind) #else # define backtrace_new_page(gc, page) /* */ # define backtrace_new_page_if_needed(gc, page) /* */ +# define backtrace_new_gen_half_page(gc, page) /* */ # define free_backtrace(page) /* */ +# define free_gen_half_backtrace(page) /* */ # define set_backtrace_source(gc, ptr, type) /* */ # define record_backtrace(gc, page, ptr) /* */ # define copy_backtrace_source(to_page, to_ptr, from_page, from_ptr) /* */ @@ -2436,6 +2504,36 @@ inline static void mark_stack_initialize(NewGC *gc) { static void push_ptr(NewGC *gc, void *ptr) { +#if 0 + /* detect a bad pointer when it's pushed, instead of when it's popped: */ + { + int alloc_type; + void *p, *start; + objhead *info = NULL; + mpage *page = NULL; + if (IS_BIG_PAGE_PTR(ptr)) { + p = REMOVE_BIG_PAGE_PTR_TAG(ptr); + page = pagemap_find_page(gc->page_maps, p); +# ifdef MZ_USE_PLACES + if (!page && gc->major_places_gc) { + page = pagemap_find_page(MASTERGC->page_maps, p); + } +# endif + start = PPTR(BIG_PAGE_TO_OBJECT(page)); + alloc_type = page->page_type; + } else { + p = ptr; + info = OBJPTR_TO_OBJHEAD(p); + start = p; + alloc_type = info->type; + } + if (alloc_type == PAGE_TAGGED) { + short tag = *(short *)start; + ASSERT_TAG(tag); + } + } +#endif + /* This happens during propagation if we go past the end of this MarkSegment*/ if(gc->mark_stack->top == MARK_STACK_END(gc->mark_stack)) { /* test to see if we already have another stack page ready */ @@ -2472,6 +2570,14 @@ inline static int pop_ptr(NewGC *gc, void **ptr) return 1; } +void GC_mark_no_recur(struct NewGC *gc, int enable) +{ + if (enable) + gc->mark_depth += MAX_RECUR_MARK_DEPTH; + else + gc->mark_depth -= MAX_RECUR_MARK_DEPTH; +} + void GC_retract_only_mark_stack_entry(void *pf, struct NewGC *gc) { void *p2; @@ -2534,7 +2640,7 @@ inline static void reset_pointer_stack(NewGC *gc) gc->mark_stack->top = MARK_STACK_START(gc->mark_stack); } -static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, void *p); +static inline void propagate_marks_worker(NewGC *gc, void *p); /*****************************************************************************/ /* MEMORY ACCOUNTING */ @@ -2618,7 +2724,7 @@ static void free_child_gc(void); inline static int page_mmu_type(mpage *page) { switch (page->size_class) { case 0: /* SMALL_PAGE , GEN0_PAGE */ - if (page->generation) { return MMU_SMALL_GEN1; } + if (page->generation >= AGE_GEN_1) { return MMU_SMALL_GEN1; } else return MMU_SMALL_GEN0; case 1: /* MED PAGE */ case 2: /* BIG PAGE */ @@ -2643,23 +2749,16 @@ static int designate_modified_gc(NewGC *gc, void *p) return 0; } - if(page) { - if (!page->back_pointers) { - page->mprotected = 0; - mmu_write_unprotect_page(gc->mmu, page->addr, real_page_size(page)); - GC_MP_CNT_INC(mp_write_barrier_cnt); - page->back_pointers = 1; - } - /* For a single mutator thread, we shouldn't get here - (and a `return 1' in the braces above would make more - sense). With multiple mutators, though, two threads might - hit the same page at effectively the same time, and only - the first one of them will handle the signal. */ + if (page) { + page->mprotected = 0; + mmu_write_unprotect_page(gc->mmu, page->addr, real_page_size(page)); + GC_MP_CNT_INC(mp_write_barrier_cnt); + page->back_pointers = 1; + gc->modified_unprotects++; return 1; } else { - if (gc->primoridal_gc) { + if (gc->primoridal_gc) return designate_modified_gc(gc->primoridal_gc, p); - } GCPRINT(GCOUTF, "Seg fault (internal error) at %p\n", p); } return 0; @@ -3218,7 +3317,7 @@ intptr_t GC_get_memory_use(void *o) /*****************************************************************************/ static void promote_marked_gen0_big_page(NewGC *gc, mpage *page) { - page->generation = 1; + page->generation = AGE_GEN_1; /* remove page */ if(page->prev) page->prev->next = page->next; else @@ -3242,9 +3341,42 @@ static void promote_marked_gen0_big_page(NewGC *gc, mpage *page) { #endif } -/* We use two mark routines to handle propagation. Why two? The first is the - one that we export out, and it does a metric crapload of work. The second - we use internally, and it doesn't do nearly as much. */ +static void mark_recur_or_push_ptr(struct NewGC *gc, void *p) +{ + objhead *ohead = OBJPTR_TO_OBJHEAD(p); + + if (gc->mark_depth < MAX_RECUR_MARK_DEPTH) { + switch (ohead->type) { + case PAGE_TAGGED: + { + const unsigned short tag = *(unsigned short*)p; + Mark2_Proc markproc; + ASSERT_TAG(tag); + markproc = gc->mark_table[tag]; + if(((uintptr_t) markproc) >= PAGE_TYPES) { + GC_ASSERT(markproc); + gc->mark_depth++; + markproc(p, gc); + --gc->mark_depth; + } + } + return; + case PAGE_PAIR: + { + Scheme_Object *pr = (Scheme_Object *)p; + gc->mark_depth++; + GC_mark2(SCHEME_CDR(pr), gc); + GC_mark2(SCHEME_CAR(pr), gc); + --gc->mark_depth; + } + return; + default: + break; + } + } + + push_ptr(gc, p); +} /* This is the first mark routine. It's a bit complicated. */ void GC_mark2(const void *const_p, struct NewGC *gc) @@ -3258,7 +3390,7 @@ void GC_mark2(const void *const_p, struct NewGC *gc) return; } - if(!(page = pagemap_find_page_for_marking(gc, p, 0))) { + if(!(page = pagemap_find_page_for_marking(gc, p))) { #ifdef MZ_USE_PLACES if (gc->major_places_gc && (page = pagemap_find_page(MASTERGC->page_maps, p))) { is_a_master_page = 1; @@ -3273,24 +3405,6 @@ void GC_mark2(const void *const_p, struct NewGC *gc) } } -#if 0 - if (page->size_class < 2) { - if (page->page_type == PAGE_TAGGED) { - void *q; - if (page->size_class) - q = MED_OBJHEAD(p, page->size) + 1; - else - q = p; - if (((objhead *)q)[-1].type == PAGE_TAGGED) { - if (!((objhead *)q)[-1].moved) { - if ((*(short *)q < 0) || (*(short *)q > 1000)) - abort(); - } - } - } - } -#endif - #ifdef NEWGC_BTC_ACCOUNT /* toss this over to the BTC mark routine if we're doing accounting */ if(gc->doing_memory_accounting) { @@ -3300,12 +3414,12 @@ void GC_mark2(const void *const_p, struct NewGC *gc) #endif /* MED OR BIG PAGE */ - if(page->size_class) { + if (page->size_class) { /* BIG PAGE */ - if(page->size_class > 1) { + if (page->size_class > 1) { /* This is a bigpage. The first thing we do is see if its been marked previously */ - if(page->size_class != 2) { + if (page->size_class != 2) { GCDEBUG((DEBUGOUTF, "Not marking %p on big %p (already marked)\n", p, page)); return; } @@ -3313,7 +3427,7 @@ void GC_mark2(const void *const_p, struct NewGC *gc) page->size_class = 3; /* if this is in the nursery, we want to move it out of the nursery */ - if(!page->generation && !is_a_master_page) + if((page->generation == AGE_GEN_0) && !is_a_master_page) promote_marked_gen0_big_page(gc, page); page->marked_on = 1; @@ -3334,7 +3448,7 @@ void GC_mark2(const void *const_p, struct NewGC *gc) p = OBJHEAD_TO_OBJPTR(info); backtrace_new_page_if_needed(gc, page); record_backtrace(gc, page, p); - push_ptr(gc, p); + mark_recur_or_push_ptr(gc, p); } } /* SMALL_PAGE from gen0 or gen1 */ @@ -3346,9 +3460,9 @@ void GC_mark2(const void *const_p, struct NewGC *gc) return; } - /* what we do next depends on whether this is a gen0 or gen1 + /* what we do next depends on whether this is a gen0, gen_half, or gen1 object */ - if(page->generation) { + if (page->generation >= AGE_GEN_1) { /* this is a generation 1 object. This means we are not going to move it, we don't have to check to see if it's an atomic object masquerading as a tagged object, etc. So all we do @@ -3361,18 +3475,18 @@ void GC_mark2(const void *const_p, struct NewGC *gc) page->previous_size = PREFIX_SIZE; page->live_size += ohead->size; record_backtrace(gc, page, p); - push_ptr(gc, p); - } - else { + mark_recur_or_push_ptr(gc, p); + } else { GCDEBUG((DEBUGOUTF, "Not marking %p (it's old; %p / %i)\n", p, page, page->previous_size)); } } else { - /* this is a generation 0 object. This means that we do have + /* this is a generation 0 or 1/2 object. This means that we do have to do all of the above. Fun, fun, fun. */ unsigned short type = ohead->type; mpage *work; size_t size; objhead *newplace; + int new_type; /* first check to see if this is an atomic object masquerading as a tagged object; if it is, then convert it */ @@ -3381,53 +3495,64 @@ void GC_mark2(const void *const_p, struct NewGC *gc) type = ohead->type = (int)(uintptr_t)gc->mark_table[*(unsigned short*)p]; } - /* now set us up for the search for where to put this thing */ - work = gc->gen1_pages[type]; size = gcWORDS_TO_BYTES(ohead->size); - /* search for a page with the space to spare */ - if (work && ((work->size + size) >= APAGE_SIZE)) - work = NULL; - - /* now either fetch where we're going to put this object or make - a new page if we couldn't find a page with space to spare */ - if(work) { - if (!work->added) { - pagemap_add(gc->page_maps, work); - work->added = 1; - } - work->marked_on = 1; - if (work->mprotected) { - work->mprotected = 0; - mmu_write_unprotect_page(gc->mmu, work->addr, APAGE_SIZE); - GC_MP_CNT_INC(mp_mark_cnt); + if (AGE_GEN_0_TO_GEN_HALF(gc) && (page->generation == AGE_GEN_0) && !gc->gc_full) { + /* move to generation 1/2 */ + work = gc->gen_half.curr_alloc_page; + if (!work || (work->size + size > GEN0_PAGE_SIZE)) { + /* new generation 1/2 page */ + gen_half_allocate_and_setup_new_page(gc); + work = gc->gen_half.curr_alloc_page; + backtrace_new_gen_half_page(gc, work); } newplace = PTR(NUM(work->addr) + work->size); + work->size += size; + new_type = 1; /* i.e., in gen 1/2 */ } else { - int protectable = (type == PAGE_ATOMIC) ? MMU_NON_PROTECTABLE : MMU_PROTECTABLE; - /* Allocate and prep the page */ - work = malloc_mpage(); - work->addr = malloc_pages(gc, APAGE_SIZE, APAGE_SIZE, MMU_DIRTY, MMU_SMALL_GEN1, protectable, - &work->mmu_src_block, 1); - work->generation = 1; - work->page_type = type; - work->size = work->previous_size = PREFIX_SIZE; - work->marked_on = 1; - backtrace_new_page(gc, work); - work->next = gc->gen1_pages[type]; - work->prev = NULL; - if(work->next) - work->next->prev = work; - pagemap_add(gc->page_maps, work); - work->added = 1; - gc->gen1_pages[type] = work; - newplace = PAGE_TO_OBJHEAD(work); - GCVERBOSEPAGE(gc, "NEW SMALL GEN1 PAGE", work); - } + /* now set us up for the search for where to put this thing in gen 1 */ + work = gc->gen1_pages[type]; - /* update the size */ - work->size += size; - work->has_new = 1; + /* search for a page with the space to spare */ + if (work && ((work->size + size) >= APAGE_SIZE)) + work = NULL; + + /* now either fetch where we're going to put this object or make + a new page if we couldn't find a page with space to spare */ + if (work) { + work->marked_on = 1; + if (work->mprotected) { + work->mprotected = 0; + mmu_write_unprotect_page(gc->mmu, work->addr, APAGE_SIZE); + GC_MP_CNT_INC(mp_mark_cnt); + } + newplace = PTR(NUM(work->addr) + work->size); + } else { + int protectable = (type == PAGE_ATOMIC) ? MMU_NON_PROTECTABLE : MMU_PROTECTABLE; + /* Allocate and prep the page */ + work = malloc_mpage(); + work->addr = malloc_pages(gc, APAGE_SIZE, APAGE_SIZE, MMU_DIRTY, MMU_SMALL_GEN1, protectable, + &work->mmu_src_block, 1); + work->generation = AGE_GEN_1; + work->page_type = type; + work->size = work->previous_size = PREFIX_SIZE; + work->marked_on = 1; + backtrace_new_page(gc, work); + work->next = gc->gen1_pages[type]; + work->prev = NULL; + if(work->next) + work->next->prev = work; + pagemap_add(gc->page_maps, work); + gc->gen1_pages[type] = work; + newplace = PAGE_TO_OBJHEAD(work); + GCVERBOSEPAGE(gc, "NEW SMALL GEN1 PAGE", work); + } + + /* update the size */ + work->size += size; + work->has_new = 1; + new_type = 0; /* i.e., not in gen 1/2 */ + } /* transfer the object */ ohead->mark = 1; /* mark is copied to newplace, too */ @@ -3439,6 +3564,7 @@ void GC_mark2(const void *const_p, struct NewGC *gc) /* mark the old location as marked and moved, and the new location as marked */ ohead->moved = 1; + ohead->type = new_type; /* if we're doing memory accounting, then we need the btc_mark to be set properly */ #ifdef NEWGC_BTC_ACCOUNT @@ -3454,7 +3580,7 @@ void GC_mark2(const void *const_p, struct NewGC *gc) /* set forwarding pointer */ GCDEBUG((DEBUGOUTF,"Marking %p (moved to %p on page %p)\n", p, newp, work)); *(void**)p = newp; - push_ptr(gc, newp); + mark_recur_or_push_ptr(gc, newp); } } } @@ -3467,7 +3593,7 @@ void GC_mark(const void *const_p) /* this is the second mark routine. It's not quite as complicated. */ /* this is what actually does mark propagation */ -static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, void *pp) +static inline void propagate_marks_worker(NewGC *gc, void *pp) { void **start, **end; int alloc_type; @@ -3478,7 +3604,7 @@ static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, voi if (IS_BIG_PAGE_PTR(pp)) { mpage *page; p = REMOVE_BIG_PAGE_PTR_TAG(pp); - page = pagemap_find_page_for_marking(gc, p, 0); + page = pagemap_find_page(gc->page_maps, p); #ifdef MZ_USE_PLACES if (!page && gc->major_places_gc) { page = pagemap_find_page(MASTERGC->page_maps, p); @@ -3504,7 +3630,7 @@ static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, voi const unsigned short tag = *(unsigned short*)start; Mark2_Proc markproc; ASSERT_TAG(tag); - markproc = mark_table[tag]; + markproc = gc->mark_table[tag]; if(((uintptr_t) markproc) >= PAGE_TYPES) { GC_ASSERT(markproc); markproc(start, gc); @@ -3523,16 +3649,16 @@ static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, voi ASSERT_TAG(tag); end -= INSET_WORDS; while(start < end) { - GC_ASSERT(mark_table[tag]); - start += mark_table[tag](start, gc); + GC_ASSERT(gc->mark_table[tag]); + start += gc->mark_table[tag](start, gc); } break; } case PAGE_PAIR: { Scheme_Object *p = (Scheme_Object *)start; - GC_mark2(SCHEME_CAR(p), gc); GC_mark2(SCHEME_CDR(p), gc); + GC_mark2(SCHEME_CAR(p), gc); } break; } @@ -3541,11 +3667,10 @@ static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, voi static void propagate_marks(NewGC *gc) { void *p; - Mark2_Proc *mark_table = gc->mark_table; while(pop_ptr(gc, &p)) { GCDEBUG((DEBUGOUTF, "Popped pointer %p\n", p)); - propagate_marks_worker(gc, mark_table, p); + propagate_marks_worker(gc, p); } } @@ -3557,7 +3682,9 @@ static void propagate_marks_plus_ephemerons(NewGC *gc) } #ifdef MZ_USE_PLACES -static void promote_marked_gen0_big_pages(NewGC *gc) { +static void promote_marked_gen0_big_pages(NewGC *gc) +/* used for the master GC, only */ +{ mpage *page; mpage *next; @@ -3572,14 +3699,14 @@ static void promote_marked_gen0_big_pages(NewGC *gc) { void *GC_resolve2(void *p, NewGC *gc) { - mpage *page = pagemap_find_page_for_marking(gc, p, 1); + mpage *page = pagemap_find_page_for_marking(gc, p); objhead *info; if(!page || page->size_class) return p; info = OBJPTR_TO_OBJHEAD(p); - if(info->mark && info->moved) + if (info->mark && info->moved) return *(void**)p; else return p; @@ -3603,7 +3730,7 @@ void GC_fixup2(void *pp, struct NewGC *gc) if (!p || (NUM(p) & 0x1)) return; - page = pagemap_find_page_for_marking(gc, p, 1); + page = pagemap_find_page_for_marking(gc, p); if (page) { objhead *info; @@ -3613,10 +3740,14 @@ void GC_fixup2(void *pp, struct NewGC *gc) info = OBJPTR_TO_OBJHEAD(p); /* assert: info->moved => info->mark */ /* !gc->gc_full => info->moved */ - if (info->moved) + if (info->moved) { *(void**)pp = *(void**)p; - else { + if (info->type) + gc->back_pointers = 1; + } else { GCDEBUG((DEBUGOUTF, "Not repairing %p from %p (not moved)\n",p,pp)); + if (page->generation < AGE_GEN_1) + gc->back_pointers = 1; } } else { #ifdef POINTER_OWNERSHIP_CHECK @@ -3825,6 +3956,8 @@ void GC_dump_with_traces(int flags, GCWARN((GCOUTF, "Generation 0: %" PRIdPTR " of %" PRIdPTR " bytes used\n", (uintptr_t) gen0_size_in_use(gc), gc->gen0.max_size)); + GCWARN((GCOUTF, "Generation 0.5: %" PRIdPTR " bytes used\n", + (uintptr_t) gen_half_size_in_use(gc))); for(i = 0; i < PAGE_TYPES; i++) { uintptr_t total_use = 0, count = 0; @@ -3865,6 +3998,7 @@ void GC_dump_with_traces(int flags, GCWARN((GCOUTF,"\n")); GCWARN((GCOUTF,"Current memory use: %" PRIdPTR "\n", GC_get_memory_use(NULL))); + GCWARN((GCOUTF,"Peak memory use before a collection: %" PRIdPTR "\n", gc->peak_pre_memory_use)); GCWARN((GCOUTF,"Peak memory use after a collection: %" PRIdPTR "\n", gc->peak_memory_use)); GCWARN((GCOUTF,"Allocated (+reserved) page sizes: %" PRIdPTR " (+%" PRIdPTR ")\n", gc->used_pages * APAGE_SIZE, @@ -3874,6 +4008,9 @@ void GC_dump_with_traces(int flags, GCWARN((GCOUTF,"# of installed finalizers: %i\n", gc->num_fnls)); GCWARN((GCOUTF,"# of traced ephemerons: %i\n", gc->num_last_seen_ephemerons)); GCWARN((GCOUTF,"# of immobile boxes: %i\n", num_immobiles)); + GCWARN((GCOUTF,"# of page-modify unprotects: %" PRIdPTR "\n", gc->modified_unprotects)); + GCWARN((GCOUTF,"# of old regions scanned during minor GCs: %" PRIdPTR "/%" PRIdPTR "\n", + gc->minor_old_traversed, gc->minor_old_traversed + gc->minor_old_skipped)); } if (flags & GC_DUMP_SHOW_TRACE) { @@ -3956,7 +4093,7 @@ static void reset_gen1_pages_live_and_previous_sizes(NewGC *gc) for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { for (work = gc->med_pages[MED_PAGE_NONATOMIC][i]; work; work = work->next) { - if (work->generation) { + if (work->generation > AGE_GEN_0) { reset_gen1_page(gc, work); } } @@ -3968,43 +4105,36 @@ static void reset_gen1_pages_live_and_previous_sizes(NewGC *gc) #endif } -static void remove_all_gen1_pages_from_pagemap(NewGC *gc) -{ - /* We don't have to work here; just setting gc->gc_full to - 0 means that any page with a non-0 `generation' and a - 0 `marked_on' will not be returned by - pagemap_find_page_for_marking(). */ -} - static void mark_backpointers(NewGC *gc) { - if(!gc->gc_full) { + if (!gc->gc_full) { mpage *work; - int i, ty; - PageMap pagemap = gc->page_maps; + int i, ty, traversed = 0, skipped = 0; /* if this is not a full collection, then we need to mark any pointers that point backwards into generation 0, since they're roots. */ - for(i = 0; i < PAGE_TYPES; i++) { - for(work = gc->gen1_pages[i]; work; work = work->next) { - if(work->back_pointers) { - /* these pages are guaranteed not to be write protected, because - if they were, they wouldn't have this bit set */ - work->marked_on = 1; + for (i = 0; i < PAGE_TYPES; i++) { + for (work = gc->gen1_pages[i]; work; work = work->next) { + if (work->back_pointers) { + if (work->mprotected) { + /* expected only if QUEUED_MPROTECT_IS_PROMISCUOUS && AGE_GEN_0_TO_GEN_HALF(gc) */ + work->mprotected = 0; + mmu_write_unprotect_page(gc->mmu, work->addr, real_page_size(work)); + } + work->marked_from = 1; work->previous_size = PREFIX_SIZE; - pagemap_add(pagemap, work); - if(work->size_class) { + if (work->size_class) { /* must be a big page */ work->size_class = 3; push_ptr(gc, TAG_AS_BIG_PAGE_PTR(BIG_PAGE_TO_OBJECT(work))); } else { - if(work->page_type != PAGE_ATOMIC) { + if (work->page_type != PAGE_ATOMIC) { void **start = PAGE_START_VSS(work); void **end = PAGE_END_VSS(work); while(start < end) { objhead *info = (objhead *)start; - if(!info->dead) { + if (!info->dead) { info->mark = 1; /* This must be a push_ptr, and not a direct call to internal_mark. This is because we need every object @@ -4017,10 +4147,12 @@ static void mark_backpointers(NewGC *gc) } } work->previous_size = PREFIX_SIZE; + traversed++; } else { GCDEBUG((DEBUGOUTF,"Setting previous_size on %p to %i\n", work, work->size)); work->previous_size = work->size; + skipped++; } } } @@ -4028,17 +4160,22 @@ static void mark_backpointers(NewGC *gc) for (ty = 0; ty < MED_PAGE_TYPES; ty++) { for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { for (work = gc->med_pages[ty][i]; work; work = work->next) { - if(work->back_pointers) { + if (work->back_pointers) { void **start = PPTR(NUM(work->addr) + PREFIX_SIZE); void **end = PPTR(NUM(work->addr) + APAGE_SIZE - work->size); - - work->marked_on = 1; - pagemap_add(pagemap, work); + + if (work->mprotected) { + /* expected only if QUEUED_MPROTECT_IS_PROMISCUOUS && AGE_GEN_0_TO_GEN_HALF(gc) */ + work->mprotected = 0; + mmu_write_unprotect_page(gc->mmu, work->addr, real_page_size(work)); + } + + work->marked_from = 1; if (ty == MED_PAGE_NONATOMIC) { - while(start <= end) { + while (start <= end) { objhead *info = (objhead *)start; - if(!info->dead) { + if (!info->dead) { info->mark = 1; /* This must be a push_ptr (see above) */ push_ptr(gc, OBJHEAD_TO_OBJPTR(info)); @@ -4046,10 +4183,16 @@ static void mark_backpointers(NewGC *gc) start += info->size; } } + traversed++; + } else { + skipped++; } } } } + + gc->minor_old_traversed += traversed; + gc->minor_old_skipped += skipped; } } @@ -4060,12 +4203,12 @@ mpage *allocate_compact_target(NewGC *gc, mpage *work) npage->addr = malloc_pages(gc, APAGE_SIZE, APAGE_SIZE, MMU_DIRTY, MMU_SMALL_GEN1, page_mmu_protectable(work), &npage->mmu_src_block, 1); npage->previous_size = npage->size = PREFIX_SIZE; - npage->generation = 1; - npage->back_pointers = 0; + npage->generation = AGE_GEN_1; npage->size_class = 0; npage->page_type = work->page_type; npage->marked_on = 1; backtrace_new_page(gc, npage); + pagemap_add(gc->page_maps, npage); GCVERBOSEPAGE(gc, "NEW COMPACT PAGE", npage); /* Link in this new replacement page */ npage->prev = work; @@ -4091,7 +4234,6 @@ inline static void do_heap_compact(NewGC *gc) { int i; int tic_tock = gc->num_major_collects % 2; - PageMap pagemap = gc->page_maps; mmu_prep_for_compaction(gc->mmu); #ifdef GC_MP_CNT mp_prev_compact_cnt = mp_compact_cnt; @@ -4107,12 +4249,12 @@ inline static void do_heap_compact(NewGC *gc) } npage = work; - while(work) { - if(work->marked_on && !work->has_new) { + while (work) { + if ((work->marked_on || work->marked_from) && !work->has_new) { /* then determine if we actually want to do compaction */ - if(NO_BACKTRACE_AND(tic_tock - ? should_compact_page(gcWORDS_TO_BYTES(work->live_size),work->size) - : mmu_should_compact_page(gc->mmu, &work->mmu_src_block))) { + if (NO_BACKTRACE_AND(tic_tock + ? should_compact_page(gcWORDS_TO_BYTES(work->live_size),work->size) + : mmu_should_compact_page(gc->mmu, &work->mmu_src_block))) { void **start = PAGE_START_VSS(work); void **end = PAGE_END_VSS(work); void **newplace; @@ -4128,10 +4270,10 @@ inline static void do_heap_compact(NewGC *gc) avail = gcBYTES_TO_WORDS(APAGE_SIZE - npage->size); newplace = PPTR(NUM(npage->addr) + npage->size); - while(start < end) { + while (start < end) { objhead *info = (objhead *)start; - if(info->mark) { + if (info->mark) { while (avail <= info->size) { npage->size = NUM(newplace) - NUM(npage->addr); do { @@ -4145,7 +4287,6 @@ inline static void do_heap_compact(NewGC *gc) #if defined(GC_DEBUG_PAGES) { - pagemap_add(pagemap, work); fprintf(gcdebugOUT(gc), "Compacting from %p to %p \n", start+1, newplace+1); fprintf_debug(gc, work, "Compacting", info, gcdebugOUT(gc), 0); } @@ -4157,6 +4298,7 @@ inline static void do_heap_compact(NewGC *gc) gcWORDS_TO_BYTES(info->size), start+1, newplace+1)); memcpy(newplace, start, gcWORDS_TO_BYTES(info->size)); info->moved = 1; + info->type = 0; /* not moved to gen 1/2 */ *(PPTR(OBJHEAD_TO_OBJPTR(start))) = OBJHEAD_TO_OBJPTR(newplace); copy_backtrace_source(npage, newplace, work, start); newplace += info->size; @@ -4175,9 +4317,6 @@ inline static void do_heap_compact(NewGC *gc) work->next = gc->release_pages; gc->release_pages = work; - /* add the old page to the page map so fixups can find forwards */ - pagemap_add(pagemap, work); - work = prev; } else { work = work->prev; @@ -4241,35 +4380,93 @@ static void killing_debug(NewGC *gc, mpage *page, objhead *info) { } #endif +static void repair_mixed_page(NewGC *gc, mpage *page, void **end) +{ + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); + Fixup2_Proc *fixup_table = gc->fixup_table; + + gc->back_pointers = 0; + + while (start <= end) { + objhead *info = (objhead *)start; + if (info->mark) { + switch(info->type) { + case PAGE_ARRAY: + { + void **tempend = PPTR(info) + info->size; + start = OBJHEAD_TO_OBJPTR(start); + while (start < tempend) gcFIXUP2(*start++, gc); + } + break; + case PAGE_TAGGED: + { + void *obj_start = OBJHEAD_TO_OBJPTR(start); + unsigned short tag = *(unsigned short *)obj_start; + ASSERT_TAG(tag); + fixup_table[tag](obj_start, gc); + start += info->size; + } + break; + case PAGE_ATOMIC: + start += info->size; + break; + case PAGE_TARRAY: + { + void **tempstart, **tempend = PPTR(info) + (info->size - INSET_WORDS); + unsigned short tag; + tempstart = OBJHEAD_TO_OBJPTR(start); + tag = *(unsigned short*)tempstart; + ASSERT_TAG(tag); + while (tempstart < tempend) + tempstart += fixup_table[tag](tempstart, gc); + start += info->size; + } + break; + case PAGE_PAIR: + { + Scheme_Object *p = (Scheme_Object *)OBJHEAD_TO_OBJPTR(start); + gcFIXUP2(SCHEME_CAR(p), gc); + gcFIXUP2(SCHEME_CDR(p), gc); + start += info->size; + } + break; + default: + printf("Unhandled info->type %i\n", info->type); + abort(); + } + info->mark = 0; +#ifdef MZ_USE_PLACES + page->marked_from = 1; +#endif + } else { +#ifdef KILLING_DEBUG + killing_debug(gc, page, info); +#endif + info->dead = 1; + start += info->size; + } + } + + page->back_pointers = gc->back_pointers; +} + static void repair_heap(NewGC *gc) { mpage *page; int i, ty; Fixup2_Proc *fixup_table = gc->fixup_table; -#ifdef MZ_USE_PLACES - int master_has_switched = postmaster_and_master_gc(gc); -#endif - - for(i = 0; i < PAGE_TYPES; i++) { - for(page = gc->gen1_pages[i]; page; page = page->next) { -#ifdef MZ_USE_PLACES - if (master_has_switched || page->marked_on) -#else - if (page->marked_on) -#endif - { + for (i = 0; i < PAGE_TYPES; i++) { + for (page = gc->gen1_pages[i]; page; page = page->next) { + if (page->marked_on || page->marked_from) { page->has_new = 0; + gc->back_pointers = 0; /* these are guaranteed not to be protected */ - if(page->size_class) { + if (page->size_class) { /* since we get here via gen1_pages, it's a big page */ void **start = PPTR(BIG_PAGE_TO_OBJECT(page)); void **end = PAGE_END_VSS(page); -#ifdef MZ_USE_PLACES - objhead *info = BIG_PAGE_TO_OBJHEAD(page); - if (page->marked_on || info->mark) { - page->marked_on = 1; -#endif + GCDEBUG((DEBUGOUTF, "Cleaning objs on page %p, starting with %p\n", page, start)); page->size_class = 2; /* remove the mark */ @@ -4288,22 +4485,15 @@ static void repair_heap(NewGC *gc) gcFIXUP2(SCHEME_CDR(p), gc); } break; - case PAGE_TARRAY: { - unsigned short tag = *(unsigned short *)start; - ASSERT_TAG(tag); - end -= INSET_WORDS; - while(start < end) start += fixup_table[tag](start, gc); - break; + case PAGE_TARRAY: + { + unsigned short tag = *(unsigned short *)start; + ASSERT_TAG(tag); + end -= INSET_WORDS; + while(start < end) start += fixup_table[tag](start, gc); + break; + } } - } -#ifdef MZ_USE_PLACES - } - else { -#ifdef KILLING_DEBUG - killing_debug(gc, page, info); -#endif - } -#endif } else { void **start = PPTR(NUM(page->addr) + page->previous_size); void **end = PAGE_END_VSS(page); @@ -4404,6 +4594,8 @@ static void repair_heap(NewGC *gc) break; } } + + page->back_pointers = gc->back_pointers; } else GCDEBUG((DEBUGOUTF,"Not Cleaning page %p\n", page)); } } @@ -4411,58 +4603,16 @@ static void repair_heap(NewGC *gc) for (ty = 0; ty < MED_PAGE_TYPES; ty++) { for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { for (page = gc->med_pages[ty][i]; page; page = page->next) { -#ifdef MZ_USE_PLACES - if (master_has_switched || page->marked_on) -#else - if (page->marked_on) -#endif - { - void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); - void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); - - while(start <= end) { - objhead *info = (objhead *)start; - if(info->mark) { - switch(info->type) { - case PAGE_ARRAY: - { - void **tempend = PPTR(info) + info->size; - start = OBJHEAD_TO_OBJPTR(start); - while(start < tempend) gcFIXUP2(*start++, gc); - } - break; - case PAGE_TAGGED: - { - void *obj_start = OBJHEAD_TO_OBJPTR(start); - unsigned short tag = *(unsigned short *)obj_start; - ASSERT_TAG(tag); - fixup_table[tag](obj_start, gc); - start += info->size; - } - break; - case PAGE_ATOMIC: - start += info->size; - break; - default: - printf("Unhandled info->type %i\n", info->type); - abort(); - } - info->mark = 0; -#ifdef MZ_USE_PLACES - page->marked_on = 1; -#endif - } else { -#ifdef KILLING_DEBUG - killing_debug(gc, page, info); -#endif - info->dead = 1; - start += info->size; - } - } - } + if (page->marked_on || page->marked_from) + repair_mixed_page(gc, page, PPTR(NUM(page->addr) + APAGE_SIZE - page->size)); } } } + + for (page = gc->gen_half.pages; page; page = page->next) { + GC_ASSERT(page->generation == AGE_GEN_HALF); + repair_mixed_page(gc, page, PPTR(NUM(page->addr) + page->size - 1)); + } } static inline void gen1_free_mpage(PageMap pagemap, mpage *page) { @@ -4495,6 +4645,21 @@ inline static void gen0_free_entire_nursery(NewGC *gc) { } } +static void gen_half_free_mpage(NewGC *gc, mpage *work) +{ + free_gen_half_backtrace(work); + gen0_free_mpage(gc, work); +} + +inline static void gen_half_free_entire_nursery(NewGC *gc) { + mpage *work = gc->gen_half.pages; + while(work) { + mpage *next = work->next; + gen_half_free_mpage(gc, work); + work = next; + } +} + inline static void gen0_free_big_pages(NewGC *gc) { mpage *work; mpage *next; @@ -4522,12 +4687,12 @@ static void clean_up_heap(NewGC *gc) gen0_free_big_pages(gc); for(i = 0; i < PAGE_TYPES; i++) { - if(gc->gc_full) { + if (gc->gc_full) { mpage *work = gc->gen1_pages[i]; mpage *prev = NULL; while(work) { mpage *next = work->next; - if(!work->marked_on) { + if (!work->marked_on) { /* remove work from list */ if(prev) prev->next = next; else gc->gen1_pages[i] = next; if(next) work->next->prev = prev; @@ -4535,8 +4700,8 @@ static void clean_up_heap(NewGC *gc) gen1_free_mpage(pagemap, work); } else { GCVERBOSEPAGE(gc, "clean_up_heap BIG PAGE ALIVE", work); - pagemap_add(pagemap, work); - work->back_pointers = work->marked_on = 0; + work->marked_on = 0; + work->marked_from = 0; memory_in_use += work->size; prev = work; } @@ -4544,9 +4709,9 @@ static void clean_up_heap(NewGC *gc) } } else { mpage *work; - for(work = gc->gen1_pages[i]; work; work = work->next) { - pagemap_add(pagemap, work); - work->back_pointers = work->marked_on = 0; + for (work = gc->gen1_pages[i]; work; work = work->next) { + work->marked_on = 0; + work->marked_from = 0; memory_in_use += work->size; } } @@ -4571,23 +4736,17 @@ static void clean_up_heap(NewGC *gc) start += info->size; } + GC_ASSERT(non_dead); /* otherwise, wouldn't have marked_on */ + next = work->next; - if (non_dead) { - work->live_size = (work->size * non_dead); - memory_in_use += work->live_size; - work->previous_size = PREFIX_SIZE; - work->back_pointers = work->marked_on = 0; - work->generation = 1; - pagemap_add(pagemap, work); - prev = work; - } else { - /* free the page */ - if(prev) prev->next = next; else gc->med_pages[ty][i] = next; - if(next) work->next->prev = prev; - GCVERBOSEPAGE(gc, "Cleaning up MED PAGE NO OBJ", work); - gen1_free_mpage(pagemap, work); - } - } else if (gc->gc_full || !work->generation) { + work->live_size = (work->size * non_dead); + memory_in_use += work->live_size; + work->previous_size = PREFIX_SIZE; + work->marked_on = 0; + work->marked_from = 0; + work->generation = AGE_GEN_1; + prev = work; + } else if (gc->gc_full || (work->generation == AGE_GEN_0)) { /* Page wasn't touched in full GC, or gen-0 not touched, so we can free it. */ next = work->next; @@ -4596,19 +4755,20 @@ static void clean_up_heap(NewGC *gc) GCVERBOSEPAGE(gc, "Cleaning up MED NO MARKEDON", work); gen1_free_mpage(pagemap, work); } else { - /* not touched during minor gc */ + /* not marked during minor gc */ memory_in_use += work->live_size; work->previous_size = PREFIX_SIZE; + work->marked_from = 0; next = work->next; prev = work; - work->back_pointers = 0; - pagemap_add(pagemap, work); } } gc->med_freelist_pages[ty][i] = prev; } } + memory_in_use += gen_half_size_in_use(gc); + memory_in_use = add_no_overflow(memory_in_use, gc->phantom_count); gc->memory_in_use = memory_in_use; @@ -4657,15 +4817,15 @@ static void protect_old_pages(NewGC *gc) mp_gc_protect_cnt = mp_pr_add_cnt; #endif - for(i = 0; i < PAGE_TYPES; i++) { - if(i != PAGE_ATOMIC) { - for(page = gc->gen1_pages[i]; page; page = page->next) { + for (i = 0; i < PAGE_TYPES; i++) { + if (i != PAGE_ATOMIC) { + for (page = gc->gen1_pages[i]; page; page = page->next) { if (page->page_type != PAGE_ATOMIC) { - if (!page->mprotected) { - page->back_pointers = 0; + if (!page->mprotected && !page->back_pointers) { page->mprotected = 1; mmu_queue_write_protect_range(mmu, page->addr, real_page_size(page), page_mmu_type(page), &page->mmu_src_block); - } + } else if (QUEUED_MPROTECT_IS_PROMISCUOUS) + page->mprotected = 1; } } } @@ -4673,11 +4833,11 @@ static void protect_old_pages(NewGC *gc) for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { for (page = gc->med_pages[MED_PAGE_NONATOMIC][i]; page; page = page->next) { - if (!page->mprotected) { - page->back_pointers = 0; + if (!page->mprotected && !page->back_pointers) { page->mprotected = 1; mmu_queue_write_protect_range(mmu, page->addr, APAGE_SIZE, page_mmu_type(page), &page->mmu_src_block); - } + } else if (QUEUED_MPROTECT_IS_PROMISCUOUS) + page->mprotected = 1; } } @@ -4833,8 +4993,8 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log if (gc->gc_full) reset_gen1_pages_live_and_previous_sizes(gc); - else /* minor collection */ - remove_all_gen1_pages_from_pagemap(gc); + + move_gen_half_pages_to_old(gc); init_weak_boxes(gc); init_weak_arrays(gc); @@ -4930,6 +5090,7 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log TIME_STEP("repaired"); clean_up_heap(gc); TIME_STEP("cleaned heap"); + clean_gen_half(gc); #ifdef MZ_USE_PLACES if (postmaster_and_master_gc(gc) && !switching_master) { master_set_max_size(gc); @@ -4945,15 +5106,11 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log TIME_STEP("accounted"); if (gc->generations_available) { #ifdef MZ_USE_PLACES - if (postmaster_and_master_gc(gc) || switching_master) { + if (postmaster_and_master_gc(gc) || switching_master) unprotect_old_pages(gc); - } - else { - protect_old_pages(gc); - } -#else - protect_old_pages(gc); + else #endif + protect_old_pages(gc); } TIME_STEP("protect"); if (gc->gc_full) @@ -4975,6 +5132,8 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log /* update some statistics */ if(gc->gc_full) gc->num_major_collects++; else gc->num_minor_collects++; + if(gc->peak_memory_use < (old_mem_use + old_gen0)) + gc->peak_pre_memory_use = (old_mem_use + old_gen0); if(gc->peak_memory_use < gc->memory_in_use) gc->peak_memory_use = gc->memory_in_use; if(gc->gc_full) gc->since_last_full = 0; @@ -5157,6 +5316,7 @@ static void free_child_gc(void) gen0_free_big_pages(gc); gen0_free_entire_nursery(gc); + gen_half_free_entire_nursery(gc); /* First, unprotect all pages. It's important to "queue" up all this work as a batch to minimize commuincation with the OS and avoid fragmenting @@ -5203,6 +5363,7 @@ void GC_free_all(void) gen0_free_big_pages(gc); gen0_free_entire_nursery(gc); + gen_half_free_entire_nursery(gc); for(i = 0; i < PAGE_TYPES; i++) { for (work = gc->gen1_pages[i]; work; work = next) { diff --git a/racket/src/racket/gc2/newgc.h b/racket/src/racket/gc2/newgc.h index 8ec9356b39..6668b8016d 100644 --- a/racket/src/racket/gc2/newgc.h +++ b/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 :1; + unsigned char generation :2; 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,8 +188,13 @@ 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; diff --git a/racket/src/racket/gc2/vm.c b/racket/src/racket/gc2/vm.c index 7a096a8162..6e1a0077b3 100644 --- a/racket/src/racket/gc2/vm.c +++ b/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 diff --git a/racket/src/racket/gc2/weak.c b/racket/src/racket/gc2/weak.c index cd6c377f58..94e9df4886 100644 --- a/racket/src/racket/gc2/weak.c +++ b/racket/src/racket/gc2/weak.c @@ -73,8 +73,9 @@ 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) diff --git a/racket/src/racket/gc2/xform.rkt b/racket/src/racket/gc2/xform.rkt index bd795249c3..1f731af3fc 100644 --- a/racket/src/racket/gc2/xform.rkt +++ b/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 () diff --git a/racket/src/racket/include/mzwin.def b/racket/src/racket/include/mzwin.def index 67733f1b38..753f959fa1 100644 --- a/racket/src/racket/include/mzwin.def +++ b/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 diff --git a/racket/src/racket/include/mzwin3m.def b/racket/src/racket/include/mzwin3m.def index 18fe63c9d6..39f7185625 100644 --- a/racket/src/racket/include/mzwin3m.def +++ b/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 diff --git a/racket/src/racket/include/racket.exp b/racket/src/racket/include/racket.exp index d8ae7beda4..49957bbc49 100644 --- a/racket/src/racket/include/racket.exp +++ b/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 diff --git a/racket/src/racket/include/racket3m.exp b/racket/src/racket/include/racket3m.exp index cb1a958ef4..c7f99578d4 100644 --- a/racket/src/racket/include/racket3m.exp +++ b/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 diff --git a/racket/src/racket/include/scheme.h b/racket/src/racket/include/scheme.h index 4001ae6705..113ca373ae 100644 --- a/racket/src/racket/include/scheme.h +++ b/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; diff --git a/racket/src/racket/include/schthread.h b/racket/src/racket/include/schthread.h index 6ed170c8e4..8db6702332 100644 --- a/racket/src/racket/include/schthread.h +++ b/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_; - struct Scheme_Object *mark_id_; - struct Scheme_Object *current_rib_timestamp_; - struct Scheme_Hash_Table *quick_hash_table_; + mzlonglong scope_counter_; struct Scheme_Object *last_phase_shift_; - struct Scheme_Object *unsealed_dependencies_; - struct Scheme_Hash_Table *id_marks_ht_; - struct Scheme_Hash_Table *than_id_marks_ht_; - struct Scheme_Bucket_Table *interned_skip_ribs_; + struct Scheme_Object *nominal_ipair_cache_; + struct Scheme_Bucket_Table *taint_intern_table_; + struct Binding_Cache_Entry *binding_cache_table_; + 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 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 scope_counter XOA (scheme_get_thread_local_variables()->scope_counter_) #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 id_marks_ht XOA (scheme_get_thread_local_variables()->id_marks_ht_) -#define than_id_marks_ht XOA (scheme_get_thread_local_variables()->than_id_marks_ht_) -#define interned_skip_ribs XOA (scheme_get_thread_local_variables()->interned_skip_ribs_) +#define taint_intern_table XOA (scheme_get_thread_local_variables()->taint_intern_table_) +#define binding_cache_table XOA (scheme_get_thread_local_variables()->binding_cache_table_) +#define binding_cache_pos XOA (scheme_get_thread_local_variables()->binding_cache_pos_) +#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_) /* **************************************** */ diff --git a/racket/src/racket/mzconfig.h.in b/racket/src/racket/mzconfig.h.in index 6d852ff880..154363d47e 100644 --- a/racket/src/racket/mzconfig.h.in +++ b/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 diff --git a/racket/src/racket/src/Makefile.in b/racket/src/racket/src/Makefile.in index 467efd5e26..22d8ba1319 100644 --- a/racket/src/racket/src/Makefile.in +++ b/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@ diff --git a/racket/src/racket/src/bool.c b/racket/src/racket/src/bool.c index 035082bf26..759b895b54 100644 --- a/racket/src/racket/src/bool.c +++ b/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; - eql.car_depth = 1; - eql.ht = NULL; - eql.recur = NULL; - eql.next = NULL; - eql.next_next = NULL; - eql.insp = NULL; - eql.for_chaperone = 0; + init_equal_info(&eql); 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; - eql.car_depth = 1; - eql.ht = NULL; - eql.recur = NULL; - eql.next = NULL; + init_equal_info(&eql); 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; - eql.car_depth = 1; - eql.ht = NULL; - eql.recur = NULL; - eql.next_next = NULL; - eql.next = NULL; - eql.insp = NULL; - eql.for_chaperone = 0; + init_equal_info(&eql); 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) - && SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj2)->val), scheme_hash_tree_type) + if (SCHEME_HASHTRP(((Scheme_Chaperone *)obj1)->val) + && 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,17 +858,30 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) } case scheme_module_index_type: { - Scheme_Modidx *midx1, *midx2; + if (!eql->eq_for_modidx) { + Scheme_Modidx *midx1, *midx2; # include "mzeqchk.inc" - midx1 = (Scheme_Modidx *)obj1; - midx2 = (Scheme_Modidx *)obj2; - if (is_equal(midx1->path, midx2->path, eql)) { - obj1 = midx1->base; - obj2 = midx2->base; - goto top; + midx1 = (Scheme_Modidx *)obj1; + midx2 = (Scheme_Modidx *)obj2; + if (is_equal(midx1->path, midx2->path, eql)) { + obj1 = midx1->base; + obj2 = midx2->base; + 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) || (t1 == scheme_proc_chaperone_type))) { @@ -968,13 +999,7 @@ int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2) { 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; + init_equal_info(&eql); 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; - eql.car_depth = 1; - eql.ht = NULL; - eql.recur = NULL; - eql.next = NULL; - eql.next_next = NULL; - eql.insp = NULL; + init_equal_info(&eql); eql.for_chaperone = 3; return is_equal(obj1, obj2, &eql); diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index 3eb86f95fd..93e52d4da5 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -35,8 +35,6 @@ READ_ONLY static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1]; READ_ONLY static Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1]; -READ_ONLY static Scheme_Object *unshadowable_symbol; - /* If locked, these are probably sharable: */ THREAD_LOCAL_DECL(static Scheme_Hash_Table *toplevels_ht); THREAD_LOCAL_DECL(static Scheme_Hash_Table *locals_ht[2]); @@ -48,30 +46,8 @@ THREAD_LOCAL_DECL(static int env_uid_counter); #define ONE_ARBITRARY_USE 0x8 /* See also SCHEME_USE_COUNT_MASK */ -typedef struct Compile_Data { - int num_const; - Scheme_Object **const_names; - Scheme_Object **const_vals; - Scheme_Object **const_uids; - int *sealed; /* NULL => already sealed */ - int *use; - Scheme_Object *lifts; - int min_use, any_use; -} Compile_Data; - -typedef struct Scheme_Full_Comp_Env { - Scheme_Comp_Env base; - Compile_Data data; -} Scheme_Full_Comp_Env; - static void init_compile_data(Scheme_Comp_Env *env); -/* Precise GC WARNING: this macro produces unaligned pointers: */ -#define COMPILE_DATA(e) (&((Scheme_Full_Comp_Env *)e)->data) - -#define SCHEME_NON_SIMPLE_FRAME (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME \ - | SCHEME_FOR_STOPS | SCHEME_CAPTURE_LIFTED) - static void init_scheme_local(); static void init_toplevels(); @@ -107,8 +83,6 @@ void scheme_init_compenv_places(void) void scheme_init_compenv_symbol(void) { - REGISTER_SO(unshadowable_symbol); - unshadowable_symbol = scheme_intern_symbol("unshadowable"); } /*========================================================================*/ @@ -155,6 +129,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, dest[i].value_name = scheme_false; dest[i].observer = src[drec].observer; dest[i].pre_unwrapped = 0; + dest[i].substitute_bindings = src[drec].substitute_bindings; dest[i].testing_constantness = 0; dest[i].env_already = 0; dest[i].comp_flags = src[drec].comp_flags; @@ -176,6 +151,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, lam[dlrec].comp = 1; lam[dlrec].dont_mark_local_use = src[drec].dont_mark_local_use; lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids; + lam[dlrec].substitute_bindings = src[dlrec].substitute_bindings; lam[dlrec].value_name = scheme_false; lam[dlrec].observer = src[drec].observer; lam[dlrec].pre_unwrapped = 0; @@ -265,7 +241,6 @@ void scheme_init_expand_observe(Scheme_Env *env) static void init_compile_data(Scheme_Comp_Env *env) { - Compile_Data *data; int i, c, *use; c = env->num_bindings; @@ -274,45 +249,45 @@ static void init_compile_data(Scheme_Comp_Env *env) else use = NULL; - data = COMPILE_DATA(env); - - data->use = use; + env->use = use; for (i = 0; i < c; i++) { use[i] = 0; } - data->min_use = c; + env->min_use = c; } -Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, Scheme_Comp_Env *base) +Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, Scheme_Object *scopes, Scheme_Comp_Env *base) { Scheme_Comp_Env *frame; int count; count = num_bindings; - frame = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Full_Comp_Env); + frame = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Comp_Env); #ifdef MZTAG_REQUIRED frame->type = scheme_rt_comp_env; #endif + frame->scopes = scopes; + { Scheme_Object **vals; vals = MALLOC_N(Scheme_Object *, count); - frame->values = vals; + frame->binders = vals; + vals = MALLOC_N(Scheme_Object *, count); + frame->bindings = vals; } frame->num_bindings = num_bindings; - frame->flags = flags | (base->flags & SCHEME_NO_RENAME); + frame->flags = flags; frame->next = base; frame->genv = base->genv; frame->insp = base->insp; frame->prefix = base->prefix; frame->in_modidx = base->in_modidx; - if (flags & SCHEME_NON_SIMPLE_FRAME) - frame->skip_depth = 0; - else if (base->next) + if (base->next) frame->skip_depth = base->skip_depth + 1; else frame->skip_depth = 0; @@ -322,7 +297,7 @@ Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, Schem return frame; } -Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int flags) +Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags) { Scheme_Comp_Env *e; Comp_Prefix *cp; @@ -330,7 +305,7 @@ Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int if (!insp) insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - e = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Full_Comp_Env); + e = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Comp_Env); #ifdef MZTAG_REQUIRED e->type = scheme_rt_comp_env; #endif @@ -348,14 +323,23 @@ Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int e->prefix = cp; + e->scopes = scopes; + return e; } -Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, int flags) +Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags) { Scheme_Comp_Env *e; - e = scheme_new_comp_env(genv, insp, flags); + if (SAME_OBJ(scopes, scheme_true)) { + if (genv->stx_context) + scopes = scheme_module_context_frame_scopes(genv->stx_context, NULL); + else + scopes = NULL; + } + + e = scheme_new_comp_env(genv, insp, scopes, flags); e->prefix = NULL; return e; @@ -374,26 +358,42 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env) int scheme_used_ever(Scheme_Comp_Env *env, int which) { - Compile_Data *data = COMPILE_DATA(env); - - return !!data->use[which]; + return !!env->use[which]; } int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which) { - Compile_Data *data = COMPILE_DATA(env); - - return !!(data->use[which] & WAS_SET_BANGED); + return !!(env->use[which] & WAS_SET_BANGED); } void scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *frame) { + Scheme_Object *binding; + if ((index >= frame->num_bindings) || (index < 0)) scheme_signal_error("internal error: scheme_add_binding: " "index out of range: %d", index); + + if (frame->scopes) { + /* sometimes redundant: */ + val = scheme_stx_adjust_frame_bind_scopes(val, frame->scopes, scheme_env_phase(frame->genv), + SCHEME_STX_ADD); + } - frame->values[index] = val; + frame->binders[index] = val; + + if (!frame->bindings[index]) { + if (frame->flags & SCHEME_INTDEF_SHADOW) { + binding = scheme_stx_lookup(val, scheme_env_phase(frame->genv)); + } else { + binding = scheme_gensym(SCHEME_STX_VAL(val)); + scheme_add_local_binding(val, scheme_env_phase(frame->genv), binding); + } + + frame->bindings[index] = binding; + } + frame->skip_table = NULL; } @@ -417,14 +417,14 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */ SCHEME_VEC_ELS(vec)[7] = provides; - COMPILE_DATA(env)->lifts = vec; + env->lifts = vec; } void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env) { while (orig_env) { - if ((COMPILE_DATA(orig_env)->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(orig_env)->lifts)[5])) + if ((orig_env->lifts) + && SCHEME_TRUEP(SCHEME_VEC_ELS(orig_env->lifts)[5])) break; orig_env = orig_env->next; } @@ -444,56 +444,75 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com SCHEME_VEC_ELS(vec)[6] = scheme_null; SCHEME_VEC_ELS(vec)[7] = scheme_false; - COMPILE_DATA(env)->lifts = vec; + env->lifts = vec; } } Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env) { - return scheme_reverse(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]); + return scheme_reverse(SCHEME_VEC_ELS(env->lifts)[0]); } Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env) { - return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]; + return SCHEME_VEC_ELS(env->lifts)[3]; } Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env) { - return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]; + return SCHEME_VEC_ELS(env->lifts)[6]; } Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env) { - return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7]; + return SCHEME_VEC_ELS(env->lifts)[7]; } void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env) { - Scheme_Object **ns, **vs; + Scheme_Object **ns, **bs, **vs; if (cnt) { ns = MALLOC_N(Scheme_Object *, cnt); + bs = MALLOC_N(Scheme_Object *, cnt); vs = MALLOC_N(Scheme_Object *, cnt); - COMPILE_DATA(env)->num_const = cnt; - COMPILE_DATA(env)->const_names = ns; - COMPILE_DATA(env)->const_vals = vs; - + env->num_bindings = cnt; + env->binders = ns; + env->bindings = bs; + env->vals = vs; } } void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val, - Scheme_Comp_Env *env) + Scheme_Comp_Env *env, + int replace_value) { - COMPILE_DATA(env)->const_names[pos] = name; - COMPILE_DATA(env)->const_vals[pos] = val; + Scheme_Object *binding; + + if (!replace_value) { + if (env->flags & SCHEME_CAPTURE_WITHOUT_RENAME) { + binding = scheme_stx_lookup(name, scheme_env_phase(env->genv)); + } else { + if (env->scopes) + name = scheme_stx_adjust_frame_bind_scopes(name, env->scopes, scheme_env_phase(env->genv), + SCHEME_STX_ADD); + + binding = scheme_gensym(SCHEME_STX_VAL(name)); + + scheme_add_local_binding(name, scheme_env_phase(env->genv), binding); + } + + env->binders[pos] = name; + env->bindings[pos] = binding; + } + env->vals[pos] = val; env->skip_table = NULL; } Scheme_Comp_Env * -scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Comp_Env *env, int flags) +scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Object *scope, Scheme_Comp_Env *env, int flags) { Scheme_Comp_Env *frame; int len, i, count; @@ -501,15 +520,15 @@ scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Comp_Env *env, int flag len = scheme_stx_list_length(vals); count = len; - frame = scheme_new_compilation_frame(count, flags, env); + frame = scheme_new_compilation_frame(count, flags, scope, env); for (i = 0; i < len ; i++) { - if (SCHEME_STX_SYMBOLP(vals)) - frame->values[i] = vals; - else { + if (SCHEME_STX_SYMBOLP(vals)) { + scheme_add_compilation_binding(i, vals, frame); + } else { Scheme_Object *a; a = SCHEME_STX_CAR(vals); - frame->values[i] = a; + scheme_add_compilation_binding(i, a, frame); vals = SCHEME_STX_CDR(vals); } } @@ -519,27 +538,45 @@ scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Comp_Env *env, int flag return frame; } +void scheme_add_compilation_frame_use_site_scope(Scheme_Comp_Env *env, Scheme_Object *use_site_scope) +{ + while (env->flags & SCHEME_USE_SCOPES_TO_NEXT) { + env = env->next; + } + + if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { + scheme_module_context_add_use_site_scope(env->genv->stx_context, use_site_scope); + } else { + use_site_scope = scheme_add_frame_use_site_scope(env->scopes, use_site_scope); + env->scopes = use_site_scope; + } +} + +void scheme_add_compilation_frame_intdef_scope(Scheme_Comp_Env *env, Scheme_Object *scope) +{ + while (env->flags & SCHEME_USE_SCOPES_TO_NEXT) { + env = env->next; + } + + if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { + /* we keep intdef scopes, even in this case, for use by get-shadower */ + } + + scope = scheme_add_frame_intdef_scope(env->scopes, scope); + env->scopes = scope; +} + Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env) { if (scheme_is_toplevel(env) || scheme_is_module_env(env) || scheme_is_module_begin_env(env) || (env->flags & SCHEME_INTDEF_FRAME)) - return scheme_new_compilation_frame(0, 0, env); + return scheme_new_compilation_frame(0, 0, NULL, env); else return env; } -Scheme_Comp_Env *scheme_require_renames(Scheme_Comp_Env *env) -{ - if (env->flags & SCHEME_NO_RENAME) { - env = scheme_new_compilation_frame(0, 0, env); - env->flags -= SCHEME_NO_RENAME; - } - - return env; -} - int scheme_is_toplevel(Scheme_Comp_Env *env) { return !env->next || (env->flags & SCHEME_TOPLEVEL_FRAME); @@ -552,12 +589,12 @@ int scheme_is_nested_module(Scheme_Comp_Env *env) int scheme_is_module_env(Scheme_Comp_Env *env) { - return !!(env->flags & SCHEME_MODULE_BEGIN_FRAME); /* name is backwards compared to symbol! */ + return !!(env->flags & SCHEME_MODULE_FRAME); } int scheme_is_module_begin_env(Scheme_Comp_Env *env) { - return !!(env->flags & SCHEME_MODULE_FRAME); /* name is backwards compared to symbol! */ + return !!(env->flags & SCHEME_MODULE_BEGIN_FRAME); } Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env) @@ -565,7 +602,7 @@ Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env) if (scheme_is_toplevel(env)) return env; else - return scheme_new_compilation_frame(0, SCHEME_TOPLEVEL_FRAME, env); + return scheme_new_compilation_frame(0, SCHEME_TOPLEVEL_FRAME, NULL, env); } Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, int flags) @@ -873,7 +910,7 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame, { int cnt, u; - u = COMPILE_DATA(frame)->use[i]; + u = frame->use[i]; // flags -= (flags & SCHEME_APP_POS); @@ -890,10 +927,10 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame, u -= (u & SCHEME_USE_COUNT_MASK); u |= (cnt << SCHEME_USE_COUNT_SHIFT); - COMPILE_DATA(frame)->use[i] = u; - if (i < COMPILE_DATA(frame)->min_use) - COMPILE_DATA(frame)->min_use = i; - COMPILE_DATA(frame)->any_use = 1; + frame->use[i] = u; + if (i < frame->min_use) + frame->min_use = i; + frame->any_use = 1; return (Scheme_Local *)scheme_make_local(scheme_local_type, p + i, 0); } @@ -973,670 +1010,75 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid return val; } -Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, - int mode, /* -1, 0 => lookup; 2, 3 => define - -1 and 3 => use temp table - 1 would mean define if no match; not currently used */ - Scheme_Object *phase, int *_skipped) -/* The `env' argument can actually be a hash table. */ -{ - Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg; - int best_match_skipped, ms; - Scheme_Hash_Table *marked_names, *temp_marked_names, *dest_marked_names; - - sym = SCHEME_STX_SYM(id); - - if (_skipped) - *_skipped = -1; - - if (SCHEME_HASHTP((Scheme_Object *)env)) { - marked_names = (Scheme_Hash_Table *)env; - temp_marked_names = NULL; - } else { - /* If there's no table and we're not defining, bail out fast */ - if ((mode <= 0) && !env->rename_set) - return sym; - marked_names = scheme_get_module_rename_marked_names(env->rename_set, - phase ? phase : scheme_make_integer(env->phase), - 0); - temp_marked_names = env->temp_marked_names; - } - - if (mode > 0) { - /* If we're defining, see if we need to create a table. Getting - marks is relatively expensive, but we only do this once per - definition. */ - if (!bdg) - bdg = scheme_stx_moduleless_env(id); - marks = scheme_stx_extract_marks(id); - if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg)) - return sym; - } - - if (!marked_names) { - scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); - marked_names = scheme_get_module_rename_marked_names(env->rename_set, - phase ? phase : scheme_make_integer(env->phase), - 1); - } - if (!temp_marked_names && (mode > 2)) { - /* The "temp" marked name table is used to correlate marked module - requires with similarly marked provides. We don't go through - the normal rename table because (for efficiency) the marks in - this case are handled more directly in the shared_pes module - renamings. */ - temp_marked_names = scheme_make_hash_table(SCHEME_hash_ptr); - env->temp_marked_names = temp_marked_names; - } - - map = scheme_hash_get(marked_names, sym); - if (!map && ((mode < 0) || (mode > 2)) && temp_marked_names) - map = scheme_hash_get(temp_marked_names, sym); - - if (!map) { - /* If we're not defining, we can bail out before extracting marks. */ - if (mode <= 0) - return sym; - else - map = scheme_null; - } - - if (!bdg) { - /* We need lexical binding, if any, too: */ - bdg = scheme_stx_moduleless_env(id); - } - - if (!marks) { - /* We really do need the marks. Get them. */ - marks = scheme_stx_extract_marks(id); - if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg)) - return sym; - } - - best_match = NULL; - best_match_skipped = scheme_list_length(marks); - if (best_match_skipped == 1) { - /* A mark list of length 1 is the common case. - Since the list is otherwise marshaled into .zo, etc., - simplify by extracting just the mark: */ - marks = SCHEME_CAR(marks); - } - - if (SCHEME_FALSEP(bdg)) - bdg = NULL; - - /* Find a mapping that matches the longest tail of marks - in the first matching tail of bdg */ - while (1) { - for (l = map; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - amarks = SCHEME_CAR(a); - - if (SCHEME_VECTORP(amarks)) { - abdg = SCHEME_VEC_ELS(amarks)[1]; - amarks = SCHEME_VEC_ELS(amarks)[0]; - } else - abdg = NULL; - - if (SAME_OBJ(abdg, bdg) - || (bdg && abdg && scheme_equal(abdg, bdg))) { - if (mode > 0) { - if (scheme_equal(amarks, marks)) { - best_match = SCHEME_CDR(a); - break; - } - } else { - if (SCHEME_NULLP(amarks)) { - /* can always match empty marks */ - best_match = SCHEME_CDR(a); - best_match_skipped = scheme_proper_list_length(marks); - } else if (!SCHEME_PAIRP(marks)) { - /* To be better than nothing, could only match exactly: */ - if (scheme_equal(amarks, marks)) { - best_match = SCHEME_CDR(a); - best_match_skipped = 0; - } - } else { - /* amarks can match a tail of marks: */ - for (m = marks, ms = 0; - SCHEME_PAIRP(m) && (ms < best_match_skipped); - m = SCHEME_CDR(m), ms++) { - - cm = m; - if (!SCHEME_PAIRP(amarks)) { - /* If we're down to the last element - of marks, then extract it to try to - match the symbol amarks. */ - if (SCHEME_NULLP(SCHEME_CDR(m))) - cm = SCHEME_CAR(m); - } - - if (scheme_equal(amarks, cm)) { - best_match = SCHEME_CDR(a); - best_match_skipped = ms; - break; - } - } - } - } - } - } - - if (!best_match && (mode <= 1) && bdg && (SCHEME_PAIRP(bdg) || SCHEME_INTP(bdg) || SCHEME_BIGNUMP(bdg))) { - /* try lookup with less bdg context */ - if (SCHEME_PAIRP(bdg)) { - bdg = SCHEME_CDR(bdg); - if (SCHEME_PAIRP(bdg) && SCHEME_NULLP(SCHEME_CDR(bdg))) - bdg = SCHEME_CAR(bdg); - } else - bdg = NULL; - } else - break; - } - - if (!best_match) { - if (mode <= 0) { - return sym; - } - - /* Last chance before making up a new name. If we're processing a - module body generated by `expand', then we picked a name last - time around. We can't pick a new name now, otherwise - "redundant" module renamings wouldn't be redundant (see - simpify in "syntax.c") and submodules won't re-expand correctly. - So, check for a context-determined existing rename. */ - if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode <= 2)) { - Scheme_Object *mod, *nm = id, *nom_modix = scheme_false; - int skipped; - mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), &nom_modix, NULL, NULL, - NULL, NULL, NULL, NULL, NULL, &skipped); - if (mod - && !SAME_OBJ(mod, scheme_undefined) - /* refers to env->module if nom_modix has #f path */ - && (!SAME_TYPE(SCHEME_TYPE(nom_modix), scheme_module_index_type) - || SCHEME_FALSEP(((Scheme_Modidx *)nom_modix)->path)) - && ((skipped == 0) || (mode < 2)) - && NOT_SAME_OBJ(nm, sym)) - /* It has a rename already! */ - best_match = nm; - } - - /* Adding a definition. We "gensym" here in a sense; actually, we - use a symbol table that's in parallel to the normal table, so - that we get the same parallel-symbol when unmarshalling - code. We use a counter attached to the environment. Normally, - this counter just increments, but if a module is re-expanded, - then the counter starts at 0 for the re-expand, and we may - re-pick an existing name. To avoid re-picking the same name, - double-check for a mapping in the environment by inspecting the - renames attached to id. In the top-level environment, it's - still possible to get a collision, because separately compiled - code might be loaded into the same environment (which is just - too bad). */ - if (!best_match) { - char onstack[50], *buf; - intptr_t len; - - while (1) { - env->id_counter++; - len = SCHEME_SYM_LEN(sym); - if (len <= 35) - buf = onstack; - else - buf = scheme_malloc_atomic(len + 15); - memcpy(buf, SCHEME_SYM_VAL(sym), len); - - /* The dot here is significant; it might gets stripped away when - printing the symbol */ - sprintf(buf XFORM_OK_PLUS len, ".%d", env->id_counter); - - best_match = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); - - if (!scheme_stx_parallel_is_used(best_match, id)) { - /* Also check environment's rename tables. This last check - includes the temp table. It also turns out to matter for - compiling in `module->namespace' contexts, because no - renaming is added after expansion to record the rename - table. */ - if (!scheme_tl_id_is_sym_used(marked_names, best_match) - && (!temp_marked_names - || !scheme_tl_id_is_sym_used(temp_marked_names, best_match))) { - /* Ok, no matches, so this name is fine. */ - break; - } - } - /* Otherwise, increment counter and try again... */ - } - } - if (bdg) { - a = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(a)[0] = marks; - SCHEME_VEC_ELS(a)[1] = bdg; - marks = a; - } - a = scheme_make_pair(marks, best_match); - map = scheme_make_pair(a, map); - - dest_marked_names = ((mode < 0) || (mode > 2)) ? temp_marked_names : marked_names; - scheme_hash_set(dest_marked_names, sym, map); - { - Scheme_Hash_Table *rev_ht; - rev_ht = (Scheme_Hash_Table *)scheme_hash_get(dest_marked_names, scheme_false); - if (rev_ht) { - scheme_hash_set(rev_ht, best_match, scheme_true); - } - } - } else { - if (_skipped) - *_skipped = best_match_skipped; - } - - return best_match; -} - -int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym) -{ - intptr_t i; - Scheme_Object *l, *a; - Scheme_Hash_Table *rev_ht; - - if (!marked_names) - return 0; - - if (!marked_names->count) - return 0; - - rev_ht = (Scheme_Hash_Table *)scheme_hash_get(marked_names, scheme_false); - - if (!rev_ht) { - rev_ht = scheme_make_hash_table(SCHEME_hash_ptr); - - for (i = marked_names->size; i--; ) { - l = marked_names->vals[i]; - if (l) { - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - scheme_hash_set(rev_ht, SCHEME_CDR(a), scheme_true); - } - } - } - scheme_hash_set(marked_names, scheme_false, (Scheme_Object *)rev_ht); - } - - if (scheme_hash_get(rev_ht, sym)) - return 1; - - return 0; -} - -static Scheme_Object *make_uid(int in_rib) -{ - char name[20]; - - sprintf(name, "%cnv%d", in_rib ? 'r' : 'e', env_uid_counter++); - return scheme_make_symbol(name); /* uninterned! */ -} - -Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env) -{ - if (env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED)) - return NULL; - - if (!env->uid) { - Scheme_Object *sym; - sym = make_uid(env->flags & SCHEME_FOR_INTDEF); - env->uid = sym; - } - return env->uid; -} - -static void make_env_renames(Scheme_Comp_Env *env, int rcount, int rstart, int rstart_sec, int force_multi, - Scheme_Object *stx) -{ - Scheme_Object *rnm; - Scheme_Object *uid = NULL; - int i, pos; - - if (env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED)) - return; - - scheme_env_frame_uid(env); - - if (force_multi) { - if (env->num_bindings && !env->uids) { - Scheme_Object **uids; - uids = MALLOC_N(Scheme_Object *, env->num_bindings); - env->uids = uids; - } - if (COMPILE_DATA(env)->num_const && !COMPILE_DATA(env)->const_uids) { - Scheme_Object **cuids; - cuids = MALLOC_N(Scheme_Object *, COMPILE_DATA(env)->num_const); - COMPILE_DATA(env)->const_uids = cuids; - } - if (env->uid && !SCHEME_FALSEP(env->uid)) { - uid = env->uid; - env->uid = scheme_false; - } - } - - if (!uid) { - if (env->uid && SCHEME_TRUEP(env->uid)) { - /* single-uid mode (at least for now) */ - uid = env->uid; - } else { - /* multi-uid mode */ - if (!rstart_sec) - uid = COMPILE_DATA(env)->const_uids[rstart]; - else - uid = env->uids[rstart]; - if (!uid) - uid = make_uid(env->flags & SCHEME_FOR_INTDEF); - } - } - - rnm = scheme_make_rename(uid, rcount); - pos = 0; - - if (!rstart_sec) { - for (i = rstart; (i < COMPILE_DATA(env)->num_const) && (pos < rcount); i++, pos++) { - if (COMPILE_DATA(env)->const_uids) - COMPILE_DATA(env)->const_uids[i] = uid; - scheme_set_rename(rnm, pos, COMPILE_DATA(env)->const_names[i]); - } - rstart = 0; - } - for (i = rstart; pos < rcount; i++, pos++) { - if (env->uids) - env->uids[i] = uid; - scheme_set_rename(rnm, pos, env->values[i]); - } - - if (SCHEME_RIBP(stx)) - scheme_add_rib_rename(stx, rnm); - - if (env->renames) { - if (SCHEME_PAIRP(env->renames) || SCHEME_NULLP(env->renames)) - rnm = scheme_make_pair(rnm, env->renames); - else - rnm = scheme_make_pair(rnm, scheme_make_pair(env->renames, scheme_null)); - } - env->renames = rnm; -} - -Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env, - Scheme_Comp_Env *upto) -{ - if (!SCHEME_STXP(stx) && !SCHEME_RIBP(stx)) { - scheme_signal_error("internal error: not syntax or rib"); - return NULL; - } - - if (SCHEME_RIBP(stx)) { - GC_CAN_IGNORE int *s; - s = scheme_stx_get_rib_sealed(stx); - COMPILE_DATA(env)->sealed = s; - } - - while (env != upto) { - if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) { - int i, count; - - /* How many slots filled in the frame so far? This can change - due to the style of let* compilation, which generates a - rename record after each binding set. The "const" bindings - are always all in place before we generate any renames in - that case. However, the "const" bindings can grow by - themselves before non-const bindings are installed. */ - count = COMPILE_DATA(env)->num_const; - for (i = env->num_bindings; i--; ) { - if (env->values[i]) - count++; - } - - if (count) { - Scheme_Object *l; - - if (!env->renames || (env->rename_var_count != count)) { - /* Need to create lexical renaming record(s). We create - multiple records as necessary to avoid uids that contain - more than one variable with the same symbol name. - - This is complicated, because we don't want to allocate a - hash table in the common case of a binding set with a few - names. It's also complicated by incremental rename - building: if env->rename_var_count is not zero, we've - done this before for a subset of `values' (and there are - no consts in that case). In the incremental case, we have - a dup_check hash table left from the previous round. */ - Scheme_Hash_Table *ht; - Scheme_Object *name; - int rcount = 0, rstart, rstart_sec = 0, vstart; - - /* rstart is where the to-be-created rename table starts - (saved from last time around, or initially zero). - vstart is where we start looking for new dups. - rstart_sec is TRUE when the new frame starts in the - non-constant area. */ - rstart = env->rename_rstart; - if (env->renames) { - /* Incremental mode. Drop the most recent (first) rename - table, because we'll recreate it: */ - if (SCHEME_PAIRP(env->renames)) - env->renames = SCHEME_CDR(env->renames); - else - env->renames = NULL; - if (SCHEME_RIBP(stx)) - scheme_drop_first_rib_rename(stx); - vstart = env->rename_var_count; - rstart_sec = 1; - /* We already know that the first rcount - are distinct (from the last iteration) */ - rcount = vstart - rstart; - } else - vstart = 0; - - /* Create or find the hash table: */ - if (env->dup_check) - ht = env->dup_check; - else if (env->num_bindings + COMPILE_DATA(env)->num_const > 10) - ht = scheme_make_hash_table(SCHEME_hash_ptr); - else - ht = NULL; - - if (rcount > 16) { - /* Instead of n^2 growth for the rename, just close the current - one off and start fresh. */ - make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); - rcount = 0; - rstart = vstart; - rstart_sec = 1; - if (ht) { - /* Flush the table for a new set: */ - ht = scheme_make_hash_table(SCHEME_hash_ptr); - } - } - - /* Check for dups among the statics, and build a rename for - each dup-free set. */ - - /* First: constants. */ - if (!rstart_sec) { - if (COMPILE_DATA(env)->num_const) { - /* Start at the beginning, always. */ - for (i = 0; i < COMPILE_DATA(env)->num_const; i++) { - int found = 0; - name = SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[i]); - if (ht) { - if (scheme_hash_get(ht, name)) - found = 1; - else - scheme_hash_set(ht, name, scheme_true); - } else { - int j; - for (j = rstart; j < i; j++) { - if (SAME_OBJ(name, SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[j]))) { - found = 1; - break; - } - } - } - - if (found) { - make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); - rcount = 1; - rstart = i; - if (ht) { - /* Flush the table for a new set: */ - ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(ht, name, scheme_true); - } - } else - rcount++; - } - } else - rstart_sec = 1; - } - - for (i = vstart; (i < env->num_bindings) && env->values[i]; i++) { - int found = 0; - name = SCHEME_STX_VAL(env->values[i]); - - if (ht) { - if (scheme_hash_get(ht, name)) - found = 1; - else - scheme_hash_set(ht, name, scheme_true); - } else { - int j; - if (!rstart_sec) { - /* Look in consts, first: */ - for (j = rstart; j < COMPILE_DATA(env)->num_const; j++) { - if (SAME_OBJ(name, SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[j]))) { - found = 1; - break; - } - } - - j = 0; - } else - j = rstart; - - if (!found) { - for (; j < i; j++) { - if (SAME_OBJ(name, SCHEME_STX_VAL(env->values[j]))) { - found = 1; - break; - } - } - } - } - - if (found) { - make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); - rcount = 1; - rstart = i; - rstart_sec = 1; - if (ht) { - /* Flush the table for a new set: */ - ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(ht, name, scheme_true); - } - } else - rcount++; - } - - make_env_renames(env, rcount, rstart, rstart_sec, 0, stx); - - env->rename_var_count = count; - env->rename_rstart = rstart; - if (count < env->num_bindings) { - /* save for next time around: */ - env->dup_check = ht; - } else { - /* drop a saved table if there; we're done with all increments */ - env->dup_check = NULL; - } - } - - if (SCHEME_STXP(stx)) { - for (l = env->renames; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - stx = scheme_add_rename(stx, SCHEME_CAR(l)); - } - if (!SCHEME_NULLP(l)) - stx = scheme_add_rename(stx, l); - } - } - } else if (env->flags & SCHEME_INTDEF_SHADOW) { - /* Just extract existing uids from identifiers, and don't need to - add renames to syntax objects. */ - if (!env->uids) { - Scheme_Object **uids, *uid; - int i; - - uids = MALLOC_N(Scheme_Object *, env->num_bindings); - env->uids = uids; - - for (i = env->num_bindings; i--; ) { - uid = scheme_stx_moduleless_env(env->values[i]); - if (SCHEME_FALSEP(uid)) - scheme_signal_error("intdef shadow binding is #f for %d/%s", - SCHEME_TYPE(env->values[i]), - scheme_write_to_string(SCHEME_STX_VAL(env->values[i]), - NULL)); - env->uids[i] = uid; - } - } - } - - env = env->next; - } - - return stx; -} - -void scheme_seal_env_renames(Scheme_Comp_Env *env) -{ - env->dup_check = NULL; -} - /*********************************************************************/ +#define IS_SKIPPING_DEPTH(n) (n && !(n & 31)) + void create_skip_table(Scheme_Comp_Env *start_frame) { - Scheme_Comp_Env *end_frame, *frame; + Scheme_Comp_Env *end_frame, *frame, *other_frame; int depth, dj = 0, dp = 0, i; - Scheme_Hash_Table *table; - int stride = 0; + Scheme_Hash_Tree *table; + int stride = 0, past_binding_frame = 0, past_stops_frame = 0; - depth = start_frame->skip_depth; + i = start_frame->skip_depth; + depth = 0; + while (!(i & 1)) { + depth = (depth << 1) | 1; + i >>= 1; + } /* Find frames to be covered by the skip table. */ for (end_frame = start_frame->next; - end_frame && ((depth & end_frame->skip_depth) != end_frame->skip_depth); + end_frame && (depth & end_frame->skip_depth); end_frame = end_frame->next) { stride++; } - table = scheme_make_hash_table(SCHEME_hash_ptr); + table = NULL; for (frame = start_frame; frame != end_frame; frame = frame->next) { - if (frame->flags & SCHEME_LAMBDA_FRAME) - dj++; - dp += frame->num_bindings; - for (i = frame->num_bindings; i--; ) { - if (frame->values[i]) { - scheme_hash_set(table, SCHEME_STX_VAL(frame->values[i]), scheme_true); + if (frame->skip_table) { + other_frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); + if (other_frame == end_frame) { + end_frame = frame; + table = frame->skip_table; + dj = SCHEME_INT_VAL(scheme_eq_hash_tree_get(table, scheme_make_integer(1))); + dp = SCHEME_INT_VAL(scheme_eq_hash_tree_get(table, scheme_make_integer(2))); + past_binding_frame = SCHEME_TRUEP(scheme_eq_hash_tree_get(table, scheme_make_integer(3))); + past_stops_frame = SCHEME_TRUEP(scheme_eq_hash_tree_get(table, scheme_make_integer(4))); + break; } } - for (i = COMPILE_DATA(frame)->num_const; i--; ) { - scheme_hash_set(table, SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]), scheme_true); - } } - scheme_hash_set(table, scheme_make_integer(0), (Scheme_Object *)end_frame); - scheme_hash_set(table, scheme_make_integer(1), scheme_make_integer(dj)); - scheme_hash_set(table, scheme_make_integer(2), scheme_make_integer(dp)); + if (!table) { + table = scheme_make_hash_tree(0); + table = scheme_hash_tree_set(table, scheme_make_integer(0), (Scheme_Object *)end_frame); + } + + for (frame = start_frame; frame != end_frame; frame = frame->next) { + if (!(frame->flags & SCHEME_REC_BINDING_FRAME) + && frame->scopes) + past_binding_frame = 1; + if (frame->flags & SCHEME_FOR_STOPS) + past_stops_frame = 1; + if (frame->flags & SCHEME_LAMBDA_FRAME) + dj++; + if (!frame->vals) + dp += frame->num_bindings; + for (i = frame->num_bindings; i--; ) { + if (frame->bindings[i]) + table = scheme_hash_tree_set(table, frame->bindings[i], scheme_true); + if (frame->binders[i]) + table = scheme_hash_tree_set(table, SCHEME_STX_VAL(frame->binders[i]), scheme_true); + } + } + + table = scheme_hash_tree_set(table, scheme_make_integer(1), scheme_make_integer(dj)); + table = scheme_hash_tree_set(table, scheme_make_integer(2), scheme_make_integer(dp)); + table = scheme_hash_tree_set(table, scheme_make_integer(3), past_binding_frame ? scheme_true : scheme_false); + table = scheme_hash_tree_set(table, scheme_make_integer(4), past_stops_frame ? scheme_true : scheme_false); start_frame->skip_table = table; } @@ -1654,10 +1096,58 @@ static Scheme_Object *intern_struct_proc_shape(int shape) { return scheme_intern_symbol(buf); } +void scheme_dump_env(Scheme_Comp_Env *env) +{ + Scheme_Comp_Env *frame; + + printf("Environment:\n"); + + for (frame = env; frame->next != NULL; frame = frame->next) { + int i; + for (i = frame->num_bindings; i--; ) { + printf(" %s -> %s\n %s\n", + scheme_write_to_string(frame->binders[i], NULL), + scheme_write_to_string(frame->bindings[i], NULL), + scheme_write_to_string((Scheme_Object *)((Scheme_Stx *)frame->binders[i])->scopes, NULL)); + } + } +} + +static int same_binding(Scheme_Object *a, Scheme_Object *b) +{ + if (SCHEME_VECTORP(a) && SCHEME_VECTORP(b)) { + if (SAME_OBJ(SCHEME_VEC_ELS(a)[1], SCHEME_VEC_ELS(b)[1]) + && SAME_OBJ(SCHEME_VEC_ELS(a)[2], SCHEME_VEC_ELS(b)[2]) + && (SAME_OBJ(SCHEME_VEC_ELS(a)[0], SCHEME_VEC_ELS(b)[0]) + || (SCHEME_TRUEP(SCHEME_VEC_ELS(a)[0]) + && SCHEME_TRUEP(SCHEME_VEC_ELS(b)[0]) + && scheme_equal(scheme_module_resolve(SCHEME_VEC_ELS(a)[0], 0), + scheme_module_resolve(SCHEME_VEC_ELS(b)[0], 0))))) + return 1; + else + return 0; + } else + return scheme_equal(a, b); +} + +static void set_binder(Scheme_Object **_binder, Scheme_Object *ref, Scheme_Object *bind) +{ + if (SAME_OBJ(SCHEME_STX_VAL(ref), SCHEME_STX_VAL(bind))) + ref = scheme_datum_to_syntax(SCHEME_STX_VAL(ref), ref, bind, 0, 2); + else { + /* rename transformer => treat like an expansion */ + ref = scheme_stx_track(scheme_datum_to_syntax(SCHEME_STX_VAL(bind), ref, bind, 0, 2), + ref, + ref); + } + + *_binder = ref; +} + /*********************************************************************/ /* - scheme_lookup_binding() is the main resolver of lexical, module, + scheme_compile_lookup() is the main resolver of lexical, module, and top-level bindings. Depending on the value of `flags', it can return a value whose type tag is: @@ -1677,174 +1167,198 @@ static Scheme_Object *intern_struct_proc_shape(int shape) { */ Scheme_Object * -scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, +scheme_compile_lookup(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, Scheme_Object *in_modidx, Scheme_Env **_menv, int *_protected, - Scheme_Object **_lexical_binding_id, + Scheme_Object **_binder, int *_need_macro_scope, Scheme_Object **_inline_variant) { Scheme_Comp_Env *frame; - int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0, is_constant; + int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0, is_constant, ambiguous; Scheme_Bucket *b; - Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; - Scheme_Object *find_id_sym = NULL, *rename_insp = NULL, *mod_constant = NULL, *shape; + Scheme_Object *binding, *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; + Scheme_Object *rename_insp = NULL, *mod_constant = NULL, *shape; Scheme_Env *genv; - intptr_t phase; - /* Need to know the phase being compiled */ - phase = env->genv->phase; + if (_binder) *_binder = NULL; + if (_need_macro_scope) *_need_macro_scope = 1; - /* Walk through the compilation frames */ - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - Scheme_Object *uid; + binding = scheme_stx_lookup_w_nominal(find_id, scheme_env_phase(env->genv), + (flags & SCHEME_STOP_AT_FREE_EQ), + NULL, &ambiguous, NULL, + &rename_insp, + NULL, NULL, NULL, NULL); - while (1) { - if (frame->skip_table) { - if (!scheme_hash_get(frame->skip_table, SCHEME_STX_VAL(find_id))) { - /* Skip ahead. 0 maps to frame, 1 maps to j delta, and 2 maps to p delta */ - val = scheme_hash_get(frame->skip_table, scheme_make_integer(1)); - j += (int)SCHEME_INT_VAL(val); - val = scheme_hash_get(frame->skip_table, scheme_make_integer(2)); - p += (int)SCHEME_INT_VAL(val); - frame = (Scheme_Comp_Env *)scheme_hash_get(frame->skip_table, scheme_make_integer(0)); - } else - break; - } else if (frame->skip_depth && !(frame->skip_depth & 0x1F)) { - /* We're some multiple of 32 frames deep. Build a skip table and try again. */ - create_skip_table(frame); - } else - break; - } - - if (frame->flags & SCHEME_LAMBDA_FRAME) - j++; +#if 0 + // REMOVEME + if (!strcmp("define$", SCHEME_SYM_VAL(SCHEME_STX_VAL(find_id)))) { + printf("%p\n", find_id); + scheme_stx_debug_print(find_id, scheme_env_phase(env->genv), 1); + printf("%s\n", scheme_write_to_string(binding, NULL)); + } +#endif - if (!skip_stops || !(frame->flags & SCHEME_FOR_STOPS)) { - if (frame->flags & SCHEME_FOR_STOPS) - skip_stops = 1; - - uid = scheme_env_frame_uid(frame); - - if (!find_id_sym - && (frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) - find_id_sym = scheme_stx_get_module_eq_sym(find_id, scheme_make_integer(phase)); - - for (i = frame->num_bindings; i--; ) { - if (frame->values[i]) { - if (frame->uids) - uid = frame->uids[i]; - if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i])) - && (scheme_stx_env_bound_eq(find_id, frame->values[i], uid, scheme_make_integer(phase)) - || ((frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME) - && scheme_stx_module_eq2(find_id, frame->values[i], scheme_make_integer(phase), find_id_sym)) - || ((frame->flags & SCHEME_CAPTURE_LIFTED) - && scheme_stx_bound_eq(find_id, frame->values[i], scheme_make_integer(phase))))) { - /* Found a lambda-, let-, etc. bound variable: */ - check_taint(find_id); - /* Looks ok; return a lexical reference */ - if (_lexical_binding_id) { - if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) - val = scheme_stx_remove_extra_marks(find_id, frame->values[i], - ((frame->flags & SCHEME_CAPTURE_LIFTED) - ? NULL - : uid)); - else - val = find_id; - *_lexical_binding_id = val; - } - if (flags & SCHEME_DONT_MARK_USE) - return scheme_make_local(scheme_local_type, p+i, 0); - else - return (Scheme_Object *)get_frame_loc(frame, i, j, p, flags); - } - } - } - - for (i = COMPILE_DATA(frame)->num_const; i--; ) { - int issame; - if (frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME) - issame = scheme_stx_module_eq2(find_id, COMPILE_DATA(frame)->const_names[i], - scheme_make_integer(phase), find_id_sym); - else { - if (COMPILE_DATA(frame)->const_uids) uid = COMPILE_DATA(frame)->const_uids[i]; - issame = (SAME_OBJ(SCHEME_STX_VAL(find_id), - SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i])) - && scheme_stx_env_bound_eq(find_id, COMPILE_DATA(frame)->const_names[i], uid, - scheme_make_integer(phase))); - } - - if (issame) { - check_taint(find_id); - - if (_lexical_binding_id) { - if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) - val = scheme_stx_remove_extra_marks(find_id, COMPILE_DATA(frame)->const_names[i], - ((frame->flags & SCHEME_CAPTURE_LIFTED) - ? NULL - : uid)); - else - val = find_id; - *_lexical_binding_id = val; - } - - val = COMPILE_DATA(frame)->const_vals[i]; - - if (!val) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context"); - return NULL; - } - - if (SCHEME_FALSEP(val)) { - /* Corresponds to a run-time binding (but will be replaced later - through a renaming to a different binding) */ - if (flags & (SCHEME_OUT_OF_CONTEXT_LOCAL | SCHEME_SETTING)) - return scheme_make_local(scheme_local_type, 0, 0); - return NULL; - } - - if (!(flags & SCHEME_ENV_CONSTANTS_OK)) { - if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) - return val; - else - scheme_wrong_syntax(scheme_set_stx_string, NULL, find_id, - "local syntax identifier cannot be mutated"); - return NULL; - } - - return val; - } - } - } - - p += frame->num_bindings; + if (ambiguous) { + if (SAME_OBJ(scheme_env_phase(env->genv), scheme_make_integer(0))) + scheme_wrong_syntax(NULL, NULL, find_id, + "identifier's binding is ambiguous%s", + scheme_stx_describe_context(find_id, scheme_make_integer(0), 1)); + else + scheme_wrong_syntax(NULL, NULL, find_id, + "identifier's binding is ambiguous\n" + " at phase: %V", + scheme_env_phase(env->genv), + scheme_stx_describe_context(find_id, scheme_env_phase(env->genv), 1)); + return NULL; } - src_find_id = find_id; - modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, - NULL, NULL, NULL, NULL, &rename_insp, NULL); + /* If binding is a symbol, then it must be in the environment, or else + the identifier is out of context. + If binding is a vector, then it most likely refers to a module-level + binding, but we may have a "fluid" binding for in the environment + to implement stops. */ - /* If modidx and modidx is not #, then find_id is now a - symbol, otherwise it's still an identifier. */ + if (SCHEME_SYMBOLP(binding)) { + /* Walk through the compilation frames */ + for (frame = env; frame->next != NULL; frame = frame->next) { + int i; - /* Used out of context? */ - if (SAME_OBJ(modidx, scheme_undefined)) { - if (SCHEME_STXP(find_id)) { - /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */ - find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL); - if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id))) - modidx = NULL; /* yes, it is bound */ + while (1) { + if (frame->skip_table) { + if (!scheme_eq_hash_tree_get(frame->skip_table, binding)) { + /* Skip ahead. 0 maps to frame, 1 maps to j delta, 2 maps to p delta, + 3 maps to binding-frameness, and 4 maps to stops-or-not (unneeded here) */ + val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(1)); + j += (int)SCHEME_INT_VAL(val); + val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(2)); + p += (int)SCHEME_INT_VAL(val); + val = scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(3)); + if (SCHEME_TRUEP(val)) + if (_need_macro_scope) + *_need_macro_scope = 0; + frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); + } else + break; + } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { + create_skip_table(frame); + /* try again... */ + } else + break; + } + + if (!(env->flags & SCHEME_REC_BINDING_FRAME) && env->scopes) + if (_need_macro_scope) + *_need_macro_scope = 0; + + if (frame->flags & SCHEME_LAMBDA_FRAME) + j++; + + if (!skip_stops || !(frame->flags & SCHEME_FOR_STOPS)) { + if (frame->flags & SCHEME_FOR_STOPS) + skip_stops = 1; + + for (i = frame->num_bindings; i--; ) { + if (frame->bindings[i] && SAME_OBJ(binding, frame->bindings[i])) { + /* Found a lambda-, let-, etc. bound variable: */ + if (_binder) + set_binder(_binder, find_id, frame->binders[i]); + check_taint(find_id); + + if (!frame->vals) { + if (flags & SCHEME_DONT_MARK_USE) + return scheme_make_local(scheme_local_type, p+i, 0); + else + return (Scheme_Object *)get_frame_loc(frame, i, j, p, flags); + } else { + val = frame->vals[i]; + + if (!val) { + scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, + "identifier used out of context"); + return NULL; + } + + if (SCHEME_FALSEP(val)) { + /* Corresponds to a run-time binding (but will be replaced later + through a renaming to a different binding) */ + if (flags & (SCHEME_OUT_OF_CONTEXT_LOCAL | SCHEME_SETTING)) + return scheme_make_local(scheme_local_type, 0, 0); + return NULL; + } + + if (!(flags & SCHEME_ENV_CONSTANTS_OK)) { + if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) + return val; + else + scheme_wrong_syntax(scheme_set_stx_string, NULL, find_id, + "local syntax identifier cannot be mutated"); + return NULL; + } + + return val; + } + } + } + } + + if (!frame->vals) + p += frame->num_bindings; } - if (modidx) { - if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context"); + if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) { + scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, + "identifier used out of context%s", + scheme_stx_describe_context(find_id, scheme_env_phase(env->genv), 1)); + } + + if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) + return scheme_make_local(scheme_local_type, 0, 0); + + return NULL; + } else { + /* First, check for a "stop" */ + for (frame = env; frame->next != NULL; frame = frame->next) { + while (1) { + if (frame->skip_table) { + /* skip if we won't jump over stops: */ + if (SCHEME_FALSEP(scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(4)))) + frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); + else + break; + } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { + create_skip_table(frame); + /* try again */ + } else + break; } - if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) - return scheme_make_local(scheme_local_type, 0, 0); - return NULL; + + if (frame->flags & SCHEME_FOR_STOPS) { + int i; + for (i = frame->num_bindings; i--; ) { + if (same_binding(frame->bindings[i], binding) + && (SCHEME_TRUEP(binding) + || SAME_OBJ(SCHEME_STX_VAL(frame->binders[i]), + SCHEME_STX_VAL(find_id)))) { + check_taint(find_id); + + return frame->vals[i]; + } + } + /* ignore any further stop frames: */ + break; + } + } + + if (SCHEME_FALSEP(binding)) { + src_find_id = find_id; + modidx = NULL; + mod_defn_phase = NULL; + } else { + src_find_id = find_id; + modidx = SCHEME_VEC_ELS(binding)[0]; + if (SCHEME_FALSEP(modidx)) modidx = NULL; + find_id = SCHEME_VEC_ELS(binding)[1]; + mod_defn_phase = SCHEME_VEC_ELS(binding)[2]; } } @@ -1859,7 +1373,21 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, /* So we can distinguish between unbound identifiers in a module and references to top-level definitions: */ module_self_reference = 1; + + if (_need_macro_scope) { + for (frame = env; frame->next != NULL; frame = frame->next) { + if (!(frame->flags & (SCHEME_TOPLEVEL_FRAME + | SCHEME_MODULE_FRAME)) + && frame->scopes) { + *_need_macro_scope = 0; + break; + } + } + } } else { + if (_need_macro_scope) + *_need_macro_scope = 0; + genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase)); if (!genv) { @@ -1877,58 +1405,50 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, modname = NULL; if (genv->module && genv->disallow_unbound) { - /* double-check for a local-module binding that's not in find_id's context; - see a similar test in scheme_check_top_identifier_bound() */ - if (SCHEME_STXP(find_id)) - find_global_id = scheme_tl_id_sym(genv, find_id, NULL, 0, NULL, NULL); - else - find_global_id = NULL; - if (find_global_id && !SAME_OBJ(find_global_id, SCHEME_STX_SYM(find_id))) { - /* it's defined after all; fall through below assumes a binding - in the enclosing module */ - } else { - if (genv->disallow_unbound > 0) { - /* Free identifier. Maybe don't continue. */ - if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { - scheme_unbound_syntax(((flags & SCHEME_SETTING) - ? scheme_set_stx_string - : scheme_var_ref_string), - NULL, src_find_id, "unbound identifier in module"); - return NULL; - } - if (flags & SCHEME_NULL_FOR_UNBOUND) - return NULL; - } else { - if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { - scheme_register_unbound_toplevel(env, src_find_id); - } - /* continue, for now */ + if (genv->disallow_unbound > 0) { + /* Free identifier. Maybe don't continue. */ + if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { + scheme_unbound_syntax(((flags & SCHEME_SETTING) + ? scheme_set_stx_string + : scheme_var_ref_string), + NULL, src_find_id, "unbound identifier in module"); + return NULL; } + if (flags & SCHEME_NULL_FOR_UNBOUND) + return NULL; + } else { + if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { + scheme_register_unbound_toplevel(env, src_find_id); + } + /* continue, for now */ } } } if (_menv && genv->module) *_menv = genv; - - if (!modname && SCHEME_STXP(find_id)) - find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL); - else + + if (SCHEME_STXP(find_id)) { + if (flags & SCHEME_NULL_FOR_UNBOUND) + return NULL; + find_global_id = scheme_future_global_binding(find_id, env->genv); + } else find_global_id = find_id; /* Try syntax table: */ if (modname) { val = scheme_module_syntax(modname, env->genv, find_id, SCHEME_INT_VAL(mod_defn_phase)); if (val && !(flags & SCHEME_NO_CERT_CHECKS)) - scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, NULL, NULL, rename_insp, + scheme_check_accessible_in_module(genv, in_modidx, + find_id, src_find_id, + env->insp, rename_insp, -2, 0, NULL, NULL, env->genv, NULL, NULL); } else { /* Only try syntax table if there's not an explicit (later) variable mapping: */ - if (genv->shadowed_syntax + if (genv->shadowed_syntax && scheme_hash_get(genv->shadowed_syntax, find_global_id)) val = NULL; else @@ -1945,9 +1465,12 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, if (flags & SCHEME_NO_CERT_CHECKS) pos = 0; else - pos = scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, NULL, env->insp, rename_insp, -1, 1, - _protected, NULL, env->genv, NULL, &mod_constant); + pos = scheme_check_accessible_in_module(genv, in_modidx, + find_id, src_find_id, + env->insp, rename_insp, + -1, 1, + _protected, NULL, + env->genv, NULL, &mod_constant); modpos = (int)SCHEME_INT_VAL(pos); } else modpos = -1; @@ -1985,6 +1508,9 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, -1, genv->mod_phase, 0, NULL); } + } else if (SCHEME_VECTORP(binding) && !genv->module) { + /* The identifier is specifically bound as a top-level definition. */ + return (Scheme_Object *)scheme_global_bucket(find_global_id, genv); } else return NULL; } @@ -2060,6 +1586,251 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, return (Scheme_Object *)b; } +static Scheme_Comp_Env *find_first_relevant(Scheme_Object *stx, Scheme_Comp_Env *frame) +{ + int i; + + for (; frame->next != NULL; frame = frame->next) { + while (1) { + if (frame->skip_table) { + if (!scheme_eq_hash_tree_get(frame->skip_table, SCHEME_STX_VAL(stx))) { + frame = (Scheme_Comp_Env *)scheme_eq_hash_tree_get(frame->skip_table, scheme_make_integer(0)); + } else + break; + } else if (IS_SKIPPING_DEPTH(frame->skip_depth)) { + create_skip_table(frame); + /* try again... */ + } else + break; + } + + for (i = frame->num_bindings; i--; ) { + if (frame->binders[i] && SAME_OBJ(SCHEME_STX_VAL(stx), SCHEME_STX_VAL(frame->binders[i]))) + return frame; + } + } + + return frame; +} + +static Scheme_Object *add_all_context(Scheme_Object *id, Scheme_Comp_Env *env) +{ + Scheme_Comp_Env *env2; + + for (env2 = env; env2; env2 = env2->next) { + if (env2->scopes) { + id = scheme_stx_adjust_frame_scopes(id, env2->scopes, scheme_env_phase(env2->genv), + SCHEME_STX_ADD); + } + } + + if (env->genv->module && env->genv->module->ii_src) + id = scheme_stx_binding_union(id, env->genv->module->ii_src, scheme_env_phase(env->genv)); + else + id = scheme_stx_add_module_context(id, env->genv->stx_context); + id = scheme_stx_adjust_module_use_site_context(id, env->genv->stx_context, SCHEME_STX_ADD); + + return id; +} + +static Scheme_Object *find_local_binder(Scheme_Object *sym, Scheme_Comp_Env *env) +{ + Scheme_Comp_Env *frame; + Scheme_Object *id, **sds, *sd; + + for (frame = env; frame->next != NULL; frame = frame->next) { + int i; + + for (i = frame->num_bindings; i--; ) { + id = frame->binders[i]; + if (id && SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->binders[i]))) { + if (!frame->shadower_deltas) { + sds = MALLOC_N(Scheme_Object*,frame->num_bindings); + frame->shadower_deltas = sds; + } + sd = frame->shadower_deltas[i]; + if (!sd) { + sd = add_all_context(scheme_datum_to_syntax(SCHEME_STX_VAL(id), scheme_false, scheme_false, 0, 0), + frame); + sd = scheme_stx_binding_subtract(id, sd, scheme_env_phase(env->genv)); + frame->shadower_deltas[i] = sd; + } + if (scheme_stx_could_bind(sd, sym, scheme_env_phase(env->genv))) + return id; + } + } + } + + return NULL; +} + +Scheme_Object *scheme_get_shadower(Scheme_Object *sym, Scheme_Comp_Env *env, int only_generated) +{ + Scheme_Comp_Env *start_env; + Scheme_Object *binder, *orig_sym; + + orig_sym = sym; + + start_env = find_first_relevant(sym, env); + if (start_env->next) + binder = find_local_binder(sym, start_env); + else + binder = NULL; + + if (binder) + sym = scheme_stx_binding_union(binder, sym, scheme_env_phase(env->genv)); + else if (only_generated) + sym = scheme_stx_introduce_to_module_context(sym, env->genv->stx_context); + else if (env->genv->module && env->genv->module->ii_src) + sym = scheme_stx_binding_union(sym, env->genv->module->ii_src, scheme_env_phase(env->genv)); + else if (env->genv->stx_context) + sym = scheme_stx_add_module_context(sym, env->genv->stx_context); + + if (!scheme_stx_is_clean(orig_sym)) + sym = scheme_stx_taint(sym); + + return sym; +} + +static Scheme_Hash_Table *get_binding_names_table(Scheme_Env *env) +{ + Scheme_Hash_Table *binding_names; + + scheme_binding_names_from_module(env); + + if (env->binding_names + && SCHEME_HASHTRP(env->binding_names)) { + /* convert to a mutable hash table */ + binding_names = (Scheme_Hash_Table *)scheme_hash_tree_copy(env->binding_names); + env->binding_names = (Scheme_Object *)binding_names; + if (env->binding_names_need_shift) { + int i; + for (i = binding_names->size; i--; ) { + if (binding_names->vals[i]) { + Scheme_Object *id; + id = binding_names->vals[i]; + if (!SAME_OBJ(id, scheme_true)) + 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); + binding_names->vals[i] = id; + } + } + } + } + + binding_names = (Scheme_Hash_Table *)env->binding_names; + if (!binding_names) { + binding_names = scheme_make_hash_table(SCHEME_hash_ptr); + env->binding_names = (Scheme_Object *)binding_names; + env->binding_names_need_shift = 0; + } + + return binding_names; +} + +static int binding_name_available(Scheme_Hash_Table *binding_names, Scheme_Object *sym, + Scheme_Object *id, Scheme_Object *phase) +{ + sym = scheme_eq_hash_get(binding_names, sym); + if (!sym || (SCHEME_STXP(sym) && scheme_stx_bound_eq(sym, id, phase))) + return 1; + return 0; +} + +static Scheme_Object *select_binding_name(Scheme_Object *sym, Scheme_Env *env, Scheme_Object *id) +{ + int i; + char onstack[50], *buf; + intptr_t len; + Scheme_Hash_Table *binding_names; + + binding_names = get_binding_names_table(env); + + /* Use a plain symbol only if the binding has no extra scopes: */ + if (SCHEME_SYM_WEIRDP(sym) + || scheme_stx_equal_module_context(id, ((env->module && env->module->ii_src) + ? env->module->ii_src + : env->stx_context))) { + if (binding_name_available(binding_names, sym, id, scheme_env_phase(env))) { + scheme_hash_set(binding_names, sym, id); + return sym; + } + } + + len = SCHEME_SYM_LEN(sym); + if (len <= 35) + buf = onstack; + else + buf = scheme_malloc_atomic(len + 15); + memcpy(buf, SCHEME_SYM_VAL(sym), len); + + i = 0; + while (1) { + sprintf(buf XFORM_OK_PLUS len, ".%d", i); + sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + + if (binding_name_available(binding_names, sym, id, scheme_env_phase(env))) { + scheme_hash_set(binding_names, sym, id); + return sym; + } + + i++; + } +} + +Scheme_Object *scheme_global_binding(Scheme_Object *id, Scheme_Env *env) +{ + Scheme_Object *sym, *binding, *phase; + int exact_match; + + phase = scheme_env_phase(env); + + binding = scheme_stx_lookup_stop_at_free_eq(id, phase, &exact_match); + + if (!SCHEME_FALSEP(binding)) { + if (exact_match) { + if (SCHEME_VECTORP(binding) + && SAME_OBJ(SCHEME_VEC_ELS(binding)[0], + (env->module + ? env->module->self_modidx + : scheme_false)) + && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], phase)) { + sym = SCHEME_VEC_ELS(binding)[1]; + /* Make sure name is in binding_names and with a specific `id`: */ + scheme_hash_set(get_binding_names_table(env), sym, id); + return sym; + } + /* Since the binding didn't match, we'll "shadow" the binding + by replacing it below. */ + } + } + + sym = select_binding_name(SCHEME_STX_VAL(id), env, id); + + scheme_add_module_binding(id, phase, + (env->module ? env->module->self_modidx : scheme_false), + (env->module + ? (env->module->prefix + ? env->module->prefix->src_insp_desc + : env->module->insp) + : env->guard_insp), + sym, + phase); + + return sym; +} + +Scheme_Object *scheme_future_global_binding(Scheme_Object *id, Scheme_Env *env) +/* The identifier id is being referenced before it has a binding. We + want to allow it, anyway, perhaps because it's outside of a module + context or because it's phase-1 code. So, we assume that it's going to + have no extra scopes and get the base name. */ +{ + return SCHEME_STX_VAL(id); +} + int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env) { if (env->genv->module) { @@ -2134,15 +1905,25 @@ int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame) { int any_use; - any_use = COMPILE_DATA(frame)->any_use; - COMPILE_DATA(frame)->any_use = 0; + any_use = frame->any_use; + frame->any_use = 0; return any_use; } int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos) { - return COMPILE_DATA(frame)->min_use < pos; + return frame->min_use < pos; +} + +void scheme_mark_all_use(Scheme_Comp_Env *frame) +{ + /* Mark all variables as used for the purposes of `letrec-syntaxes+values` + splitting */ + while (frame && (frame->min_use > -1)) { + frame->min_use = -1; + frame = frame->next; + } } int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count) @@ -2150,7 +1931,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count) int *v, i; v = MALLOC_N_ATOMIC(int, count); - memcpy(v, COMPILE_DATA(frame)->use + start, sizeof(int) * count); + memcpy(v, frame->use + start, sizeof(int) * count); for (i = count; i--; ) { int old; @@ -2182,7 +1963,7 @@ Scheme_Object * scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object *argv[]) { Scheme_Comp_Env *env, *orig_env; - Scheme_Object *id, *ids, *rev_ids, *local_mark, *expr, *data, *vec, *id_sym; + Scheme_Object *id, *ids, *rev_ids, *local_scope, *expr, *data, *vec, *id_sym; Scheme_Lift_Capture_Proc cp; Scheme_Object *orig_expr; int count; @@ -2208,19 +1989,19 @@ scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object scheme_wrong_contract(who, "syntax?", stx_pos, argc, argv); env = orig_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) scheme_contract_error(who, "not currently transforming", NULL); - while (env && !COMPILE_DATA(env)->lifts) { + while (env && !env->lifts) { env = env->next; } if (env) - if (SCHEME_FALSEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0])) + if (SCHEME_FALSEP(SCHEME_VEC_ELS(env->lifts)[0])) env = NULL; if (!env) @@ -2228,11 +2009,11 @@ scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object "no lift target", NULL); - if (local_mark) - expr = scheme_add_remove_mark(expr, local_mark); + if (local_scope) + expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv)); - /* We don't really need a new symbol each time, since the mark - will generate new bindings. But lots of things work better or faster + /* We don't really need a new symbol each time, since the scope + will generate new bindings, but things may work better or faster when different bindings have different symbols. Use env->genv->id_counter to help keep name generation deterministic within a module. */ rev_ids = scheme_null; @@ -2241,13 +2022,16 @@ scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0); - id = scheme_add_remove_mark(id, scheme_new_mark()); + id = scheme_stx_add_scope(id, scheme_new_scope(SCHEME_STX_MACRO_SCOPE), scheme_env_phase(env->genv)); + + if (env->genv->stx_context) + id = scheme_stx_introduce_to_module_context(id, env->genv->stx_context); rev_ids = scheme_make_pair(id, rev_ids); } ids = scheme_reverse(rev_ids); - vec = COMPILE_DATA(env)->lifts; + vec = env->lifts; cp = *(Scheme_Lift_Capture_Proc *)SCHEME_VEC_ELS(vec)[1]; data = SCHEME_VEC_ELS(vec)[2]; @@ -2263,8 +2047,8 @@ scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object rev_ids = scheme_null; for (; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { id = SCHEME_CAR(ids); - if (local_mark) - id = scheme_add_remove_mark(id, local_mark); + if (local_scope) + id = scheme_stx_flip_scope(id, local_scope, scheme_env_phase(env->genv)); rev_ids = scheme_make_pair(id, rev_ids); } ids = scheme_reverse(rev_ids); @@ -2275,21 +2059,21 @@ scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object Scheme_Object * scheme_local_lift_context(Scheme_Comp_Env *env) { - while (env && !COMPILE_DATA(env)->lifts) { + while (env && !env->lifts) { env = env->next; } if (!env) return scheme_false; - return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[4]; + return SCHEME_VEC_ELS(env->lifts)[4]; } Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env) { while (env) { - if ((COMPILE_DATA(env)->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3])) + if ((env->lifts) + && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[3])) break; env = env->next; } @@ -2298,7 +2082,7 @@ Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env) } Scheme_Object * -scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, Scheme_Comp_Env *env) +scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env) { Scheme_Object *pr; Scheme_Object *orig_expr; @@ -2311,12 +2095,12 @@ scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, " an expression within a module declaration", NULL); - if (local_mark) - expr = scheme_add_remove_mark(expr, local_mark); + if (local_scope) + expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv)); orig_expr = expr; - pr = scheme_make_pair(expr, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]); - SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3] = pr; + pr = scheme_make_pair(expr, SCHEME_VEC_ELS(env->lifts)[3]); + SCHEME_VEC_ELS(env->lifts)[3] = pr; SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr); @@ -2324,18 +2108,20 @@ scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, } Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form, - intptr_t phase, Scheme_Object *local_mark, Scheme_Comp_Env *env) + intptr_t phase, Scheme_Object *local_scope, Scheme_Comp_Env *cenv) { - Scheme_Object *mark, *data, *pr; + Scheme_Object *scope, *data, *pr; Scheme_Object *req_form; int need_prepare = 0; + Scheme_Comp_Env *env; data = NULL; + env = cenv; while (env) { - if (COMPILE_DATA(env)->lifts - && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5])) { - data = SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5]; + if (env->lifts + && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[5])) { + data = SCHEME_VEC_ELS(env->lifts)[5]; if (SCHEME_RPAIRP(data) && !SCHEME_CAR(data)) { env = (Scheme_Comp_Env *)SCHEME_CDR(data); @@ -2351,26 +2137,22 @@ Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *ori NULL); - mark = scheme_new_mark(); + scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); if (SCHEME_RPAIRP(data)) - form = scheme_parse_lifted_require(form, phase, mark, SCHEME_CAR(data), &orig_form); + form = scheme_parse_lifted_require(form, phase, scope, SCHEME_CAR(data), &orig_form, cenv); else { - form = scheme_toplevel_require_for_expand(form, phase, env, mark); + form = scheme_toplevel_require_for_expand(form, phase, cenv, scope); need_prepare = 1; } - pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]); - SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6] = pr; + pr = scheme_make_pair(form, SCHEME_VEC_ELS(env->lifts)[6]); + SCHEME_VEC_ELS(env->lifts)[6] = pr; req_form = form; form = orig_form; - if (local_mark) - form = scheme_add_remove_mark(form, local_mark); - form = scheme_add_remove_mark(form, mark); - if (local_mark) - form = scheme_add_remove_mark(form, local_mark); + form = scheme_stx_flip_scope(form, scope, scheme_env_phase(env->genv)); SCHEME_EXPAND_OBSERVE_LIFT_REQUIRE(scheme_get_expand_observe(), req_form, orig_form, form); @@ -2381,14 +2163,14 @@ Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *ori return form; } -Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_mark, +Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_scope, Scheme_Comp_Env *env) { Scheme_Object *pr; while (env) { - if (COMPILE_DATA(env)->lifts - && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7])) { + if (env->lifts + && SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[7])) { break; } else env = env->next; @@ -2399,8 +2181,8 @@ Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *loc "not expanding in a module run-time body", NULL); - if (local_mark) - form = scheme_add_remove_mark(form, local_mark); + if (local_scope) + form = scheme_stx_flip_scope(form, local_scope, scheme_env_phase(env->genv)); form = scheme_datum_to_syntax(scheme_make_pair(scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, scheme_sys_wraps(env), 0, 0), @@ -2409,8 +2191,8 @@ Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *loc SCHEME_EXPAND_OBSERVE_LIFT_PROVIDE(scheme_get_expand_observe(), form); - pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7]); - SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7] = pr; + pr = scheme_make_pair(form, SCHEME_VEC_ELS(env->lifts)[7]); + SCHEME_VEC_ELS(env->lifts)[7] = pr; return scheme_void; } @@ -2419,22 +2201,25 @@ Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *gen Scheme_Object **_id, int *_use_map) { Scheme_Object *id = NULL, *v; - Scheme_Full_Comp_Env inlined_e; + Scheme_Comp_Env inlined_e; - scheme_prepare_env_renames(genv, mzMOD_RENAME_TOPLEVEL); + scheme_prepare_env_stx_context(genv); scheme_prepare_compile_env(genv); - id = scheme_make_renamed_stx(sym, genv->rename_set); + id = scheme_datum_to_syntax(sym, scheme_false, scheme_false, 0, 0); + id = scheme_stx_add_module_context(id, genv->stx_context); - inlined_e.base.num_bindings = 0; - inlined_e.base.next = NULL; - inlined_e.base.genv = genv; - inlined_e.base.flags = SCHEME_TOPLEVEL_FRAME; - init_compile_data((Scheme_Comp_Env *)&inlined_e); - inlined_e.base.prefix = NULL; + inlined_e.num_bindings = 0; + inlined_e.next = NULL; + inlined_e.genv = genv; + inlined_e.flags = SCHEME_TOPLEVEL_FRAME; + init_compile_data(&inlined_e); + inlined_e.prefix = NULL; - v = scheme_lookup_binding(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, - NULL, NULL, NULL, NULL, NULL); + v = scheme_compile_lookup(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, + NULL, + NULL, NULL, + NULL, NULL, NULL); if (v) { if (!SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) { *_use_map = -1; @@ -2447,77 +2232,6 @@ Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *gen return v; } -Scheme_Object *scheme_find_local_shadower(Scheme_Object *sym, Scheme_Object *sym_marks, Scheme_Comp_Env *env, - Scheme_Object **_free_id) -{ - Scheme_Comp_Env *frame; - Scheme_Object *esym, *uid = NULL, *env_marks, *prop, *val; - - /* Walk backward through the frames, looking for a renaming binding - with the same marks as the given identifier, sym. Skip over - unsealed ribs, though. When we find a match, rename the given - identifier so that it matches frame. */ - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - - for (i = frame->num_bindings; i--; ) { - if (frame->values[i]) { - if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->values[i]))) { - prop = scheme_stx_property(frame->values[i], unshadowable_symbol, NULL); - if (SCHEME_FALSEP(prop)) { - esym = frame->values[i]; - env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { - sym = esym; - if (frame->uids) - uid = frame->uids[i]; - else - uid = frame->uid; - break; - } - } - } - } - } - if (uid) - break; - - if (!COMPILE_DATA(frame)->sealed || *COMPILE_DATA(frame)->sealed) { - for (i = COMPILE_DATA(frame)->num_const; i--; ) { - if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) { - if (SAME_OBJ(SCHEME_STX_VAL(sym), - SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) { - esym = COMPILE_DATA(frame)->const_names[i]; - prop = scheme_stx_property(esym, unshadowable_symbol, NULL); - if (SCHEME_FALSEP(prop)) { - env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { - sym = esym; - if (COMPILE_DATA(frame)->const_uids) - uid = COMPILE_DATA(frame)->const_uids[i]; - else - uid = frame->uid; - val = COMPILE_DATA(frame)->const_vals[i]; - if (val && SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { - if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(val))) { - val = scheme_rename_transformer_id(SCHEME_PTR_VAL(val)); - *_free_id = val; - } - } - break; - } - } - } - } - } - } - if (uid) - break; - } - - return uid; -} - /*========================================================================*/ /* syntax-checking utils */ /*========================================================================*/ @@ -2551,6 +2265,7 @@ void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, Scheme_Object *form) { int i; + Scheme_Object *l; if (r->count <= 5) { for (i = 0; i < r->count; i++) { @@ -2564,21 +2279,30 @@ void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, return; } else { Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_bound_id); + ht = scheme_make_hash_table(SCHEME_hash_ptr); r->ht = ht; for (i = 0; i < r->count; i++) { - scheme_hash_set(ht, r->syms[i], scheme_true); + l = scheme_hash_get(ht, SCHEME_STX_VAL(r->syms[i])); + if (!l) l = scheme_null; + l = scheme_make_pair(r->syms[i], l); + scheme_hash_set(ht, SCHEME_STX_VAL(r->syms[i]), l); } r->count++; } } - if (scheme_hash_get(r->ht, symbol)) { - scheme_wrong_syntax(where, symbol, form, - "duplicate %s name", what); - } + l = scheme_hash_get(r->ht, SCHEME_STX_VAL(symbol)); + if (!l) l = scheme_null; + scheme_hash_set(r->ht, SCHEME_STX_VAL(symbol), scheme_make_pair(symbol, l)); - scheme_hash_set(r->ht, symbol, scheme_true); + while (!SCHEME_NULLP(l)) { + if (scheme_stx_bound_eq(symbol, SCHEME_CAR(l), scheme_make_integer(r->phase))) { + scheme_wrong_syntax(where, symbol, form, + "duplicate %s name", what); + return; + } + l = SCHEME_CDR(l); + } } diff --git a/racket/src/racket/src/compile.c b/racket/src/racket/src/compile.c index 89d9deea0a..6eda66f72a 100644 --- a/racket/src/racket/src/compile.c +++ b/racket/src/racket/src/compile.c @@ -26,7 +26,7 @@ See "eval.c" for an overview of compilation passes. - The main compile/expand loop is scheme_compile_expand_expr(). */ + The main compile/expand loop is compile_expand_expr(). */ #include "schpriv.h" #include "schmach.h" @@ -65,6 +65,7 @@ ROSYM static Scheme_Object *values_symbol; ROSYM static Scheme_Object *call_with_values_symbol; ROSYM static Scheme_Object *inferred_name_symbol; ROSYM static Scheme_Object *undefined_error_name_symbol; +ROSYM static Scheme_Object *local_keyword; THREAD_LOCAL_DECL(static Scheme_Object *quick_stx); @@ -88,8 +89,6 @@ static Scheme_Object *case_lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *e static Scheme_Object *case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); static Scheme_Object *let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); static Scheme_Object *let_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *let_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); static Scheme_Object *letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); static Scheme_Object *letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); static Scheme_Object *begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); @@ -127,6 +126,10 @@ static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Sch static Scheme_Object *expand_lam(int argc, Scheme_Object **argv); +static Scheme_Object *compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + int app_position); + static Scheme_Object *compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); static Scheme_Object *compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, @@ -135,6 +138,13 @@ static Scheme_Object *expand_block(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); static Scheme_Object *expand_stratified_block(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec, + int as_intdef); +static Scheme_Object *compile_list(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec); +static Scheme_Object *expand_list(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Expand_Info *erec, int drec); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -170,12 +180,13 @@ void scheme_init_compile (Scheme_Env *env) REGISTER_SO(inferred_name_symbol); REGISTER_SO(undefined_error_name_symbol); + REGISTER_SO(local_keyword); + scheme_undefined->type = scheme_undefined_type; lambda_symbol = scheme_intern_symbol("lambda"); letrec_values_symbol = scheme_intern_symbol("letrec-values"); - let_star_values_symbol = scheme_intern_symbol("let*-values"); let_values_symbol = scheme_intern_symbol("let-values"); begin_symbol = scheme_intern_symbol("begin"); @@ -186,6 +197,8 @@ void scheme_init_compile (Scheme_Env *env) inferred_name_symbol = scheme_intern_symbol("inferred-name"); undefined_error_name_symbol = scheme_intern_symbol("undefined-error-name"); + local_keyword = scheme_intern_exact_keyword("local", 5); + scheme_define_values_syntax = scheme_make_compiled_syntax(define_values_syntax, define_values_expand); scheme_define_syntaxes_syntax = scheme_make_compiled_syntax(define_syntaxes_syntax, @@ -241,10 +254,6 @@ void scheme_init_compile (Scheme_Env *env) scheme_make_compiled_syntax(let_values_syntax, let_values_expand), env); - scheme_add_global_keyword("let*-values", - scheme_make_compiled_syntax(let_star_values_syntax, - let_star_values_expand), - env); scheme_add_global_keyword("letrec-values", scheme_make_compiled_syntax(letrec_values_syntax, letrec_values_expand), @@ -542,7 +551,7 @@ make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code, Scheme_Compile_Info *rec, int drec) /* Compiles a `lambda' expression */ { - Scheme_Object *allparams, *params, *forms, *param, *name; + Scheme_Object *allparams, *params, *forms, *param, *name, *scope; Scheme_Closure_Data *data; Scheme_Compile_Info lam; Scheme_Comp_Env *frame; @@ -574,7 +583,9 @@ make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code, forms = SCHEME_STX_CDR(code); forms = SCHEME_STX_CDR(forms); - frame = scheme_new_compilation_frame(data->num_params, SCHEME_LAMBDA_FRAME, env); + scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + + frame = scheme_new_compilation_frame(data->num_params, SCHEME_LAMBDA_FRAME, scope, env); params = allparams; for (i = 0; i < data->num_params; i++) { if (!SCHEME_STX_PAIRP(params)) @@ -590,7 +601,7 @@ make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code, scheme_wrong_syntax(NULL, NULL, code, "empty body not allowed"); forms = scheme_datum_to_syntax(forms, code, code, 0, 0); - forms = scheme_add_env_renames(forms, frame, env); + forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); name = scheme_build_closure_name(code, rec, drec); data->name = name; @@ -601,9 +612,10 @@ make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code, { Scheme_Object *datacode; - datacode = scheme_compile_sequence(forms, - scheme_no_defines(frame), - &lam, 0); + datacode = compile_sequence(forms, + scheme_no_defines(frame), + &lam, 0, + 1); data->code = datacode; } @@ -638,7 +650,7 @@ lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *r static Scheme_Object * lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) { - Scheme_Object *args, *body, *fn, *form; + Scheme_Object *args, *body, *fn, *form, *scope; Scheme_Comp_Env *newenv; Scheme_Expand_Info erec1; @@ -651,15 +663,17 @@ lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info lambda_check_args(args, form, env); - newenv = scheme_add_compilation_frame(args, env, 0); + scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + + newenv = scheme_add_compilation_frame(args, scope, env, 0); body = SCHEME_STX_CDR(form); body = SCHEME_STX_CDR(body); body = scheme_datum_to_syntax(body, form, form, 0, 0); - body = scheme_add_env_renames(body, newenv, env); + body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); + args = scheme_stx_add_scope(args, scope, scheme_env_phase(env->genv)); /* for re-expansion */ - args = scheme_add_env_renames(args, newenv, env); /* for re-expansion */ SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(erec[drec].observer, args, body); fn = SCHEME_STX_CAR(form); @@ -715,6 +729,32 @@ Scheme_Object *scheme_clone_vector(Scheme_Object *data, int skip, int set_type) return naya; } +Scheme_Object *scheme_revert_use_site_scopes(Scheme_Object *o, Scheme_Comp_Env *env) +{ + while (1) { + if (env->scopes) { + o = scheme_stx_adjust_frame_use_site_scopes(o, + env->scopes, + scheme_env_phase(env->genv), + SCHEME_STX_REMOVE); + } + if (env->flags & (SCHEME_FOR_INTDEF | SCHEME_INTDEF_FRAME | SCHEME_INTDEF_SHADOW)) { + env = env->next; + if (!env) + break; + } else + break; + } + + if (env->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) { + o = scheme_stx_adjust_module_use_site_context(o, + env->genv->stx_context, + SCHEME_STX_REMOVE); + } + + return o; +} + void scheme_define_parse(Scheme_Object *form, Scheme_Object **var, Scheme_Object **_stk_val, int defmacro, @@ -737,6 +777,8 @@ void scheme_define_parse(Scheme_Object *form, rest = SCHEME_STX_CDR(rest); *_stk_val = SCHEME_STX_CAR(rest); + vars = scheme_revert_use_site_scopes(vars, env); + *var = vars; scheme_begin_dup_symbol_check(&r, env); @@ -765,7 +807,7 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In Scheme_Object *name, *pr, *bucket; name = SCHEME_STX_CAR(var); - name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL); + name = scheme_global_binding(name, env->genv); if (rec[drec].resolve_module_ids || !env->genv->module) { bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv); @@ -808,6 +850,14 @@ define_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_ rec[drec].value_name = SCHEME_STX_SYM(var); } +#if 0 + if (env->scopes) + val = scheme_stx_adjust_frame_use_site_scopes(val, + env->scopes, + scheme_env_phase(env->genv), + SCHEME_STX_ADD); +#endif + env = scheme_no_defines(env); val = scheme_compile_expr(val, env, rec, drec); @@ -1183,7 +1233,7 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, find_name = name; while (1) { - var = scheme_lookup_binding(find_name, env, + var = scheme_compile_lookup(find_name, env, SCHEME_SETTING + SCHEME_GLOB_ALWAYS_REFERENCE + (rec[drec].dont_mark_local_use @@ -1193,12 +1243,14 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, ? SCHEME_RESOLVE_MODIDS : 0), env->in_modidx, - &menv, NULL, NULL, NULL); - + &menv, NULL, + NULL, NULL, + NULL); + if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { /* Redirect to a macro? */ if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { - form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1); + form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1, 0); return scheme_compile_expr(form, env, rec, drec); } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { @@ -1245,7 +1297,7 @@ static Scheme_Object * set_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) { Scheme_Env *menv = NULL; - Scheme_Object *name, *var, *fn, *rhs, *find_name, *lexical_binding_id, *form; + Scheme_Object *name, *var, *fn, *rhs, *find_name, *form, *binding_id; int l; SCHEME_EXPAND_OBSERVE_PRIM_SET(erec[drec].observer); @@ -1267,10 +1319,12 @@ set_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *e while (1) { /* Make sure it's mutable, and check for redirects: */ - lexical_binding_id = NULL; - var = scheme_lookup_binding(find_name, env, SCHEME_SETTING, + var = scheme_compile_lookup(find_name, env, + SCHEME_SETTING + SCHEME_STOP_AT_FREE_EQ, env->in_modidx, - &menv, NULL, &lexical_binding_id, NULL); + &menv, NULL, + &binding_id, NULL, + NULL); SCHEME_EXPAND_OBSERVE_RESOLVE(erec[drec].observer, find_name); @@ -1280,7 +1334,7 @@ set_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *e SCHEME_EXPAND_OBSERVE_ENTER_MACRO(erec[drec].observer, form); - form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec, drec, 1); + form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec, drec, 1, 0); SCHEME_EXPAND_OBSERVE_EXIT_MACRO(erec[drec].observer, form); @@ -1299,9 +1353,8 @@ set_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *e } else break; } else { - if (lexical_binding_id) { - find_name = lexical_binding_id; - } + if (binding_id) + find_name = binding_id; break; } } @@ -1339,7 +1392,7 @@ static Scheme_Object * ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { Scheme_Env *menv = NULL; - Scheme_Object *var, *name, *rest, *dummy, *lex_id = NULL; + Scheme_Object *var, *name, *rest, *dummy, *bind_id; int l, ok; if (rec[drec].comp) @@ -1361,6 +1414,7 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, var = dummy; else var = scheme_void; + bind_id = NULL; } else { if (l != 2) bad_form(form, l); @@ -1376,7 +1430,7 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, } else { var = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_top_stx), scheme_false, scheme_sys_wraps(env), 0, 0); } - ok = scheme_stx_module_eq(rest, var, env->genv->phase); + ok = scheme_stx_free_eq(rest, var, env->genv->phase); } else ok = SCHEME_STX_SYMBOLP(name); @@ -1394,8 +1448,7 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, else var = scheme_expand_expr(name, env, rec, drec); } else { - lex_id = NULL; - var = scheme_lookup_binding(name, env, + var = scheme_compile_lookup(name, env, SCHEME_REFERENCING + SCHEME_GLOB_ALWAYS_REFERENCE + (rec[drec].dont_mark_local_use @@ -1403,9 +1456,13 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, : 0) + (rec[drec].resolve_module_ids ? SCHEME_RESOLVE_MODIDS + : 0) + + (!rec[drec].comp + ? SCHEME_STOP_AT_FREE_EQ : 0), env->in_modidx, - &menv, NULL, &lex_id, NULL); + &menv, NULL, + &bind_id, NULL, NULL); if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { @@ -1437,9 +1494,9 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, SCHEME_PTR2_VAL(o) = (Scheme_Object *)dummy; return o; } else { - if (lex_id) { + if (bind_id) { form = SCHEME_STX_CAR(form); - return scheme_make_pair(form, scheme_make_pair(lex_id, scheme_null)); + return scheme_make_pair(form, scheme_make_pair(bind_id, scheme_null)); } return NULL; } @@ -1660,7 +1717,7 @@ case_lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand form = SCHEME_STX_CDR(form); while (SCHEME_STX_PAIRP(form)) { - Scheme_Object *line_form; + Scheme_Object *line_form, *scope; Scheme_Comp_Env *newenv; SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); @@ -1673,11 +1730,14 @@ case_lambda_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand args = SCHEME_STX_CAR(line_form); body = scheme_datum_to_syntax(body, line_form, line_form, 0, 0); - - newenv = scheme_add_compilation_frame(args, env, 0); - - body = scheme_add_env_renames(body, newenv, env); - args = scheme_add_env_renames(args, newenv, env); + + scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + + newenv = scheme_add_compilation_frame(args, scope, env, 0); + + body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); + args = scheme_stx_add_scope(args, scope, scheme_env_phase(env->genv)); + SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(erec[drec].observer, args, body); { @@ -2031,7 +2091,7 @@ static Scheme_Object *detect_traditional_letrec(Scheme_Object *form, Scheme_Comp id = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_module_eq(v, id, env->genv->phase)) return form; + if (!scheme_stx_free_eq(v, id, env->genv->phase)) return form; /* found `if'; look for `(#%app values)' */ v = SCHEME_STX_CDR(v2); @@ -2048,7 +2108,7 @@ static Scheme_Object *detect_traditional_letrec(Scheme_Object *form, Scheme_Comp if (!SCHEME_STX_SYMBOLP(v2)) return form; id = scheme_datum_to_syntax(app_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_module_eq(v2, id, env->genv->phase)) return form; + if (!scheme_stx_free_eq(v2, id, env->genv->phase)) return form; v = SCHEME_STX_CDR(v); if (!SCHEME_STX_PAIRP(v)) return form; @@ -2059,7 +2119,7 @@ static Scheme_Object *detect_traditional_letrec(Scheme_Object *form, Scheme_Comp if (!SCHEME_STX_SYMBOLP(v)) return form; id = scheme_datum_to_syntax(values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - if (!scheme_stx_module_eq(v, id, env->genv->phase)) return form; + if (!scheme_stx_free_eq(v, id, env->genv->phase)) return form; /* pattern matched; drop the first clause */ v = SCHEME_STX_CDR(form); @@ -2078,29 +2138,32 @@ static Scheme_Object *detect_traditional_letrec(Scheme_Object *form, Scheme_Comp static Scheme_Object * gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, - int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec, + int recursive, int multi, Scheme_Compile_Info *rec, int drec, Scheme_Comp_Env *frame_already) { - Scheme_Object *bindings, *l, *binding, *name, **names, **clv_names, *forms, *defname; + Scheme_Object *bindings, *l, *binding, *name, **names, **clv_names, *forms, *defname, *scope; int num_clauses, num_bindings, i, j, k, m, pre_k; Scheme_Comp_Env *frame, *env, *rhs_env; Scheme_Compile_Info *recs; Scheme_Object *first = NULL; Scheme_Compiled_Let_Value *last = NULL, *lv; DupCheckRecord r; - int rec_env_already = rec[drec].env_already; - int rev_bind_order, post_bind; + int rec_env_already = rec[drec].env_already, body_block; + int rev_bind_order, post_bind, already_compiled_body; Scheme_Let_Header *head; - + form = scheme_stx_taint_disarm(form, NULL); - if (rec_env_already == 2) { + if (rec_env_already >= 2) { + body_block = (rec_env_already > 2); l = detect_traditional_letrec(form, origenv); if (!SAME_OBJ(l, form)) { rec_env_already = 1; form = l; - } - } + } else + rec_env_already = 2; + } else + body_block = !rec_env_already; i = scheme_stx_proper_list_length(form); if (i < 3) @@ -2113,9 +2176,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, if (num_clauses < 0) scheme_wrong_syntax(NULL, bindings, form, NULL); - if (num_clauses < 2) star = 0; - - post_bind = !recursive && !star; + post_bind = !recursive; rev_bind_order = recursive; /* forms ends up being the let body */ @@ -2124,12 +2185,19 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, forms = scheme_datum_to_syntax(forms, form, form, 0, 0); if (!num_clauses) { - env = scheme_no_defines(origenv); + if (!body_block) + scheme_signal_error("internal error: no local bindings, but body is not in a block"); + + /* Even though there are no bindings, we need a scope to + indicate a nested binding context */ + scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + env = scheme_new_compilation_frame(0, 0, scope, origenv); + forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); name = scheme_check_name_property(form, rec[drec].value_name); rec[drec].value_name = name; - return scheme_compile_sequence(forms, env, rec, drec); + return compile_sequence(forms, env, rec, drec, body_block); } if (multi) { @@ -2169,6 +2237,10 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, } else num_bindings = num_clauses; + if (rec_env_already) + scope = NULL; + else + scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); names = MALLOC_N(Scheme_Object *, num_bindings); if (frame_already) @@ -2176,6 +2248,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, else { frame = scheme_new_compilation_frame(num_bindings, (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), + scope, origenv); if (rec_env_already) frame_already = frame; @@ -2194,7 +2267,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, defname = scheme_check_name_property(form, defname); - if (!star && !frame_already) { + if (!frame_already) { scheme_begin_dup_symbol_check(&r, env); } @@ -2259,7 +2332,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, names[k++] = name; } - if (!star && !frame_already) { + if (!frame_already) { for (m = pre_k; m < k; m++) { scheme_dup_symbol_check(&r, NULL, names[m], "binding", form); } @@ -2294,7 +2367,6 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, Scheme_Object *ce, *rhs; rhs = SCHEME_STX_CDR(binding); rhs = SCHEME_STX_CAR(rhs); - rhs = scheme_add_env_renames(rhs, env, origenv); ce = scheme_compile_expr(rhs, rhs_env, recs, i); lv->value = ce; } else { @@ -2304,7 +2376,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, lv->value = rhs; } - if (star || recursive) { + if (recursive) { for (m = pre_k; m < k; m++) { scheme_add_compilation_binding(m, names[m], frame); } @@ -2316,15 +2388,14 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, k = pre_k; } - if (!star && !recursive) { + if (!recursive) { for (i = 0; i < num_bindings; i++) { scheme_add_compilation_binding(i, names[i], frame); } } head = make_header(first, num_bindings, num_clauses, - ((recursive ? SCHEME_LET_RECURSIVE : 0) - | (star ? SCHEME_LET_STAR : 0))); + (recursive ? SCHEME_LET_RECURSIVE : 0)); if (recursive) { Scheme_Let_Header *current_head = head; @@ -2335,7 +2406,8 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) { Scheme_Object *ce, *rhs; rhs = lv->value; - rhs = scheme_add_env_renames(rhs, env, origenv); + if (scope) + rhs = scheme_stx_add_scope(rhs, scope, scheme_env_phase(env->genv)); ce = scheme_compile_expr(rhs, env, recs, i); lv->value = ce; @@ -2392,11 +2464,18 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, } } + if (SCHEME_STX_PAIRP(forms) + && SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(SCHEME_STX_CAR(forms))), + scheme_already_comp_type)) + already_compiled_body = 1; + else + already_compiled_body = 0; + recs[num_clauses].value_name = defname ? SCHEME_STX_SYM(defname) : NULL; { Scheme_Object *cs; - forms = scheme_add_env_renames(forms, env, origenv); - cs = scheme_compile_sequence(forms, env, recs, num_clauses); + if (scope) forms = scheme_stx_add_scope(forms, scope, scheme_env_phase(env->genv)); + cs = compile_sequence(forms, env, recs, num_clauses, body_block); last->body = cs; } @@ -2442,6 +2521,32 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, } } + if (!already_compiled_body) { + /* Help the optimizer by removing unused expressions right away */ + lv = (Scheme_Compiled_Let_Value *)head->body; + for (i = 0; i < head->num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) { + for (j = lv->count; j--; ) { + if (lv->flags[j] & SCHEME_WAS_USED) + break; + } + if (j < 0) { + if (scheme_omittable_expr(lv->value, lv->count, 10, 0, NULL, NULL, 0, 0, 1)) { + if (lv->count == 1) { + lv->value = scheme_false; + } else { + Scheme_Object *app; + app = scheme_null; + for (k = lv->count; k--; ) { + app = scheme_make_pair(scheme_false, app); + } + app = scheme_make_application(scheme_make_pair(scheme_values_func, app), NULL); + lv->value = app; + } + } + } + } + } + scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1); return (Scheme_Object *)head; @@ -2449,27 +2554,30 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, static Scheme_Object * do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_Info *erec, int drec, - const char *formname, int letrec, int multi, int letstar, + const char *formname, int letrec, int multi, Scheme_Comp_Env *env_already) { - Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname, *form, *pre_set; + Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname, *form, *pre_set, *scope; Scheme_Comp_Env *use_env, *env; Scheme_Expand_Info erec1; DupCheckRecord r; - int rec_env_already = erec[drec].env_already, forward_ref_boundary; + int rec_env_already = erec[drec].env_already, forward_ref_boundary, body_block; /* If env_already == 2, then it's not a true `letrec': it's from `letrec-values+syntax' and should be expanded into `let' plus `letrec'. */ form = scheme_stx_taint_disarm(orig_form, NULL); - if (rec_env_already == 2) { + if (rec_env_already >= 2) { + body_block = (rec_env_already > 2); + rec_env_already = 2; v = detect_traditional_letrec(form, origenv); if (!SAME_OBJ(v, form)) { rec_env_already = 1; form = v; } - } + } else + body_block = !rec_env_already; vars = SCHEME_STX_CDR(form); @@ -2486,56 +2594,7 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ boundname = scheme_check_name_property(form, erec[drec].value_name); erec[drec].value_name = boundname; - - if (letstar) { - if (!SCHEME_STX_NULLP(vars)) { - Scheme_Object *a, *vr; - - if (!SCHEME_STX_PAIRP(vars)) - scheme_wrong_syntax(NULL, vars, form, NULL); - - a = SCHEME_STX_CAR(vars); - vr = SCHEME_STX_CDR(vars); - - first = let_values_symbol; - first = scheme_datum_to_syntax(first, form, scheme_sys_wraps(origenv), 0, 0); - - if (SCHEME_STX_NULLP(vr)) { - /* Don't create redundant empty let form */ - } else { - last = let_star_values_symbol; - last = scheme_datum_to_syntax(last, form, scheme_sys_wraps(origenv), 0, 0); - body = cons(cons(last, cons(vr, body)), - scheme_null); - } - - body = cons(first, - cons(cons(a, scheme_null), - body)); - } else { - first = scheme_datum_to_syntax(let_values_symbol, form, scheme_sys_wraps(origenv), 0, 0); - body = cons(first, cons(scheme_null, body)); - } - - body = scheme_datum_to_syntax(body, form, form, 0, -1); - - first = SCHEME_STX_CAR(form); - body = scheme_stx_track(body, form, first); - - if (erec[drec].depth > 0) - --erec[drec].depth; - - body = scheme_stx_taint_rearm(body, orig_form); - - if (!erec[drec].depth) - return body; - else { - env = scheme_no_defines(origenv); - return scheme_expand_expr(body, env, erec, drec); - } - } - /* Note: no more letstar handling needed after this point */ if (!env_already && !rec_env_already) scheme_begin_dup_symbol_check(&r, origenv); @@ -2581,12 +2640,19 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ if (!SCHEME_STX_NULLP(vs)) scheme_wrong_syntax(NULL, vs, form, NULL); - if (env_already) + if (env_already) { env = env_already; - else + scope = NULL; + } else { + if (rec_env_already) + scope = NULL; + else + scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); env = scheme_add_compilation_frame(vlist, - origenv, + scope, + origenv, (rec_env_already ? SCHEME_INTDEF_SHADOW : 0)); + } if (letrec) use_env = env; @@ -2605,14 +2671,14 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ /* Make sure names gets their own renames: */ name = SCHEME_STX_CAR(v); - name = scheme_add_env_renames(name, env, origenv); + if (scope) name = scheme_stx_add_scope(name, scope, scheme_env_phase(env->genv)); if (rec_env_already == 2) forward_ref_boundary += scheme_stx_proper_list_length(name); rhs = SCHEME_STX_CDR(v); rhs = SCHEME_STX_CAR(rhs); - rhs = scheme_add_env_renames(rhs, use_env, origenv); + if (scope && letrec) rhs = scheme_stx_add_scope(rhs, scope, scheme_env_phase(env->genv)); v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); v = cons(v, scheme_null); @@ -2631,7 +2697,7 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ vars = first; body = scheme_datum_to_syntax(body, form, form, 0, 0); - body = scheme_add_env_renames(body, env, origenv); + if (scope) body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv)); SCHEME_EXPAND_OBSERVE_LET_RENAMES(erec[drec].observer, vars, body); /* Pass 2: Expand */ @@ -2707,7 +2773,10 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_ SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer); scheme_init_expand_recs(erec, drec, &erec1, 1); erec1.value_name = erec[drec].value_name; - body = expand_block(body, env, &erec1, 0); + if (!body_block) + body = expand_list(body, env, &erec1, 0); + else + body = expand_block(body, env, &erec1, 0); if (SCHEME_PAIRP(pre_set)) { if (first) @@ -2735,21 +2804,14 @@ static Scheme_Object * let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) { SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(erec[drec].observer); - return do_let_expand(form, env, erec, drec, "let-values", 0, 1, 0, NULL); -} - -static Scheme_Object * -let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(erec[drec].observer); - return do_let_expand(form, env, erec, drec, "let*-values", 0, 1, 1, NULL); + return do_let_expand(form, env, erec, drec, "let-values", 0, 1, NULL); } static Scheme_Object * letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) { SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(erec[drec].observer); - return do_let_expand(form, env, erec, drec, "letrec-values", 1, 1, 0, NULL); + return do_let_expand(form, env, erec, drec, "letrec-values", 1, 1, NULL); } @@ -2757,57 +2819,24 @@ static Scheme_Object * let_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { - return gen_let_syntax(form, env, "let-values", 0, 0, 1, rec, drec, NULL); -} - -static Scheme_Object * -let_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return gen_let_syntax(form, env, "let*-values", 1, 0, 1, rec, drec, NULL); + return gen_let_syntax(form, env, "let-values", 0, 1, rec, drec, NULL); } static Scheme_Object * letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { - return gen_let_syntax(form, env, "letrec-values", 0, 1, 1, rec, drec, NULL); + return gen_let_syntax(form, env, "letrec-values", 1, 1, rec, drec, NULL); } /**********************************************************************/ /* begin, begin0, implicit begins */ /**********************************************************************/ -Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, +static Scheme_Object *compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) + Scheme_Compile_Info *rec, int drec, + int as_intdef) { -#if 0 - /* This attempt at a shortcut is wrong, because the sole expression might expand - to a `begin' that needs to be spliced into an internal-definition context. */ - try_again: - - if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { - /* If it's a begin, we have to check some more... */ - Scheme_Object *first, *val; - - first = SCHEME_STX_CAR(forms); - first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL, 0); - - if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) { - /* Flatten begin: */ - if (scheme_stx_proper_list_length(first) > 1) { - Scheme_Object *rest; - rest = scheme_flatten_begin(first, scheme_null); - first = scheme_datum_to_syntax(rest, first, first, 0, 2); - forms = first; - goto try_again; - } - } - - return scheme_compile_expr(first, env, rec, drec); - } -#endif - if (scheme_stx_proper_list_length(forms) < 0) { scheme_wrong_syntax(scheme_begin_stx_string, NULL, scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), @@ -2815,7 +2844,10 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, return NULL; } else { Scheme_Object *body; - body = compile_block(forms, env, rec, drec); + if (as_intdef) + body = compile_block(forms, env, rec, drec); + else + body = compile_list(forms, env, rec, drec); return scheme_make_sequence_compilation(body, 1); } } @@ -2873,7 +2905,7 @@ do_begin_syntax(char *name, first = SCHEME_STX_CAR(forms); first = scheme_compile_expr(first, env, recs, 0); rest = SCHEME_STX_CDR(forms); - rest = scheme_compile_list(rest, env, recs, 1); + rest = compile_list(rest, env, recs, 1); scheme_merge_compile_recs(rec, drec, recs, 2); @@ -2883,11 +2915,11 @@ do_begin_syntax(char *name, v = scheme_check_name_property(form, rec[drec].value_name); rec[drec].value_name = v; - body = scheme_compile_list(forms, env, rec, drec); + body = compile_list(forms, env, rec, drec); } } else { /* Top level */ - body = scheme_compile_list(forms, env, rec, drec); + body = compile_list(forms, env, rec, drec); } forms = scheme_make_sequence_compilation(body, zero ? -1 : 1); @@ -3078,7 +3110,7 @@ do_begin_expand(char *name, fst = scheme_expand_expr(fst, env, &erec1, 0); rest = scheme_datum_to_syntax(rest, form, form, 0, 0); SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - rest = scheme_expand_list(rest, env, erec, drec); + rest = expand_list(rest, env, erec, drec); form = cons(fst, rest); } else { @@ -3086,8 +3118,8 @@ do_begin_expand(char *name, boundname = scheme_check_name_property(form, erec[drec].value_name); erec[drec].value_name = boundname; - form = scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), - env, erec, drec); + form = expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), + env, erec, drec); #if 0 if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) return scheme_stx_taint_rearm(SCHEME_STX_CAR(form), orig_form); @@ -3095,8 +3127,8 @@ do_begin_expand(char *name, } } else { /* Top level */ - form = scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), - env, erec, drec); + form = expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), + env, erec, drec); } return scheme_datum_to_syntax(cons(form_name, form), @@ -3242,8 +3274,9 @@ unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er static Scheme_Object * quote_syntax_syntax(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { - int len; + int len, local; Scheme_Object *stx, *form; + Scheme_Comp_Env *frame; if (rec[drec].comp) env->prefix->non_phaseless = 1; @@ -3254,15 +3287,61 @@ quote_syntax_syntax(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compi scheme_compile_rec_done_local(rec, drec); len = check_form(form, form); - if (len != 2) + if ((len != 2) && (len != 3)) bad_form(form, len); - if (rec[drec].comp) { + if (len == 3) { + stx = SCHEME_STX_CDR(form); + stx = SCHEME_STX_CDR(stx); + stx = SCHEME_STX_CAR(stx); + if (!SAME_OBJ(SCHEME_STX_VAL(stx), local_keyword)) { + scheme_wrong_syntax(NULL, stx, form, "second subform is not `#:local'"); + return NULL; + } + local = 1; + if (!rec[drec].comp) { + /* A `(quote-syntax _ #:local)` counts as a reference at all levels */ + scheme_mark_all_use(env); + } + } else + local = 0; + + if (!local) { stx = SCHEME_STX_CDR(form); stx = SCHEME_STX_CAR(stx); - return scheme_register_stx_in_prefix(stx, env, rec, drec); - } else - return orig_form; + + /* Remove scopes for all enclosing local binding contexts. */ + for (frame = env; frame; frame = frame->next) { + if (frame->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME)) + stx = scheme_stx_adjust_module_use_site_context(stx, + env->genv->stx_context, + SCHEME_STX_REMOVE); + else if (frame->scopes) { + if (frame->flags & SCHEME_KEEP_SCOPES_FRAME) + stx = scheme_stx_adjust_frame_use_site_scopes(stx, frame->scopes, + scheme_env_phase(frame->genv), SCHEME_STX_REMOVE); + else + stx = scheme_stx_adjust_frame_scopes(stx, frame->scopes, + scheme_env_phase(frame->genv), SCHEME_STX_REMOVE); + } + } + + if (rec[drec].comp) + return scheme_register_stx_in_prefix(stx, env, rec, drec); + else { + form = SCHEME_STX_CAR(form); + return scheme_datum_to_syntax(scheme_make_pair(form, + scheme_make_pair(stx, scheme_null)), + orig_form, orig_form, 0, 2); + } + } else { + if (rec[drec].comp) { + stx = SCHEME_STX_CDR(form); + stx = SCHEME_STX_CAR(stx); + return scheme_register_stx_in_prefix(stx, env, rec, drec); + } else + return orig_form; + } } static Scheme_Object * @@ -3282,6 +3361,7 @@ static void prep_exp_env_compile_rec(Scheme_Compile_Info *rec, int drec) rec[0].comp = 1; rec[0].dont_mark_local_use = 0; rec[0].resolve_module_ids = 0; + rec[0].substitute_bindings = 1; rec[0].value_name = NULL; rec[0].observer = NULL; rec[0].pre_unwrapped = 0; @@ -3294,7 +3374,7 @@ static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) { Scheme_Env *env = (Scheme_Env *)_env; - return scheme_tl_id_sym(env, name, NULL, 2, NULL, NULL); + return scheme_global_binding(name, env); } static Scheme_Object * @@ -3311,12 +3391,14 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, scheme_define_parse(form, &names, &code, 1, env, 0); + code = scheme_revert_use_site_scopes(code, env); + scheme_prepare_exp_env(env->genv); scheme_prepare_compile_env(env->genv->exp_env); names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv); - exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); + exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, NULL, 0); dummy = scheme_make_environment_dummy(env); @@ -3355,12 +3437,14 @@ define_syntaxes_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Ex scheme_define_parse(form, &names, &code, 1, env, 0); + code = scheme_revert_use_site_scopes(code, env); + SCHEME_EXPAND_OBSERVE_PREPARE_ENV(erec[drec].observer); scheme_prepare_exp_env(env->genv); scheme_prepare_compile_env(env->genv->exp_env); - env = scheme_new_expand_env(env->genv->exp_env, env->insp, 0); + env = scheme_new_expand_env(env->genv->exp_env, env->insp, NULL, 0); erec[drec].value_name = names; fpart = scheme_expand_expr_lift_to_let(code, env, erec, drec); @@ -3396,9 +3480,9 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem scheme_prepare_compile_env(in_env->genv->exp_env); if (rec[drec].comp) - env = scheme_new_comp_env(in_env->genv->exp_env, in_env->insp, 0); + env = scheme_new_comp_env(in_env->genv->exp_env, in_env->insp, NULL, 0); else - env = scheme_new_expand_env(in_env->genv->exp_env, in_env->insp, 0); + env = scheme_new_expand_env(in_env->genv->exp_env, in_env->insp, NULL, 0); if (rec[drec].comp) dummy = scheme_make_environment_dummy(in_env); @@ -3415,10 +3499,10 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem if (rec[drec].comp) { scheme_init_compile_recs(rec, drec, recs, 1); prep_exp_env_compile_rec(recs, 0); - l = scheme_compile_list(l, env, recs, 0); + l = compile_list(l, env, recs, 0); } else { scheme_init_expand_recs(rec, drec, recs, 1); - l = scheme_expand_list(l, env, recs, 0); + l = expand_list(l, env, recs, 0); } if (SCHEME_NULLP(form)) @@ -3522,7 +3606,8 @@ static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_e 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, rhs_env->genv, rhs_env->genv->link_midx); + scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false, + rhs_env->genv, rhs_env->genv->link_midx); a = scheme_eval_linked_expr_multi_with_dynamic_state(a, &dyn_state); scheme_pop_continuation_frame(&cframe); @@ -3558,7 +3643,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos, Scheme_Object *rename_rib) + int *_pos, Scheme_Object *rename_rib, + int replace_value) { Scheme_Object **results, *l, *a_expr; Scheme_Comp_Env *eenv; @@ -3568,7 +3654,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object int vc, nc, j, i; Scheme_Compile_Expand_Info mrec; - eenv = scheme_new_comp_env(exp_env, insp, 0); + eenv = scheme_new_comp_env(exp_env, insp, NULL, 0); /* First expand for expansion-observation */ if (!rec[drec].comp) { @@ -3581,6 +3667,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object mrec.comp = 1; mrec.dont_mark_local_use = 0; mrec.resolve_module_ids = 1; + mrec.substitute_bindings = 1; mrec.value_name = NULL; mrec.observer = NULL; mrec.pre_unwrapped = 0; @@ -3601,7 +3688,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object expression may have syntax objects with a lexical rename that is still being extended. For letrec-syntaxes+values, don't simplify because it's too expensive. */ - rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, 0); + rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, insp); ri = scheme_resolve_info_create(rp); a = scheme_resolve_expr(a, ri); @@ -3666,13 +3753,14 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object SCHEME_PTR_VAL(macro) = a; else SCHEME_PTR_VAL(macro) = results[j]; - - scheme_set_local_syntax(i++, name, macro, stx_env); + + scheme_set_local_syntax(i++, name, macro, stx_env, replace_value); if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) { - /* Install a free-id=? rename */ - scheme_install_free_id_rename(name, scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), rename_rib, - scheme_make_integer(rhs_env->genv->phase)); + /* Rebind to the target identifier's binding */ + scheme_add_binding_copy(name, + scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), + scheme_make_integer(stx_env->genv->phase)); } } *_pos = i; @@ -3687,10 +3775,10 @@ do_letrec_syntaxes(const char *where, Scheme_Object *orig_forms, Scheme_Comp_Env *origenv, Scheme_Compile_Info *rec, int drec) { - Scheme_Object *forms, *form, *bindings, *var_bindings, *body, *v; + Scheme_Object *forms, *form, *bindings, *var_bindings, *body, *v, *scope; Scheme_Object *names_to_disappear; Scheme_Comp_Env *stx_env, *var_env, *rhs_env; - int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already; + int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already, restore; DupCheckRecord r; forms = scheme_stx_taint_disarm(orig_forms, NULL); @@ -3710,10 +3798,13 @@ do_letrec_syntaxes(const char *where, scheme_wrong_syntax(NULL, NULL, forms, NULL); body = scheme_datum_to_syntax(form, forms, forms, 0, 0); - if (env_already) + if (env_already) { stx_env = origenv; - else - stx_env = scheme_new_compilation_frame(0, 0, origenv); + scope = NULL; + } else { + scope = scheme_new_scope(SCHEME_STX_LOCAL_BIND_SCOPE); + stx_env = scheme_new_compilation_frame(0, 0, scope, origenv); + } rhs_env = stx_env; @@ -3730,8 +3821,9 @@ do_letrec_syntaxes(const char *where, saw_var = 0; depth = rec[drec].depth; + restore = (depth >= 0); - if (!rec[drec].comp && (depth <= 0) && (depth > -2)) + if (!rec[drec].comp && !restore) names_to_disappear = scheme_null; else names_to_disappear = NULL; @@ -3792,7 +3884,8 @@ do_letrec_syntaxes(const char *where, if (saw_var) { var_env = scheme_new_compilation_frame(var_cnt, - (env_already ? SCHEME_INTDEF_SHADOW : 0), + (env_already ? SCHEME_INTDEF_SHADOW : 0), + scope, stx_env); } else var_env = NULL; @@ -3827,7 +3920,7 @@ do_letrec_syntaxes(const char *where, But that's ok. We need it now for env_renames. */ scheme_add_compilation_binding(j++, a, var_env); } else - scheme_set_local_syntax(j++, a, NULL, stx_env); + scheme_set_local_syntax(j++, a, NULL, stx_env, 0); } if (i) j = pre_j; @@ -3835,6 +3928,12 @@ do_letrec_syntaxes(const char *where, } } + if (scope) { + bindings = scheme_stx_add_scope(bindings, scope, scheme_env_phase(stx_env->genv)); + var_bindings = scheme_stx_add_scope(var_bindings, scope, scheme_env_phase(stx_env->genv)); + body = scheme_stx_add_scope(body, scope, scheme_env_phase(stx_env->genv)); + } + if (names_to_disappear) { for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { Scheme_Object *a, *names; @@ -3843,20 +3942,12 @@ do_letrec_syntaxes(const char *where, names = SCHEME_STX_CAR(a); while (!SCHEME_STX_NULLP(names)) { a = SCHEME_STX_CAR(names); - if (names_to_disappear) - names_to_disappear = cons(a, names_to_disappear); + names_to_disappear = cons(a, names_to_disappear); names = SCHEME_STX_CDR(names); } } } - - bindings = scheme_add_env_renames(bindings, stx_env, origenv); - if (var_env) - bindings = scheme_add_env_renames(bindings, var_env, origenv); - if (var_env) - var_bindings = scheme_add_env_renames(var_bindings, stx_env, origenv); - body = scheme_add_env_renames(body, stx_env, origenv); SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(rec[drec].observer, bindings, var_bindings, body); SCHEME_EXPAND_OBSERVE_PREPARE_ENV(rec[drec].observer); @@ -3881,7 +3972,7 @@ do_letrec_syntaxes(const char *where, stx_env->insp, rec, drec, stx_env, rhs_env, - &i, NULL); + &i, NULL, 1); } } @@ -3908,7 +3999,7 @@ do_letrec_syntaxes(const char *where, for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { a = SCHEME_CAR(l); - a = scheme_add_env_renames(a, stx_env, origenv); + if (scope) a = scheme_stx_add_scope(a, scope, scheme_env_phase(stx_env->genv)); SCHEME_CAR(l) = a; } @@ -3919,15 +4010,21 @@ do_letrec_syntaxes(const char *where, } if (!var_env) { - var_env = scheme_require_renames(stx_env); + var_env = stx_env; if (rec[drec].comp) { v = scheme_check_name_property(forms, rec[drec].value_name); rec[drec].value_name = v; - v = compile_block(body, var_env, rec, drec); + if (env_already) + v = compile_list(body, var_env, rec, drec); + else + v = compile_block(body, var_env, rec, drec); v = scheme_make_sequence_compilation(v, 1); } else { - v = expand_block(body, var_env, rec, drec); - if ((depth >= 0) || (depth == -2)) { + if (env_already) + v = expand_list(body, var_env, rec, drec); + else + v = expand_block(body, var_env, rec, drec); + if (restore) { Scheme_Object *formname; formname = SCHEME_STX_CAR(forms); v = cons(formname, cons(bindings, cons(var_bindings, v))); @@ -3941,7 +4038,7 @@ do_letrec_syntaxes(const char *where, else v = scheme_stx_taint_rearm(v, orig_forms); - if (!((depth >= 0) || (depth == -2))) { + if (!restore) { SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v); } } @@ -3949,25 +4046,24 @@ do_letrec_syntaxes(const char *where, /* Construct letrec-values expression: */ v = cons(letrec_values_symbol, cons(var_bindings, body)); v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), 0, 2); - + if (!env_already) { /* i.e., not internal defn */ /* We want non-`letrec' semantics for value bindings (i.e., sort - out the bindings into `letrec' and `let'): */ - rec[drec].env_already = 2; + out the bindings into `letrec' and `let'), but also treat the + body as a block. */ + rec[drec].env_already = 3; } if (rec[drec].comp) { - v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env); + v = gen_let_syntax(v, stx_env, "letrec-values", 1, 1, rec, drec, var_env); } else { - int restore = ((depth >= 0) || (depth == -2)); - if (restore && (rec[drec].env_already == 2)) { /* don't sort out after all, because we're keeping `letrec-values+syntaxes' */ rec[drec].env_already = 1; } SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(rec[drec].observer); - v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env); + v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, var_env); if (restore) { /* Add back out the pieces we want: */ @@ -4208,8 +4304,8 @@ void scheme_finish_application(Scheme_App_Rec *app) /*========================================================================*/ static Scheme_Object * -scheme_inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, int start_app_position) +inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec, int start_app_position) { int len; @@ -4240,8 +4336,8 @@ scheme_inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, first = SCHEME_STX_CAR(rest); rest = SCHEME_STX_CDR(rest); - c = scheme_compile_expand_expr(first, env, recs, i, - !i && start_app_position); + c = compile_expand_expr(first, env, recs, i, + !i && start_app_position); p = scheme_make_pair(c, scheme_null); if (comp_last) @@ -4279,31 +4375,26 @@ static Scheme_Object *compile_application(Scheme_Object *form, Scheme_Comp_Env * scheme_wrong_syntax(scheme_application_stx_string, NULL, form, NULL); scheme_compile_rec_done_local(rec, drec); - form = scheme_inner_compile_list(form, scheme_no_defines(env), rec, drec, 1); + form = inner_compile_list(form, scheme_no_defines(env), rec, drec, 1); result = scheme_make_application(form, NULL); return result; } -Scheme_Object * -scheme_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) +Scheme_Object *compile_list(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) { - return scheme_inner_compile_list(form, env, rec, drec, 0); + return inner_compile_list(form, env, rec, drec, 0); } Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec, - int internel_def_pos, Scheme_Object **current_val, - Scheme_Comp_Env **_xenv, - Scheme_Object *ctx, int keep_name) { Scheme_Object *name, *val; - Scheme_Comp_Env *xenv = (_xenv ? *_xenv : NULL); Scheme_Expand_Info erec1; Scheme_Env *menv = NULL; @@ -4325,7 +4416,7 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, } while (1) { - val = scheme_lookup_binding(name, env, + val = scheme_compile_lookup(name, env, SCHEME_NULL_FOR_UNBOUND + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + SCHEME_DONT_MARK_USE @@ -4334,9 +4425,14 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, : 0) + ((rec[drec].comp && rec[drec].resolve_module_ids) ? SCHEME_RESOLVE_MODIDS + : 0) + + (!rec[drec].comp + ? SCHEME_STOP_AT_FREE_EQ : 0), env->in_modidx, - &menv, NULL, NULL, NULL); + &menv, NULL, + NULL, NULL, + NULL); if (SCHEME_STX_PAIRP(first)) *current_val = val; @@ -4352,24 +4448,10 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, menv = NULL; SCHEME_USE_FUEL(1); } else { - /* It's a normal macro; expand once. Also, extend env to indicate - an internal-define position, if necessary. */ - if (!xenv) { - if (internel_def_pos) { - xenv = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, env); - if (ctx) - xenv->intdef_name = ctx; - if (_xenv) - *_xenv = xenv; - } else - xenv = env; - } - { - scheme_init_expand_recs(rec, drec, &erec1, 1); - erec1.depth = 1; - erec1.value_name = (keep_name ? rec[drec].value_name : scheme_false); - first = scheme_expand_expr(first, xenv, &erec1, 0); - } + scheme_init_expand_recs(rec, drec, &erec1, 1); + erec1.depth = 1; + erec1.value_name = (keep_name ? rec[drec].value_name : scheme_false); + first = scheme_expand_expr(first, env, &erec1, 0); break; /* break to outer loop */ } } else { @@ -4383,7 +4465,8 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, static Scheme_Object * compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *macro, Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) + Scheme_Compile_Expand_Info *rec, int drec, + int scope_macro_use) { Scheme_Object *xformer, *boundname; @@ -4402,7 +4485,8 @@ compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *m if (!boundname) boundname = scheme_false; - return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0); + return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0, + scope_macro_use); /* caller expects rec[drec] to be used to compile the result... */ } @@ -4412,7 +4496,9 @@ static int same_effective_env(Scheme_Comp_Env *orig, Scheme_Comp_Env *e) while (1) { if (orig == e) return 1; - if (e && e->flags & SCHEME_FOR_STOPS) + if ((e && e->flags & SCHEME_FOR_STOPS) + || (!(e->flags & (~SCHEME_INTDEF_FRAME)) + && !e->num_bindings)) e = e->next; else return 0; @@ -4430,22 +4516,22 @@ static Scheme_Object *compile_expand_expr_k(void) p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; - return scheme_compile_expand_expr(form, - env, - rec, - p->ku.k.i3, - p->ku.k.i2); + return compile_expand_expr(form, + env, + rec, + p->ku.k.i3, + p->ku.k.i2); } Scheme_Object * -scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int app_position) +compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + int app_position) { Scheme_Object *name, *var, *stx, *normal, *can_recycle_stx = NULL, *orig_unbound_name = NULL; Scheme_Env *menv = NULL; GC_CAN_IGNORE char *not_allowed; - int looking_for_top, has_orig_unbound = 0; + int has_orig_unbound = 0, need_macro_scope = 0; top: @@ -4491,36 +4577,33 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) { var = SCHEME_STX_VAL(form); - if (scheme_stx_has_empty_wraps(form) + if (scheme_stx_has_empty_wraps(form, scheme_env_phase(env->genv)) && same_effective_env(SCHEME_PTR2_VAL(var), env)) { /* FIXME [Ryan?]: this needs EXPAND_OBSERVE callbacks. */ form = scheme_stx_track(SCHEME_PTR1_VAL(var), form, form); - if (!rec[drec].comp && (rec[drec].depth != -1)) { + if (!rec[drec].comp) { /* Already fully expanded. */ return form; } } else { scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), "expanded syntax not in its original lexical context" - " (extra bindings or marks in the current context)"); + " (extra bindings or scopes in the current context)"); } } - looking_for_top = 0; - if (SCHEME_STX_NULLP(form)) { stx = app_symbol; not_allowed = "function application"; normal = app_expander; } else if (!SCHEME_STX_PAIRP(form)) { if (SCHEME_STX_SYMBOLP(form)) { - Scheme_Object *find_name = form, *lexical_binding_id, *inline_variant; + Scheme_Object *find_name = form, *inline_variant, *bind_id; int protected = 0; while (1) { - lexical_binding_id = NULL; inline_variant = NULL; - var = scheme_lookup_binding(find_name, env, + var = scheme_compile_lookup(find_name, env, SCHEME_NULL_FOR_UNBOUND + SCHEME_ENV_CONSTANTS_OK + (rec[drec].comp @@ -4537,9 +4620,14 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, : 0) + ((!rec[drec].comp && (rec[drec].depth == -2)) ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) + : 0) + + (!rec[drec].comp + ? SCHEME_STOP_AT_FREE_EQ : 0), env->in_modidx, - &menv, &protected, &lexical_binding_id, &inline_variant); + &menv, &protected, + &bind_id, &need_macro_scope, + &inline_variant); SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name); @@ -4569,7 +4657,6 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, normal = top_expander; has_orig_unbound = 1; form = find_name; /* in case it was re-mapped */ - looking_for_top = 1; } else { if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { if (var == stop_expander) { @@ -4611,9 +4698,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, return var; } else { SCHEME_EXPAND_OBSERVE_VARIABLE(rec[drec].observer, form, find_name); - if (lexical_binding_id) { - find_name = lexical_binding_id; - } + if (bind_id && rec[drec].substitute_bindings) + find_name = bind_id; if (protected) { /* Add a property to indicate that the name is protected */ find_name = scheme_stx_property(find_name, protected_symbol, scheme_true); @@ -4645,7 +4731,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, scheme_init_expand_recs(rec, drec, &erec1, 1); while (1) { - var = scheme_lookup_binding(find_name, env, + var = scheme_compile_lookup(find_name, env, SCHEME_APP_POS + SCHEME_NULL_FOR_UNBOUND + SCHEME_ENV_CONSTANTS_OK @@ -4658,9 +4744,14 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, : 0) + ((!rec[drec].comp && (rec[drec].depth == -2)) ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) + : 0) + + (!rec[drec].comp + ? SCHEME_STOP_AT_FREE_EQ : 0), env->in_modidx, - &menv, NULL, NULL, NULL); + &menv, NULL, + NULL, &need_macro_scope, + NULL); SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) @@ -4727,10 +4818,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, stx = scheme_datum_to_syntax(stx, form, form, 0, 1); stx = scheme_stx_taint_rearm(stx, form); } else if (quick_stx && rec[drec].comp) { - ((Scheme_Stx *)quick_stx)->val = stx; - ((Scheme_Stx *)quick_stx)->wraps = ((Scheme_Stx *)form)->wraps; - ((Scheme_Stx *)quick_stx)->u.modinfo_cache = NULL; - ((Scheme_Stx *)quick_stx)->taints = NULL; + scheme_stx_set(quick_stx, stx, form); stx = quick_stx; quick_stx = NULL; } else @@ -4743,15 +4831,20 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *find_name = stx; while (1) { - var = scheme_lookup_binding(find_name, env, + var = scheme_compile_lookup(find_name, env, SCHEME_NULL_FOR_UNBOUND + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + SCHEME_DONT_MARK_USE + ((!rec[drec].comp && (rec[drec].depth == -2)) ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) + : 0) + + (!rec[drec].comp + ? SCHEME_STOP_AT_FREE_EQ : 0), env->in_modidx, - &menv, NULL, NULL, NULL); + &menv, NULL, + NULL, &need_macro_scope, + NULL); SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); @@ -4776,27 +4869,6 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, can_recycle_stx = NULL; } - if (!var && looking_for_top) { - /* If form is a marked name, then force #%top binding. - This is so temporaries can be used as defined ids. */ - Scheme_Object *nm; - nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL, NULL); - if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) { - stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - - /* Should be either top_expander or stop_expander: */ - var = scheme_lookup_binding(stx, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_DONT_MARK_USE - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0), - env->in_modidx, - &menv, NULL, NULL, NULL); - } - } - if (var && (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type))) { if (SAME_OBJ(var, stop_expander)) { @@ -4813,10 +4885,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, f = (Scheme_Syntax *)SCHEME_SYNTAX(var); if (can_recycle_stx && !quick_stx) { quick_stx = can_recycle_stx; - ((Scheme_Stx *)quick_stx)->val = NULL; - ((Scheme_Stx *)quick_stx)->wraps = NULL; - ((Scheme_Stx *)quick_stx)->u.modinfo_cache = NULL; - ((Scheme_Stx *)quick_stx)->taints = NULL; + scheme_stx_set(quick_stx, NULL, NULL); } return f(form, env, rec, drec); } else { @@ -4865,16 +4934,22 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, scheme_wrong_syntax(scheme_compile_stx_string, orig_unbound_name, form, "unbound identifier%s;\n" - " also, no %S syntax transformer is bound", + " also, no %S syntax transformer is bound%s", phase, - SCHEME_STX_VAL(stx)); + SCHEME_STX_VAL(stx), + scheme_stx_describe_context(orig_unbound_name, + scheme_env_phase(env->genv), + 0)); } else { scheme_wrong_syntax(scheme_compile_stx_string, NULL, form, "%s is not allowed;\n" " no %S syntax transformer is bound%s", not_allowed, SCHEME_STX_VAL(stx), - phase); + phase, + scheme_stx_describe_context(orig_unbound_name, + scheme_env_phase(env->genv), + 0)); } return NULL; } @@ -4886,7 +4961,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, } SCHEME_EXPAND_OBSERVE_ENTER_MACRO(rec[drec].observer, form); - form = compile_expand_macro_app(name, menv, var, form, env, rec, drec); + form = compile_expand_macro_app(name, menv, var, form, env, rec, drec, need_macro_scope); SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form); if (rec[drec].comp) @@ -4972,7 +5047,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, return compile_application(form, env, rec, drec); else { rec[drec].value_name = scheme_false; - naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec); + naya = expand_list(form, scheme_no_defines(env), rec, drec); /* naya will be prefixed and returned... */ } } else if (rec[drec].comp) { @@ -4980,7 +5055,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, name = SCHEME_STX_CAR(form); origname = name; - name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL, 0); + name = scheme_check_immediate_macro(name, env, rec, drec, &gval, 0); /* look for ((lambda (x ...) ....) ....) or ((lambda x ....) ....) */ if (SAME_OBJ(gval, scheme_lambda_syntax)) { @@ -5057,7 +5132,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, body = scheme_syntax_taint_rearm(body, orig_form); - return scheme_compile_expand_expr(body, env, rec, drec, 0); + return compile_expand_expr(body, env, rec, drec, 0); } else { #if 0 scheme_wrong_syntax(scheme_application_stx_string, NULL, form, @@ -5089,16 +5164,16 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, scheme_false, scheme_sys_wraps(env), 0, 0); } - if (scheme_stx_module_eq(name, cwv_stx, 0)) { + if (scheme_stx_free_eq(name, cwv_stx, 0)) { Scheme_Object *first, *orig_first; orig_first = SCHEME_STX_CAR(at_first); - first = scheme_check_immediate_macro(orig_first, env, rec, drec, 0, &gval, NULL, NULL, 0); + first = scheme_check_immediate_macro(orig_first, env, rec, drec, &gval, 0); if (SAME_OBJ(gval, scheme_lambda_syntax) && SCHEME_STX_PAIRP(first) && (arg_count(first, env) == 0)) { Scheme_Object *second, *orig_second; orig_second = SCHEME_STX_CAR(at_second); - second = scheme_check_immediate_macro(orig_second, env, rec, drec, 0, &gval, NULL, NULL, 0); + second = scheme_check_immediate_macro(orig_second, env, rec, drec, &gval, 0); if (SAME_OBJ(gval, scheme_lambda_syntax) && SCHEME_STX_PAIRP(second) && (arg_count(second, env) >= 0)) { @@ -5122,7 +5197,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, scheme_null), icons(second, scheme_null))); form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2); - return scheme_compile_expand_expr(form, env, rec, drec, 0); + return compile_expand_expr(form, env, rec, drec, 0); } if (!SAME_OBJ(second, orig_second)) { at_second = scheme_datum_to_syntax(icons(second, the_end), at_second, at_second, 0, 2); @@ -5149,7 +5224,7 @@ compile_expand_app(Scheme_Object *orig_form, Scheme_Comp_Env *env, return compile_application(form, env, rec, drec); } else { rec[drec].value_name = scheme_false; - naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec); + naya = expand_list(form, scheme_no_defines(env), rec, drec); /* naya will be prefixed returned... */ } @@ -5227,20 +5302,16 @@ datum_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info int scheme_check_top_identifier_bound(Scheme_Object *c, Scheme_Env *genv, int disallow_unbound) { - Scheme_Object *symbol = c; - Scheme_Object *modidx, *tl_id; + Scheme_Object *symbol, *binding; + Scheme_Object *modidx; int bad; - tl_id = scheme_tl_id_sym(genv, symbol, NULL, 0, NULL, NULL); - if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { - /* Since the module has a rename for this id, count it as - defined. This covers the unusual case that a marked identifier - is bound in a module, but the identifier doesn't have the - module's post_ex_rename_set in its lexical information. */ - bad = 0; - } else { - modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(genv->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL, NULL, NULL); + binding = scheme_stx_lookup(c, scheme_make_integer(genv->phase)); + + if (SCHEME_VECTORP(binding)) { + modidx = SCHEME_VEC_ELS(binding)[0]; + if (SCHEME_FALSEP(modidx)) modidx = NULL; + symbol = SCHEME_VEC_ELS(binding)[1]; if (modidx) { /* If it's an access path, resolve it: */ if (genv->module @@ -5250,27 +5321,38 @@ int scheme_check_top_identifier_bound(Scheme_Object *c, Scheme_Env *genv, int di bad = 1; } else bad = 1; + } else + bad = 1; - if (disallow_unbound) { - if (bad || !scheme_lookup_in_table(genv->toplevel, (const char *)SCHEME_STX_SYM(c))) { - GC_CAN_IGNORE const char *reason; - if (genv->phase == 1) { - reason = "unbound identifier in module (in phase 1, transformer environment)"; - /* Check in the run-time environment */ - if (scheme_lookup_in_table(genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) { - reason = ("unbound identifier in module (in the transformer environment, which does" - " not include the run-time definition)"); - } else if (genv->template_env->syntax - && scheme_lookup_in_table(genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) { - reason = ("unbound identifier in module (in the transformer environment, which does" - " not include the macro definition that is visible to run-time expressions)"); - } - } else if (genv->phase == 0) - reason = "unbound identifier in module"; - else - reason = "unbound identifier in module (in phase %d)"; - scheme_unbound_syntax(scheme_expand_stx_string, NULL, c, reason, genv->phase); + if (disallow_unbound) { + if (bad || !scheme_lookup_in_table(genv->toplevel, (const char *)symbol)) { + GC_CAN_IGNORE const char *reason; + int need_phase = 0; + + if (genv->phase == 1) { + reason = "unbound identifier in module (in phase 1, transformer environment)%s"; + /* Check in the run-time environment */ + if (scheme_lookup_in_table(genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) { + reason = ("unbound identifier in module (in the transformer environment, which does" + " not include the run-time definition)%s"); + } else if (genv->template_env->syntax + && scheme_lookup_in_table(genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) { + reason = ("unbound identifier in module (in the transformer environment, which does" + " not include the macro definition that is visible to run-time expressions)%s"); + } + } else if (genv->phase == 0) + reason = "unbound identifier in module%s"; + else { + reason = "unbound identifier in module (in phase %d)%s"; + need_phase = 1; } + + if (need_phase) + scheme_unbound_syntax(scheme_expand_stx_string, NULL, c, reason, genv->phase, + scheme_stx_describe_context(c, scheme_env_phase(genv), 0)); + else + scheme_unbound_syntax(scheme_expand_stx_string, NULL, c, reason, + scheme_stx_describe_context(c, scheme_env_phase(genv), 0)); } } @@ -5307,7 +5389,7 @@ static Scheme_Object *check_top(Scheme_Object *orig_form, static Scheme_Object * top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { - Scheme_Object *c; + Scheme_Object *c, *b; int need_bound_check = 0; c = check_top(form, env, rec, drec, &need_bound_check); @@ -5315,7 +5397,11 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, if (need_bound_check) scheme_register_unbound_toplevel(env, c); - c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL, NULL); + b = scheme_stx_lookup(c, scheme_make_integer(env->genv->phase)); + if (SCHEME_VECTORP(b)) + c = SCHEME_VEC_ELS(b)[1]; + else + c = scheme_future_global_binding(c, env->genv); if (env->genv->module && !rec[drec].resolve_module_ids) { /* Self-reference in a module; need to remember the modidx. Don't @@ -5350,13 +5436,13 @@ top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { - return scheme_compile_expand_expr(form, env, rec, drec, 0); + return compile_expand_expr(form, env, rec, drec, 0); } Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) { - return scheme_compile_expand_expr(form, env, erec, drec, 0); + return compile_expand_expr(form, env, erec, drec, 0); } Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env) @@ -5365,8 +5451,11 @@ Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Sche Scheme_Object *ids, *id; int pos; + /* We don't add a scope for this frame, because the lifted identifier + already has a scope. */ + pos = scheme_list_length(*_ids); - naya = scheme_new_compilation_frame(pos, SCHEME_CAPTURE_LIFTED, (*ip)->next); + naya = scheme_new_compilation_frame(pos, SCHEME_CAPTURE_LIFTED, NULL, (*ip)->next); (*ip)->next = naya; *ip = naya; @@ -5472,7 +5561,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, } #endif - inserted = scheme_new_compilation_frame(0, 0, env); + inserted = scheme_new_compilation_frame(0, 0, NULL, env); ip = MALLOC_N(Scheme_Comp_Env *, 1); *ip = inserted; @@ -5560,9 +5649,8 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, It is espcailly ugly because we have to expand macros before deciding what we have. */ { - Scheme_Object *first, *rib, *ctx, *ectx, *orig = forms, *pre_exprs = scheme_null; - void **d; - Scheme_Comp_Env *xenv = NULL; + Scheme_Object *first, *orig = forms, *pre_exprs = scheme_null, *old; + Scheme_Object *rib, *ectx, *frame_scopes; Scheme_Compile_Info recs[2]; DupCheckRecord r; @@ -5584,17 +5672,25 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, } } - rib = scheme_make_rename_rib(); - ctx = scheme_alloc_object(); - ctx->type = scheme_intdef_context_type; - d = MALLOC_N(void*, 3); - d[0] = env; - SCHEME_PTR1_VAL(ctx) = d; - SCHEME_PTR2_VAL(ctx) = rib; + rib = scheme_new_scope(SCHEME_STX_INTDEF_SCOPE); ectx = scheme_make_pair(scheme_make_struct_instance(scheme_liberal_def_ctx_type, 0, NULL), scheme_null); + scheme_begin_dup_symbol_check(&r, env); + frame_scopes = scheme_make_frame_scopes(rib); + + env = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, + frame_scopes, + env); + env->intdef_name = ectx; + + forms = scheme_datum_to_syntax(forms, scheme_false, scheme_false, 0, 0); + + old = forms; + forms = scheme_stx_add_scope(forms, rib, scheme_env_phase(env->genv)); + SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer, forms, old); + try_again: SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); @@ -5606,16 +5702,6 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, first = SCHEME_STX_CAR(forms); - { - /* Need to send both parts (before & after) of block rename */ - Scheme_Object *old_first; - - old_first = first; - first = scheme_add_rename_rib(first, rib); - - SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first); - } - { Scheme_Object *gval, *result; int more = 1, is_last; @@ -5623,10 +5709,16 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(forms)); result = forms; + old = first; /* Check for macro expansion, which could mask the real define-values, define-syntax, etc.: */ - first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx, is_last); + first = scheme_check_immediate_macro(first, env, rec, drec, &gval, is_last); + + if (!SAME_OBJ(first, old)) { + old = first; + first = scheme_stx_add_scope(first, rib, scheme_env_phase(env->genv)); + } if (SAME_OBJ(gval, scheme_begin_syntax)) { /* Inline content */ @@ -5681,22 +5773,18 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, int cnt; if (!SCHEME_NULLP(pre_exprs)) { - Scheme_Object *begin_stx, *values_app_stx, *exp_mark; + Scheme_Object *begin_stx, *values_app_stx; pre_exprs = scheme_reverse(pre_exprs); - exp_mark = scheme_new_mark(); - begin_stx = scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - begin_stx = scheme_add_remove_mark(begin_stx, exp_mark); values_app_stx = scheme_datum_to_syntax(scheme_make_pair(values_symbol, scheme_null), scheme_false, scheme_sys_wraps(env), 0, 0); - values_app_stx = scheme_add_remove_mark(values_app_stx, exp_mark); while (SCHEME_PAIRP(pre_exprs)) { v = scheme_make_pair(scheme_null, @@ -5782,7 +5870,8 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Object *names, *expr, *l, *a; int pos; - new_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, env); + new_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, NULL, env); + new_env->intdef_name = ectx; names = SCHEME_STX_CAR(v); expr = SCHEME_STX_CDR(v); @@ -5800,21 +5889,21 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, "extra data after expression"); } expr = SCHEME_STX_CAR(expr); + if (!is_val) + expr = scheme_revert_use_site_scopes(expr, env); scheme_add_local_syntax(cnt, new_env); + names = scheme_revert_use_site_scopes(names, env); + /* Initialize environment slots to #f, which means "not syntax". */ cnt = 0; for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { a = SCHEME_STX_CAR(l); - scheme_set_local_syntax(cnt++, a, scheme_false, new_env); + scheme_set_local_syntax(cnt++, a, scheme_false, new_env, 0); } - /* Extend shared rib with renamings */ - scheme_add_env_renames(rib, new_env, env); - - /* Check for duplicates after extending the rib with renamings, - since the renamings properly track marks. */ + /* Check for duplicates: */ for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { a = SCHEME_STX_CAR(l); scheme_dup_symbol_check(&r, "internal definition", a, "binding", first); @@ -5826,33 +5915,25 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, scheme_prepare_exp_env(new_env->genv); scheme_prepare_compile_env(new_env->genv->exp_env); pos = 0; - expr = scheme_add_rename_rib(expr, rib); scheme_bind_syntaxes("local syntax definition", names, expr, new_env->genv->exp_env, new_env->insp, rec, drec, new_env, new_env, - &pos, rib); + &pos, rib, 1); } /* Remember extended environment */ - ((void **)SCHEME_PTR1_VAL(ctx))[0] = new_env; - env = new_env; - xenv = NULL; + env = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, frame_scopes, new_env); + env->intdef_name = ectx; } define_try_again: if (!SCHEME_STX_NULLP(result)) { first = SCHEME_STX_CAR(result); first = scheme_datum_to_syntax(first, forms, forms, 0, 0); - { - Scheme_Object *old_first; - old_first = first; - first = scheme_add_rename_rib(first, rib); - SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); - SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first); - } + SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(result)); - first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx, is_last); + first = scheme_check_immediate_macro(first, env, rec, drec, &gval, is_last); more = 1; if (NOT_SAME_OBJ(gval, scheme_define_values_syntax) && NOT_SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { @@ -5901,7 +5982,6 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result)); } result = scheme_datum_to_syntax(result, forms, scheme_sys_wraps(env), 0, 2); - result = scheme_add_rename_rib(result, rib); more = 0; } else { @@ -5926,11 +6006,10 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, if (!more) { /* We've converted to a letrec or letrec-values+syntaxes */ - scheme_stx_seal_rib(rib); rec[drec].env_already = (mixed ? 2 : 1); if (rec[drec].comp) { - result = scheme_compile_expr(result, env, rec, drec); + result = scheme_compile_expr(result, scheme_no_defines(env), rec, drec); return scheme_make_pair(result, scheme_null); } else { if (!mixed && ((rec[drec].depth == -2) || (rec[drec].depth > 0))) { @@ -5942,7 +6021,7 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, if (rec[drec].depth) { SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, scheme_make_pair(result, scheme_null)); - result = scheme_expand_expr(result, env, rec, drec); + result = scheme_expand_expr(result, scheme_no_defines(env), rec, drec); } result = scheme_make_pair(result, scheme_null); return scheme_datum_to_syntax(result, forms, forms, 0, 0); @@ -5950,11 +6029,11 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, } } - scheme_stx_seal_rib(rib); - if (SCHEME_PAIRP(pre_exprs)) pre_exprs = scheme_reverse(pre_exprs); + env = scheme_no_defines(env); + if (rec[drec].comp) { Scheme_Object *vname, *rest; @@ -5978,7 +6057,7 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, first = scheme_compile_expr(first, env, recs, 0); - forms = scheme_compile_list(rest, env, recs, 1); + forms = compile_list(rest, env, recs, 1); scheme_merge_compile_recs(rec, drec, recs, 2); return scheme_make_pair(first, forms); @@ -5999,12 +6078,12 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, } forms = scheme_datum_to_syntax(newforms, orig, orig, 0, -1); - + if (scheme_stx_proper_list_length(forms) < 0) scheme_wrong_syntax(scheme_begin_stx_string, NULL, beginify(env, forms), "bad syntax"); - + SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms); - forms = scheme_expand_list(forms, env, recs, 0); + forms = expand_list(forms, env, recs, 0); return forms; } } @@ -6035,8 +6114,8 @@ expand_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expan return compile_expand_block(forms, env, erec, drec, 0); } -Scheme_Object * -scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +static Scheme_Object *expand_list(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Expand_Info *erec, int drec) { Scheme_Object *first = NULL, *last = NULL, *fm; @@ -6131,7 +6210,7 @@ void scheme_add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env { Scheme_Object *stx; stx = scheme_datum_to_syntax(sym, scheme_false, scheme_sys_wraps(env), 0, 0); - scheme_set_local_syntax(pos, stx, stop_expander, env); + scheme_set_local_syntax(pos, stx, stop_expander, env, 0); } /**********************************************************************/ diff --git a/racket/src/racket/src/cstartup.inc b/racket/src/racket/src/cstartup.inc index 63b0d4fb81..4aaf8315a1 100644 --- a/racket/src/racket/src/cstartup.inc +++ b/racket/src/racket/src/cstartup.inc @@ -1,1566 +1,1576 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,50,46,48,46,50,84,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, -18,0,22,0,29,0,36,0,41,0,54,0,59,0,64,0,67,0,74,0,83, -0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, -163,0,170,0,192,0,194,0,208,0,19,1,48,1,59,1,70,1,96,1,129, -1,162,1,224,1,24,2,105,2,161,2,166,2,187,2,84,3,105,3,158,3, -227,3,117,4,7,5,61,5,72,5,155,5,0,0,120,7,0,0,69,35,37, -109,105,110,45,115,116,120,29,11,11,11,63,108,101,116,63,97,110,100,66,108, -101,116,114,101,99,66,100,101,102,105,110,101,64,99,111,110,100,72,112,97,114, -97,109,101,116,101,114,105,122,101,64,119,104,101,110,64,108,101,116,42,62,111, -114,66,117,110,108,101,115,115,68,104,101,114,101,45,115,116,120,29,11,11,11, -65,113,117,111,116,101,29,94,2,15,68,35,37,107,101,114,110,101,108,11,29, -94,2,15,68,35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105, -110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73, -108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,1, -20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121, -61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240, -94,89,0,0,95,144,2,17,36,36,144,2,16,36,36,144,2,16,36,36,16, -20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2, -2,8,2,2,2,9,2,2,2,10,2,2,2,11,2,2,2,12,2,2,97, -37,11,8,240,94,89,0,0,93,144,2,16,36,37,16,2,2,13,146,2,2, -37,2,13,2,2,2,13,96,38,11,8,240,94,89,0,0,16,0,96,11,11, -8,240,94,89,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14, -2,2,11,11,11,8,32,8,31,8,30,8,29,27,248,22,166,4,195,249,22, -159,4,80,143,39,36,251,22,92,2,18,248,22,104,199,12,249,22,82,2,19, -248,22,106,201,27,248,22,166,4,195,249,22,159,4,80,143,39,36,251,22,92, -2,18,248,22,104,199,249,22,82,2,19,248,22,106,201,12,27,248,22,84,248, -22,166,4,196,28,248,22,90,193,20,14,144,37,36,37,28,248,22,90,248,22, -84,194,248,22,160,20,193,249,22,159,4,80,143,39,36,251,22,92,2,18,248, -22,160,20,199,249,22,82,2,4,248,22,161,20,201,11,18,100,10,13,16,6, -36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2, -20,3,1,8,101,110,118,49,56,48,49,51,16,4,11,11,2,21,3,1,8, -101,110,118,49,56,48,49,52,27,248,22,84,248,22,166,4,196,28,248,22,90, -193,20,14,144,37,36,37,28,248,22,90,248,22,84,194,248,22,160,20,193,249, -22,159,4,80,143,39,36,250,22,92,2,22,248,22,92,249,22,92,248,22,92, -2,23,248,22,160,20,201,251,22,92,2,18,2,23,2,23,249,22,82,2,11, -248,22,161,20,204,18,100,11,13,16,6,36,2,14,2,2,11,11,11,8,32, -8,31,8,30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,56,48, -49,54,16,4,11,11,2,21,3,1,8,101,110,118,49,56,48,49,55,248,22, -166,4,193,27,248,22,166,4,194,249,22,82,248,22,92,248,22,83,196,248,22, -161,20,195,27,248,22,84,248,22,166,4,23,197,1,249,22,159,4,80,143,39, -36,28,248,22,66,248,22,160,4,248,22,83,23,198,2,27,249,22,2,32,0, -88,148,8,36,37,43,11,9,222,33,40,248,22,166,4,248,22,104,23,200,2, -250,22,92,2,24,248,22,92,249,22,92,248,22,92,248,22,160,20,23,204,2, -250,22,93,2,25,249,22,2,22,83,23,204,2,248,22,106,23,206,2,249,22, -82,248,22,160,20,23,202,1,249,22,2,22,104,23,200,1,250,22,93,2,22, -249,22,2,32,0,88,148,8,36,37,47,11,9,222,33,41,248,22,166,4,248, -22,160,20,201,248,22,161,20,198,27,248,22,166,4,194,249,22,82,248,22,92, -248,22,83,196,248,22,161,20,195,27,248,22,84,248,22,166,4,23,197,1,249, -22,159,4,80,143,39,36,250,22,93,2,24,249,22,2,32,0,88,148,8,36, -37,47,11,9,222,33,43,248,22,166,4,248,22,83,201,248,22,161,20,198,27, -248,22,84,248,22,166,4,196,27,248,22,166,4,248,22,83,195,249,22,159,4, -80,143,40,36,28,248,22,90,195,250,22,93,2,22,9,248,22,161,20,199,250, -22,92,2,3,248,22,92,248,22,83,199,250,22,93,2,10,248,22,161,20,201, -248,22,161,20,202,27,248,22,84,248,22,166,4,23,197,1,27,249,22,1,22, -96,249,22,2,22,166,4,248,22,166,4,248,22,83,199,248,22,187,4,249,22, -159,4,80,143,41,36,251,22,92,1,22,119,105,116,104,45,99,111,110,116,105, -110,117,97,116,105,111,110,45,109,97,114,107,2,26,250,22,93,1,23,101,120, -116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, -21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107, -45,115,101,116,45,102,105,114,115,116,11,2,26,202,250,22,93,2,22,9,248, -22,161,20,204,27,248,22,84,248,22,166,4,196,28,248,22,90,193,20,14,144, -37,36,37,249,22,159,4,80,143,39,36,27,248,22,166,4,248,22,83,197,28, -249,22,170,9,62,61,62,248,22,160,4,248,22,104,196,250,22,92,2,22,248, -22,92,249,22,92,21,93,2,27,248,22,83,199,250,22,93,2,7,249,22,92, -2,27,249,22,92,248,22,113,203,2,27,248,22,161,20,202,251,22,92,2,18, -28,249,22,170,9,248,22,160,4,248,22,83,200,64,101,108,115,101,10,248,22, -160,20,197,250,22,93,2,22,9,248,22,161,20,200,249,22,82,2,7,248,22, -161,20,202,99,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30, -8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,56,48,51,57,16,4, -11,11,2,21,3,1,8,101,110,118,49,56,48,52,48,18,143,94,10,64,118, -111,105,100,8,48,27,248,22,84,248,22,166,4,196,249,22,159,4,80,143,39, -36,28,248,22,66,248,22,160,4,248,22,83,197,250,22,92,2,28,248,22,92, -248,22,160,20,199,248,22,104,198,27,248,22,160,4,248,22,160,20,197,250,22, -92,2,28,248,22,92,248,22,83,197,250,22,93,2,25,248,22,161,20,199,248, -22,161,20,202,144,36,20,114,144,36,16,1,11,16,0,20,26,15,58,9,2, -1,2,1,2,2,11,9,9,11,11,11,10,36,80,143,36,36,20,114,144,36, -16,0,16,0,38,39,36,16,0,36,16,0,36,11,11,11,16,10,2,3,2, -4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11, -11,11,11,11,11,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2, -8,2,9,2,10,2,11,2,12,36,46,37,16,0,36,16,1,2,13,37,11, -11,11,16,0,16,0,16,0,36,36,11,12,11,11,16,0,16,0,16,0,36, -36,16,11,16,5,11,20,15,16,2,20,14,144,36,36,37,80,143,36,36,36, -20,114,144,36,16,1,2,13,16,1,33,33,10,16,5,2,12,88,148,8,36, -37,53,37,9,223,0,33,34,36,20,114,144,36,16,1,2,13,16,0,11,16, -5,2,9,88,148,8,36,37,53,37,9,223,0,33,35,36,20,114,144,36,16, -1,2,13,16,0,11,16,5,2,4,88,148,8,36,37,53,39,9,223,0,33, -36,36,20,114,144,36,16,1,2,13,16,1,33,37,11,16,5,2,11,88,148, -8,36,37,56,39,9,223,0,33,38,36,20,114,144,36,16,1,2,13,16,1, -33,39,11,16,5,2,3,88,148,8,36,37,58,37,9,223,0,33,42,36,20, -114,144,36,16,1,2,13,16,0,11,16,5,2,5,88,148,8,36,37,53,37, -9,223,0,33,44,36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,10, -88,148,8,36,37,54,37,9,223,0,33,45,36,20,114,144,36,16,1,2,13, -16,0,11,16,5,2,8,88,148,8,36,37,56,37,9,223,0,33,46,36,20, -114,144,36,16,1,2,13,16,0,11,16,5,2,7,88,148,8,36,37,58,39, -9,223,0,33,47,36,20,114,144,36,16,1,2,13,16,1,33,49,11,16,5, -2,6,88,148,8,36,37,54,37,9,223,0,33,50,36,20,114,144,36,16,1, -2,13,16,0,11,16,0,94,2,16,2,17,93,2,16,9,9,36,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2056); + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,9,54,46,50,46,57,48,48,46,52,84,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8,0, +18,0,22,0,29,0,36,0,41,0,46,0,51,0,63,0,66,0,73,0,86, +0,90,0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159,0, +173,0,180,0,202,0,204,0,218,0,246,0,251,0,254,0,35,1,42,1,114, +1,121,1,132,1,141,1,174,1,207,1,13,2,18,2,99,2,104,2,109,2, +130,2,27,3,48,3,101,3,170,3,239,3,129,4,21,5,32,5,115,5,0, +0,144,7,0,0,3,1,5,105,110,115,112,48,71,35,37,109,105,110,45,115, +116,120,29,11,11,11,68,108,101,116,114,101,99,68,100,101,102,105,110,101,66, +99,111,110,100,66,119,104,101,110,66,108,101,116,42,73,108,101,116,42,45,118, +97,108,117,101,115,64,111,114,68,117,110,108,101,115,115,74,112,97,114,97,109, +101,116,101,114,105,122,101,65,108,101,116,65,97,110,100,70,104,101,114,101,45, +115,116,120,67,113,117,111,116,101,29,94,2,16,70,35,37,107,101,114,110,101, +108,11,29,94,2,16,70,35,37,112,97,114,97,109,122,11,64,105,102,67,98, +101,103,105,110,72,108,101,116,45,118,97,108,117,101,115,63,120,75,108,101,116, +114,101,99,45,118,97,108,117,101,115,68,108,97,109,98,100,97,1,20,112,97, +114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,63,118,75, +100,101,102,105,110,101,45,118,97,108,117,101,115,38,28,16,3,93,16,2,29, +11,11,11,2,3,2,29,93,143,16,5,40,2,31,39,2,33,2,2,39,38, +29,93,2,30,36,30,39,36,31,144,40,143,2,32,16,4,2,17,40,39,2, +1,16,2,2,15,93,143,2,32,147,2,1,2,3,40,2,15,143,2,3,40, +2,15,38,32,143,2,31,2,29,36,33,145,40,143,2,34,16,4,2,17,39, +39,2,1,143,2,34,16,4,2,18,39,39,2,1,16,22,2,14,2,35,2, +12,2,35,2,5,2,35,2,10,2,35,2,6,2,35,2,13,2,35,2,11, +2,35,2,8,2,35,2,9,2,35,2,7,2,35,2,4,2,35,38,34,143, +2,33,2,29,38,35,93,143,2,34,143,2,1,2,3,18,143,66,104,101,114, +101,2,28,27,248,22,166,4,195,249,22,159,4,80,143,42,39,251,22,92,2, +19,248,22,104,199,12,249,22,82,2,20,248,22,106,201,27,248,22,166,4,195, +249,22,159,4,80,143,42,39,251,22,92,2,19,248,22,104,199,249,22,82,2, +20,248,22,106,201,12,27,248,22,84,248,22,166,4,196,28,248,22,90,193,20, +14,144,40,39,40,28,248,22,90,248,22,84,194,248,22,163,20,193,249,22,159, +4,80,143,42,39,251,22,92,2,19,248,22,163,20,199,249,22,82,2,14,248, +22,164,20,201,11,18,143,10,2,28,27,248,22,84,248,22,166,4,196,28,248, +22,90,193,20,14,144,40,39,40,28,248,22,90,248,22,84,194,248,22,163,20, +193,249,22,159,4,80,143,42,39,250,22,92,2,21,248,22,92,249,22,92,248, +22,92,2,22,248,22,163,20,201,251,22,92,2,19,2,22,2,22,249,22,82, +2,10,248,22,164,20,204,18,143,11,2,28,248,22,166,4,193,27,248,22,166, +4,194,249,22,82,248,22,92,248,22,83,196,248,22,164,20,195,27,248,22,84, +248,22,166,4,23,197,1,249,22,159,4,80,143,42,39,28,248,22,66,248,22, +160,4,248,22,83,23,198,2,27,249,22,2,32,0,88,148,8,36,40,46,11, +9,222,33,43,248,22,166,4,248,22,104,23,200,2,250,22,92,2,23,248,22, +92,249,22,92,248,22,92,248,22,163,20,23,204,2,250,22,93,2,24,249,22, +2,22,83,23,204,2,248,22,106,23,206,2,249,22,82,248,22,163,20,23,202, +1,249,22,2,22,104,23,200,1,250,22,93,2,21,249,22,2,32,0,88,148, +8,36,40,50,11,9,222,33,44,248,22,166,4,248,22,163,20,201,248,22,164, +20,198,27,248,22,166,4,194,249,22,82,248,22,92,248,22,83,196,248,22,164, +20,195,27,248,22,84,248,22,166,4,23,197,1,249,22,159,4,80,143,42,39, +250,22,93,2,23,249,22,2,32,0,88,148,8,36,40,50,11,9,222,33,46, +248,22,166,4,248,22,83,201,248,22,164,20,198,27,248,22,84,248,22,166,4, +196,27,248,22,166,4,248,22,83,195,249,22,159,4,80,143,43,39,28,248,22, +90,195,250,22,93,2,21,9,248,22,164,20,199,250,22,92,2,13,248,22,92, +248,22,83,199,250,22,93,2,8,248,22,164,20,201,248,22,164,20,202,27,248, +22,84,248,22,166,4,196,27,248,22,166,4,248,22,83,195,249,22,159,4,80, +143,43,39,28,248,22,90,195,250,22,93,2,21,9,248,22,164,20,199,250,22, +92,2,21,248,22,92,248,22,83,199,250,22,93,2,9,248,22,164,20,201,248, +22,164,20,202,27,248,22,84,248,22,166,4,23,197,1,27,249,22,1,22,96, +249,22,2,22,166,4,248,22,166,4,248,22,83,199,248,22,187,4,249,22,159, +4,80,143,44,39,251,22,92,1,22,119,105,116,104,45,99,111,110,116,105,110, +117,97,116,105,111,110,45,109,97,114,107,2,25,250,22,93,1,23,101,120,116, +101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,21, +95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45, +115,101,116,45,102,105,114,115,116,11,2,25,202,250,22,93,2,21,9,248,22, +164,20,204,27,248,22,84,248,22,166,4,196,28,248,22,90,193,20,14,144,40, +39,40,249,22,159,4,80,143,42,39,27,248,22,166,4,248,22,83,197,28,249, +22,171,9,64,61,62,248,22,160,4,248,22,104,196,250,22,92,2,21,248,22, +92,249,22,92,21,93,2,26,248,22,163,20,199,250,22,93,2,6,249,22,92, +2,26,249,22,92,248,22,113,203,2,26,248,22,164,20,202,251,22,92,2,19, +28,249,22,171,9,248,22,160,4,248,22,163,20,200,66,101,108,115,101,10,248, +22,163,20,197,250,22,93,2,21,9,248,22,164,20,200,249,22,82,2,6,248, +22,164,20,202,18,143,94,10,66,118,111,105,100,2,28,27,248,22,84,248,22, +166,4,196,249,22,159,4,80,143,42,39,28,248,22,66,248,22,160,4,248,22, +83,197,250,22,92,2,27,248,22,92,248,22,163,20,199,248,22,104,198,27,248, +22,160,4,248,22,163,20,197,250,22,92,2,27,248,22,92,248,22,83,197,250, +22,93,2,24,248,22,164,20,199,248,22,164,20,202,144,39,20,120,145,2,1, +39,16,1,11,16,0,20,26,15,61,9,2,2,2,2,2,3,11,11,11,11, +9,9,11,11,11,10,39,80,143,39,39,20,120,145,2,1,39,16,0,16,0, +41,42,39,16,0,39,16,0,39,11,11,11,16,11,2,4,2,5,2,6,2, +7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,16,11,11,11,11,11, +11,11,11,11,11,11,11,16,11,2,4,2,5,2,6,2,7,2,8,2,9, +2,10,2,11,2,12,2,13,2,14,39,50,40,16,0,39,16,1,2,15,40, +11,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0, +39,39,16,12,16,5,11,20,15,16,2,20,14,144,39,39,40,80,143,39,39, +39,20,120,145,2,1,39,16,1,2,15,16,1,33,36,10,16,5,2,11,88, +148,8,36,40,56,40,9,223,0,33,37,39,20,120,145,2,1,39,16,1,2, +15,16,0,11,16,5,2,7,88,148,8,36,40,56,40,9,223,0,33,38,39, +20,120,145,2,1,39,16,1,2,15,16,0,11,16,5,2,14,88,148,8,36, +40,56,42,9,223,0,33,39,39,20,120,145,2,1,39,16,1,2,15,16,1, +33,40,11,16,5,2,10,88,148,8,36,40,59,42,9,223,0,33,41,39,20, +120,145,2,1,39,16,1,2,15,16,1,33,42,11,16,5,2,13,88,148,8, +36,40,61,40,9,223,0,33,45,39,20,120,145,2,1,39,16,1,2,15,16, +0,11,16,5,2,4,88,148,8,36,40,56,40,9,223,0,33,47,39,20,120, +145,2,1,39,16,1,2,15,16,0,11,16,5,2,8,88,148,8,36,40,57, +40,9,223,0,33,48,39,20,120,145,2,1,39,16,1,2,15,16,0,11,16, +5,2,9,88,148,8,36,40,57,40,9,223,0,33,49,39,20,120,145,2,1, +39,16,1,2,15,16,0,11,16,5,2,12,88,148,8,36,40,59,40,9,223, +0,33,50,39,20,120,145,2,1,39,16,1,2,15,16,0,11,16,5,2,6, +88,148,8,36,40,61,42,9,223,0,33,51,39,20,120,145,2,1,39,16,1, +2,15,16,1,33,52,11,16,5,2,5,88,148,8,36,40,57,40,9,223,0, +33,53,39,20,120,145,2,1,39,16,1,2,15,16,0,11,16,0,94,2,17, +2,18,93,2,17,9,9,39,9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 2088); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,50,46,48,46,50,84,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,193,0,0,0,1,0,0,8,0,21,0, -26,0,43,0,55,0,77,0,106,0,150,0,156,0,165,0,172,0,187,0,205, -0,217,0,233,0,247,0,13,1,32,1,39,1,73,1,90,1,107,1,130,1, -145,1,184,1,202,1,233,1,245,1,6,2,18,2,33,2,57,2,89,2,118, -2,134,2,152,2,171,2,191,2,209,2,240,2,254,2,15,3,59,3,67,3, -72,3,116,3,123,3,133,3,148,3,157,3,162,3,164,3,197,3,221,3,242, -3,255,3,9,4,18,4,29,4,47,4,60,4,70,4,80,4,86,4,91,4, -103,4,106,4,110,4,115,4,158,4,171,4,174,4,198,4,237,4,244,4,1, -5,23,5,34,5,64,5,87,5,95,5,119,5,140,5,84,6,114,6,195,9, -218,9,235,9,159,11,6,12,20,12,224,12,200,14,209,14,218,14,232,14,242, -14,3,16,106,16,219,16,36,17,109,17,213,17,242,17,57,18,195,18,10,19, -223,19,85,20,98,20,216,20,229,20,68,21,135,21,148,21,159,21,55,22,173, -22,217,22,72,23,150,25,174,25,36,26,116,27,123,27,175,27,189,27,179,28, -195,28,50,29,209,29,216,29,92,31,169,31,186,31,86,32,106,32,166,32,173, -32,33,33,87,33,106,33,56,34,72,34,32,35,21,36,58,36,67,36,144,37, -245,39,5,40,72,40,93,40,113,40,133,40,190,40,158,43,124,44,140,44,111, -45,169,45,202,45,78,46,237,46,253,46,94,47,111,47,189,49,240,51,0,52, -230,53,162,54,164,54,191,54,207,54,223,54,64,55,131,56,63,57,79,57,88, -57,95,57,161,58,227,59,89,60,135,63,8,64,139,64,83,66,33,67,75,67, -183,67,0,0,120,75,0,0,67,35,37,117,116,105,108,115,72,112,97,116,104, -45,115,116,114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,108,45, -99,97,115,101,45,112,97,116,104,71,114,101,114,111,111,116,45,112,97,116,104, -1,20,102,105,110,100,45,101,120,101,99,117,116,97,98,108,101,45,112,97,116, -104,1,27,112,97,116,104,45,108,105,115,116,45,115,116,114,105,110,103,45,62, -112,97,116,104,45,108,105,115,116,1,42,99,97,108,108,45,119,105,116,104,45, -100,101,102,97,117,108,116,45,114,101,97,100,105,110,103,45,112,97,114,97,109, -101,116,101,114,105,122,97,116,105,111,110,65,113,117,111,116,101,68,35,37,112, -97,114,97,109,122,29,94,2,9,2,10,11,74,45,99,104,101,99,107,45,114, -101,108,112,97,116,104,77,45,99,104,101,99,107,45,99,111,108,108,101,99,116, -105,111,110,71,45,99,104,101,99,107,45,102,97,105,108,75,99,111,108,108,101, -99,116,105,111,110,45,112,97,116,104,73,102,105,110,100,45,99,111,108,45,102, -105,108,101,1,20,99,111,108,108,101,99,116,105,111,110,45,102,105,108,101,45, -112,97,116,104,78,102,105,110,100,45,109,97,105,110,45,99,111,108,108,101,99, -116,115,29,94,2,9,2,10,11,1,32,101,120,101,45,114,101,108,97,116,105, -118,101,45,112,97,116,104,45,62,99,111,109,112,108,101,116,101,45,112,97,116, -104,76,102,105,110,100,45,109,97,105,110,45,99,111,110,102,105,103,76,103,101, -116,45,99,111,110,102,105,103,45,116,97,98,108,101,1,21,103,101,116,45,105, -110,115,116,97,108,108,97,116,105,111,110,45,110,97,109,101,74,99,111,101,114, -99,101,45,116,111,45,112,97,116,104,1,37,99,111,108,108,101,99,116,115,45, -114,101,108,97,116,105,118,101,45,112,97,116,104,45,62,99,111,109,112,108,101, -116,101,45,112,97,116,104,77,97,100,100,45,99,111,110,102,105,103,45,115,101, -97,114,99,104,1,29,102,105,110,100,45,108,105,98,114,97,114,121,45,99,111, -108,108,101,99,116,105,111,110,45,108,105,110,107,115,71,108,105,110,107,115,45, -99,97,99,104,101,76,115,116,97,109,112,45,112,114,111,109,112,116,45,116,97, -103,71,102,105,108,101,45,62,115,116,97,109,112,74,110,111,45,102,105,108,101, -45,115,116,97,109,112,63,1,22,103,101,116,45,108,105,110,107,101,100,45,99, -111,108,108,101,99,116,105,111,110,115,1,30,110,111,114,109,97,108,105,122,101, -45,99,111,108,108,101,99,116,105,111,110,45,114,101,102,101,114,101,110,99,101, -1,27,102,105,108,101,45,101,120,105,115,116,115,63,47,109,97,121,98,101,45, -99,111,109,112,105,108,101,100,75,112,97,116,104,45,97,100,100,45,115,117,102, -102,105,120,77,99,104,101,99,107,45,115,117,102,102,105,120,45,99,97,108,108, -78,112,97,116,104,45,97,100,106,117,115,116,45,115,117,102,102,105,120,79,112, -97,116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,77,108,111, -97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,1,29,102,105,110,100, -45,108,105,98,114,97,114,121,45,99,111,108,108,101,99,116,105,111,110,45,112, -97,116,104,115,73,101,109,98,101,100,100,101,100,45,108,111,97,100,76,110,111, -114,109,97,108,45,112,97,116,104,45,99,97,115,101,6,41,41,40,111,114,47, -99,32,112,97,116,104,45,102,111,114,45,115,111,109,101,45,115,121,115,116,101, -109,63,32,112,97,116,104,45,115,116,114,105,110,103,63,41,67,119,105,110,100, -111,119,115,6,2,2,92,49,6,41,41,40,111,114,47,99,32,112,97,116,104, -45,115,116,114,105,110,103,63,32,112,97,116,104,45,102,111,114,45,115,111,109, -101,45,115,121,115,116,101,109,63,41,6,4,4,112,97,116,104,5,8,92,92, -63,92,82,69,76,92,6,12,12,112,97,116,104,45,115,116,114,105,110,103,63, -68,114,101,108,97,116,105,118,101,64,108,111,111,112,5,0,6,30,30,40,112, -114,111,99,101,100,117,114,101,45,97,114,105,116,121,45,105,110,99,108,117,100, -101,115,47,99,32,48,41,6,21,21,105,110,118,97,108,105,100,32,114,101,108, -97,116,105,118,101,32,112,97,116,104,6,18,18,40,97,110,121,47,99,32,46, -32,45,62,32,46,32,97,110,121,41,72,99,111,108,108,101,99,116,115,45,100, -105,114,69,101,120,101,99,45,102,105,108,101,68,111,114,105,103,45,100,105,114, -70,99,111,110,102,105,103,45,100,105,114,77,105,110,115,116,97,108,108,97,116, -105,111,110,45,110,97,109,101,6,10,10,108,105,110,107,115,46,114,107,116,100, -69,97,100,100,111,110,45,100,105,114,69,102,115,45,99,104,97,110,103,101,65, -101,114,114,111,114,64,114,111,111,116,71,115,116,97,116,105,99,45,114,111,111, -116,6,0,0,6,1,1,47,5,3,46,122,111,6,40,40,114,101,109,111,118, -105,110,103,32,115,117,102,102,105,120,32,109,97,107,101,115,32,112,97,116,104, -32,101,108,101,109,101,110,116,32,101,109,112,116,121,6,10,10,103,105,118,101, -110,32,112,97,116,104,5,1,95,6,21,21,40,111,114,47,99,32,115,116,114, -105,110,103,63,32,98,121,116,101,115,63,41,6,36,36,99,97,110,110,111,116, -32,97,100,100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111, -111,116,32,112,97,116,104,58,32,66,102,105,110,105,115,104,5,11,80,76,84, -67,79,76,76,69,67,84,83,1,20,99,111,108,108,101,99,116,115,45,115,101, -97,114,99,104,45,100,105,114,115,6,8,8,99,111,108,108,101,99,116,115,27, -248,22,174,15,194,28,192,192,28,248,22,154,7,194,27,248,22,133,16,195,28, -192,192,248,22,134,16,195,11,0,21,35,114,120,34,94,91,92,92,93,91,92, -92,93,91,63,93,91,92,92,93,34,0,6,35,114,120,34,47,34,0,22,35, -114,120,34,91,47,92,92,93,91,46,32,93,43,91,47,92,92,93,42,36,34, -0,19,35,114,120,34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34, -86,94,28,28,248,22,175,15,23,195,2,10,28,248,22,174,15,23,195,2,10, -28,248,22,154,7,23,195,2,28,248,22,133,16,23,195,2,10,248,22,134,16, -23,195,2,11,12,250,22,181,11,2,42,2,43,23,197,2,28,28,248,22,175, -15,23,195,2,249,22,170,9,248,22,176,15,23,197,2,2,44,249,22,170,9, -247,22,181,8,2,44,27,28,248,22,154,7,23,196,2,23,195,2,248,22,166, -8,248,22,179,15,23,197,2,28,249,22,171,16,2,80,23,195,2,28,248,22, -154,7,195,248,22,182,15,195,194,27,248,22,129,8,23,195,1,249,22,183,15, -248,22,169,8,250,22,179,16,2,81,28,249,22,171,16,2,82,23,201,2,23, -199,1,250,22,179,16,2,83,23,202,1,2,45,80,144,44,37,38,2,44,28, -248,22,154,7,194,248,22,182,15,194,193,0,28,35,114,120,34,94,92,92,92, -92,92,92,92,92,91,63,93,92,92,92,92,85,78,67,92,92,92,92,34,86, -95,28,28,28,248,22,174,15,23,195,2,10,28,248,22,154,7,23,195,2,28, -248,22,133,16,23,195,2,10,248,22,134,16,23,195,2,11,10,248,22,175,15, -23,195,2,12,252,22,181,11,2,5,2,46,36,23,199,2,23,200,2,28,28, -28,248,22,174,15,23,196,2,10,28,248,22,154,7,23,196,2,28,248,22,133, -16,23,196,2,10,248,22,134,16,23,196,2,11,10,248,22,175,15,23,196,2, -12,252,22,181,11,2,5,2,46,37,23,199,2,23,200,2,27,28,248,22,175, -15,23,196,2,248,22,176,15,23,196,2,247,22,177,15,86,95,28,28,248,22, -135,16,23,196,2,10,249,22,170,9,247,22,177,15,23,195,2,12,253,22,183, -11,2,5,6,54,54,112,97,116,104,32,105,115,32,110,111,116,32,99,111,109, -112,108,101,116,101,32,97,110,100,32,110,111,116,32,116,104,101,32,112,108,97, -116,102,111,114,109,39,115,32,99,111,110,118,101,110,116,105,111,110,2,47,23, -201,2,6,24,24,112,108,97,116,102,111,114,109,32,99,111,110,118,101,110,116, -105,111,110,32,116,121,112,101,247,22,177,15,28,249,22,170,9,28,248,22,175, -15,23,199,2,248,22,176,15,23,199,2,247,22,177,15,23,195,2,12,253,22, -183,11,2,5,6,37,37,103,105,118,101,110,32,112,97,116,104,115,32,117,115, -101,32,100,105,102,102,101,114,101,110,116,32,99,111,110,118,101,110,116,105,111, -110,115,2,47,23,201,2,6,9,9,114,111,111,116,32,112,97,116,104,23,202, -2,27,27,248,22,139,16,28,248,22,135,16,23,199,2,23,198,1,248,22,136, -16,23,199,1,86,94,28,28,248,22,175,15,23,194,2,10,28,248,22,174,15, -23,194,2,10,28,248,22,154,7,23,194,2,28,248,22,133,16,23,194,2,10, -248,22,134,16,23,194,2,11,12,250,22,181,11,2,42,2,43,23,196,2,28, -28,248,22,175,15,23,194,2,249,22,170,9,248,22,176,15,23,196,2,2,44, -249,22,170,9,247,22,181,8,2,44,27,28,248,22,154,7,23,195,2,23,194, -2,248,22,166,8,248,22,179,15,23,196,2,28,249,22,171,16,2,80,23,195, -2,28,248,22,154,7,194,248,22,182,15,194,193,27,248,22,129,8,23,195,1, -249,22,183,15,248,22,169,8,250,22,179,16,2,81,28,249,22,171,16,2,82, -23,201,2,23,199,1,250,22,179,16,2,83,23,202,1,2,45,80,144,47,37, -38,2,44,28,248,22,154,7,193,248,22,182,15,193,192,27,248,22,179,15,23, -195,2,28,249,22,170,9,23,197,2,64,117,110,105,120,28,249,22,151,8,194, -5,1,47,28,248,22,175,15,198,197,248,22,182,15,198,249,22,128,16,199,249, -22,183,15,249,22,154,8,248,22,179,15,200,37,198,28,249,22,170,9,23,197, -2,2,44,249,22,128,16,23,200,1,249,22,183,15,28,249,22,171,16,0,27, -35,114,120,34,94,92,92,92,92,92,92,92,92,91,63,93,92,92,92,92,91, -97,45,122,93,58,34,23,199,2,251,22,155,8,2,48,250,22,154,8,203,40, -41,5,1,92,249,22,154,8,202,42,28,249,22,171,16,2,85,23,199,2,249, -22,155,8,2,48,249,22,154,8,200,40,28,249,22,171,16,2,85,23,199,2, -249,22,155,8,2,48,249,22,154,8,200,40,28,249,22,171,16,0,14,35,114, -120,34,94,92,92,92,92,92,92,92,92,34,23,199,2,249,22,155,8,5,4, -85,78,67,92,249,22,154,8,200,38,28,249,22,171,16,0,12,35,114,120,34, -94,91,97,45,122,93,58,34,198,249,22,155,8,250,22,154,8,201,36,37,249, -22,154,8,200,38,12,198,12,32,87,88,148,8,36,39,53,11,70,102,111,117, -110,100,45,101,120,101,99,222,33,90,32,88,88,148,8,36,40,58,11,64,110, -101,120,116,222,33,89,27,248,22,137,16,23,196,2,28,249,22,172,9,23,195, -2,23,197,1,11,28,248,22,133,16,23,194,2,27,249,22,128,16,23,197,1, -23,196,1,28,23,197,2,90,144,39,11,89,146,39,36,11,248,22,131,16,23, -197,2,86,95,23,195,1,23,194,1,27,28,23,202,2,27,248,22,137,16,23, -199,2,28,249,22,172,9,23,195,2,23,200,2,11,28,248,22,133,16,23,194, -2,250,2,87,23,205,2,23,206,2,249,22,128,16,23,200,2,23,198,1,250, -2,87,23,205,2,23,206,2,23,196,1,11,28,23,193,2,192,86,94,23,193, -1,27,28,248,22,174,15,23,196,2,27,249,22,128,16,23,198,2,23,205,2, -28,28,248,22,187,15,193,10,248,22,186,15,193,192,11,11,28,23,193,2,192, -86,94,23,193,1,28,23,203,2,11,27,248,22,137,16,23,200,2,28,249,22, -172,9,194,23,201,1,11,28,248,22,133,16,193,250,2,87,205,206,249,22,128, -16,200,197,250,2,87,205,206,195,192,86,94,23,194,1,28,23,196,2,90,144, -39,11,89,146,39,36,11,248,22,131,16,23,197,2,86,95,23,195,1,23,194, -1,27,28,23,201,2,27,248,22,137,16,23,199,2,28,249,22,172,9,23,195, -2,23,200,2,11,28,248,22,133,16,23,194,2,250,2,87,23,204,2,23,205, -2,249,22,128,16,23,200,2,23,198,1,250,2,87,23,204,2,23,205,2,23, -196,1,11,28,23,193,2,192,86,94,23,193,1,27,28,248,22,174,15,23,196, -2,27,249,22,128,16,23,198,2,23,204,2,28,28,248,22,187,15,193,10,248, -22,186,15,193,192,11,11,28,23,193,2,192,86,94,23,193,1,28,23,202,2, -11,27,248,22,137,16,23,200,2,28,249,22,172,9,194,23,201,1,11,28,248, -22,133,16,193,250,2,87,204,205,249,22,128,16,200,197,250,2,87,204,205,195, -192,28,23,193,2,90,144,39,11,89,146,39,36,11,248,22,131,16,23,199,2, -86,95,23,195,1,23,194,1,27,28,23,198,2,251,2,88,23,198,2,23,203, -2,23,201,2,23,202,2,11,28,23,193,2,192,86,94,23,193,1,27,28,248, -22,174,15,195,27,249,22,128,16,197,200,28,28,248,22,187,15,193,10,248,22, -186,15,193,192,11,11,28,192,192,28,198,11,251,2,88,198,203,201,202,194,32, -91,88,148,8,36,40,57,11,2,51,222,33,92,28,248,22,90,23,197,2,11, -27,249,22,128,16,248,22,136,16,248,22,83,23,201,2,23,196,2,28,248,22, -186,15,23,194,2,250,2,87,197,198,195,86,94,23,193,1,27,248,22,161,20, -23,199,1,28,248,22,90,23,194,2,11,27,249,22,128,16,248,22,136,16,248, -22,83,23,198,2,23,198,2,28,248,22,186,15,23,194,2,250,2,87,199,200, -195,86,94,23,193,1,27,248,22,161,20,23,196,1,28,248,22,90,23,194,2, -11,27,249,22,128,16,248,22,136,16,248,22,83,23,198,2,23,200,2,28,248, -22,186,15,23,194,2,250,2,87,201,202,195,86,94,23,193,1,27,248,22,161, -20,23,196,1,28,248,22,90,23,194,2,11,27,249,22,128,16,248,22,136,16, -248,22,83,197,201,28,248,22,186,15,193,250,2,87,203,204,195,251,2,91,203, -204,205,248,22,161,20,198,86,95,28,28,248,22,174,15,23,195,2,10,28,248, -22,154,7,23,195,2,28,248,22,133,16,23,195,2,10,248,22,134,16,23,195, -2,11,12,250,22,181,11,2,6,2,49,23,197,2,28,28,23,195,2,28,28, -248,22,174,15,23,196,2,10,28,248,22,154,7,23,196,2,28,248,22,133,16, -23,196,2,10,248,22,134,16,23,196,2,11,248,22,133,16,23,196,2,11,10, -12,250,22,181,11,2,6,6,45,45,40,111,114,47,99,32,35,102,32,40,97, -110,100,47,99,32,112,97,116,104,45,115,116,114,105,110,103,63,32,114,101,108, -97,116,105,118,101,45,112,97,116,104,63,41,41,23,198,2,28,28,248,22,133, -16,23,195,2,90,144,39,11,89,146,39,36,11,248,22,131,16,23,198,2,249, -22,170,9,194,2,50,11,27,249,22,176,8,247,22,175,8,5,4,80,65,84, -72,27,28,23,194,2,249,80,143,40,41,249,22,166,8,23,198,1,7,63,9, -86,94,23,194,1,9,27,28,249,22,170,9,247,22,181,8,2,44,249,22,82, -248,22,183,15,5,1,46,23,196,1,23,194,1,28,248,22,90,23,194,2,11, -27,249,22,128,16,248,22,136,16,248,22,83,23,198,2,23,200,2,28,248,22, -186,15,23,194,2,250,2,87,201,202,195,86,94,23,193,1,27,248,22,161,20, -23,196,1,28,248,22,90,23,194,2,11,27,249,22,128,16,248,22,136,16,248, -22,83,23,198,2,23,202,2,28,248,22,186,15,23,194,2,250,2,87,203,204, -195,86,94,23,193,1,27,248,22,161,20,23,196,1,28,248,22,90,23,194,2, -11,27,249,22,128,16,248,22,136,16,248,22,83,23,198,2,23,204,2,28,248, -22,186,15,23,194,2,250,2,87,205,206,195,86,94,23,193,1,27,248,22,161, -20,23,196,1,28,248,22,90,23,194,2,11,27,249,22,128,16,248,22,136,16, -248,22,83,197,205,28,248,22,186,15,193,250,2,87,23,15,23,16,195,251,2, -91,23,15,23,16,23,17,248,22,161,20,198,27,248,22,136,16,23,196,1,28, -248,22,186,15,193,250,2,87,198,199,195,11,250,80,144,39,40,39,196,197,11, -250,80,144,39,40,39,196,11,11,32,96,88,148,8,36,39,55,11,2,51,222, -33,98,0,8,35,114,120,35,34,92,34,34,27,249,22,167,16,23,197,2,23, -198,2,28,23,193,2,86,94,23,196,1,27,248,22,104,23,195,2,27,27,248, -22,113,23,197,1,27,249,22,167,16,23,201,2,23,196,2,28,23,193,2,86, -94,23,194,1,27,248,22,104,23,195,2,27,250,2,96,202,23,204,1,248,22, -113,23,199,1,27,28,249,22,170,9,247,22,181,8,2,44,250,22,179,16,2, -97,23,198,1,2,52,194,28,249,22,151,8,194,2,52,249,22,96,202,195,249, -22,82,248,22,183,15,195,195,86,95,23,199,1,23,193,1,27,28,249,22,170, -9,247,22,181,8,2,44,250,22,179,16,2,97,23,198,1,2,52,194,28,249, -22,151,8,194,2,52,249,22,96,200,9,249,22,82,248,22,183,15,195,9,27, -28,249,22,170,9,247,22,181,8,2,44,250,22,179,16,2,97,23,198,1,2, -52,194,28,249,22,151,8,194,2,52,249,22,96,198,195,249,22,82,248,22,183, -15,195,195,86,94,23,193,1,27,28,249,22,170,9,247,22,181,8,2,44,250, -22,179,16,2,97,23,200,1,2,52,196,28,249,22,151,8,194,2,52,249,22, -96,196,9,249,22,82,248,22,183,15,195,9,86,95,28,28,248,22,143,8,194, -10,248,22,154,7,194,12,250,22,181,11,2,7,6,21,21,40,111,114,47,99, -32,98,121,116,101,115,63,32,115,116,114,105,110,103,63,41,196,28,28,248,22, -91,195,249,22,4,22,174,15,196,11,12,250,22,181,11,2,7,6,14,14,40, -108,105,115,116,111,102,32,112,97,116,104,63,41,197,250,2,96,197,195,28,248, -22,154,7,197,248,22,168,8,197,196,28,28,248,22,0,23,195,2,249,22,50, -23,196,2,36,11,20,13,144,80,144,36,43,37,26,29,80,144,8,29,44,37, -249,22,33,11,80,144,8,31,43,37,22,144,15,10,22,145,15,10,22,146,15, -10,22,149,15,10,22,148,15,11,22,150,15,10,22,147,15,10,22,151,15,10, -22,152,15,10,22,153,15,10,22,154,15,10,22,155,15,11,22,156,15,10,22, -142,15,11,247,23,194,1,250,22,181,11,2,8,2,53,23,197,1,86,94,28, -28,248,22,174,15,23,195,2,10,28,248,22,154,7,23,195,2,28,248,22,133, -16,23,195,2,10,248,22,134,16,23,195,2,11,12,250,22,181,11,23,196,2, -2,49,23,197,2,28,248,22,133,16,23,195,2,12,251,22,183,11,23,197,1, -2,54,2,47,23,198,1,86,94,28,28,248,22,174,15,23,195,2,10,28,248, -22,154,7,23,195,2,28,248,22,133,16,23,195,2,10,248,22,134,16,23,195, -2,11,12,250,22,181,11,23,196,2,2,49,23,197,2,28,248,22,133,16,23, -195,2,12,251,22,183,11,23,197,1,2,54,2,47,23,198,1,86,94,86,94, -28,28,248,22,174,15,23,195,2,10,28,248,22,154,7,23,195,2,28,248,22, -133,16,23,195,2,10,248,22,134,16,23,195,2,11,12,250,22,181,11,23,196, -2,2,49,23,197,2,28,248,22,133,16,23,195,2,86,94,23,194,1,12,251, -22,183,11,23,197,2,2,54,2,47,23,198,1,249,22,3,20,20,94,88,148, -8,36,37,47,11,9,223,2,33,102,23,195,1,23,197,1,28,28,248,22,0, -23,195,2,249,22,50,23,196,2,37,11,12,250,22,181,11,23,196,1,2,55, -23,197,1,86,94,28,28,248,22,174,15,23,194,2,10,28,248,22,154,7,23, -194,2,28,248,22,133,16,23,194,2,10,248,22,134,16,23,194,2,11,12,250, -22,181,11,2,15,2,49,23,196,2,28,248,22,133,16,23,194,2,12,251,22, -183,11,2,15,2,54,2,47,23,197,1,86,95,86,94,86,94,28,28,248,22, -174,15,23,196,2,10,28,248,22,154,7,23,196,2,28,248,22,133,16,23,196, -2,10,248,22,134,16,23,196,2,11,12,250,22,181,11,2,15,2,49,23,198, -2,28,248,22,133,16,23,196,2,12,251,22,183,11,2,15,2,54,2,47,23, -199,2,249,22,3,32,0,88,148,8,36,37,46,11,9,222,33,105,23,198,2, -28,28,248,22,0,23,195,2,249,22,50,23,196,2,37,11,12,250,22,181,11, -2,15,2,55,23,197,2,252,80,143,41,49,23,199,1,23,200,1,23,201,1, -11,11,86,94,28,28,248,22,174,15,23,194,2,10,28,248,22,154,7,23,194, -2,28,248,22,133,16,23,194,2,10,248,22,134,16,23,194,2,11,12,250,22, -181,11,2,17,2,49,23,196,2,28,248,22,133,16,23,194,2,12,251,22,183, -11,2,17,2,54,2,47,23,197,1,86,96,86,94,28,28,248,22,174,15,23, -197,2,10,28,248,22,154,7,23,197,2,28,248,22,133,16,23,197,2,10,248, -22,134,16,23,197,2,11,12,250,22,181,11,2,17,2,49,23,199,2,28,248, -22,133,16,23,197,2,12,251,22,183,11,2,17,2,54,2,47,23,200,2,86, -94,86,94,28,28,248,22,174,15,23,198,2,10,28,248,22,154,7,23,198,2, -28,248,22,133,16,23,198,2,10,248,22,134,16,23,198,2,11,12,250,22,181, -11,2,17,2,49,23,200,2,28,248,22,133,16,23,198,2,12,251,22,183,11, -2,17,2,54,2,47,23,201,2,249,22,3,32,0,88,148,8,36,37,46,11, -9,222,33,107,23,200,2,28,28,248,22,0,23,195,2,249,22,50,23,196,2, -37,11,12,250,22,181,11,2,17,2,55,23,197,2,252,80,143,41,49,23,199, -1,23,202,1,23,203,1,23,201,1,23,200,1,27,248,22,151,16,2,56,28, -248,22,135,16,23,194,2,248,22,138,16,23,194,1,28,248,22,134,16,23,194, -2,90,144,39,11,89,146,39,36,11,248,22,131,16,249,22,136,16,250,80,144, -46,40,39,248,22,151,16,2,57,11,11,248,22,151,16,2,58,86,95,23,195, -1,23,194,1,248,22,138,16,249,22,136,16,23,199,1,23,196,1,27,250,80, -144,41,40,39,248,22,151,16,2,57,23,197,1,10,28,23,193,2,248,22,138, -16,23,194,1,11,249,80,144,38,52,37,36,80,144,38,8,40,39,27,248,22, -151,16,2,59,28,248,22,135,16,23,194,2,248,22,138,16,23,194,1,28,248, -22,134,16,23,194,2,90,144,39,11,89,146,39,36,11,248,22,131,16,249,22, -136,16,250,80,144,46,40,39,248,22,151,16,2,57,11,11,248,22,151,16,2, -58,86,95,23,195,1,23,194,1,248,22,138,16,249,22,136,16,23,199,1,23, -196,1,27,250,80,144,41,40,39,248,22,151,16,2,57,23,197,1,10,28,23, -193,2,248,22,138,16,23,194,1,11,249,80,144,38,52,37,37,80,144,38,8, -41,39,27,20,13,144,80,144,37,43,37,26,29,80,144,8,30,44,37,249,22, -33,11,80,144,8,32,43,37,22,144,15,10,22,145,15,10,22,146,15,10,22, -149,15,10,22,148,15,11,22,150,15,10,22,147,15,10,22,151,15,10,22,152, -15,10,22,153,15,10,22,154,15,10,22,155,15,11,22,156,15,10,22,142,15, -11,247,22,149,6,28,248,22,151,2,193,192,11,27,28,23,195,2,249,22,128, -16,23,197,1,6,11,11,99,111,110,102,105,103,46,114,107,116,100,86,94,23, -195,1,11,27,28,23,194,2,28,248,22,186,15,23,195,2,249,22,141,6,23, -196,1,80,144,40,8,42,39,11,11,28,192,192,21,17,1,0,250,22,160,2, -23,196,1,2,60,247,22,172,8,250,22,160,2,195,2,60,247,22,172,8,28, -248,22,154,7,23,195,2,27,248,22,182,15,23,196,1,28,248,22,135,16,23, -194,2,192,249,22,136,16,23,195,1,27,247,80,144,40,51,39,28,23,193,2, -192,86,94,23,193,1,247,22,152,16,28,248,22,143,8,23,195,2,27,248,22, -183,15,23,196,1,28,248,22,135,16,23,194,2,192,249,22,136,16,23,195,1, -27,247,80,144,40,51,39,28,23,193,2,192,86,94,23,193,1,247,22,152,16, -28,248,22,174,15,23,195,2,28,248,22,135,16,23,195,2,193,249,22,136,16, -23,196,1,27,247,80,144,39,51,39,28,23,193,2,192,86,94,23,193,1,247, -22,152,16,193,27,248,22,151,16,2,56,28,248,22,135,16,23,194,2,248,22, -138,16,23,194,1,28,248,22,134,16,23,194,2,90,144,39,11,89,146,39,36, -11,248,22,131,16,249,22,136,16,250,80,144,46,40,39,248,22,151,16,2,57, -11,11,248,22,151,16,2,58,86,95,23,195,1,23,194,1,248,22,138,16,249, -22,136,16,23,199,1,23,196,1,27,250,80,144,41,40,39,248,22,151,16,2, -57,23,197,1,10,28,23,193,2,248,22,138,16,23,194,1,11,28,248,22,135, -16,23,195,2,193,249,22,136,16,23,196,1,27,249,80,144,41,52,37,36,80, -144,41,8,43,39,28,23,193,2,192,86,94,23,193,1,247,22,152,16,28,248, -22,135,16,23,195,2,248,22,138,16,23,195,1,28,248,22,134,16,23,195,2, -90,144,39,11,89,146,39,36,11,248,22,131,16,249,22,136,16,250,80,144,45, -40,39,248,22,151,16,2,57,11,11,248,22,151,16,2,58,86,95,23,195,1, -23,194,1,248,22,138,16,249,22,136,16,23,200,1,23,196,1,27,250,80,144, -40,40,39,248,22,151,16,2,57,23,198,1,10,28,23,193,2,248,22,138,16, -23,194,1,11,28,248,22,90,23,196,2,9,28,248,22,83,23,196,2,249,22, -82,27,248,22,160,20,23,199,2,28,248,22,154,7,23,194,2,27,248,22,182, -15,23,195,1,28,248,22,135,16,23,194,2,192,249,22,136,16,23,195,1,27, -247,80,144,43,51,39,28,23,193,2,192,86,94,23,193,1,247,22,152,16,28, -248,22,143,8,23,194,2,27,248,22,183,15,23,195,1,28,248,22,135,16,23, -194,2,192,249,22,136,16,23,195,1,27,247,80,144,43,51,39,28,23,193,2, -192,86,94,23,193,1,247,22,152,16,28,248,22,174,15,23,194,2,28,248,22, -135,16,23,194,2,192,249,22,136,16,23,195,1,27,247,80,144,42,51,39,28, -23,193,2,192,86,94,23,193,1,247,22,152,16,192,27,248,22,161,20,23,199, -1,28,248,22,90,23,194,2,9,28,248,22,83,23,194,2,249,22,82,248,80, -144,42,57,39,248,22,160,20,23,197,2,27,248,22,161,20,23,197,1,28,248, -22,90,23,194,2,9,28,248,22,83,23,194,2,249,22,82,248,80,144,45,57, -39,248,22,160,20,23,197,2,249,80,144,46,8,44,39,23,204,1,248,22,161, -20,23,198,1,249,22,96,23,202,2,249,80,144,46,8,44,39,23,204,1,248, -22,161,20,23,198,1,249,22,96,23,199,2,27,248,22,161,20,23,197,1,28, -248,22,90,23,194,2,9,28,248,22,83,23,194,2,249,22,82,248,80,144,45, -57,39,248,22,160,20,23,197,2,249,80,144,46,8,44,39,23,204,1,248,22, -161,20,23,198,1,249,22,96,23,202,2,249,80,144,46,8,44,39,23,204,1, -248,22,161,20,23,198,1,249,22,96,23,196,2,27,248,22,161,20,23,199,1, -28,248,22,90,23,194,2,9,28,248,22,83,23,194,2,249,22,82,248,80,144, -42,57,39,248,22,160,20,23,197,2,27,248,22,161,20,23,197,1,28,248,22, -90,23,194,2,9,28,248,22,83,23,194,2,249,22,82,248,80,144,45,57,39, -248,22,160,20,23,197,2,249,80,144,46,8,44,39,23,204,1,248,22,161,20, -23,198,1,249,22,96,23,202,2,249,80,144,46,8,44,39,23,204,1,248,22, -161,20,23,198,1,249,22,96,23,199,2,27,248,22,161,20,23,197,1,28,248, -22,90,23,194,2,9,28,248,22,83,23,194,2,249,22,82,248,80,144,45,57, -39,248,22,160,20,23,197,2,249,80,144,46,8,44,39,23,204,1,248,22,161, -20,23,198,1,249,22,96,23,202,2,249,80,144,46,8,44,39,23,204,1,248, -22,161,20,23,198,1,27,250,22,160,2,23,198,1,23,199,1,11,28,192,249, -80,144,39,8,44,39,198,194,196,27,248,22,151,16,2,59,28,248,22,135,16, -23,194,2,248,22,138,16,23,194,1,28,248,22,134,16,23,194,2,90,144,39, -11,89,146,39,36,11,248,22,131,16,249,22,136,16,250,80,144,46,40,39,248, -22,151,16,2,57,11,11,248,22,151,16,2,58,86,95,23,195,1,23,194,1, -248,22,138,16,249,22,136,16,23,199,1,23,196,1,27,250,80,144,41,40,39, -248,22,151,16,2,57,23,197,1,10,28,23,193,2,248,22,138,16,23,194,1, -11,27,248,80,144,38,55,39,249,80,144,40,52,37,37,80,144,40,8,45,39, -27,27,250,22,160,2,23,198,2,70,108,105,110,107,115,45,102,105,108,101,11, -27,28,23,194,2,23,194,1,86,94,23,194,1,249,22,128,16,27,250,22,160, -2,23,202,2,69,115,104,97,114,101,45,100,105,114,11,28,192,192,249,22,128, -16,62,117,112,6,5,5,115,104,97,114,101,2,61,28,248,22,154,7,23,194, -2,27,248,22,182,15,23,195,1,28,248,22,135,16,23,194,2,192,249,22,136, -16,23,195,1,27,247,80,144,44,51,39,28,23,193,2,192,86,94,23,193,1, -247,22,152,16,28,248,22,143,8,23,194,2,27,248,22,183,15,23,195,1,28, -248,22,135,16,23,194,2,192,249,22,136,16,23,195,1,27,247,80,144,44,51, -39,28,23,193,2,192,86,94,23,193,1,247,22,152,16,28,248,22,174,15,23, -194,2,28,248,22,135,16,23,194,2,192,249,22,136,16,23,195,1,27,247,80, -144,43,51,39,28,23,193,2,192,86,94,23,193,1,247,22,152,16,192,250,22, -96,248,22,92,11,28,247,22,159,16,28,247,22,160,16,248,22,92,250,22,128, -16,248,22,151,16,2,62,250,22,160,2,23,204,2,2,60,247,22,172,8,2, -61,9,9,28,247,22,160,16,250,80,144,44,59,39,23,200,1,78,108,105,110, -107,115,45,115,101,97,114,99,104,45,102,105,108,101,115,248,22,92,23,200,1, -9,248,22,173,13,23,194,1,249,22,16,80,144,38,8,26,38,28,248,22,129, -13,23,197,2,86,94,23,196,1,32,0,88,148,8,36,36,41,11,9,222,11, -20,20,94,88,148,8,36,36,43,11,9,223,3,33,125,23,196,1,32,127,88, -148,36,37,56,11,2,51,222,33,128,2,90,144,39,11,89,146,39,36,11,248, -22,131,16,23,197,1,86,95,23,195,1,23,194,1,28,248,22,174,15,23,194, -2,28,248,22,187,15,23,194,2,249,22,146,6,23,195,1,32,0,88,148,8, -36,36,41,11,9,222,11,90,144,39,11,89,146,39,36,11,248,22,131,16,23, -197,1,86,95,23,195,1,23,194,1,28,248,22,174,15,23,194,2,28,248,22, -187,15,23,194,2,249,22,146,6,23,195,1,32,0,88,148,8,36,36,41,11, -9,222,11,90,144,39,11,89,146,39,36,11,248,22,131,16,23,197,1,86,95, -23,195,1,23,194,1,28,248,22,174,15,23,194,2,28,248,22,187,15,23,194, -2,249,22,146,6,23,195,1,32,0,88,148,8,36,36,41,11,9,222,11,90, -144,39,11,89,146,39,36,11,248,22,131,16,23,197,1,86,95,23,195,1,23, -194,1,28,248,22,174,15,23,194,2,28,248,22,187,15,23,194,2,249,22,146, -6,23,195,1,32,0,88,148,8,36,36,41,11,9,222,11,248,2,127,23,194, -1,11,11,11,11,32,129,2,88,148,8,36,37,55,11,2,51,222,33,130,2, -27,249,22,164,6,8,128,128,23,196,2,28,248,22,149,7,23,194,2,9,249, -22,82,23,195,1,27,249,22,164,6,8,128,128,23,199,2,28,248,22,149,7, -23,194,2,9,249,22,82,23,195,1,27,249,22,164,6,8,128,128,23,202,2, -28,248,22,149,7,23,194,2,9,249,22,82,23,195,1,27,249,22,164,6,8, -128,128,23,205,2,28,248,22,149,7,23,194,2,9,249,22,82,23,195,1,248, -2,129,2,23,206,1,27,249,22,164,6,8,128,128,23,196,2,28,248,22,143, -8,23,194,2,28,249,22,134,4,248,22,148,8,23,196,2,8,128,128,249,22, -1,22,155,8,249,22,82,23,197,1,27,249,22,164,6,8,128,128,23,201,2, -28,248,22,149,7,23,194,2,9,249,22,82,23,195,1,27,249,22,164,6,8, -128,128,23,204,2,28,248,22,149,7,23,194,2,9,249,22,82,23,195,1,27, -249,22,164,6,8,128,128,23,207,2,28,248,22,149,7,23,194,2,9,249,22, -82,23,195,1,27,249,22,164,6,8,128,128,23,210,2,28,248,22,149,7,23, -194,2,9,249,22,82,23,195,1,248,2,129,2,23,211,1,192,192,248,22,134, -6,23,194,1,20,13,144,80,144,37,8,28,37,80,144,37,8,46,39,27,28, -249,22,190,8,248,22,181,8,2,63,38,90,144,39,11,89,146,39,36,11,248, -22,131,16,23,198,2,86,95,23,195,1,23,194,1,28,248,22,174,15,23,194, -2,28,248,22,187,15,23,194,2,249,22,146,6,23,195,1,32,0,88,148,8, -36,36,41,11,9,222,11,90,144,39,11,89,146,39,36,11,248,22,131,16,23, -197,1,86,95,23,195,1,23,194,1,28,248,22,174,15,23,194,2,28,248,22, -187,15,23,194,2,249,22,146,6,23,195,1,32,0,88,148,8,36,36,41,11, -9,222,11,90,144,39,11,89,146,39,36,11,248,22,131,16,23,197,1,86,95, -23,195,1,23,194,1,28,248,22,174,15,23,194,2,28,248,22,187,15,23,194, -2,249,22,146,6,23,195,1,32,0,88,148,8,36,36,41,11,9,222,11,90, -144,39,11,89,146,39,36,11,248,22,131,16,23,197,1,86,95,23,195,1,23, -194,1,28,248,22,174,15,23,194,2,28,248,22,187,15,23,194,2,249,22,146, -6,23,195,1,32,0,88,148,8,36,36,41,11,9,222,11,248,2,127,23,194, -1,11,11,11,11,11,28,248,22,186,15,23,195,2,27,28,249,22,190,8,248, -22,181,8,2,63,38,249,22,146,6,23,197,2,32,0,88,148,8,36,36,41, -11,9,222,11,11,86,94,28,23,194,2,248,22,148,6,23,195,1,86,94,23, -194,1,12,249,22,82,27,248,22,189,5,23,199,1,250,22,46,22,37,88,148, -36,36,8,24,11,9,223,3,33,131,2,20,20,94,88,148,36,36,43,11,9, -223,3,33,132,2,23,196,1,194,249,22,82,11,194,28,28,23,195,2,28,248, -22,84,23,196,2,248,22,168,9,249,22,175,14,36,248,22,161,20,23,199,2, -11,11,194,86,94,23,195,1,249,22,14,20,20,94,88,148,8,32,36,58,16, -4,36,8,128,80,8,240,0,64,0,0,36,9,224,2,3,33,133,2,23,196, -1,80,144,38,8,26,38,27,248,22,168,9,194,28,192,192,248,22,168,9,248, -22,83,195,86,95,28,248,22,150,12,23,198,2,27,247,22,142,12,28,249,22, -132,12,23,195,2,2,64,251,22,138,12,23,197,1,2,64,250,22,138,8,6, -42,42,101,114,114,111,114,32,114,101,97,100,105,110,103,32,99,111,108,108,101, -99,116,105,111,110,32,108,105,110,107,115,32,102,105,108,101,32,126,115,58,32, -126,97,23,203,2,248,22,146,12,23,206,2,247,22,29,12,12,28,23,193,2, -250,22,158,2,80,144,42,8,25,38,23,198,1,249,22,82,23,198,1,21,17, -0,0,86,95,23,195,1,23,193,1,12,28,248,22,150,12,23,198,2,86,94, -23,197,1,248,23,195,1,247,22,140,2,196,88,148,36,37,55,8,240,0,0, -0,2,9,226,0,2,1,3,33,136,2,20,20,94,248,22,149,6,23,194,2, -28,248,22,149,7,248,22,149,6,23,195,1,12,248,22,177,11,6,30,30,101, -120,112,101,99,116,101,100,32,97,32,115,105,110,103,108,101,32,83,45,101,120, -112,114,101,115,115,105,111,110,248,22,134,6,23,194,1,28,248,22,91,193,28, -28,249,22,130,4,38,248,22,95,195,10,249,22,130,4,39,248,22,95,195,28, -28,248,22,154,7,248,22,83,194,10,28,249,22,170,9,2,65,248,22,160,20, -195,10,249,22,170,9,2,66,248,22,160,20,195,28,27,248,22,104,194,28,248, -22,174,15,193,10,28,248,22,154,7,193,28,248,22,133,16,193,10,248,22,134, -16,193,11,27,248,22,90,248,22,106,195,28,192,192,248,22,180,16,248,22,113, -195,11,11,11,11,28,248,22,187,15,249,22,128,16,23,196,2,23,198,2,27, -248,22,70,248,22,178,15,23,198,1,250,22,158,2,23,198,2,23,196,2,249, -22,82,23,199,1,250,22,160,2,23,203,1,23,201,1,9,12,250,22,158,2, -23,197,1,23,198,1,249,22,82,23,198,1,23,201,1,28,28,248,22,90,248, -22,106,23,197,2,10,249,22,171,16,248,22,113,23,198,2,247,22,172,8,27, -248,22,138,16,249,22,136,16,248,22,104,23,200,2,23,198,1,28,249,22,170, -9,248,22,83,23,199,2,2,66,86,94,23,196,1,249,22,3,20,20,94,88, -148,8,36,37,53,11,9,224,3,2,33,141,2,23,196,1,248,22,141,16,23, -196,1,28,249,22,170,9,248,22,160,20,23,199,2,2,65,86,94,23,196,1, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,9,54,46,50,46,57,48,48,46,52,84,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,194,0,0,0,1,0,0,8,0, +16,0,29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,173,0,180, +0,195,0,213,0,225,0,241,0,255,0,21,1,41,1,48,1,82,1,99,1, +116,1,139,1,154,1,193,1,211,1,242,1,254,1,15,2,27,2,42,2,66, +2,98,2,127,2,143,2,161,2,181,2,202,2,220,2,251,2,9,3,26,3, +70,3,78,3,83,3,127,3,134,3,144,3,159,3,168,3,173,3,175,3,208, +3,232,3,253,3,10,4,20,4,29,4,40,4,58,4,71,4,81,4,91,4, +97,4,102,4,114,4,117,4,121,4,126,4,169,4,182,4,185,4,209,4,248, +4,255,4,12,5,34,5,45,5,75,5,98,5,106,5,130,5,151,5,95,6, +125,6,206,9,229,9,246,9,170,11,17,12,31,12,235,12,211,14,220,14,229, +14,243,14,253,14,14,16,117,16,230,16,47,17,120,17,224,17,253,17,68,18, +206,18,21,19,234,19,96,20,109,20,227,20,240,20,79,21,146,21,159,21,170, +21,66,22,184,22,228,22,83,23,161,25,185,25,47,26,129,27,136,27,188,27, +203,27,194,28,210,28,65,29,224,29,231,29,108,31,185,31,202,31,102,32,122, +32,182,32,189,32,49,33,103,33,122,33,73,34,89,34,49,35,38,36,75,36, +84,36,161,37,6,40,22,40,89,40,110,40,130,40,150,40,207,40,175,43,141, +44,157,44,128,45,186,45,219,45,95,46,254,46,14,47,111,47,128,47,206,49, +1,52,17,52,247,53,179,54,181,54,208,54,224,54,240,54,81,55,148,56,80, +57,96,57,105,57,112,57,178,58,244,59,106,60,152,63,26,64,158,64,103,66, +53,67,95,67,203,67,0,0,150,75,0,0,3,1,5,105,110,115,112,48,69, +35,37,117,116,105,108,115,74,112,97,116,104,45,115,116,114,105,110,103,63,66, +98,115,98,115,78,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104, +73,114,101,114,111,111,116,45,112,97,116,104,1,20,102,105,110,100,45,101,120, +101,99,117,116,97,98,108,101,45,112,97,116,104,1,27,112,97,116,104,45,108, +105,115,116,45,115,116,114,105,110,103,45,62,112,97,116,104,45,108,105,115,116, +1,42,99,97,108,108,45,119,105,116,104,45,100,101,102,97,117,108,116,45,114, +101,97,100,105,110,103,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105, +111,110,67,113,117,111,116,101,70,35,37,112,97,114,97,109,122,29,94,2,10, +2,11,11,76,45,99,104,101,99,107,45,114,101,108,112,97,116,104,79,45,99, +104,101,99,107,45,99,111,108,108,101,99,116,105,111,110,73,45,99,104,101,99, +107,45,102,97,105,108,77,99,111,108,108,101,99,116,105,111,110,45,112,97,116, +104,75,102,105,110,100,45,99,111,108,45,102,105,108,101,1,20,99,111,108,108, +101,99,116,105,111,110,45,102,105,108,101,45,112,97,116,104,1,18,102,105,110, +100,45,109,97,105,110,45,99,111,108,108,101,99,116,115,29,94,2,10,2,11, +11,1,32,101,120,101,45,114,101,108,97,116,105,118,101,45,112,97,116,104,45, +62,99,111,109,112,108,101,116,101,45,112,97,116,104,78,102,105,110,100,45,109, +97,105,110,45,99,111,110,102,105,103,78,103,101,116,45,99,111,110,102,105,103, +45,116,97,98,108,101,1,21,103,101,116,45,105,110,115,116,97,108,108,97,116, +105,111,110,45,110,97,109,101,76,99,111,101,114,99,101,45,116,111,45,112,97, +116,104,1,37,99,111,108,108,101,99,116,115,45,114,101,108,97,116,105,118,101, +45,112,97,116,104,45,62,99,111,109,112,108,101,116,101,45,112,97,116,104,79, +97,100,100,45,99,111,110,102,105,103,45,115,101,97,114,99,104,1,29,102,105, +110,100,45,108,105,98,114,97,114,121,45,99,111,108,108,101,99,116,105,111,110, +45,108,105,110,107,115,73,108,105,110,107,115,45,99,97,99,104,101,78,115,116, +97,109,112,45,112,114,111,109,112,116,45,116,97,103,73,102,105,108,101,45,62, +115,116,97,109,112,76,110,111,45,102,105,108,101,45,115,116,97,109,112,63,1, +22,103,101,116,45,108,105,110,107,101,100,45,99,111,108,108,101,99,116,105,111, +110,115,1,30,110,111,114,109,97,108,105,122,101,45,99,111,108,108,101,99,116, +105,111,110,45,114,101,102,101,114,101,110,99,101,1,27,102,105,108,101,45,101, +120,105,115,116,115,63,47,109,97,121,98,101,45,99,111,109,112,105,108,101,100, +77,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120,79,99,104,101,99, +107,45,115,117,102,102,105,120,45,99,97,108,108,1,18,112,97,116,104,45,97, +100,106,117,115,116,45,115,117,102,102,105,120,1,19,112,97,116,104,45,114,101, +112,108,97,99,101,45,115,117,102,102,105,120,79,108,111,97,100,47,117,115,101, +45,99,111,109,112,105,108,101,100,1,29,102,105,110,100,45,108,105,98,114,97, +114,121,45,99,111,108,108,101,99,116,105,111,110,45,112,97,116,104,115,75,101, +109,98,101,100,100,101,100,45,108,111,97,100,78,110,111,114,109,97,108,45,112, +97,116,104,45,99,97,115,101,6,41,41,40,111,114,47,99,32,112,97,116,104, +45,102,111,114,45,115,111,109,101,45,115,121,115,116,101,109,63,32,112,97,116, +104,45,115,116,114,105,110,103,63,41,69,119,105,110,100,111,119,115,6,2,2, +92,49,6,41,41,40,111,114,47,99,32,112,97,116,104,45,115,116,114,105,110, +103,63,32,112,97,116,104,45,102,111,114,45,115,111,109,101,45,115,121,115,116, +101,109,63,41,6,4,4,112,97,116,104,5,8,92,92,63,92,82,69,76,92, +6,12,12,112,97,116,104,45,115,116,114,105,110,103,63,70,114,101,108,97,116, +105,118,101,66,108,111,111,112,5,0,6,30,30,40,112,114,111,99,101,100,117, +114,101,45,97,114,105,116,121,45,105,110,99,108,117,100,101,115,47,99,32,48, +41,6,21,21,105,110,118,97,108,105,100,32,114,101,108,97,116,105,118,101,32, +112,97,116,104,6,18,18,40,97,110,121,47,99,32,46,32,45,62,32,46,32, +97,110,121,41,74,99,111,108,108,101,99,116,115,45,100,105,114,71,101,120,101, +99,45,102,105,108,101,70,111,114,105,103,45,100,105,114,72,99,111,110,102,105, +103,45,100,105,114,79,105,110,115,116,97,108,108,97,116,105,111,110,45,110,97, +109,101,6,10,10,108,105,110,107,115,46,114,107,116,100,71,97,100,100,111,110, +45,100,105,114,71,102,115,45,99,104,97,110,103,101,67,101,114,114,111,114,66, +114,111,111,116,73,115,116,97,116,105,99,45,114,111,111,116,6,0,0,6,1, +1,47,5,3,46,122,111,6,40,40,114,101,109,111,118,105,110,103,32,115,117, +102,102,105,120,32,109,97,107,101,115,32,112,97,116,104,32,101,108,101,109,101, +110,116,32,101,109,112,116,121,6,10,10,103,105,118,101,110,32,112,97,116,104, +5,1,95,6,21,21,40,111,114,47,99,32,115,116,114,105,110,103,63,32,98, +121,116,101,115,63,41,6,36,36,99,97,110,110,111,116,32,97,100,100,32,97, +32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32,112,97,116, +104,58,32,68,102,105,110,105,115,104,5,11,80,76,84,67,79,76,76,69,67, +84,83,1,20,99,111,108,108,101,99,116,115,45,115,101,97,114,99,104,45,100, +105,114,115,6,8,8,99,111,108,108,101,99,116,115,27,248,22,175,15,194,28, +192,192,28,248,22,155,7,194,27,248,22,134,16,195,28,192,192,248,22,135,16, +195,11,0,21,35,114,120,34,94,91,92,92,93,91,92,92,93,91,63,93,91, +92,92,93,34,0,6,35,114,120,34,47,34,0,22,35,114,120,34,91,47,92, +92,93,91,46,32,93,43,91,47,92,92,93,42,36,34,0,19,35,114,120,34, +91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,86,94,28,28,248,22, +176,15,23,195,2,10,28,248,22,175,15,23,195,2,10,28,248,22,155,7,23, +195,2,28,248,22,134,16,23,195,2,10,248,22,135,16,23,195,2,11,12,250, +22,182,11,2,43,2,44,23,197,2,28,28,248,22,176,15,23,195,2,249,22, +171,9,248,22,177,15,23,197,2,2,45,249,22,171,9,247,22,182,8,2,45, +27,28,248,22,155,7,23,196,2,23,195,2,248,22,167,8,248,22,180,15,23, +197,2,28,249,22,172,16,2,81,23,195,2,28,248,22,155,7,195,248,22,183, +15,195,194,27,248,22,130,8,23,195,1,249,22,184,15,248,22,170,8,250,22, +180,16,2,82,28,249,22,172,16,2,83,23,201,2,23,199,1,250,22,180,16, +2,84,23,202,1,2,46,80,144,47,40,41,2,45,28,248,22,155,7,194,248, +22,183,15,194,193,0,28,35,114,120,34,94,92,92,92,92,92,92,92,92,91, +63,93,92,92,92,92,85,78,67,92,92,92,92,34,86,95,28,28,28,248,22, +175,15,23,195,2,10,28,248,22,155,7,23,195,2,28,248,22,134,16,23,195, +2,10,248,22,135,16,23,195,2,11,10,248,22,176,15,23,195,2,12,252,22, +182,11,2,6,2,47,39,23,199,2,23,200,2,28,28,28,248,22,175,15,23, +196,2,10,28,248,22,155,7,23,196,2,28,248,22,134,16,23,196,2,10,248, +22,135,16,23,196,2,11,10,248,22,176,15,23,196,2,12,252,22,182,11,2, +6,2,47,40,23,199,2,23,200,2,27,28,248,22,176,15,23,196,2,248,22, +177,15,23,196,2,247,22,178,15,86,95,28,28,248,22,136,16,23,196,2,10, +249,22,171,9,247,22,178,15,23,195,2,12,253,22,184,11,2,6,6,54,54, +112,97,116,104,32,105,115,32,110,111,116,32,99,111,109,112,108,101,116,101,32, +97,110,100,32,110,111,116,32,116,104,101,32,112,108,97,116,102,111,114,109,39, +115,32,99,111,110,118,101,110,116,105,111,110,2,48,23,201,2,6,24,24,112, +108,97,116,102,111,114,109,32,99,111,110,118,101,110,116,105,111,110,32,116,121, +112,101,247,22,178,15,28,249,22,171,9,28,248,22,176,15,23,199,2,248,22, +177,15,23,199,2,247,22,178,15,23,195,2,12,253,22,184,11,2,6,6,37, +37,103,105,118,101,110,32,112,97,116,104,115,32,117,115,101,32,100,105,102,102, +101,114,101,110,116,32,99,111,110,118,101,110,116,105,111,110,115,2,48,23,201, +2,6,9,9,114,111,111,116,32,112,97,116,104,23,202,2,27,27,248,22,140, +16,28,248,22,136,16,23,199,2,23,198,1,248,22,137,16,23,199,1,86,94, +28,28,248,22,176,15,23,194,2,10,28,248,22,175,15,23,194,2,10,28,248, +22,155,7,23,194,2,28,248,22,134,16,23,194,2,10,248,22,135,16,23,194, +2,11,12,250,22,182,11,2,43,2,44,23,196,2,28,28,248,22,176,15,23, +194,2,249,22,171,9,248,22,177,15,23,196,2,2,45,249,22,171,9,247,22, +182,8,2,45,27,28,248,22,155,7,23,195,2,23,194,2,248,22,167,8,248, +22,180,15,23,196,2,28,249,22,172,16,2,81,23,195,2,28,248,22,155,7, +194,248,22,183,15,194,193,27,248,22,130,8,23,195,1,249,22,184,15,248,22, +170,8,250,22,180,16,2,82,28,249,22,172,16,2,83,23,201,2,23,199,1, +250,22,180,16,2,84,23,202,1,2,46,80,144,50,40,41,2,45,28,248,22, +155,7,193,248,22,183,15,193,192,27,248,22,180,15,23,195,2,28,249,22,171, +9,23,197,2,66,117,110,105,120,28,249,22,152,8,194,5,1,47,28,248,22, +176,15,198,197,248,22,183,15,198,249,22,129,16,199,249,22,184,15,249,22,155, +8,248,22,180,15,200,40,198,28,249,22,171,9,23,197,2,2,45,249,22,129, +16,23,200,1,249,22,184,15,28,249,22,172,16,0,27,35,114,120,34,94,92, +92,92,92,92,92,92,92,91,63,93,92,92,92,92,91,97,45,122,93,58,34, +23,199,2,251,22,156,8,2,49,250,22,155,8,203,43,44,5,1,92,249,22, +155,8,202,45,28,249,22,172,16,2,86,23,199,2,249,22,156,8,2,49,249, +22,155,8,200,43,28,249,22,172,16,2,86,23,199,2,249,22,156,8,2,49, +249,22,155,8,200,43,28,249,22,172,16,0,14,35,114,120,34,94,92,92,92, +92,92,92,92,92,34,23,199,2,249,22,156,8,5,4,85,78,67,92,249,22, +155,8,200,41,28,249,22,172,16,0,12,35,114,120,34,94,91,97,45,122,93, +58,34,198,249,22,156,8,250,22,155,8,201,39,40,249,22,155,8,200,41,12, +198,12,32,88,88,148,8,36,42,56,11,72,102,111,117,110,100,45,101,120,101, +99,222,33,91,32,89,88,148,8,36,43,61,11,66,110,101,120,116,222,33,90, +27,248,22,138,16,23,196,2,28,249,22,173,9,23,195,2,23,197,1,11,28, +248,22,134,16,23,194,2,27,249,22,129,16,23,197,1,23,196,1,28,23,197, +2,90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,2,86,95,23,195, +1,23,194,1,27,28,23,202,2,27,248,22,138,16,23,199,2,28,249,22,173, +9,23,195,2,23,200,2,11,28,248,22,134,16,23,194,2,250,2,88,23,205, +2,23,206,2,249,22,129,16,23,200,2,23,198,1,250,2,88,23,205,2,23, +206,2,23,196,1,11,28,23,193,2,192,86,94,23,193,1,27,28,248,22,175, +15,23,196,2,27,249,22,129,16,23,198,2,23,205,2,28,28,248,22,188,15, +193,10,248,22,187,15,193,192,11,11,28,23,193,2,192,86,94,23,193,1,28, +23,203,2,11,27,248,22,138,16,23,200,2,28,249,22,173,9,194,23,201,1, +11,28,248,22,134,16,193,250,2,88,205,206,249,22,129,16,200,197,250,2,88, +205,206,195,192,86,94,23,194,1,28,23,196,2,90,144,42,11,89,146,42,39, +11,248,22,132,16,23,197,2,86,95,23,195,1,23,194,1,27,28,23,201,2, +27,248,22,138,16,23,199,2,28,249,22,173,9,23,195,2,23,200,2,11,28, +248,22,134,16,23,194,2,250,2,88,23,204,2,23,205,2,249,22,129,16,23, +200,2,23,198,1,250,2,88,23,204,2,23,205,2,23,196,1,11,28,23,193, +2,192,86,94,23,193,1,27,28,248,22,175,15,23,196,2,27,249,22,129,16, +23,198,2,23,204,2,28,28,248,22,188,15,193,10,248,22,187,15,193,192,11, +11,28,23,193,2,192,86,94,23,193,1,28,23,202,2,11,27,248,22,138,16, +23,200,2,28,249,22,173,9,194,23,201,1,11,28,248,22,134,16,193,250,2, +88,204,205,249,22,129,16,200,197,250,2,88,204,205,195,192,28,23,193,2,90, +144,42,11,89,146,42,39,11,248,22,132,16,23,199,2,86,95,23,195,1,23, +194,1,27,28,23,198,2,251,2,89,23,198,2,23,203,2,23,201,2,23,202, +2,11,28,23,193,2,192,86,94,23,193,1,27,28,248,22,175,15,195,27,249, +22,129,16,197,200,28,28,248,22,188,15,193,10,248,22,187,15,193,192,11,11, +28,192,192,28,198,11,251,2,89,198,203,201,202,194,32,92,88,148,8,36,43, +60,11,2,52,222,33,93,28,248,22,90,23,197,2,11,27,249,22,129,16,248, +22,137,16,248,22,83,23,201,2,23,196,2,28,248,22,187,15,23,194,2,250, +2,88,197,198,195,86,94,23,193,1,27,248,22,164,20,23,199,1,28,248,22, +90,23,194,2,11,27,249,22,129,16,248,22,137,16,248,22,83,23,198,2,23, +198,2,28,248,22,187,15,23,194,2,250,2,88,199,200,195,86,94,23,193,1, +27,248,22,164,20,23,196,1,28,248,22,90,23,194,2,11,27,249,22,129,16, +248,22,137,16,248,22,83,23,198,2,23,200,2,28,248,22,187,15,23,194,2, +250,2,88,201,202,195,86,94,23,193,1,27,248,22,164,20,23,196,1,28,248, +22,90,23,194,2,11,27,249,22,129,16,248,22,137,16,248,22,83,197,201,28, +248,22,187,15,193,250,2,88,203,204,195,251,2,92,203,204,205,248,22,164,20, +198,86,95,28,28,248,22,175,15,23,195,2,10,28,248,22,155,7,23,195,2, +28,248,22,134,16,23,195,2,10,248,22,135,16,23,195,2,11,12,250,22,182, +11,2,7,2,50,23,197,2,28,28,23,195,2,28,28,248,22,175,15,23,196, +2,10,28,248,22,155,7,23,196,2,28,248,22,134,16,23,196,2,10,248,22, +135,16,23,196,2,11,248,22,134,16,23,196,2,11,10,12,250,22,182,11,2, +7,6,45,45,40,111,114,47,99,32,35,102,32,40,97,110,100,47,99,32,112, +97,116,104,45,115,116,114,105,110,103,63,32,114,101,108,97,116,105,118,101,45, +112,97,116,104,63,41,41,23,198,2,28,28,248,22,134,16,23,195,2,90,144, +42,11,89,146,42,39,11,248,22,132,16,23,198,2,249,22,171,9,194,2,51, +11,27,249,22,177,8,247,22,176,8,5,4,80,65,84,72,27,28,23,194,2, +249,80,143,43,44,249,22,167,8,23,198,1,7,63,9,86,94,23,194,1,9, +27,28,249,22,171,9,247,22,182,8,2,45,249,22,82,248,22,184,15,5,1, +46,23,196,1,23,194,1,28,248,22,90,23,194,2,11,27,249,22,129,16,248, +22,137,16,248,22,83,23,198,2,23,200,2,28,248,22,187,15,23,194,2,250, +2,88,201,202,195,86,94,23,193,1,27,248,22,164,20,23,196,1,28,248,22, +90,23,194,2,11,27,249,22,129,16,248,22,137,16,248,22,83,23,198,2,23, +202,2,28,248,22,187,15,23,194,2,250,2,88,203,204,195,86,94,23,193,1, +27,248,22,164,20,23,196,1,28,248,22,90,23,194,2,11,27,249,22,129,16, +248,22,137,16,248,22,83,23,198,2,23,204,2,28,248,22,187,15,23,194,2, +250,2,88,205,206,195,86,94,23,193,1,27,248,22,164,20,23,196,1,28,248, +22,90,23,194,2,11,27,249,22,129,16,248,22,137,16,248,22,83,197,205,28, +248,22,187,15,193,250,2,88,23,15,23,16,195,251,2,92,23,15,23,16,23, +17,248,22,164,20,198,27,248,22,137,16,23,196,1,28,248,22,187,15,193,250, +2,88,198,199,195,11,250,80,144,42,43,42,196,197,11,250,80,144,42,43,42, +196,11,11,32,97,88,148,8,36,42,58,11,2,52,222,33,99,0,8,35,114, +120,35,34,92,34,34,27,249,22,168,16,23,197,2,23,198,2,28,23,193,2, +86,94,23,196,1,27,248,22,104,23,195,2,27,27,248,22,113,23,197,1,27, +249,22,168,16,23,201,2,23,196,2,28,23,193,2,86,94,23,194,1,27,248, +22,104,23,195,2,27,250,2,97,202,23,204,1,248,22,113,23,199,1,27,28, +249,22,171,9,247,22,182,8,2,45,250,22,180,16,2,98,23,198,1,2,53, +194,28,249,22,152,8,194,2,53,249,22,96,202,195,249,22,82,248,22,184,15, +195,195,86,95,23,199,1,23,193,1,27,28,249,22,171,9,247,22,182,8,2, +45,250,22,180,16,2,98,23,198,1,2,53,194,28,249,22,152,8,194,2,53, +249,22,96,200,9,249,22,82,248,22,184,15,195,9,27,28,249,22,171,9,247, +22,182,8,2,45,250,22,180,16,2,98,23,198,1,2,53,194,28,249,22,152, +8,194,2,53,249,22,96,198,195,249,22,82,248,22,184,15,195,195,86,94,23, +193,1,27,28,249,22,171,9,247,22,182,8,2,45,250,22,180,16,2,98,23, +200,1,2,53,196,28,249,22,152,8,194,2,53,249,22,96,196,9,249,22,82, +248,22,184,15,195,9,86,95,28,28,248,22,144,8,194,10,248,22,155,7,194, +12,250,22,182,11,2,8,6,21,21,40,111,114,47,99,32,98,121,116,101,115, +63,32,115,116,114,105,110,103,63,41,196,28,28,248,22,91,195,249,22,4,22, +175,15,196,11,12,250,22,182,11,2,8,6,14,14,40,108,105,115,116,111,102, +32,112,97,116,104,63,41,197,250,2,97,197,195,28,248,22,155,7,197,248,22, +169,8,197,196,28,28,248,22,0,23,195,2,249,22,50,23,196,2,39,11,20, +13,144,80,144,39,46,40,26,29,80,144,8,29,47,40,249,22,33,11,80,144, +8,31,46,40,22,145,15,10,22,146,15,10,22,147,15,10,22,150,15,10,22, +149,15,11,22,151,15,10,22,148,15,10,22,152,15,10,22,153,15,10,22,154, +15,10,22,155,15,10,22,156,15,11,22,157,15,10,22,143,15,11,247,23,194, +1,250,22,182,11,2,9,2,54,23,197,1,86,94,28,28,248,22,175,15,23, +195,2,10,28,248,22,155,7,23,195,2,28,248,22,134,16,23,195,2,10,248, +22,135,16,23,195,2,11,12,250,22,182,11,23,196,2,2,50,23,197,2,28, +248,22,134,16,23,195,2,12,251,22,184,11,23,197,1,2,55,2,48,23,198, +1,86,94,28,28,248,22,175,15,23,195,2,10,28,248,22,155,7,23,195,2, +28,248,22,134,16,23,195,2,10,248,22,135,16,23,195,2,11,12,250,22,182, +11,23,196,2,2,50,23,197,2,28,248,22,134,16,23,195,2,12,251,22,184, +11,23,197,1,2,55,2,48,23,198,1,86,94,86,94,28,28,248,22,175,15, +23,195,2,10,28,248,22,155,7,23,195,2,28,248,22,134,16,23,195,2,10, +248,22,135,16,23,195,2,11,12,250,22,182,11,23,196,2,2,50,23,197,2, +28,248,22,134,16,23,195,2,86,94,23,194,1,12,251,22,184,11,23,197,2, +2,55,2,48,23,198,1,249,22,3,20,20,94,88,148,8,36,40,50,11,9, +223,2,33,103,23,195,1,23,197,1,28,28,248,22,0,23,195,2,249,22,50, +23,196,2,40,11,12,250,22,182,11,23,196,1,2,56,23,197,1,86,94,28, +28,248,22,175,15,23,194,2,10,28,248,22,155,7,23,194,2,28,248,22,134, +16,23,194,2,10,248,22,135,16,23,194,2,11,12,250,22,182,11,2,16,2, +50,23,196,2,28,248,22,134,16,23,194,2,12,251,22,184,11,2,16,2,55, +2,48,23,197,1,86,95,86,94,86,94,28,28,248,22,175,15,23,196,2,10, +28,248,22,155,7,23,196,2,28,248,22,134,16,23,196,2,10,248,22,135,16, +23,196,2,11,12,250,22,182,11,2,16,2,50,23,198,2,28,248,22,134,16, +23,196,2,12,251,22,184,11,2,16,2,55,2,48,23,199,2,249,22,3,32, +0,88,148,8,36,40,49,11,9,222,33,106,23,198,2,28,28,248,22,0,23, +195,2,249,22,50,23,196,2,40,11,12,250,22,182,11,2,16,2,56,23,197, +2,252,80,143,44,52,23,199,1,23,200,1,23,201,1,11,11,86,94,28,28, +248,22,175,15,23,194,2,10,28,248,22,155,7,23,194,2,28,248,22,134,16, +23,194,2,10,248,22,135,16,23,194,2,11,12,250,22,182,11,2,18,2,50, +23,196,2,28,248,22,134,16,23,194,2,12,251,22,184,11,2,18,2,55,2, +48,23,197,1,86,96,86,94,28,28,248,22,175,15,23,197,2,10,28,248,22, +155,7,23,197,2,28,248,22,134,16,23,197,2,10,248,22,135,16,23,197,2, +11,12,250,22,182,11,2,18,2,50,23,199,2,28,248,22,134,16,23,197,2, +12,251,22,184,11,2,18,2,55,2,48,23,200,2,86,94,86,94,28,28,248, +22,175,15,23,198,2,10,28,248,22,155,7,23,198,2,28,248,22,134,16,23, +198,2,10,248,22,135,16,23,198,2,11,12,250,22,182,11,2,18,2,50,23, +200,2,28,248,22,134,16,23,198,2,12,251,22,184,11,2,18,2,55,2,48, +23,201,2,249,22,3,32,0,88,148,8,36,40,49,11,9,222,33,108,23,200, +2,28,28,248,22,0,23,195,2,249,22,50,23,196,2,40,11,12,250,22,182, +11,2,18,2,56,23,197,2,252,80,143,44,52,23,199,1,23,202,1,23,203, +1,23,201,1,23,200,1,27,248,22,152,16,2,57,28,248,22,136,16,23,194, +2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2,90,144,42,11,89, +146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,49,43,42,248,22,152, +16,2,58,11,11,248,22,152,16,2,59,86,95,23,195,1,23,194,1,248,22, +139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144,44,43,42,248,22, +152,16,2,58,23,197,1,10,28,23,193,2,248,22,139,16,23,194,1,11,249, +80,144,41,55,40,39,80,144,41,8,40,42,27,248,22,152,16,2,60,28,248, +22,136,16,23,194,2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2, +90,144,42,11,89,146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,49, +43,42,248,22,152,16,2,58,11,11,248,22,152,16,2,59,86,95,23,195,1, +23,194,1,248,22,139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144, +44,43,42,248,22,152,16,2,58,23,197,1,10,28,23,193,2,248,22,139,16, +23,194,1,11,249,80,144,41,55,40,40,80,144,41,8,41,42,27,20,13,144, +80,144,40,46,40,26,29,80,144,8,30,47,40,249,22,33,11,80,144,8,32, +46,40,22,145,15,10,22,146,15,10,22,147,15,10,22,150,15,10,22,149,15, +11,22,151,15,10,22,148,15,10,22,152,15,10,22,153,15,10,22,154,15,10, +22,155,15,10,22,156,15,11,22,157,15,10,22,143,15,11,247,22,150,6,28, +248,22,151,2,193,192,11,27,28,23,195,2,249,22,129,16,23,197,1,6,11, +11,99,111,110,102,105,103,46,114,107,116,100,86,94,23,195,1,11,27,28,23, +194,2,28,248,22,187,15,23,195,2,249,22,142,6,23,196,1,80,144,43,8, +42,42,11,11,28,192,192,21,17,1,0,250,22,160,2,23,196,1,2,61,247, +22,173,8,250,22,160,2,195,2,61,247,22,173,8,28,248,22,155,7,23,195, +2,27,248,22,183,15,23,196,1,28,248,22,136,16,23,194,2,192,249,22,137, +16,23,195,1,27,247,80,144,43,54,42,28,23,193,2,192,86,94,23,193,1, +247,22,153,16,28,248,22,144,8,23,195,2,27,248,22,184,15,23,196,1,28, +248,22,136,16,23,194,2,192,249,22,137,16,23,195,1,27,247,80,144,43,54, +42,28,23,193,2,192,86,94,23,193,1,247,22,153,16,28,248,22,175,15,23, +195,2,28,248,22,136,16,23,195,2,193,249,22,137,16,23,196,1,27,247,80, +144,42,54,42,28,23,193,2,192,86,94,23,193,1,247,22,153,16,193,27,248, +22,152,16,2,57,28,248,22,136,16,23,194,2,248,22,139,16,23,194,1,28, +248,22,135,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16,249, +22,137,16,250,80,144,49,43,42,248,22,152,16,2,58,11,11,248,22,152,16, +2,59,86,95,23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,199,1, +23,196,1,27,250,80,144,44,43,42,248,22,152,16,2,58,23,197,1,10,28, +23,193,2,248,22,139,16,23,194,1,11,28,248,22,136,16,23,195,2,193,249, +22,137,16,23,196,1,27,249,80,144,44,55,40,39,80,144,44,8,43,42,28, +23,193,2,192,86,94,23,193,1,247,22,153,16,28,248,22,136,16,23,195,2, +248,22,139,16,23,195,1,28,248,22,135,16,23,195,2,90,144,42,11,89,146, +42,39,11,248,22,132,16,249,22,137,16,250,80,144,48,43,42,248,22,152,16, +2,58,11,11,248,22,152,16,2,59,86,95,23,195,1,23,194,1,248,22,139, +16,249,22,137,16,23,200,1,23,196,1,27,250,80,144,43,43,42,248,22,152, +16,2,58,23,198,1,10,28,23,193,2,248,22,139,16,23,194,1,11,28,248, +22,90,23,196,2,9,28,248,22,83,23,196,2,249,22,82,27,248,22,163,20, +23,199,2,28,248,22,155,7,23,194,2,27,248,22,183,15,23,195,1,28,248, +22,136,16,23,194,2,192,249,22,137,16,23,195,1,27,247,80,144,46,54,42, +28,23,193,2,192,86,94,23,193,1,247,22,153,16,28,248,22,144,8,23,194, +2,27,248,22,184,15,23,195,1,28,248,22,136,16,23,194,2,192,249,22,137, +16,23,195,1,27,247,80,144,46,54,42,28,23,193,2,192,86,94,23,193,1, +247,22,153,16,28,248,22,175,15,23,194,2,28,248,22,136,16,23,194,2,192, +249,22,137,16,23,195,1,27,247,80,144,45,54,42,28,23,193,2,192,86,94, +23,193,1,247,22,153,16,192,27,248,22,164,20,23,199,1,28,248,22,90,23, +194,2,9,28,248,22,83,23,194,2,249,22,82,248,80,144,45,60,42,248,22, +163,20,23,197,2,27,248,22,164,20,23,197,1,28,248,22,90,23,194,2,9, +28,248,22,83,23,194,2,249,22,82,248,80,144,48,60,42,248,22,163,20,23, +197,2,249,80,144,49,8,44,42,23,204,1,248,22,164,20,23,198,1,249,22, +96,23,202,2,249,80,144,49,8,44,42,23,204,1,248,22,164,20,23,198,1, +249,22,96,23,199,2,27,248,22,164,20,23,197,1,28,248,22,90,23,194,2, +9,28,248,22,83,23,194,2,249,22,82,248,80,144,48,60,42,248,22,163,20, +23,197,2,249,80,144,49,8,44,42,23,204,1,248,22,164,20,23,198,1,249, +22,96,23,202,2,249,80,144,49,8,44,42,23,204,1,248,22,164,20,23,198, +1,249,22,96,23,196,2,27,248,22,164,20,23,199,1,28,248,22,90,23,194, +2,9,28,248,22,83,23,194,2,249,22,82,248,80,144,45,60,42,248,22,163, +20,23,197,2,27,248,22,164,20,23,197,1,28,248,22,90,23,194,2,9,28, +248,22,83,23,194,2,249,22,82,248,80,144,48,60,42,248,22,163,20,23,197, +2,249,80,144,49,8,44,42,23,204,1,248,22,164,20,23,198,1,249,22,96, +23,202,2,249,80,144,49,8,44,42,23,204,1,248,22,164,20,23,198,1,249, +22,96,23,199,2,27,248,22,164,20,23,197,1,28,248,22,90,23,194,2,9, +28,248,22,83,23,194,2,249,22,82,248,80,144,48,60,42,248,22,163,20,23, +197,2,249,80,144,49,8,44,42,23,204,1,248,22,164,20,23,198,1,249,22, +96,23,202,2,249,80,144,49,8,44,42,23,204,1,248,22,164,20,23,198,1, +27,250,22,160,2,23,198,1,23,199,1,11,28,192,249,80,144,42,8,44,42, +198,194,196,27,248,22,152,16,2,60,28,248,22,136,16,23,194,2,248,22,139, +16,23,194,1,28,248,22,135,16,23,194,2,90,144,42,11,89,146,42,39,11, +248,22,132,16,249,22,137,16,250,80,144,49,43,42,248,22,152,16,2,58,11, +11,248,22,152,16,2,59,86,95,23,195,1,23,194,1,248,22,139,16,249,22, +137,16,23,199,1,23,196,1,27,250,80,144,44,43,42,248,22,152,16,2,58, +23,197,1,10,28,23,193,2,248,22,139,16,23,194,1,11,27,248,80,144,41, +58,42,249,80,144,43,55,40,40,80,144,43,8,45,42,27,27,250,22,160,2, +23,198,2,72,108,105,110,107,115,45,102,105,108,101,11,27,28,23,194,2,23, +194,1,86,94,23,194,1,249,22,129,16,27,250,22,160,2,23,202,2,71,115, +104,97,114,101,45,100,105,114,11,28,192,192,249,22,129,16,64,117,112,6,5, +5,115,104,97,114,101,2,62,28,248,22,155,7,23,194,2,27,248,22,183,15, +23,195,1,28,248,22,136,16,23,194,2,192,249,22,137,16,23,195,1,27,247, +80,144,47,54,42,28,23,193,2,192,86,94,23,193,1,247,22,153,16,28,248, +22,144,8,23,194,2,27,248,22,184,15,23,195,1,28,248,22,136,16,23,194, +2,192,249,22,137,16,23,195,1,27,247,80,144,47,54,42,28,23,193,2,192, +86,94,23,193,1,247,22,153,16,28,248,22,175,15,23,194,2,28,248,22,136, +16,23,194,2,192,249,22,137,16,23,195,1,27,247,80,144,46,54,42,28,23, +193,2,192,86,94,23,193,1,247,22,153,16,192,250,22,96,248,22,92,11,28, +247,22,160,16,28,247,22,161,16,248,22,92,250,22,129,16,248,22,152,16,2, +63,250,22,160,2,23,204,2,2,61,247,22,173,8,2,62,9,9,28,247,22, +161,16,250,80,144,47,8,23,42,23,200,1,1,18,108,105,110,107,115,45,115, +101,97,114,99,104,45,102,105,108,101,115,248,22,92,23,200,1,9,248,22,174, +13,23,194,1,249,22,16,80,144,41,8,26,41,28,248,22,130,13,23,197,2, +86,94,23,196,1,32,0,88,148,8,36,39,44,11,9,222,11,20,20,94,88, +148,8,36,39,46,11,9,223,3,33,126,23,196,1,32,128,2,88,148,39,40, +59,11,2,52,222,33,129,2,90,144,42,11,89,146,42,39,11,248,22,132,16, +23,197,1,86,95,23,195,1,23,194,1,28,248,22,175,15,23,194,2,28,248, +22,188,15,23,194,2,249,22,147,6,23,195,1,32,0,88,148,8,36,39,44, +11,9,222,11,90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,1,86, +95,23,195,1,23,194,1,28,248,22,175,15,23,194,2,28,248,22,188,15,23, +194,2,249,22,147,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11, +90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,1,86,95,23,195,1, +23,194,1,28,248,22,175,15,23,194,2,28,248,22,188,15,23,194,2,249,22, +147,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,90,144,42,11, +89,146,42,39,11,248,22,132,16,23,197,1,86,95,23,195,1,23,194,1,28, +248,22,175,15,23,194,2,28,248,22,188,15,23,194,2,249,22,147,6,23,195, +1,32,0,88,148,8,36,39,44,11,9,222,11,248,2,128,2,23,194,1,11, +11,11,11,32,130,2,88,148,8,36,40,58,11,2,52,222,33,131,2,27,249, +22,165,6,8,128,128,23,196,2,28,248,22,150,7,23,194,2,9,249,22,82, +23,195,1,27,249,22,165,6,8,128,128,23,199,2,28,248,22,150,7,23,194, +2,9,249,22,82,23,195,1,27,249,22,165,6,8,128,128,23,202,2,28,248, +22,150,7,23,194,2,9,249,22,82,23,195,1,27,249,22,165,6,8,128,128, +23,205,2,28,248,22,150,7,23,194,2,9,249,22,82,23,195,1,248,2,130, +2,23,206,1,27,249,22,165,6,8,128,128,23,196,2,28,248,22,144,8,23, +194,2,28,249,22,134,4,248,22,149,8,23,196,2,8,128,128,249,22,1,22, +156,8,249,22,82,23,197,1,27,249,22,165,6,8,128,128,23,201,2,28,248, +22,150,7,23,194,2,9,249,22,82,23,195,1,27,249,22,165,6,8,128,128, +23,204,2,28,248,22,150,7,23,194,2,9,249,22,82,23,195,1,27,249,22, +165,6,8,128,128,23,207,2,28,248,22,150,7,23,194,2,9,249,22,82,23, +195,1,27,249,22,165,6,8,128,128,23,210,2,28,248,22,150,7,23,194,2, +9,249,22,82,23,195,1,248,2,130,2,23,211,1,192,192,248,22,135,6,23, +194,1,20,13,144,80,144,40,8,28,40,80,144,40,8,46,42,27,28,249,22, +191,8,248,22,182,8,2,64,41,90,144,42,11,89,146,42,39,11,248,22,132, +16,23,198,2,86,95,23,195,1,23,194,1,28,248,22,175,15,23,194,2,28, +248,22,188,15,23,194,2,249,22,147,6,23,195,1,32,0,88,148,8,36,39, +44,11,9,222,11,90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,1, +86,95,23,195,1,23,194,1,28,248,22,175,15,23,194,2,28,248,22,188,15, +23,194,2,249,22,147,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222, +11,90,144,42,11,89,146,42,39,11,248,22,132,16,23,197,1,86,95,23,195, +1,23,194,1,28,248,22,175,15,23,194,2,28,248,22,188,15,23,194,2,249, +22,147,6,23,195,1,32,0,88,148,8,36,39,44,11,9,222,11,90,144,42, +11,89,146,42,39,11,248,22,132,16,23,197,1,86,95,23,195,1,23,194,1, +28,248,22,175,15,23,194,2,28,248,22,188,15,23,194,2,249,22,147,6,23, +195,1,32,0,88,148,8,36,39,44,11,9,222,11,248,2,128,2,23,194,1, +11,11,11,11,11,28,248,22,187,15,23,195,2,27,28,249,22,191,8,248,22, +182,8,2,64,41,249,22,147,6,23,197,2,32,0,88,148,8,36,39,44,11, +9,222,11,11,86,94,28,23,194,2,248,22,149,6,23,195,1,86,94,23,194, +1,12,249,22,82,27,248,22,190,5,23,199,1,250,22,46,22,37,88,148,39, +39,8,24,11,9,223,3,33,132,2,20,20,94,88,148,39,39,46,11,9,223, +3,33,133,2,23,196,1,194,249,22,82,11,194,28,28,23,195,2,28,248,22, +84,23,196,2,248,22,169,9,249,22,176,14,39,248,22,164,20,23,199,2,11, +11,194,86,94,23,195,1,249,22,14,20,20,94,88,148,8,32,39,61,16,4, +39,8,128,80,8,240,0,64,0,0,39,9,224,2,3,33,134,2,23,196,1, +80,144,41,8,26,41,27,248,22,169,9,194,28,192,192,248,22,169,9,248,22, +83,195,86,95,28,248,22,151,12,23,198,2,27,247,22,143,12,28,249,22,133, +12,23,195,2,2,65,251,22,139,12,23,197,1,2,65,250,22,139,8,6,42, +42,101,114,114,111,114,32,114,101,97,100,105,110,103,32,99,111,108,108,101,99, +116,105,111,110,32,108,105,110,107,115,32,102,105,108,101,32,126,115,58,32,126, +97,23,203,2,248,22,147,12,23,206,2,247,22,29,12,12,28,23,193,2,250, +22,158,2,80,144,45,8,25,41,23,198,1,249,22,82,23,198,1,21,17,0, +0,86,95,23,195,1,23,193,1,12,28,248,22,151,12,23,198,2,86,94,23, +197,1,248,23,195,1,247,22,140,2,196,88,148,39,40,58,8,240,0,0,0, +2,9,226,0,2,1,3,33,137,2,20,20,94,248,22,150,6,23,194,2,28, +248,22,150,7,248,22,150,6,23,195,1,12,248,22,178,11,6,30,30,101,120, +112,101,99,116,101,100,32,97,32,115,105,110,103,108,101,32,83,45,101,120,112, +114,101,115,115,105,111,110,248,22,135,6,23,194,1,28,248,22,91,193,28,28, +249,22,130,4,41,248,22,95,195,10,249,22,130,4,42,248,22,95,195,28,28, +248,22,155,7,248,22,83,194,10,28,249,22,171,9,2,66,248,22,163,20,195, +10,249,22,171,9,2,67,248,22,163,20,195,28,27,248,22,104,194,28,248,22, +175,15,193,10,28,248,22,155,7,193,28,248,22,134,16,193,10,248,22,135,16, +193,11,27,248,22,90,248,22,106,195,28,192,192,248,22,181,16,248,22,113,195, +11,11,11,11,28,248,22,188,15,249,22,129,16,23,196,2,23,198,2,27,248, +22,70,248,22,179,15,23,198,1,250,22,158,2,23,198,2,23,196,2,249,22, +82,23,199,1,250,22,160,2,23,203,1,23,201,1,9,12,250,22,158,2,23, +197,1,23,198,1,249,22,82,23,198,1,23,201,1,28,28,248,22,90,248,22, +106,23,197,2,10,249,22,172,16,248,22,113,23,198,2,247,22,173,8,27,248, +22,139,16,249,22,137,16,248,22,104,23,200,2,23,198,1,28,249,22,171,9, +248,22,163,20,23,199,2,2,67,86,94,23,196,1,249,22,3,20,20,94,88, +148,8,36,40,56,11,9,224,3,2,33,142,2,23,196,1,248,22,142,16,23, +196,1,28,249,22,171,9,248,22,163,20,23,199,2,2,66,86,94,23,196,1, 86,94,28,250,22,160,2,23,197,2,11,11,12,250,22,158,2,23,197,2,11, -9,249,22,166,2,23,196,2,20,20,95,88,148,8,36,38,50,11,9,224,3, -2,33,142,2,23,195,1,23,196,1,27,248,22,70,248,22,160,20,23,199,1, +9,249,22,166,2,23,196,2,20,20,95,88,148,8,36,41,53,11,9,224,3, +2,33,143,2,23,195,1,23,196,1,27,248,22,70,248,22,163,20,23,199,1, 250,22,158,2,23,198,2,23,196,2,249,22,82,248,22,131,2,23,200,1,250, 22,160,2,23,203,1,23,201,1,9,12,250,22,158,2,23,196,1,23,197,1, -248,22,97,23,199,1,27,28,28,23,194,2,248,22,168,9,248,22,83,23,196, -2,10,9,27,249,22,189,5,23,198,2,66,98,105,110,97,114,121,250,22,46, -22,37,88,148,8,36,36,44,11,9,223,3,33,138,2,20,20,94,88,148,36, -36,43,11,9,223,3,33,139,2,23,196,1,86,94,28,28,248,22,91,23,194, -2,249,22,4,32,0,88,148,8,36,37,45,11,9,222,33,140,2,23,195,2, -11,12,248,22,177,11,6,18,18,105,108,108,45,102,111,114,109,101,100,32,99, -111,110,116,101,110,116,27,247,22,140,2,27,90,144,39,11,89,146,39,36,11, -248,22,131,16,23,201,2,192,86,96,249,22,3,20,20,94,88,148,8,36,37, -54,11,9,224,2,3,33,143,2,23,195,1,23,197,1,249,22,166,2,195,88, -148,8,36,38,48,11,9,223,3,33,144,2,250,22,158,2,80,144,44,8,25, -38,23,200,1,249,22,82,23,201,1,198,193,20,13,144,80,144,37,8,28,37, -250,80,144,40,8,47,39,23,198,2,23,196,2,11,27,250,22,160,2,80,144, -41,8,25,38,23,197,2,21,143,11,17,0,0,27,248,22,83,23,195,2,27, -249,80,144,42,8,27,39,23,198,2,23,196,2,28,249,22,172,9,23,195,2, -23,196,1,248,22,161,20,195,86,94,23,195,1,20,13,144,80,144,40,8,28, -37,250,80,144,43,8,47,39,23,201,1,23,199,2,23,196,2,27,20,20,95, -88,148,8,36,36,52,8,240,0,0,0,2,9,225,5,4,1,33,145,2,23, -194,1,23,197,1,28,249,22,50,23,195,2,36,20,13,144,80,144,41,43,37, -26,29,80,144,8,34,44,37,249,22,33,11,80,144,8,36,43,37,22,144,15, -10,22,145,15,10,22,146,15,10,22,149,15,10,22,148,15,11,22,150,15,10, -22,147,15,10,22,151,15,10,22,152,15,10,22,153,15,10,22,154,15,10,22, -155,15,11,22,156,15,10,22,142,15,11,247,23,193,1,250,22,181,11,2,8, -2,53,23,196,1,248,22,8,20,20,94,88,148,36,37,8,43,16,4,8,128, -6,8,128,104,8,240,0,128,0,0,36,9,224,1,2,33,146,2,23,195,1, -0,7,35,114,120,34,47,43,34,28,248,22,154,7,23,195,2,27,249,22,169, -16,2,148,2,23,197,2,28,23,193,2,28,249,22,130,4,248,22,103,23,196, -2,248,22,184,3,248,22,157,7,23,199,2,249,22,7,250,22,176,7,23,200, -1,36,248,22,103,23,199,1,23,198,1,249,22,7,250,22,176,7,23,200,2, -36,248,22,103,23,199,2,249,22,82,249,22,176,7,23,201,1,248,22,105,23, -200,1,23,200,1,249,22,7,23,197,1,23,198,1,90,144,39,11,89,146,39, -36,11,248,22,131,16,23,198,1,86,94,23,195,1,28,249,22,170,9,23,195, -2,2,50,86,94,23,193,1,249,22,7,23,196,1,23,200,1,27,249,22,82, -23,197,1,23,201,1,28,248,22,154,7,23,195,2,27,249,22,169,16,2,148, +248,22,97,23,199,1,27,28,28,23,194,2,248,22,169,9,248,22,83,23,196, +2,10,9,27,249,22,190,5,23,198,2,68,98,105,110,97,114,121,250,22,46, +22,37,88,148,8,36,39,47,11,9,223,3,33,139,2,20,20,94,88,148,39, +39,46,11,9,223,3,33,140,2,23,196,1,86,94,28,28,248,22,91,23,194, +2,249,22,4,32,0,88,148,8,36,40,48,11,9,222,33,141,2,23,195,2, +11,12,248,22,178,11,6,18,18,105,108,108,45,102,111,114,109,101,100,32,99, +111,110,116,101,110,116,27,247,22,140,2,27,90,144,42,11,89,146,42,39,11, +248,22,132,16,23,201,2,192,86,96,249,22,3,20,20,94,88,148,8,36,40, +57,11,9,224,2,3,33,144,2,23,195,1,23,197,1,249,22,166,2,195,88, +148,8,36,41,51,11,9,223,3,33,145,2,250,22,158,2,80,144,47,8,25, +41,23,200,1,249,22,82,23,201,1,198,193,20,13,144,80,144,40,8,28,40, +250,80,144,43,8,47,42,23,198,2,23,196,2,11,27,250,22,160,2,80,144, +44,8,25,41,23,197,2,21,143,11,17,0,0,27,248,22,83,23,195,2,27, +249,80,144,45,8,27,42,23,198,2,23,196,2,28,249,22,173,9,23,195,2, +23,196,1,248,22,164,20,195,86,94,23,195,1,20,13,144,80,144,43,8,28, +40,250,80,144,46,8,47,42,23,201,1,23,199,2,23,196,2,27,20,20,95, +88,148,8,36,39,55,8,240,0,0,0,2,9,225,5,4,1,33,146,2,23, +194,1,23,197,1,28,249,22,50,23,195,2,39,20,13,144,80,144,44,46,40, +26,29,80,144,8,34,47,40,249,22,33,11,80,144,8,36,46,40,22,145,15, +10,22,146,15,10,22,147,15,10,22,150,15,10,22,149,15,11,22,151,15,10, +22,148,15,10,22,152,15,10,22,153,15,10,22,154,15,10,22,155,15,10,22, +156,15,11,22,157,15,10,22,143,15,11,247,23,193,1,250,22,182,11,2,9, +2,54,23,196,1,248,22,8,20,20,94,88,148,39,40,8,43,16,4,8,128, +6,8,128,104,8,240,0,128,0,0,39,9,224,1,2,33,147,2,23,195,1, +0,7,35,114,120,34,47,43,34,28,248,22,155,7,23,195,2,27,249,22,170, +16,2,149,2,23,197,2,28,23,193,2,28,249,22,130,4,248,22,103,23,196, +2,248,22,184,3,248,22,158,7,23,199,2,249,22,7,250,22,177,7,23,200, +1,39,248,22,103,23,199,1,23,198,1,249,22,7,250,22,177,7,23,200,2, +39,248,22,103,23,199,2,249,22,82,249,22,177,7,23,201,1,248,22,105,23, +200,1,23,200,1,249,22,7,23,197,1,23,198,1,90,144,42,11,89,146,42, +39,11,248,22,132,16,23,198,1,86,94,23,195,1,28,249,22,171,9,23,195, +2,2,51,86,94,23,193,1,249,22,7,23,196,1,23,200,1,27,249,22,82, +23,197,1,23,201,1,28,248,22,155,7,23,195,2,27,249,22,170,16,2,149, 2,23,197,2,28,23,193,2,28,249,22,130,4,248,22,103,23,196,2,248,22, -184,3,248,22,157,7,23,199,2,249,22,7,250,22,176,7,23,200,1,36,248, -22,103,23,199,1,23,196,1,249,22,7,250,22,176,7,23,200,2,36,248,22, -103,23,199,2,249,22,82,249,22,176,7,23,201,1,248,22,105,23,200,1,23, -198,1,249,22,7,23,197,1,23,196,1,90,144,39,11,89,146,39,36,11,248, -22,131,16,23,198,1,86,94,23,195,1,28,249,22,170,9,23,195,2,2,50, -86,94,23,193,1,249,22,7,23,196,1,23,198,1,249,80,144,45,8,31,39, +184,3,248,22,158,7,23,199,2,249,22,7,250,22,177,7,23,200,1,39,248, +22,103,23,199,1,23,196,1,249,22,7,250,22,177,7,23,200,2,39,248,22, +103,23,199,2,249,22,82,249,22,177,7,23,201,1,248,22,105,23,200,1,23, +198,1,249,22,7,23,197,1,23,196,1,90,144,42,11,89,146,42,39,11,248, +22,132,16,23,198,1,86,94,23,195,1,28,249,22,171,9,23,195,2,2,51, +86,94,23,193,1,249,22,7,23,196,1,23,198,1,249,80,144,48,8,31,42, 194,249,22,82,197,199,28,248,22,90,23,196,2,9,28,248,22,83,23,196,2, -28,248,22,151,2,248,22,160,20,23,197,2,250,22,96,249,22,2,22,131,2, -250,22,160,2,248,22,160,20,23,204,2,23,202,2,9,250,22,160,2,248,22, -160,20,23,202,2,11,9,27,248,22,161,20,23,200,1,28,248,22,90,23,194, -2,9,28,248,22,83,23,194,2,28,248,22,151,2,248,22,160,20,23,195,2, -250,22,96,249,22,2,22,131,2,250,22,160,2,248,22,160,20,23,202,2,23, -206,2,9,250,22,160,2,248,22,160,20,23,200,2,11,9,249,80,144,45,8, -48,39,23,203,1,248,22,161,20,23,199,1,27,248,80,144,42,8,30,39,248, -22,160,20,23,196,2,250,22,96,250,22,160,2,23,199,2,23,205,2,9,250, -22,160,2,23,199,1,11,9,249,80,144,46,8,48,39,23,204,1,248,22,161, -20,23,200,1,249,22,96,247,22,155,16,249,80,144,44,8,48,39,23,202,1, -248,22,161,20,23,198,1,27,248,80,144,38,8,30,39,248,22,160,20,23,198, +28,248,22,151,2,248,22,163,20,23,197,2,250,22,96,249,22,2,22,131,2, +250,22,160,2,248,22,163,20,23,204,2,23,202,2,9,250,22,160,2,248,22, +163,20,23,202,2,11,9,27,248,22,164,20,23,200,1,28,248,22,90,23,194, +2,9,28,248,22,83,23,194,2,28,248,22,151,2,248,22,163,20,23,195,2, +250,22,96,249,22,2,22,131,2,250,22,160,2,248,22,163,20,23,202,2,23, +206,2,9,250,22,160,2,248,22,163,20,23,200,2,11,9,249,80,144,48,8, +48,42,23,203,1,248,22,164,20,23,199,1,27,248,80,144,45,8,30,42,248, +22,163,20,23,196,2,250,22,96,250,22,160,2,23,199,2,23,205,2,9,250, +22,160,2,23,199,1,11,9,249,80,144,49,8,48,42,23,204,1,248,22,164, +20,23,200,1,249,22,96,247,22,156,16,249,80,144,47,8,48,42,23,202,1, +248,22,164,20,23,198,1,27,248,80,144,41,8,30,42,248,22,163,20,23,198, 2,250,22,96,250,22,160,2,23,199,2,23,201,2,9,250,22,160,2,23,199, -1,11,9,27,248,22,161,20,23,201,1,28,248,22,90,23,194,2,9,28,248, -22,83,23,194,2,28,248,22,151,2,248,22,160,20,23,195,2,250,22,96,249, -22,2,22,131,2,250,22,160,2,248,22,160,20,23,202,2,23,207,2,9,250, -22,160,2,248,22,160,20,23,200,2,11,9,249,80,144,46,8,48,39,23,204, -1,248,22,161,20,23,199,1,27,248,80,144,43,8,30,39,248,22,160,20,23, +1,11,9,27,248,22,164,20,23,201,1,28,248,22,90,23,194,2,9,28,248, +22,83,23,194,2,28,248,22,151,2,248,22,163,20,23,195,2,250,22,96,249, +22,2,22,131,2,250,22,160,2,248,22,163,20,23,202,2,23,207,2,9,250, +22,160,2,248,22,163,20,23,200,2,11,9,249,80,144,49,8,48,42,23,204, +1,248,22,164,20,23,199,1,27,248,80,144,46,8,30,42,248,22,163,20,23, 196,2,250,22,96,250,22,160,2,23,199,2,23,206,2,9,250,22,160,2,23, -199,1,11,9,249,80,144,47,8,48,39,23,205,1,248,22,161,20,23,200,1, -249,22,96,247,22,155,16,249,80,144,45,8,48,39,23,203,1,248,22,161,20, -23,198,1,249,22,96,247,22,155,16,27,248,22,161,20,23,199,1,28,248,22, -90,23,194,2,9,28,248,22,83,23,194,2,28,248,22,151,2,248,22,160,20, -23,195,2,250,22,96,249,22,2,22,131,2,250,22,160,2,248,22,160,20,23, -202,2,23,205,2,9,250,22,160,2,248,22,160,20,23,200,2,11,9,249,80, -144,44,8,48,39,23,202,1,248,22,161,20,23,199,1,27,248,80,144,41,8, -30,39,248,22,160,20,23,196,2,250,22,96,250,22,160,2,23,199,2,23,204, -2,9,250,22,160,2,23,199,1,11,9,249,80,144,45,8,48,39,23,203,1, -248,22,161,20,23,200,1,249,22,96,247,22,155,16,249,80,144,43,8,48,39, -23,201,1,248,22,161,20,23,198,1,32,151,2,88,148,8,36,37,47,11,2, -51,222,33,152,2,28,248,22,90,248,22,84,23,195,2,248,22,92,27,248,22, -160,20,195,28,248,22,174,15,193,248,22,178,15,193,192,250,22,93,27,248,22, -160,20,23,198,2,28,248,22,174,15,193,248,22,178,15,193,192,2,68,248,2, -151,2,248,22,161,20,23,198,1,250,22,138,8,6,7,7,10,32,126,97,32, -126,97,6,1,1,32,23,196,1,249,22,138,8,6,6,6,10,32,32,32,126, -97,248,22,134,2,23,196,1,32,155,2,88,148,36,38,48,11,66,102,105,108, -116,101,114,222,33,156,2,28,248,22,90,23,195,2,9,28,248,23,194,2,248, -22,83,23,196,2,249,22,82,248,22,160,20,23,197,2,249,2,155,2,23,197, -1,248,22,161,20,23,199,1,249,2,155,2,23,195,1,248,22,161,20,23,197, +199,1,11,9,249,80,144,50,8,48,42,23,205,1,248,22,164,20,23,200,1, +249,22,96,247,22,156,16,249,80,144,48,8,48,42,23,203,1,248,22,164,20, +23,198,1,249,22,96,247,22,156,16,27,248,22,164,20,23,199,1,28,248,22, +90,23,194,2,9,28,248,22,83,23,194,2,28,248,22,151,2,248,22,163,20, +23,195,2,250,22,96,249,22,2,22,131,2,250,22,160,2,248,22,163,20,23, +202,2,23,205,2,9,250,22,160,2,248,22,163,20,23,200,2,11,9,249,80, +144,47,8,48,42,23,202,1,248,22,164,20,23,199,1,27,248,80,144,44,8, +30,42,248,22,163,20,23,196,2,250,22,96,250,22,160,2,23,199,2,23,204, +2,9,250,22,160,2,23,199,1,11,9,249,80,144,48,8,48,42,23,203,1, +248,22,164,20,23,200,1,249,22,96,247,22,156,16,249,80,144,46,8,48,42, +23,201,1,248,22,164,20,23,198,1,32,152,2,88,148,8,36,40,50,11,2, +52,222,33,153,2,28,248,22,90,248,22,84,23,195,2,248,22,92,27,248,22, +163,20,195,28,248,22,175,15,193,248,22,179,15,193,192,250,22,93,27,248,22, +163,20,23,198,2,28,248,22,175,15,193,248,22,179,15,193,192,2,69,248,2, +152,2,248,22,164,20,23,198,1,250,22,139,8,6,7,7,10,32,126,97,32, +126,97,6,1,1,32,23,196,1,249,22,139,8,6,6,6,10,32,32,32,126, +97,248,22,134,2,23,196,1,32,156,2,88,148,39,41,51,11,68,102,105,108, +116,101,114,222,33,157,2,28,248,22,90,23,195,2,9,28,248,23,194,2,248, +22,83,23,196,2,249,22,82,248,22,163,20,23,197,2,249,2,156,2,23,197, +1,248,22,164,20,23,199,1,249,2,156,2,23,195,1,248,22,164,20,23,197, 1,28,248,22,90,23,201,2,86,95,23,200,1,23,199,1,28,23,201,2,28, -197,249,22,128,16,202,199,200,27,28,248,22,90,23,198,2,2,67,249,22,1, -22,177,7,248,2,151,2,23,200,2,248,23,199,1,251,22,138,8,6,70,70, +197,249,22,129,16,202,199,200,27,28,248,22,90,23,198,2,2,68,249,22,1, +22,178,7,248,2,152,2,23,200,2,248,23,199,1,251,22,139,8,6,70,70, 99,111,108,108,101,99,116,105,111,110,32,110,111,116,32,102,111,117,110,100,10, 32,32,99,111,108,108,101,99,116,105,111,110,58,32,126,115,10,32,32,105,110, 32,99,111,108,108,101,99,116,105,111,110,32,100,105,114,101,99,116,111,114,105, -101,115,58,126,97,126,97,28,248,22,90,23,203,1,28,248,22,174,15,23,202, -2,248,22,178,15,23,202,1,23,201,1,250,22,177,7,28,248,22,174,15,23, -205,2,248,22,178,15,23,205,1,23,204,1,2,68,23,201,2,249,22,1,22, -177,7,249,22,2,32,0,88,148,8,36,37,45,11,9,222,33,153,2,27,248, -22,95,23,206,2,27,248,22,95,247,22,155,16,28,249,22,131,4,249,22,186, -3,23,198,2,23,197,2,41,23,206,2,249,22,96,247,22,155,16,248,22,92, -249,22,138,8,6,50,50,46,46,46,32,91,126,97,32,97,100,100,105,116,105, +101,115,58,126,97,126,97,28,248,22,90,23,203,1,28,248,22,175,15,23,202, +2,248,22,179,15,23,202,1,23,201,1,250,22,178,7,28,248,22,175,15,23, +205,2,248,22,179,15,23,205,1,23,204,1,2,69,23,201,2,249,22,1,22, +178,7,249,22,2,32,0,88,148,8,36,40,48,11,9,222,33,154,2,27,248, +22,95,23,206,2,27,248,22,95,247,22,156,16,28,249,22,131,4,249,22,186, +3,23,198,2,23,197,2,44,23,206,2,249,22,96,247,22,156,16,248,22,92, +249,22,139,8,6,50,50,46,46,46,32,91,126,97,32,97,100,100,105,116,105, 111,110,97,108,32,108,105,110,107,101,100,32,97,110,100,32,112,97,99,107,97, 103,101,32,100,105,114,101,99,116,111,114,105,101,115,93,249,22,186,3,23,201, -1,23,200,1,28,249,22,5,22,133,2,23,202,2,250,22,138,8,6,49,49, +1,23,200,1,28,249,22,5,22,133,2,23,202,2,250,22,139,8,6,49,49, 10,32,32,32,115,117,98,45,99,111,108,108,101,99,116,105,111,110,58,32,126, 115,10,32,32,105,110,32,112,97,114,101,110,116,32,100,105,114,101,99,116,111, -114,105,101,115,58,126,97,23,201,1,249,22,1,22,177,7,249,22,2,32,0, -88,148,8,36,37,45,11,9,222,33,154,2,249,2,155,2,22,133,2,23,209, -1,86,95,23,200,1,23,198,1,2,67,27,248,22,83,23,202,2,27,28,248, -22,174,15,23,195,2,249,22,128,16,23,196,1,23,199,2,248,22,134,2,23, -195,1,28,28,248,22,174,15,248,22,160,20,23,204,2,248,22,187,15,23,194, -2,10,27,250,22,1,22,128,16,23,197,1,23,202,2,28,28,248,22,90,23, -200,2,10,248,22,187,15,23,194,2,28,23,201,2,28,28,250,80,144,42,8, -32,39,195,203,204,10,27,28,248,22,174,15,202,248,22,178,15,202,201,19,248, -22,157,7,23,195,2,27,28,249,22,134,4,23,196,4,40,28,249,22,160,7, -6,4,4,46,114,107,116,249,22,176,7,23,199,2,249,22,186,3,23,200,4, -40,249,22,177,7,250,22,176,7,23,200,1,36,249,22,186,3,23,201,4,40, -6,3,3,46,115,115,86,94,23,195,1,11,11,28,23,193,2,250,80,144,45, -8,32,39,198,23,196,1,23,15,11,2,28,200,249,22,128,16,194,202,192,26, -8,80,144,47,8,49,39,204,205,206,23,15,23,16,23,17,248,22,161,20,23, -19,28,23,19,23,19,200,28,200,249,22,128,16,194,202,192,26,8,80,144,47, -8,49,39,204,205,206,23,15,23,16,23,17,248,22,161,20,23,19,23,19,26, -8,80,144,46,8,49,39,203,204,205,206,23,15,23,16,248,22,161,20,23,18, -23,18,90,144,38,11,89,146,38,36,11,249,80,144,40,8,31,39,23,199,1, -23,200,1,27,248,22,70,28,248,22,174,15,195,248,22,178,15,195,194,27,27, -247,22,156,16,28,248,22,90,23,194,2,9,28,248,22,83,23,194,2,28,248, -22,151,2,248,22,160,20,23,195,2,250,22,96,249,22,2,22,131,2,250,22, -160,2,248,22,160,20,23,202,2,23,203,2,9,250,22,160,2,248,22,160,20, -23,200,2,11,9,249,80,144,46,8,48,39,23,200,1,248,22,161,20,23,199, -1,27,248,80,144,43,8,30,39,248,22,160,20,23,196,2,250,22,96,250,22, +114,105,101,115,58,126,97,23,201,1,249,22,1,22,178,7,249,22,2,32,0, +88,148,8,36,40,48,11,9,222,33,155,2,249,2,156,2,22,133,2,23,209, +1,86,95,23,200,1,23,198,1,2,68,27,248,22,83,23,202,2,27,28,248, +22,175,15,23,195,2,249,22,129,16,23,196,1,23,199,2,248,22,134,2,23, +195,1,28,28,248,22,175,15,248,22,163,20,23,204,2,248,22,188,15,23,194, +2,10,27,250,22,1,22,129,16,23,197,1,23,202,2,28,28,248,22,90,23, +200,2,10,248,22,188,15,23,194,2,28,23,201,2,28,28,250,80,144,45,8, +32,42,195,203,204,10,27,28,248,22,175,15,202,248,22,179,15,202,201,19,248, +22,158,7,23,195,2,27,28,249,22,134,4,23,196,4,43,28,249,22,161,7, +6,4,4,46,114,107,116,249,22,177,7,23,199,2,249,22,186,3,23,200,4, +43,249,22,178,7,250,22,177,7,23,200,1,39,249,22,186,3,23,201,4,43, +6,3,3,46,115,115,86,94,23,195,1,11,11,28,23,193,2,250,80,144,48, +8,32,42,198,23,196,1,23,15,11,2,28,200,249,22,129,16,194,202,192,26, +8,80,144,50,8,49,42,204,205,206,23,15,23,16,23,17,248,22,164,20,23, +19,28,23,19,23,19,200,28,200,249,22,129,16,194,202,192,26,8,80,144,50, +8,49,42,204,205,206,23,15,23,16,23,17,248,22,164,20,23,19,23,19,26, +8,80,144,49,8,49,42,203,204,205,206,23,15,23,16,248,22,164,20,23,18, +23,18,90,144,41,11,89,146,41,39,11,249,80,144,43,8,31,42,23,199,1, +23,200,1,27,248,22,70,28,248,22,175,15,195,248,22,179,15,195,194,27,27, +247,22,157,16,28,248,22,90,23,194,2,9,28,248,22,83,23,194,2,28,248, +22,151,2,248,22,163,20,23,195,2,250,22,96,249,22,2,22,131,2,250,22, +160,2,248,22,163,20,23,202,2,23,203,2,9,250,22,160,2,248,22,163,20, +23,200,2,11,9,249,80,144,49,8,48,42,23,200,1,248,22,164,20,23,199, +1,27,248,80,144,46,8,30,42,248,22,163,20,23,196,2,250,22,96,250,22, 160,2,23,199,2,23,202,2,9,250,22,160,2,23,199,1,11,9,249,80,144, -47,8,48,39,23,201,1,248,22,161,20,23,200,1,249,22,96,247,22,155,16, -249,80,144,45,8,48,39,23,199,1,248,22,161,20,23,198,1,26,8,80,144, -48,8,49,39,200,202,203,205,23,16,23,17,200,11,32,159,2,88,148,8,36, -39,56,11,2,51,222,33,160,2,28,248,22,135,4,23,196,2,86,94,23,195, -1,19,248,22,148,8,23,195,2,19,248,22,148,8,23,196,2,249,22,184,15, -27,251,22,155,8,250,22,154,8,23,205,2,36,23,204,4,2,52,249,22,154, -8,23,204,1,23,202,4,2,69,28,248,22,135,4,248,22,148,8,23,195,2, -86,94,23,193,1,251,22,183,11,2,38,2,70,2,71,202,192,28,248,22,175, -15,198,248,22,176,15,198,247,22,177,15,2,2,27,248,22,184,3,23,197,1, -28,249,22,170,9,8,46,249,22,149,8,23,198,2,23,197,2,27,248,22,183, -3,23,195,2,249,22,184,15,27,251,22,155,8,250,22,154,8,23,205,2,36, -23,204,1,2,72,249,22,154,8,23,204,1,23,202,1,2,69,28,248,22,135, -4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11,2,38,2,70, -2,71,202,192,28,248,22,175,15,198,248,22,176,15,198,247,22,177,15,250,2, -159,2,196,197,195,248,22,186,15,27,250,22,128,16,23,200,1,23,202,1,23, -199,1,28,249,22,170,9,23,197,2,64,115,97,109,101,192,28,248,22,133,16, -23,196,2,249,22,128,16,194,196,249,80,144,43,39,39,23,195,1,23,197,1, -249,22,5,20,20,96,88,148,36,37,51,44,9,226,5,4,2,6,33,161,2, -23,199,1,23,195,1,23,197,1,23,196,1,27,248,22,186,15,249,22,128,16, +50,8,48,42,23,201,1,248,22,164,20,23,200,1,249,22,96,247,22,156,16, +249,80,144,48,8,48,42,23,199,1,248,22,164,20,23,198,1,26,8,80,144, +51,8,49,42,200,202,203,205,23,16,23,17,200,11,32,160,2,88,148,8,36, +42,59,11,2,52,222,33,161,2,28,248,22,135,4,23,196,2,86,94,23,195, +1,19,248,22,149,8,23,195,2,19,248,22,149,8,23,196,2,249,22,185,15, +27,251,22,156,8,250,22,155,8,23,205,2,39,23,204,4,2,53,249,22,155, +8,23,204,1,23,202,4,2,70,28,248,22,135,4,248,22,149,8,23,195,2, +86,94,23,193,1,251,22,184,11,2,39,2,71,2,72,202,192,28,248,22,176, +15,198,248,22,177,15,198,247,22,178,15,2,2,27,248,22,184,3,23,197,1, +28,249,22,171,9,8,46,249,22,150,8,23,198,2,23,197,2,27,248,22,183, +3,23,195,2,249,22,185,15,27,251,22,156,8,250,22,155,8,23,205,2,39, +23,204,1,2,73,249,22,155,8,23,204,1,23,202,1,2,70,28,248,22,135, +4,248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11,2,39,2,71, +2,72,202,192,28,248,22,176,15,198,248,22,177,15,198,247,22,178,15,250,2, +160,2,196,197,195,248,22,187,15,27,250,22,129,16,23,200,1,23,202,1,23, +199,1,28,249,22,171,9,23,197,2,66,115,97,109,101,192,28,248,22,134,16, +23,196,2,249,22,129,16,194,196,249,80,144,46,42,42,23,195,1,23,197,1, +249,22,5,20,20,96,88,148,39,40,54,47,9,226,5,4,2,6,33,162,2, +23,199,1,23,195,1,23,197,1,23,196,1,27,248,22,187,15,249,22,129,16, 23,198,2,23,199,2,28,23,193,2,192,86,94,23,193,1,28,23,197,1,27, -90,144,38,11,89,146,38,36,11,250,80,144,43,8,34,39,23,202,2,2,69, -2,38,27,248,22,180,15,23,196,1,27,250,2,159,2,23,197,2,23,204,1, -248,22,148,8,23,198,1,28,248,22,175,15,195,249,22,128,16,196,194,192,27, -247,22,157,16,249,22,5,20,20,96,88,148,36,37,48,44,9,226,5,6,2, -3,33,162,2,23,196,1,23,195,1,23,199,1,247,22,158,16,11,86,95,28, -28,248,22,175,15,23,194,2,10,28,248,22,174,15,23,194,2,10,28,248,22, -154,7,23,194,2,28,248,22,133,16,23,194,2,10,248,22,134,16,23,194,2, -11,12,252,22,181,11,23,200,2,2,43,36,23,198,2,23,199,2,28,28,248, -22,154,7,23,195,2,10,248,22,143,8,23,195,2,86,94,23,194,1,12,252, -22,181,11,23,200,2,2,73,37,23,198,2,23,199,1,90,144,39,11,89,146, -39,36,11,248,22,131,16,23,197,2,86,94,23,195,1,86,94,28,23,193,2, -86,95,23,198,1,23,196,1,12,250,22,184,11,23,201,1,2,74,23,199,1, -249,22,7,23,195,1,23,196,1,32,165,2,88,148,8,36,43,58,11,2,75, -222,33,166,2,249,22,184,15,27,251,22,155,8,250,22,154,8,23,203,2,36, -23,207,1,23,205,1,249,23,203,1,23,202,1,23,208,1,28,248,22,154,7, -23,204,2,249,22,169,8,23,205,1,8,63,23,203,1,28,248,22,135,4,248, -22,148,8,23,195,2,86,94,23,193,1,251,22,183,11,2,38,2,70,2,71, -201,192,28,248,22,175,15,197,248,22,176,15,197,247,22,177,15,32,167,2,88, -148,8,36,42,8,24,11,2,51,222,33,168,2,28,248,22,135,4,23,199,2, -86,95,23,198,1,23,194,1,19,248,22,148,8,23,195,2,19,248,22,148,8, -23,196,2,249,22,184,15,27,251,22,155,8,250,22,154,8,23,205,2,36,23, -204,4,2,52,249,23,206,1,23,204,1,23,202,4,28,248,22,154,7,23,207, -2,249,22,169,8,23,208,1,8,63,23,206,1,28,248,22,135,4,248,22,148, -8,23,195,2,86,94,23,193,1,251,22,183,11,2,38,2,70,2,71,204,192, -28,248,22,175,15,200,248,22,176,15,200,247,22,177,15,2,2,27,248,22,184, -3,23,200,1,28,249,22,170,9,8,46,249,22,149,8,23,198,2,23,197,2, -27,248,22,183,3,23,195,2,249,22,184,15,27,251,22,155,8,250,22,154,8, -23,205,2,36,23,204,1,23,203,1,249,23,206,1,23,204,1,23,202,1,28, -248,22,154,7,23,207,2,249,22,169,8,23,208,1,8,63,23,206,1,28,248, -22,135,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11,2,38, -2,70,2,71,204,192,28,248,22,175,15,200,248,22,176,15,200,247,22,177,15, -28,248,22,135,4,23,194,2,86,95,23,195,1,23,193,1,19,248,22,148,8, -23,196,2,19,248,22,148,8,23,197,2,249,22,184,15,27,251,22,155,8,250, -22,154,8,23,206,2,36,23,204,4,2,52,249,23,207,1,23,205,1,23,202, -4,28,248,22,154,7,23,208,2,249,22,169,8,23,209,1,8,63,23,207,1, -28,248,22,135,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11, -2,38,2,70,2,71,205,192,28,248,22,175,15,201,248,22,176,15,201,247,22, -177,15,2,2,27,248,22,184,3,23,195,1,28,249,22,170,9,8,46,249,22, -149,8,23,199,2,23,197,2,27,248,22,183,3,23,195,2,249,22,184,15,27, -251,22,155,8,250,22,154,8,23,206,2,36,23,204,1,23,204,1,249,23,207, -1,23,205,1,23,202,1,28,248,22,154,7,23,208,2,249,22,169,8,23,209, -1,8,63,23,207,1,28,248,22,135,4,248,22,148,8,23,195,2,86,94,23, -193,1,251,22,183,11,2,38,2,70,2,71,205,192,28,248,22,175,15,201,248, -22,176,15,201,247,22,177,15,28,248,22,135,4,193,254,2,165,2,201,203,204, -205,248,22,148,8,202,2,52,248,22,148,8,202,27,248,22,184,3,194,28,249, -22,170,9,8,46,249,22,149,8,199,196,254,2,165,2,202,204,205,206,199,203, -248,22,183,3,200,253,2,167,2,201,202,203,204,205,198,90,144,38,11,89,146, -38,36,11,86,95,28,28,248,22,175,15,23,199,2,10,28,248,22,174,15,23, -199,2,10,28,248,22,154,7,23,199,2,28,248,22,133,16,23,199,2,10,248, -22,134,16,23,199,2,11,12,252,22,181,11,23,200,2,2,43,36,23,203,2, -23,204,2,28,28,248,22,154,7,23,200,2,10,248,22,143,8,23,200,2,12, -252,22,181,11,23,200,2,2,73,37,23,203,2,23,204,2,90,144,39,11,89, -146,39,36,11,248,22,131,16,23,202,2,86,94,23,195,1,86,94,28,192,12, -250,22,184,11,23,201,1,2,74,23,204,2,249,22,7,194,195,27,248,22,180, -15,23,196,1,27,19,248,22,148,8,23,196,2,28,248,22,135,4,23,194,4, -86,94,23,199,1,19,248,22,148,8,23,197,2,19,248,22,148,8,23,198,2, -249,22,184,15,27,251,22,155,8,250,22,154,8,23,207,2,36,23,204,4,2, -52,249,23,211,1,23,206,1,23,202,4,28,248,22,154,7,23,212,2,249,22, -169,8,23,213,1,8,63,23,211,1,28,248,22,135,4,248,22,148,8,23,195, -2,86,94,23,193,1,251,22,183,11,2,38,2,70,2,71,23,17,192,28,248, -22,175,15,205,248,22,176,15,205,247,22,177,15,2,2,27,248,22,184,3,23, -195,4,28,249,22,170,9,8,46,249,22,149,8,23,200,2,23,197,2,27,248, -22,183,3,23,195,2,249,22,184,15,27,251,22,155,8,250,22,154,8,23,207, -2,36,23,204,1,23,208,1,249,23,211,1,23,206,1,23,202,1,28,248,22, -154,7,23,212,2,249,22,169,8,23,213,1,8,63,23,211,1,28,248,22,135, -4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11,2,38,2,70, -2,71,23,17,192,28,248,22,175,15,205,248,22,176,15,205,247,22,177,15,28, -248,22,135,4,23,194,2,86,95,23,200,1,23,193,1,254,2,165,2,23,203, -2,23,208,1,23,209,1,23,210,1,248,22,148,8,23,204,2,2,52,248,22, -148,8,23,204,1,27,248,22,184,3,23,195,1,28,249,22,170,9,8,46,249, -22,149,8,23,201,2,23,197,2,254,2,165,2,23,204,1,23,209,1,23,210, -1,23,211,1,23,200,2,23,208,1,248,22,183,3,23,201,1,253,2,167,2, +90,144,41,11,89,146,41,39,11,250,80,144,46,8,34,42,23,202,2,2,70, +2,39,27,248,22,181,15,23,196,1,27,250,2,160,2,23,197,2,23,204,1, +248,22,149,8,23,198,1,28,248,22,176,15,195,249,22,129,16,196,194,192,27, +247,22,158,16,249,22,5,20,20,96,88,148,39,40,51,47,9,226,5,6,2, +3,33,163,2,23,196,1,23,195,1,23,199,1,247,22,159,16,11,86,95,28, +28,248,22,176,15,23,194,2,10,28,248,22,175,15,23,194,2,10,28,248,22, +155,7,23,194,2,28,248,22,134,16,23,194,2,10,248,22,135,16,23,194,2, +11,12,252,22,182,11,23,200,2,2,44,39,23,198,2,23,199,2,28,28,248, +22,155,7,23,195,2,10,248,22,144,8,23,195,2,86,94,23,194,1,12,252, +22,182,11,23,200,2,2,74,40,23,198,2,23,199,1,90,144,42,11,89,146, +42,39,11,248,22,132,16,23,197,2,86,94,23,195,1,86,94,28,23,193,2, +86,95,23,198,1,23,196,1,12,250,22,185,11,23,201,1,2,75,23,199,1, +249,22,7,23,195,1,23,196,1,32,166,2,88,148,8,36,46,61,11,2,76, +222,33,167,2,249,22,185,15,27,251,22,156,8,250,22,155,8,23,203,2,39, +23,207,1,23,205,1,249,23,203,1,23,202,1,23,208,1,28,248,22,155,7, +23,204,2,249,22,170,8,23,205,1,8,63,23,203,1,28,248,22,135,4,248, +22,149,8,23,195,2,86,94,23,193,1,251,22,184,11,2,39,2,71,2,72, +201,192,28,248,22,176,15,197,248,22,177,15,197,247,22,178,15,32,168,2,88, +148,8,36,45,8,24,11,2,52,222,33,169,2,28,248,22,135,4,23,199,2, +86,95,23,198,1,23,194,1,19,248,22,149,8,23,195,2,19,248,22,149,8, +23,196,2,249,22,185,15,27,251,22,156,8,250,22,155,8,23,205,2,39,23, +204,4,2,53,249,23,206,1,23,204,1,23,202,4,28,248,22,155,7,23,207, +2,249,22,170,8,23,208,1,8,63,23,206,1,28,248,22,135,4,248,22,149, +8,23,195,2,86,94,23,193,1,251,22,184,11,2,39,2,71,2,72,204,192, +28,248,22,176,15,200,248,22,177,15,200,247,22,178,15,2,2,27,248,22,184, +3,23,200,1,28,249,22,171,9,8,46,249,22,150,8,23,198,2,23,197,2, +27,248,22,183,3,23,195,2,249,22,185,15,27,251,22,156,8,250,22,155,8, +23,205,2,39,23,204,1,23,203,1,249,23,206,1,23,204,1,23,202,1,28, +248,22,155,7,23,207,2,249,22,170,8,23,208,1,8,63,23,206,1,28,248, +22,135,4,248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11,2,39, +2,71,2,72,204,192,28,248,22,176,15,200,248,22,177,15,200,247,22,178,15, +28,248,22,135,4,23,194,2,86,95,23,195,1,23,193,1,19,248,22,149,8, +23,196,2,19,248,22,149,8,23,197,2,249,22,185,15,27,251,22,156,8,250, +22,155,8,23,206,2,39,23,204,4,2,53,249,23,207,1,23,205,1,23,202, +4,28,248,22,155,7,23,208,2,249,22,170,8,23,209,1,8,63,23,207,1, +28,248,22,135,4,248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11, +2,39,2,71,2,72,205,192,28,248,22,176,15,201,248,22,177,15,201,247,22, +178,15,2,2,27,248,22,184,3,23,195,1,28,249,22,171,9,8,46,249,22, +150,8,23,199,2,23,197,2,27,248,22,183,3,23,195,2,249,22,185,15,27, +251,22,156,8,250,22,155,8,23,206,2,39,23,204,1,23,204,1,249,23,207, +1,23,205,1,23,202,1,28,248,22,155,7,23,208,2,249,22,170,8,23,209, +1,8,63,23,207,1,28,248,22,135,4,248,22,149,8,23,195,2,86,94,23, +193,1,251,22,184,11,2,39,2,71,2,72,205,192,28,248,22,176,15,201,248, +22,177,15,201,247,22,178,15,28,248,22,135,4,193,254,2,166,2,201,203,204, +205,248,22,149,8,202,2,53,248,22,149,8,202,27,248,22,184,3,194,28,249, +22,171,9,8,46,249,22,150,8,199,196,254,2,166,2,202,204,205,206,199,203, +248,22,183,3,200,253,2,168,2,201,202,203,204,205,198,90,144,41,11,89,146, +41,39,11,86,95,28,28,248,22,176,15,23,199,2,10,28,248,22,175,15,23, +199,2,10,28,248,22,155,7,23,199,2,28,248,22,134,16,23,199,2,10,248, +22,135,16,23,199,2,11,12,252,22,182,11,23,200,2,2,44,39,23,203,2, +23,204,2,28,28,248,22,155,7,23,200,2,10,248,22,144,8,23,200,2,12, +252,22,182,11,23,200,2,2,74,40,23,203,2,23,204,2,90,144,42,11,89, +146,42,39,11,248,22,132,16,23,202,2,86,94,23,195,1,86,94,28,192,12, +250,22,185,11,23,201,1,2,75,23,204,2,249,22,7,194,195,27,248,22,181, +15,23,196,1,27,19,248,22,149,8,23,196,2,28,248,22,135,4,23,194,4, +86,94,23,199,1,19,248,22,149,8,23,197,2,19,248,22,149,8,23,198,2, +249,22,185,15,27,251,22,156,8,250,22,155,8,23,207,2,39,23,204,4,2, +53,249,23,211,1,23,206,1,23,202,4,28,248,22,155,7,23,212,2,249,22, +170,8,23,213,1,8,63,23,211,1,28,248,22,135,4,248,22,149,8,23,195, +2,86,94,23,193,1,251,22,184,11,2,39,2,71,2,72,23,17,192,28,248, +22,176,15,205,248,22,177,15,205,247,22,178,15,2,2,27,248,22,184,3,23, +195,4,28,249,22,171,9,8,46,249,22,150,8,23,200,2,23,197,2,27,248, +22,183,3,23,195,2,249,22,185,15,27,251,22,156,8,250,22,155,8,23,207, +2,39,23,204,1,23,208,1,249,23,211,1,23,206,1,23,202,1,28,248,22, +155,7,23,212,2,249,22,170,8,23,213,1,8,63,23,211,1,28,248,22,135, +4,248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11,2,39,2,71, +2,72,23,17,192,28,248,22,176,15,205,248,22,177,15,205,247,22,178,15,28, +248,22,135,4,23,194,2,86,95,23,200,1,23,193,1,254,2,166,2,23,203, +2,23,208,1,23,209,1,23,210,1,248,22,149,8,23,204,2,2,53,248,22, +149,8,23,204,1,27,248,22,184,3,23,195,1,28,249,22,171,9,8,46,249, +22,150,8,23,201,2,23,197,2,254,2,166,2,23,204,1,23,209,1,23,210, +1,23,211,1,23,200,2,23,208,1,248,22,183,3,23,201,1,253,2,168,2, 23,203,1,23,207,1,23,208,1,23,209,1,23,210,1,23,199,1,2,28,248, -22,175,15,195,249,22,128,16,196,194,192,32,170,2,88,148,8,36,40,58,11, -2,51,222,33,171,2,28,248,22,135,4,23,197,2,86,94,23,196,1,19,248, -22,148,8,23,195,2,35,248,22,148,8,23,196,2,249,22,184,15,27,251,22, -155,8,250,22,154,8,23,205,1,36,23,204,4,2,52,2,52,28,248,22,154, -7,23,205,2,249,22,169,8,23,206,1,8,63,23,204,1,28,248,22,135,4, -248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11,2,38,2,70,2, -71,202,192,28,248,22,175,15,198,248,22,176,15,198,247,22,177,15,2,27,248, -22,184,3,23,198,1,28,249,22,170,9,8,46,249,22,149,8,23,198,2,23, -197,2,35,248,22,183,3,23,195,2,249,22,184,15,27,251,22,155,8,250,22, -154,8,23,205,1,36,23,204,1,2,52,2,52,28,248,22,154,7,23,205,2, -249,22,169,8,23,206,1,8,63,23,204,1,28,248,22,135,4,248,22,148,8, -23,195,2,86,94,23,193,1,251,22,183,11,2,38,2,70,2,71,202,192,28, -248,22,175,15,198,248,22,176,15,198,247,22,177,15,28,248,22,135,4,23,194, -2,86,94,23,193,1,19,248,22,148,8,23,196,2,35,248,22,148,8,23,197, -2,249,22,184,15,27,251,22,155,8,250,22,154,8,23,206,1,36,23,204,4, -2,52,2,52,28,248,22,154,7,23,206,2,249,22,169,8,23,207,1,8,63, -23,205,1,28,248,22,135,4,248,22,148,8,23,195,2,86,94,23,193,1,251, -22,183,11,2,38,2,70,2,71,203,192,28,248,22,175,15,199,248,22,176,15, -199,247,22,177,15,2,27,248,22,184,3,23,195,1,28,249,22,170,9,8,46, -249,22,149,8,23,199,2,23,197,2,35,248,22,183,3,23,195,2,249,22,184, -15,27,251,22,155,8,250,22,154,8,23,206,1,36,23,204,1,2,52,2,52, -28,248,22,154,7,23,206,2,249,22,169,8,23,207,1,8,63,23,205,1,28, -248,22,135,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11,2, -38,2,70,2,71,203,192,28,248,22,175,15,199,248,22,176,15,199,247,22,177, -15,251,2,170,2,198,199,200,196,90,144,38,11,89,146,38,36,11,86,95,28, -28,248,22,175,15,23,196,2,10,28,248,22,174,15,23,196,2,10,28,248,22, -154,7,23,196,2,28,248,22,133,16,23,196,2,10,248,22,134,16,23,196,2, -11,12,252,22,181,11,2,38,2,43,36,23,200,2,23,201,2,28,28,248,22, -154,7,23,197,2,10,248,22,143,8,23,197,2,12,252,22,181,11,2,38,2, -73,37,23,200,2,23,201,2,90,144,39,11,89,146,39,36,11,248,22,131,16, -23,199,2,86,94,23,195,1,86,94,28,192,12,250,22,184,11,2,38,2,74, -23,201,2,249,22,7,194,195,27,248,22,180,15,23,196,1,27,251,2,170,2, -23,198,2,23,201,1,23,202,1,248,22,148,8,23,199,1,28,248,22,175,15, -195,249,22,128,16,196,194,192,2,52,252,80,144,41,8,35,39,2,38,2,52, -32,0,88,148,8,36,38,43,11,9,222,33,173,2,198,199,32,175,2,88,148, -8,36,40,57,11,2,51,222,33,178,2,32,176,2,88,148,8,36,42,57,11, -2,75,222,33,177,2,249,22,184,15,27,251,22,155,8,250,22,154,8,23,203, -2,36,23,206,1,23,204,1,249,22,154,8,23,202,1,23,207,1,28,248,22, -154,7,23,203,2,249,22,169,8,23,204,1,8,63,23,202,1,28,248,22,135, -4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11,2,38,2,70, -2,71,200,192,28,248,22,175,15,196,248,22,176,15,196,247,22,177,15,28,248, -22,135,4,23,197,2,86,94,23,196,1,19,248,22,148,8,23,195,2,19,248, -22,148,8,23,196,2,249,22,184,15,27,251,22,155,8,250,22,154,8,23,205, -2,36,23,204,4,2,52,249,22,154,8,23,204,1,23,202,4,28,248,22,154, -7,23,205,2,249,22,169,8,23,206,1,8,63,23,204,1,28,248,22,135,4, -248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11,2,38,2,70,2, -71,202,192,28,248,22,175,15,198,248,22,176,15,198,247,22,177,15,2,2,27, -248,22,184,3,23,198,1,28,249,22,170,9,8,46,249,22,149,8,23,198,2, -23,197,2,27,248,22,183,3,23,195,2,249,22,184,15,27,251,22,155,8,250, -22,154,8,23,205,2,36,23,204,1,2,72,249,22,154,8,23,204,1,23,202, -1,28,248,22,154,7,23,205,2,249,22,169,8,23,206,1,8,63,23,204,1, -28,248,22,135,4,248,22,148,8,23,195,2,86,94,23,193,1,251,22,183,11, -2,38,2,70,2,71,202,192,28,248,22,175,15,198,248,22,176,15,198,247,22, -177,15,28,248,22,135,4,193,253,2,176,2,199,200,201,248,22,148,8,200,2, -52,248,22,148,8,200,27,248,22,184,3,194,28,249,22,170,9,8,46,249,22, -149,8,198,196,253,2,176,2,200,201,202,198,2,72,248,22,183,3,199,251,2, -175,2,198,199,200,196,90,144,38,11,89,146,38,36,11,86,95,28,28,248,22, -175,15,23,196,2,10,28,248,22,174,15,23,196,2,10,28,248,22,154,7,23, -196,2,28,248,22,133,16,23,196,2,10,248,22,134,16,23,196,2,11,12,252, -22,181,11,2,38,2,43,36,23,200,2,23,201,2,28,28,248,22,154,7,23, -197,2,10,248,22,143,8,23,197,2,12,252,22,181,11,2,38,2,73,37,23, -200,2,23,201,2,90,144,39,11,89,146,39,36,11,248,22,131,16,23,199,2, -86,94,23,195,1,86,94,28,192,12,250,22,184,11,2,38,2,74,23,201,2, -249,22,7,194,195,27,248,22,180,15,23,196,1,27,251,2,175,2,23,198,2, -23,201,1,23,202,1,248,22,148,8,23,199,1,28,248,22,175,15,195,249,22, -128,16,196,194,192,252,80,144,41,8,35,39,2,38,2,72,22,154,8,198,199, -249,247,22,177,5,23,195,1,11,249,247,22,177,5,194,11,28,248,22,90,23, -195,2,9,27,27,248,22,83,23,197,2,28,248,22,135,16,23,194,2,248,22, -138,16,23,194,1,28,248,22,134,16,23,194,2,90,144,39,11,89,146,39,36, -11,248,22,131,16,249,22,136,16,250,80,144,47,40,39,248,22,151,16,2,57, -11,11,248,22,151,16,2,58,86,95,23,195,1,23,194,1,248,22,138,16,249, -22,136,16,23,199,1,23,196,1,27,250,80,144,42,40,39,248,22,151,16,2, -57,23,197,1,10,28,23,193,2,248,22,138,16,23,194,1,11,28,23,193,2, -249,22,82,248,22,138,16,249,22,136,16,23,198,1,247,22,152,16,27,248,22, -161,20,23,199,1,28,248,22,90,23,194,2,9,27,248,80,144,42,53,39,248, -22,83,23,196,2,28,23,193,2,249,22,82,248,22,138,16,249,22,136,16,23, -198,1,247,22,152,16,248,80,144,44,8,50,39,248,22,161,20,23,198,1,86, -94,23,193,1,248,80,144,42,8,50,39,248,22,161,20,23,196,1,86,94,23, -193,1,27,248,22,161,20,23,197,1,28,248,22,90,23,194,2,9,27,248,80, -144,40,53,39,248,22,83,23,196,2,28,23,193,2,249,22,82,248,22,138,16, -249,22,136,16,23,198,1,247,22,152,16,248,80,144,42,8,50,39,248,22,161, -20,23,198,1,86,94,23,193,1,248,80,144,40,8,50,39,248,22,161,20,23, +22,176,15,195,249,22,129,16,196,194,192,32,171,2,88,148,8,36,43,61,11, +2,52,222,33,172,2,28,248,22,135,4,23,197,2,86,94,23,196,1,19,248, +22,149,8,23,195,2,35,248,22,149,8,23,196,2,249,22,185,15,27,251,22, +156,8,250,22,155,8,23,205,1,39,23,204,4,2,53,2,53,28,248,22,155, +7,23,205,2,249,22,170,8,23,206,1,8,63,23,204,1,28,248,22,135,4, +248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11,2,39,2,71,2, +72,202,192,28,248,22,176,15,198,248,22,177,15,198,247,22,178,15,2,27,248, +22,184,3,23,198,1,28,249,22,171,9,8,46,249,22,150,8,23,198,2,23, +197,2,35,248,22,183,3,23,195,2,249,22,185,15,27,251,22,156,8,250,22, +155,8,23,205,1,39,23,204,1,2,53,2,53,28,248,22,155,7,23,205,2, +249,22,170,8,23,206,1,8,63,23,204,1,28,248,22,135,4,248,22,149,8, +23,195,2,86,94,23,193,1,251,22,184,11,2,39,2,71,2,72,202,192,28, +248,22,176,15,198,248,22,177,15,198,247,22,178,15,28,248,22,135,4,23,194, +2,86,94,23,193,1,19,248,22,149,8,23,196,2,35,248,22,149,8,23,197, +2,249,22,185,15,27,251,22,156,8,250,22,155,8,23,206,1,39,23,204,4, +2,53,2,53,28,248,22,155,7,23,206,2,249,22,170,8,23,207,1,8,63, +23,205,1,28,248,22,135,4,248,22,149,8,23,195,2,86,94,23,193,1,251, +22,184,11,2,39,2,71,2,72,203,192,28,248,22,176,15,199,248,22,177,15, +199,247,22,178,15,2,27,248,22,184,3,23,195,1,28,249,22,171,9,8,46, +249,22,150,8,23,199,2,23,197,2,35,248,22,183,3,23,195,2,249,22,185, +15,27,251,22,156,8,250,22,155,8,23,206,1,39,23,204,1,2,53,2,53, +28,248,22,155,7,23,206,2,249,22,170,8,23,207,1,8,63,23,205,1,28, +248,22,135,4,248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11,2, +39,2,71,2,72,203,192,28,248,22,176,15,199,248,22,177,15,199,247,22,178, +15,251,2,171,2,198,199,200,196,90,144,41,11,89,146,41,39,11,86,95,28, +28,248,22,176,15,23,196,2,10,28,248,22,175,15,23,196,2,10,28,248,22, +155,7,23,196,2,28,248,22,134,16,23,196,2,10,248,22,135,16,23,196,2, +11,12,252,22,182,11,2,39,2,44,39,23,200,2,23,201,2,28,28,248,22, +155,7,23,197,2,10,248,22,144,8,23,197,2,12,252,22,182,11,2,39,2, +74,40,23,200,2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,132,16, +23,199,2,86,94,23,195,1,86,94,28,192,12,250,22,185,11,2,39,2,75, +23,201,2,249,22,7,194,195,27,248,22,181,15,23,196,1,27,251,2,171,2, +23,198,2,23,201,1,23,202,1,248,22,149,8,23,199,1,28,248,22,176,15, +195,249,22,129,16,196,194,192,2,53,252,80,144,44,8,35,42,2,39,2,53, +32,0,88,148,8,36,41,46,11,9,222,33,174,2,198,199,32,176,2,88,148, +8,36,43,60,11,2,52,222,33,179,2,32,177,2,88,148,8,36,45,60,11, +2,76,222,33,178,2,249,22,185,15,27,251,22,156,8,250,22,155,8,23,203, +2,39,23,206,1,23,204,1,249,22,155,8,23,202,1,23,207,1,28,248,22, +155,7,23,203,2,249,22,170,8,23,204,1,8,63,23,202,1,28,248,22,135, +4,248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11,2,39,2,71, +2,72,200,192,28,248,22,176,15,196,248,22,177,15,196,247,22,178,15,28,248, +22,135,4,23,197,2,86,94,23,196,1,19,248,22,149,8,23,195,2,19,248, +22,149,8,23,196,2,249,22,185,15,27,251,22,156,8,250,22,155,8,23,205, +2,39,23,204,4,2,53,249,22,155,8,23,204,1,23,202,4,28,248,22,155, +7,23,205,2,249,22,170,8,23,206,1,8,63,23,204,1,28,248,22,135,4, +248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11,2,39,2,71,2, +72,202,192,28,248,22,176,15,198,248,22,177,15,198,247,22,178,15,2,2,27, +248,22,184,3,23,198,1,28,249,22,171,9,8,46,249,22,150,8,23,198,2, +23,197,2,27,248,22,183,3,23,195,2,249,22,185,15,27,251,22,156,8,250, +22,155,8,23,205,2,39,23,204,1,2,73,249,22,155,8,23,204,1,23,202, +1,28,248,22,155,7,23,205,2,249,22,170,8,23,206,1,8,63,23,204,1, +28,248,22,135,4,248,22,149,8,23,195,2,86,94,23,193,1,251,22,184,11, +2,39,2,71,2,72,202,192,28,248,22,176,15,198,248,22,177,15,198,247,22, +178,15,28,248,22,135,4,193,253,2,177,2,199,200,201,248,22,149,8,200,2, +53,248,22,149,8,200,27,248,22,184,3,194,28,249,22,171,9,8,46,249,22, +150,8,198,196,253,2,177,2,200,201,202,198,2,73,248,22,183,3,199,251,2, +176,2,198,199,200,196,90,144,41,11,89,146,41,39,11,86,95,28,28,248,22, +176,15,23,196,2,10,28,248,22,175,15,23,196,2,10,28,248,22,155,7,23, +196,2,28,248,22,134,16,23,196,2,10,248,22,135,16,23,196,2,11,12,252, +22,182,11,2,39,2,44,39,23,200,2,23,201,2,28,28,248,22,155,7,23, +197,2,10,248,22,144,8,23,197,2,12,252,22,182,11,2,39,2,74,40,23, +200,2,23,201,2,90,144,42,11,89,146,42,39,11,248,22,132,16,23,199,2, +86,94,23,195,1,86,94,28,192,12,250,22,185,11,2,39,2,75,23,201,2, +249,22,7,194,195,27,248,22,181,15,23,196,1,27,251,2,176,2,23,198,2, +23,201,1,23,202,1,248,22,149,8,23,199,1,28,248,22,176,15,195,249,22, +129,16,196,194,192,252,80,144,44,8,35,42,2,39,2,73,22,155,8,198,199, +249,247,22,178,5,23,195,1,11,249,247,22,178,5,194,11,28,248,22,90,23, +195,2,9,27,27,248,22,83,23,197,2,28,248,22,136,16,23,194,2,248,22, +139,16,23,194,1,28,248,22,135,16,23,194,2,90,144,42,11,89,146,42,39, +11,248,22,132,16,249,22,137,16,250,80,144,50,43,42,248,22,152,16,2,58, +11,11,248,22,152,16,2,59,86,95,23,195,1,23,194,1,248,22,139,16,249, +22,137,16,23,199,1,23,196,1,27,250,80,144,45,43,42,248,22,152,16,2, +58,23,197,1,10,28,23,193,2,248,22,139,16,23,194,1,11,28,23,193,2, +249,22,82,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16,27,248,22, +164,20,23,199,1,28,248,22,90,23,194,2,9,27,248,80,144,45,56,42,248, +22,83,23,196,2,28,23,193,2,249,22,82,248,22,139,16,249,22,137,16,23, +198,1,247,22,153,16,248,80,144,47,8,50,42,248,22,164,20,23,198,1,86, +94,23,193,1,248,80,144,45,8,50,42,248,22,164,20,23,196,1,86,94,23, +193,1,27,248,22,164,20,23,197,1,28,248,22,90,23,194,2,9,27,248,80, +144,43,56,42,248,22,83,23,196,2,28,23,193,2,249,22,82,248,22,139,16, +249,22,137,16,23,198,1,247,22,153,16,248,80,144,45,8,50,42,248,22,164, +20,23,198,1,86,94,23,193,1,248,80,144,43,8,50,42,248,22,164,20,23, 196,1,28,248,22,90,23,195,2,9,27,27,248,22,83,23,197,2,28,248,22, -135,16,23,194,2,248,22,138,16,23,194,1,28,248,22,134,16,23,194,2,90, -144,39,11,89,146,39,36,11,248,22,131,16,249,22,136,16,250,80,144,47,40, -39,248,22,151,16,2,57,11,11,248,22,151,16,2,58,86,95,23,195,1,23, -194,1,248,22,138,16,249,22,136,16,23,199,1,23,196,1,27,250,80,144,42, -40,39,248,22,151,16,2,57,23,197,1,10,28,23,193,2,248,22,138,16,23, -194,1,11,28,23,193,2,249,22,82,248,22,138,16,249,22,136,16,23,198,1, -247,22,152,16,27,248,22,161,20,23,199,1,28,248,22,90,23,194,2,9,27, -248,80,144,42,53,39,248,22,83,23,196,2,28,23,193,2,249,22,82,248,22, -138,16,249,22,136,16,23,198,1,247,22,152,16,248,80,144,44,8,51,39,248, -22,161,20,23,198,1,86,94,23,193,1,248,80,144,42,8,51,39,248,22,161, -20,23,196,1,86,94,23,193,1,27,248,22,161,20,23,197,1,28,248,22,90, -23,194,2,9,27,248,80,144,40,53,39,248,22,83,23,196,2,28,23,193,2, -249,22,82,248,22,138,16,249,22,136,16,23,198,1,247,22,152,16,248,80,144, -42,8,51,39,248,22,161,20,23,198,1,86,94,23,193,1,248,80,144,40,8, -51,39,248,22,161,20,23,196,1,27,248,22,151,16,2,59,28,248,22,135,16, -23,194,2,248,22,138,16,23,194,1,28,248,22,134,16,23,194,2,90,144,39, -11,89,146,39,36,11,248,22,131,16,249,22,136,16,250,80,144,46,40,39,248, -22,151,16,2,57,11,11,248,22,151,16,2,58,86,95,23,195,1,23,194,1, -248,22,138,16,249,22,136,16,23,199,1,23,196,1,27,250,80,144,41,40,39, -248,22,151,16,2,57,23,197,1,10,28,23,193,2,248,22,138,16,23,194,1, -11,28,248,22,90,23,195,2,9,27,27,248,22,83,23,197,2,28,248,22,135, -16,23,194,2,248,22,138,16,23,194,1,28,248,22,134,16,23,194,2,90,144, -39,11,89,146,39,36,11,248,22,131,16,249,22,136,16,250,80,144,47,40,39, -248,22,151,16,2,57,11,11,248,22,151,16,2,58,86,95,23,195,1,23,194, -1,248,22,138,16,249,22,136,16,23,199,1,23,196,1,27,250,80,144,42,40, -39,248,22,151,16,2,57,23,197,1,10,28,23,193,2,248,22,138,16,23,194, -1,11,28,23,193,2,249,22,82,248,22,138,16,249,22,136,16,23,198,1,247, -22,152,16,27,248,22,161,20,23,199,1,28,248,22,90,23,194,2,9,27,27, -248,22,83,23,196,2,28,248,22,135,16,23,194,2,248,22,138,16,23,194,1, -28,248,22,134,16,23,194,2,90,144,39,11,89,146,39,36,11,248,22,131,16, -249,22,136,16,250,80,144,51,40,39,248,22,151,16,2,57,11,11,248,22,151, -16,2,58,86,95,23,195,1,23,194,1,248,22,138,16,249,22,136,16,23,199, -1,23,196,1,27,250,80,144,46,40,39,248,22,151,16,2,57,23,197,1,10, -28,23,193,2,248,22,138,16,23,194,1,11,28,23,193,2,249,22,82,248,22, -138,16,249,22,136,16,23,198,1,247,22,152,16,27,248,22,161,20,23,198,1, -28,248,22,90,23,194,2,9,27,248,80,144,46,53,39,248,22,83,23,196,2, -28,23,193,2,249,22,82,248,22,138,16,249,22,136,16,23,198,1,247,22,152, -16,248,80,144,48,8,53,39,248,22,161,20,23,198,1,86,94,23,193,1,248, -80,144,46,8,53,39,248,22,161,20,23,196,1,86,94,23,193,1,27,248,22, -161,20,23,196,1,28,248,22,90,23,194,2,9,27,248,80,144,44,53,39,248, -22,83,23,196,2,28,23,193,2,249,22,82,248,22,138,16,249,22,136,16,23, -198,1,247,22,152,16,248,80,144,46,8,53,39,248,22,161,20,23,198,1,86, -94,23,193,1,248,80,144,44,8,53,39,248,22,161,20,23,196,1,86,94,23, -193,1,27,248,22,161,20,23,197,1,28,248,22,90,23,194,2,9,27,27,248, -22,83,23,196,2,28,248,22,135,16,23,194,2,248,22,138,16,23,194,1,28, -248,22,134,16,23,194,2,90,144,39,11,89,146,39,36,11,248,22,131,16,249, -22,136,16,250,80,144,49,40,39,248,22,151,16,2,57,11,11,248,22,151,16, -2,58,86,95,23,195,1,23,194,1,248,22,138,16,249,22,136,16,23,199,1, -23,196,1,27,250,80,144,44,40,39,248,22,151,16,2,57,23,197,1,10,28, -23,193,2,248,22,138,16,23,194,1,11,28,23,193,2,249,22,82,248,22,138, -16,249,22,136,16,23,198,1,247,22,152,16,27,248,22,161,20,23,198,1,28, -248,22,90,23,194,2,9,27,248,80,144,44,53,39,248,22,83,23,196,2,28, -23,193,2,249,22,82,248,22,138,16,249,22,136,16,23,198,1,247,22,152,16, -248,80,144,46,8,53,39,248,22,161,20,23,198,1,86,94,23,193,1,248,80, -144,44,8,53,39,248,22,161,20,23,196,1,86,94,23,193,1,27,248,22,161, -20,23,196,1,28,248,22,90,23,194,2,9,27,248,80,144,42,53,39,248,22, -83,23,196,2,28,23,193,2,249,22,82,248,22,138,16,249,22,136,16,23,198, -1,247,22,152,16,248,80,144,44,8,53,39,248,22,161,20,23,198,1,86,94, -23,193,1,248,80,144,42,8,53,39,248,22,161,20,23,196,1,27,247,22,159, -16,27,248,80,144,39,55,39,247,80,144,39,54,39,249,80,144,40,41,38,28, -23,196,2,27,249,22,176,8,247,22,175,8,2,76,28,192,249,22,166,8,194, -7,63,2,67,2,67,250,80,144,43,59,39,23,198,2,2,77,27,28,23,200, -1,250,22,128,16,248,22,151,16,2,62,250,22,160,2,23,205,1,2,60,247, -22,172,8,2,78,86,94,23,199,1,11,27,248,80,144,46,8,50,39,250,22, -96,9,248,22,92,248,22,151,16,2,56,9,28,193,249,22,82,195,194,192,27, -247,22,159,16,27,248,80,144,39,55,39,247,80,144,39,54,39,249,80,144,40, -41,38,28,23,196,2,27,249,22,176,8,247,22,175,8,2,76,28,192,249,22, -166,8,194,7,63,2,67,2,67,250,80,144,43,59,39,23,198,2,2,77,27, -28,23,200,1,250,22,128,16,248,22,151,16,2,62,250,22,160,2,23,205,1, -2,60,247,22,172,8,2,78,86,94,23,199,1,11,27,248,80,144,46,8,51, -39,250,22,96,23,207,1,248,22,92,248,22,151,16,2,56,9,28,193,249,22, -82,195,194,192,27,247,22,159,16,27,248,80,144,39,55,39,249,80,144,41,52, -37,37,80,144,41,8,52,39,249,80,144,40,41,38,28,23,196,2,27,249,22, -176,8,247,22,175,8,2,76,28,192,249,22,166,8,194,7,63,2,67,2,67, -250,80,144,43,59,39,23,198,2,2,77,27,28,23,200,1,250,22,128,16,248, -22,151,16,2,62,250,22,160,2,23,205,1,2,60,247,22,172,8,2,78,86, -94,23,199,1,11,27,27,250,22,96,23,207,1,248,22,92,248,22,151,16,2, -56,23,208,1,28,248,22,90,23,194,2,9,27,27,248,22,83,23,196,2,28, -248,22,135,16,23,194,2,248,22,138,16,23,194,1,28,248,22,134,16,23,194, -2,90,144,39,11,89,146,39,36,11,248,22,131,16,249,22,136,16,250,80,144, -57,40,39,248,22,151,16,2,57,11,11,248,22,151,16,2,58,86,95,23,195, -1,23,194,1,248,22,138,16,249,22,136,16,23,199,1,23,196,1,27,250,80, -144,52,40,39,248,22,151,16,2,57,23,197,1,10,28,23,193,2,248,22,138, -16,23,194,1,11,28,23,193,2,249,22,82,248,22,138,16,249,22,136,16,23, -198,1,247,22,152,16,27,248,22,161,20,23,198,1,28,248,22,90,23,194,2, -9,27,248,80,144,52,53,39,248,22,83,23,196,2,28,23,193,2,249,22,82, -248,22,138,16,249,22,136,16,23,198,1,247,22,152,16,248,80,144,54,8,53, -39,248,22,161,20,23,198,1,86,94,23,193,1,248,80,144,52,8,53,39,248, -22,161,20,23,196,1,86,94,23,193,1,27,248,22,161,20,23,196,1,28,248, -22,90,23,194,2,9,27,248,80,144,50,53,39,248,22,83,23,196,2,28,23, -193,2,249,22,82,248,22,138,16,249,22,136,16,23,198,1,247,22,152,16,248, -80,144,52,8,53,39,248,22,161,20,23,198,1,86,94,23,193,1,248,80,144, -50,8,53,39,248,22,161,20,23,196,1,28,193,249,22,82,195,194,192,27,20, -13,144,80,144,37,43,37,26,9,80,144,46,44,37,249,22,33,11,80,144,48, -43,37,22,148,15,10,22,155,15,10,22,156,15,10,22,157,15,10,248,22,149, -6,23,196,2,28,248,22,149,7,23,194,2,12,86,94,248,22,178,9,23,194, -1,27,20,13,144,80,144,38,43,37,26,9,80,144,47,44,37,249,22,33,11, -80,144,49,43,37,22,148,15,10,22,155,15,10,22,156,15,10,22,157,15,10, -248,22,149,6,23,197,2,28,248,22,149,7,23,194,2,12,86,94,248,22,178, -9,23,194,1,27,20,13,144,80,144,39,43,37,26,9,80,144,48,44,37,249, -22,33,11,80,144,50,43,37,22,148,15,10,22,155,15,10,22,156,15,10,22, -157,15,10,248,22,149,6,23,198,2,28,248,22,149,7,23,194,2,12,86,94, -248,22,178,9,23,194,1,248,80,144,40,8,54,39,197,86,94,249,22,140,7, -247,22,173,5,23,196,2,248,22,164,6,249,22,138,4,36,249,22,186,3,28, -23,198,2,23,198,1,86,94,23,198,1,36,23,199,1,27,248,22,190,5,28, -23,198,2,86,95,23,197,1,23,196,1,23,198,1,86,94,23,198,1,27,250, -80,144,42,40,39,248,22,151,16,2,57,11,11,27,248,22,141,4,23,199,1, -27,28,23,194,2,23,194,1,86,94,23,194,1,36,27,248,22,141,4,23,202, -1,249,22,141,6,23,198,1,20,20,95,88,148,8,36,36,48,11,9,224,3, -2,33,191,2,23,195,1,23,196,1,248,80,144,38,8,54,39,193,144,36,20, -114,144,36,16,1,11,16,0,20,26,15,53,9,2,1,2,1,29,11,11,11, -11,9,9,11,11,11,10,43,80,143,36,36,20,114,144,51,16,40,2,2,2, -3,2,4,2,5,2,6,2,7,2,8,30,2,11,1,20,112,97,114,97,109, -101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,6,30,2,11,1, -23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116, -105,111,110,11,4,2,12,2,13,2,14,2,15,2,16,2,17,2,18,30,2, -19,79,99,97,99,104,101,45,99,111,110,102,105,103,117,114,97,116,105,111,110, -11,1,2,20,2,21,2,22,2,23,2,24,2,25,2,26,2,27,2,28,2, -29,2,30,30,2,19,1,21,101,120,99,101,112,116,105,111,110,45,104,97,110, -100,108,101,114,45,107,101,121,11,3,2,31,2,32,2,33,2,34,2,35,2, -36,2,37,2,38,2,39,2,40,2,41,16,0,37,39,36,16,0,36,16,19, -2,13,2,14,2,12,2,26,2,3,2,36,2,24,2,25,2,20,2,30,2, -34,2,22,2,23,2,32,2,28,2,31,2,33,2,37,2,29,55,11,11,11, -16,17,2,8,2,17,2,15,2,41,2,16,2,6,2,27,2,40,2,18,2, -21,2,39,2,4,2,35,2,7,2,38,2,2,2,5,16,17,11,11,11,11, -11,11,11,11,11,11,11,11,11,11,11,11,11,16,17,2,8,2,17,2,15, -2,41,2,16,2,6,2,27,2,40,2,18,2,21,2,39,2,4,2,35,2, -7,2,38,2,2,2,5,53,53,37,12,11,11,16,0,16,0,16,0,36,36, -11,12,11,11,16,0,16,0,16,0,36,36,16,51,20,15,16,2,32,0,88, -148,8,36,37,45,11,2,2,222,33,79,80,144,36,36,37,20,15,16,2,249, -22,156,7,7,92,7,92,80,144,36,37,37,20,15,16,2,88,148,8,36,37, -54,38,2,4,223,0,33,84,80,144,36,38,37,20,15,16,2,88,148,8,36, -38,58,38,2,5,223,0,33,86,80,144,36,39,37,20,15,16,2,20,25,96, -2,6,88,148,8,36,39,8,24,8,32,9,223,0,33,93,88,148,8,36,38, -47,52,9,223,0,33,94,88,148,8,36,37,46,52,9,223,0,33,95,80,144, -36,40,37,20,15,16,2,27,248,22,163,16,248,22,168,8,27,28,249,22,170, -9,247,22,181,8,2,44,6,1,1,59,6,1,1,58,250,22,138,8,6,14, -14,40,91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1, -88,148,8,36,38,48,11,2,7,223,0,33,99,80,144,36,41,37,20,15,16, -2,88,148,36,37,8,38,8,128,6,2,8,223,0,33,100,80,144,36,42,37, -20,15,16,2,32,0,88,148,8,36,38,47,11,2,12,222,33,101,80,144,36, -45,37,20,15,16,2,32,0,88,148,8,36,39,48,11,2,13,222,33,103,80, -144,36,46,37,20,15,16,2,32,0,88,148,8,36,38,46,11,2,14,222,33, -104,80,144,36,47,37,20,15,16,2,88,148,36,39,50,8,128,128,2,15,223, -0,33,106,80,144,36,48,37,20,15,16,2,88,148,36,41,52,8,128,128,2, -17,223,0,33,108,80,144,36,50,37,20,15,16,2,88,148,36,36,53,52,9, -223,0,33,109,80,144,36,8,40,39,20,15,16,2,88,148,36,36,44,16,4, -36,37,8,128,4,36,2,18,223,0,33,110,80,144,36,51,37,20,15,16,2, -88,148,36,36,53,52,9,223,0,33,111,80,144,36,8,41,39,20,15,16,2, -88,148,36,36,44,16,4,36,37,8,128,8,36,2,21,223,0,33,112,80,144, -36,54,37,20,15,16,2,88,148,8,36,36,8,38,8,128,6,9,223,0,33, -113,80,144,36,8,42,39,20,15,16,2,88,148,8,36,37,47,16,4,36,36, -8,128,16,36,2,22,223,0,33,114,80,144,36,55,37,20,15,16,2,20,27, -143,32,0,88,148,36,37,45,11,2,23,222,33,115,32,0,88,148,36,37,45, -11,2,23,222,33,116,80,144,36,56,37,20,15,16,2,88,148,8,36,37,47, -8,240,0,128,0,0,2,24,223,0,33,117,80,144,36,57,37,20,15,16,2, -88,148,36,36,53,52,9,223,0,33,118,80,144,36,8,43,39,20,15,16,2, -88,148,8,36,37,48,16,4,36,37,8,128,32,36,2,25,223,0,33,119,80, -144,36,58,37,20,15,16,2,88,148,36,37,53,52,2,20,223,0,33,120,80, -144,36,53,37,20,15,16,2,88,148,8,36,38,55,16,4,8,240,0,128,0, -0,8,32,8,128,64,36,2,51,223,0,33,121,80,144,36,8,44,39,20,15, -16,2,88,148,8,36,39,49,16,4,36,36,8,128,64,36,2,26,223,0,33, -122,80,144,36,59,37,20,15,16,2,88,148,36,36,53,52,9,223,0,33,123, -80,144,36,8,45,39,20,15,16,2,88,148,8,36,36,54,16,4,8,240,0, -128,0,0,8,137,2,8,128,128,36,2,27,223,0,33,124,80,144,36,8,24, -37,20,15,16,2,247,22,142,2,80,144,36,8,25,37,20,15,16,2,248,22, -18,65,115,116,97,109,112,80,144,36,8,26,37,20,15,16,2,88,148,36,37, -46,8,240,0,0,0,4,9,223,0,33,126,80,144,36,8,46,39,20,15,16, -2,88,148,36,38,48,16,4,36,8,128,80,8,240,0,64,0,0,36,2,30, -223,0,33,134,2,80,144,36,8,27,37,20,15,16,2,32,0,88,148,8,36, -37,45,11,2,31,222,33,135,2,80,144,36,8,29,37,20,15,16,2,88,148, -8,36,39,45,8,240,0,0,0,2,72,109,97,107,101,45,104,97,110,100,108, -101,114,223,0,33,137,2,80,144,36,8,47,39,20,15,16,2,88,148,36,37, -44,16,4,8,128,6,8,128,104,8,240,0,128,0,0,36,2,32,223,0,33, -147,2,80,144,36,8,30,37,20,15,16,2,88,148,36,38,56,16,2,36,8, -240,0,128,0,0,2,33,223,0,33,149,2,80,144,36,8,31,37,20,15,16, -2,88,148,8,36,38,58,16,4,36,8,240,0,64,0,0,36,37,2,51,223, -0,33,150,2,80,144,36,8,48,39,20,15,16,2,88,148,36,44,8,33,16, -4,36,36,37,38,65,99,108,111,111,112,223,0,33,157,2,80,144,36,8,49, -39,20,15,16,2,88,148,36,41,8,25,16,4,36,8,240,0,192,0,0,36, -39,2,16,223,0,33,158,2,80,144,36,49,37,20,15,16,2,88,148,36,39, -55,16,4,44,36,40,36,2,34,223,0,33,163,2,80,144,36,8,32,37,20, -15,16,2,32,0,88,148,36,39,50,11,2,36,222,33,164,2,80,144,36,8, -34,37,20,15,16,2,32,0,88,148,8,36,41,8,27,11,2,37,222,33,169, -2,80,144,36,8,35,37,20,15,16,2,20,27,143,32,0,88,148,8,36,38, -52,11,2,38,222,33,172,2,88,148,8,100,38,49,16,4,36,36,44,36,2, -38,223,0,33,174,2,80,144,36,8,36,37,20,15,16,2,20,27,143,32,0, -88,148,8,36,38,52,11,2,35,222,33,179,2,88,148,8,100,38,49,16,4, -36,36,44,36,2,35,223,0,33,180,2,80,144,36,8,33,37,20,15,16,2, -20,27,143,32,0,88,148,36,37,44,11,2,39,222,33,181,2,32,0,88,148, -36,37,44,11,2,39,222,33,182,2,80,144,36,8,37,37,20,15,16,2,88, -148,8,36,37,55,16,4,52,38,36,40,2,51,223,0,33,183,2,80,144,36, -8,50,39,20,15,16,2,88,148,8,36,37,55,16,4,52,38,36,44,2,51, -223,0,33,184,2,80,144,36,8,51,39,20,15,16,2,88,148,36,36,53,52, -9,223,0,33,185,2,80,144,36,8,52,39,20,15,16,2,88,148,8,36,37, -59,16,4,52,38,36,8,32,2,51,223,0,33,186,2,80,144,36,8,53,39, -20,15,16,2,20,25,96,2,40,88,148,36,36,57,16,4,8,32,8,140,2, -36,40,9,223,0,33,187,2,88,148,36,37,58,16,4,8,32,8,140,2,36, -44,9,223,0,33,188,2,88,148,36,38,8,30,16,4,8,48,8,139,2,36, -8,48,9,223,0,33,189,2,80,144,36,8,38,37,20,15,16,2,88,148,8, -36,37,57,16,4,8,128,6,36,36,8,64,2,51,223,0,33,190,2,80,144, -36,8,54,39,20,15,16,2,88,148,8,36,39,53,16,4,52,36,36,8,64, -2,41,223,0,33,128,3,80,144,36,8,39,37,95,29,94,2,9,68,35,37, -107,101,114,110,101,108,11,29,94,2,9,69,35,37,109,105,110,45,115,116,120, -11,2,19,9,9,9,36,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 19748); +136,16,23,194,2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2,90, +144,42,11,89,146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,50,43, +42,248,22,152,16,2,58,11,11,248,22,152,16,2,59,86,95,23,195,1,23, +194,1,248,22,139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144,45, +43,42,248,22,152,16,2,58,23,197,1,10,28,23,193,2,248,22,139,16,23, +194,1,11,28,23,193,2,249,22,82,248,22,139,16,249,22,137,16,23,198,1, +247,22,153,16,27,248,22,164,20,23,199,1,28,248,22,90,23,194,2,9,27, +248,80,144,45,56,42,248,22,83,23,196,2,28,23,193,2,249,22,82,248,22, +139,16,249,22,137,16,23,198,1,247,22,153,16,248,80,144,47,8,51,42,248, +22,164,20,23,198,1,86,94,23,193,1,248,80,144,45,8,51,42,248,22,164, +20,23,196,1,86,94,23,193,1,27,248,22,164,20,23,197,1,28,248,22,90, +23,194,2,9,27,248,80,144,43,56,42,248,22,83,23,196,2,28,23,193,2, +249,22,82,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16,248,80,144, +45,8,51,42,248,22,164,20,23,198,1,86,94,23,193,1,248,80,144,43,8, +51,42,248,22,164,20,23,196,1,27,248,22,152,16,2,60,28,248,22,136,16, +23,194,2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2,90,144,42, +11,89,146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,49,43,42,248, +22,152,16,2,58,11,11,248,22,152,16,2,59,86,95,23,195,1,23,194,1, +248,22,139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144,44,43,42, +248,22,152,16,2,58,23,197,1,10,28,23,193,2,248,22,139,16,23,194,1, +11,28,248,22,90,23,195,2,9,27,27,248,22,83,23,197,2,28,248,22,136, +16,23,194,2,248,22,139,16,23,194,1,28,248,22,135,16,23,194,2,90,144, +42,11,89,146,42,39,11,248,22,132,16,249,22,137,16,250,80,144,50,43,42, +248,22,152,16,2,58,11,11,248,22,152,16,2,59,86,95,23,195,1,23,194, +1,248,22,139,16,249,22,137,16,23,199,1,23,196,1,27,250,80,144,45,43, +42,248,22,152,16,2,58,23,197,1,10,28,23,193,2,248,22,139,16,23,194, +1,11,28,23,193,2,249,22,82,248,22,139,16,249,22,137,16,23,198,1,247, +22,153,16,27,248,22,164,20,23,199,1,28,248,22,90,23,194,2,9,27,27, +248,22,83,23,196,2,28,248,22,136,16,23,194,2,248,22,139,16,23,194,1, +28,248,22,135,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16, +249,22,137,16,250,80,144,54,43,42,248,22,152,16,2,58,11,11,248,22,152, +16,2,59,86,95,23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,199, +1,23,196,1,27,250,80,144,49,43,42,248,22,152,16,2,58,23,197,1,10, +28,23,193,2,248,22,139,16,23,194,1,11,28,23,193,2,249,22,82,248,22, +139,16,249,22,137,16,23,198,1,247,22,153,16,27,248,22,164,20,23,198,1, +28,248,22,90,23,194,2,9,27,248,80,144,49,56,42,248,22,83,23,196,2, +28,23,193,2,249,22,82,248,22,139,16,249,22,137,16,23,198,1,247,22,153, +16,248,80,144,51,8,53,42,248,22,164,20,23,198,1,86,94,23,193,1,248, +80,144,49,8,53,42,248,22,164,20,23,196,1,86,94,23,193,1,27,248,22, +164,20,23,196,1,28,248,22,90,23,194,2,9,27,248,80,144,47,56,42,248, +22,83,23,196,2,28,23,193,2,249,22,82,248,22,139,16,249,22,137,16,23, +198,1,247,22,153,16,248,80,144,49,8,53,42,248,22,164,20,23,198,1,86, +94,23,193,1,248,80,144,47,8,53,42,248,22,164,20,23,196,1,86,94,23, +193,1,27,248,22,164,20,23,197,1,28,248,22,90,23,194,2,9,27,27,248, +22,83,23,196,2,28,248,22,136,16,23,194,2,248,22,139,16,23,194,1,28, +248,22,135,16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16,249, +22,137,16,250,80,144,52,43,42,248,22,152,16,2,58,11,11,248,22,152,16, +2,59,86,95,23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,199,1, +23,196,1,27,250,80,144,47,43,42,248,22,152,16,2,58,23,197,1,10,28, +23,193,2,248,22,139,16,23,194,1,11,28,23,193,2,249,22,82,248,22,139, +16,249,22,137,16,23,198,1,247,22,153,16,27,248,22,164,20,23,198,1,28, +248,22,90,23,194,2,9,27,248,80,144,47,56,42,248,22,83,23,196,2,28, +23,193,2,249,22,82,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16, +248,80,144,49,8,53,42,248,22,164,20,23,198,1,86,94,23,193,1,248,80, +144,47,8,53,42,248,22,164,20,23,196,1,86,94,23,193,1,27,248,22,164, +20,23,196,1,28,248,22,90,23,194,2,9,27,248,80,144,45,56,42,248,22, +83,23,196,2,28,23,193,2,249,22,82,248,22,139,16,249,22,137,16,23,198, +1,247,22,153,16,248,80,144,47,8,53,42,248,22,164,20,23,198,1,86,94, +23,193,1,248,80,144,45,8,53,42,248,22,164,20,23,196,1,27,247,22,160, +16,27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144,43,44,41,28, +23,196,2,27,249,22,177,8,247,22,176,8,2,77,28,192,249,22,167,8,194, +7,63,2,68,2,68,250,80,144,46,8,23,42,23,198,2,2,78,27,28,23, +200,1,250,22,129,16,248,22,152,16,2,63,250,22,160,2,23,205,1,2,61, +247,22,173,8,2,79,86,94,23,199,1,11,27,248,80,144,49,8,50,42,250, +22,96,9,248,22,92,248,22,152,16,2,57,9,28,193,249,22,82,195,194,192, +27,247,22,160,16,27,248,80,144,42,58,42,247,80,144,42,57,42,249,80,144, +43,44,41,28,23,196,2,27,249,22,177,8,247,22,176,8,2,77,28,192,249, +22,167,8,194,7,63,2,68,2,68,250,80,144,46,8,23,42,23,198,2,2, +78,27,28,23,200,1,250,22,129,16,248,22,152,16,2,63,250,22,160,2,23, +205,1,2,61,247,22,173,8,2,79,86,94,23,199,1,11,27,248,80,144,49, +8,51,42,250,22,96,23,207,1,248,22,92,248,22,152,16,2,57,9,28,193, +249,22,82,195,194,192,27,247,22,160,16,27,248,80,144,42,58,42,249,80,144, +44,55,40,40,80,144,44,8,52,42,249,80,144,43,44,41,28,23,196,2,27, +249,22,177,8,247,22,176,8,2,77,28,192,249,22,167,8,194,7,63,2,68, +2,68,250,80,144,46,8,23,42,23,198,2,2,78,27,28,23,200,1,250,22, +129,16,248,22,152,16,2,63,250,22,160,2,23,205,1,2,61,247,22,173,8, +2,79,86,94,23,199,1,11,27,27,250,22,96,23,207,1,248,22,92,248,22, +152,16,2,57,23,208,1,28,248,22,90,23,194,2,9,27,27,248,22,83,23, +196,2,28,248,22,136,16,23,194,2,248,22,139,16,23,194,1,28,248,22,135, +16,23,194,2,90,144,42,11,89,146,42,39,11,248,22,132,16,249,22,137,16, +250,80,144,60,43,42,248,22,152,16,2,58,11,11,248,22,152,16,2,59,86, +95,23,195,1,23,194,1,248,22,139,16,249,22,137,16,23,199,1,23,196,1, +27,250,80,144,55,43,42,248,22,152,16,2,58,23,197,1,10,28,23,193,2, +248,22,139,16,23,194,1,11,28,23,193,2,249,22,82,248,22,139,16,249,22, +137,16,23,198,1,247,22,153,16,27,248,22,164,20,23,198,1,28,248,22,90, +23,194,2,9,27,248,80,144,55,56,42,248,22,83,23,196,2,28,23,193,2, +249,22,82,248,22,139,16,249,22,137,16,23,198,1,247,22,153,16,248,80,144, +57,8,53,42,248,22,164,20,23,198,1,86,94,23,193,1,248,80,144,55,8, +53,42,248,22,164,20,23,196,1,86,94,23,193,1,27,248,22,164,20,23,196, +1,28,248,22,90,23,194,2,9,27,248,80,144,53,56,42,248,22,83,23,196, +2,28,23,193,2,249,22,82,248,22,139,16,249,22,137,16,23,198,1,247,22, +153,16,248,80,144,55,8,53,42,248,22,164,20,23,198,1,86,94,23,193,1, +248,80,144,53,8,53,42,248,22,164,20,23,196,1,28,193,249,22,82,195,194, +192,27,20,13,144,80,144,40,46,40,26,9,80,144,49,47,40,249,22,33,11, +80,144,51,46,40,22,149,15,10,22,156,15,10,22,157,15,10,22,158,15,10, +248,22,150,6,23,196,2,28,248,22,150,7,23,194,2,12,86,94,248,22,179, +9,23,194,1,27,20,13,144,80,144,41,46,40,26,9,80,144,50,47,40,249, +22,33,11,80,144,52,46,40,22,149,15,10,22,156,15,10,22,157,15,10,22, +158,15,10,248,22,150,6,23,197,2,28,248,22,150,7,23,194,2,12,86,94, +248,22,179,9,23,194,1,27,20,13,144,80,144,42,46,40,26,9,80,144,51, +47,40,249,22,33,11,80,144,53,46,40,22,149,15,10,22,156,15,10,22,157, +15,10,22,158,15,10,248,22,150,6,23,198,2,28,248,22,150,7,23,194,2, +12,86,94,248,22,179,9,23,194,1,248,80,144,43,8,54,42,197,86,94,249, +22,141,7,247,22,174,5,23,196,2,248,22,165,6,249,22,138,4,39,249,22, +186,3,28,23,198,2,23,198,1,86,94,23,198,1,39,23,199,1,27,248,22, +191,5,28,23,198,2,86,95,23,197,1,23,196,1,23,198,1,86,94,23,198, +1,27,250,80,144,45,43,42,248,22,152,16,2,58,11,11,27,248,22,141,4, +23,199,1,27,28,23,194,2,23,194,1,86,94,23,194,1,39,27,248,22,141, +4,23,202,1,249,22,142,6,23,198,1,20,20,95,88,148,8,36,39,51,11, +9,224,3,2,33,128,3,23,195,1,23,196,1,248,80,144,41,8,54,42,193, +144,39,20,120,145,2,1,39,16,1,11,16,0,20,26,15,56,9,2,2,2, +2,29,11,11,11,11,11,11,11,9,9,11,11,11,10,46,80,143,39,39,20, +120,145,2,1,54,16,40,2,3,2,4,2,5,2,6,2,7,2,8,2,9, +30,2,12,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, +45,107,101,121,11,6,30,2,12,1,23,101,120,116,101,110,100,45,112,97,114, +97,109,101,116,101,114,105,122,97,116,105,111,110,11,4,2,13,2,14,2,15, +2,16,2,17,2,18,2,19,30,2,20,1,19,99,97,99,104,101,45,99,111, +110,102,105,103,117,114,97,116,105,111,110,11,1,2,21,2,22,2,23,2,24, +2,25,2,26,2,27,2,28,2,29,2,30,2,31,30,2,20,1,21,101,120, +99,101,112,116,105,111,110,45,104,97,110,100,108,101,114,45,107,101,121,11,3, +2,32,2,33,2,34,2,35,2,36,2,37,2,38,2,39,2,40,2,41,2, +42,16,0,40,42,39,16,0,39,16,19,2,14,2,15,2,13,2,27,2,4, +2,37,2,25,2,26,2,21,2,31,2,35,2,23,2,24,2,33,2,29,2, +32,2,34,2,38,2,30,58,11,11,11,16,17,2,9,2,18,2,16,2,42, +2,17,2,7,2,28,2,41,2,19,2,22,2,40,2,5,2,36,2,8,2, +39,2,3,2,6,16,17,11,11,11,11,11,11,11,11,11,11,11,11,11,11, +11,11,11,16,17,2,9,2,18,2,16,2,42,2,17,2,7,2,28,2,41, +2,19,2,22,2,40,2,5,2,36,2,8,2,39,2,3,2,6,56,56,40, +12,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0, +39,39,16,51,20,15,16,2,32,0,88,148,8,36,40,48,11,2,3,222,33, +80,80,144,39,39,40,20,15,16,2,249,22,157,7,7,92,7,92,80,144,39, +40,40,20,15,16,2,88,148,8,36,40,57,41,2,5,223,0,33,85,80,144, +39,41,40,20,15,16,2,88,148,8,36,41,61,41,2,6,223,0,33,87,80, +144,39,42,40,20,15,16,2,20,25,96,2,7,88,148,8,36,42,8,24,8, +32,9,223,0,33,94,88,148,8,36,41,50,55,9,223,0,33,95,88,148,8, +36,40,49,55,9,223,0,33,96,80,144,39,43,40,20,15,16,2,27,248,22, +164,16,248,22,169,8,27,28,249,22,171,9,247,22,182,8,2,45,6,1,1, +59,6,1,1,58,250,22,139,8,6,14,14,40,91,94,126,97,93,42,41,126, +97,40,46,42,41,23,196,2,23,196,1,88,148,8,36,41,51,11,2,8,223, +0,33,100,80,144,39,44,40,20,15,16,2,88,148,39,40,8,38,8,128,6, +2,9,223,0,33,101,80,144,39,45,40,20,15,16,2,32,0,88,148,8,36, +41,50,11,2,13,222,33,102,80,144,39,48,40,20,15,16,2,32,0,88,148, +8,36,42,51,11,2,14,222,33,104,80,144,39,49,40,20,15,16,2,32,0, +88,148,8,36,41,49,11,2,15,222,33,105,80,144,39,50,40,20,15,16,2, +88,148,39,42,53,8,128,128,2,16,223,0,33,107,80,144,39,51,40,20,15, +16,2,88,148,39,44,55,8,128,128,2,18,223,0,33,109,80,144,39,53,40, +20,15,16,2,88,148,39,39,56,55,9,223,0,33,110,80,144,39,8,40,42, +20,15,16,2,88,148,39,39,47,16,4,39,40,8,128,4,39,2,19,223,0, +33,111,80,144,39,54,40,20,15,16,2,88,148,39,39,56,55,9,223,0,33, +112,80,144,39,8,41,42,20,15,16,2,88,148,39,39,47,16,4,39,40,8, +128,8,39,2,22,223,0,33,113,80,144,39,57,40,20,15,16,2,88,148,8, +36,39,8,38,8,128,6,9,223,0,33,114,80,144,39,8,42,42,20,15,16, +2,88,148,8,36,40,50,16,4,39,39,8,128,16,39,2,23,223,0,33,115, +80,144,39,58,40,20,15,16,2,20,27,143,32,0,88,148,39,40,48,11,2, +24,222,33,116,32,0,88,148,39,40,48,11,2,24,222,33,117,80,144,39,59, +40,20,15,16,2,88,148,8,36,40,50,8,240,0,128,0,0,2,25,223,0, +33,118,80,144,39,60,40,20,15,16,2,88,148,39,39,56,55,9,223,0,33, +119,80,144,39,8,43,42,20,15,16,2,88,148,8,36,40,51,16,4,39,40, +8,128,32,39,2,26,223,0,33,120,80,144,39,61,40,20,15,16,2,88,148, +39,40,56,55,2,21,223,0,33,121,80,144,39,56,40,20,15,16,2,88,148, +8,36,41,58,16,4,8,240,0,128,0,0,8,32,8,128,64,39,2,52,223, +0,33,122,80,144,39,8,44,42,20,15,16,2,88,148,8,36,42,52,16,4, +39,39,8,128,64,39,2,27,223,0,33,123,80,144,39,8,23,40,20,15,16, +2,88,148,39,39,56,55,9,223,0,33,124,80,144,39,8,45,42,20,15,16, +2,88,148,8,36,39,57,16,4,8,240,0,128,0,0,8,137,2,8,128,128, +39,2,28,223,0,33,125,80,144,39,8,24,40,20,15,16,2,247,22,142,2, +80,144,39,8,25,40,20,15,16,2,248,22,18,67,115,116,97,109,112,80,144, +39,8,26,40,20,15,16,2,88,148,39,40,49,8,240,0,0,0,4,9,223, +0,33,127,80,144,39,8,46,42,20,15,16,2,88,148,39,41,51,16,4,39, +8,128,80,8,240,0,64,0,0,39,2,31,223,0,33,135,2,80,144,39,8, +27,40,20,15,16,2,32,0,88,148,8,36,40,48,11,2,32,222,33,136,2, +80,144,39,8,29,40,20,15,16,2,88,148,8,36,42,48,8,240,0,0,0, +2,74,109,97,107,101,45,104,97,110,100,108,101,114,223,0,33,138,2,80,144, +39,8,47,42,20,15,16,2,88,148,39,40,47,16,4,8,128,6,8,128,104, +8,240,0,128,0,0,39,2,33,223,0,33,148,2,80,144,39,8,30,40,20, +15,16,2,88,148,39,41,59,16,2,39,8,240,0,128,0,0,2,34,223,0, +33,150,2,80,144,39,8,31,40,20,15,16,2,88,148,8,36,41,61,16,4, +39,8,240,0,64,0,0,39,40,2,52,223,0,33,151,2,80,144,39,8,48, +42,20,15,16,2,88,148,39,47,8,33,16,4,39,39,40,41,67,99,108,111, +111,112,223,0,33,158,2,80,144,39,8,49,42,20,15,16,2,88,148,39,44, +8,25,16,4,39,8,240,0,192,0,0,39,42,2,17,223,0,33,159,2,80, +144,39,52,40,20,15,16,2,88,148,39,42,58,16,4,47,39,43,39,2,35, +223,0,33,164,2,80,144,39,8,32,40,20,15,16,2,32,0,88,148,39,42, +53,11,2,37,222,33,165,2,80,144,39,8,34,40,20,15,16,2,32,0,88, +148,8,36,44,8,27,11,2,38,222,33,170,2,80,144,39,8,35,40,20,15, +16,2,20,27,143,32,0,88,148,8,36,41,55,11,2,39,222,33,173,2,88, +148,8,100,41,52,16,4,39,39,47,39,2,39,223,0,33,175,2,80,144,39, +8,36,40,20,15,16,2,20,27,143,32,0,88,148,8,36,41,55,11,2,36, +222,33,180,2,88,148,8,100,41,52,16,4,39,39,47,39,2,36,223,0,33, +181,2,80,144,39,8,33,40,20,15,16,2,20,27,143,32,0,88,148,39,40, +47,11,2,40,222,33,182,2,32,0,88,148,39,40,47,11,2,40,222,33,183, +2,80,144,39,8,37,40,20,15,16,2,88,148,8,36,40,58,16,4,55,41, +39,43,2,52,223,0,33,184,2,80,144,39,8,50,42,20,15,16,2,88,148, +8,36,40,58,16,4,55,41,39,47,2,52,223,0,33,185,2,80,144,39,8, +51,42,20,15,16,2,88,148,39,39,56,55,9,223,0,33,186,2,80,144,39, +8,52,42,20,15,16,2,88,148,8,36,40,8,23,16,4,55,41,39,8,32, +2,52,223,0,33,187,2,80,144,39,8,53,42,20,15,16,2,20,25,96,2, +41,88,148,39,39,60,16,4,8,32,8,140,2,39,43,9,223,0,33,188,2, +88,148,39,40,61,16,4,8,32,8,140,2,39,47,9,223,0,33,189,2,88, +148,39,41,8,30,16,4,8,48,8,139,2,39,8,48,9,223,0,33,190,2, +80,144,39,8,38,40,20,15,16,2,88,148,8,36,40,60,16,4,8,128,6, +39,39,8,64,2,52,223,0,33,191,2,80,144,39,8,54,42,20,15,16,2, +88,148,8,36,42,56,16,4,55,39,39,8,64,2,42,223,0,33,129,3,80, +144,39,8,39,40,95,29,94,2,10,70,35,37,107,101,114,110,101,108,11,29, +94,2,10,71,35,37,109,105,110,45,115,116,120,11,2,20,9,9,9,39,9, +0}; + EVAL_ONE_SIZED_STR((char *)expr, 19782); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,50,46,48,46,50,84,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,14,0,0,0,1,0,0,15,0,40,0, -57,0,75,0,97,0,120,0,140,0,162,0,171,0,180,0,187,0,196,0,203, -0,0,0,231,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99, -116,1,23,115,116,114,117,99,116,58,84,72,45,112,108,97,99,101,45,99,104, -97,110,110,101,108,76,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101, -108,77,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,63,1,20, -84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,45,114,101,102,1, -21,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,45,115,101,116, -33,79,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,45,105,110, -1,20,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,45,111,117, -116,249,80,143,38,39,23,196,1,36,249,80,143,38,39,23,196,1,36,249,80, -143,38,39,195,36,249,80,143,38,39,23,196,1,37,249,80,143,38,39,195,37, -144,36,20,114,144,36,16,1,11,16,0,20,26,15,53,9,2,1,2,1,29, -11,11,11,11,9,9,11,11,11,10,45,80,143,36,36,20,114,144,36,16,7, -2,2,2,3,2,4,2,5,2,6,2,7,2,8,16,0,37,39,36,16,0, -36,16,2,2,5,2,6,38,11,11,11,16,5,2,3,2,7,2,8,2,4, -2,2,16,5,11,11,11,11,11,16,5,2,3,2,7,2,8,2,4,2,2, -41,41,37,12,11,11,16,0,16,0,16,0,36,36,11,12,11,11,16,0,16, -0,16,0,36,36,16,3,20,15,16,6,253,22,189,10,2,3,11,38,36,11, -248,22,92,249,22,82,22,175,10,88,148,36,37,45,44,9,223,9,33,9,80, -144,36,36,37,80,144,36,37,37,80,144,36,38,37,80,144,36,39,37,80,144, -36,40,37,20,15,16,2,20,27,143,88,148,36,37,45,44,9,223,0,33,10, -88,148,36,37,45,44,9,223,0,33,11,80,144,36,41,37,20,15,16,2,20, -27,143,88,148,36,37,45,44,9,223,0,33,12,88,148,36,37,45,44,9,223, -0,33,13,80,144,36,42,37,93,29,94,65,113,117,111,116,101,68,35,37,107, -101,114,110,101,108,11,9,9,9,36,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 557); + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,9,54,46,50,46,57,48,48,46,52,84,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8,0, +23,0,48,0,65,0,83,0,105,0,128,0,149,0,171,0,180,0,189,0,196, +0,205,0,212,0,0,0,247,1,0,0,3,1,5,105,110,115,112,48,76,35, +37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116,114,117,99,116, +58,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,78,84,72,45, +112,108,97,99,101,45,99,104,97,110,110,101,108,79,84,72,45,112,108,97,99, +101,45,99,104,97,110,110,101,108,63,1,20,84,72,45,112,108,97,99,101,45, +99,104,97,110,110,101,108,45,114,101,102,1,21,84,72,45,112,108,97,99,101, +45,99,104,97,110,110,101,108,45,115,101,116,33,1,19,84,72,45,112,108,97, +99,101,45,99,104,97,110,110,101,108,45,105,110,1,20,84,72,45,112,108,97, +99,101,45,99,104,97,110,110,101,108,45,111,117,116,249,80,143,41,42,23,196, +1,39,249,80,143,41,42,23,196,1,39,249,80,143,41,42,195,39,249,80,143, +41,42,23,196,1,40,249,80,143,41,42,195,40,144,39,20,120,145,2,1,39, +16,1,11,16,0,20,26,15,56,9,2,2,2,2,29,11,11,11,11,11,11, +11,9,9,11,11,11,10,48,80,143,39,39,20,120,145,2,1,39,16,7,2, +3,2,4,2,5,2,6,2,7,2,8,2,9,16,0,40,42,39,16,0,39, +16,2,2,6,2,7,41,11,11,11,16,5,2,4,2,8,2,9,2,5,2, +3,16,5,11,11,11,11,11,16,5,2,4,2,8,2,9,2,5,2,3,44, +44,40,12,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0, +16,0,39,39,16,3,20,15,16,6,253,22,190,10,2,4,11,41,39,11,248, +22,92,249,22,82,22,176,10,88,148,39,40,48,47,9,223,9,33,10,80,144, +39,39,40,80,144,39,40,40,80,144,39,41,40,80,144,39,42,40,80,144,39, +43,40,20,15,16,2,20,27,143,88,148,39,40,48,47,9,223,0,33,11,88, +148,39,40,48,47,9,223,0,33,12,80,144,39,44,40,20,15,16,2,20,27, +143,88,148,39,40,48,47,9,223,0,33,13,88,148,39,40,48,47,9,223,0, +33,14,80,144,39,45,40,93,29,94,67,113,117,111,116,101,70,35,37,107,101, +114,110,101,108,11,9,9,9,39,9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 577); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,50,46,48,46,50,84,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,102,0,0,0,1,0,0,7,0,18,0, -45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, -0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,75,1,87,1,118,1, -125,1,130,1,135,1,153,1,159,1,164,1,173,1,178,1,184,1,189,1,193, -1,208,1,215,1,220,1,224,1,229,1,236,1,247,1,254,1,6,2,109,2, -144,2,247,2,26,3,120,3,155,3,249,3,28,4,46,11,76,11,127,11,202, -11,218,11,234,11,248,11,8,12,83,12,99,12,115,12,131,12,206,12,113,13, -129,13,204,13,199,14,79,15,154,15,61,16,74,16,227,16,155,17,198,17,24, -18,152,18,213,18,221,18,232,18,10,20,113,20,141,20,154,20,75,21,82,21, -242,21,6,22,106,22,128,22,138,22,152,22,189,22,32,23,36,23,43,23,249, -23,145,32,198,32,222,32,246,32,0,0,17,37,0,0,66,35,37,98,111,111, -116,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116, -45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117, -111,116,101,68,35,37,112,97,114,97,109,122,29,94,2,4,2,5,11,1,20, -112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,29, -94,2,4,67,35,37,117,116,105,108,115,11,1,24,45,109,111,100,117,108,101, -45,104,97,115,104,45,116,97,98,108,101,45,116,97,98,108,101,76,114,101,103, -105,115,116,101,114,45,122,111,45,112,97,116,104,1,20,100,101,102,97,117,108, -116,45,114,101,97,100,101,114,45,103,117,97,114,100,67,67,65,67,72,69,45, -78,71,45,112,97,116,104,45,99,97,99,104,101,74,112,97,116,104,45,99,97, -99,104,101,45,103,101,116,75,112,97,116,104,45,99,97,99,104,101,45,115,101, -116,33,77,45,108,111,97,100,105,110,103,45,102,105,108,101,110,97,109,101,79, -45,108,111,97,100,105,110,103,45,112,114,111,109,112,116,45,116,97,103,71,45, -112,114,101,118,45,114,101,108,116,111,75,45,112,114,101,118,45,114,101,108,116, -111,45,100,105,114,1,21,115,112,108,105,116,45,114,101,108,97,116,105,118,101, -45,115,116,114,105,110,103,1,22,102,111,114,109,97,116,45,115,111,117,114,99, -101,45,108,111,99,97,116,105,111,110,71,111,114,105,103,45,112,97,114,97,109, -122,1,29,115,116,97,110,100,97,114,100,45,109,111,100,117,108,101,45,110,97, -109,101,45,114,101,115,111,108,118,101,114,29,94,2,4,2,5,11,64,98,111, -111,116,64,115,101,97,108,77,108,111,97,100,47,117,115,101,45,99,111,109,112, -105,108,101,100,5,4,46,114,107,116,64,115,97,109,101,6,6,6,110,97,116, -105,118,101,5,3,46,122,111,65,105,108,111,111,112,64,108,111,111,112,63,108, -105,98,6,12,12,109,111,100,117,108,101,45,112,97,116,104,63,66,115,117,98, -109,111,100,6,2,2,46,46,6,1,1,46,64,102,105,108,101,66,112,108,97, -110,101,116,6,8,8,109,97,105,110,46,114,107,116,6,4,4,46,114,107,116, -67,105,103,110,111,114,101,100,27,252,22,128,16,28,249,22,170,9,23,201,2, -2,29,86,94,23,199,1,23,201,1,28,248,22,133,16,23,200,2,249,22,128, -16,23,203,1,23,201,1,249,80,144,47,42,39,23,203,1,23,201,1,23,203, -1,2,30,247,22,182,8,249,80,144,47,43,39,23,202,1,80,144,47,36,38, -27,250,22,146,16,196,11,32,0,88,148,8,36,36,41,11,9,222,11,28,192, -249,22,82,195,194,11,249,22,5,20,20,96,88,148,8,36,37,54,8,129,3, -9,226,5,3,2,6,33,44,23,199,1,23,195,1,23,196,1,23,197,1,27, -252,22,128,16,28,249,22,170,9,23,201,2,2,29,86,94,23,199,1,23,201, -1,28,248,22,133,16,23,200,2,249,22,128,16,23,203,1,23,201,1,249,80, -144,47,42,39,23,203,1,23,201,1,23,203,1,2,30,247,22,182,8,249,80, -144,47,43,39,23,202,1,80,144,47,36,38,27,250,22,146,16,196,11,32,0, -88,148,8,36,36,41,11,9,222,11,28,192,249,22,82,195,194,11,249,22,5, -20,20,96,88,148,8,36,37,54,8,129,3,9,226,5,3,2,6,33,46,23, -199,1,23,195,1,23,196,1,23,197,1,27,250,22,128,16,28,249,22,170,9, -23,199,2,2,29,86,94,23,197,1,23,199,1,28,248,22,133,16,23,198,2, -249,22,128,16,23,201,1,23,199,1,249,80,144,45,42,39,23,201,1,23,199, -1,23,201,1,249,80,144,45,43,39,23,200,1,2,31,27,250,22,146,16,196, -11,32,0,88,148,8,36,36,41,11,9,222,11,28,192,249,22,82,195,194,11, -249,22,5,20,20,96,88,148,8,36,37,52,8,128,3,9,226,5,3,2,6, -33,48,23,199,1,23,195,1,23,196,1,23,197,1,27,250,22,128,16,28,249, -22,170,9,23,199,2,2,29,86,94,23,197,1,23,199,1,28,248,22,133,16, -23,198,2,249,22,128,16,23,201,1,23,199,1,249,80,144,45,42,39,23,201, -1,23,199,1,23,201,1,249,80,144,45,43,39,23,200,1,2,31,27,250,22, -146,16,196,11,32,0,88,148,8,36,36,41,11,9,222,11,28,192,249,22,82, -195,194,11,249,22,5,20,20,96,88,148,8,36,37,52,8,128,3,9,226,5, -3,2,6,33,50,23,199,1,23,195,1,23,196,1,23,197,1,86,95,28,248, -80,144,37,40,39,23,195,2,12,250,22,181,11,2,27,6,12,12,112,97,116, -104,45,115,116,114,105,110,103,63,23,197,2,28,28,23,195,2,28,248,22,66, -23,196,2,10,28,248,22,91,23,196,2,28,249,22,132,4,248,22,95,23,198, -2,37,28,28,248,22,66,248,22,83,23,197,2,10,248,22,168,9,248,22,160, -20,23,197,2,249,22,4,22,66,248,22,161,20,23,198,2,11,11,11,10,12, -250,22,181,11,2,27,6,71,71,40,111,114,47,99,32,35,102,32,115,121,109, -98,111,108,63,32,40,99,111,110,115,47,99,32,40,111,114,47,99,32,35,102, -32,115,121,109,98,111,108,63,41,32,40,110,111,110,45,101,109,112,116,121,45, -108,105,115,116,111,102,32,115,121,109,98,111,108,63,41,41,41,23,197,2,27, -28,23,196,2,247,22,128,5,11,27,28,23,194,2,250,22,160,2,80,143,41, -41,248,22,128,17,247,22,144,14,11,11,27,28,23,194,2,250,22,160,2,248, -22,84,23,198,2,23,198,2,11,11,28,23,193,2,86,96,23,197,1,23,195, -1,23,194,1,20,13,144,80,144,39,38,37,250,80,144,42,39,37,249,22,33, -11,80,144,44,38,37,22,129,5,248,22,104,23,197,2,27,248,22,113,23,195, -2,20,13,144,80,144,40,38,37,250,80,144,43,39,37,249,22,33,11,80,144, -45,38,37,22,178,5,28,248,22,174,15,23,197,2,23,196,1,86,94,23,196, -1,247,22,152,16,249,247,22,176,5,248,22,83,23,197,1,23,201,1,86,94, -23,193,1,90,144,47,11,89,146,37,36,11,28,248,22,135,16,23,209,2,23, -208,2,27,247,22,178,5,28,192,249,22,136,16,23,211,2,194,23,209,2,89, -146,39,37,11,248,22,131,16,23,209,1,86,94,23,196,1,89,146,38,40,11, -28,23,209,2,27,248,22,179,15,23,197,2,19,248,22,148,8,194,28,28,249, -22,134,4,23,195,4,40,249,22,151,8,2,28,249,22,154,8,197,249,22,186, -3,23,199,4,40,11,249,22,7,23,199,2,248,22,183,15,249,22,155,8,250, -22,154,8,201,36,249,22,186,3,23,203,4,40,5,3,46,115,115,249,22,7, -23,199,2,11,2,249,22,7,23,197,2,11,89,146,37,42,11,28,249,22,170, -9,23,199,2,23,197,2,23,193,2,249,22,128,16,23,196,2,23,199,2,89, -146,37,43,11,28,23,198,2,28,249,22,170,9,23,200,2,23,197,1,23,193, -1,86,94,23,193,1,249,22,128,16,23,196,2,23,200,2,86,94,23,195,1, -11,89,146,37,44,11,28,249,22,170,9,23,196,2,68,114,101,108,97,116,105, -118,101,86,94,23,194,1,2,29,23,194,1,89,146,37,45,11,247,22,157,16, -89,146,37,46,11,247,22,158,16,27,250,22,146,16,23,203,2,11,32,0,88, -148,8,36,36,41,11,9,222,11,27,28,23,194,2,249,22,82,23,203,2,23, -196,1,86,94,23,194,1,11,27,28,23,203,2,28,23,194,2,11,27,250,22, -146,16,23,207,2,11,32,0,88,148,8,36,36,41,11,9,222,11,28,192,249, -22,82,23,206,2,194,11,11,27,28,23,195,2,23,195,2,23,194,2,27,28, -23,196,2,23,196,2,248,22,168,9,23,196,2,27,28,23,204,2,28,23,196, -2,86,94,23,197,1,23,196,2,248,22,168,9,23,198,1,11,27,28,23,195, -2,27,249,22,5,88,148,36,37,48,8,129,3,9,226,24,19,18,14,33,45, -23,213,2,27,28,23,198,2,11,193,28,192,192,28,193,28,23,198,2,28,249, -22,134,4,248,22,84,196,248,22,84,23,201,2,193,11,11,11,11,28,23,193, -2,86,105,23,213,1,23,212,1,23,210,1,23,209,1,23,207,1,23,206,1, -23,205,1,23,204,1,23,197,1,23,196,1,23,195,1,23,194,1,20,13,144, -80,144,57,38,37,250,80,144,8,24,39,37,249,22,33,11,80,144,8,26,38, -37,22,129,5,11,20,13,144,80,144,57,38,37,250,80,144,8,24,39,37,249, -22,33,11,80,144,8,26,38,37,22,178,5,28,248,22,174,15,23,212,2,23, -211,1,86,94,23,211,1,247,22,152,16,249,247,22,162,16,248,22,83,23,196, -1,23,218,1,86,94,23,193,1,27,28,23,195,2,27,249,22,5,88,148,36, -37,48,8,129,3,9,226,25,20,19,16,33,47,23,214,2,27,28,23,200,2, -11,193,28,192,192,28,193,28,199,28,249,22,134,4,248,22,84,196,248,22,84, -202,193,11,11,11,11,28,23,193,2,86,103,23,214,1,23,213,1,23,211,1, -23,210,1,23,207,1,23,206,1,23,205,1,23,197,1,23,196,1,23,195,1, -20,13,144,80,144,58,38,37,250,80,144,8,25,39,37,249,22,33,11,80,144, -8,27,38,37,22,129,5,23,211,1,20,13,144,80,144,58,38,37,250,80,144, -8,25,39,37,249,22,33,11,80,144,8,27,38,37,22,178,5,28,248,22,174, -15,23,213,2,23,212,1,86,94,23,212,1,247,22,152,16,249,247,22,162,16, -248,22,83,23,196,1,23,219,1,86,94,23,193,1,27,28,23,197,2,27,249, -22,5,20,20,94,88,148,36,37,48,8,128,3,9,226,26,21,20,16,33,49, -23,209,1,23,215,2,27,28,23,200,2,11,193,28,192,192,28,193,28,23,200, -2,28,249,22,134,4,248,22,84,196,248,22,84,23,203,2,193,11,11,11,86, -94,23,206,1,11,28,23,193,2,86,101,23,212,1,23,211,1,23,209,1,23, -208,1,23,207,1,23,198,1,23,197,1,23,196,1,86,94,27,248,22,83,23, -195,2,28,23,215,2,250,22,158,2,248,22,84,23,219,1,23,219,1,250,22, -92,23,199,1,11,23,217,2,12,20,13,144,80,144,59,38,37,250,80,144,8, -26,39,37,249,22,33,11,80,144,8,28,38,37,22,129,5,11,20,13,144,80, -144,59,38,37,250,80,144,8,26,39,37,249,22,33,11,80,144,8,28,38,37, -22,178,5,28,248,22,174,15,23,214,2,23,213,1,86,94,23,213,1,247,22, -152,16,249,247,22,176,5,248,22,160,20,23,196,1,23,220,1,86,94,23,193, -1,27,28,23,197,1,27,249,22,5,20,20,95,88,148,36,37,48,8,128,3, -9,226,27,22,21,18,33,51,23,211,1,23,215,1,23,216,1,27,28,23,201, -2,11,193,28,192,192,28,193,28,200,28,249,22,134,4,248,22,84,196,248,22, -84,203,193,11,11,11,86,96,23,213,1,23,212,1,23,208,1,11,28,23,193, -2,86,95,23,209,1,23,198,1,86,94,27,248,22,83,23,195,2,28,23,216, -2,250,22,158,2,248,22,84,23,220,1,23,220,1,250,22,92,23,199,1,23, -217,2,23,218,2,12,20,13,144,80,144,8,24,38,37,250,80,144,8,27,39, -37,249,22,33,11,80,144,8,29,38,37,22,129,5,23,213,1,20,13,144,80, -144,8,24,38,37,250,80,144,8,27,39,37,249,22,33,11,80,144,8,29,38, -37,22,178,5,28,248,22,174,15,23,215,2,23,214,1,86,94,23,214,1,247, -22,152,16,249,247,22,176,5,248,22,160,20,23,196,1,23,221,1,86,94,23, -193,1,28,28,248,22,80,23,220,2,248,22,160,20,23,220,2,10,27,28,23, -199,2,86,94,23,211,1,23,210,1,86,94,23,210,1,23,211,1,28,28,248, -22,80,23,221,2,248,22,168,9,248,22,186,15,23,195,2,11,12,20,13,144, -80,144,8,25,38,37,250,80,144,8,28,39,37,249,22,33,11,80,144,8,30, -38,37,22,129,5,28,23,223,2,28,23,202,1,11,23,196,2,86,94,23,202, -1,11,20,13,144,80,144,8,25,38,37,250,80,144,8,28,39,37,249,22,33, -11,80,144,8,30,38,37,22,178,5,28,248,22,174,15,23,216,2,23,215,1, -86,94,23,215,1,247,22,152,16,249,247,22,176,5,23,195,1,23,222,1,12, -28,23,194,2,250,22,158,2,248,22,84,23,198,1,23,196,1,250,22,92,23, -201,1,23,202,1,23,203,1,12,27,249,22,190,8,80,144,39,47,38,249,22, -129,4,248,22,189,3,248,22,175,2,200,8,128,8,27,28,193,248,22,178,2, -194,11,28,192,27,249,22,102,198,195,28,192,248,22,84,193,11,11,27,249,22, -129,4,248,22,189,3,248,22,175,2,23,199,2,8,128,8,27,249,22,190,8, -80,144,40,47,38,23,196,2,250,22,191,8,80,144,41,47,38,23,197,1,248, -22,177,2,249,22,82,249,22,82,23,204,1,23,205,1,27,28,23,200,2,248, -22,178,2,200,11,28,192,192,9,32,56,88,149,8,38,39,51,11,2,32,36, -223,3,33,71,32,57,88,149,8,38,39,50,11,2,32,36,223,3,33,70,32, -58,88,148,8,36,37,50,11,2,33,222,33,69,32,59,88,149,8,38,39,50, -11,2,32,36,223,3,33,60,28,249,22,130,4,23,197,2,23,195,4,248,22, -92,194,28,249,22,137,9,7,47,249,22,158,7,23,198,2,23,199,2,249,22, -82,250,22,176,7,23,199,2,36,23,200,2,248,2,58,249,22,176,7,23,199, -1,248,22,183,3,23,201,1,250,2,59,23,196,4,196,248,22,183,3,198,32, -61,88,149,8,38,39,52,11,2,32,36,223,3,33,68,32,62,88,149,8,38, -39,51,11,2,32,36,223,3,33,65,32,63,88,149,8,38,39,50,11,2,32, -36,223,3,33,64,28,249,22,130,4,23,197,2,23,195,4,248,22,92,194,28, -249,22,137,9,7,47,249,22,158,7,23,198,2,23,199,2,249,22,82,250,22, -176,7,23,199,2,36,23,200,2,248,2,58,249,22,176,7,23,199,1,248,22, -183,3,23,201,1,250,2,63,23,196,4,196,248,22,183,3,198,28,249,22,130, -4,23,197,2,23,195,4,248,22,92,194,28,249,22,137,9,7,47,249,22,158, -7,23,198,2,23,199,2,249,22,82,250,22,176,7,23,199,2,36,23,200,2, -27,249,22,176,7,23,199,1,248,22,183,3,23,201,1,19,248,22,157,7,23, -195,2,250,2,63,23,196,4,23,197,1,36,2,27,248,22,183,3,23,197,1, -28,249,22,130,4,23,195,2,23,196,4,248,22,92,195,28,249,22,137,9,7, -47,249,22,158,7,23,199,2,23,197,2,249,22,82,250,22,176,7,23,200,2, -36,23,198,2,248,2,58,249,22,176,7,23,200,1,248,22,183,3,23,199,1, -250,2,62,23,197,4,197,248,22,183,3,196,32,66,88,149,8,38,39,50,11, -2,32,36,223,3,33,67,28,249,22,130,4,23,197,2,23,195,4,248,22,92, -194,28,249,22,137,9,7,47,249,22,158,7,23,198,2,23,199,2,249,22,82, -250,22,176,7,23,199,2,36,23,200,2,248,2,58,249,22,176,7,23,199,1, -248,22,183,3,23,201,1,250,2,66,23,196,4,196,248,22,183,3,198,28,249, -22,130,4,23,197,2,23,195,4,248,22,92,194,28,249,22,137,9,7,47,249, -22,158,7,23,198,2,23,199,2,249,22,82,250,22,176,7,23,199,2,36,23, -200,2,27,249,22,176,7,23,199,1,248,22,183,3,23,201,1,19,248,22,157, -7,23,195,2,250,2,62,23,196,4,23,197,1,36,2,27,248,22,183,3,23, -197,1,28,249,22,130,4,23,195,2,23,196,4,248,22,92,195,28,249,22,137, -9,7,47,249,22,158,7,23,199,2,23,197,2,249,22,82,250,22,176,7,23, -200,2,36,23,198,2,27,249,22,176,7,23,200,1,248,22,183,3,23,199,1, -19,248,22,157,7,23,195,2,250,2,66,23,196,4,23,197,1,36,2,27,248, -22,183,3,23,195,1,28,249,22,130,4,23,195,2,23,197,4,248,22,92,196, -28,249,22,137,9,7,47,249,22,158,7,23,200,2,23,197,2,249,22,82,250, -22,176,7,23,201,2,36,23,198,2,248,2,58,249,22,176,7,23,201,1,248, -22,183,3,23,199,1,250,2,61,23,198,4,198,248,22,183,3,196,19,248,22, -157,7,23,195,2,28,249,22,130,4,36,23,195,4,248,22,92,194,28,249,22, -137,9,7,47,249,22,158,7,23,198,2,36,249,22,82,250,22,176,7,23,199, -2,36,36,27,249,22,176,7,23,199,1,37,19,248,22,157,7,23,195,2,250, -2,59,23,196,4,23,197,1,36,2,28,249,22,130,4,37,23,195,4,248,22, -92,194,28,249,22,137,9,7,47,249,22,158,7,23,198,2,37,249,22,82,250, -22,176,7,23,199,2,36,37,248,2,58,249,22,176,7,23,199,1,38,250,2, -61,23,196,4,196,38,2,28,249,22,130,4,23,197,2,23,195,4,248,22,92, -194,28,249,22,137,9,7,47,249,22,158,7,23,198,2,23,199,2,249,22,82, -250,22,176,7,23,199,2,36,23,200,2,248,2,58,249,22,176,7,23,199,1, -248,22,183,3,23,201,1,250,2,57,23,196,4,196,248,22,183,3,198,28,249, -22,130,4,23,197,2,23,195,4,248,22,92,194,28,249,22,137,9,7,47,249, -22,158,7,23,198,2,23,199,2,249,22,82,250,22,176,7,23,199,2,36,23, -200,2,27,249,22,176,7,23,199,1,248,22,183,3,23,201,1,19,248,22,157, -7,23,195,2,250,2,57,23,196,4,23,197,1,36,2,27,248,22,183,3,23, -197,1,28,249,22,130,4,23,195,2,23,196,4,248,22,92,195,28,249,22,137, -9,7,47,249,22,158,7,23,199,2,23,197,2,249,22,82,250,22,176,7,23, -200,2,36,23,198,2,248,2,58,249,22,176,7,23,200,1,248,22,183,3,23, -199,1,250,2,56,23,197,4,197,248,22,183,3,196,32,72,88,148,36,37,55, -11,2,33,222,33,73,28,248,22,90,248,22,84,23,195,2,249,22,7,9,248, -22,160,20,23,196,1,90,144,38,11,89,146,38,36,11,27,248,22,161,20,23, -197,2,28,248,22,90,248,22,84,23,195,2,249,22,7,9,248,22,160,20,195, -90,144,38,11,89,146,38,36,11,27,248,22,161,20,196,28,248,22,90,248,22, -84,23,195,2,249,22,7,9,248,22,160,20,195,90,144,38,11,89,146,38,36, -11,248,2,72,248,22,161,20,196,249,22,7,249,22,82,248,22,160,20,199,196, -195,249,22,7,249,22,82,248,22,160,20,199,196,195,249,22,7,249,22,82,248, -22,160,20,23,200,1,23,197,1,23,196,1,27,19,248,22,157,7,23,196,2, -250,2,56,23,196,4,23,198,1,36,2,28,23,195,1,192,28,248,22,90,248, -22,84,23,195,2,249,22,7,9,248,22,160,20,23,196,1,27,248,22,161,20, -23,195,2,90,144,38,11,89,146,38,36,11,28,248,22,90,248,22,84,23,197, -2,249,22,7,9,248,22,160,20,23,198,1,27,248,22,161,20,23,197,2,90, -144,38,11,89,146,38,36,11,28,248,22,90,248,22,84,23,197,2,249,22,7, -9,248,22,160,20,197,90,144,38,11,89,146,38,36,11,248,2,72,248,22,161, -20,198,249,22,7,249,22,82,248,22,160,20,201,196,195,249,22,7,249,22,82, -248,22,160,20,23,203,1,196,195,249,22,7,249,22,82,248,22,160,20,23,201, -1,23,197,1,23,196,1,248,22,143,12,252,22,162,10,248,22,165,4,23,200, -2,248,22,161,4,23,200,2,248,22,162,4,23,200,2,248,22,163,4,23,200, -2,248,22,164,4,23,200,1,28,24,194,2,12,20,13,144,80,144,36,58,37, -80,143,36,56,89,146,37,37,10,249,22,131,5,21,94,2,34,6,19,19,112, -108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,114,107,116,1,27,112, -108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115, -111,108,118,101,114,12,27,28,23,195,2,28,249,22,170,9,23,197,2,80,143, -39,52,86,94,23,195,1,80,143,37,53,27,248,22,154,5,23,197,2,27,28, -248,22,80,23,195,2,248,22,160,20,23,195,1,23,194,1,28,248,22,174,15, -23,194,2,90,144,39,11,89,146,39,36,11,248,22,131,16,23,197,1,86,95, -20,18,144,11,80,143,42,52,199,20,18,144,11,80,143,42,53,192,192,11,11, -28,23,193,2,192,86,94,23,193,1,27,247,22,178,5,28,23,193,2,192,86, -94,23,193,1,247,22,152,16,90,144,39,11,89,146,39,36,11,248,22,131,16, -23,198,2,86,95,23,195,1,23,193,1,28,249,22,167,16,0,11,35,114,120, -34,91,46,93,115,115,36,34,248,22,179,15,23,197,1,249,80,144,41,59,39, -23,199,1,2,28,196,249,80,144,38,54,39,195,10,249,22,14,23,196,1,80, -144,38,51,38,86,96,28,248,22,152,5,23,196,2,12,250,22,181,11,2,23, -6,21,21,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97, -116,104,63,23,198,2,28,28,23,196,2,248,22,145,14,23,197,2,10,12,250, -22,181,11,2,23,6,20,20,40,111,114,47,99,32,35,102,32,110,97,109,101, -115,112,97,99,101,63,41,23,199,2,28,24,193,2,248,24,194,1,23,196,2, -86,94,23,193,1,12,27,250,22,160,2,80,144,41,41,38,248,22,128,17,247, -22,144,14,11,27,28,23,194,2,23,194,1,86,94,23,194,1,27,249,22,82, -247,22,140,2,247,22,140,2,86,94,250,22,158,2,80,144,43,41,38,248,22, -128,17,247,22,144,14,195,192,86,94,250,22,158,2,248,22,83,23,197,2,23, -200,2,68,100,101,99,108,97,114,101,100,28,23,198,2,27,28,248,22,80,248, -22,154,5,23,200,2,248,22,153,5,248,22,83,248,22,154,5,23,201,1,23, -198,1,27,250,22,160,2,80,144,44,41,38,248,22,128,17,23,204,1,11,28, -23,193,2,27,250,22,160,2,248,22,84,23,198,1,23,198,2,11,28,23,193, -2,250,22,158,2,248,22,161,20,23,200,1,23,198,1,23,196,1,12,12,12, -86,94,251,22,138,12,247,22,142,12,65,101,114,114,111,114,6,69,69,100,101, -102,97,117,108,116,32,109,111,100,117,108,101,32,110,97,109,101,32,114,101,115, -111,108,118,101,114,32,99,97,108,108,101,100,32,119,105,116,104,32,116,104,114, -101,101,32,97,114,103,117,109,101,110,116,115,32,40,100,101,112,114,101,99,97, -116,101,100,41,11,251,24,197,1,23,198,1,23,199,1,23,200,1,10,32,83, -88,148,36,38,47,11,76,102,108,97,116,116,101,110,45,115,117,98,45,112,97, -116,104,222,33,86,32,84,88,148,36,40,54,11,2,33,222,33,85,28,248,22, -90,23,197,2,28,248,22,90,195,192,249,22,82,194,248,22,97,197,28,249,22, -172,9,248,22,83,23,199,2,2,37,28,248,22,90,23,196,2,86,95,23,196, -1,23,195,1,250,22,177,11,2,23,6,37,37,116,111,111,32,109,97,110,121, -32,34,46,46,34,115,32,105,110,32,115,117,98,109,111,100,117,108,101,32,112, -97,116,104,58,32,126,46,115,250,22,93,2,36,28,249,22,172,9,23,201,2, -2,38,23,199,1,28,248,22,174,15,23,200,2,23,199,1,249,22,92,28,248, -22,66,23,202,2,2,4,2,39,23,201,1,23,200,1,251,2,84,196,197,248, -22,84,199,248,22,161,20,200,251,2,84,196,197,249,22,82,248,22,160,20,202, -200,248,22,161,20,200,251,2,84,196,197,9,197,27,250,22,177,7,27,28,23, -199,2,28,247,22,130,12,248,80,144,44,55,39,23,200,2,11,11,28,192,192, -6,29,29,115,116,97,110,100,97,114,100,45,109,111,100,117,108,101,45,110,97, -109,101,45,114,101,115,111,108,118,101,114,6,2,2,58,32,250,22,178,16,0, -7,35,114,120,34,92,110,34,23,203,1,249,22,138,8,6,23,23,10,32,32, -102,111,114,32,109,111,100,117,108,101,32,112,97,116,104,58,32,126,115,10,23, -202,2,248,22,173,13,28,23,196,2,251,22,181,12,23,198,1,247,22,29,248, -22,92,23,201,1,23,199,1,86,94,23,196,1,250,22,144,13,23,197,1,247, -22,29,23,198,1,32,88,88,148,8,36,37,50,11,67,115,115,45,62,114,107, -116,222,33,89,19,248,22,157,7,194,28,249,22,134,4,23,195,4,39,28,249, -22,170,9,7,46,249,22,158,7,197,249,22,186,3,23,199,4,39,28,28,249, -22,170,9,7,115,249,22,158,7,197,249,22,186,3,23,199,4,38,249,22,170, -9,7,115,249,22,158,7,197,249,22,186,3,23,199,4,37,11,249,22,177,7, -250,22,176,7,198,36,249,22,186,3,23,200,4,39,2,42,193,193,193,2,28, -249,22,160,7,194,2,38,2,29,28,249,22,160,7,194,2,37,62,117,112,192, -0,8,35,114,120,34,91,46,93,34,32,92,88,148,8,36,37,47,11,2,33, -222,33,93,28,248,22,90,23,194,2,9,250,22,93,6,4,4,10,32,32,32, -248,22,178,15,248,22,105,23,198,2,248,2,92,248,22,84,23,198,1,28,249, -22,172,9,248,22,84,23,200,2,23,197,1,28,249,22,170,9,248,22,160,20, -23,200,1,23,196,1,251,22,177,11,2,23,6,41,41,99,121,99,108,101,32, -105,110,32,108,111,97,100,105,110,103,10,32,32,97,116,32,112,97,116,104,58, -32,126,97,10,32,32,112,97,116,104,115,58,126,97,23,200,1,249,22,1,22, -177,7,248,2,92,248,22,97,23,201,1,12,12,247,23,193,1,250,22,159,4, -11,196,195,20,13,144,80,144,46,50,38,249,22,82,249,22,82,23,198,1,23, -202,1,23,195,1,20,13,144,80,144,46,38,37,252,80,144,51,39,37,249,22, -33,11,80,144,53,38,37,22,128,5,23,201,2,22,130,5,248,28,23,208,2, -20,20,94,88,148,8,36,37,46,11,9,223,15,33,96,23,208,1,86,94,23, -208,1,22,7,28,248,22,66,23,207,2,23,206,1,28,28,248,22,80,23,207, -2,249,22,170,9,248,22,160,20,23,209,2,2,34,11,23,206,1,86,94,23, -206,1,28,248,22,152,5,23,203,2,27,248,22,154,5,23,204,2,28,248,22, -66,193,249,22,92,2,4,194,192,23,202,2,249,247,22,177,5,23,201,1,27, -248,22,70,248,22,178,15,23,202,1,28,23,204,2,28,250,22,160,2,248,22, -160,20,23,202,1,23,202,1,11,249,22,82,11,205,249,22,82,194,205,192,86, -96,28,248,22,162,5,23,196,2,12,28,248,22,157,4,23,198,2,250,22,179, -11,11,6,15,15,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23, -200,2,250,22,181,11,2,23,2,35,23,198,2,28,28,23,196,2,248,22,152, -5,23,197,2,10,12,250,22,181,11,2,23,6,31,31,40,111,114,47,99,32, -35,102,32,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97, -116,104,63,41,23,199,2,28,28,23,197,2,248,22,157,4,23,198,2,10,12, -250,22,181,11,2,23,6,17,17,40,111,114,47,99,32,35,102,32,115,121,110, -116,97,120,63,41,23,200,2,28,28,248,22,80,23,196,2,249,22,170,9,248, -22,160,20,23,198,2,2,4,11,86,97,23,198,1,23,197,1,23,196,1,23, -193,1,248,22,153,5,248,22,104,23,197,1,28,28,248,22,80,23,196,2,28, -249,22,170,9,248,22,160,20,23,198,2,2,36,28,248,22,80,248,22,104,23, -197,2,249,22,170,9,248,22,108,23,198,2,2,4,11,11,11,86,97,23,198, -1,23,197,1,23,196,1,23,193,1,248,22,153,5,249,2,83,248,22,121,23, -199,2,248,22,106,23,199,1,28,28,248,22,80,23,196,2,28,249,22,170,9, -248,22,160,20,23,198,2,2,36,28,28,249,22,172,9,248,22,104,23,198,2, -2,38,10,249,22,172,9,248,22,104,23,198,2,2,37,28,23,196,2,27,248, -22,154,5,23,198,2,28,248,22,66,193,10,28,248,22,80,193,248,22,66,248, -22,160,20,194,11,11,11,11,11,86,96,23,198,1,23,197,1,23,193,1,27, -248,22,154,5,23,198,1,248,22,153,5,249,2,83,28,248,22,80,23,197,2, -248,22,160,20,23,197,2,23,196,2,27,28,249,22,172,9,248,22,104,23,203, -2,2,37,248,22,161,20,200,248,22,106,200,28,248,22,80,23,198,2,249,22, -96,248,22,161,20,199,194,192,28,28,248,22,80,23,196,2,249,22,170,9,248, -22,160,20,23,198,2,2,40,11,86,94,248,80,144,38,8,29,39,23,194,2, -253,24,199,1,23,201,1,23,202,1,23,203,1,23,204,1,11,80,143,43,56, -28,28,248,22,80,23,196,2,28,249,22,170,9,248,22,160,20,23,198,2,2, -36,28,248,22,80,248,22,104,23,197,2,249,22,170,9,248,22,108,23,198,2, -2,40,11,11,11,86,94,248,80,144,38,8,29,39,23,194,2,253,24,199,1, -248,22,104,23,202,2,23,202,1,23,203,1,23,204,1,248,22,106,23,202,1, -80,143,43,56,86,94,23,193,1,27,88,148,8,36,37,54,8,240,0,0,8, -0,79,115,104,111,119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114, -225,2,5,3,33,87,27,28,248,22,80,23,198,2,28,249,22,170,9,2,36, -248,22,160,20,23,200,2,27,248,22,104,23,199,2,28,28,249,22,172,9,23, -195,2,2,38,10,249,22,172,9,23,195,2,2,37,86,94,23,193,1,28,23, -199,2,27,248,22,154,5,23,201,2,28,248,22,80,193,248,22,160,20,193,192, -250,22,177,11,2,23,6,45,45,110,111,32,98,97,115,101,32,112,97,116,104, -32,102,111,114,32,114,101,108,97,116,105,118,101,32,115,117,98,109,111,100,117, -108,101,32,112,97,116,104,58,32,126,46,115,23,201,2,192,23,197,2,23,197, -2,27,28,248,22,80,23,199,2,28,249,22,170,9,2,36,248,22,160,20,23, -201,2,27,28,28,28,249,22,172,9,248,22,104,23,202,2,2,38,10,249,22, -172,9,248,22,104,23,202,2,2,37,23,200,2,11,27,248,22,154,5,23,202, -2,27,28,249,22,172,9,248,22,104,23,204,2,2,37,248,22,161,20,23,202, -1,248,22,106,23,202,1,28,248,22,80,23,195,2,249,2,83,248,22,160,20, -23,197,2,249,22,96,248,22,161,20,23,199,1,23,197,1,249,2,83,23,196, -1,23,195,1,249,2,83,2,38,28,249,22,172,9,248,22,104,23,204,2,2, -37,248,22,161,20,23,202,1,248,22,106,23,202,1,28,248,22,80,193,248,22, -161,20,193,11,11,11,27,28,248,22,66,23,196,2,27,248,80,144,43,48,39, -249,22,82,23,199,2,248,22,128,17,247,22,144,14,28,23,193,2,192,86,94, -23,193,1,90,144,38,11,89,146,38,36,11,249,80,144,46,54,39,248,22,73, -23,201,2,11,27,28,248,22,90,23,195,2,2,41,249,22,177,7,23,197,2, -2,42,252,80,144,50,8,24,39,23,205,1,28,248,22,90,23,200,2,23,200, -1,86,94,23,200,1,248,22,83,23,200,2,28,248,22,90,23,200,2,86,94, -23,199,1,9,248,22,84,23,200,1,23,198,1,10,28,248,22,154,7,23,196, -2,86,94,23,196,1,27,248,80,144,43,8,30,39,23,202,2,27,248,80,144, -44,48,39,249,22,82,23,200,2,23,197,2,28,23,193,2,192,86,94,23,193, -1,90,144,38,11,89,146,38,36,11,249,80,144,47,54,39,23,201,2,11,28, -248,22,90,23,194,2,86,94,23,193,1,249,22,128,16,23,198,1,248,2,88, -23,197,1,250,22,1,22,128,16,23,199,1,249,22,96,249,22,2,32,0,88, -148,8,36,37,44,11,9,222,33,90,23,200,1,248,22,92,248,2,88,23,201, -1,28,248,22,174,15,23,196,2,86,94,23,196,1,248,80,144,42,8,31,39, -248,22,138,16,28,248,22,135,16,23,198,2,23,197,2,249,22,136,16,23,199, -2,248,80,144,46,8,30,39,23,205,2,28,249,22,170,9,248,22,83,23,198, -2,2,34,27,248,80,144,43,48,39,249,22,82,23,199,2,248,22,128,17,247, -22,144,14,28,23,193,2,192,86,94,23,193,1,90,144,39,11,89,146,38,36, -11,249,80,144,47,54,39,248,22,104,23,202,2,11,89,146,37,38,11,28,248, -22,90,248,22,106,23,201,2,28,248,22,90,23,194,2,249,22,171,16,2,91, -23,196,2,11,10,27,28,23,196,2,248,2,88,23,196,2,28,248,22,90,23, -195,2,2,41,28,249,22,171,16,2,91,23,197,2,248,2,88,23,196,2,249, -22,177,7,23,197,2,2,42,27,28,23,197,1,86,94,23,196,1,249,22,96, -28,248,22,90,248,22,106,23,205,2,21,93,6,5,5,109,122,108,105,98,249, -22,1,22,96,249,22,2,80,144,53,8,32,39,248,22,106,23,208,2,23,197, -1,28,248,22,90,23,196,2,86,94,23,195,1,248,22,92,23,197,1,86,94, -23,196,1,23,195,1,252,80,144,52,8,24,39,23,207,1,248,22,83,23,199, -2,248,22,161,20,23,199,1,23,199,1,10,28,249,22,170,9,248,22,160,20, -23,198,2,2,39,248,80,144,42,8,31,39,248,22,138,16,249,22,136,16,248, -22,140,16,248,22,104,23,201,2,248,80,144,46,8,30,39,23,205,2,12,86, -94,28,28,248,22,174,15,23,194,2,10,248,22,185,8,23,194,2,12,28,23, -201,2,250,22,179,11,67,114,101,113,117,105,114,101,249,22,138,8,6,17,17, -98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2, -248,22,83,23,199,2,6,0,0,23,204,2,250,22,181,11,2,23,2,35,23, -198,2,27,28,248,22,185,8,23,195,2,249,22,190,8,23,196,2,36,249,22, -138,16,248,22,139,16,23,197,2,11,27,28,248,22,185,8,23,196,2,249,22, -190,8,23,197,2,37,248,80,144,44,8,25,39,23,195,2,90,144,39,11,89, -146,39,36,11,28,248,22,185,8,23,199,2,250,22,7,2,43,249,22,190,8, -23,203,2,38,2,43,248,22,131,16,23,198,2,86,95,23,195,1,23,193,1, -27,28,248,22,185,8,23,200,2,249,22,190,8,23,201,2,39,249,80,144,49, -59,39,23,197,2,5,0,27,28,248,22,185,8,23,201,2,249,22,190,8,23, -202,2,40,248,22,153,5,23,200,2,27,250,22,160,2,80,144,52,41,38,248, -22,128,17,247,22,144,14,11,27,28,23,194,2,23,194,1,86,94,23,194,1, -27,249,22,82,247,22,140,2,247,22,140,2,86,94,250,22,158,2,80,144,54, -41,38,248,22,128,17,247,22,144,14,195,192,27,28,23,204,2,248,22,153,5, -249,22,82,248,22,154,5,23,200,2,23,207,2,23,196,2,86,95,28,23,212, -2,28,250,22,160,2,248,22,83,23,198,2,195,11,86,96,23,211,1,23,204, -1,23,194,1,12,27,251,22,33,11,80,144,56,50,38,9,28,248,22,17,80, -144,57,51,38,80,144,56,51,38,247,22,19,27,248,22,128,17,247,22,144,14, -86,94,249,22,3,88,148,8,36,37,54,11,9,226,13,12,2,3,33,94,23, -196,2,248,28,248,22,17,80,144,55,51,38,32,0,88,148,36,37,42,11,9, -222,33,95,80,144,54,8,33,39,20,20,98,88,148,36,36,8,25,8,240,12, -64,0,0,9,233,18,21,14,15,12,11,7,6,4,1,2,33,97,23,195,1, -23,194,1,23,197,1,23,207,1,23,214,1,12,28,28,248,22,185,8,23,204, -1,86,94,23,212,1,11,28,23,212,1,28,248,22,154,7,23,206,2,10,28, -248,22,66,23,206,2,10,28,248,22,80,23,206,2,249,22,170,9,248,22,160, -20,23,208,2,2,34,11,11,249,80,144,53,49,39,28,248,22,154,7,23,208, -2,249,22,82,23,209,1,248,80,144,56,8,30,39,23,215,1,86,94,23,212, -1,249,22,82,23,209,1,248,22,128,17,247,22,144,14,252,22,187,8,23,209, -1,23,208,1,23,206,1,23,204,1,23,203,1,12,192,86,96,20,18,144,11, -80,143,36,56,248,80,144,37,8,28,37,249,22,33,11,80,144,39,58,37,248, -22,191,4,80,144,37,57,38,248,22,177,5,80,144,37,37,39,248,22,143,15, -80,144,37,45,39,20,18,144,11,80,143,36,56,248,80,144,37,8,28,37,249, -22,33,11,80,144,39,58,37,20,18,144,11,80,143,36,56,248,80,144,37,8, -28,37,249,22,33,11,80,144,39,58,37,144,36,20,114,144,36,16,1,11,16, -0,20,26,15,53,9,2,1,2,1,29,11,11,11,11,9,9,11,11,11,10, -38,80,143,36,36,20,114,144,41,16,29,2,2,2,3,30,2,6,2,7,11, -6,30,2,6,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101, -114,105,122,97,116,105,111,110,11,4,30,2,8,72,112,97,116,104,45,115,116, -114,105,110,103,63,39,196,15,2,9,30,2,8,71,114,101,114,111,111,116,45, -112,97,116,104,41,196,16,30,2,8,75,112,97,116,104,45,97,100,100,45,115, -117,102,102,105,120,41,196,12,2,10,2,11,2,12,2,13,2,14,2,15,2, -16,2,17,2,18,2,19,2,20,2,21,2,22,2,23,30,2,24,2,7,11, -6,30,2,8,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,117,102, -102,105,120,41,196,14,30,2,8,73,102,105,110,100,45,99,111,108,45,102,105, -108,101,46,196,4,30,2,8,76,110,111,114,109,97,108,45,99,97,115,101,45, -112,97,116,104,39,196,11,2,25,2,26,30,2,24,74,114,101,112,97,114,97, -109,101,116,101,114,105,122,101,11,7,16,0,37,39,36,16,0,36,16,16,2, -16,2,17,2,9,2,13,2,18,2,19,2,12,2,3,2,11,2,2,2,21, -2,14,2,15,2,10,2,20,2,23,52,11,11,11,16,3,2,25,2,22,2, -26,16,3,11,11,11,16,3,2,25,2,22,2,26,39,39,37,12,11,11,16, -0,16,0,16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,24, -20,15,16,2,248,22,181,8,69,115,111,45,115,117,102,102,105,120,80,144,36, -36,37,20,15,16,2,88,148,36,38,8,39,8,189,3,2,3,223,0,33,52, -80,144,36,37,37,20,15,16,2,32,0,88,148,8,36,41,52,11,2,10,222, -33,53,80,144,36,44,37,20,15,16,2,20,27,143,32,0,88,148,8,36,37, -42,11,2,11,222,192,32,0,88,148,8,36,37,42,11,2,11,222,192,80,144, -36,45,37,20,15,16,2,247,22,143,2,80,144,36,41,37,20,15,16,2,8, -128,8,80,144,36,46,37,20,15,16,2,249,22,186,8,8,128,8,11,80,144, -36,47,37,20,15,16,2,88,148,8,36,37,50,8,128,32,2,14,223,0,33, -54,80,144,36,48,37,20,15,16,2,88,148,8,36,38,54,8,128,32,2,15, -223,0,33,55,80,144,36,49,37,20,15,16,2,247,22,78,80,144,36,50,37, -20,15,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110, -103,80,144,36,51,37,20,15,16,2,11,80,143,36,52,20,15,16,2,11,80, -143,36,53,20,15,16,2,32,0,88,148,36,38,57,11,2,20,222,33,74,80, -144,36,54,37,20,15,16,2,32,0,88,148,8,36,37,49,11,2,21,222,33, -75,80,144,36,55,37,20,15,16,2,11,80,143,36,56,20,15,16,2,88,149, -8,34,37,45,8,240,0,0,80,0,1,21,112,114,101,112,45,112,108,97,110, -101,116,45,114,101,115,111,108,118,101,114,33,37,224,1,0,33,76,80,144,36, -8,29,39,20,15,16,2,88,148,36,37,50,8,240,0,0,3,0,67,103,101, -116,45,100,105,114,223,0,33,77,80,144,36,8,30,39,20,15,16,2,88,148, -36,37,49,8,240,0,0,128,0,72,112,97,116,104,45,115,115,45,62,114,107, -116,223,0,33,78,80,144,36,8,31,39,20,15,16,2,88,148,8,36,37,45, -8,240,0,0,4,0,9,223,0,33,79,80,144,36,8,32,39,20,15,16,2, -88,148,36,37,45,8,240,0,128,0,0,9,223,0,33,80,80,144,36,8,33, -39,20,15,16,2,27,11,20,19,143,36,90,144,37,10,89,146,37,36,10,20, -25,96,2,23,88,148,8,36,38,54,8,32,9,224,2,1,33,81,88,148,36, -39,49,11,9,223,0,33,82,88,148,36,40,8,32,16,4,8,240,44,240,0, -0,8,240,156,227,0,0,39,36,9,224,2,1,33,98,207,80,144,36,57,37, -20,15,16,2,88,148,36,36,45,16,2,8,130,8,8,176,65,2,25,223,0, -33,99,80,144,36,8,26,37,20,15,16,2,20,27,143,88,148,8,36,36,45, -16,2,36,8,144,65,2,26,223,0,33,100,88,148,8,36,36,45,16,2,36, -8,144,65,2,26,223,0,33,101,80,144,36,8,27,37,96,29,94,2,4,68, -35,37,107,101,114,110,101,108,11,29,94,2,4,69,35,37,109,105,110,45,115, -116,120,11,2,8,2,24,9,9,9,36,9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 9735); + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,9,54,46,50,46,57,48,48,46,52,84,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,103,0,0,0,1,0,0,8,0, +15,0,26,0,53,0,59,0,68,0,75,0,97,0,110,0,136,0,153,0,175, +0,183,0,195,0,210,0,226,0,244,0,9,1,21,1,37,1,60,1,84,1, +96,1,127,1,134,1,139,1,144,1,162,1,168,1,173,1,182,1,187,1,193, +1,198,1,202,1,217,1,224,1,229,1,233,1,238,1,245,1,0,2,7,2, +15,2,118,2,153,2,0,3,35,3,129,3,164,3,2,4,37,4,38,11,68, +11,119,11,194,11,210,11,226,11,240,11,0,12,75,12,91,12,107,12,123,12, +198,12,105,13,121,13,196,13,191,14,71,15,146,15,53,16,66,16,219,16,147, +17,190,17,16,18,144,18,206,18,214,18,225,18,3,20,106,20,134,20,147,20, +68,21,75,21,235,21,255,21,99,22,121,22,131,22,145,22,183,22,26,23,30, +23,37,23,243,23,137,32,190,32,214,32,238,32,0,0,17,37,0,0,3,1, +5,105,110,115,112,48,68,35,37,98,111,111,116,72,100,108,108,45,115,117,102, +102,105,120,1,25,100,101,102,97,117,108,116,45,108,111,97,100,47,117,115,101, +45,99,111,109,112,105,108,101,100,67,113,117,111,116,101,70,35,37,112,97,114, +97,109,122,29,94,2,5,2,6,11,1,20,112,97,114,97,109,101,116,101,114, +105,122,97,116,105,111,110,45,107,101,121,29,94,2,5,69,35,37,117,116,105, +108,115,11,1,24,45,109,111,100,117,108,101,45,104,97,115,104,45,116,97,98, +108,101,45,116,97,98,108,101,78,114,101,103,105,115,116,101,114,45,122,111,45, +112,97,116,104,1,20,100,101,102,97,117,108,116,45,114,101,97,100,101,114,45, +103,117,97,114,100,69,67,65,67,72,69,45,78,73,45,112,97,116,104,45,99, +97,99,104,101,76,112,97,116,104,45,99,97,99,104,101,45,103,101,116,77,112, +97,116,104,45,99,97,99,104,101,45,115,101,116,33,79,45,108,111,97,100,105, +110,103,45,102,105,108,101,110,97,109,101,1,19,45,108,111,97,100,105,110,103, +45,112,114,111,109,112,116,45,116,97,103,73,45,112,114,101,118,45,114,101,108, +116,111,77,45,112,114,101,118,45,114,101,108,116,111,45,100,105,114,1,21,115, +112,108,105,116,45,114,101,108,97,116,105,118,101,45,115,116,114,105,110,103,1, +22,102,111,114,109,97,116,45,115,111,117,114,99,101,45,108,111,99,97,116,105, +111,110,73,111,114,105,103,45,112,97,114,97,109,122,1,29,115,116,97,110,100, +97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108, +118,101,114,29,94,2,5,2,6,11,66,98,111,111,116,66,115,101,97,108,79, +108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,5,4,46,114, +107,116,66,115,97,109,101,6,6,6,110,97,116,105,118,101,5,3,46,122,111, +67,105,108,111,111,112,66,108,111,111,112,65,108,105,98,6,12,12,109,111,100, +117,108,101,45,112,97,116,104,63,68,115,117,98,109,111,100,6,2,2,46,46, +6,1,1,46,66,102,105,108,101,68,112,108,97,110,101,116,6,8,8,109,97, +105,110,46,114,107,116,6,4,4,46,114,107,116,69,105,103,110,111,114,101,100, +27,252,22,129,16,28,249,22,171,9,23,201,2,2,30,86,94,23,199,1,23, +200,1,28,248,22,134,16,23,200,2,249,22,129,16,23,202,1,23,201,1,249, +80,144,50,45,42,23,202,1,23,201,1,23,203,1,2,31,247,22,183,8,249, +80,144,50,46,42,23,203,1,80,144,50,39,41,27,250,22,147,16,196,11,32, +0,88,148,8,36,39,44,11,9,222,11,28,192,249,22,82,195,194,11,249,22, +5,20,20,96,88,148,8,36,40,57,8,129,3,9,226,5,4,3,6,33,45, +23,199,1,23,196,1,23,197,1,23,195,1,27,252,22,129,16,28,249,22,171, +9,23,201,2,2,30,86,94,23,199,1,23,200,1,28,248,22,134,16,23,200, +2,249,22,129,16,23,202,1,23,201,1,249,80,144,50,45,42,23,202,1,23, +201,1,23,203,1,2,31,247,22,183,8,249,80,144,50,46,42,23,203,1,80, +144,50,39,41,27,250,22,147,16,196,11,32,0,88,148,8,36,39,44,11,9, +222,11,28,192,249,22,82,195,194,11,249,22,5,20,20,96,88,148,8,36,40, +57,8,129,3,9,226,5,4,3,6,33,47,23,199,1,23,196,1,23,197,1, +23,195,1,27,250,22,129,16,28,249,22,171,9,23,199,2,2,30,86,94,23, +197,1,23,198,1,28,248,22,134,16,23,198,2,249,22,129,16,23,200,1,23, +199,1,249,80,144,48,45,42,23,200,1,23,199,1,23,201,1,249,80,144,48, +46,42,23,201,1,2,32,27,250,22,147,16,196,11,32,0,88,148,8,36,39, +44,11,9,222,11,28,192,249,22,82,195,194,11,249,22,5,20,20,96,88,148, +8,36,40,55,8,128,3,9,226,5,4,3,6,33,49,23,199,1,23,196,1, +23,197,1,23,195,1,27,250,22,129,16,28,249,22,171,9,23,199,2,2,30, +86,94,23,197,1,23,198,1,28,248,22,134,16,23,198,2,249,22,129,16,23, +200,1,23,199,1,249,80,144,48,45,42,23,200,1,23,199,1,23,201,1,249, +80,144,48,46,42,23,201,1,2,32,27,250,22,147,16,196,11,32,0,88,148, +8,36,39,44,11,9,222,11,28,192,249,22,82,195,194,11,249,22,5,20,20, +96,88,148,8,36,40,55,8,128,3,9,226,5,4,3,6,33,51,23,199,1, +23,196,1,23,197,1,23,195,1,86,95,28,248,80,144,40,43,42,23,195,2, +12,250,22,182,11,2,28,6,12,12,112,97,116,104,45,115,116,114,105,110,103, +63,23,197,2,28,28,23,195,2,28,248,22,66,23,196,2,10,28,248,22,91, +23,196,2,28,249,22,132,4,248,22,95,23,198,2,40,28,28,248,22,66,248, +22,83,23,197,2,10,248,22,169,9,248,22,163,20,23,197,2,249,22,4,22, +66,248,22,164,20,23,198,2,11,11,11,10,12,250,22,182,11,2,28,6,71, +71,40,111,114,47,99,32,35,102,32,115,121,109,98,111,108,63,32,40,99,111, +110,115,47,99,32,40,111,114,47,99,32,35,102,32,115,121,109,98,111,108,63, +41,32,40,110,111,110,45,101,109,112,116,121,45,108,105,115,116,111,102,32,115, +121,109,98,111,108,63,41,41,41,23,197,2,27,28,23,196,2,247,22,129,5, +11,27,28,23,194,2,250,22,160,2,80,143,44,44,248,22,129,17,247,22,145, +14,11,11,27,28,23,194,2,250,22,160,2,248,22,84,23,198,2,23,198,2, +11,11,28,23,193,2,86,96,23,197,1,23,195,1,23,194,1,20,13,144,80, +144,42,41,40,250,80,144,45,42,40,249,22,33,11,80,144,47,41,40,22,130, +5,248,22,104,23,197,2,27,248,22,113,23,195,2,20,13,144,80,144,43,41, +40,250,80,144,46,42,40,249,22,33,11,80,144,48,41,40,22,179,5,28,248, +22,175,15,23,197,2,23,196,1,86,94,23,196,1,247,22,153,16,249,247,22, +177,5,248,22,163,20,23,197,1,23,201,1,86,94,23,193,1,27,28,248,22, +136,16,23,199,2,23,198,2,27,247,22,179,5,28,192,249,22,137,16,23,201, +2,194,23,199,2,90,144,42,11,89,146,42,39,11,248,22,132,16,23,202,1, +86,94,23,195,1,90,144,41,11,89,146,41,39,11,28,23,204,2,27,248,22, +180,15,23,198,2,19,248,22,149,8,194,28,28,249,22,134,4,23,195,4,43, +249,22,152,8,2,29,249,22,155,8,197,249,22,186,3,23,199,4,43,11,249, +22,7,23,200,2,248,22,184,15,249,22,156,8,250,22,155,8,201,39,249,22, +186,3,23,203,4,43,5,3,46,115,115,249,22,7,23,200,2,11,2,249,22, +7,23,198,2,11,27,28,249,22,171,9,23,196,2,23,199,2,23,199,2,249, +22,129,16,23,198,2,23,196,2,27,28,23,196,2,28,249,22,171,9,23,198, +2,23,200,1,23,200,1,86,94,23,200,1,249,22,129,16,23,199,2,23,198, +2,86,94,23,198,1,11,27,28,249,22,171,9,23,200,2,70,114,101,108,97, +116,105,118,101,86,94,23,198,1,2,30,23,198,1,27,247,22,158,16,27,247, +22,159,16,27,250,22,147,16,23,201,2,11,32,0,88,148,8,36,39,44,11, +9,222,11,27,28,23,194,2,249,22,82,23,201,2,23,196,1,86,94,23,194, +1,11,27,28,23,199,2,28,23,194,2,11,27,250,22,147,16,23,203,2,11, +32,0,88,148,8,36,39,44,11,9,222,11,28,192,249,22,82,23,202,2,194, +11,11,27,28,23,195,2,23,195,2,23,194,2,27,28,23,196,2,23,196,2, +248,22,169,9,23,196,2,27,28,23,205,2,28,23,196,2,86,94,23,197,1, +23,196,2,248,22,169,9,23,198,1,11,27,28,23,195,2,27,249,22,5,88, +148,39,40,51,8,129,3,9,226,24,15,12,11,33,46,23,203,2,27,28,23, +198,2,11,193,28,192,192,28,193,28,23,198,2,28,249,22,134,4,248,22,84, +196,248,22,84,23,201,2,193,11,11,11,11,28,23,193,2,86,105,23,213,1, +23,212,1,23,206,1,23,205,1,23,204,1,23,203,1,23,201,1,23,200,1, +23,197,1,23,196,1,23,195,1,23,194,1,20,13,144,80,144,60,41,40,250, +80,144,8,24,42,40,249,22,33,11,80,144,8,26,41,40,22,130,5,11,20, +13,144,80,144,60,41,40,250,80,144,8,24,42,40,249,22,33,11,80,144,8, +26,41,40,22,179,5,28,248,22,175,15,23,206,2,23,205,1,86,94,23,205, +1,247,22,153,16,249,247,22,163,16,248,22,83,23,196,1,23,218,1,86,94, +23,193,1,27,28,23,195,2,27,249,22,5,88,148,39,40,51,8,129,3,9, +226,25,17,13,12,33,48,23,204,2,27,28,23,200,2,11,193,28,192,192,28, +193,28,199,28,249,22,134,4,248,22,84,196,248,22,84,202,193,11,11,11,11, +28,23,193,2,86,103,23,214,1,23,213,1,23,207,1,23,206,1,23,205,1, +23,202,1,23,201,1,23,197,1,23,196,1,23,195,1,20,13,144,80,144,61, +41,40,250,80,144,8,25,42,40,249,22,33,11,80,144,8,27,41,40,22,130, +5,23,207,1,20,13,144,80,144,61,41,40,250,80,144,8,25,42,40,249,22, +33,11,80,144,8,27,41,40,22,179,5,28,248,22,175,15,23,207,2,23,206, +1,86,94,23,206,1,247,22,153,16,249,247,22,163,16,248,22,83,23,196,1, +23,219,1,86,94,23,193,1,27,28,23,197,2,27,249,22,5,20,20,94,88, +148,39,40,51,8,128,3,9,226,26,17,14,13,33,50,23,210,1,23,205,2, +27,28,23,200,2,11,193,28,192,192,28,193,28,23,200,2,28,249,22,134,4, +248,22,84,196,248,22,84,23,203,2,193,11,11,11,86,94,23,207,1,11,28, +23,193,2,86,101,23,208,1,23,206,1,23,205,1,23,203,1,23,202,1,23, +198,1,23,197,1,23,196,1,86,94,27,248,22,83,23,195,2,28,23,215,2, +250,22,158,2,248,22,84,23,219,1,23,219,1,250,22,92,23,199,1,11,23, +211,2,12,20,13,144,80,144,8,23,41,40,250,80,144,8,26,42,40,249,22, +33,11,80,144,8,28,41,40,22,130,5,11,20,13,144,80,144,8,23,41,40, +250,80,144,8,26,42,40,249,22,33,11,80,144,8,28,41,40,22,179,5,28, +248,22,175,15,23,208,2,23,207,1,86,94,23,207,1,247,22,153,16,249,247, +22,177,5,248,22,163,20,23,196,1,23,220,1,86,94,23,193,1,27,28,23, +197,1,27,249,22,5,20,20,95,88,148,39,40,51,8,128,3,9,226,27,19, +15,14,33,52,23,207,1,23,212,1,23,206,1,27,28,23,201,2,11,193,28, +192,192,28,193,28,200,28,249,22,134,4,248,22,84,196,248,22,84,203,193,11, +11,11,86,96,23,209,1,23,204,1,23,203,1,11,28,23,193,2,86,95,23, +207,1,23,198,1,86,94,27,248,22,83,23,195,2,28,23,216,2,250,22,158, +2,248,22,84,23,220,1,23,220,1,250,22,92,23,199,1,23,213,2,23,212, +2,12,20,13,144,80,144,8,24,41,40,250,80,144,8,27,42,40,249,22,33, +11,80,144,8,29,41,40,22,130,5,23,209,1,20,13,144,80,144,8,24,41, +40,250,80,144,8,27,42,40,249,22,33,11,80,144,8,29,41,40,22,179,5, +28,248,22,175,15,23,209,2,23,208,1,86,94,23,208,1,247,22,153,16,249, +247,22,177,5,248,22,163,20,23,196,1,23,221,1,86,94,23,193,1,28,28, +248,22,80,23,220,2,248,22,163,20,23,220,2,10,27,28,23,199,2,86,94, +23,207,1,23,208,1,86,94,23,208,1,23,207,1,28,28,248,22,80,23,221, +2,248,22,169,9,248,22,187,15,23,195,2,11,12,20,13,144,80,144,8,25, +41,40,250,80,144,8,28,42,40,249,22,33,11,80,144,8,30,41,40,22,130, +5,28,23,223,2,28,23,202,1,11,23,196,2,86,94,23,202,1,11,20,13, +144,80,144,8,25,41,40,250,80,144,8,28,42,40,249,22,33,11,80,144,8, +30,41,40,22,179,5,28,248,22,175,15,23,210,2,23,209,1,86,94,23,209, +1,247,22,153,16,249,247,22,177,5,23,195,1,23,222,1,12,28,23,194,2, +250,22,158,2,248,22,84,23,198,1,23,196,1,250,22,92,23,201,1,23,202, +1,23,203,1,12,27,249,22,191,8,80,144,42,50,41,249,22,129,4,248,22, +189,3,248,22,175,2,200,8,128,8,27,28,193,248,22,178,2,194,11,28,192, +27,249,22,102,198,195,28,192,248,22,84,193,11,11,27,249,22,129,4,248,22, +189,3,248,22,175,2,23,199,2,8,128,8,27,249,22,191,8,80,144,43,50, +41,23,196,2,250,22,128,9,80,144,44,50,41,23,197,1,248,22,177,2,249, +22,82,249,22,82,23,204,1,23,205,1,27,28,23,200,2,248,22,178,2,200, +11,28,192,192,9,32,57,88,149,8,38,42,54,11,2,33,39,223,3,33,72, +32,58,88,149,8,38,42,53,11,2,33,39,223,3,33,71,32,59,88,148,8, +36,40,53,11,2,34,222,33,70,32,60,88,149,8,38,42,53,11,2,33,39, +223,3,33,61,28,249,22,130,4,23,197,2,23,195,4,248,22,92,194,28,249, +22,138,9,7,47,249,22,159,7,23,198,2,23,199,2,249,22,82,250,22,177, +7,23,199,2,39,23,200,2,248,2,59,249,22,177,7,23,199,1,248,22,183, +3,23,201,1,250,2,60,23,196,4,196,248,22,183,3,198,32,62,88,149,8, +38,42,55,11,2,33,39,223,3,33,69,32,63,88,149,8,38,42,54,11,2, +33,39,223,3,33,66,32,64,88,149,8,38,42,53,11,2,33,39,223,3,33, +65,28,249,22,130,4,23,197,2,23,195,4,248,22,92,194,28,249,22,138,9, +7,47,249,22,159,7,23,198,2,23,199,2,249,22,82,250,22,177,7,23,199, +2,39,23,200,2,248,2,59,249,22,177,7,23,199,1,248,22,183,3,23,201, +1,250,2,64,23,196,4,196,248,22,183,3,198,28,249,22,130,4,23,197,2, +23,195,4,248,22,92,194,28,249,22,138,9,7,47,249,22,159,7,23,198,2, +23,199,2,249,22,82,250,22,177,7,23,199,2,39,23,200,2,27,249,22,177, +7,23,199,1,248,22,183,3,23,201,1,19,248,22,158,7,23,195,2,250,2, +64,23,196,4,23,197,1,39,2,27,248,22,183,3,23,197,1,28,249,22,130, +4,23,195,2,23,196,4,248,22,92,195,28,249,22,138,9,7,47,249,22,159, +7,23,199,2,23,197,2,249,22,82,250,22,177,7,23,200,2,39,23,198,2, +248,2,59,249,22,177,7,23,200,1,248,22,183,3,23,199,1,250,2,63,23, +197,4,197,248,22,183,3,196,32,67,88,149,8,38,42,53,11,2,33,39,223, +3,33,68,28,249,22,130,4,23,197,2,23,195,4,248,22,92,194,28,249,22, +138,9,7,47,249,22,159,7,23,198,2,23,199,2,249,22,82,250,22,177,7, +23,199,2,39,23,200,2,248,2,59,249,22,177,7,23,199,1,248,22,183,3, +23,201,1,250,2,67,23,196,4,196,248,22,183,3,198,28,249,22,130,4,23, +197,2,23,195,4,248,22,92,194,28,249,22,138,9,7,47,249,22,159,7,23, +198,2,23,199,2,249,22,82,250,22,177,7,23,199,2,39,23,200,2,27,249, +22,177,7,23,199,1,248,22,183,3,23,201,1,19,248,22,158,7,23,195,2, +250,2,63,23,196,4,23,197,1,39,2,27,248,22,183,3,23,197,1,28,249, +22,130,4,23,195,2,23,196,4,248,22,92,195,28,249,22,138,9,7,47,249, +22,159,7,23,199,2,23,197,2,249,22,82,250,22,177,7,23,200,2,39,23, +198,2,27,249,22,177,7,23,200,1,248,22,183,3,23,199,1,19,248,22,158, +7,23,195,2,250,2,67,23,196,4,23,197,1,39,2,27,248,22,183,3,23, +195,1,28,249,22,130,4,23,195,2,23,197,4,248,22,92,196,28,249,22,138, +9,7,47,249,22,159,7,23,200,2,23,197,2,249,22,82,250,22,177,7,23, +201,2,39,23,198,2,248,2,59,249,22,177,7,23,201,1,248,22,183,3,23, +199,1,250,2,62,23,198,4,198,248,22,183,3,196,19,248,22,158,7,23,195, +2,28,249,22,130,4,39,23,195,4,248,22,92,194,28,249,22,138,9,7,47, +249,22,159,7,23,198,2,39,249,22,82,250,22,177,7,23,199,2,39,39,27, +249,22,177,7,23,199,1,40,19,248,22,158,7,23,195,2,250,2,60,23,196, +4,23,197,1,39,2,28,249,22,130,4,40,23,195,4,248,22,92,194,28,249, +22,138,9,7,47,249,22,159,7,23,198,2,40,249,22,82,250,22,177,7,23, +199,2,39,40,248,2,59,249,22,177,7,23,199,1,41,250,2,62,23,196,4, +196,41,2,28,249,22,130,4,23,197,2,23,195,4,248,22,92,194,28,249,22, +138,9,7,47,249,22,159,7,23,198,2,23,199,2,249,22,82,250,22,177,7, +23,199,2,39,23,200,2,248,2,59,249,22,177,7,23,199,1,248,22,183,3, +23,201,1,250,2,58,23,196,4,196,248,22,183,3,198,28,249,22,130,4,23, +197,2,23,195,4,248,22,92,194,28,249,22,138,9,7,47,249,22,159,7,23, +198,2,23,199,2,249,22,82,250,22,177,7,23,199,2,39,23,200,2,27,249, +22,177,7,23,199,1,248,22,183,3,23,201,1,19,248,22,158,7,23,195,2, +250,2,58,23,196,4,23,197,1,39,2,27,248,22,183,3,23,197,1,28,249, +22,130,4,23,195,2,23,196,4,248,22,92,195,28,249,22,138,9,7,47,249, +22,159,7,23,199,2,23,197,2,249,22,82,250,22,177,7,23,200,2,39,23, +198,2,248,2,59,249,22,177,7,23,200,1,248,22,183,3,23,199,1,250,2, +57,23,197,4,197,248,22,183,3,196,32,73,88,148,39,40,58,11,2,34,222, +33,74,28,248,22,90,248,22,84,23,195,2,249,22,7,9,248,22,163,20,23, +196,1,90,144,41,11,89,146,41,39,11,27,248,22,164,20,23,197,2,28,248, +22,90,248,22,84,23,195,2,249,22,7,9,248,22,163,20,195,90,144,41,11, +89,146,41,39,11,27,248,22,164,20,196,28,248,22,90,248,22,84,23,195,2, +249,22,7,9,248,22,163,20,195,90,144,41,11,89,146,41,39,11,248,2,73, +248,22,164,20,196,249,22,7,249,22,82,248,22,163,20,199,196,195,249,22,7, +249,22,82,248,22,163,20,199,196,195,249,22,7,249,22,82,248,22,163,20,23, +200,1,23,197,1,23,196,1,27,19,248,22,158,7,23,196,2,250,2,57,23, +196,4,23,198,1,39,2,28,23,195,1,192,28,248,22,90,248,22,84,23,195, +2,249,22,7,9,248,22,163,20,23,196,1,27,248,22,164,20,23,195,2,90, +144,41,11,89,146,41,39,11,28,248,22,90,248,22,84,23,197,2,249,22,7, +9,248,22,163,20,23,198,1,27,248,22,164,20,23,197,2,90,144,41,11,89, +146,41,39,11,28,248,22,90,248,22,84,23,197,2,249,22,7,9,248,22,163, +20,197,90,144,41,11,89,146,41,39,11,248,2,73,248,22,164,20,198,249,22, +7,249,22,82,248,22,163,20,201,196,195,249,22,7,249,22,82,248,22,163,20, +23,203,1,196,195,249,22,7,249,22,82,248,22,163,20,23,201,1,23,197,1, +23,196,1,248,22,144,12,252,22,163,10,248,22,165,4,23,200,2,248,22,161, +4,23,200,2,248,22,162,4,23,200,2,248,22,163,4,23,200,2,248,22,164, +4,23,200,1,28,24,194,2,12,20,13,144,80,144,39,61,40,80,143,39,59, +89,146,40,40,10,249,22,132,5,21,94,2,35,6,19,19,112,108,97,110,101, +116,47,114,101,115,111,108,118,101,114,46,114,107,116,1,27,112,108,97,110,101, +116,45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101, +114,12,27,28,23,195,2,28,249,22,171,9,23,197,2,80,143,42,55,86,94, +23,195,1,80,143,40,56,27,248,22,155,5,23,197,2,27,28,248,22,80,23, +195,2,248,22,163,20,23,195,1,23,194,1,28,248,22,175,15,23,194,2,90, +144,42,11,89,146,42,39,11,248,22,132,16,23,197,1,86,95,20,18,144,11, +80,143,45,55,199,20,18,144,11,80,143,45,56,192,192,11,11,28,23,193,2, +192,86,94,23,193,1,27,247,22,179,5,28,23,193,2,192,86,94,23,193,1, +247,22,153,16,90,144,42,11,89,146,42,39,11,248,22,132,16,23,198,2,86, +95,23,195,1,23,193,1,28,249,22,168,16,0,11,35,114,120,34,91,46,93, +115,115,36,34,248,22,180,15,23,197,1,249,80,144,44,8,23,42,23,199,1, +2,29,196,249,80,144,41,57,42,195,10,249,22,14,23,196,1,80,144,41,54, +41,86,96,28,248,22,153,5,23,196,2,12,250,22,182,11,2,24,6,21,21, +114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,63, +23,198,2,28,28,23,196,2,248,22,146,14,23,197,2,10,12,250,22,182,11, +2,24,6,20,20,40,111,114,47,99,32,35,102,32,110,97,109,101,115,112,97, +99,101,63,41,23,199,2,28,24,193,2,248,24,194,1,23,196,2,86,94,23, +193,1,12,27,250,22,160,2,80,144,44,44,41,248,22,129,17,247,22,145,14, +11,27,28,23,194,2,23,194,1,86,94,23,194,1,27,249,22,82,247,22,140, +2,247,22,140,2,86,94,250,22,158,2,80,144,46,44,41,248,22,129,17,247, +22,145,14,195,192,86,94,250,22,158,2,248,22,83,23,197,2,23,200,2,70, +100,101,99,108,97,114,101,100,28,23,198,2,27,28,248,22,80,248,22,155,5, +23,200,2,248,22,154,5,248,22,83,248,22,155,5,23,201,1,23,198,1,27, +250,22,160,2,80,144,47,44,41,248,22,129,17,23,204,1,11,28,23,193,2, +27,250,22,160,2,248,22,84,23,198,1,23,198,2,11,28,23,193,2,250,22, +158,2,248,22,164,20,23,200,1,23,198,1,23,196,1,12,12,12,86,94,251, +22,139,12,247,22,143,12,67,101,114,114,111,114,6,69,69,100,101,102,97,117, +108,116,32,109,111,100,117,108,101,32,110,97,109,101,32,114,101,115,111,108,118, +101,114,32,99,97,108,108,101,100,32,119,105,116,104,32,116,104,114,101,101,32, +97,114,103,117,109,101,110,116,115,32,40,100,101,112,114,101,99,97,116,101,100, +41,11,251,24,197,1,23,198,1,23,199,1,23,200,1,10,32,84,88,148,39, +41,50,11,78,102,108,97,116,116,101,110,45,115,117,98,45,112,97,116,104,222, +33,87,32,85,88,148,39,43,57,11,2,34,222,33,86,28,248,22,90,23,197, +2,28,248,22,90,195,192,249,22,82,194,248,22,97,197,28,249,22,173,9,248, +22,83,23,199,2,2,38,28,248,22,90,23,196,2,86,95,23,196,1,23,195, +1,250,22,178,11,2,24,6,37,37,116,111,111,32,109,97,110,121,32,34,46, +46,34,115,32,105,110,32,115,117,98,109,111,100,117,108,101,32,112,97,116,104, +58,32,126,46,115,250,22,93,2,37,28,249,22,173,9,23,201,2,2,39,23, +199,1,28,248,22,175,15,23,200,2,23,199,1,249,22,92,28,248,22,66,23, +202,2,2,5,2,40,23,201,1,23,200,1,251,2,85,196,197,248,22,84,199, +248,22,164,20,200,251,2,85,196,197,249,22,82,248,22,163,20,202,200,248,22, +164,20,200,251,2,85,196,197,9,197,27,250,22,178,7,27,28,23,199,2,28, +247,22,131,12,248,80,144,47,58,42,23,200,2,11,11,28,192,192,6,29,29, +115,116,97,110,100,97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45, +114,101,115,111,108,118,101,114,6,2,2,58,32,250,22,179,16,0,7,35,114, +120,34,92,110,34,23,203,1,249,22,139,8,6,23,23,10,32,32,102,111,114, +32,109,111,100,117,108,101,32,112,97,116,104,58,32,126,115,10,23,202,2,248, +22,174,13,28,23,196,2,251,22,182,12,23,198,1,247,22,29,248,22,92,23, +201,1,23,199,1,86,94,23,196,1,250,22,145,13,23,197,1,247,22,29,23, +198,1,32,89,88,148,8,36,40,53,11,69,115,115,45,62,114,107,116,222,33, +90,19,248,22,158,7,194,28,249,22,134,4,23,195,4,42,28,249,22,171,9, +7,46,249,22,159,7,197,249,22,186,3,23,199,4,42,28,28,249,22,171,9, +7,115,249,22,159,7,197,249,22,186,3,23,199,4,41,249,22,171,9,7,115, +249,22,159,7,197,249,22,186,3,23,199,4,40,11,249,22,178,7,250,22,177, +7,198,39,249,22,186,3,23,200,4,42,2,43,193,193,193,2,28,249,22,161, +7,194,2,39,2,30,28,249,22,161,7,194,2,38,64,117,112,192,0,8,35, +114,120,34,91,46,93,34,32,93,88,148,8,36,40,50,11,2,34,222,33,94, +28,248,22,90,23,194,2,9,250,22,93,6,4,4,10,32,32,32,248,22,179, +15,248,22,105,23,198,2,248,2,93,248,22,164,20,23,198,1,28,249,22,173, +9,248,22,84,23,200,2,23,197,1,28,249,22,171,9,248,22,163,20,23,200, +1,23,196,1,251,22,178,11,2,24,6,41,41,99,121,99,108,101,32,105,110, +32,108,111,97,100,105,110,103,10,32,32,97,116,32,112,97,116,104,58,32,126, +97,10,32,32,112,97,116,104,115,58,126,97,23,200,1,249,22,1,22,178,7, +248,2,93,248,22,97,23,201,1,12,12,247,23,193,1,250,22,159,4,11,196, +195,20,13,144,80,144,49,53,41,249,22,82,249,22,82,23,198,1,23,202,1, +23,195,1,20,13,144,80,144,49,41,40,252,80,144,54,42,40,249,22,33,11, +80,144,56,41,40,22,129,5,23,201,2,22,131,5,248,28,23,208,2,20,20, +94,88,148,8,36,40,49,11,9,223,15,33,97,23,208,1,86,94,23,208,1, +22,7,28,248,22,66,23,207,2,23,206,1,28,28,248,22,80,23,207,2,249, +22,171,9,248,22,163,20,23,209,2,2,35,11,23,206,1,86,94,23,206,1, +28,248,22,153,5,23,203,2,27,248,22,155,5,23,204,2,28,248,22,66,193, +249,22,92,2,5,194,192,23,202,2,249,247,22,178,5,23,201,1,27,248,22, +70,248,22,179,15,23,202,1,28,23,204,2,28,250,22,160,2,248,22,163,20, +23,202,1,23,202,1,11,249,22,82,11,205,249,22,82,194,205,192,86,96,28, +248,22,163,5,23,196,2,12,28,248,22,157,4,23,198,2,250,22,180,11,11, +6,15,15,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,200,2, +250,22,182,11,2,24,2,36,23,198,2,28,28,23,196,2,248,22,153,5,23, +197,2,10,12,250,22,182,11,2,24,6,31,31,40,111,114,47,99,32,35,102, +32,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104, +63,41,23,199,2,28,28,23,197,2,248,22,157,4,23,198,2,10,12,250,22, +182,11,2,24,6,17,17,40,111,114,47,99,32,35,102,32,115,121,110,116,97, +120,63,41,23,200,2,28,28,248,22,80,23,196,2,249,22,171,9,248,22,163, +20,23,198,2,2,5,11,86,97,23,198,1,23,197,1,23,196,1,23,193,1, +248,22,154,5,248,22,104,23,197,1,28,28,248,22,80,23,196,2,28,249,22, +171,9,248,22,163,20,23,198,2,2,37,28,248,22,80,248,22,104,23,197,2, +249,22,171,9,248,22,108,23,198,2,2,5,11,11,11,86,97,23,198,1,23, +197,1,23,196,1,23,193,1,248,22,154,5,249,2,84,248,22,121,23,199,2, +248,22,106,23,199,1,28,28,248,22,80,23,196,2,28,249,22,171,9,248,22, +163,20,23,198,2,2,37,28,28,249,22,173,9,248,22,104,23,198,2,2,39, +10,249,22,173,9,248,22,104,23,198,2,2,38,28,23,196,2,27,248,22,155, +5,23,198,2,28,248,22,66,193,10,28,248,22,80,193,248,22,66,248,22,163, +20,194,11,11,11,11,11,86,96,23,198,1,23,197,1,23,193,1,27,248,22, +155,5,23,198,1,248,22,154,5,249,2,84,28,248,22,80,23,197,2,248,22, +163,20,23,197,2,23,196,2,27,28,249,22,173,9,248,22,104,23,203,2,2, +38,248,22,164,20,200,248,22,106,200,28,248,22,80,23,198,2,249,22,96,248, +22,164,20,199,194,192,28,28,248,22,80,23,196,2,249,22,171,9,248,22,163, +20,23,198,2,2,41,11,86,94,248,80,144,41,8,29,42,23,194,2,253,24, +199,1,23,201,1,23,202,1,23,203,1,23,204,1,11,80,143,46,59,28,28, +248,22,80,23,196,2,28,249,22,171,9,248,22,163,20,23,198,2,2,37,28, +248,22,80,248,22,104,23,197,2,249,22,171,9,248,22,108,23,198,2,2,41, +11,11,11,86,94,248,80,144,41,8,29,42,23,194,2,253,24,199,1,248,22, +104,23,202,2,23,202,1,23,203,1,23,204,1,248,22,106,23,202,1,80,143, +46,59,86,94,23,193,1,27,88,148,8,36,40,57,8,240,0,0,8,0,1, +19,115,104,111,119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,225, +2,5,3,33,88,27,28,248,22,80,23,198,2,28,249,22,171,9,2,37,248, +22,163,20,23,200,2,27,248,22,104,23,199,2,28,28,249,22,173,9,23,195, +2,2,39,10,249,22,173,9,23,195,2,2,38,86,94,23,193,1,28,23,199, +2,27,248,22,155,5,23,201,2,28,248,22,80,193,248,22,163,20,193,192,250, +22,178,11,2,24,6,45,45,110,111,32,98,97,115,101,32,112,97,116,104,32, +102,111,114,32,114,101,108,97,116,105,118,101,32,115,117,98,109,111,100,117,108, +101,32,112,97,116,104,58,32,126,46,115,23,201,2,192,23,197,2,23,197,2, +27,28,248,22,80,23,199,2,28,249,22,171,9,2,37,248,22,163,20,23,201, +2,27,28,28,28,249,22,173,9,248,22,104,23,202,2,2,39,10,249,22,173, +9,248,22,104,23,202,2,2,38,23,200,2,11,27,248,22,155,5,23,202,2, +27,28,249,22,173,9,248,22,104,23,204,2,2,38,248,22,164,20,23,202,1, +248,22,106,23,202,1,28,248,22,80,23,195,2,249,2,84,248,22,163,20,23, +197,2,249,22,96,248,22,164,20,23,199,1,23,197,1,249,2,84,23,196,1, +23,195,1,249,2,84,2,39,28,249,22,173,9,248,22,104,23,204,2,2,38, +248,22,164,20,23,202,1,248,22,106,23,202,1,28,248,22,80,193,248,22,164, +20,193,11,11,11,27,28,248,22,66,23,196,2,27,248,80,144,46,51,42,249, +22,82,23,199,2,248,22,129,17,247,22,145,14,28,23,193,2,192,86,94,23, +193,1,90,144,41,11,89,146,41,39,11,249,80,144,49,57,42,248,22,73,23, +201,2,11,27,28,248,22,90,23,195,2,2,42,249,22,178,7,23,197,2,2, +43,252,80,144,53,8,24,42,23,205,1,28,248,22,90,23,200,2,23,200,1, +86,94,23,200,1,248,22,83,23,200,2,28,248,22,90,23,200,2,86,94,23, +199,1,9,248,22,84,23,200,1,23,198,1,10,28,248,22,155,7,23,196,2, +86,94,23,196,1,27,248,80,144,46,8,30,42,23,202,2,27,248,80,144,47, +51,42,249,22,82,23,200,2,23,197,2,28,23,193,2,192,86,94,23,193,1, +90,144,41,11,89,146,41,39,11,249,80,144,50,57,42,23,201,2,11,28,248, +22,90,23,194,2,86,94,23,193,1,249,22,129,16,23,198,1,248,2,89,23, +197,1,250,22,1,22,129,16,23,199,1,249,22,96,249,22,2,32,0,88,148, +8,36,40,47,11,9,222,33,91,23,200,1,248,22,92,248,2,89,23,201,1, +28,248,22,175,15,23,196,2,86,94,23,196,1,248,80,144,45,8,31,42,248, +22,139,16,28,248,22,136,16,23,198,2,23,197,2,249,22,137,16,23,199,2, +248,80,144,49,8,30,42,23,205,2,28,249,22,171,9,248,22,83,23,198,2, +2,35,27,248,80,144,46,51,42,249,22,82,23,199,2,248,22,129,17,247,22, +145,14,28,23,193,2,192,86,94,23,193,1,90,144,41,11,89,146,41,39,11, +249,80,144,49,57,42,248,22,104,23,201,2,11,27,28,248,22,90,248,22,106, +23,201,2,28,248,22,90,23,195,2,249,22,172,16,2,92,23,197,2,11,10, +27,28,23,194,2,248,2,89,23,197,2,28,248,22,90,23,196,2,2,42,28, +249,22,172,16,2,92,23,198,2,248,2,89,23,197,2,249,22,178,7,23,198, +2,2,43,27,28,23,195,1,86,94,23,197,1,249,22,96,28,248,22,90,248, +22,106,23,205,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,96,249, +22,2,80,144,56,8,32,42,248,22,106,23,208,2,23,198,1,28,248,22,90, +23,197,2,86,94,23,196,1,248,22,92,23,198,1,86,94,23,197,1,23,196, +1,252,80,144,55,8,24,42,23,207,1,248,22,83,23,199,2,248,22,164,20, +23,199,1,23,199,1,10,28,249,22,171,9,248,22,163,20,23,198,2,2,40, +248,80,144,45,8,31,42,248,22,139,16,249,22,137,16,248,22,141,16,248,22, +104,23,201,2,248,80,144,49,8,30,42,23,205,2,12,86,94,28,28,248,22, +175,15,23,194,2,10,248,22,186,8,23,194,2,12,28,23,201,2,250,22,180, +11,69,114,101,113,117,105,114,101,249,22,139,8,6,17,17,98,97,100,32,109, +111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,83,23,199, +2,6,0,0,23,204,2,250,22,182,11,2,24,2,36,23,198,2,27,28,248, +22,186,8,23,195,2,249,22,191,8,23,196,2,39,249,22,139,16,248,22,140, +16,23,197,2,11,27,28,248,22,186,8,23,196,2,249,22,191,8,23,197,2, +40,248,80,144,47,8,25,42,23,195,2,90,144,42,11,89,146,42,39,11,28, +248,22,186,8,23,199,2,250,22,7,2,44,249,22,191,8,23,203,2,41,2, +44,248,22,132,16,23,198,2,86,95,23,195,1,23,193,1,27,28,248,22,186, +8,23,200,2,249,22,191,8,23,201,2,42,249,80,144,52,8,23,42,23,197, +2,5,0,27,28,248,22,186,8,23,201,2,249,22,191,8,23,202,2,43,248, +22,154,5,23,200,2,27,250,22,160,2,80,144,55,44,41,248,22,129,17,247, +22,145,14,11,27,28,23,194,2,23,194,1,86,94,23,194,1,27,249,22,82, +247,22,140,2,247,22,140,2,86,94,250,22,158,2,80,144,57,44,41,248,22, +129,17,247,22,145,14,195,192,27,28,23,204,2,248,22,154,5,249,22,82,248, +22,155,5,23,200,2,23,207,2,23,196,2,86,95,28,23,212,2,28,250,22, +160,2,248,22,83,23,198,2,195,11,86,96,23,211,1,23,204,1,23,194,1, +12,27,251,22,33,11,80,144,59,53,41,9,28,248,22,17,80,144,60,54,41, +80,144,59,54,41,247,22,19,27,248,22,129,17,247,22,145,14,86,94,249,22, +3,88,148,8,36,40,57,11,9,226,13,12,2,3,33,95,23,196,2,248,28, +248,22,17,80,144,58,54,41,32,0,88,148,39,40,45,11,9,222,33,96,80, +144,57,8,33,42,20,20,98,88,148,39,39,8,25,8,240,12,64,0,0,9, +233,18,21,14,15,12,11,7,6,4,1,2,33,98,23,195,1,23,194,1,23, +197,1,23,207,1,23,214,1,12,28,28,248,22,186,8,23,204,1,86,94,23, +212,1,11,28,23,212,1,28,248,22,155,7,23,206,2,10,28,248,22,66,23, +206,2,10,28,248,22,80,23,206,2,249,22,171,9,248,22,163,20,23,208,2, +2,35,11,11,249,80,144,56,52,42,28,248,22,155,7,23,208,2,249,22,82, +23,209,1,248,80,144,59,8,30,42,23,215,1,86,94,23,212,1,249,22,82, +23,209,1,248,22,129,17,247,22,145,14,252,22,188,8,23,209,1,23,208,1, +23,206,1,23,204,1,23,203,1,12,192,86,96,20,18,144,11,80,143,39,59, +248,80,144,40,8,28,40,249,22,33,11,80,144,42,61,40,248,22,128,5,80, +144,40,60,41,248,22,178,5,80,144,40,40,42,248,22,144,15,80,144,40,48, +42,20,18,144,11,80,143,39,59,248,80,144,40,8,28,40,249,22,33,11,80, +144,42,61,40,20,18,144,11,80,143,39,59,248,80,144,40,8,28,40,249,22, +33,11,80,144,42,61,40,144,39,20,120,145,2,1,39,16,1,11,16,0,20, +26,15,56,9,2,2,2,2,29,11,11,11,11,11,11,11,9,9,11,11,11, +10,41,80,143,39,39,20,120,145,2,1,44,16,29,2,3,2,4,30,2,7, +2,8,11,6,30,2,7,1,23,101,120,116,101,110,100,45,112,97,114,97,109, +101,116,101,114,105,122,97,116,105,111,110,11,4,30,2,9,74,112,97,116,104, +45,115,116,114,105,110,103,63,42,196,15,2,10,30,2,9,73,114,101,114,111, +111,116,45,112,97,116,104,44,196,16,30,2,9,77,112,97,116,104,45,97,100, +100,45,115,117,102,102,105,120,44,196,12,2,11,2,12,2,13,2,14,2,15, +2,16,2,17,2,18,2,19,2,20,2,21,2,22,2,23,2,24,30,2,25, +2,8,11,6,30,2,9,1,19,112,97,116,104,45,114,101,112,108,97,99,101, +45,115,117,102,102,105,120,44,196,14,30,2,9,75,102,105,110,100,45,99,111, +108,45,102,105,108,101,49,196,4,30,2,9,78,110,111,114,109,97,108,45,99, +97,115,101,45,112,97,116,104,42,196,11,2,26,2,27,30,2,25,76,114,101, +112,97,114,97,109,101,116,101,114,105,122,101,11,7,16,0,40,42,39,16,0, +39,16,16,2,17,2,18,2,10,2,14,2,19,2,20,2,13,2,4,2,12, +2,3,2,22,2,15,2,16,2,11,2,21,2,24,55,11,11,11,16,3,2, +26,2,23,2,27,16,3,11,11,11,16,3,2,26,2,23,2,27,42,42,40, +12,11,11,16,0,16,0,16,0,39,39,11,12,11,11,16,0,16,0,16,0, +39,39,16,24,20,15,16,2,248,22,182,8,71,115,111,45,115,117,102,102,105, +120,80,144,39,39,40,20,15,16,2,88,148,39,41,8,39,8,189,3,2,4, +223,0,33,53,80,144,39,40,40,20,15,16,2,32,0,88,148,8,36,44,55, +11,2,11,222,33,54,80,144,39,47,40,20,15,16,2,20,27,143,32,0,88, +148,8,36,40,45,11,2,12,222,192,32,0,88,148,8,36,40,45,11,2,12, +222,192,80,144,39,48,40,20,15,16,2,247,22,143,2,80,144,39,44,40,20, +15,16,2,8,128,8,80,144,39,49,40,20,15,16,2,249,22,187,8,8,128, +8,11,80,144,39,50,40,20,15,16,2,88,148,8,36,40,53,8,128,32,2, +15,223,0,33,55,80,144,39,51,40,20,15,16,2,88,148,8,36,41,57,8, +128,32,2,16,223,0,33,56,80,144,39,52,40,20,15,16,2,247,22,78,80, +144,39,53,40,20,15,16,2,248,22,18,76,109,111,100,117,108,101,45,108,111, +97,100,105,110,103,80,144,39,54,40,20,15,16,2,11,80,143,39,55,20,15, +16,2,11,80,143,39,56,20,15,16,2,32,0,88,148,39,41,60,11,2,21, +222,33,75,80,144,39,57,40,20,15,16,2,32,0,88,148,8,36,40,52,11, +2,22,222,33,76,80,144,39,58,40,20,15,16,2,11,80,143,39,59,20,15, +16,2,88,149,8,34,40,48,8,240,0,0,80,0,1,21,112,114,101,112,45, +112,108,97,110,101,116,45,114,101,115,111,108,118,101,114,33,40,224,1,0,33, +77,80,144,39,8,29,42,20,15,16,2,88,148,39,40,53,8,240,0,0,3, +0,69,103,101,116,45,100,105,114,223,0,33,78,80,144,39,8,30,42,20,15, +16,2,88,148,39,40,52,8,240,0,0,128,0,74,112,97,116,104,45,115,115, +45,62,114,107,116,223,0,33,79,80,144,39,8,31,42,20,15,16,2,88,148, +8,36,40,48,8,240,0,0,4,0,9,223,0,33,80,80,144,39,8,32,42, +20,15,16,2,88,148,39,40,48,8,240,0,128,0,0,9,223,0,33,81,80, +144,39,8,33,42,20,15,16,2,27,11,20,19,143,39,90,144,40,10,89,146, +40,39,10,20,25,96,2,24,88,148,8,36,41,57,8,32,9,224,2,1,33, +82,88,148,39,42,52,11,9,223,0,33,83,88,148,39,43,8,32,16,4,8, +240,44,240,0,0,8,240,156,227,0,0,42,39,9,224,2,1,33,99,207,80, +144,39,60,40,20,15,16,2,88,148,39,39,48,16,2,8,130,8,8,176,65, +2,26,223,0,33,100,80,144,39,8,26,40,20,15,16,2,20,27,143,88,148, +8,36,39,48,16,2,39,8,144,65,2,27,223,0,33,101,88,148,8,36,39, +48,16,2,39,8,144,65,2,27,223,0,33,102,80,144,39,8,27,40,96,29, +94,2,5,70,35,37,107,101,114,110,101,108,11,29,94,2,5,71,35,37,109, +105,110,45,115,116,120,11,2,9,2,25,9,9,9,39,9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 9739); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,50,46,48,46,50,84,0,0,0,0,0,0,0,0,0,0, -0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, -29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,101,1,0, -0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, -67,35,37,117,116,105,108,115,11,29,94,2,2,69,35,37,110,101,116,119,111, -114,107,11,29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2, -74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,2,66, -35,37,98,111,111,116,11,29,94,2,2,68,35,37,101,120,112,111,98,115,11, -29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,235,91, -0,0,100,144,2,3,36,36,144,2,4,36,36,144,2,5,36,36,144,2,6, -36,36,144,2,7,36,36,144,2,8,36,36,144,2,9,36,36,144,2,9,36, -36,16,0,144,36,20,114,144,36,16,1,11,16,0,20,26,15,53,9,2,1, -2,1,29,11,11,11,11,9,9,11,11,11,18,96,11,46,46,46,36,80,143, -36,36,20,114,144,36,16,0,16,0,37,39,36,16,0,36,16,0,36,11,11, -11,16,0,16,0,16,0,36,36,37,12,11,11,16,0,16,0,16,0,36,36, -11,12,11,11,16,0,16,0,16,0,36,36,16,0,104,2,9,2,8,29,94, -2,2,69,35,37,102,111,114,101,105,103,110,11,29,94,2,2,68,35,37,117, -110,115,97,102,101,11,29,94,2,2,69,35,37,102,108,102,120,110,117,109,11, -2,7,2,6,2,5,2,4,2,3,29,94,2,2,67,35,37,112,108,97,99, -101,11,29,94,2,2,69,35,37,102,117,116,117,114,101,115,11,9,9,9,36, -9,0}; - EVAL_ONE_SIZED_STR((char *)expr, 421); + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,9,54,46,50,46,57,48,48,46,52,84,0,0,0,0,0,0,0,0, +0,0,0,0,0,0,0,0,0,0,0,0,17,0,0,0,1,0,0,8,0, +18,0,24,0,38,0,52,0,64,0,84,0,98,0,113,0,126,0,131,0,134, +0,146,0,229,0,236,0,6,1,0,0,196,1,0,0,3,1,5,105,110,115, +112,48,71,35,37,98,117,105,108,116,105,110,67,113,117,111,116,101,29,94,2, +3,70,35,37,107,101,114,110,101,108,11,29,94,2,3,70,35,37,101,120,112, +111,98,115,11,29,94,2,3,68,35,37,98,111,111,116,11,29,94,2,3,76, +35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,3,70,35, +37,112,97,114,97,109,122,11,29,94,2,3,71,35,37,110,101,116,119,111,114, +107,11,29,94,2,3,69,35,37,117,116,105,108,115,11,38,11,93,2,12,36, +12,39,38,13,93,143,16,3,39,2,14,2,2,39,36,14,150,40,143,2,15, +16,4,2,4,39,39,2,1,143,2,15,16,4,2,5,39,39,2,1,143,2, +15,16,4,2,6,39,39,2,1,143,2,15,16,4,2,7,39,39,2,1,143, +2,15,16,4,2,8,39,39,2,1,143,2,15,16,4,2,9,39,39,2,1, +143,2,15,16,4,2,10,39,39,2,1,16,0,38,15,143,2,14,2,11,18, +143,16,2,143,10,16,3,9,2,11,2,13,143,11,16,3,9,9,2,13,16, +3,9,9,9,144,39,20,120,145,2,1,39,16,1,11,16,0,20,26,15,56, +9,2,2,2,2,29,11,11,11,11,11,11,11,9,9,11,11,11,33,16,39, +80,143,39,39,20,120,145,2,1,39,16,0,16,0,40,42,39,16,0,39,16, +0,39,11,11,11,16,0,16,0,16,0,39,39,40,12,11,11,16,0,16,0, +16,0,39,39,11,12,11,11,16,0,16,0,16,0,39,39,16,0,104,2,4, +2,5,29,94,2,3,71,35,37,102,111,114,101,105,103,110,11,29,94,2,3, +70,35,37,117,110,115,97,102,101,11,29,94,2,3,71,35,37,102,108,102,120, +110,117,109,11,2,6,2,7,2,8,2,9,2,10,29,94,2,3,69,35,37, +112,108,97,99,101,11,29,94,2,3,71,35,37,102,117,116,117,114,101,115,11, +9,9,9,39,9,0}; + EVAL_ONE_SIZED_STR((char *)expr, 530); } diff --git a/racket/src/racket/src/env.c b/racket/src/racket/src/env.c index e3418877ad..223f4c92d5 100644 --- a/racket/src/racket/src/env.c +++ b/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 *rns, *insp; + Scheme_Object *mc, *shift, *insp; - insp = env->access_insp; - if (!insp) - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + if (env->stx_context) return; - rns = scheme_make_module_rename_set(kind, NULL, insp); - env->rename_set = rns; - } + insp = env->access_insp; + if (!insp) + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + + if (env->module) { + 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); - eenv->rename_set = env->rename_set; + scheme_prepare_env_stx_context(env); + 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); - eenv->rename_set = env->rename_set; + scheme_prepare_env_stx_context(env); + 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,63 +1455,150 @@ 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) { - rn = scheme_get_module_rename_from_set(env->rename_set, - scheme_make_integer(env->phase), - 0); - if (rn) { - scheme_remove_module_rename(rn, n); - if (env->module) { - scheme_extend_module_rename(rn, - env->module->self_modidx, - n, n, - env->module->self_modidx, - n, - env->mod_phase, - NULL, - NULL, - 0); - } + i = SCHEME_VEC_SIZE(vec); + if (i & 1) return (Scheme_Object *)ht; /* defend against bad bytecode */ + + while (i -= 2) { + key = SCHEME_VEC_ELS(vec)[i]; + val = SCHEME_VEC_ELS(vec)[i+1]; + + /* defend against bad bytecode here, too: */ + if (kind) { + if (!SCHEME_INTP(key) + || !SCHEME_VECTORP(val)) + key = NULL; + } else { + if (!SCHEME_SYMBOLP(key) + || ((!SCHEME_STXP(val) + || !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; + + menv->binding_names = binding_names; + menv->binding_names_need_shift = 1; +} - if (stxtoo) { - if (!env->module || rn) { - if (!env->shadowed_syntax) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - env->shadowed_syntax = ht; - } - - scheme_hash_set(env->shadowed_syntax, n, scheme_true); +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); + env->shadowed_syntax = ht; } + + scheme_hash_set(env->shadowed_syntax, n, scheme_true); } else { if (env->shadowed_syntax) scheme_hash_set(env->shadowed_syntax, n, NULL); - - if (rn) { - /* If the syntax binding is a rename transformer, need to install - a mapping. */ - Scheme_Object *v; - v = scheme_lookup_in_table(env->syntax, (const char *)n); - if (v) { - v = SCHEME_PTR_VAL(v); - if (scheme_is_binding_rename_transformer(v)) { - scheme_install_free_id_rename(n, - scheme_rename_transformer_id(v), - rn, - scheme_make_integer(env->phase)); - } - } - } } + + scheme_binding_names_from_module(env); + + if (env->binding_names) { + if (SCHEME_HASHTP(env->binding_names)) + id = scheme_eq_hash_get((Scheme_Hash_Table *)env->binding_names, n); + else + id = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)env->binding_names, n); + if (id && !SCHEME_STXP(id)) + id = NULL; + } else + id = NULL; + + 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: */ - if (genv->rename_set) - obj = scheme_add_rename(obj, genv->rename_set); + obj = scheme_stx_add_module_context(obj, genv->stx_context); 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) - scheme_list_module_rename(env->rename_set, mapped, env->module_registry->exports); + if (env->stx_context) + 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) - sym = scheme_add_remove_mark(sym, scheme_current_thread->current_local_mark); + if (scheme_current_thread->current_local_scope) + 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,20 +2480,15 @@ 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))); - skips = scheme_make_pair(SCHEME_PTR2_VAL(SCHEME_CAR(l)), skips); + scope = SCHEME_PTR2_VAL(SCHEME_CAR(l)); + 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) - s = scheme_add_remove_mark(s, scheme_current_thread->current_local_mark); - - return s; -} - -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); - } + if (scheme_current_thread->current_local_scope) + 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) + s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_use_scope, scheme_env_phase(env->genv)); 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); +int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv) +{ + int mode = SCHEME_STX_FLIP; - if (!scheme_stx_is_clean(orig_sym)) - sym = scheme_stx_taint(sym); - } - - return sym; - } - - { - Scheme_Object *rn, *result; - - result = scheme_datum_to_syntax(SCHEME_STX_VAL(sym), orig_sym, sym, 0, 0); - ((Scheme_Stx *)result)->props = ((Scheme_Stx *)orig_sym)->props; - - rn = scheme_make_rename(uid, 1); - 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; - } + if (SAME_OBJ(argv[which], flip_symbol)) + 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); + + return mode; } 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, - "syntax-introducer", 1, 1); + info[0] = scope; + 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); + } + + return scheme_make_closed_prim_w_arity(introducer_proc, info, + "syntax-introducer", 1, 2); } -static Scheme_Object * -delta_introducer_proc(void *_i_plus_m, int argc, Scheme_Object *argv[]) +static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]) { - Scheme_Object *p = (Scheme_Object *)_i_plus_m, *l, *v, *a[1]; - const char *who = "delta introducer attached to a rename transformer"; - - v = argv[0]; - if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) { - scheme_wrong_contract(who, "identifier?", 0, argc, argv); - } - - /* Apply mapping functions: */ - 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; + scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "syntax-local-make-delta-introducer: " NOT_SUPPORTED_STR); + ESCAPED_BEFORE_HERE; } -static Scheme_Object * -local_make_delta_introduce(int argc, Scheme_Object *argv[]) +static Scheme_Object *local_binding_id(int argc, Scheme_Object **argv) { - Scheme_Object *sym, *binder, *introducer, *a[2], *v; - Scheme_Object *introducers = scheme_null, *mappers = scheme_null; - int renamed = 0; - Scheme_Comp_Env *env; + Scheme_Object *a = argv[0]; - env = scheme_current_thread->current_local_env; - if (!env) - not_currently_transforming("syntax-local-make-delta-introducer"); + if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) + scheme_wrong_contract("syntax-local-identifier-as-binding", "identifier?", 0, argc, argv); - if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) - scheme_wrong_contract("syntax-local-make-delta-introducer", "identifier?", 0, argc, argv); - - sym = argv[0]; - - 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); - } - } + if (scheme_current_thread->current_local_env) + return scheme_revert_use_site_scopes(a, scheme_current_thread->current_local_env); + else + return a; } 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; } diff --git a/racket/src/racket/src/error.c b/racket/src/racket/src/error.c index a999c991ae..a112dc1bbc 100644 --- a/racket/src/racket/src/error.c +++ b/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))) { - /* Get module and name at source: */ - int phase; + if (SCHEME_SYMBOLP(SCHEME_STX_VAL(first))) 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 { diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index ec32065b17..bd9f3a8f25 100644 --- a/racket/src/racket/src/eval.c +++ b/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, - insp, NULL, pos, 0, NULL, NULL, env, NULL, - NULL); + varname = scheme_check_accessible_in_module(menv, NULL, varname, NULL, + NULL, insp, + 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,36 +3895,32 @@ 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) { - if (SCHEME_STX_PAIRP(form)) { - Scheme_Object *a, *d, *module_stx; + 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); - module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), - scheme_false, - scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), - 0, 0); - if (scheme_stx_module_eq(a, module_stx, genv->phase)) { - /* Don't add renames to the whole module; let the - module's language take over. */ - d = SCHEME_STX_CDR(form); - a = scheme_make_pair(a, d); - form = scheme_datum_to_syntax(a, form, form, 0, 1); - return form; - } + a = SCHEME_STX_CAR(form); + if (SCHEME_STX_SYMBOLP(a)) { + a = scheme_stx_push_module_context(a, genv->stx_context); + module_stx = scheme_datum_to_syntax(module_symbol, + scheme_false, + scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), + 0, 0); + if (scheme_stx_free_eq(a, module_stx, genv->phase)) { + /* Don't add context to the whole module, since the + `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); + return form; } } - } + } - if (genv->rename_set) { - 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); - } + form = scheme_stx_push_module_context(form, genv->stx_context); 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); - 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); - } + form = scheme_top_introduce(form, genv); } 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, - env->module_registry->exports, NULL, NULL); + s = SCHEME_VEC_ELS(expr)[i]; + 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); } } @@ -4958,10 +4984,11 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in (void)scheme_get_stop_expander(); - env = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME + env = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_FOR_STOPS - | kind), - env); + | kind), + NULL, + env); if (catch_lifts < 0) { /* Note: extra frames can get inserted after env by pair_lifted */ ip = MALLOC_N(Scheme_Comp_Env *, 1); @@ -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... */ - l = scheme_add_remove_mark(l, local_mark); + we need to remove the temporary scope... */ + 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. */ - l = r_expand(l, env, -2, 0, 0, catch_lifts_key, 0, catch_lifts ? catch_lifts : 1); + preserve letrec-syntax, while -3 is -2 but also avoid replacing reference ids + 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) - exp_expr = scheme_add_remove_mark(exp_expr, local_mark); + if (local_scope) + exp_expr = scheme_stx_flip_scope(exp_expr, local_scope, scheme_env_phase(env->genv)); } - if (local_mark) { - /* Put the temporary mark back: */ - l = scheme_add_remove_mark(l, local_mark); + if (local_scope) { + /* Put the temporary scope back: */ + 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,40 +5594,35 @@ 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", "transforming context does not match given internal-definition context", NULL); } - old_stx_env = stx_env; - stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, stx_env); + stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF | SCHEME_USE_SCOPES_TO_NEXT, rib, stx_env); scheme_add_local_syntax(cnt, stx_env); - /* Mark names */ - if (scheme_current_thread->current_local_mark) - names = scheme_named_map_1(NULL, scheme_add_remove_mark, names, - scheme_current_thread->current_local_mark); + /* Scope names */ + if (scheme_current_thread->current_local_scope) + names = scheme_named_map_1(NULL, flip_scope_at_phase_and_revert_expr, names, + 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) - expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark); + if (scheme_current_thread->current_local_scope) + 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); - rn_names = scheme_named_map_1(NULL, scheme_add_rename_rib, names, rib); + expr = scheme_stx_add_scope(expr, rib, scheme_env_phase(stx_env->genv)); + 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_Object *insp) + Scheme_Env *dummy_env, 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), - src_modidx, now_modidx, - genv ? genv->module_registry->exports : NULL, - insp, NULL); + v = scheme_make_shift(scheme_make_integer(now_phase - src_phase), + src_modidx, now_modidx, + genv ? genv->module_registry->exports : 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; @@ -5719,7 +5772,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, pf->a[i] = (Scheme_Object *)ls; /* Rest of a left zeroed, to be filled in lazily by quote-syntax evaluation */ } else { - /* No shift, so fill in stxes immediately */ + /* No shift, so fill in stxes immediately */ i++; for (j = 0; j < rp->num_stxes; j++) { pf->a[i + j] = rp->stxes[j]; @@ -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); diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 0fb41d6621..b10b57dea0 100644 --- a/racket/src/racket/src/fun.c +++ b/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) - || scheme_stx_module_eq_x(scheme_module_begin_stx, name, phase)) { + if (scheme_stx_free_eq_x(scheme_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) - || scheme_stx_module_eq_x(scheme_define_syntaxes_stx, name, phase)) { + } else if (scheme_stx_free_eq_x(scheme_define_values_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(); - rator = scheme_add_remove_mark(rator, mark); + scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); + 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,9 +1951,16 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, } track_code = code; /* after mode properties are removed */ - mark = scheme_new_mark(); - code = scheme_add_remove_mark(code, mark); + scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); + 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); pre_code = code; @@ -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); diff --git a/racket/src/racket/src/hamt_subset.inc b/racket/src/racket/src/hamt_subset.inc new file mode 100644 index 0000000000..580671f4c8 --- /dev/null +++ b/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 diff --git a/racket/src/racket/src/hash.c b/racket/src/racket/src/hash.c index 59d84f57c5..873283d5a7 100644 --- a/racket/src/racket/src/hash.c +++ b/racket/src/racket/src/hash.c @@ -164,26 +164,6 @@ static void string_hash_indices(void *_key, intptr_t *_h, intptr_t *_h2) *_h2 = to_signed_hash(h2); } -static void id_hash_indices(void *_key, intptr_t *_h, intptr_t *_h2) -{ - Scheme_Object *key = (Scheme_Object *)_key; - uintptr_t lkey; - - if (SCHEME_STXP(key)) - key = SCHEME_STX_VAL(key); - - lkey = PTR_TO_LONG((Scheme_Object *)key); - if (_h) - *_h = to_signed_hash(lkey); - if (_h2) - *_h2 = to_signed_hash(lkey >> 1); -} - -static int not_stx_bound_eq(char *a, char *b) -{ - return !scheme_stx_bound_eq((Scheme_Object *)a, (Scheme_Object *)b, 0); -} - /*========================================================================*/ /* normal hash table */ /*========================================================================*/ @@ -208,10 +188,6 @@ Scheme_Hash_Table *scheme_make_hash_table(int type) table->make_hash_indices = string_hash_indices; table->compare = (Hash_Compare_Proc)strcmp; } - if (type == SCHEME_hash_bound_id) { - table->make_hash_indices = id_hash_indices; - table->compare = (Hash_Compare_Proc)not_stx_bound_eq; - } return table; } @@ -1211,6 +1187,7 @@ XFORM_NONGCING static uintptr_t long_dbl_hash2_val(long_double d) #define MZ_MIX(k) (k += (k << 10), k ^= (k >> 6)) XFORM_NONGCING static uintptr_t fast_equal_hash_key(Scheme_Object *o, uintptr_t k, int *_done) +/* must cover eqv hash keys that are just eq hash keys */ { Scheme_Type t; @@ -1350,6 +1327,11 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi) o = ((Scheme_Chaperone *)o)->val; t = SCHEME_TYPE(o); + if (t == scheme_hash_tree_indirection_type) { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + t = SCHEME_TYPE(o); + } + k += t; if (hi->depth > (MAX_HASH_DEPTH << 1)) @@ -1571,6 +1553,9 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi) return k; } case scheme_hash_tree_type: + case scheme_eq_hash_tree_type: + case scheme_eqv_hash_tree_type: + case scheme_hash_tree_indirection_type: { Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o; Scheme_Object *ik, *iv; @@ -1584,12 +1569,15 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi) hi->depth += 2; old_depth = hi->depth; + /* hash tree holds pre-computed hashes for keys, so use those: */ + vk = scheme_hash_tree_key_hash(ht); + for (i = scheme_hash_tree_next(ht, -1); i != -1; i = scheme_hash_tree_next(ht, i)) { scheme_hash_tree_index(ht, i, &ik, &iv); if (!SAME_OBJ(o, orig_obj)) iv = scheme_chaperone_hash_traversal_get(orig_obj, ik, &ik); - vk = equal_hash_key(ik, 0, hi); - MZ_MIX(vk); + /* vk = equal_hash_key(ik, 0, hi); */ + /* MZ_MIX(vk); */ vk += equal_hash_key(iv, 0, hi); MZ_MIX(vk); k += vk; /* can't mix k, because the key order shouldn't matter */ @@ -1666,7 +1654,15 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi) k = (k << 3) + k; k += equal_hash_key(midx->path, 0, hi); o = midx->base; - break; + } + break; + case scheme_scope_table_type: + { + Scheme_Scope_Table *mt = (Scheme_Scope_Table *)o; + hi->depth += 2; + k = (k << 3) + k; + k += equal_hash_key((Scheme_Object *)mt->simple_scopes, 0, hi); + o = mt->multi_scopes; } break; default: @@ -1717,20 +1713,49 @@ intptr_t scheme_equal_hash_key2(Scheme_Object *o) return to_signed_hash(equal_hash_key2(o, &hi)); } -intptr_t scheme_eqv_hash_key(Scheme_Object *o) +XFORM_NONGCING static uintptr_t fast_equal_hash_key2(Scheme_Object *o, int *_done) +/* must cover eqv hash keys that are just eq hash keys */ { - if (!SCHEME_INTP(o) && (SCHEME_NUMBERP(o) || SCHEME_CHARP(o))) - return to_signed_hash(scheme_equal_hash_key(o)); - else - return to_signed_hash(PTR_TO_LONG(o)); -} + Scheme_Type t; -intptr_t scheme_eqv_hash_key2(Scheme_Object *o) -{ - if (!SCHEME_INTP(o) && (SCHEME_NUMBERP(o) || SCHEME_CHARP(o))) - return to_signed_hash(scheme_equal_hash_key2(o)); - else - return to_signed_hash(PTR_TO_LONG(o) >> 1); + t = SCHEME_TYPE(o); + + *_done = 1; + + switch(t) { + case scheme_integer_type: + return t - SCHEME_INT_VAL(o); +#ifdef MZ_USE_SINGLE_FLOATS + case scheme_float_type: +#endif + case scheme_double_type: + { + return dbl_hash2_val(SCHEME_FLOAT_VAL(o)); + } +#ifdef MZ_LONG_DOUBLE + case scheme_long_double_type: + { + return long_dbl_hash2_val(SCHEME_LONG_DBL_VAL(o)); + } +#endif + case scheme_bignum_type: + return SCHEME_BIGDIG(o)[0]; + case scheme_rational_type: + return fast_equal_hash_key2(scheme_rational_numerator(o), _done); + case scheme_complex_type: + { + uintptr_t v1, v2; + Scheme_Complex *c = (Scheme_Complex *)o; + v1 = fast_equal_hash_key2(c->r, _done); + v2 = fast_equal_hash_key2(c->i, _done); + return v1 + v2; + } + case scheme_char_type: + return t; + default: + *_done = 0; + return 0; + } } static Scheme_Object *hash2_recur(int argc, Scheme_Object **argv, Scheme_Object *prim) @@ -1789,45 +1814,24 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) { Scheme_Type t; Scheme_Object *orig_obj; + uintptr_t r; + int done; top: orig_obj = o; if (SCHEME_CHAPERONEP(o)) o = ((Scheme_Chaperone *)o)->val; + r = fast_equal_hash_key2(o, &done); + if (done) + return r; + t = SCHEME_TYPE(o); if (hi->depth > (MAX_HASH_DEPTH << 1)) return t; - + switch(t) { - case scheme_integer_type: - return t - SCHEME_INT_VAL(o); -#ifdef MZ_USE_SINGLE_FLOATS - case scheme_float_type: -#endif - case scheme_double_type: - { - return dbl_hash2_val(SCHEME_FLOAT_VAL(o)); - } -#ifdef MZ_LONG_DOUBLE - case scheme_long_double_type: - { - return long_dbl_hash2_val(SCHEME_LONG_DBL_VAL(o)); - } -#endif - case scheme_bignum_type: - return SCHEME_BIGDIG(o)[0]; - case scheme_rational_type: - return equal_hash_key2(scheme_rational_numerator(o), hi); - case scheme_complex_type: - { - uintptr_t v1, v2; - Scheme_Complex *c = (Scheme_Complex *)o; - v1 = equal_hash_key2(c->r, hi); - v2 = equal_hash_key2(c->i, hi); - return v1 + v2; - } case scheme_pair_type: { uintptr_t v1, v2; @@ -1909,8 +1913,6 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) return k; } #endif - case scheme_char_type: - return t; case scheme_byte_string_type: case scheme_unix_path_type: case scheme_windows_path_type: @@ -2057,6 +2059,9 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) return k; } case scheme_hash_tree_type: + case scheme_eq_hash_tree_type: + case scheme_eqv_hash_tree_type: + case scheme_hash_tree_indirection_type: { Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o; Scheme_Object *iv, *ik; @@ -2068,12 +2073,14 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) hi->depth += 2; old_depth = hi->depth; + + /* hash tree holds pre-computed hashes for keys, so use those: */ + k += scheme_hash_tree_key_hash(ht); for (i = scheme_hash_tree_next(ht, -1); i != -1; i = scheme_hash_tree_next(ht, i)) { scheme_hash_tree_index(ht, i, &ik, &iv); if (!SAME_OBJ(o, orig_obj)) iv = scheme_chaperone_hash_traversal_get(orig_obj, ik, &ik); - k += equal_hash_key2(ik, hi); k += equal_hash_key2(iv, hi); hi->depth = old_depth; } @@ -2134,6 +2141,16 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) v2 = equal_hash_key2(midx->base, hi); return v1 + v2; } + case scheme_scope_table_type: + { + Scheme_Scope_Table *mt = (Scheme_Scope_Table *)o; + uintptr_t k; + hi->depth += 2; + k = equal_hash_key2((Scheme_Object *)mt->simple_scopes, hi); + k += equal_hash_key2(mt->multi_scopes, hi); + return k; + } + break; case scheme_place_bi_channel_type: /* a bi channel has sendch and recvch, but sends are the same iff recvs are the same: */ @@ -2160,537 +2177,586 @@ intptr_t scheme_recur_equal_hash_key2(Scheme_Object *o, void *cycle_data) return to_signed_hash(equal_hash_key2(o, (Hash_Info *)cycle_data)); } +intptr_t scheme_eqv_hash_key(Scheme_Object *o) +{ + if (!SCHEME_INTP(o) && (SCHEME_NUMBERP(o) || SCHEME_CHARP(o))) { + int done; + return to_signed_hash(fast_equal_hash_key(o, 0, &done)); + } else + return to_signed_hash(PTR_TO_LONG(o)); +} + +intptr_t scheme_eqv_hash_key2(Scheme_Object *o) +{ + if (!SCHEME_INTP(o) && (SCHEME_NUMBERP(o) || SCHEME_CHARP(o))) { + int done; + return to_signed_hash(fast_equal_hash_key2(o, &done)); + } else + return to_signed_hash(PTR_TO_LONG(o) >> 1); +} + /*========================================================================*/ /* functional hash tables */ /*========================================================================*/ -typedef struct AVLNode { - MZTAG_IF_REQUIRED - char height; - uintptr_t code; - Scheme_Object *key; /* NULL => val is another tree for multiple key-value pairs */ - Scheme_Object *val; - struct AVLNode *left; - struct AVLNode *right; -} AVLNode; +/* Based on Phil Bagwell's "Ideal Hash Trees" (2000) */ -#if 0 -# define AVL_ASSERT(p) if (p) { } else { scheme_signal_error("hash-tree assert failure %d", __LINE__); } -# define AVL_ASSERT_ONLY(x) x -# define AVL_CHECK_FORMS 1 -#else -# define AVL_ASSERT(p) /* empty */ -# define AVL_ASSERT_ONLY(x) /* empty */ -#endif +#define HASHTR_KIND_MULT(kind) (!kind ? 1 : ((kind == 1) ? 2 : 3)) +#define HASH_TREE_RECORD_SIZE(kind, popcount) (sizeof(Scheme_Hash_Tree) \ + + (((HASHTR_KIND_MULT(kind) * (popcount)) - mzFLEX_DELTA) \ + * sizeof(Scheme_Object*))) -#ifdef REVERSE_HASH_TABLE_ORDER -# define HASH_KEY_GT_OP < -# define HASH_KEY_LT_OP > -# define QUICK_TABLE_INIT_LEFT 1 -# define QUICK_TABLE_INIT_RIGHT 0 -#else -# define HASH_KEY_GT_OP > -# define HASH_KEY_LT_OP < -# define QUICK_TABLE_INIT_LEFT 0 -# define QUICK_TABLE_INIT_RIGHT 1 -#endif +#define HASHTR_HAS_VAL 0x1 +#define HASHTR_HAS_CODE 0x2 -XFORM_NONGCING static int get_height(AVLNode* t) +#define HASHTR_SUBTREEP(o) SAME_TYPE(SCHEME_TYPE(o), scheme_hash_tree_subtree_type) +#define HASHTR_COLLISIONP(o) SAME_TYPE(SCHEME_TYPE(o), scheme_hash_tree_collision_type) + +/* max log word size depends on `hash_tree_bitmap_t` */ +#define mzHAMT_LOG_WORD_SIZE 5 +#define mzHAMT_WORD_SIZE (1 << mzHAMT_LOG_WORD_SIZE) + + +XFORM_NONGCING static Scheme_Hash_Tree *resolve_placeholder(Scheme_Hash_Tree *ht) { - if (t == NULL) - return 0; + /* This is ugly, but to support cyclic tables, we need a + level of indirection */ + if (SAME_TYPE(SCHEME_TYPE(ht), scheme_hash_tree_indirection_type)) + return (Scheme_Hash_Tree *)ht->els[0]; else - return t->height; + return ht; } -XFORM_NONGCING static void fix_height(AVLNode* t) +XFORM_NONGCING static int hamt_index(uintptr_t code, int shift) { - int h; - h = get_height(t->left); - if (get_height(t->right) > h) - h = get_height(t->right); - t->height = h + 1; + return (code >> shift) & ((1 << mzHAMT_LOG_WORD_SIZE) - 1); } -static AVLNode *make_avl(AVLNode *left, - uintptr_t code, Scheme_Object *key, Scheme_Object *val, - AVLNode *right) +XFORM_NONGCING int hamt_popcount(hash_tree_bitmap_t x) { - AVLNode *avl; - - avl = scheme_malloc_small_dirty_tagged(sizeof(AVLNode)); - SET_REQUIRED_TAG(avl->type = scheme_rt_avl_node); - avl->code = code; - avl->key = key; - avl->val = val; - avl->left = left; - avl->right = right; - - fix_height(avl); - - return avl; +#if MZ_HAS_BUILTIN_POPCOUNT + return __builtin_popcount(x); +#else + /* http://bits.stephan-brumme.com/countBits.html */ + /* count bits of each 2-bit chunk */ + x = x - ((x >> 1) & 0x55555555); + /* count bits of each 4-bit chunk */ + x = (x & 0x33333333) + ((x >> 2) & 0x33333333); + /* count bits of each 8-bit chunk */ + x = x + (x >> 4); + /* mask out junk */ + x &= 0xF0F0F0F; + /* add all four 8-bit chunks */ + return (x * 0x01010101) >> 24; +#endif } -static AVLNode *avl_clone(AVLNode *avl) +XFORM_NONGCING static int hamt_popcount_below(hash_tree_bitmap_t bitmap, int index) { - AVLNode *naya; - naya = MALLOC_ONE_TAGGED(AVLNode); - memcpy(naya, avl, sizeof(AVLNode)); - return naya; + return hamt_popcount(bitmap & (((hash_tree_bitmap_t)1 << index) - 1)); } -XFORM_NONGCING static int get_balance(AVLNode* t) +XFORM_NONGCING static hash_tree_bitmap_t hamt_bit(int index) { - return get_height(t->left) - get_height(t->right); + return ((hash_tree_bitmap_t)1 << index); } -XFORM_NONGCING static AVLNode *avl_find(uintptr_t code, AVLNode *s) +XFORM_NONGCING Scheme_Object *_mzHAMT_VAL(Scheme_Hash_Tree *ht, int pos, int popcount) +{ + return ((SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) ? (ht)->els[(popcount)+(pos)] : (ht)->els[pos]); +} + +XFORM_NONGCING uintptr_t mzHAMT_KEY_CODE(Scheme_Object *o) { while (1) { - if (!s) - return NULL; - - if (s->code == code) - return s; - else if (s->code HASH_KEY_GT_OP code) - s = s->left; + if (HASHTR_COLLISIONP(o)) + o = ((Scheme_Hash_Tree *)o)->els[0]; else - s = s->right; + return PTR_TO_LONG(o); } } -#ifdef AVL_CHECK_FORMS -static AVLNode *AVL_CHK(AVLNode *avl, uintptr_t code) +XFORM_NONGCING uintptr_t _mzHAMT_CODE(Scheme_Hash_Tree *ht, int pos, int popcount) { - AVL_ASSERT(avl_find(code, avl)); - return avl; -} -static void AVL_CHK_FORM(AVLNode *avl) -{ - if (avl) { - int h1, h2; - h1 = get_height(avl->left); - h2 = get_height(avl->right); - if (h2 > h1) h1 = h2; - AVL_ASSERT(avl->height == (h1 + 1)); - AVL_CHK_FORM(avl->left); - AVL_CHK_FORM(avl->right); - } -} -#else -# define AVL_CHK(avl, code) avl -XFORM_NONGCING static void AVL_CHK_FORM(AVLNode *avl) { } -#endif - -AVLNode* check_rotate_right(AVLNode* t) -{ - if (get_balance(t) == 2) { - /* need to rotate right */ - AVLNode* left = t->left; - left = avl_clone(left); - if (get_balance(left) < 0) { - /* double right rotation */ - AVLNode* left_right = left->right; - left_right = avl_clone(left_right); - left->right = left_right->left; - left_right->left = left; - fix_height(left); - left = left_right; - } - t = avl_clone(t); - t->left = left->right; - left->right = t; - fix_height(t); - fix_height(left); - return left; - } - - return t; + return ((SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_CODE) ? (uintptr_t)(ht)->els[2*(popcount)+(pos)] : mzHAMT_KEY_CODE((ht)->els[pos])); } -AVLNode* check_rotate_left(AVLNode* t) +#define mzHAMT_VAL(ht, pos) _mzHAMT_VAL(ht, pos, hamt_popcount((ht)->bitmap)) +#define mzHAMT_CODE(ht, pos) _mzHAMT_CODE(ht, pos, hamt_popcount((ht)->bitmap)) + +#define _mzHAMT_SET_VAL(ht, pos, val, popcount) (ht)->els[(popcount) + (pos)] = val +#define _mzHAMT_SET_CODE(ht, pos, code, popcount) (ht)->els[2*(popcount) + (pos)] = (Scheme_Object *)code + +XFORM_NONGCING static void hamt_content_copy(Scheme_Hash_Tree *dest, Scheme_Hash_Tree *src, + int dest_popcount, int src_popcount, + intptr_t dest_start, intptr_t src_start, + intptr_t len) { - if (get_balance(t) == -2) { - /* need to rotate left */ - AVLNode* right = t->right; - right = avl_clone(right); - if (get_balance(right) > 0) { - /* double left rotation */ - AVLNode* right_left = right->left; - right_left = avl_clone(right_left); - right->left = right_left->right; - right_left->right = right; - fix_height(right); - right = right_left; - } else - right = avl_clone(right); - t = avl_clone(t); - t->right = right->left; - right->left = t; - fix_height(t); - fix_height(right); - return right; - } - - return t; -} - -static AVLNode *avl_ins(uintptr_t code, Scheme_Object *key, Scheme_Object *val, AVLNode *t) -{ - if (t == NULL) - return AVL_CHK(make_avl(NULL, code, key, val, NULL), code); - else { - if (t->code HASH_KEY_GT_OP code) { - /* insert on left */ - AVLNode *left; - - left = avl_ins(code, key, val, t->left); - if (left == t->left) - return t; - - t = avl_clone(t); - t->left = left; - fix_height(t); - - return check_rotate_right(t); - } else if (t->code HASH_KEY_LT_OP code) { - /* insert on right */ - AVLNode *right; - - right = avl_ins(code, key, val, t->right); - if (right == t->right) - return t; - - t = avl_clone(t); - t->right = right; - fix_height(t); - - return check_rotate_left(t); - } else - return t; - } -} - -static AVLNode* avl_del(AVLNode* t, uintptr_t code) -{ - if (t == NULL) - return NULL; - else { - if (code HASH_KEY_LT_OP t->code) { - /* delete on left */ - AVLNode *new_left; - - new_left = avl_del(t->left, code); - if (new_left == t->left) - return t; - - t = avl_clone(t); - t->left = new_left; - fix_height(t); - return check_rotate_left(t); - } else if (code HASH_KEY_GT_OP t->code) { - /* delete on right */ - AVLNode *new_right; - - new_right = avl_del(t->right, code); - if (new_right == t->right) - return t; - - t = avl_clone(t); - t->right = new_right; - fix_height(t); - return check_rotate_right(t); - } else { - if (!t->left) - return t->right; - else if (!t->right) - return t->left; - else { - AVLNode *lm, *new_left; - /* Get the max of the left: */ - for (lm = t->left; lm->right != NULL; lm = lm->right) { - } - /* Delete it: */ - new_left = avl_del(t->left, lm->code); - /* Use it in place of t: */ - lm = avl_clone(lm); - lm->left = new_left; - lm->right = t->right; - fix_height(lm); - - if (get_balance(lm) == -2) - return check_rotate_left(lm); - else - return check_rotate_right(lm); - } + memcpy(dest->els+dest_start, src->els+src_start, len*sizeof(Scheme_Object*)); + if (SCHEME_HASHTR_FLAGS(src) & HASHTR_HAS_VAL) { + memcpy(dest->els+dest_popcount+dest_start, src->els+src_popcount+src_start, len*sizeof(Scheme_Object*)); + if (SCHEME_HASHTR_FLAGS(src) & HASHTR_HAS_CODE) { + memcpy(dest->els+2*dest_popcount+dest_start, src->els+2*src_popcount+src_start, len*sizeof(Scheme_Object*)); } } } -static AVLNode *avl_replace(AVLNode *s, AVLNode *orig, AVLNode *naya) +XFORM_NONGCING static Scheme_Hash_Tree *hamt_assoc(Scheme_Hash_Tree *ht, uintptr_t code, int *_pos, int shift) { - AVLNode *next; + int index, pos; - if (SAME_OBJ(s, orig)) - return naya; - - s = avl_clone(s); - - if (s->code HASH_KEY_GT_OP orig->code) { - next = avl_replace(s->left, orig, naya); - s->left = next; - } else { - next = avl_replace(s->right, orig, naya); - s->right = next; - } - - return s; -} - -Scheme_Hash_Tree *scheme_make_hash_tree(int kind) -{ - Scheme_Hash_Tree *tree; - - tree = MALLOC_ONE_TAGGED(Scheme_Hash_Tree); - - tree->count = 0; - - tree->iso.so.type = scheme_hash_tree_type; - SCHEME_HASHTR_FLAGS(tree) |= (kind & 0x3); - - return tree; -} - -static intptr_t search_nodes(AVLNode *n, Scheme_Object *key, int kind) -/* O(N) search full tree to find a code for `key'; returns -1 if not found */ -{ - intptr_t code; - - if ((kind && ((kind == 1) - ? scheme_equal(n->key, key) - : scheme_eqv(n->key, key))) - || (!kind && SAME_OBJ(n->key, key))) - return n->code; - - if (n->left) { - code = search_nodes(n->left, key, kind); - if (code >= 0) - return code; - } - - if (n->right) - return search_nodes(n->right, key, kind); - else - return -1; -} - -XFORM_NONGCING static intptr_t search_nodes_eq(AVLNode *n, Scheme_Object *key) -/* O(N) search full tree to find a code for `key'; returns -1 if not found */ -{ - intptr_t code; - - if (SAME_OBJ(n->key, key)) - return n->code; - - if (n->left) { - code = search_nodes_eq(n->left, key); - if (code >= 0) - return code; - } - - if (n->right) - return search_nodes_eq(n->right, key); - else - return -1; -} - -XFORM_NONGCING static intptr_t fresh_code(AVLNode *root) -/* O(n) search for an available code */ -{ - int i = 0; while (1) { - if (!avl_find(i, root)) - return i; - i++; - } -} - -static void *hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val, intptr_t h, - AVLNode *root, int kind) -{ - Scheme_Hash_Tree *tree2; - AVLNode *added; - int delta; - - AVL_CHK_FORM(root); - - if (!val) { - /* Removing ... */ - added = avl_find(h, root); - if (!added) { - /* nothing to remove */ - return (tree ? (void *)tree : (void *)root); - } - if (added->key) { - if ((kind && ((kind == 1) - ? scheme_equal(added->key, key) - : scheme_eqv(added->key, key))) - || (!kind && SAME_OBJ(added->key, key))) { - /* remove single item */ - root = avl_del(root, h); - - if (tree) { - tree2 = MALLOC_ONE_TAGGED(Scheme_Hash_Tree); - memcpy(tree2, tree, sizeof(Scheme_Hash_Tree)); - - AVL_CHK_FORM(root); - - tree2->root = root; - --tree2->count; - - return tree2; + index = hamt_index(code, shift); + if (ht->bitmap & hamt_bit(index)) { + pos = hamt_popcount_below(ht->bitmap, index); + if (HASHTR_SUBTREEP(ht->els[pos])) { + ht = (Scheme_Hash_Tree *)ht->els[pos]; + shift += mzHAMT_LOG_WORD_SIZE; + } else { + if (code == mzHAMT_CODE(ht, pos)) { + *_pos = pos; + return ht; } else - return root; - } else { - /* Nothing to remove */ - return (tree ? (void *)tree : (void *)root); + return NULL; } - } else { - /* multiple mappings; remove it below */ - } - } else { - /* Adding/setting: */ - root = avl_ins(h, NULL, NULL, root); - added = avl_find(h, root); + } else + return NULL; } - - delta = 0; - if (added->val) { - if (!added->key) { - /* Have a subtree of keys and vals (with bogus "code"s). */ - AVLNode *savl = (AVLNode *)added->val; - intptr_t code; - code = search_nodes(savl, key, kind); - if (code < 0) { - /* Not mapped already: */ - if (!val) { - /* nothing to remove after all */ - return (tree ? (void *)tree : (void *)root); - } - savl = (AVLNode *)hash_tree_set(NULL, key, val, fresh_code(savl), savl, kind); - val = (Scheme_Object *)savl; - key = NULL; - delta = 1; - } else { - /* Mapped already: */ - savl = (AVLNode *)hash_tree_set(NULL, key, val, code, savl, kind); - if (val) { - /* Updated */ - val = (Scheme_Object *)savl; - key = NULL; - } else { - /* Removed */ - delta = -1; - if (!savl->left && !savl->right) { - /* Removal reduced to a single mapping: */ - val = savl->val; - key = savl->key; - } else { - val = (Scheme_Object *)savl; - key = NULL; - } - } - } - } else { - /* Currently have one value for this hash code */ - int same; - if (kind) { - if (kind == 1) - same = scheme_equal(key, added->key); - else - same = scheme_eqv(key, added->key); - } else { - same = SAME_OBJ(key, added->key); - } - if (!same) { - /* Switch to sub-tree mode to hold mulitple keys for the - same code: */ - static AVLNode *sn; - - /* avoid intermediate allocations by constructing directly: */ - sn = make_avl(NULL, QUICK_TABLE_INIT_RIGHT, added->key, added->val, NULL); - sn = make_avl(NULL, QUICK_TABLE_INIT_LEFT, key, val, sn); - - val = (Scheme_Object *)sn; - key = NULL; - delta = 1; - } - } - root = avl_replace(root, - added, - make_avl(added->left, - added->code, key, val, - added->right)); - } else { - added->key = key; - added->val = val; - delta = 1; - } - - AVL_CHK_FORM(root); - - if (tree) { - tree2 = MALLOC_ONE_TAGGED(Scheme_Hash_Tree); - memcpy(tree2, tree, sizeof(Scheme_Hash_Tree)); - - if (delta) - tree2->count += delta; - tree2->root = root; - - return tree2; - } else - return root; + return NULL; } -Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val) +static Scheme_Hash_Tree *hamt_alloc(int kind, int popcount) +/* be sure to set `bitmap` field before a GC becomes possible */ { - uintptr_t h; - int kind = (SCHEME_HASHTR_FLAGS(tree) & 0x3); + return (Scheme_Hash_Tree *)scheme_malloc_small_tagged(HASH_TREE_RECORD_SIZE(kind, popcount)); +} - if (kind) { - if (kind == 1) { - h = to_unsigned_hash(scheme_equal_hash_key(key)); +static Scheme_Hash_Tree *hamt_dup(Scheme_Hash_Tree *ht, int popcount) +{ + Scheme_Hash_Tree *new_ht; + int kind; + + kind = SCHEME_HASHTR_KIND(ht); + new_ht = hamt_alloc(kind, popcount); + memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(kind, popcount)); + + return new_ht; +} + +static Scheme_Hash_Tree *hamt_make1(Scheme_Hash_Tree *ht, int index) +/* allocates a node that has a single entry, which is another node */ +{ + Scheme_Hash_Tree *new_ht; + int kind; + + kind = SCHEME_HASHTR_KIND(ht); + new_ht = hamt_alloc(kind, 1); + new_ht->iso.so.type = scheme_hash_tree_subtree_type; + SCHEME_HASHTR_FLAGS(new_ht) = kind; + new_ht->bitmap = hamt_bit(index); + new_ht->count = ht->count; + new_ht->els[0] = (Scheme_Object *)ht; + + return new_ht; +} + +static Scheme_Hash_Tree *hamt_make2(int kind, int shift, + uintptr_t code1, Scheme_Object *key1, Scheme_Object *val1, + uintptr_t code2, Scheme_Object *key2, Scheme_Object *val2) +/* allocates a subtree (at the level indicated by `shift`) for two + values, pushing them down to further subtress as needed */ +{ + int index1, index2, pos1, pos2; + Scheme_Hash_Tree *new_ht; + + index1 = hamt_index(code1, shift); + index2 = hamt_index(code2, shift); + if (index1 == index2) { + /* since hash codes map to the same index at this level, + we need another level */ + new_ht = hamt_make2(kind, shift + mzHAMT_LOG_WORD_SIZE, + code1, key1, val1, + code2, key2, val2); + return hamt_make1(new_ht, index1); + } else { + new_ht = hamt_alloc(kind, 2); + new_ht->iso.so.type = scheme_hash_tree_subtree_type; + SCHEME_HASHTR_FLAGS(new_ht) = kind; + new_ht->bitmap = (hamt_bit(index1) | hamt_bit(index2)); + new_ht->count = 2; + if (HASHTR_COLLISIONP(key1)) + new_ht->count += (((Scheme_Hash_Tree *)key1)->count - 1); + if (HASHTR_COLLISIONP(key2)) + new_ht->count += (((Scheme_Hash_Tree *)key2)->count - 1); + if (index1 < index2) { + pos1 = 0; + pos2 = 1; } else { - h = to_unsigned_hash(scheme_eqv_hash_key(key)); + pos1 = 1; + pos2 = 0; + } + new_ht->els[pos1] = key1; + new_ht->els[pos2] = key2; + if (SCHEME_HASHTR_FLAGS(new_ht) & HASHTR_HAS_VAL) { + _mzHAMT_SET_VAL(new_ht, pos1, val1, 2); + _mzHAMT_SET_VAL(new_ht, pos2, val2, 2); + if (SCHEME_HASHTR_FLAGS(new_ht) & HASHTR_HAS_CODE) { + _mzHAMT_SET_CODE(new_ht, pos1, code1, 2); + _mzHAMT_SET_CODE(new_ht, pos2, code2, 2); + } + } + return new_ht; + } +} + +static Scheme_Hash_Tree *hamt_set(Scheme_Hash_Tree *ht, uintptr_t code, int shift, + Scheme_Object *key, Scheme_Object *val, int inc) +/* updates `ht` (at level `shift`) to replace or add the mapping for `code`, + adjusting the overall count by `inc` */ +{ + int index, pos, popcount; + Scheme_Hash_Tree *new_ht; + + index = hamt_index(code, shift); + pos = hamt_popcount_below(ht->bitmap, index); + popcount = hamt_popcount(ht->bitmap); + + if (ht->bitmap & hamt_bit(index)) { + /* Replacing: */ + new_ht = hamt_dup(ht, popcount); + if (HASHTR_SUBTREEP(ht->els[pos])) { + ht = (Scheme_Hash_Tree *)ht->els[pos]; + ht = hamt_set(ht, code, shift + mzHAMT_LOG_WORD_SIZE, key, val, inc); + new_ht->els[pos] = (Scheme_Object *)ht; + new_ht->count += inc; + } else { + if (code == _mzHAMT_CODE(new_ht, pos, popcount)) { + new_ht->els[pos] = key; + if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) + _mzHAMT_SET_VAL(new_ht, pos, val, popcount); + new_ht->count += inc; + } else { + /* make a new level */ + ht = hamt_make2(SCHEME_HASHTR_KIND(new_ht), shift + mzHAMT_LOG_WORD_SIZE, + _mzHAMT_CODE(new_ht, pos, popcount), new_ht->els[pos], _mzHAMT_VAL(new_ht, pos, popcount), + code, key, val); + new_ht->els[pos] = (Scheme_Object *)ht; + if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) + _mzHAMT_SET_VAL(new_ht, pos, NULL, popcount); + new_ht->count += inc; + } } } else { - h = PTR_TO_LONG((Scheme_Object *)key); + new_ht = hamt_alloc(SCHEME_HASHTR_KIND(ht), popcount+1); + memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(new_ht), 0)); + hamt_content_copy(new_ht, ht, popcount+1,popcount, 0, 0, pos); + if (pos < popcount) + hamt_content_copy(new_ht, ht, popcount+1, popcount, pos+1, pos, popcount-pos); + new_ht->bitmap |= hamt_bit(index); + new_ht->count += inc; + new_ht->els[pos] = key; + if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) { + _mzHAMT_SET_VAL(new_ht, pos, val, popcount+1); + if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_CODE) + _mzHAMT_SET_CODE(new_ht, pos, code, popcount+1); + } + } + + return new_ht; +} + +static Scheme_Hash_Tree *hamt_contract(Scheme_Hash_Tree *ht, int popcount, int index, int pos) +/* return a node that's smaller by one by dropping the mapping at `pos` */ +{ + Scheme_Hash_Tree *new_ht; + + if (popcount == 1) + return NULL; + + new_ht = hamt_alloc(SCHEME_HASHTR_KIND(ht), popcount-1); + memcpy(new_ht, ht, HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(new_ht), 0)); + hamt_content_copy(new_ht, ht, popcount-1, popcount, 0, 0, pos); + if (pos < popcount-1) + hamt_content_copy(new_ht, ht, popcount-1, popcount, pos, pos+1, popcount-pos-1); + new_ht->bitmap -= hamt_bit(index); + --new_ht->count; + + return new_ht; +} + +static Scheme_Hash_Tree *hamt_remove(Scheme_Hash_Tree *ht, uintptr_t code, int shift) +/* remove the mapping for `code`, where `ht` is at the level indicated by `shift` */ +{ + int index, pos, popcount; + Scheme_Hash_Tree *sub_ht; + + index = hamt_index(code, shift); + if (ht->bitmap & hamt_bit(index)) { + pos = hamt_popcount_below(ht->bitmap, index); + popcount = hamt_popcount(ht->bitmap); + if (!HASHTR_SUBTREEP(ht->els[pos])) + return hamt_contract(ht, popcount, index, pos); + else { + sub_ht = hamt_remove((Scheme_Hash_Tree *)ht->els[pos], code, shift + mzHAMT_LOG_WORD_SIZE); + if (!SAME_OBJ((Scheme_Object *)sub_ht, ht->els[pos])) { + if (!sub_ht) + return hamt_contract(ht, popcount, index, pos); + ht = hamt_dup(ht, popcount); + ht->count -= 1; + if ((sub_ht->count == 1) && !HASHTR_SUBTREEP(sub_ht->els[0])) { + /* drop extra layer that has 1 immediate entry */ + ht->els[pos] = sub_ht->els[0]; + if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) { + _mzHAMT_SET_VAL(ht, pos, _mzHAMT_VAL(sub_ht, 0, 1), popcount); + if (SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_CODE) + _mzHAMT_SET_CODE(ht, pos, _mzHAMT_CODE(sub_ht, 0, 1), popcount); + } + } else + ht->els[pos] = (Scheme_Object *)sub_ht; + return ht; + } else + return ht; + } + } else + return ht; +} + +mzlonglong scheme_hash_tree_next(Scheme_Hash_Tree *tree, mzlonglong pos) +{ + if (pos == -1) + pos = 0; + else + pos++; + + if (pos == tree->count) + return -1; + else + return pos; +} + +#if REVERSE_HASH_TABLE_ORDER +# define HAMT_TRAVERSE_INIT(popcount) ((popcount)-1) +# define HAMT_TRAVERSE_NEXT(i) ((i)-1) +#else +# define HAMT_TRAVERSE_INIT(popcount) 0 +# define HAMT_TRAVERSE_NEXT(i) ((i)+1) +#endif + + +XFORM_NONGCING static void hamt_at_index(Scheme_Hash_Tree *ht, mzlonglong pos, + Scheme_Object **_key, Scheme_Object **_val, uintptr_t *_code) +{ + int popcount, i; + Scheme_Hash_Tree *sub; + + while (1) { + popcount = hamt_popcount(ht->bitmap); + i = HAMT_TRAVERSE_INIT(popcount); + while (1) { + if (HASHTR_SUBTREEP(ht->els[i]) + || HASHTR_COLLISIONP(ht->els[i])) { + sub = (Scheme_Hash_Tree *)ht->els[i]; + if (pos < sub->count) { + ht = sub; + break; /* to outer loop */ + } else + pos -= sub->count; + } else { + if (!pos) { + *_key = ht->els[i]; + if (_val) + *_val = _mzHAMT_VAL(ht, i, popcount); + if (_code) + *_code = _mzHAMT_CODE(ht, i, popcount); + return; + } + --pos; + } + i = HAMT_TRAVERSE_NEXT(i); + } + } +} + +int scheme_hash_tree_index(Scheme_Hash_Tree *ht, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val) +{ + ht = resolve_placeholder(ht); + + if (pos < ht->count) { + hamt_at_index(ht, pos, _key, _val, NULL); + return 1; + } else + return 0; +} + +static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Scheme_Object *key, + GC_CAN_IGNORE int *_i, GC_CAN_IGNORE uintptr_t *_code) +/* in the case of hash collisions, we put the colliding elements in a + tree that uses integers as keys; we have to search through the tree + for keys, but the advatange of using a HAMT (instead of a list) is + in indexing (as part of the encloding tree) and update */ +{ + int i; + Scheme_Object *found_key, *found_val; + + for (i = 0; i < tree->count; i++) { + hamt_at_index(tree, i, &found_key, &found_val, _code); + if (stype == scheme_eq_hash_tree_type) { + if (SAME_OBJ(key, found_key)) { + if (_i) *_i = i; + return found_val; + } + } else if (stype == scheme_hash_tree_type) { + if (scheme_equal(key, found_key)) { + if (_i) *_i = i; + return found_val; + } + } else { + if (scheme_eqv(key, found_key)) { + if (_i) *_i = i; + return found_val; + } + } } - return (Scheme_Hash_Tree *)hash_tree_set(tree, key, val, h, tree->root, kind); + return NULL; +} + +XFORM_NONGCING static Scheme_Object *hamt_eq_linear_search(Scheme_Hash_Tree *tree, Scheme_Object *key) +/* specialized for `eq?`, where we know that comparison doesn't trigger a GC */ +{ + int i; + Scheme_Object *found_key, *found_val; + uintptr_t found_code; + + for (i = 0; i < tree->count; i++) { + hamt_at_index(tree, i, &found_key, &found_val, &found_code); + if (SAME_OBJ(key, found_key)) + return found_val; + } + + return NULL; +} + +XFORM_NONGCING static uintptr_t hamt_find_free_code(Scheme_Hash_Tree *tree, int base, int shift) +/* for selecting a key when adding to a hash-collision subtree */ +{ + int i, mincount, minpos; + Scheme_Hash_Tree *subtree; + + for (i = 0; i < mzHAMT_WORD_SIZE; i++) { + if (!(tree->bitmap & (1 << i))) + return (i << shift) + base; + } + + /* first layer is full; pick next layer */ + mincount = -1; + minpos = mzHAMT_WORD_SIZE; + for (i = mzHAMT_WORD_SIZE; i--; ) { + if (!HASHTR_SUBTREEP(tree->els[i])) { + uintptr_t code = (i << shift) + base; + if (_mzHAMT_CODE(tree, i, mzHAMT_WORD_SIZE) == code) + return code + (1 << (shift + mzHAMT_LOG_WORD_SIZE)); + else + return code; + } else { + subtree = (Scheme_Hash_Tree *)tree->els[i]; + if ((mincount < 0) + || (subtree->count < mincount)) { + mincount = subtree->count; + minpos = i; + } + } + } + + return hamt_find_free_code((Scheme_Hash_Tree *)tree->els[minpos], + (minpos << shift) + base, + shift + mzHAMT_LOG_WORD_SIZE); +} + +static Scheme_Hash_Tree *make_hash_tree(int eql_kind, int val_kind, int popcount) +{ + Scheme_Hash_Tree *ht; + int kind = val_kind | (eql_kind ? (HASHTR_HAS_CODE | HASHTR_HAS_VAL) : 0); + + ht = hamt_alloc(kind, popcount); + + ht->iso.so.type = (!eql_kind + ? scheme_eq_hash_tree_type + : ((eql_kind == 1) + ? scheme_hash_tree_type + : scheme_eqv_hash_tree_type)); + SCHEME_HASHTR_FLAGS(ht) = kind; + + return ht; +} + +Scheme_Hash_Tree *scheme_make_hash_tree(int eql_kind) +{ + return make_hash_tree(eql_kind, HASHTR_HAS_VAL, 0); +} + +Scheme_Hash_Tree *scheme_make_hash_tree_set(int eql_kind) +{ + return make_hash_tree(eql_kind, 0, 0); +} + +Scheme_Hash_Tree *scheme_make_hash_tree_of_type(Scheme_Type stype) +{ + if (stype == scheme_eq_hash_tree_type) + return scheme_make_hash_tree(0); + else if (stype == scheme_hash_tree_type) + return scheme_make_hash_tree(1); + else + return scheme_make_hash_tree(2); +} + +Scheme_Hash_Tree *scheme_make_hash_tree_placeholder(int eql_kind) +/* for cyclic immutable hash tables, we need an indirection to form + the cycle (since we don't know in advance how large the top record + needs to be) */ +{ + Scheme_Hash_Tree *ht, *sub; + + ht = make_hash_tree(eql_kind, 0, 1); + ht->iso.so.type = scheme_hash_tree_indirection_type; + ht->count = 0; + ht->bitmap = 1; + + sub = make_hash_tree(eql_kind, HASHTR_HAS_VAL, 0); + ht->els[0] = (Scheme_Object *)sub; + + return ht; +} + +void scheme_hash_tree_tie_placeholder(Scheme_Hash_Tree *t, Scheme_Hash_Tree *base) +{ + t->count = base->count; + t->els[0] = (Scheme_Object *)base; +} + +Scheme_Hash_Tree *scheme_hash_tree_resolve_placeholder(Scheme_Hash_Tree *t) +{ + return resolve_placeholder(t); } Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) { uintptr_t h; - AVLNode *avl; + int pos; h = PTR_TO_LONG((Scheme_Object *)key); - avl = avl_find(h, tree->root); - if (avl) { - if (!avl->key) { - /* Have tree */ - AVLNode *savl = (AVLNode *)avl->val; - intptr_t code; - code = search_nodes_eq(savl, key); - if (code >= 0) { - avl = avl_find(code, savl); - return avl->val; - } - } else if (SAME_OBJ(avl->key, key)) - return avl->val; + tree = hamt_assoc(resolve_placeholder(tree), h, &pos, 0); + if (!tree) + return NULL; + + if (HASHTR_COLLISIONP(tree->els[pos])) { + /* hash collision; linear search in subtree */ + return hamt_eq_linear_search((Scheme_Hash_Tree *)tree->els[pos], key); + } else { + if (SAME_OBJ(key, tree->els[pos])) + return mzHAMT_VAL(tree, pos); } return NULL; @@ -2699,132 +2765,209 @@ Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *ke Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key) { uintptr_t h; - AVLNode *avl; - int kind = (SCHEME_HASHTR_FLAGS(tree) & 0x3); + int stype, pos; - if (kind) { - if (kind == 1) - h = to_unsigned_hash(scheme_equal_hash_key(key)); - else - h = to_unsigned_hash(scheme_eqv_hash_key(key)); - } else { + tree = resolve_placeholder(tree); + stype = SCHEME_TYPE(tree); + + if (stype == scheme_eq_hash_tree_type) return scheme_eq_hash_tree_get(tree, key); - } + else if (stype == scheme_hash_tree_type) + h = to_unsigned_hash(scheme_equal_hash_key(key)); + else + h = to_unsigned_hash(scheme_eqv_hash_key(key)); - avl = avl_find(h, tree->root); - if (avl) { - if (!avl->key) { - /* Have tree */ - AVLNode *savl = (AVLNode *)avl->val; - intptr_t code; - code = search_nodes(savl, key, kind); - if (code >= 0) { - avl = avl_find(code, savl); - return avl->val; - } + tree = hamt_assoc(tree, h, &pos, 0); + if (!tree) + return NULL; + + if (HASHTR_COLLISIONP(tree->els[pos])) { + /* hash collision; linear search in subtree */ + uintptr_t code; + return hamt_linear_search((Scheme_Hash_Tree *)tree->els[pos], stype, key, NULL, &code); + } else { + if (stype == scheme_hash_tree_type) { + if (scheme_equal(key, tree->els[pos])) + return mzHAMT_VAL(tree, pos); } else { - if (kind == 1) { - if (scheme_equal(key, avl->key)) - return avl->val; - } else { - if (scheme_eqv(key, avl->key)) - return avl->val; - } + if (scheme_eqv(key, tree->els[pos])) + return mzHAMT_VAL(tree, pos); } } return NULL; } -XFORM_NONGCING mzlonglong path_next(AVLNode *avl, mzlonglong path) +Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val) +/* val == NULL => remove */ { - if (!avl) - return -1; + uintptr_t h; + Scheme_Hash_Tree *in_tree; + int stype, pos; + + stype = SCHEME_TYPE(resolve_placeholder(tree)); + + if (stype == scheme_eq_hash_tree_type) + h = PTR_TO_LONG((Scheme_Object *)key); + else if (stype == scheme_hash_tree_type) + h = to_unsigned_hash(scheme_equal_hash_key(key)); + else + h = to_unsigned_hash(scheme_eqv_hash_key(key)); - if (!avl->key) { - /* subtree choice */ - if (path & 0x1) { - /* in subtree or right */ - if (!(path & 0x2)) { - /* haven't exhausted the subtree, yet: */ - path >>= 2; - path = path_next((AVLNode *)avl->val, path); - if (path > 0) - return (path << 2) | 0x1; - path = 0x1; /* move on to right */ - } else { - /* we have exhausted the subtree, and we're working on right */ - path >>= 1; - /* assert: path & 0x1 */ - } - } - } - - if (path & 0x1) { - path = path_next(avl->right, path >> 1); - /* The result cannot be 0. - If the result is -1, then the following calculation preserves the -1. - If the result is positive, then we preserve the decision to go right here. */ - if (avl->key) - return (path << 1) | 0x1; - else - return (path << 2) | 0x3; - } - - path = path_next(avl->left, path >> 1); - if (path > 0) - return path << 1; - - /* start here */ - if (avl->key) - return 0x1; - else { - /* start subtree */ - path = path_next((AVLNode *)avl->val, 0); - return (path << 2) | 0x1; - } -} - -XFORM_NONGCING int path_find(AVLNode *avl, mzlonglong path, Scheme_Object **_key, Scheme_Object **_val) -{ - if (!avl) return 0; - - if (!avl->key) { - /* subtree choice */ - if (path & 0x1) { - /* in subtree or right */ - if (!(path & 0x2)) { - /* in subtree */ - return path_find((AVLNode *)avl->val, path >> 2, _key, _val); - } else { - /* in right */ - path >>= 1; - /* assert: path & 0x1 */ - } - } - } - - if (path & 0x1) { - if (path >> 1) - return path_find(avl->right, path >> 1, _key, _val); + in_tree = hamt_assoc(resolve_placeholder(tree), h, &pos, 0); + if (!in_tree) { + if (!val) + return tree; else { - *_key = avl->key; - *_val = avl->val; - return 1; + /* simple add */ + tree = resolve_placeholder(tree); + return hamt_set(tree, h, 0, key, val, 1); } - } else - return path_find(avl->left, path >> 1, _key, _val); + } + + if (HASHTR_COLLISIONP(in_tree->els[pos])) { + /* hash collision */ + int i, inc; + uintptr_t code; + in_tree = (Scheme_Hash_Tree *)in_tree->els[pos]; + if (hamt_linear_search(in_tree, stype, key, &i, &code)) { + /* key is part of the current collision */ + if (!val) { + if (in_tree->count == 2) { + /* no more hash collision */ + Scheme_Object *other_key, *other_val; + hamt_at_index(in_tree, 1-i, &other_key, &other_val, &code); + tree = resolve_placeholder(tree); + return hamt_set(tree, h, 0, other_key, other_val, -1); + } else { + /* less collision */ + in_tree = hamt_remove(in_tree, code, 0); + inc = -1; + } + } else { + /* update collision */ + in_tree = hamt_set(in_tree, code, 0, key, val, 0); + inc = 0; + } + } else { + if (!val) + return tree; + else { + /* more collision */ + code = hamt_find_free_code(in_tree, 0, 0); + in_tree = hamt_set(in_tree, code, 0, key, val, 1); + inc = 1; + } + } + /* install updated collision tree in main tree: */ + tree = resolve_placeholder(tree); + return hamt_set(tree, h, 0, (Scheme_Object *)in_tree, NULL, inc); + } else { + int same; + + if (stype == scheme_eq_hash_tree_type) + same = SAME_OBJ(key, in_tree->els[pos]); + else if (stype == scheme_hash_tree_type) + same = scheme_equal(key, in_tree->els[pos]); + else + same = scheme_eqv(key, in_tree->els[pos]); + + if (same) { + /* replace */ + tree = resolve_placeholder(tree); + if (!val) { + int kind = SCHEME_HASHTR_KIND(tree); + tree = hamt_remove(tree, h, 0); + if (!tree) { + tree = hamt_alloc(kind, 0); + tree->iso.so.type = stype; + SCHEME_HASHTR_FLAGS(tree) = kind; + return tree; + } else + return tree; + } else + return hamt_set(tree, h, 0, key, val, 0); + } else { + /* add */ + if (!val) + return tree; + else { + /* new hash collision */ + in_tree = hamt_make2(SCHEME_HASHTR_KIND(in_tree) | HASHTR_HAS_CODE, 0, + 0, in_tree->els[pos], mzHAMT_VAL(in_tree, pos), + 1, key, val); + in_tree->iso.so.type = scheme_hash_tree_collision_type; + tree = resolve_placeholder(tree); + return hamt_set(tree, h, 0, (Scheme_Object *)in_tree, NULL, 1); + } + } + } } -mzlonglong scheme_hash_tree_next(Scheme_Hash_Tree *tree, mzlonglong pos) +static int hamt_equal_entries(int stype, void *eql_data, + Scheme_Object *k1, Scheme_Object *v1, + Scheme_Object *k2, Scheme_Object *v2) { - /* Iteration uses a key where the bits say when to turn right */ - return path_next(tree->root, ((pos == -1) ? 0 : pos)); + if (stype == scheme_eq_hash_tree_type) { + if (SAME_OBJ(k1, k2)) + return scheme_recur_equal(v1, v2, eql_data); + } else if (stype == scheme_hash_tree_type) { + if (scheme_recur_equal(k1, k2, eql_data)) + return scheme_recur_equal(v1, v2, eql_data); + } else { + if (scheme_eqv(k1, k2)) + return scheme_recur_equal(v1, v2, eql_data); + } + return 0; } -int scheme_hash_tree_index(Scheme_Hash_Tree *tree, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val) +#define HAMT_NONGCING /* empty */ +#define HAMT_SUBSET_OF hamt_subset_of +#define HAMT_ELEMENT_OF hamt_element_of +#define HAMT_ELEMENT_OF_COLLISION hamt_element_of_collision +#define HAMT_EQUAL_ENTRIES hamt_equal_entries +#define HAMT_IF_VAL(v, n) v +#define HAMT_USE_FUEL() SCHEME_USE_FUEL() +#include "hamt_subset.inc" + +/* fast variant for eq-based sets (i.e., no separate values in table) */ +#define HAMT_NONGCING XFORM_NONGCING +#define HAMT_SUBSET_OF hamt_eq_subset_of +#define HAMT_ELEMENT_OF hamt_eq_element_of +#define HAMT_ELEMENT_OF_COLLISION hamt_eq_element_of_collision +#define HAMT_EQUAL_ENTRIES(stype, eql_data, k1, v1, k2, v2) SAME_OBJ(k1, k2) +#define HAMT_IF_VAL(v, n) n +#define HAMT_USE_FUEL() /* empty */ +#include "hamt_subset.inc" + +static uintptr_t hamt_combine_key_hashes(Scheme_Hash_Tree *ht) { - return path_find(tree->root, pos, _key, _val); + int popcount, i; + uintptr_t k = 0, code; + + popcount = hamt_popcount(ht->bitmap); + + for (i = 0; i < popcount; i++) { + if (HASHTR_SUBTREEP(ht->els[i])) { + SCHEME_USE_FUEL(); + code = hamt_combine_key_hashes((Scheme_Hash_Tree *)ht->els[i]); + } else if (HASHTR_COLLISIONP(ht->els[i])) { + int count = ((Scheme_Hash_Tree *)ht->els[i])->count, j; + code = _mzHAMT_CODE(ht, i, popcount); + for (j = 0; j < count; j++) { + MZ_MIX(code); + } + } else + code = _mzHAMT_CODE(ht, i, popcount); + + k += code; + + /* Since the keys are always in the same order (we don't go into collision trees), + it's ok to mix the total: */ + MZ_MIX(k); + } + + return k; } int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Object *orig_t1, @@ -2834,9 +2977,16 @@ int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Object *orig_t1, Scheme_Object *k, *v, *v2; int i; + t1 = resolve_placeholder(t1); + t2 = resolve_placeholder(t2); + if ((t1->count != t2->count) - || ((SCHEME_HASHTR_FLAGS(t1) & 0x3) != (SCHEME_HASHTR_FLAGS(t2) & 0x3))) + || (SCHEME_TYPE(t1) != SCHEME_TYPE(t2))) return 0; + + if (SAME_OBJ((Scheme_Object *)t1, orig_t1) + && SAME_OBJ((Scheme_Object *)t2, orig_t2)) + return hamt_subset_of(t1, t2, 0, SCHEME_TYPE(t1), eql); for (i = scheme_hash_tree_next(t1, -1); i != -1; i = scheme_hash_tree_next(t1, i)) { scheme_hash_tree_index(t1, i, &k, &v); @@ -2858,11 +3008,24 @@ int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Object *orig_t1, return 1; } -int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2) +int scheme_eq_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2) +/* assumes that `t1` and `t2` are sets, as opposed to maps */ { - return scheme_equal((Scheme_Object *)t1, (Scheme_Object *)t2); + t1 = resolve_placeholder(t1); + t2 = resolve_placeholder(t2); + + if (t1->count > t2->count) + return 0; + + return hamt_eq_subset_of(t1, t2, 0, scheme_eq_hash_tree_type, NULL); } +intptr_t scheme_hash_tree_key_hash(Scheme_Hash_Tree *ht) +{ + ht = resolve_placeholder(ht); + + return (intptr_t)hamt_combine_key_hashes(ht); +} /*========================================================================*/ /* precise GC traversers */ @@ -2877,7 +3040,11 @@ START_XFORM_SKIP; static void register_traversers(void) { GC_REG_TRAV(scheme_hash_tree_type, hash_tree_val); - GC_REG_TRAV(scheme_rt_avl_node, mark_avl_node); + GC_REG_TRAV(scheme_eq_hash_tree_type, hash_tree_val); + GC_REG_TRAV(scheme_eqv_hash_tree_type, hash_tree_val); + GC_REG_TRAV(scheme_hash_tree_subtree_type, hash_tree_val); + GC_REG_TRAV(scheme_hash_tree_collision_type, hash_tree_val); + GC_REG_TRAV(scheme_hash_tree_indirection_type, hash_tree_val); } END_XFORM_SKIP; diff --git a/racket/src/racket/src/jit_ts.c b/racket/src/racket/src/jit_ts.c index 220652b83e..6cb0ad1399 100644 --- a/racket/src/racket/src/jit_ts.c +++ b/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 diff --git a/racket/src/racket/src/jitcommon.c b/racket/src/racket/src/jitcommon.c index 900b93e000..3c95dde179 100644 --- a/racket/src/racket/src/jitcommon.c +++ b/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); - ref = jit_beqi_l(jit_forward(), JIT_R2, 0x0); + jit_ldxi_l(JIT_R2, JIT_R0, &((Scheme_Stx *)0x0)->u.to_propagate); + ref = jit_beqi_p(jit_forward(), JIT_R2, 0x0); CHECK_LIMIT(); /* Maybe needs to propagate; check STX_SUBSTX_FLAG flag */ diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index f3eefdf0ab..1e9bb352d8 100644 --- a/racket/src/racket/src/list.c +++ b/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,38 +2127,43 @@ 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)) { - Scheme_Hash_Tree *t; - Scheme_Hash_Table *naya; - mzlonglong i; - Scheme_Object *k, *val; - - if (SCHEME_NP_CHAPERONEP(v)) - t = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(v); - else - t = (Scheme_Hash_Tree *)v; - - if (scheme_is_hash_tree_equal((Scheme_Object *)t)) - naya = scheme_make_hash_table_equal(); - else if (scheme_is_hash_tree_eqv((Scheme_Object *)t)) - naya = scheme_make_hash_table_eqv(); - else - naya = scheme_make_hash_table(SCHEME_hash_ptr); - - 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 (!SAME_OBJ((Scheme_Object *)t, v)) - val = scheme_chaperone_hash_traversal_get(v, k, &k); - if (val) - scheme_hash_set(naya, k, val); - } - - return (Scheme_Object *)naya; + 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; + Scheme_Object *k, *val; + + if (SCHEME_NP_CHAPERONEP(v)) + t = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(v); + else + t = (Scheme_Hash_Tree *)v; + + if (scheme_is_hash_tree_equal((Scheme_Object *)t)) + naya = scheme_make_hash_table_equal(); + else if (scheme_is_hash_tree_eqv((Scheme_Object *)t)) + naya = scheme_make_hash_table_eqv(); + else + naya = scheme_make_hash_table(SCHEME_hash_ptr); + + 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 (!SAME_OBJ((Scheme_Object *)t, v)) + val = scheme_chaperone_hash_traversal_get(v, k, &k); + if (val) + scheme_hash_set(naya, k, val); + } + + return (Scheme_Object *)naya; +} + static Scheme_Object *hash_p(int argc, Scheme_Object *argv[]) { Scheme_Object *o = argv[0]; @@ -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 - return (Scheme_Object *)scheme_make_hash_tree(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)v) & 0x3); + } else { + 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); diff --git a/racket/src/racket/src/marshal.c b/racket/src/racket/src/marshal.c index 161f3e68c1..32073b7940 100644 --- a/racket/src/racket/src/marshal.c +++ b/racket/src/racket/src/marshal.c @@ -768,57 +768,62 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj) if (!ds) { mt = scheme_current_thread->current_mt; - if (!mt->pass) { - int key; - - pos = mt->cdata_counter; - if ((!mt->cdata_map || (pos >= 32)) - && !(pos & (pos - 1))) { - /* Need to grow the array */ - Scheme_Object **a; - a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32)); - memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *)); - mt->cdata_map = a; - } - mt->cdata_counter++; - - key = pos & 255; - MZ_OPT_HASH_KEY(&data->iso) = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0x00FF) | (key << 8); + if (mt->pass < 0) { + /* nothing to do, yet */ + ds = scheme_false; } else { - pos = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0xFF00) >> 8; + if (!mt->pass) { + int key; - while (pos < mt->cdata_counter) { - ds = mt->cdata_map[pos]; - if (ds) { - ds = SCHEME_PTR_VAL(ds); - if (SAME_OBJ(data->code, ds)) - break; - if (SAME_TYPE(scheme_quote_compilation_type, SCHEME_TYPE(ds))) - if (SAME_OBJ(data->code, SCHEME_PTR_VAL(ds))) - break; + pos = mt->cdata_counter; + if ((!mt->cdata_map || (pos >= 32)) + && !(pos & (pos - 1))) { + /* Need to grow the array */ + Scheme_Object **a; + a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32)); + memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *)); + mt->cdata_map = a; + } + mt->cdata_counter++; + + key = pos & 255; + MZ_OPT_HASH_KEY(&data->iso) = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0x00FF) | (key << 8); + } else { + pos = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0xFF00) >> 8; + + while (pos < mt->cdata_counter) { + ds = mt->cdata_map[pos]; + if (ds) { + ds = SCHEME_PTR_VAL(ds); + if (SAME_OBJ(data->code, ds)) + break; + if (SAME_TYPE(scheme_quote_compilation_type, SCHEME_TYPE(ds))) + if (SAME_OBJ(data->code, SCHEME_PTR_VAL(ds))) + break; + } + pos += 256; + } + if (pos >= mt->cdata_counter) { + scheme_signal_error("didn't find delay record"); } - pos += 256; } - if (pos >= mt->cdata_counter) { - scheme_signal_error("didn't find delay record"); + + ds = mt->cdata_map[pos]; + if (!ds) { + if (mt->pass) + scheme_signal_error("broken closure-data table\n"); + + code = scheme_protect_quote(data->code); + + ds = scheme_alloc_small_object(); + ds->type = scheme_delay_syntax_type; + SCHEME_PTR_VAL(ds) = code; + + MZ_OPT_HASH_KEY(&((Scheme_Small_Object *)ds)->iso) |= 1; /* => hash on ds, not contained data */ + + mt->cdata_map[pos] = ds; } } - - ds = mt->cdata_map[pos]; - if (!ds) { - if (mt->pass) - scheme_signal_error("broken closure-data table\n"); - - code = scheme_protect_quote(data->code); - - ds = scheme_alloc_small_object(); - ds->type = scheme_delay_syntax_type; - SCHEME_PTR_VAL(ds) = code; - - MZ_OPT_HASH_KEY(&((Scheme_Small_Object *)ds)->iso) |= 1; /* => hash on ds, not contained data */ - - mt->cdata_map[pos] = ds; - } } /* Encode data->tl_map as either a fixnum or a vector of 16-bit values */ @@ -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->type = scheme_delay_syntax_type; - SCHEME_PTR_VAL(ds) = rp->stxes[i]; + ds = make_delayed_syntax(rp->stxes[i]); } else ds = scheme_false; SCHEME_VEC_ELS(sv)[i] = ds; @@ -1109,17 +1128,25 @@ 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))) { obj = SCHEME_CDR(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)) - v = scheme_list_to_vector(v); + else if (!SAME_OBJ(v, scheme_true)) { + 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); diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 9eb14c91f1..b645fb7c95 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -107,18 +107,17 @@ static void eval_exptime(Scheme_Object *names, int count, Scheme_Env *genv, Scheme_Comp_Env *env, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, int at_phase, - Scheme_Object *free_id_rename_rn, + Scheme_Object *ids_for_rename_trans, Scheme_Object *insp); typedef struct Module_Begin_Expand_State { /* All pointers, because it's allocated with scheme_malloc(): */ - Scheme_Object *post_ex_rn_set; Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */ Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */ Scheme_Hash_Tree *all_defs; /* phase -> list of sxtid */ Scheme_Hash_Table *all_defs_out; /* phase -> list of (cons protected? (stx-list except-name ...)) */ - int *all_simple_renames; + int *all_simple_bindings; /* can we reconstruct bindings for `module->namespace`? */ int *_num_phases; Scheme_Object *saved_provides; /* list of (cons form phase) */ Scheme_Object *saved_submodules; /* list of (cons form phase) */ @@ -126,7 +125,6 @@ typedef struct Module_Begin_Expand_State { Scheme_Hash_Table *modidx_cache; Scheme_Object *redef_modname; Scheme_Object *end_statementss; /* list of lists */ - Scheme_Object *rn_stx; } Module_Begin_Expand_State; static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, @@ -163,7 +161,9 @@ static Scheme_Object *convert_submodule_path(Scheme_Object *name, Scheme_Object *check_data); static int check_is_submodule(Scheme_Object *modname, Scheme_Object *_genv); -static Scheme_Object *scheme_sys_wraps_phase_worker(intptr_t p); +static Scheme_Object *sys_wraps_phase(intptr_t p); + +static int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b); static int phaseless_rhs(Scheme_Object *val, int var_count, int phase); @@ -180,10 +180,6 @@ READ_ONLY static Scheme_Object *futures_modname; READ_ONLY static Scheme_Object *unsafe_modname; READ_ONLY static Scheme_Object *foreign_modname; -/* global read-only phase wraps */ -READ_ONLY static Scheme_Object *scheme_sys_wraps0; -READ_ONLY static Scheme_Object *scheme_sys_wraps1; - /* global read-only symbols */ ROSYM static Scheme_Object *module_begin_symbol; ROSYM static Scheme_Object *prefix_symbol; @@ -213,41 +209,57 @@ ROSYM static Scheme_Object *submod_symbol; ROSYM static Scheme_Object *module_name_symbol; ROSYM static Scheme_Object *nominal_id_symbol; ROSYM static Scheme_Object *phaseless_keyword; +ROSYM static Scheme_Object *empty_namespace_keyword; -/* global read-only syntax */ -READ_ONLY Scheme_Object *scheme_module_stx; -READ_ONLY Scheme_Object *scheme_modulestar_stx; -READ_ONLY Scheme_Object *scheme_module_begin_stx; -READ_ONLY Scheme_Object *scheme_begin_stx; -READ_ONLY Scheme_Object *scheme_define_values_stx; -READ_ONLY Scheme_Object *scheme_define_syntaxes_stx; -READ_ONLY Scheme_Object *scheme_top_stx; -READ_ONLY Scheme_Object *scheme_begin_for_syntax_stx; READ_ONLY static Scheme_Object *modbeg_syntax; -READ_ONLY static Scheme_Object *require_stx; -READ_ONLY static Scheme_Object *provide_stx; -READ_ONLY static Scheme_Object *declare_stx; -READ_ONLY static Scheme_Object *set_stx; -READ_ONLY static Scheme_Object *app_stx; -READ_ONLY static Scheme_Object *lambda_stx; -READ_ONLY static Scheme_Object *case_lambda_stx; -READ_ONLY static Scheme_Object *let_values_stx; -READ_ONLY static Scheme_Object *letrec_values_stx; -READ_ONLY static Scheme_Object *if_stx; -READ_ONLY static Scheme_Object *begin0_stx; -READ_ONLY static Scheme_Object *with_continuation_mark_stx; -READ_ONLY static Scheme_Object *letrec_syntaxes_stx; -READ_ONLY static Scheme_Object *var_ref_stx; -READ_ONLY static Scheme_Object *expression_stx; -READ_ONLY static Scheme_Object *quote_stx; -READ_ONLY static Scheme_Object *datum_stx; -READ_ONLY static Scheme_Object *make_struct_type_stx; -READ_ONLY static Scheme_Object *make_struct_type_property_stx; -READ_ONLY static Scheme_Object *list_stx; -READ_ONLY static Scheme_Object *cons_stx; -READ_ONLY static Scheme_Object *gensym_stx; -READ_ONLY static Scheme_Object *string_to_uninterned_symbol_stx; +/* phase wraps */ +THREAD_LOCAL_DECL(static Scheme_Object *scheme_sys_wraps0); +THREAD_LOCAL_DECL(static Scheme_Object *scheme_sys_wraps1); + +/* global syntax */ +THREAD_LOCAL_DECL(Scheme_Object *scheme_module_stx); +THREAD_LOCAL_DECL(Scheme_Object *scheme_modulestar_stx); +THREAD_LOCAL_DECL(Scheme_Object *scheme_module_begin_stx); +THREAD_LOCAL_DECL(Scheme_Object *scheme_begin_stx); +THREAD_LOCAL_DECL(Scheme_Object *scheme_define_values_stx); +THREAD_LOCAL_DECL(Scheme_Object *scheme_define_syntaxes_stx); +THREAD_LOCAL_DECL(Scheme_Object *scheme_top_stx); +THREAD_LOCAL_DECL(Scheme_Object *scheme_begin_for_syntax_stx); + +THREAD_LOCAL_DECL(Scheme_Object *more_constant_stxes[NUM_MORE_CONSTANT_STXES]); + +#ifdef MZ_XFORM +# define cnstXOA XFORM_OK_ASSIGN +#else +# define cnstXOA /* empty */ +#endif +#define CONSTANT_STX(pos) cnstXOA (more_constant_stxes[pos]) + +#define require_stx CONSTANT_STX(0) +#define provide_stx CONSTANT_STX(1) +#define declare_stx CONSTANT_STX(2) +#define set_stx CONSTANT_STX(3) +#define app_stx CONSTANT_STX(4) +#define lambda_stx CONSTANT_STX(5) +#define case_lambda_stx CONSTANT_STX(6) +#define let_values_stx CONSTANT_STX(7) +#define letrec_values_stx CONSTANT_STX(8) +#define if_stx CONSTANT_STX(9) +#define begin0_stx CONSTANT_STX(10) +#define with_continuation_mark_stx CONSTANT_STX(11) +#define letrec_syntaxes_stx CONSTANT_STX(12) +#define var_ref_stx CONSTANT_STX(13) +#define expression_stx CONSTANT_STX(14) +#define quote_stx CONSTANT_STX(15) +#define datum_stx CONSTANT_STX(16) + +#define make_struct_type_stx CONSTANT_STX(17) +#define make_struct_type_property_stx CONSTANT_STX(18) +#define list_stx CONSTANT_STX(19) +#define cons_stx CONSTANT_STX(20) +#define gensym_stx CONSTANT_STX(21) +#define string_to_uninterned_symbol_stx CONSTANT_STX(22) READ_ONLY static Scheme_Object *empty_self_modidx; READ_ONLY static Scheme_Object *empty_self_modname; @@ -265,8 +277,6 @@ THREAD_LOCAL_DECL(static Scheme_Bucket_Table *place_local_modpath_table); THREAD_LOCAL_DECL(static Scheme_Env *initial_modules_env); THREAD_LOCAL_DECL(static int num_initial_modules); THREAD_LOCAL_DECL(static Scheme_Object **initial_modules); -THREAD_LOCAL_DECL(static Scheme_Object *initial_renames); -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *initial_toplevel); /* caches */ THREAD_LOCAL_DECL(static Scheme_Modidx *modidx_caching_chain); @@ -295,21 +305,21 @@ THREAD_LOCAL_DECL(static Scheme_Object *global_shift_cache); #define NON_PHASELESS_IMPORT 0x1 #define NON_PHASELESS_FORM 0x2 -typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name, +typedef void (*Check_Func)(Scheme_Object *id, Scheme_Object *self_modidx, Scheme_Object *nominal_modname, Scheme_Object *nominal_export, Scheme_Object *modname, Scheme_Object *srcname, int exet, int isval, void *data, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *mark_src, + Scheme_Object *err_src, Scheme_Object *scope_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase); static void parse_requires(Scheme_Object *form, int at_phase, Scheme_Object *base_modidx, Scheme_Env *env, Scheme_Module *for_m, - Scheme_Object *rns, Scheme_Object *post_ex_rns, + Scheme_Object *rns, Check_Func ck, void *data, Scheme_Object *redef_modname, - int unpack_kern, int copy_vars, int can_save_marshal, + int copy_vars, int eval_exp, int eval_run, int *all_simple, Scheme_Hash_Table *modix_cache, @@ -528,7 +538,6 @@ void scheme_finish_kernel(Scheme_Env *env) /* When this function is called, the initial namespace has all the primitive bindings for syntax and procedures. This function fills in the module wrapper for #%kernel. */ - Scheme_Object *w; char *running; REGISTER_SO(kernel); @@ -562,7 +571,6 @@ void scheme_finish_kernel(Scheme_Env *env) int i, j, count, syntax_start = 0; Scheme_Bucket **bs; Scheme_Object **exs; - Scheme_Object *rn; /* Provide all syntax and variables: */ count = 0; for (j = 0; j < 2; j++) { @@ -616,93 +624,8 @@ void scheme_finish_kernel(Scheme_Env *env) running[1] = 1; env->running = running; env->attached = 1; - - /* Since this is the first module rename, it's registered as - the kernel module rename: */ - rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL, NULL, NULL); - for (i = kernel->me->rt->num_provides; i--; ) { - scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], - 0, scheme_make_integer(0), NULL, 0); - } - scheme_seal_module_rename(rn, STX_SEAL_ALL); } - REGISTER_SO(scheme_sys_wraps0); - REGISTER_SO(scheme_sys_wraps1); - - scheme_sys_wraps0 = scheme_sys_wraps_phase_worker(0); - scheme_sys_wraps1 = scheme_sys_wraps_phase_worker(1); - - scheme_sys_wraps(NULL); - - REGISTER_SO(scheme_module_stx); - REGISTER_SO(scheme_modulestar_stx); - REGISTER_SO(scheme_module_begin_stx); - REGISTER_SO(scheme_begin_stx); - REGISTER_SO(scheme_define_values_stx); - REGISTER_SO(scheme_define_syntaxes_stx); - REGISTER_SO(scheme_begin_for_syntax_stx); - REGISTER_SO(require_stx); - REGISTER_SO(provide_stx); - REGISTER_SO(declare_stx); - REGISTER_SO(set_stx); - REGISTER_SO(app_stx); - REGISTER_SO(scheme_top_stx); - REGISTER_SO(lambda_stx); - REGISTER_SO(case_lambda_stx); - REGISTER_SO(let_values_stx); - REGISTER_SO(letrec_values_stx); - REGISTER_SO(if_stx); - REGISTER_SO(begin0_stx); - REGISTER_SO(with_continuation_mark_stx); - REGISTER_SO(letrec_syntaxes_stx); - REGISTER_SO(var_ref_stx); - REGISTER_SO(expression_stx); - REGISTER_SO(quote_stx); - REGISTER_SO(datum_stx); - - w = scheme_sys_wraps0; - scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0); - scheme_modulestar_stx = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, w, 0, 0); - scheme_module_begin_stx = scheme_datum_to_syntax(module_begin_symbol, scheme_false, w, 0, 0); - scheme_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); - scheme_define_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); - scheme_define_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); - scheme_begin_for_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); - require_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); - provide_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); - declare_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%declare"), scheme_false, w, 0, 0); - set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0); - app_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0); - scheme_top_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0); - lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0); - case_lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0); - let_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0); - letrec_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0); - if_stx = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0); - begin0_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0); - with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0); - letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0); - var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0); - expression_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0); - quote_stx = scheme_datum_to_syntax(scheme_intern_symbol("quote"), scheme_false, w, 0, 0); - datum_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%datum"), scheme_false, w, 0, 0); - - REGISTER_SO(make_struct_type_stx); - REGISTER_SO(make_struct_type_property_stx); - REGISTER_SO(cons_stx); - REGISTER_SO(list_stx); - REGISTER_SO(gensym_stx); - REGISTER_SO(string_to_uninterned_symbol_stx); - - make_struct_type_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type"), scheme_false, w, 0, 0); - make_struct_type_property_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type-property"), scheme_false, w, 0, 0); - cons_stx = scheme_datum_to_syntax(scheme_intern_symbol("cons"), scheme_false, w, 0, 0); - list_stx = scheme_datum_to_syntax(scheme_intern_symbol("list"), scheme_false, w, 0, 0); - gensym_stx = scheme_datum_to_syntax(scheme_intern_symbol("gensym"), scheme_false, w, 0, 0); - string_to_uninterned_symbol_stx = scheme_datum_to_syntax(scheme_intern_symbol("string->uninterned-symbol"), - scheme_false, w, 0, 0); - REGISTER_SO(prefix_symbol); REGISTER_SO(only_symbol); REGISTER_SO(rename_symbol); @@ -753,6 +676,68 @@ void scheme_finish_kernel(Scheme_Env *env) const char *s = "cross-phase-persistent"; phaseless_keyword = scheme_intern_exact_keyword(s, strlen(s)); } + + REGISTER_SO(empty_namespace_keyword); + { + const char *s = "empty-namespace"; + empty_namespace_keyword = scheme_intern_exact_keyword(s, strlen(s)); + } +} + +void scheme_init_syntax_bindings() +{ + Scheme_Object *w; + + REGISTER_SO(scheme_sys_wraps0); + REGISTER_SO(scheme_sys_wraps1); + + scheme_sys_wraps0 = sys_wraps_phase(0); + scheme_sys_wraps1 = sys_wraps_phase(1); + + REGISTER_SO(scheme_module_stx); + REGISTER_SO(scheme_modulestar_stx); + REGISTER_SO(scheme_module_begin_stx); + REGISTER_SO(scheme_begin_stx); + REGISTER_SO(scheme_define_values_stx); + REGISTER_SO(scheme_define_syntaxes_stx); + REGISTER_SO(scheme_top_stx); + REGISTER_SO(scheme_begin_for_syntax_stx); + REGISTER_SO(more_constant_stxes); + + w = scheme_sys_wraps0; + scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0); + scheme_modulestar_stx = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, w, 0, 0); + scheme_module_begin_stx = scheme_datum_to_syntax(module_begin_symbol, scheme_false, w, 0, 0); + scheme_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); + scheme_define_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); + scheme_define_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); + scheme_begin_for_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); + require_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); + provide_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); + declare_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%declare"), scheme_false, w, 0, 0); + set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0); + app_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0); + scheme_top_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0); + lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0); + case_lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0); + let_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0); + letrec_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0); + if_stx = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0); + begin0_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0); + with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0); + letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0); + var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0); + expression_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0); + quote_stx = scheme_datum_to_syntax(scheme_intern_symbol("quote"), scheme_false, w, 0, 0); + datum_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%datum"), scheme_false, w, 0, 0); + + make_struct_type_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type"), scheme_false, w, 0, 0); + make_struct_type_property_stx = scheme_datum_to_syntax(scheme_intern_symbol("make-struct-type-property"), scheme_false, w, 0, 0); + cons_stx = scheme_datum_to_syntax(scheme_intern_symbol("cons"), scheme_false, w, 0, 0); + list_stx = scheme_datum_to_syntax(scheme_intern_symbol("list"), scheme_false, w, 0, 0); + gensym_stx = scheme_datum_to_syntax(scheme_intern_symbol("gensym"), scheme_false, w, 0, 0); + string_to_uninterned_symbol_stx = scheme_datum_to_syntax(scheme_intern_symbol("string->uninterned-symbol"), + scheme_false, w, 0, 0); } int scheme_is_kernel_modname(Scheme_Object *modname) @@ -845,25 +830,24 @@ Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env) return scheme_sys_wraps_phase(scheme_make_integer(phase)); } -static Scheme_Object *scheme_sys_wraps_phase_worker(intptr_t p) +static Scheme_Object *sys_wraps_phase(intptr_t p) { Scheme_Object *rn, *w; - rn = scheme_make_module_rename(scheme_make_integer(p), mzMOD_RENAME_NORMAL, NULL, NULL, NULL); + rn = scheme_make_module_context(NULL, NULL, kernel_symbol); + rn = scheme_module_context_at_phase(rn, scheme_make_integer(p)); /* Add a module mapping for all kernel provides: */ - scheme_extend_module_rename_with_shared(rn, kernel_modidx, - kernel->me->rt, - scheme_make_integer(p), - scheme_make_integer(0), - scheme_null, - NULL, - 1); - - scheme_seal_module_rename(rn, STX_SEAL_ALL); + scheme_extend_module_context_with_shared(rn, kernel_modidx, + kernel->me->rt, + scheme_false, /* no prefix */ + NULL, /* no excepts */ + scheme_make_integer(p), + NULL, + NULL); w = scheme_datum_to_syntax(kernel_symbol, scheme_false, scheme_false, 0, 0); - w = scheme_add_rename(w, rn); + w = scheme_stx_add_module_context(w, rn); return w; } @@ -880,7 +864,7 @@ Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase) if (p == 0) return scheme_sys_wraps0; if (p == 1) return scheme_sys_wraps1; - return scheme_sys_wraps_phase_worker(p); + return sys_wraps_phase(p); } void scheme_save_initial_module_set(Scheme_Env *env) @@ -916,28 +900,6 @@ void scheme_save_initial_module_set(Scheme_Env *env) initial_modules[count++] = ht->keys[i]; } } - - /* Clone renames: */ - if (!initial_renames) { - REGISTER_SO(initial_renames); - } - initial_renames = scheme_make_module_rename(scheme_make_integer(0), - mzMOD_RENAME_NORMAL, - NULL, - NULL, - NULL); - scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); - scheme_append_module_rename(scheme_get_module_rename_from_set(env->rename_set, - scheme_make_integer(0), - 1), - initial_renames, - 1); - - /* Clone variable bindings: */ - if (!initial_toplevel) { - REGISTER_SO(initial_toplevel); - } - initial_toplevel = scheme_clone_toplevel(env->toplevel, NULL); } void scheme_install_initial_module_set(Scheme_Env *env) @@ -959,20 +921,7 @@ void scheme_install_initial_module_set(Scheme_Env *env) namespace_attach_module(3, a); } - /* Copy renamings: */ - scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); - scheme_append_module_rename(initial_renames, - scheme_get_module_rename_from_set(env->rename_set, - scheme_make_integer(0), - 1), - 1); - - /* Copy toplevel: */ - { - Scheme_Bucket_Table *tl; - tl = scheme_clone_toplevel(initial_toplevel, env); - env->toplevel = tl; - } + scheme_prepare_env_stx_context(env); } static Scheme_Module *registry_get_loaded(Scheme_Env *env, Scheme_Object *name) @@ -1227,7 +1176,9 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], started = 1; srcmname = srcm->me->rt->provide_srcs[i]; - srcmname = scheme_modidx_shift(srcmname, srcm->me->src_modidx, srcm->self_modidx); + srcmname = scheme_modidx_shift(srcmname, + srcm->me->src_modidx, + srcm->self_modidx); srcmname = scheme_module_resolve(srcmname, 1); srcname = srcm->me->rt->provide_src_names[i]; @@ -1471,7 +1422,7 @@ static Scheme_Object *dynamic_require_for_syntax(int argc, Scheme_Object *argv[] static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], int copy, int etonly) { - Scheme_Object *form, *rns, *insp; + Scheme_Object *form, *insp; if (!env) env = scheme_get_env(NULL); @@ -1479,26 +1430,24 @@ static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Obj if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)) form = argv[0]; - else + else { form = scheme_datum_to_syntax(scheme_make_pair(require_stx, scheme_make_pair(argv[0], scheme_null)), scheme_false, scheme_false, 1, 0); + form = scheme_stx_add_module_context(form, env->stx_context); + } insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - rns = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL, insp); - parse_requires(form, env->phase, scheme_false, env, NULL, - rns, NULL, + env->stx_context, NULL /* ck */, NULL /* data */, NULL, - 1, copy, 0, + copy, (etonly ? 1 : -1), !etonly, NULL, NULL, NULL, NULL); - scheme_append_rename_set_to_env(rns, env); - return scheme_void; } @@ -2729,7 +2678,7 @@ int scheme_is_module_path(Scheme_Object *obj) int len, counter; len = scheme_proper_list_length(obj); - + if (len == 2) { /* Symbolic or string shorthand? */ obj = SCHEME_CDR(obj); @@ -2828,16 +2777,81 @@ static Scheme_Object *is_module_path(int argc, Scheme_Object **argv) : scheme_false); } -static int do_add_simple_require_renames(Scheme_Object *rn, +static Scheme_Object *require_binding_to_key(Scheme_Hash_Table *required, + Scheme_Object *binding_vec, + Scheme_Object *sym) +{ + Scheme_Object *vec, *vec2, *modname; + + vec = scheme_hash_get(required, sym); + if (vec) { + if (SCHEME_FALSEP(vec)) { + /* we've split the mapping for this symbol into binding-specific + mappings already; fall through */ + } else { + /* the symbol is mapped -- for the same binding? */ + if (same_resolved_modidx(SCHEME_VEC_ELS(binding_vec)[0], + SCHEME_VEC_ELS(vec)[1]) + && SAME_OBJ(SCHEME_VEC_ELS(binding_vec)[1], + SCHEME_VEC_ELS(vec)[2]) + && SAME_OBJ(SCHEME_VEC_ELS(binding_vec)[2], + SCHEME_VEC_ELS(vec)[8])) { + /* Yes, this symbol is mapped only for that one binding, so far */ + return sym; + } else { + /* need to re-key the existing mapping to a full binding, + map the plain symbol to #f, and fall through to generate + a full key for the new binding */ + vec2 = scheme_make_vector(4, NULL); + modname = scheme_module_resolve(SCHEME_VEC_ELS(vec)[1], 0); + SCHEME_VEC_ELS(vec2)[0] = modname; + SCHEME_VEC_ELS(vec2)[1] = SCHEME_VEC_ELS(vec)[2]; + SCHEME_VEC_ELS(vec2)[2] = SCHEME_VEC_ELS(vec)[8]; + SCHEME_VEC_ELS(vec2)[3] = sym; + + scheme_hash_set(required, vec2, vec); + scheme_hash_set(required, sym, scheme_false); + } + } + } else { + /* no binding mapped with this symbol in the key, yet, so we can + just use the symbol: */ + return sym; + } + + modname = scheme_module_resolve(SCHEME_VEC_ELS(binding_vec)[0], 0); + + vec2 = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec2)[0] = modname; + SCHEME_VEC_ELS(vec2)[1] = SCHEME_VEC_ELS(binding_vec)[1]; + SCHEME_VEC_ELS(vec2)[2] = SCHEME_VEC_ELS(binding_vec)[2]; + SCHEME_VEC_ELS(vec2)[3] = sym; + + return vec2; +} + +static int prep_required_id(Scheme_Object *vec) +{ + Scheme_Object *id = SCHEME_VEC_ELS(vec)[6]; + + if (SCHEME_SYMBOLP(id)) { + id = scheme_datum_to_syntax(id, scheme_false, SCHEME_VEC_ELS(vec)[5], 0, 0); + SCHEME_VEC_ELS(vec)[6] = id; + } + + return 1; +} + +static int do_add_simple_require_renames(Scheme_Object *rn, Scheme_Env *env, Scheme_Hash_Table *required, Scheme_Object *orig_src, Scheme_Module *im, Scheme_Module_Phase_Exports *pt, Scheme_Object *idx, - Scheme_Object *marshal_phase_index, Scheme_Object *src_phase_index, - int can_override) + int can_override, + int skip_binding_step) { int i, saw_mb, numvals; - Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src; + Scheme_Object **exs, **exss, **exsns, *midx, *vec, *nml, *key; int *exets; int with_shared = 1; @@ -2846,19 +2860,17 @@ static int do_add_simple_require_renames(Scheme_Object *rn, if (!pt->num_provides) return 0; - if (with_shared) { + if (with_shared && !skip_binding_step) { if (!pt->src_modidx && im->me->src_modidx) pt->src_modidx = im->me->src_modidx; - scheme_extend_module_rename_with_shared(rn, idx, pt, - marshal_phase_index, - scheme_make_integer(0), - scheme_null, - NULL, - 1); + scheme_extend_module_context_with_shared(rn, idx, pt, + scheme_false, /* no prefix */ + NULL, /* no excepts */ + src_phase_index, + orig_src, + NULL); } - mark_src = scheme_rename_to_stx(rn); - exs = pt->provides; exsns = pt->provide_src_names; exss = pt->provide_srcs; @@ -2869,10 +2881,9 @@ static int do_add_simple_require_renames(Scheme_Object *rn, midx = scheme_modidx_shift(exss[i], im->me->src_modidx, idx); else midx = idx; - if (!with_shared) { - scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i], - exets ? exets[i] : 0, src_phase_index, pt->phase_index, - 1); + if (!with_shared && !skip_binding_step) { + scheme_extend_module_context(rn, orig_src, midx, exs[i], exsns[i], idx, exs[i], + exets ? exets[i] : 0, src_phase_index, pt->phase_index); } if (SAME_OBJ(exs[i], module_begin_symbol)) saw_mb = 1; @@ -2884,32 +2895,32 @@ static int do_add_simple_require_renames(Scheme_Object *rn, 1 : the initial midx for the import 2 : a symbolic name in the original exporting module 3 : variable => #t; syntax => #f - 4 : the exported name + 4 : the exported name as a symbol 5 : a syntax object for error reporting - 6 : a syntax object for marks - 7 : whether the import can be shadowed + 6 : identifier as imported, where table key is corresponding binding; + a symbol value should be converted to an id using slot 5; see prep_required_id() + 7 : boolean, true if slot 6 is overrideable 8 : source phase */ vec = scheme_make_vector(9, NULL); nml = scheme_make_pair(idx, scheme_null); + + /* Since all initial exports have different names, we can use the + simple form of a key and be consistent with binding_to_key(): */ + key = exs[i]; + SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[1] = midx; SCHEME_VEC_ELS(vec)[2] = exsns[i]; SCHEME_VEC_ELS(vec)[3] = ((i < numvals) ? scheme_true : scheme_false); SCHEME_VEC_ELS(vec)[4] = exs[i]; SCHEME_VEC_ELS(vec)[5] = orig_src; - SCHEME_VEC_ELS(vec)[6] = mark_src; + SCHEME_VEC_ELS(vec)[6] = exs[i]; /* => id by cmbining with orig_src */ SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_make_integer(0); - scheme_hash_set(required, exs[i], vec); - } - } - if (!with_shared) { - info = cons(idx, cons(marshal_phase_index, - cons(scheme_make_integer(0), - cons(scheme_null, scheme_false)))); - scheme_save_module_rename_unmarshal(rn, info); + scheme_hash_set(required, key, vec); + } } return saw_mb; @@ -2922,8 +2933,8 @@ static Scheme_Object *get_table(Scheme_Hash_Table *tables, Scheme_Object *phase) vec = scheme_hash_get(tables, phase); if (!vec) { - required = scheme_make_hash_table(SCHEME_hash_ptr); - vec = scheme_make_vector(3, NULL); + required = scheme_make_hash_table_equal(); + vec = scheme_make_vector(3, scheme_false); SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required; scheme_hash_set(tables, phase, vec); } @@ -2944,24 +2955,25 @@ static Scheme_Hash_Table *get_required_from_tables(Scheme_Hash_Table *tables, Sc } static int add_simple_require_renames(Scheme_Object *orig_src, - Scheme_Object *rn_set, + Scheme_Object *rn_set, Scheme_Env *env, Scheme_Hash_Table *tables, Scheme_Module *im, Scheme_Object *idx, Scheme_Object *import_shift /* = src_phase_index */, Scheme_Object *only_export_phase, - int can_override) + int can_override, + int skip_binding_step) { int saw_mb; Scheme_Object *phase; if (im->me->rt && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(0)))) - saw_mb = do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, import_shift, 1), + saw_mb = do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, import_shift), env, get_required_from_tables(tables, import_shift), orig_src, im, im->me->rt, idx, - scheme_make_integer(0), import_shift, - can_override); + can_override, + skip_binding_step); else saw_mb = 0; @@ -2971,22 +2983,22 @@ static int add_simple_require_renames(Scheme_Object *orig_src, phase = scheme_false; else phase = scheme_bin_plus(scheme_make_integer(1), import_shift); - do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, phase, 1), + do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, phase), env, get_required_from_tables(tables, phase), orig_src, im, im->me->et, idx, - scheme_make_integer(1), import_shift, - can_override); + can_override, + skip_binding_step); } if (im->me->dt && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_false))) { - do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, scheme_false, 1), + do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, scheme_false), env, get_required_from_tables(tables, scheme_false), orig_src, im, im->me->dt, idx, - scheme_false, import_shift, - can_override); + can_override, + skip_binding_step); } if (im->me->other_phases) { @@ -3001,12 +3013,12 @@ static int add_simple_require_renames(Scheme_Object *orig_src, phase = scheme_false; else phase = scheme_bin_plus(key, import_shift); - do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, phase, 1), + do_add_simple_require_renames(scheme_module_context_at_phase(rn_set, phase), env, get_required_from_tables(tables, phase), orig_src, im, (Scheme_Module_Phase_Exports *)val, idx, - key, import_shift, - can_override); + can_override, + skip_binding_step); } } } @@ -3015,6 +3027,24 @@ static int add_simple_require_renames(Scheme_Object *orig_src, return saw_mb; } +static void add_reconstructed_binding(Scheme_Object *name, Scheme_Object *one_rn, Scheme_Object *self_modidx, + Scheme_Env *env, int phase) +{ + Scheme_Hash_Table *binding_names; + + scheme_extend_module_context(one_rn, NULL, self_modidx, name, name, self_modidx, name, phase, + scheme_make_integer(phase), NULL); + + binding_names = (Scheme_Hash_Table *)env->binding_names; + if (!binding_names) { + binding_names = scheme_make_hash_table(SCHEME_hash_ptr); + env->binding_names = (Scheme_Object *)binding_names; + } + scheme_hash_set(binding_names, name, + scheme_stx_add_module_context(scheme_datum_to_syntax(name, scheme_false, scheme_false, 0, 0), + one_rn)); +} + void scheme_prep_namespace_rename(Scheme_Env *menv) { while (menv->mod_phase > 0) { @@ -3030,41 +3060,19 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) Scheme_Object *rns; Scheme_Module *m = menv->module; - scheme_prepare_env_renames(menv, mzMOD_RENAME_NORMAL); + scheme_prepare_env_stx_context(menv); if (SAME_OBJ(scheme_true, m->rn_stx)) { /* Reconstruct renames based on defns and requires. This case is - used only when it's easy to reconstruct: no renames, no for-syntax - definitions, etc. */ + used only when it's easy to reconstruct: no rename on import, + no prefixes or exclusions on import, no definitions within the + module that are inaccessible due to scope differences, etc. */ int i, j; Scheme_Module *im; Scheme_Object *l, *idx, *one_rn, *shift, *name; - rns = menv->rename_set; - one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(0), 1); - - /* Local, provided: */ - for (i = 0; i < m->me->rt->num_provides; i++) { - if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) { - name = m->me->rt->provide_src_names[i]; - scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); - } - } - for (j = 0; j < m->num_phases; j++) { - Scheme_Module_Export_Info *exp_info = m->exp_infos[j]; - one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(j), 1); - for (i = 0; i < exp_info->num_indirect_provides; i++) { - name = exp_info->indirect_provides[i]; - scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, j, - scheme_make_integer(j), NULL, 0); - } - for (i = 0; i < exp_info->num_indirect_syntax_provides; i++) { - name = exp_info->indirect_syntax_provides[i]; - scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, j, - scheme_make_integer(j), NULL, 0); - } - } + rns = menv->stx_context; + one_rn = scheme_module_context_at_phase(rns, scheme_make_integer(0)); /* Required: */ for (i = -4; i < (menv->other_require_names ? menv->other_require_names->size : 0); i++) { @@ -3101,55 +3109,62 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) if (!im) im = registry_get_loaded(menv, name); - add_simple_require_renames(NULL, rns, NULL, im, idx, shift, NULL, 0); + add_simple_require_renames(NULL, rns, menv, NULL, im, idx, shift, + NULL, 0, 0); } } } + + /* Local, provided: */ + for (i = 0; i < m->me->rt->num_provides; i++) { + if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) { + name = m->me->rt->provide_src_names[i]; + add_reconstructed_binding(name, one_rn, m->self_modidx, menv, 0); + } + } + for (j = 0; j < m->num_phases; j++) { + Scheme_Module_Export_Info *exp_info = m->exp_infos[j]; + Scheme_Env *penv; + one_rn = scheme_module_context_at_phase(rns, scheme_make_integer(j)); + penv = scheme_find_env_at_phase(menv, scheme_make_integer(j)); + for (i = 0; i < exp_info->num_indirect_provides; i++) { + name = exp_info->indirect_provides[i]; + add_reconstructed_binding(name, one_rn, m->self_modidx, penv, j); + } + for (i = 0; i < exp_info->num_indirect_syntax_provides; i++) { + name = exp_info->indirect_syntax_provides[i]; + add_reconstructed_binding(name, one_rn, m->self_modidx, penv, j); + } + } - rns = scheme_rename_to_stx(rns); + rns = scheme_module_context_to_stx(rns, NULL); m->rn_stx = rns; } else if (SCHEME_PAIRP(m->rn_stx)) { /* Delayed shift: */ - Scheme_Object *vec, *vec2, *rn_stx, *midx; - int i; - - vec = SCHEME_CAR(m->rn_stx); - midx = SCHEME_CDR(m->rn_stx); + Scheme_Object *rn_stx, *midx; - if (!SCHEME_VECTORP(vec)) - vec = scheme_make_vector(1, vec); - vec2 = scheme_make_vector(SCHEME_VEC_SIZE(vec), NULL); + rn_stx = SCHEME_CAR(m->rn_stx); + midx = SCHEME_CDR(m->rn_stx); - for (i = SCHEME_VEC_SIZE(vec); i--; ) { - rn_stx = SCHEME_VEC_ELS(vec)[i]; - rns = scheme_stx_to_rename(rn_stx); - rns = scheme_stx_shift_rename_set(rns, midx, m->self_modidx, menv->access_insp); - rn_stx = scheme_rename_to_stx(rns); - SCHEME_VEC_ELS(vec2)[i] = rn_stx; - } + rn_stx = scheme_stx_force_delayed(rn_stx); + + rn_stx = scheme_stx_shift(rn_stx, scheme_make_integer(0), midx, m->self_modidx, + NULL, m->prefix->src_insp_desc, menv->access_insp); - m->rn_stx = vec2; + m->rn_stx = rn_stx; + } else { + Scheme_Object *rn_stx; + rn_stx = scheme_stx_force_delayed(m->rn_stx); + m->rn_stx = rn_stx; } - /* add rename(s) to the environment's rename: */ - { - int i; - Scheme_Object *vec = m->rn_stx, *prior = NULL; - - if (!SCHEME_VECTORP(vec)) { - vec = scheme_make_vector(1, vec); - m->rn_stx = vec; - } - - for (i = SCHEME_VEC_SIZE(vec); i--; ) { - rns = scheme_stx_to_rename(SCHEME_VEC_ELS(vec)[i]); - scheme_append_rename_set_to_env(rns, menv); - prior = scheme_accum_prior_contexts(rns, prior); - } - scheme_install_prior_contexts_to_env(prior, menv); - } + rns = scheme_stx_to_module_context(m->rn_stx); + menv->stx_context = rns; menv->rename_set_ready = 1; + } else { + /* had #:empty-namespace declaration */ + scheme_prepare_env_stx_context(menv); } } } @@ -3199,6 +3214,8 @@ Scheme_Object *scheme_module_to_namespace(Scheme_Object *name, Scheme_Env *env) scheme_prep_namespace_rename(menv); + menv->interactive_bindings = 1; + return (Scheme_Object *)menv; } @@ -3971,7 +3988,7 @@ Scheme_Object *scheme_make_modidx(Scheme_Object *path, return (Scheme_Object *)modidx; } -int same_modidx(Scheme_Object *a, Scheme_Object *b) +static int same_modidx(Scheme_Object *a, Scheme_Object *b) { if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = ((Scheme_Modidx *)a)->path; @@ -3981,7 +3998,7 @@ int same_modidx(Scheme_Object *a, Scheme_Object *b) return scheme_equal(a, b); } -int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b) +static int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b) { if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = scheme_module_resolve(a, 1); @@ -3991,6 +4008,25 @@ int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b) return scheme_equal(a, b); } +static Scheme_Object *resolved_module_path_to_modidx(Scheme_Object *rmp) +{ + Scheme_Object *path; + + path = SCHEME_PTR_VAL(rmp); + if (!SCHEME_PATHP(path)) { + if (SCHEME_SYMBOLP(path)) + path = scheme_make_pair(quote_symbol, scheme_make_pair(path, scheme_null)); + else { + if (SCHEME_SYMBOLP(SCHEME_CAR(path))) + path = scheme_make_pair(scheme_make_pair(quote_symbol, scheme_make_pair(SCHEME_CAR(path), scheme_null)), + scheme_null); + path = scheme_make_pair(submod_symbol, path); + } + } + + return scheme_make_modidx(path, scheme_false, rmp); +} + Scheme_Object *scheme_get_submodule_empty_self_modidx(Scheme_Object *submodule_path) { Scheme_Bucket *b; @@ -4350,9 +4386,8 @@ static void setup_accessible_table(Scheme_Module *m) /* Add syntax as negative ids: */ count = pt->num_provides; for (i = nvp; i < count; i++) { - if (SCHEME_FALSEP(pt->provide_srcs[i])) { + if (SCHEME_FALSEP(pt->provide_srcs[i])) scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(-(i+1))); - } } if (!j) { @@ -4466,17 +4501,17 @@ Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, intptr_t } static void check_certified(Scheme_Object *stx, - Scheme_Object *prot_insp, Scheme_Object *insp, - Scheme_Object *rename_insp, Scheme_Object *in_modidx, + Scheme_Object *current_insp, Scheme_Object *binding_insp, + Scheme_Object *in_modidx, Scheme_Env *env, Scheme_Object *symbol, int var, int prot, int *_would_complain) { int need_cert = 1; - if (need_cert && insp) - need_cert = scheme_module_protected_wrt(env->guard_insp, insp); - if (need_cert && rename_insp) - need_cert = scheme_module_protected_wrt(env->guard_insp, rename_insp); + if (need_cert && current_insp) + need_cert = scheme_module_protected_wrt(env->guard_insp, current_insp); + if (need_cert && binding_insp) + need_cert = scheme_module_protected_wrt(env->guard_insp, binding_insp); if (need_cert) { if (_would_complain) { @@ -4496,10 +4531,28 @@ static void check_certified(Scheme_Object *stx, } } -Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx, +static Scheme_Object *to_defined_symbol_at_phase(Scheme_Object *symbol, Scheme_Env *env, Scheme_Object *phase) +{ + Scheme_Object *binding; + + binding = scheme_stx_lookup(symbol, phase); + if (SCHEME_VECTORP(binding) + && SAME_OBJ(env->module->self_modidx, SCHEME_VEC_ELS(binding)[0]) + && SAME_OBJ(phase, SCHEME_VEC_ELS(binding)[2])) + return SCHEME_VEC_ELS(binding)[1]; + + return SCHEME_STX_VAL(symbol); +} + +static Scheme_Object *to_defined_symbol(Scheme_Object *symbol, Scheme_Env *env) +{ + return to_defined_symbol_at_phase(symbol, env, scheme_make_integer(env->phase)); +} + +Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *in_modidx, Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *certs, Scheme_Object *unexp_insp, - Scheme_Object *rename_insp, + Scheme_Object *current_insp, + Scheme_Object *binding_insp, int position, int want_pos, int *_protected, int *_unexported, Scheme_Env *from_env, int *_would_complain, @@ -4509,19 +4562,12 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object If position < -1, then merely checks for protected syntax. Access for protected and unexported names depends on - certifictions in stx+certs, access implied by - {prot_,unexp_}insp, or access implied by in_modidx. For - unexported access, either stx+certs or unexp_insp must be - supplied (not both), and prot_insp should be supplied - (for protected re-exports of unexported). - For unprotected access, both prot_insp and stx+certs - should be supplied. In either case, rename_insp - is optionally allowed. */ + `current_insp` (dynamic context) and `binding_insp` (static context). */ { Scheme_Module_Phase_Exports *pt; if (!SCHEME_SYMBOLP(symbol)) - symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL); + symbol = to_defined_symbol(symbol, env); if (scheme_is_kernel_env(env) || ((env->module->primitive && !env->module->exp_infos[0]->provide_protects))) { @@ -4585,7 +4631,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) { if ((position < pt->num_var_provides) - && scheme_module_protected_wrt(env->guard_insp, prot_insp)) { + && scheme_module_protected_wrt(env->guard_insp, current_insp)) { char *provide_protects; if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) @@ -4597,12 +4643,12 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && provide_protects[position]) { if (_protected) *_protected = 1; - check_certified(stx, prot_insp, prot_insp, rename_insp, in_modidx, env, symbol, 1, 1, _would_complain); + check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 1, 1, _would_complain); } } if (need_cert) - check_certified(stx, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 1, 0, _would_complain); + check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 1, 0, _would_complain); if (want_pos) return scheme_make_integer(position); @@ -4618,7 +4664,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object pos = scheme_hash_get(env->module->exp_infos[env->mod_phase]->accessible, symbol); else pos = NULL; - + if (pos) { if (SCHEME_PAIRP(pos)) { if (_is_constant) *_is_constant = SCHEME_CDR(pos); @@ -4665,7 +4711,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && provide_protects[SCHEME_INT_VAL(pos)]) { if (_protected) *_protected = 1; - check_certified(stx, prot_insp, prot_insp, rename_insp, in_modidx, env, symbol, 1, 1, _would_complain); + check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 1, 1, _would_complain); } if ((position >= -1) @@ -4675,7 +4721,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *_protected = 1; if (_unexported) *_unexported = 1; - check_certified(stx, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 1, 0, _would_complain); + check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 1, 0, _would_complain); } if (want_pos) @@ -4688,7 +4734,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object /* unexported syntax -- need cert */ if (_unexported) *_unexported = 1; - check_certified(stx, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 0, 0, _would_complain); + check_certified(stx, current_insp, binding_insp, in_modidx, env, symbol, 0, 0, _would_complain); return NULL; } } @@ -4852,7 +4898,7 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, } if (SCHEME_STXP(name)) - name = scheme_tl_id_sym(menv, name, NULL, 0, NULL, NULL); + name = to_defined_symbol(name, menv); val = scheme_lookup_in_table(menv->syntax, (char *)name); @@ -5057,7 +5103,7 @@ static void compute_require_names(Scheme_Env *menv, Scheme_Object *phase, reqs = scheme_null; if (!SCHEME_NULLP(reqs) && !menv->other_require_names) { Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_equal(); + ht = scheme_make_hash_table_eqv(); menv->other_require_names = ht; } if (menv->other_require_names) @@ -5384,6 +5430,8 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res env2 = menv->label_env; if (env2) env2->module = m; + + menv->interactive_bindings = 1; } menv->access_insp = m->insp; @@ -5396,7 +5444,7 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res menv->et_require_names = scheme_null; menv->tt_require_names = scheme_null; menv->dt_require_names = scheme_null; - + if (env->label_env != env) { setup_accessible_table(m); @@ -5516,7 +5564,7 @@ void *scheme_module_exprun_finish(Scheme_Env *menv, int at_phase) syntax = menv->syntax; - rhs_env = scheme_new_comp_env(menv, menv->access_insp, SCHEME_TOPLEVEL_FRAME); + rhs_env = scheme_new_comp_env(menv, menv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); cnt = SCHEME_VEC_SIZE(menv->module->bodies[at_phase]); for (i = 0; i < cnt; i++) { @@ -5725,9 +5773,11 @@ static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) menv = (Scheme_Env *)v; v = menv->available_next[pos]; menv->available_next[pos] = NULL; + BEGIN_ESCAPEABLE(unlock_registry, env); start_module(menv->module, menv->instance_env, 0, NULL, 1, 0, base_phase, scheme_null, 1); + END_ESCAPEABLE(); } if (need_lock) @@ -6254,13 +6304,13 @@ static void *eval_exptime_k(void) Resolve_Prefix *rp; int let_depth, shift; Scheme_Bucket_Table *syntax; - Scheme_Object *free_id_rename_rn, *insp; + Scheme_Object *ids_for_rename_trans, *insp; names = (Scheme_Object *)p->ku.k.p1; expr = (Scheme_Object *)p->ku.k.p2; genv = (Scheme_Env *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[0]; comp_env = (Scheme_Comp_Env *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[1]; - free_id_rename_rn = SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[2]; + ids_for_rename_trans = SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[2]; rp = (Resolve_Prefix *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[3]; syntax = (Scheme_Bucket_Table *)SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[4]; insp = SCHEME_VEC_ELS((Scheme_Object *)p->ku.k.p4)[5]; @@ -6276,7 +6326,7 @@ static void *eval_exptime_k(void) p->ku.k.p5 = NULL; eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, at_phase, - free_id_rename_rn, insp); + ids_for_rename_trans, insp); return NULL; } @@ -6298,7 +6348,7 @@ static void eval_exptime(Scheme_Object *names, int count, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, int at_phase, - Scheme_Object *free_id_rename_rn, + Scheme_Object *ids_for_rename_trans, Scheme_Object *insp) { Scheme_Object *macro, *vals, *name, **save_runstack; @@ -6312,7 +6362,7 @@ static void eval_exptime(Scheme_Object *names, int count, vals = scheme_make_vector(6, NULL); SCHEME_VEC_ELS(vals)[0] = (Scheme_Object *)genv; SCHEME_VEC_ELS(vals)[1] = (Scheme_Object *)comp_env; - SCHEME_VEC_ELS(vals)[2] = free_id_rename_rn; + SCHEME_VEC_ELS(vals)[2] = ids_for_rename_trans; SCHEME_VEC_ELS(vals)[3] = (Scheme_Object *)rp; SCHEME_VEC_ELS(vals)[4] = (Scheme_Object *)syntax; SCHEME_VEC_ELS(vals)[5] = insp; @@ -6347,7 +6397,7 @@ static void eval_exptime(Scheme_Object *names, int count, scheme_push_continuation_frame(&cframe); scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - scheme_set_dynamic_state(&dyn_state, comp_env, NULL, scheme_false, + scheme_set_dynamic_state(&dyn_state, comp_env, NULL, NULL, scheme_false, genv, (genv->link_midx ? genv->link_midx : genv->module->me->src_modidx)); vals = scheme_eval_linked_expr_multi_with_dynamic_state(expr, &dyn_state); @@ -6374,12 +6424,16 @@ static void eval_exptime(Scheme_Object *names, int count, macro->type = scheme_macro_type; SCHEME_PTR_VAL(macro) = values[i]; - if (SCHEME_TRUEP(free_id_rename_rn) - && scheme_is_binding_rename_transformer(values[i])) - scheme_install_free_id_rename(name, scheme_rename_transformer_id(values[i]), free_id_rename_rn, - scheme_make_integer(0)); - + if (SCHEME_TRUEP(ids_for_rename_trans) + && scheme_is_binding_rename_transformer(values[i])) { + scheme_add_binding_copy(SCHEME_CAR(ids_for_rename_trans), + scheme_rename_transformer_id(values[i]), + scheme_make_integer(at_phase-1)); + } scheme_add_to_table(syntax, (const char *)name, macro, 0); + + if (SCHEME_TRUEP(ids_for_rename_trans)) + ids_for_rename_trans = SCHEME_CDR(ids_for_rename_trans); } return; @@ -6390,12 +6444,13 @@ static void eval_exptime(Scheme_Object *names, int count, macro = scheme_alloc_small_object(); macro->type = scheme_macro_type; SCHEME_PTR_VAL(macro) = vals; - - if (SCHEME_TRUEP(free_id_rename_rn) - && scheme_is_binding_rename_transformer(vals)) - scheme_install_free_id_rename(name, scheme_rename_transformer_id(vals), free_id_rename_rn, - scheme_make_integer(0)); - + + if (SCHEME_TRUEP(ids_for_rename_trans) + && scheme_is_binding_rename_transformer(vals)) { + scheme_add_binding_copy(SCHEME_CAR(ids_for_rename_trans), + scheme_rename_transformer_id(vals), + scheme_make_integer(at_phase-1)); + } scheme_add_to_table(syntax, (const char *)name, macro, 0); return; @@ -6549,8 +6604,6 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, /* Delay the shift: */ Scheme_Object *v; v = m->rn_stx; - if (SCHEME_PAIRP(v)) - v = scheme_list_to_vector(v); v = scheme_make_pair(v, (Scheme_Object *)midx); m->rn_stx = v; } @@ -6635,6 +6688,7 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, ht = scheme_make_hash_table(SCHEME_hash_ptr); env->module_pre_registry->loaded = ht; ht = scheme_make_hash_table(SCHEME_hash_ptr); + MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1; /* print (for debugging) as opqaue */ env->module_pre_registry->exports = ht; } scheme_hash_set(env->module_pre_registry->loaded, m->modname, (Scheme_Object *)m); @@ -6654,6 +6708,7 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, /* Replacing an already-running or already-syntaxing module? */ if (old_menv) { + old_menv->interactive_bindings = 1; start_module(m, env, 1, NULL, ((m->num_phases > 1) ? old_menv->running[1] : 0), old_menv->running[0], @@ -6911,271 +6966,9 @@ static void check_not_tainted(Scheme_Object *orig) "cannot expand module body tainted by macro expansion"); } -static Scheme_Object *do_annotate_submodules_k(void); - -Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase, int incl_star) -{ - Scheme_Object *a, *d, *v, *fm2; - int changed = 0; - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)fm; - p->ku.k.i1 = phase; - p->ku.k.i2 = incl_star; - return scheme_handle_stack_overflow(do_annotate_submodules_k); - } -#endif - - if (SCHEME_STXP(fm)) - check_not_tainted(fm); - - if (!SCHEME_STX_PAIRP(fm)) - return fm; - - if (SCHEME_STXP(fm)) - fm2 = scheme_stx_taint_disarm(fm, NULL); - else - fm2 = fm; - - a = SCHEME_STX_CAR(fm2); - if (SCHEME_STX_PAIRP(a)) { - a = scheme_stx_taint_disarm(a, NULL); - v = SCHEME_STX_CAR(a); - if (SCHEME_STX_SYMBOLP(v)) { - if (scheme_stx_module_eq3(scheme_module_stx, v, - scheme_make_integer(0), scheme_make_integer(phase), - NULL) - || (incl_star - && scheme_stx_module_eq3(scheme_modulestar_stx, v, - scheme_make_integer(0), scheme_make_integer(phase), - NULL))) { - /* found a submodule */ - v = scheme_stx_property(a, scheme_intern_symbol("submodule"), NULL); - if (SCHEME_FALSEP(v)) { - a = scheme_stx_property(a, scheme_intern_symbol("submodule"), a); - changed = 1; - } - } else if (scheme_stx_module_eq3(scheme_begin_for_syntax_stx, v, - scheme_make_integer(0), scheme_make_integer(phase), - NULL)) { - /* found `begin-for-syntax' */ - v = do_annotate_submodules(a, phase+1, incl_star); - if (!SAME_OBJ(v, a)) { - changed = 1; - a = v; - } - } else if (scheme_stx_module_eq3(scheme_begin_stx, v, - scheme_make_integer(0), scheme_make_integer(phase), - NULL)) { - /* found `begin' */ - v = do_annotate_submodules(a, phase, incl_star); - if (!SAME_OBJ(v, a)) { - changed = 1; - a = v; - } - } - } - } - - v = SCHEME_STX_CDR(fm2); - d = do_annotate_submodules(v, phase, incl_star); - - if (!changed && SAME_OBJ(v, d)) - return fm; - - v = scheme_make_pair(a, d); - if (SCHEME_STXP(fm)) - v = scheme_datum_to_syntax(v, fm, fm, 0, 2); - - return v; -} - -static Scheme_Object *do_annotate_submodules_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *fm = (Scheme_Object *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - return do_annotate_submodules(fm, p->ku.k.i1, p->ku.k.i2); -} - -Scheme_Object *scheme_annotate_existing_submodules(Scheme_Object *orig_fm, int incl_star) -{ - Scheme_Object *fm = orig_fm; - - if (!SCHEME_STX_PAIRP(fm)) - return orig_fm; - fm = SCHEME_STX_CAR(fm); - if (!SCHEME_STX_SYMBOLP(fm)) - return orig_fm; - - if (scheme_stx_module_eq(scheme_module_begin_stx, fm, 0)) { - /* It's a `#%plain-module-begin' form */ - return do_annotate_submodules(orig_fm, 0, incl_star); - } - - return orig_fm; -} - -static Scheme_Object *phase_shift_tail(Scheme_Object *v, Scheme_Object *ps) -{ - if (!SCHEME_STXP(v)) - v = scheme_datum_to_syntax(v, scheme_false, scheme_false, 0, 0); - - return scheme_add_rename(v, ps); -} - -static Scheme_Object *rebuild_with_phase_shift(Scheme_Object *orig, Scheme_Object *a, Scheme_Object *d, - Scheme_Object *ps) -{ - if (!a) { - a = orig; - if (SCHEME_STXP(a)) - a = scheme_stx_taint_disarm(a, NULL); - a = SCHEME_STX_CAR(a); - a = scheme_add_rename(a, ps); - } - if (!d) { - d = orig; - if (SCHEME_STXP(d)) - d = scheme_stx_taint_disarm(d, NULL); - d = SCHEME_STX_CDR(d); - d = phase_shift_tail(d, ps); - } - - a = scheme_make_pair(a, d); - - if (SCHEME_PAIRP(orig)) - return a; - - check_not_tainted(orig); - - orig = scheme_add_rename(orig, ps); - return scheme_datum_to_syntax(a, orig, orig, 0, 2); -} - -static Scheme_Object *phase_shift_skip_submodules_k(void); - -static Scheme_Object *phase_shift_skip_submodules(Scheme_Object *fm, Scheme_Object *ps, int phase) -{ - Scheme_Object *v0, *v1, *v2, *v3, *v4, *naya; - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)fm; - p->ku.k.p2 = (void *)ps; - p->ku.k.i1 = phase; - return scheme_handle_stack_overflow(phase_shift_skip_submodules_k); - } -#endif - - if (phase == -1) { - /* at top, so this is a `module[*]' form: */ - v0 = fm; - if (SCHEME_STXP(v0)) - v0 = scheme_stx_taint_disarm(v0, NULL); - v0 = SCHEME_STX_CDR(v0); - v1 = SCHEME_STX_CDR(v0); - v2 = SCHEME_STX_CDR(v1); - v3 = SCHEME_STX_CAR(v2); - v4 = scheme_stx_taint_disarm(v3, NULL); - v4 = SCHEME_STX_CDR(v4); - - naya = phase_shift_skip_submodules(v4, ps, 0); - if (SAME_OBJ(naya, v4)) { - return scheme_add_rename(fm, ps); - } else { - v3 = rebuild_with_phase_shift(v3, NULL, naya, ps); - v2 = rebuild_with_phase_shift(v2, v3, NULL, ps); - v1 = rebuild_with_phase_shift(v1, NULL, v2, ps); - v0 = rebuild_with_phase_shift(v0, NULL, v1, ps); - return rebuild_with_phase_shift(fm, NULL, v0, ps); - } - } else if (SCHEME_STX_NULLP(fm)) { - return fm; - } else { - v0 = fm; - if (SCHEME_STXP(v0)) - v0 = scheme_stx_taint_disarm(v0, NULL); - v1 = SCHEME_STX_CAR(v0); - - if (SCHEME_STX_PAIRP(v1)) { - if (SCHEME_STXP(v1)) - v1 = scheme_stx_taint_disarm(v1, NULL); - v2 = SCHEME_STX_CAR(v1); - if (SCHEME_STX_SYMBOLP(v2)) { - if (scheme_stx_module_eq_x(scheme_module_stx, v2, phase) - || scheme_stx_module_eq_x(scheme_modulestar_stx, v2, phase)) { - /* found a submodule */ - v2 = SCHEME_STX_CDR(fm); - naya = phase_shift_skip_submodules(v2, ps, phase); - if (SAME_OBJ(naya, v2)) - naya = phase_shift_tail(naya, ps); - return rebuild_with_phase_shift(fm, v1, naya, ps); - } else if (scheme_stx_module_eq_x(scheme_begin_for_syntax_stx, v2, phase)) { - /* found `begin-for-syntax': */ - naya = phase_shift_skip_submodules(v1, ps, phase+1); - v2 = SCHEME_STX_CDR(fm); - v3 = phase_shift_skip_submodules(v2, ps, phase); - if (SAME_OBJ(naya, v1) && SAME_OBJ(v2, v3)) - return fm; - else { - if (SAME_OBJ(naya, v1)) - naya = phase_shift_tail(naya, ps); - if (SAME_OBJ(v2, v3)) - v3 = phase_shift_tail(v3, ps); - return rebuild_with_phase_shift(fm, naya, v3, ps); - } - } - } - } - - v3 = SCHEME_STX_CDR(fm); - v4 = phase_shift_skip_submodules(v3, ps, phase); - if (SAME_OBJ(v3, v4)) - return fm; - else { - v1 = scheme_add_rename(v1, ps); - return rebuild_with_phase_shift(fm, v1, v4, ps); - } - } -} - -static Scheme_Object *phase_shift_skip_submodules_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *fm = (Scheme_Object *)p->ku.k.p1; - Scheme_Object *ps = (Scheme_Object *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return phase_shift_skip_submodules(fm, ps, p->ku.k.i1); -} - static Scheme_Env *find_env(Scheme_Env *env, intptr_t ph) { - 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; + return scheme_find_env_at_phase(env, scheme_make_integer(ph - env->phase)); } static Scheme_Object *extract_root_module_name(Scheme_Module *m) @@ -7195,6 +6988,30 @@ static Scheme_Object *extract_root_module_name(Scheme_Module *m) return root_module_name; } +static void add_binding_names_from_environment(Scheme_Module *m, Scheme_Env *benv) +{ + if (benv->binding_names) { + int c; + + if (SCHEME_HASHTP(benv->binding_names)) + c = ((Scheme_Hash_Table *)benv->binding_names)->count; + else + c = ((Scheme_Hash_Tree *)benv->binding_names)->count; + + if (c) { + Scheme_Hash_Table *ht; + + ht = (Scheme_Hash_Table *)m->other_binding_names; + if (!ht) { + ht = scheme_make_hash_table_eqv(); + m->other_binding_names = (Scheme_Object *)ht; + } + + scheme_hash_set(ht, scheme_env_phase(benv), benv->binding_names); + } + } +} + #if 0 # define LOG_EXPAND_DECLS intptr_t start_time # define LOG_START_EXPAND(mod) (start_time = scheme_get_process_milliseconds()) @@ -7214,14 +7031,14 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *super_phase_shift) { Scheme_Object *fm, *disarmed_form; - Scheme_Object *nm, *ii, *iidx, *self_modidx, *rmp, *rn_set, *mb_ctx; + Scheme_Object *nm, *ii, *iidx, *self_modidx, *rmp, *rn_set, *mb_ctx, *ctx_form; Scheme_Module *iim; Scheme_Env *menv, *top_env; Scheme_Comp_Env *benv; Scheme_Module *m; Scheme_Object *mbval, *orig_ii; Scheme_Object *this_empty_self_modidx; - int saw_mb, check_mb = 0, skip_strip = 0; + int saw_mb, check_mb = 0, shift_back = 0; Scheme_Object *restore_confusing_name = NULL; LOG_EXPAND_DECLS; @@ -7231,15 +7048,6 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, rec[drec].depth++; } - if (scheme_is_nested_module(env)) { - fm = scheme_stx_property(form, scheme_intern_symbol("submodule"), NULL); - if (SCHEME_STXP(fm)) { - form = fm; - skip_strip = 1; - } else - skip_strip = 0; - } - if (!scheme_is_toplevel(env)) scheme_wrong_syntax(NULL, NULL, form, "not in a module-definition context"); @@ -7256,20 +7064,31 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, scheme_wrong_syntax(NULL, NULL, form, NULL); ii = SCHEME_STX_CAR(fm); fm = SCHEME_STX_CDR(fm); + orig_ii = ii; - if (scheme_is_nested_module(env)) { - if (post && SCHEME_FALSEP(SCHEME_STX_VAL(ii))) { - ii = NULL; - } else { - super_phase_shift = scheme_make_integer(0); - if (!skip_strip) { - ii = strip_lexical_context(ii); - fm = strip_lexical_context(fm); - } - } + if (post && SCHEME_FALSEP(SCHEME_STX_VAL(ii))) { + ii = NULL; + ctx_form = disarmed_form; + } else { + /* "Punch a hole" in the enclosing context by removing the + immediately enclosing module context: */ + fm = disarmed_form; + fm = scheme_revert_use_site_scopes(fm, env); + fm = scheme_stx_unintroduce_from_module_context(fm, env->genv->stx_context); + ctx_form = fm; + fm = SCHEME_STX_CDR(fm); + nm = SCHEME_STX_CAR(fm); + fm = SCHEME_STX_CDR(fm); + ii = SCHEME_STX_CAR(fm); + fm = SCHEME_STX_CDR(fm); + super_phase_shift = scheme_make_integer(0); + orig_ii = ii; } + if (!SCHEME_STXP(fm)) + fm = scheme_datum_to_syntax(fm, scheme_false, scheme_false, 0, 0); + m = MALLOC_ONE_TAGGED(Scheme_Module); m->so.type = scheme_module_type; m->predefined = scheme_starting_up; @@ -7363,7 +7182,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, scheme_false); } else { void **super_bxs_info; - Scheme_Object *rn, *rnss, *rnss2, *rn2; + Scheme_Object *shift; iidx = scheme_make_modidx(scheme_make_pair(submod_symbol, scheme_make_pair(scheme_make_utf8_string(".."), @@ -7373,29 +7192,18 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, super_phase_shift = scheme_bin_minus(scheme_make_integer(0), super_phase_shift); - rn = scheme_stx_phase_shift_as_rename(super_phase_shift, - top_env->module->self_modidx, iidx, - menv->module_registry->exports, - env->insp, NULL); - - rnss2 = scheme_null; - for (rnss = super_bxs->rn_stx; SCHEME_PAIRP(rnss); rnss = SCHEME_CDR(rnss)) { - rn2 = scheme_stx_to_rename(SCHEME_CAR(rnss)); - rn2 = scheme_stx_shift_rename_set(rn2, - top_env->module->self_modidx, iidx, - env->insp); - rnss2 = scheme_make_pair(scheme_rename_to_stx(rn2), rnss2); - } - rnss2 = scheme_reverse(rnss2); + shift = scheme_make_shift(super_phase_shift, + top_env->module->self_modidx, iidx, + menv->module_registry->exports, + m->insp, m->insp); - super_bxs_info = MALLOC_N(void*, 7); + super_bxs_info = MALLOC_N(void*, 6); super_bxs_info[0] = super_bxs; - super_bxs_info[1] = rn; + super_bxs_info[1] = shift; super_bxs_info[2] = top_env->module->self_modidx; super_bxs_info[3] = iidx; super_bxs_info[4] = top_env; super_bxs_info[5] = super_phase_shift; - super_bxs_info[6] = rnss2; m->super_bxs_info = super_bxs_info; } @@ -7427,16 +7235,16 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Hash_Table *oht; oht = m->other_requires; if (!oht) { - oht = scheme_make_hash_table_equal(); + oht = scheme_make_hash_table_eqv(); m->other_requires = oht; } scheme_hash_set(oht, super_phase_shift, ins); } } - scheme_prepare_env_renames(menv, mzMOD_RENAME_NORMAL); + scheme_prepare_env_stx_context(menv); - rn_set = menv->rename_set; + rn_set = menv->stx_context; { Scheme_Object *insp; @@ -7456,41 +7264,43 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, mb_ctx = scheme_false; /* For each provide in iim, add a module rename to fm */ - if (ii) - saw_mb = add_simple_require_renames(NULL, rn_set, NULL, iim, iidx, scheme_make_integer(0), NULL, 1); - else { - if (!skip_strip) { - Scheme_Object *rn; - rn = (Scheme_Object *)m->super_bxs_info[1]; - if (!SCHEME_STXP(fm)) - fm = scheme_datum_to_syntax(fm, scheme_false, scheme_false, 0, 0); - fm = scheme_add_rename(fm, rn); - mb_ctx = scheme_add_rename(disarmed_form, rn); - } else { - if (!SCHEME_STXP(fm)) - fm = scheme_datum_to_syntax(fm, scheme_false, scheme_false, 0, 0); - } - /* there must be a `#%module-begin' in the enclosing module, right? */ + orig_ii = scheme_stx_add_module_context(orig_ii, rn_set); + if (ii) { + saw_mb = add_simple_require_renames(orig_ii, rn_set, menv, NULL, iim, iidx, scheme_make_integer(0), + NULL, 1, 0); + mb_ctx = scheme_datum_to_syntax(scheme_false, scheme_false, orig_ii, 0, 0); + } else { + Scheme_Object *shift; + shift = (Scheme_Object *)m->super_bxs_info[1]; + fm = scheme_stx_add_shift(fm, shift); + mb_ctx = scheme_stx_add_shift(ctx_form, shift); + orig_ii = scheme_stx_add_shift(orig_ii, shift); + shift_back = 1; + /* there must be a `#%module-begin' in the enclosing module; if it's + shadowed, then we want a different error message than the one for + saw_mb == 0 */ saw_mb = 1; } - if (rec[drec].comp) - benv = scheme_new_comp_env(menv, env->insp, SCHEME_MODULE_FRAME); - else - benv = scheme_new_expand_env(menv, env->insp, SCHEME_MODULE_FRAME); + m->ii_src = orig_ii; + + { + Scheme_Object *frame_scopes; + frame_scopes = scheme_module_context_frame_scopes(rn_set, NULL); + if (rec[drec].comp) + benv = scheme_new_comp_env(menv, env->insp, frame_scopes, + SCHEME_MODULE_BEGIN_FRAME | SCHEME_KEEP_SCOPES_FRAME); + else + benv = scheme_new_expand_env(menv, env->insp, frame_scopes, + SCHEME_MODULE_BEGIN_FRAME | SCHEME_KEEP_SCOPES_FRAME); + } /* If fm isn't a single expression, it certainly needs a `#%module-begin': */ if (SCHEME_STX_PAIRP(fm) && SCHEME_STX_NULLP(SCHEME_STX_CDR(fm))) { /* Perhaps expandable... */ fm = SCHEME_STX_CAR(fm); - - /* If the body is `#%plain-module-begin' and if any form is a - `module' form (i.e., already with the `module' binding, then - attach the original form as a property to the `module' form, so - that re-expansion can use it instead of dropping all lexical - context: */ - fm = scheme_annotate_existing_submodules(fm, 1); + check_not_tainted(fm); } else { fm = scheme_make_pair(scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 2), fm); @@ -7507,35 +7317,24 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, this_empty_self_modidx = scheme_get_submodule_empty_self_modidx(submodule_path); - if (ii) { - /* phase shift to replace self_modidx of previous expansion (if any): */ - fm = scheme_stx_phase_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, m->insp, NULL); + /* phase shift to replace self_modidx of previous expansion: */ + fm = scheme_stx_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, + m->insp, m->insp); - fm = scheme_add_rename(fm, rn_set); - } else { - if (skip_strip) { - /* phase shift to replace self_modidx of previous expansion: */ - fm = scheme_stx_phase_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, m->insp, NULL); - } - } + fm = scheme_stx_add_module_frame_context(fm, rn_set); SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm); if (!check_mb) { - - fm = scheme_check_immediate_macro(fm, benv, rec, drec, 0, &mbval, NULL, NULL, 1); + fm = scheme_check_immediate_macro(fm, benv, rec, drec, &mbval, 1); /* If expansion is not the primitive `#%module-begin', add local one: */ if (!SAME_OBJ(mbval, modbeg_syntax)) { Scheme_Object *mb; mb = scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 0); fm = scheme_make_pair(mb, scheme_make_pair(fm, scheme_null)); - fm = scheme_datum_to_syntax(fm, form, disarmed_form, 0, 2); + fm = scheme_datum_to_syntax(fm, form, mb_ctx, 0, 2); fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp)); - if (ii) { - /* Since fm is a newly-created syntax object, we need to re-add renamings: */ - fm = scheme_add_rename(fm, rn_set); - } SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, fm); @@ -7580,9 +7379,15 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, fm = (Scheme_Object *)m; } else { Scheme_Object *hints, *formname, *ps; + Scheme_Object *shift; fm = scheme_expand_expr(fm, benv, rec, drec); + if (shift_back) { + shift = (Scheme_Object *)m->super_bxs_info[5]; + fm = scheme_stx_add_shift(fm, scheme_bin_minus(scheme_make_integer(0), shift)); + } + m->ii_src = NULL; m->super_bxs_info = NULL; @@ -7592,9 +7397,10 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, formname = SCHEME_STX_CAR(disarmed_form); fm = cons(formname, cons(nm, - cons(orig_ii, cons(fm, scheme_null)))); + cons(orig_ii, + cons(fm, scheme_null)))); - fm = scheme_datum_to_syntax(fm, form, form, 0, 2); + fm = scheme_datum_to_syntax(fm, form, ctx_form, 0, 2); if (hints) { fm = scheme_stx_property(fm, @@ -7628,12 +7434,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, } /* for future expansion, shift away from self_modidx: */ - ps = scheme_stx_phase_shift_as_rename(NULL, self_modidx, this_empty_self_modidx, - NULL, NULL, scheme_rename_set_identity(rn_set)); - if (m->pre_submodules) /* non-NULL => some submodules, even if it's '() */ - fm = phase_shift_skip_submodules(fm, ps, -1); - else - fm = scheme_add_rename(fm, ps); + ps = scheme_make_shift(NULL, self_modidx, this_empty_self_modidx, NULL, NULL, NULL); + fm = scheme_stx_add_shift(fm, ps); /* make self_modidx like the empty modidx */ if (SAME_OBJ(this_empty_self_modidx, empty_self_modidx)) @@ -7644,8 +7446,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, if (rec[drec].comp || (rec[drec].depth != -2)) { /* rename tables no longer needed; NULL them out */ - menv->rename_set = NULL; - menv->post_ex_rename_set = NULL; + menv->stx_context = NULL; } m->submodule_ancestry = NULL; /* ancestry no longer needed; NULL to avoid leak */ @@ -7689,9 +7490,9 @@ Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *e Scheme_Comp_Env *rhs_env; Scheme_Dynamic_State dyn_state; - rhs_env = scheme_new_comp_env(env, NULL, SCHEME_TOPLEVEL_FRAME); + rhs_env = scheme_new_comp_env(env, NULL, NULL, SCHEME_TOPLEVEL_FRAME); - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, + scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, NULL, scheme_false, env, (env->link_midx ? env->link_midx : (env->module @@ -7701,21 +7502,69 @@ Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *e return scheme_apply_multi_with_dynamic_state(proc, 0, NULL, &dyn_state); } +Scheme_Object *scheme_prune_bindings_table(Scheme_Object *binding_names, Scheme_Object *rn_stx, Scheme_Object *phase) +{ + int dropped = 0; + intptr_t i; + Scheme_Object *k, *val, *base_stx; + Scheme_Hash_Tree *ht; + + ht = scheme_make_hash_tree(0); + + base_stx = scheme_stx_add_module_context(scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0), + scheme_module_context_at_phase(scheme_stx_to_module_context(rn_stx), + phase)); + + if (SCHEME_HASHTRP(binding_names)) { + Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)binding_names; + 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_stx_could_bind(val, + scheme_datum_to_syntax(k, scheme_false, base_stx, 0, 0), + phase)) { + dropped = 1; + val = scheme_true; + } + ht = scheme_hash_tree_set(ht, k, val); + } + } else { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)binding_names; + for (i = t->size; i--; ) { + if (t->vals[i]) { + k = t->keys[i]; + val = t->vals[i]; + if (!scheme_stx_could_bind(val, + scheme_datum_to_syntax(k, scheme_false, base_stx, 0, 0), + phase)) { + dropped = 1; + val = scheme_true; + } + ht = scheme_hash_tree_set(ht, k, val); + } + } + } + + if (dropped) + return (Scheme_Object *)ht; + else + return binding_names; +} + /**********************************************************************/ /* #%module-begin */ /**********************************************************************/ -static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, +static void check_require_name(Scheme_Object *id, Scheme_Object *self_modidx, Scheme_Object *nominal_modidx, Scheme_Object *nominal_name, Scheme_Object *modidx, Scheme_Object *exname, int exet, int isval, void *tables, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *mark_src, + Scheme_Object *err_src, Scheme_Object *scope_src, Scheme_Object *phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase) { Scheme_Bucket_Table *toplevel, *syntax; Scheme_Hash_Table *required; - Scheme_Object *vec, *nml, *tvec; + Scheme_Object *vec, *nml, *tvec, *binding; tvec = scheme_hash_get((Scheme_Hash_Table *)tables, phase); if (!tvec) { @@ -7728,25 +7577,73 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, syntax = (Scheme_Bucket_Table *)(SCHEME_VEC_ELS(tvec)[2]); } - /* Check that it's not yet defined: */ - if (toplevel) { - if (scheme_lookup_in_table(toplevel, (const char *)name)) { - scheme_wrong_syntax("module", prnt_name, form, "imported identifier already defined"); + if (!scheme_hash_get(required, SCHEME_STX_VAL(id))) { + /* no mapping so far means that we haven't imported anything + with this name so far, and we'll be able to use a symbol a + sumbol as a key; see require_binding_to_key() */ + binding = SCHEME_STX_VAL(id); + } else { + /* Look for import collisions by checking whether `id` has a binding; + if so, then check whether that binding matches an import that + we have already. If it has a binding and it's not the same binding, + then it's an import conflict. If it's the same bindig, we keep + track of all the imports of the binding. */ + binding = scheme_stx_lookup_exact(id, phase); + if (SCHEME_FALSEP(binding)) { + /* not defined */ + binding = NULL; + } else { + if (!SCHEME_VECTORP(binding) + || (SCHEME_VECTORP(binding) + && self_modidx + && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], self_modidx))) { + scheme_wrong_syntax("module", id, form, "imported identifier already defined"); + return; + } else if (SCHEME_VECTORP(binding) + && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], exname) + && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], scheme_make_integer(exet)) + && same_resolved_modidx(SCHEME_VEC_ELS(binding)[0], modidx)) { + /* import is redundant, but may add new nominal info */ + binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); + } else { + binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); + if (scheme_hash_get(required, binding)) { + /* use error report below */ + } else { + /* identifier has a binding in some context, but not within the current module */ + binding = NULL; + } + } + } + + if (!binding) { + if (!scheme_hash_get(required, SCHEME_STX_VAL(id))) { + /* we can just use a symbol as a key, since it's not mapped + so far */ + binding = SCHEME_STX_VAL(id); + } else { + /* generate a binding vector: */ + binding = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(binding)[0] = modidx; + SCHEME_VEC_ELS(binding)[1] = exname; + SCHEME_VEC_ELS(binding)[2] = scheme_make_integer(exet); + /* convert to a general key: */ + binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); + } } } if (!SAME_OBJ(src_phase_index, scheme_make_integer(0)) || !SAME_OBJ(nominal_export_phase, scheme_make_integer(0)) - || !SAME_OBJ(nominal_name, prnt_name)) { + || !SAME_OBJ(nominal_name, SCHEME_STX_VAL(id))) { nominal_modidx = scheme_make_pair(nominal_modidx, scheme_make_pair(src_phase_index, scheme_make_pair(nominal_name, scheme_make_pair(nominal_export_phase, scheme_null)))); } - - /* Check not required, or required from same module: */ - vec = scheme_hash_get(required, name); + + vec = scheme_hash_get(required, binding); if (vec) { Scheme_Object *srcs; char *fromsrc = NULL, *fromsrc_colon = "", *phase_expl; @@ -7758,12 +7655,23 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, and also add source phase for re-provides. */ nml = scheme_make_pair(nominal_modidx, SCHEME_VEC_ELS(vec)[0]); SCHEME_VEC_ELS(vec)[0] = nml; - SCHEME_VEC_ELS(vec)[7] = scheme_false; + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7]) + && prep_required_id(vec) + && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, phase)) + SCHEME_VEC_ELS(vec)[7] = scheme_false; return; } - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) { - /* can override */ + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7]) + && prep_required_id(vec) + && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, phase)) { + /* can override; construct overriding `binding` */ + binding = scheme_make_vector(4, NULL); + vec = scheme_module_resolve(modidx, 0); + SCHEME_VEC_ELS(binding)[0] = vec; + SCHEME_VEC_ELS(binding)[1] = exname; + SCHEME_VEC_ELS(binding)[2] = scheme_make_integer(exet); + SCHEME_VEC_ELS(binding)[3] = SCHEME_STX_VAL(id); } else { /* error: already imported */ srcs = scheme_null; @@ -7797,19 +7705,12 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, phase_expl = scheme_strdup(buf); } - scheme_wrong_syntax_with_more_sources("module", prnt_name, err_src, srcs, + scheme_wrong_syntax_with_more_sources("module", id, err_src, srcs, "identifier already imported%s from%s %t", phase_expl, fromsrc_colon, fromsrc, fromsrclen); } } - - /* Check not syntax: */ - if (syntax) { - if (scheme_lookup_in_table(syntax, (const char *)name)) { - scheme_wrong_syntax("module", prnt_name, form, "imported identifier already defined"); - } - } /* Remember require: */ vec = scheme_make_vector(9, NULL); @@ -7818,25 +7719,32 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, SCHEME_VEC_ELS(vec)[1] = modidx; SCHEME_VEC_ELS(vec)[2] = exname; SCHEME_VEC_ELS(vec)[3] = (isval ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[4] = prnt_name; + SCHEME_VEC_ELS(vec)[4] = SCHEME_STX_VAL(id); SCHEME_VEC_ELS(vec)[5] = (err_src ? err_src : scheme_false); - SCHEME_VEC_ELS(vec)[6] = (mark_src ? mark_src : scheme_false); + SCHEME_VEC_ELS(vec)[6] = id; SCHEME_VEC_ELS(vec)[7] = scheme_false; SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(exet); - scheme_hash_set(required, name, vec); + + scheme_hash_set(required, binding, vec); } -static int check_already_required(Scheme_Hash_Table *required, Scheme_Object *name) +static int check_already_required(Scheme_Hash_Table *required, + Scheme_Object *id, int phase, + Scheme_Object *binding) { Scheme_Object *vec; - vec = scheme_hash_get(required, name); + binding = require_binding_to_key(required, binding, SCHEME_STX_VAL(id)); + + vec = scheme_hash_get(required, binding); if (vec) { - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) { - scheme_hash_set(required, name, NULL); - return 0; + if (prep_required_id(vec) + && scheme_stx_bound_eq(SCHEME_VEC_ELS(vec)[6], id, scheme_make_integer(phase))) { + scheme_hash_set(required, binding, NULL); + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) + return 0; + return 1; } - return 1; } return 0; @@ -7850,6 +7758,12 @@ static void warn_previously_required(Scheme_Object *modname, Scheme_Object *name modname); } +static int check_already_defined(Scheme_Object *name, Scheme_Env *genv) +{ + return (scheme_lookup_in_table(genv->toplevel, (const char *)name) + || scheme_lookup_in_table(genv->syntax, (const char *)name)); +} + static void propagate_imports(Module_Begin_Expand_State *bxs, Module_Begin_Expand_State *super_bxs, Scheme_Object *rn, @@ -7858,10 +7772,12 @@ static void propagate_imports(Module_Begin_Expand_State *bxs, Scheme_Env *super_genv, Scheme_Env *genv, Scheme_Object *phase_shift) +/* Record imports from the enclosing module as imports here, + and record definitions from the enclosing module as imports here. */ { Scheme_Hash_Table *ht, *required, *super_required; - Scheme_Object *phase, *super_name, *name, *super_vec, *vec; - Scheme_Object *l, *v, *super_defs, *key, *val; + Scheme_Object *phase, *super_key, *name, *super_vec, *vec; + Scheme_Object *l, *v, *super_defs, *key, *val, *binding; int i, j; Scheme_Env *super_def_genv, *def_genv; @@ -7878,40 +7794,45 @@ static void propagate_imports(Module_Begin_Expand_State *bxs, for (j = super_required->size; j--; ) { if (super_required->vals[j]) { - super_name = super_required->keys[j]; + super_key = super_required->keys[j]; super_vec = super_required->vals[j]; - name = super_name; + if (SCHEME_TRUEP(super_vec)) { + vec = scheme_make_vector(9, NULL); - vec = scheme_make_vector(9, NULL); - - l = SCHEME_VEC_ELS(super_vec)[0]; - v = scheme_null; - while (!SCHEME_NULLP(l)) { - v = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(l), from_idx, to_idx), - v); - l = SCHEME_CDR(l); - } - v = scheme_reverse(v); - SCHEME_VEC_ELS(vec)[0] = v; + l = SCHEME_VEC_ELS(super_vec)[0]; + v = scheme_null; + while (!SCHEME_NULLP(l)) { + v = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(l), from_idx, to_idx), + v); + l = SCHEME_CDR(l); + } + v = scheme_reverse(v); + SCHEME_VEC_ELS(vec)[0] = v; - v = scheme_modidx_shift(SCHEME_VEC_ELS(super_vec)[1], from_idx, to_idx); - SCHEME_VEC_ELS(vec)[1] = v; + v = scheme_modidx_shift(SCHEME_VEC_ELS(super_vec)[1], from_idx, to_idx); + SCHEME_VEC_ELS(vec)[1] = v; - SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(super_vec)[2]; - SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(super_vec)[3]; - SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(super_vec)[4]; - SCHEME_VEC_ELS(vec)[5] = SCHEME_VEC_ELS(super_vec)[5]; + SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(super_vec)[2]; + SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(super_vec)[3]; + SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(super_vec)[4]; + SCHEME_VEC_ELS(vec)[5] = SCHEME_VEC_ELS(super_vec)[5]; - v = SCHEME_VEC_ELS(super_vec)[6]; - if (SCHEME_TRUEP(v)) - v = scheme_add_rename(v, rn); - SCHEME_VEC_ELS(vec)[6] = v; + if (!SAME_OBJ(phase_shift, scheme_make_integer(0))) + prep_required_id(super_vec); - SCHEME_VEC_ELS(vec)[7] = scheme_true; /* can be shadowed */ - SCHEME_VEC_ELS(vec)[8] = SCHEME_VEC_ELS(super_vec)[8]; + v = SCHEME_VEC_ELS(super_vec)[6]; + if (SCHEME_TRUEP(v) && !SAME_OBJ(phase_shift, scheme_make_integer(0))) + v = scheme_stx_add_shift(v, phase_shift); + SCHEME_VEC_ELS(vec)[6] = v; - scheme_hash_set(required, name, vec); + SCHEME_VEC_ELS(vec)[7] = scheme_true; /* can be shadowed */ + + SCHEME_VEC_ELS(vec)[8] = SCHEME_VEC_ELS(super_vec)[8]; + } else + vec = scheme_false; + + scheme_hash_set(required, super_key, vec); } } } @@ -7940,7 +7861,12 @@ static void propagate_imports(Module_Begin_Expand_State *bxs, v = scheme_make_pair(to_idx, scheme_null); SCHEME_VEC_ELS(vec)[0] = v; SCHEME_VEC_ELS(vec)[1] = to_idx; - v = scheme_tl_id_sym(super_def_genv, name, NULL, 2, NULL, NULL); + binding = scheme_stx_lookup_stop_at_free_eq(name, phase, NULL); + if (!SCHEME_VECTORP(binding) + || !SAME_OBJ(phase, SCHEME_VEC_ELS(binding)[2])) + scheme_signal_error("internal error: broken binding of defined id from encloding module: %V at %V = %V", + name, phase, binding); + v = SCHEME_VEC_ELS(binding)[1]; SCHEME_VEC_ELS(vec)[2] = v; if (scheme_lookup_in_table(super_def_genv->toplevel, (char *)v)) SCHEME_VEC_ELS(vec)[3] = scheme_true; @@ -7948,24 +7874,30 @@ static void propagate_imports(Module_Begin_Expand_State *bxs, SCHEME_VEC_ELS(vec)[3] = scheme_false; SCHEME_VEC_ELS(vec)[4] = SCHEME_STX_VAL(name); SCHEME_VEC_ELS(vec)[5] = name; - name = scheme_add_rename(name, rn); + if (!SAME_OBJ(phase_shift, scheme_make_integer(0))) + name = scheme_stx_add_shift(name, phase_shift); SCHEME_VEC_ELS(vec)[6] = name; SCHEME_VEC_ELS(vec)[7] = scheme_true; /* can be shadowed */ SCHEME_VEC_ELS(vec)[8] = phase; - v = scheme_tl_id_sym(def_genv, name, NULL, 2, NULL, NULL); + v = require_binding_to_key(required, binding, SCHEME_STX_VAL(name)); scheme_hash_set(required, v, vec); } } } } -Scheme_Object *reverse_and_add_rename(Scheme_Object *fm, Scheme_Object *post_ex_rn) +Scheme_Object *introduce_to_module_context(Scheme_Object *a, Scheme_Object *rn) +{ + return scheme_stx_introduce_to_module_context(a, rn); +} + +Scheme_Object *reverse_and_introduce_module_context(Scheme_Object *fm, Scheme_Object *rn) { Scheme_Object *l2 = scheme_null; while (!SCHEME_NULLP(fm)) { - l2 = scheme_make_pair(scheme_add_rename(SCHEME_CAR(fm), post_ex_rn), + l2 = scheme_make_pair(introduce_to_module_context(SCHEME_CAR(fm), rn), l2); fm = SCHEME_CDR(fm); } @@ -7974,12 +7906,8 @@ Scheme_Object *reverse_and_add_rename(Scheme_Object *fm, Scheme_Object *post_ex_ static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv) { - return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2, NULL, NULL); -} - -static Scheme_Object *add_a_rename(Scheme_Object *fm, Scheme_Object *post_ex_rn) -{ - return scheme_add_rename(fm, post_ex_rn); + name = scheme_stx_lookup_exact(name, scheme_env_phase((Scheme_Env *)_genv)); + return SCHEME_VEC_ELS(name)[1]; } static Scheme_Object *add_req(Scheme_Object *imods, Scheme_Object *requires) @@ -8009,24 +7937,21 @@ static Scheme_Object *add_req(Scheme_Object *imods, Scheme_Object *requires) static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *_env) { Scheme_Comp_Env *env; - Scheme_Object *self_modidx, *rn, *name, *ids, *id, *new_ids = scheme_null; + Scheme_Object *rn, *name, *ids, *id, *new_ids = scheme_null; env = (Scheme_Comp_Env *)SCHEME_VEC_ELS(data)[0]; - self_modidx = SCHEME_VEC_ELS(data)[1]; rn = SCHEME_VEC_ELS(data)[2]; for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { id = SCHEME_CAR(ids); - name = scheme_tl_id_sym(env->genv, id, scheme_false, 2, NULL, NULL); + id = introduce_to_module_context(id, rn); + + name = scheme_global_binding(id, env->genv); /* Create the bucket, indicating that the name will be defined: */ scheme_add_global_symbol(name, scheme_undefined, env->genv); - - /* Add a renaming: */ - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); - id = scheme_add_rename(id, rn); new_ids = cons(id, new_ids); } @@ -8096,60 +8021,61 @@ static Scheme_Object *shift_require_phase(Scheme_Object *e, Scheme_Object *phase scheme_make_pair(phase, l)); } -static Scheme_Object *make_require_form(Scheme_Object *module_path, - intptr_t abs_phase, intptr_t rel_phase, - Scheme_Object *mark) +static Scheme_Object *make_require_form(Scheme_Object *module_path, intptr_t rel_phase, + Scheme_Object *scope, intptr_t scope_phase) { Scheme_Object *e = module_path, *r; if (rel_phase != 0) { e = shift_require_phase(e, scheme_make_integer(rel_phase), 1); } - if (abs_phase == 0) + if (scope_phase == 0) r = require_stx; else { r = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, - scheme_sys_wraps_phase_worker(abs_phase), + sys_wraps_phase(scope_phase), 0, 0); } e = scheme_make_pair(r, scheme_make_pair(e, scheme_null)); e = scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0); - e = scheme_add_remove_mark(e, mark); + e = scheme_stx_add_scope(e, scope, scheme_make_integer(scope_phase)); return e; } Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, intptr_t phase, - Scheme_Object *mark, + Scheme_Object *scope, void *data, - Scheme_Object **_ref_expr) + Scheme_Object **_ref_expr, + Scheme_Comp_Env *cenv) { Scheme_Object *e; Scheme_Object *base_modidx = (Scheme_Object *)((void **)data)[1]; Scheme_Env *env = (Scheme_Env *)((void **)data)[2]; Scheme_Module *for_m = (Scheme_Module *)((void **)data)[3]; Scheme_Object *rns = (Scheme_Object *)((void **)data)[4]; - Scheme_Object *post_ex_rns = (Scheme_Object *)((void **)data)[5]; void *tables = ((void **)data)[6]; Scheme_Object *redef_modname = (Scheme_Object *)((void **)data)[7]; int *all_simple = (int *)((void **)data)[8]; Scheme_Hash_Table *submodule_names = (Scheme_Hash_Table *)((void **)data)[9]; if (*_ref_expr) { - e = scheme_add_rename(*_ref_expr, post_ex_rns); + e = introduce_to_module_context(*_ref_expr, rns); *_ref_expr = e; } - e = make_require_form(module_path, env->phase, phase - env->phase, mark); + e = make_require_form(module_path, phase - env->phase, scope, env->phase); + e = scheme_revert_use_site_scopes(e, cenv); + e = introduce_to_module_context(e, rns); parse_requires(e, env->phase, base_modidx, env, for_m, - rns, post_ex_rns, + rns, check_require_name, tables, redef_modname, - 0, 0, 1, + 0, 1, phase ? 1 : 0, all_simple, NULL, @@ -8168,7 +8094,7 @@ Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, static Scheme_Object *package_require_data(Scheme_Object *base_modidx, Scheme_Env *env, Scheme_Module *for_m, - Scheme_Object *rns, Scheme_Object *post_ex_rns, + Scheme_Object *rns, void *data, Scheme_Object *redef_modname, int *all_simple, @@ -8182,7 +8108,7 @@ static Scheme_Object *package_require_data(Scheme_Object *base_modidx, vals[2] = env; vals[3] = for_m; vals[4] = rns; - vals[5] = post_ex_rns; + vals[5] = NULL; /* removed argument */ vals[6] = data; vals[7] = redef_modname; vals[8] = all_simple; @@ -8205,25 +8131,26 @@ static void flush_definitions(Scheme_Env *genv) t->with_home = 1; genv->toplevel = t; } + + genv->binding_names = NULL; } static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec) { - int num_phases, *_num_phases, i, exicount, *all_simple_renames, has_submodules; + int num_phases, *_num_phases, i, exicount, *all_simple_bindings, has_submodules; Scheme_Hash_Tree *all_defs; Scheme_Hash_Table *tables, *all_defs_out, *all_provided, *all_reprovided, *modidx_cache; Scheme_Module_Export_Info **exp_infos, *exp_info; Scheme_Module_Phase_Exports *pt; - Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */ - Scheme_Object *form, *redef_modname, *rn_set, *observer, **exis, *body_lists, *expanded_l, *rn_stx; + Scheme_Object *form, *redef_modname, *rn_set, *observer, **exis, *body_lists, *expanded_l; Scheme_Env *genv; Module_Begin_Expand_State *bxs; Scheme_Expand_Info crec; form = scheme_stx_taint_disarm(orig_form, NULL); - if (!(env->flags & SCHEME_MODULE_FRAME)) + if (!(env->flags & SCHEME_MODULE_BEGIN_FRAME)) scheme_wrong_syntax(NULL, NULL, form, "illegal use (not a module body)"); if (scheme_stx_proper_list_length(form) < 0) @@ -8241,17 +8168,23 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env modidx_cache = scheme_make_hash_table_equal(); - all_provided = scheme_make_hash_table_equal(); - all_reprovided = scheme_make_hash_table_equal(); - all_defs = scheme_make_hash_tree(1); - all_defs_out = scheme_make_hash_table_equal(); + all_provided = scheme_make_hash_table_eqv(); + all_reprovided = scheme_make_hash_table_eqv(); + all_defs = scheme_make_hash_tree(2); + all_defs_out = scheme_make_hash_table_eqv(); - rn_set = env->genv->rename_set; - post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set, env->genv->access_insp); + rn_set = env->genv->stx_context; + + /* For `module->namespace`: */ + { + Scheme_Object *rn_stx; + rn_stx = scheme_module_context_to_stx(rn_set, env->genv->module->ii_src); + env->genv->module->rn_stx = rn_stx; + } /* It's possible that #%module-begin expansion introduces - marked identifiers for definitions. */ - form = scheme_add_rename(form, post_ex_rn_set); + scoped identifiers for definitions. */ + form = introduce_to_module_context(form, rn_set); observer = rec[drec].observer; SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form); @@ -8259,33 +8192,20 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env _num_phases = MALLOC_ONE_ATOMIC(int); *_num_phases = 0; - all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int)); - *all_simple_renames = 1; + all_simple_bindings = (int *)scheme_malloc_atomic(sizeof(int)); + *all_simple_bindings = 1; if (env->genv->module->super_bxs_info) { - rn_stx = scheme_rename_to_stx(post_ex_rn_set); - *all_simple_renames = 0; - } else - rn_stx = scheme_rename_to_stx(rn_set); - if (env->genv->module->super_bxs_info && env->genv->module->super_bxs_info[6]) - rn_stx = scheme_make_pair(rn_stx, env->genv->module->super_bxs_info[6]); - { - Scheme_Object *v; - if (SCHEME_PAIRP(rn_stx)) - v = scheme_list_to_vector(rn_stx); - else - v = rn_stx; - env->genv->module->rn_stx = v; + *all_simple_bindings = 0; } bxs = scheme_malloc(sizeof(Module_Begin_Expand_State)); - bxs->post_ex_rn_set = post_ex_rn_set; bxs->tables = tables; bxs->all_provided = all_provided; bxs->all_reprovided = all_reprovided; bxs->all_defs = all_defs; bxs->all_defs_out = all_defs_out; - bxs->all_simple_renames = all_simple_renames; + bxs->all_simple_bindings = all_simple_bindings; bxs->_num_phases = _num_phases; bxs->saved_provides = scheme_null; bxs->saved_submodules = scheme_null; @@ -8313,6 +8233,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env crec.comp = 1; crec.dont_mark_local_use = 0; crec.resolve_module_ids = 0; + crec.substitute_bindings = 1; crec.value_name = scheme_false; crec.observer = NULL; crec.pre_unwrapped = 0; @@ -8367,7 +8288,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env env->genv, form, num_phases, exp_infos); - + /* Compute indirect provides (which is everything at the top-level): */ genv = env->genv; for (i = 0; i < num_phases; i++) { @@ -8486,7 +8407,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env env->genv->module->exp_infos = exp_infos; - if (!*all_simple_renames) { + if (!*all_simple_bindings) { /* No need to keep indirect syntax provides */ for (i = 0; i < num_phases; i++) { exp_infos[i]->indirect_syntax_provides = NULL; @@ -8494,8 +8415,23 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env } } - if (*all_simple_renames) { + if (*all_simple_bindings && env->genv->module->rn_stx) { + /* We will be able to reconstruct binding for `module->namespace`: */ env->genv->module->rn_stx = scheme_true; + } else { + Scheme_Env *bnenv = env->genv; + env->genv->module->binding_names = bnenv->binding_names; + if (bnenv->exp_env) { + bnenv = bnenv->exp_env; + env->genv->module->et_binding_names = bnenv->binding_names; + for (bnenv = bnenv->exp_env; bnenv; bnenv = bnenv->exp_env) { + add_binding_names_from_environment(env->genv->module, bnenv); + } + bnenv = env->genv; + } + for (bnenv = bnenv->template_env; bnenv; bnenv = bnenv->template_env) { + add_binding_names_from_environment(env->genv->module, bnenv); + } } } @@ -8539,7 +8475,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env scheme_optimize_info_never_inline(oi); o = scheme_optimize_expr(o, oi, 0); - rp = scheme_resolve_prefix(0, env->prefix, 1); + rp = scheme_resolve_prefix(0, env->prefix, env->insp); ri = scheme_resolve_info_create(rp); scheme_resolve_info_enforce_const(ri, rec[drec].comp_flags & COMP_ENFORCE_CONSTS); @@ -8555,10 +8491,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env (void)do_module_execute(o, env->genv, 0, 1, root_module_name, NULL); } - if (!SCHEME_PAIRP(rn_stx)) - rn_stx = scheme_make_pair(rn_stx, scheme_null); - bxs->rn_stx = rn_stx; - if (!rec[drec].comp && (is_modulestar_stop(env))) { Scheme_Object *l = bxs->saved_submodules; expanded_modules = NULL; @@ -8632,6 +8564,13 @@ static Scheme_Object *get_higher_phase_lifts(Module_Begin_Expand_State *bxs, return fm; } +static Scheme_Object *revert_use_site_scopes_via_context(Scheme_Object *o, Scheme_Object *rn_set, intptr_t phase) +{ + return scheme_stx_adjust_module_use_site_context(o, + rn_set, + SCHEME_STX_REMOVE); +} + static Scheme_Object *do_module_begin_k(void) { Scheme_Thread *p = scheme_current_thread; @@ -8650,7 +8589,6 @@ static Scheme_Object *do_module_begin_k(void) phase, body_lists, bxs); } - static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Compile_Expand_Info *erec, int derec, @@ -8663,7 +8601,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ If both rec[drec].comp && erec, cons results. If !rec[drec].comp, then erec is non-NULL. */ { - Scheme_Object *fm, *first, *last, *p, *rn_set, *rn, *exp_body, *self_modidx, *prev_p; + Scheme_Object *fm, *first, *last, *p, *rn_set, *exp_body, *self_modidx, *prev_p; Scheme_Object *expanded_l; Scheme_Comp_Env *xenv, *cenv, *rhs_env; Scheme_Hash_Table *required; /* name -> (vector nominal-modidx-list modidx srcname var? prntname) @@ -8672,11 +8610,11 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ Scheme_Object *all_rt_defs; /* list of stxid; this is almost redundant to the syntax and toplevel tables, but it preserves the original name for exporting */ Scheme_Hash_Tree *adt; - Scheme_Object *post_ex_rn; /* renames for ids introduced by expansion */ Scheme_Object *lift_data; Scheme_Object *lift_ctx; Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null; int maybe_has_lifts = 0, expand_ends = (phase == 0), non_phaseless, requested_phaseless; + int requested_empty_namespace; Scheme_Object *observer, *vec, *end_statements; Scheme_Object *begin_for_syntax_stx, *non_phaseless_form = NULL; const char *who = "module"; @@ -8734,13 +8672,15 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ non_phaseless = (env->genv->module->phaseless ? 0 : NON_PHASELESS_IMPORT); requested_phaseless = 0; + requested_empty_namespace = 0; env->genv->module->phaseless = NULL; /* Expand each expression in form up to `begin', `define-values', `define-syntax', `require', `provide', `#%app', etc. */ - xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_MODULE_BEGIN_FRAME - | SCHEME_FOR_STOPS), + xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME + | SCHEME_MODULE_FRAME + | SCHEME_FOR_STOPS), + NULL, env); install_stops(xenv, phase, &begin_for_syntax_stx); @@ -8748,13 +8688,12 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ first = scheme_null; last = NULL; - rn_set = env->genv->rename_set; - rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(phase), 1); + rn_set = env->genv->stx_context; vec = get_table(bxs->tables, scheme_make_integer(phase)); - if (!SCHEME_VEC_ELS(vec)[0]) + if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[0])) SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel; - if (!SCHEME_VEC_ELS(vec)[2]) + if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[2])) SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax; required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1]; @@ -8762,7 +8701,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ /* Put initial requires into the table: (This is redundant for the rename set, but we need to fill the `all_requires' table, etc.) */ - if (env->genv->module->ii_src) { + if (env->genv->module->ii_src && SCHEME_TRUEP(SCHEME_STX_VAL(env->genv->module->ii_src))) { Scheme_Module *iim; Scheme_Object *nmidx, *orig_src; @@ -8776,10 +8715,10 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ nmidx = SCHEME_CAR(env->genv->module->requires); iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL); - add_simple_require_renames(orig_src, rn_set, bxs->tables, + add_simple_require_renames(orig_src, rn_set, env->genv, bxs->tables, iim, nmidx, scheme_make_integer(0), - NULL, 1); + NULL, 1, 1); scheme_hash_set(bxs->modidx_cache, ((Scheme_Modidx *)nmidx)->path, nmidx); } @@ -8803,11 +8742,8 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ self_modidx = env->genv->module->self_modidx; - post_ex_rn = scheme_get_module_rename_from_set(bxs->post_ex_rn_set, scheme_make_integer(phase), 1); - env->genv->post_ex_rename_set = bxs->post_ex_rn_set; - /* For syntax-local-context, etc., in a d-s RHS: */ - rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); + rhs_env = scheme_new_comp_env(env->genv, env->insp, NULL, SCHEME_TOPLEVEL_FRAME); if (erec) { observer = erec[derec].observer; @@ -8819,10 +8755,10 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ lift_ctx = scheme_generate_lifts_key(); req_data = package_require_data(self_modidx, env->genv, env->genv->module, - rn_set, bxs->post_ex_rn_set, + rn_set, bxs->tables, bxs->redef_modname, - bxs->all_simple_renames, + bxs->all_simple_bindings, bxs->submodule_names); if (SCHEME_PAIRP(bxs->end_statementss)) { @@ -8850,7 +8786,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ ? scheme_frame_get_end_statement_lifts(xenv) : end_statements); prev_p = (maybe_has_lifts - ? scheme_frame_get_provide_lifts(xenv) + ? scheme_frame_get_provide_lifts(xenv) : scheme_null); scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p, lift_ctx, req_data, prev_p); @@ -8863,9 +8799,10 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ erec1.value_name = scheme_false; erec1.observer = observer; erec1.pre_unwrapped = 0; + erec1.substitute_bindings = 1; erec1.env_already = 0; erec1.comp_flags = rec[drec].comp_flags; - e = scheme_expand_expr(e, xenv, &erec1, 0); + e = scheme_expand_expr(e, xenv, &erec1, 0); } lifted_reqs = scheme_frame_get_require_lifts(xenv); @@ -8882,10 +8819,10 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ if (!SCHEME_NULLP(fst)) { /* Expansion lifted expressions, so add them to the front and try again. */ - *bxs->all_simple_renames = 0; + *bxs->all_simple_bindings = 0; fm = SCHEME_STX_CDR(fm); - e = scheme_add_rename(e, bxs->post_ex_rn_set); - fm = scheme_named_map_1(NULL, add_a_rename, fm, bxs->post_ex_rn_set); + e = introduce_to_module_context(e, rn_set); + fm = scheme_named_map_1(NULL, introduce_to_module_context, fm, rn_set); fm = scheme_make_pair(e, fm); SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm); fm = scheme_append(fst, fm); @@ -8897,9 +8834,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ else fst = NULL; - if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_module_eq_x(scheme_begin_stx, fst, phase)) { + if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_free_eq_x(scheme_begin_stx, fst, phase)) { fm = SCHEME_STX_CDR(fm); - e = scheme_add_rename(e, bxs->post_ex_rn_set); + e = introduce_to_module_context(e, rn_set); SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); fm = scheme_flatten_begin(e, fm); SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm); @@ -8908,7 +8845,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ e = scheme_reverse(e); if (expand_ends) { fm = scheme_frame_get_end_statement_lifts(xenv); - fm = reverse_and_add_rename(fm, post_ex_rn); + fm = reverse_and_introduce_module_context(fm, rn_set); if (!SCHEME_NULLP(e)) fm = scheme_append(fm, e); maybe_has_lifts = 0; @@ -8928,17 +8865,17 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ } if (!e) break; /* (begin) expansion at end */ - e = scheme_add_rename(e, bxs->post_ex_rn_set); + e = introduce_to_module_context(e, rn_set); SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); - + if (SCHEME_STX_PAIRP(e)) { Scheme_Object *fst; fst = SCHEME_STX_CAR(e); if (SCHEME_STX_SYMBOLP(fst)) { - if (scheme_stx_module_eq_x(scheme_define_values_stx, fst, phase)) { + if (scheme_stx_free_eq_x(scheme_define_values_stx, fst, phase)) { /************ define-values *************/ Scheme_Object *vars, *val; int var_count = 0; @@ -8946,11 +8883,11 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer); - /* Create top-level vars */ - scheme_define_parse(e, &vars, &val, 0, env, 1); + /* Create top-level vars; uses revert_use_site_scopes() on the vars */ + scheme_define_parse(e, &vars, &val, 0, xenv, 1); while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *name, *orig_name; + Scheme_Object *name, *orig_name, *binding; name = SCHEME_STX_CAR(vars); @@ -8958,34 +8895,30 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ /* Remember the original: */ all_rt_defs = scheme_make_pair(name, all_rt_defs); - - name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL); - /* Check that it's not yet defined: */ - if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) { - scheme_wrong_syntax(who, orig_name, e, "duplicate definition for identifier"); - return NULL; - } + binding = scheme_stx_lookup_exact(name, scheme_make_integer(phase)); - if (check_already_required(required, name)) { - warn_previously_required(env->genv->module->modname, orig_name); + if (!SCHEME_FALSEP(binding)) { + if (SCHEME_SYMBOLP(binding)) { + scheme_wrong_syntax(who, orig_name, e, "out-of-context identifier for definition"); + return NULL; + } else if (SAME_OBJ(SCHEME_VEC_ELS(binding)[0], self_modidx) + && check_already_defined(SCHEME_VEC_ELS(binding)[1], env->genv)) { + scheme_wrong_syntax(who, orig_name, e, "duplicate definition for identifier"); + return NULL; + } else if (check_already_required(required, name, phase, binding)) + warn_previously_required(env->genv->module->modname, orig_name); } - /* Not syntax: */ - if (scheme_lookup_in_table(env->genv->syntax, (const char *)name)) { - scheme_wrong_syntax(who, orig_name, e, "duplicate definition for identifier"); - return NULL; - } + /* Generate symbol for this binding: */ + name = scheme_global_binding(name, env->genv); /* Create the bucket, indicating that the name will be defined: */ scheme_add_global_symbol(name, scheme_undefined, env->genv); - /* Add a renaming: */ - if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { - scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, phase, NULL, NULL, 0); - *bxs->all_simple_renames = 0; - } else - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, phase, NULL, NULL, 0); + if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name) + || !scheme_stx_equal_module_context(orig_name, env->genv->module->rn_stx)) + *bxs->all_simple_bindings = 0; vars = SCHEME_STX_CDR(vars); var_count++; @@ -8995,26 +8928,35 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ non_phaseless |= NON_PHASELESS_FORM; non_phaseless_form = val; } + + if (!rec[drec].comp) { + /* Reconstruct to remove scopes that don't belong on the binding names in the expansion: */ + e = scheme_datum_to_syntax(scheme_make_pair(fst, scheme_make_pair(vars, + scheme_make_pair(val, + scheme_null))), + e, e, 0, 2); + } SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); kind = DEFN_MODFORM_KIND; - } else if (scheme_stx_module_eq_x(scheme_define_syntaxes_stx, fst, phase) - || scheme_stx_module_eq_x(scheme_begin_for_syntax_stx, fst, phase)) { + } else if (scheme_stx_free_eq_x(scheme_define_syntaxes_stx, fst, phase) + || scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase)) { /************ define-syntaxes & begin-for-syntax *************/ /* Define the macro: */ Scheme_Compile_Info mrec, erec1; - Scheme_Object *names, *l, *code, *m, *vec, *boundname; + Scheme_Object *names, *orig_names, *l, *code, *m, *vec, *boundname, *frame_scopes; Resolve_Prefix *rp; Resolve_Info *ri; Scheme_Comp_Env *oenv, *eenv; Optimize_Info *oi; int count = 0; int for_stx; - int use_post_ex = 0; int max_let_depth; - for_stx = scheme_stx_module_eq_x(scheme_begin_for_syntax_stx, fst, phase); - + e = revert_use_site_scopes_via_context(e, rn_set, phase); + + for_stx = scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase); + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); if (for_stx) { @@ -9033,10 +8975,14 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ boundname = scheme_false; SCHEME_EXPAND_OBSERVE_PREPARE_ENV(observer); + + frame_scopes = scheme_module_context_use_site_frame_scopes(env->genv->exp_env->stx_context); scheme_prepare_exp_env(env->genv); scheme_prepare_compile_env(env->genv->exp_env); - eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); + eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, + frame_scopes, + 0); if (!for_stx) scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, req_data, scheme_false); @@ -9044,46 +8990,44 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ oenv = env; if (!for_stx) { + orig_names = scheme_null; for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - Scheme_Object *name, *orig_name; + Scheme_Object *name, *orig_name, *binding; name = SCHEME_STX_CAR(l); orig_name = name; /* Remember the original: */ all_rt_defs = scheme_make_pair(name, all_rt_defs); + orig_names = scheme_make_pair(name, orig_names); - name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL); - - if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) { - scheme_wrong_syntax(who, orig_name, e, - "duplicate definition for identifier"); - return NULL; - } - - /* Check that it's not yet defined: */ - if (scheme_lookup_in_table(oenv->genv->toplevel, (const char *)name)) { - scheme_wrong_syntax(who, orig_name, e, - "duplicate definition for identifier"); - return NULL; + binding = scheme_stx_lookup_exact(name, scheme_make_integer(phase)); + + if (!SCHEME_FALSEP(binding)) { + if (SCHEME_SYMBOLP(binding)) { + scheme_wrong_syntax(who, orig_name, e, "out-of-context identifier for definition"); + return NULL; + } else if (SAME_OBJ(SCHEME_VEC_ELS(binding)[0], self_modidx) + && check_already_defined(SCHEME_VEC_ELS(binding)[1], env->genv)) { + scheme_wrong_syntax(who, orig_name, e, + "duplicate definition for identifier"); + return NULL; + } else if (check_already_required(required, name, phase, binding)) + warn_previously_required(oenv->genv->module->modname, orig_name); } - if (check_already_required(required, name)) { - warn_previously_required(oenv->genv->module->modname, orig_name); - } + /* Generate symbol for this binding: */ + name = scheme_global_binding(name, env->genv); - if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { - scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, - phase, NULL, NULL, 0); - *bxs->all_simple_renames = 0; - use_post_ex = 1; - } else - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, - phase, NULL, NULL, 0); + if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name) + || !scheme_stx_equal_module_context(orig_name, env->genv->module->rn_stx)) + *bxs->all_simple_bindings = 0; count++; } - } + orig_names = scheme_reverse(orig_names); + } else + orig_names = NULL; if (for_stx) names = NULL; @@ -9093,6 +9037,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ mrec.comp = 1; mrec.dont_mark_local_use = 0; mrec.resolve_module_ids = 0; + mrec.substitute_bindings = 1; mrec.value_name = NULL; mrec.observer = NULL; mrec.pre_unwrapped = 0; @@ -9105,6 +9050,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ erec1.value_name = boundname; erec1.observer = observer; erec1.pre_unwrapped = 0; + erec1.substitute_bindings = 1; erec1.env_already = 0; erec1.comp_flags = rec[drec].comp_flags; } @@ -9161,8 +9107,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ scheme_optimize_info_never_inline(oi); m = scheme_optimize_expr(m, oi, 0); - /* Simplify only in compile mode; it is too slow in expand mode. */ - rp = scheme_resolve_prefix(1, eenv->prefix, !erec); + rp = scheme_resolve_prefix(1, eenv->prefix, env->insp); ri = scheme_resolve_info_create(rp); scheme_enable_expression_resolve_lifts(ri); m = scheme_resolve_expr(m, ri); @@ -9195,8 +9140,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ eval_exptime(names, count, m, eenv->genv, rhs_env, rp, max_let_depth, 0, (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), phase + 1, - for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn), - NULL); + for_stx ? scheme_false : orig_names, NULL); if (erec) { if (for_stx) { @@ -9218,19 +9162,21 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ non_phaseless |= NON_PHASELESS_FORM; if (!non_phaseless_form) non_phaseless_form = e; - } else if (scheme_stx_module_eq_x(require_stx, fst, phase)) { + } else if (scheme_stx_free_eq_x(require_stx, fst, phase)) { /************ require *************/ SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer); + e = revert_use_site_scopes_via_context(e, rn_set, phase); + /* Adds requires to renamings and required modules to requires lists: */ parse_requires(e, phase, self_modidx, env->genv, env->genv->module, - rn_set, bxs->post_ex_rn_set, + rn_set, check_require_name, bxs->tables, bxs->redef_modname, - 0, 0, 1, + 0, 1, phase ? 1 : 0, - bxs->all_simple_renames, bxs->modidx_cache, + bxs->all_simple_bindings, bxs->modidx_cache, bxs->submodule_names, &non_phaseless); @@ -9239,14 +9185,14 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); kind = DONE_MODFORM_KIND; - } else if (scheme_stx_module_eq_x(provide_stx, fst, phase)) { + } else if (scheme_stx_free_eq_x(provide_stx, fst, phase)) { /************ provide *************/ /* remember it for pass 3 */ p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), bxs->saved_provides); bxs->saved_provides = p; kind = PROVIDE_MODFORM_KIND; - } else if (scheme_stx_module_eq_x(declare_stx, fst, phase)) { + } else if (scheme_stx_free_eq_x(declare_stx, fst, phase)) { /************ declare *************/ Scheme_Object *kws, *kw; @@ -9258,6 +9204,10 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ if (requested_phaseless) scheme_wrong_syntax(who, kw, e, "duplicate declaration"); requested_phaseless = 1; + } else if (SAME_OBJ(SCHEME_STX_VAL(kw), empty_namespace_keyword)) { + if (requested_empty_namespace) + scheme_wrong_syntax(who, kw, e, "duplicate declaration"); + requested_empty_namespace = 1; } else { scheme_wrong_syntax(who, kw, e, "unrecognized keyword"); } @@ -9270,14 +9220,16 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ scheme_wrong_syntax(who, NULL, e, IMPROPER_LIST_FORM); kind = DECLARE_MODFORM_KIND; - } else if (scheme_stx_module_eq_x(scheme_module_stx, fst, phase) - || scheme_stx_module_eq_x(scheme_modulestar_stx, fst, phase)) { + } else if (scheme_stx_free_eq_x(scheme_module_stx, fst, phase) + || scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase)) { /************ module[*] *************/ /* check outer syntax & name, then expand pre-module or remember for post-module pass */ Scheme_Object *name = NULL; int is_star; - is_star = scheme_stx_module_eq_x(scheme_modulestar_stx, fst, phase); + is_star = scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase); + + e = revert_use_site_scopes_via_context(e, rn_set, phase); SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); if (is_star) { @@ -9365,7 +9317,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ e = scheme_reverse(e); if (expand_ends) { fm = scheme_frame_get_end_statement_lifts(xenv); - fm = reverse_and_add_rename(fm, post_ex_rn); + fm = reverse_and_introduce_module_context(fm, rn_set); if (!SCHEME_NULLP(e)) fm = scheme_append(fm, e); maybe_has_lifts = 0; @@ -9384,12 +9336,6 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ } if (!phase) { - /* Bound names will not be re-bound at this point: */ - if (!erec || (erec[derec].depth != -2)) { - scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND); - } - scheme_seal_module_rename_set(bxs->post_ex_rn_set, STX_SEAL_BOUND); - /* Check that all bindings used in phase-N expressions (for N >= 1) were defined by now: */ check_formerly_unbound(unbounds, env); @@ -9398,16 +9344,18 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ /* Pass 2 */ SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); - if (rec[drec].comp) { + { /* Module and each `begin-for-syntax' group manages its own prefix: */ - cenv = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); - } else - cenv = scheme_extend_as_toplevel(env); + Scheme_Object *frame_scopes; + frame_scopes = scheme_module_context_frame_scopes(rn_set, xenv->scopes); + cenv = scheme_new_comp_env(env->genv, env->insp, frame_scopes, + SCHEME_TOPLEVEL_FRAME | SCHEME_KEEP_SCOPES_FRAME); + } lift_data = scheme_make_vector(3, NULL); SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv; SCHEME_VEC_ELS(lift_data)[1] = self_modidx; - SCHEME_VEC_ELS(lift_data)[2] = rn; + SCHEME_VEC_ELS(lift_data)[2] = rn_set; maybe_has_lifts = 0; @@ -9462,14 +9410,14 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ if (kind == DEFN_MODFORM_KIND) nenv = cenv; else - nenv = scheme_new_compilation_frame(0, 0, cenv); + nenv = scheme_new_compilation_frame(0, 0, NULL, cenv); if (erec) { Scheme_Expand_Info erec1; scheme_init_expand_recs(erec, derec, &erec1, 1); erec1.value_name = scheme_false; e = scheme_expand_expr(e, nenv, &erec1, 0); - expanded_l = scheme_make_pair(e, expanded_l); + expanded_l = scheme_make_pair(e, expanded_l); } if (rec[drec].comp) { @@ -9492,7 +9440,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ p = SCHEME_CDR(p); } else { /* Lifts - insert them and try again */ - *bxs->all_simple_renames = 0; + *bxs->all_simple_bindings = 0; SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l)); if (erec) { e = scheme_make_pair(scheme_make_pair(e, SCHEME_CAR(expanded_l)), @@ -9610,13 +9558,6 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ } } - if (phase == 0) { - if (!erec || (erec[derec].depth != -2)) { - scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL); - } - scheme_seal_module_rename_set(bxs->post_ex_rn_set, STX_SEAL_ALL); - } - adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); bxs->all_defs = adt; @@ -9644,6 +9585,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ } } + if (requested_empty_namespace) + env->genv->module->rn_stx = NULL; + if (rec[drec].comp) { body_lists = scheme_make_pair(first, scheme_make_pair(exp_body, body_lists)); if (erec) @@ -9694,9 +9638,9 @@ static Scheme_Object *expand_all_provides(Scheme_Object *form, penv = penv->exp_env; } if (rec[drec].comp) - pcenv = scheme_new_comp_env(penv, penv->access_insp, SCHEME_TOPLEVEL_FRAME); + pcenv = scheme_new_comp_env(penv, penv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); else - pcenv = scheme_new_expand_env(penv, penv->access_insp, SCHEME_TOPLEVEL_FRAME); + pcenv = scheme_new_expand_env(penv, penv->access_insp, NULL, SCHEME_TOPLEVEL_FRAME); } else { pcenv = cenv; } @@ -9734,6 +9678,7 @@ static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int dre env = scheme_new_compilation_frame(0, (SCHEME_TOPLEVEL_FRAME | SCHEME_NESTED_MODULE_FRAME), + NULL, env); l = scheme_reverse(l); @@ -9806,10 +9751,10 @@ static Scheme_Object *fixup_expanded(Scheme_Object *expanded_l, e = SCHEME_CAR(p); if (SCHEME_STX_PAIRP(e)) { fst = SCHEME_STX_CAR(e); - if (scheme_stx_module_eq_x(prov_stx, fst, phase)) { + if (scheme_stx_free_eq_x(prov_stx, fst, phase)) { SCHEME_CAR(p) = SCHEME_CAR(expanded_provides); expanded_provides = SCHEME_CDR(expanded_provides); - } else if (scheme_stx_module_eq_x(scheme_begin_for_syntax_stx, fst, phase)) { + } else if (scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase)) { l = scheme_flatten_syntax_list(e, NULL); l = scheme_copy_list(l); expanded_provides = fixup_expanded(SCHEME_CDR(l), expanded_provides, phase + 1, kind); @@ -9874,13 +9819,14 @@ static int is_modulestar_stop(Scheme_Comp_Env *env) { Scheme_Object *p; p = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, scheme_sys_wraps(env), 0, 0); - p = scheme_lookup_binding(p, env, + p = scheme_compile_lookup(p, env, (SCHEME_NULL_FOR_UNBOUND + SCHEME_DONT_MARK_USE + SCHEME_ENV_CONSTANTS_OK + (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)), env->in_modidx, - NULL, NULL, NULL, NULL); + NULL, NULL, + NULL, NULL, NULL); return (scheme_get_stop_expander() == p); } @@ -9893,63 +9839,63 @@ static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **_beg scheme_add_local_syntax(22, xenv); if (phase == 0) { - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); - scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv); - scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(3, scheme_begin_for_syntax_stx, stop, xenv); + scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv, 0); + scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv, 0); + scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv, 0); + scheme_set_local_syntax(3, scheme_begin_for_syntax_stx, stop, xenv, 0); *_begin_for_syntax_stx = scheme_begin_for_syntax_stx; - scheme_set_local_syntax(4, require_stx, stop, xenv); - scheme_set_local_syntax(5, provide_stx, stop, xenv); - scheme_set_local_syntax(6, set_stx, stop, xenv); - scheme_set_local_syntax(7, app_stx, stop, xenv); - scheme_set_local_syntax(8, scheme_top_stx, stop, xenv); - scheme_set_local_syntax(9, lambda_stx, stop, xenv); - scheme_set_local_syntax(10, case_lambda_stx, stop, xenv); - scheme_set_local_syntax(11, let_values_stx, stop, xenv); - scheme_set_local_syntax(12, letrec_values_stx, stop, xenv); - scheme_set_local_syntax(13, if_stx, stop, xenv); - scheme_set_local_syntax(14, begin0_stx, stop, xenv); - scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv); - scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(17, var_ref_stx, stop, xenv); - scheme_set_local_syntax(18, expression_stx, stop, xenv); - scheme_set_local_syntax(19, scheme_modulestar_stx, stop, xenv); - scheme_set_local_syntax(20, scheme_module_stx, stop, xenv); - scheme_set_local_syntax(21, declare_stx, stop, xenv); + scheme_set_local_syntax(4, require_stx, stop, xenv, 0); + scheme_set_local_syntax(5, provide_stx, stop, xenv, 0); + scheme_set_local_syntax(6, set_stx, stop, xenv, 0); + scheme_set_local_syntax(7, app_stx, stop, xenv, 0); + scheme_set_local_syntax(8, scheme_top_stx, stop, xenv, 0); + scheme_set_local_syntax(9, lambda_stx, stop, xenv, 0); + scheme_set_local_syntax(10, case_lambda_stx, stop, xenv, 0); + scheme_set_local_syntax(11, let_values_stx, stop, xenv, 0); + scheme_set_local_syntax(12, letrec_values_stx, stop, xenv, 0); + scheme_set_local_syntax(13, if_stx, stop, xenv, 0); + scheme_set_local_syntax(14, begin0_stx, stop, xenv, 0); + scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv, 0); + scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv, 0); + scheme_set_local_syntax(17, var_ref_stx, stop, xenv, 0); + scheme_set_local_syntax(18, expression_stx, stop, xenv, 0); + scheme_set_local_syntax(19, scheme_modulestar_stx, stop, xenv, 0); + scheme_set_local_syntax(20, scheme_module_stx, stop, xenv, 0); + scheme_set_local_syntax(21, declare_stx, stop, xenv, 0); } else { - w = scheme_sys_wraps_phase_worker(phase); + w = scheme_sys_wraps_phase(scheme_make_integer(phase)); s = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); - scheme_set_local_syntax(0, s, stop, xenv); + scheme_set_local_syntax(0, s, stop, xenv, 0); s = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); - scheme_set_local_syntax(1, s, stop, xenv); + scheme_set_local_syntax(1, s, stop, xenv, 0); s = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); - scheme_set_local_syntax(2, s, stop, xenv); + scheme_set_local_syntax(2, s, stop, xenv, 0); s = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); - scheme_set_local_syntax(3, s, stop, xenv); + scheme_set_local_syntax(3, s, stop, xenv, 0); *_begin_for_syntax_stx = s; s = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); - scheme_set_local_syntax(4, s, stop, xenv); + scheme_set_local_syntax(4, s, stop, xenv, 0); s = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); - scheme_set_local_syntax(5, s, stop, xenv); - scheme_set_local_syntax(6, scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(7, scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(8, scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(9, scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(10, scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(11, scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(12, scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(13, scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(14, scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(15, scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(16, scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(17, scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0), stop, xenv); - scheme_set_local_syntax(18, scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(5, s, stop, xenv, 0); + scheme_set_local_syntax(6, scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(7, scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(8, scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(9, scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(10, scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(11, scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(12, scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(13, scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(14, scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(15, scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(16, scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(17, scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0), stop, xenv, 0); + scheme_set_local_syntax(18, scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0), stop, xenv, 0); s = scheme_datum_to_syntax(scheme_intern_symbol("module*"), scheme_false, w, 0, 0); - scheme_set_local_syntax(19, s, stop, xenv); + scheme_set_local_syntax(19, s, stop, xenv, 0); s = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0); - scheme_set_local_syntax(20, s, stop, xenv); + scheme_set_local_syntax(20, s, stop, xenv, 0); s = scheme_datum_to_syntax(scheme_intern_symbol("#%declare"), scheme_false, w, 0, 0); - scheme_set_local_syntax(21, s, stop, xenv); + scheme_set_local_syntax(21, s, stop, xenv, 0); } } @@ -9973,7 +9919,7 @@ static void check_already_provided(Scheme_Hash_Table *provided, Scheme_Object *o v = scheme_hash_get(provided, outname); if (v) { - if (!scheme_stx_module_eq2(SCHEME_CAR(v), name, phase, NULL)) + if (!scheme_stx_free_eq2(SCHEME_CAR(v), name, phase)) scheme_wrong_syntax("module", outname, form, "identifier already provided (as a different binding)"); if (protected && SCHEME_FALSEP(SCHEME_CDR(v))) @@ -9999,7 +9945,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, int i, k, z; Scheme_Object *rx, *provided_list, *phase, *req_phase; Scheme_Object *all_x_defs, *all_x_defs_out; - Scheme_Env *genv; + Scheme_Env *genv, *name_env; if (all_phases) { /* synthesize all_reprovided for the loop below: */ @@ -10007,7 +9953,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, reprovided = scheme_make_pair(scheme_false, scheme_null); else reprovided = all_phases; - all_reprovided = scheme_make_hash_table_equal(); + all_reprovided = scheme_make_hash_table_eqv(); if (mod_for_requires->requires && !SCHEME_NULLP(mod_for_requires->requires)) scheme_hash_set(all_reprovided, scheme_make_integer(0), reprovided); @@ -10030,7 +9976,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } } else if (all_mods) { reprovided = scheme_make_pair(scheme_false, scheme_null); - all_reprovided = scheme_make_hash_table_equal(); + all_reprovided = scheme_make_hash_table_eqv(); while (SCHEME_PAIRP(all_mods)) { scheme_hash_set(all_reprovided, SCHEME_CAR(all_mods), reprovided); all_mods = SCHEME_CDR(all_mods); @@ -10063,6 +10009,8 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } if (!requires) requires = scheme_null; + + name_env = scheme_find_env_at_phase(_genv, phase); for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) { Scheme_Object *midx = SCHEME_CAR(SCHEME_CAR(rx)), *l, *exns; @@ -10091,17 +10039,21 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, exns = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(rx))); for (l = exns; !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) { /* Make sure excluded name was required: */ - Scheme_Object *a, *vec = NULL; - a = SCHEME_STX_VAL(SCHEME_STX_CAR(l)); + Scheme_Object *a, *b, *vec = NULL; for (k = 0; k < tables->size; k++) { if (tables->vals[k]) { tvec = tables->vals[k]; required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1]; - if (required) - vec = scheme_hash_get(required, a); - else + if (required) { + a = SCHEME_STX_CAR(l); + b = scheme_stx_lookup(a, tables->keys[k]); + if (SCHEME_VECTORP(b) + && !SAME_OBJ(SCHEME_VEC_ELS(b)[0], _genv->module->self_modidx)) + b = require_binding_to_key(required, b, SCHEME_STX_VAL(a)); + vec = scheme_hash_get(required, b); + } else vec = NULL; if (vec) { @@ -10134,6 +10086,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } } + /* For each reprovided, walk through requires, check for re-provided bindings: */ for (z = 0; z < all_reprovided->size; z++) { reprovided = all_reprovided->vals[z]; @@ -10147,14 +10100,14 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, req_phase = tables->keys[k]; for (i = required->size; i--; ) { - if (required->vals[i]) { - Scheme_Object *nominal_modidx, *name, *outname, *nml, *orig_nml, *mark_src; + if (required->vals[i] && SCHEME_TRUEP(required->vals[i])) { + Scheme_Object *nominal_modidx, *outname, *nml, *orig_nml, *id; int break_outer = 0; - name = required->keys[i]; /* internal symbolic name */ orig_nml = SCHEME_VEC_ELS(required->vals[i])[0]; outname = SCHEME_VEC_ELS(required->vals[i])[4]; - mark_src = SCHEME_VEC_ELS(required->vals[i])[6]; + prep_required_id(required->vals[i]); + id = SCHEME_VEC_ELS(required->vals[i])[6]; for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) { for (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) { @@ -10187,10 +10140,10 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, /* Was this name excluded? */ Scheme_Object *a; a = SCHEME_STX_VAL(SCHEME_STX_CAR(exns)); - if (SAME_OBJ(a, name)) + if (SAME_OBJ(a, outname)) break; } - + if (SCHEME_STX_NULLP(exns)) { /* Not excluded, so provide it. */ if (matching_form) { @@ -10200,32 +10153,13 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, provided = scheme_make_hash_table(SCHEME_hash_ptr); scheme_hash_set(all_provided, req_phase, (Scheme_Object *)provided); } - check_already_provided(provided, outname, name, 0, SCHEME_CAR(ree), req_phase); - scheme_hash_set(provided, outname, scheme_make_pair(name, scheme_false)); + check_already_provided(provided, outname, id, 0, SCHEME_CAR(ree), req_phase); + scheme_hash_set(provided, outname, scheme_make_pair(id, scheme_false)); } else { - if (SCHEME_TRUEP(mark_src)) { - if (SCHEME_SYM_PARALLELP(name)) { - /* reverse scheme_tl_id_sym */ - char *s; - int len; - len = SCHEME_SYM_LEN(name); - s = scheme_malloc_atomic(len + 1); - memcpy(s, SCHEME_SYM_VAL(name), len+1); - while (len && (s[len] != '.')) { - --len; - } - s[len] = 0; - name = scheme_intern_exact_symbol(s, len); - } - name = scheme_datum_to_syntax(name, scheme_false, mark_src, 0, 0); - } else { - scheme_signal_error("found an import with no lexical context"); - } - provided_list = scheme_hash_get(all_provided, req_phase); if (!provided_list) provided_list = scheme_null; - provided_list = scheme_make_pair(name, provided_list); + provided_list = scheme_make_pair(id, provided_list); scheme_hash_set(all_provided, req_phase, provided_list); } } @@ -10252,7 +10186,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, if (all_x_defs_out) { for (; !SCHEME_NULLP(all_x_defs_out); all_x_defs_out = SCHEME_CDR(all_x_defs_out)) { - Scheme_Object *exns, *ree, *ree_kw, *exl, *name, *a, *adl, *exname, *pfx; + Scheme_Object *exns, *ree, *ree_kw, *exl, *name, *a, *adl, *exname, *pfx, *name_sym; int protected; ree = SCHEME_CAR(all_x_defs_out); @@ -10266,7 +10200,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, /* Make sure each excluded name was defined: */ for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { a = SCHEME_STX_CAR(exns); - name = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL); + name = to_defined_symbol(a, genv); if (!scheme_lookup_in_table(genv->toplevel, (const char *)name) && !scheme_lookup_in_table(genv->syntax, (const char *)name)) { scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined"); @@ -10276,13 +10210,13 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, for (adl = all_x_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { name = SCHEME_CAR(adl); exname = SCHEME_STX_SYM(name); - name = scheme_tl_id_sym(genv, name, NULL, 0, NULL, NULL); + name_sym = to_defined_symbol(name, genv); /* Was this one excluded? */ for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { a = SCHEME_STX_CAR(exns); - a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL); - if (SAME_OBJ(a, name)) + a = to_defined_symbol(a, genv); + if (SAME_OBJ(a, name_sym)) break; } @@ -10290,22 +10224,22 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, /* not excluded */ /* But don't export uninterned: */ - if (!SCHEME_SYM_UNINTERNEDP(name)) { + if (!SCHEME_SYM_UNINTERNEDP(exname)) { /* Also, check that ree_kw and the identifier have the same introduction (in case one or the other was introduced by a macro). We perform this check by getting exname's tl_id as if it had ree_kw's context, then comparing that result to the actual tl_id. */ a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0); - a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL); + a = to_defined_symbol(a, genv); - if (SAME_OBJ(a, name)) { + if (SAME_OBJ(a, name_sym)) { /* Add prefix, if any */ if (SCHEME_TRUEP(pfx)) { exname = scheme_symbol_append(pfx, exname); } check_already_provided(provided, exname, name, protected, ree_kw, phase); - + scheme_hash_set(provided, exname, scheme_make_pair(name, protected ? scheme_true : scheme_false)); } @@ -10334,7 +10268,7 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv, if (vars) { start = 0; - end = pt->num_var_provides; + end = pt->num_provides; /* check both vars & syntax, in case of rename transformer */ } else { start = pt->num_var_provides; end = pt->num_provides; @@ -10376,7 +10310,7 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv, if (SAME_OBJ(name, exsns[j])) break; } - + if (j == end) exis[count++] = name; } @@ -10403,7 +10337,7 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind int v, i; tables = (Scheme_Hash_Table *)SCHEME_CAR(bindings); - all_reprovided = scheme_make_hash_table_equal(); + all_reprovided = scheme_make_hash_table_eqv(); if (SCHEME_FALSEP(modpath)) { if (SAME_OBJ(mode, scheme_true)) { @@ -10433,7 +10367,7 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind } /* Receives result: */ - all_provided = scheme_make_hash_table_equal(); + all_provided = scheme_make_hash_table_eqv(); v = compute_reprovides(all_provided, all_reprovided, @@ -10496,115 +10430,13 @@ static Scheme_Object *adjust_for_rename(Scheme_Object *out_name, Scheme_Object * return first; } -static Scheme_Object *extract_free_id_name(Scheme_Object *name, - Scheme_Object *phase, - Scheme_Env *genv, - int always, - int *_implicit, - Scheme_Object **_implicit_src, - Scheme_Object **_implicit_src_name, - Scheme_Object **_implicit_mod_phase, - Scheme_Object **_implicit_nominal_name, - Scheme_Object **_implicit_nominal_mod) +static int lookup(Scheme_Env *name_env, int as_syntax, Scheme_Object *name) { - *_implicit = 0; + Scheme_Bucket_Table *bt = (as_syntax ? name_env->syntax : name_env->toplevel); - if (genv) { - if (SCHEME_FALSEP(phase)) { - /* genv is used for tl_id_sym */ - } else { - int i; - i = SCHEME_INT_VAL(phase); - if (i > 0) { - for (; i--; ) { - genv = genv->exp_env; - if (!genv) break; - } - } else if (i < 0) { - for (; i++; ) { - genv = genv->template_env; - if (!genv) break; - } - } - } - } - - while (1) { /* loop for free-id=? renaming */ - if (SCHEME_STXP(name)) { - if (genv - && (always || SCHEME_INTP(phase))) { - name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); - } else - name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ - } - - /* Check for free-id=? renaming: */ - if (SAME_OBJ(phase, scheme_make_integer(0))) { - Scheme_Object *v2; - v2 = scheme_lookup_in_table(genv->syntax, (const char *)name); - if (v2 && scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(v2))) { - Scheme_Object *name2; - Scheme_Object *mod, *id, *rename_insp = NULL; - Scheme_Object *mod_phase = NULL; - - name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2)); - id = name2; - - if (_implicit_mod_phase) mod_phase = *_implicit_mod_phase; - mod = scheme_stx_module_name(NULL, &id, phase, - _implicit_nominal_mod, _implicit_nominal_name, - &mod_phase, - NULL, NULL, NULL, NULL, &rename_insp, NULL); - if (_implicit_mod_phase) *_implicit_mod_phase = mod_phase; - - if (mod && SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) { - if (SCHEME_FALSEP(((Scheme_Modidx *)mod)->path)) { - /* keep looking locally */ - name = name2; - SCHEME_USE_FUEL(1); - } else { - /* free-id=? equivalence to a name that is not necessarily imported explicitly. */ - /* Note that we're dropping `rename_insp'. It's possible that `rename_insp' provides - more access than a context where the export htat we're recording is eventually - imported; in that case, a non-free=id? rename transformer might still be able - to acces the binding, since it doesn't lose track of `rename_insp'. But re-exporting - a protected binding with less protection is a bad idea, and tracking - `rename_insp' is coplicated --- too much work to support a bad idea. */ - if (_implicit_src) { - *_implicit_src = mod; - *_implicit_src_name = id; - name2 = scheme_stx_property(name2, nominal_id_symbol, NULL); - if (SCHEME_SYMBOLP(name2)) - *_implicit_nominal_name = name2; - *_implicit = 1; - } - break; - } - } else - break; - } else - break; - } else - break; - } - - return name; -} - -static int lookup(Scheme_Env *genv, Scheme_Object *phase, int as_syntax, const char *name) -{ - int p; - - if (SCHEME_FALSEP(phase)) - return 0; - - p = SCHEME_INT_VAL(phase); - while (p--) { - genv = genv->exp_env; - if (!genv) return 0; - } + if (!bt) return 0; - return !!scheme_lookup_in_table((as_syntax ? genv->syntax : genv->toplevel), (const char *)name); + return !!scheme_lookup_in_table(bt, (const char *)name); } void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, @@ -10613,15 +10445,15 @@ void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table * Scheme_Object *form, int num_phases, Scheme_Module_Export_Info **exp_infos) { - int i, count, z, implicit; - Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase; + int i, k, count, z; + Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase, *binding; Scheme_Hash_Table *provided, *required; char *exps; int *exets; int excount, exvcount; Scheme_Module_Phase_Exports *pt; - Scheme_Object *implicit_src, *implicit_src_name, *implicit_mod_phase; - Scheme_Object *implicit_nominal_name, *implicit_nominal_mod; + Scheme_Object *nominal_mod, *nominal_name, *nominal_in_phase, *nominal_src_phase; + Scheme_Env *name_env; for (z = 0; z < all_provided->size; z++) { provided = (Scheme_Hash_Table *)all_provided->vals[z]; @@ -10630,7 +10462,7 @@ void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table * phase = all_provided->keys[z]; required = get_required_from_tables(tables, phase); if (!required) - required = scheme_make_hash_table(SCHEME_hash_ptr); + required = scheme_make_hash_table_equal(); if (SAME_OBJ(phase, scheme_make_integer(0))) pt = me->rt; @@ -10644,7 +10476,7 @@ void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table * pt->phase_index = phase; if (!me->other_phases) { Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_equal(); + ht = scheme_make_hash_table_eqv(); me->other_phases = ht; } scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); @@ -10663,127 +10495,106 @@ void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table * exets = MALLOC_N_ATOMIC(int, count); memset(exets, 0, count * sizeof(int)); - /* Do non-syntax first. */ - for (count = 0, i = provided->size; i--; ) { - if (provided->vals[i]) { - Scheme_Object *name, *prnt_name, *v; - int protected; + name_env = scheme_find_env_at_phase(genv, phase); + + count = 0; + exvcount = 0; + + for (k = 0; k < 2; k++) { + for (i = provided->size; i--; ) { + if (provided->vals[i]) { + Scheme_Object *name, *prnt_name, *v; + int protected, defined; - v = provided->vals[i]; /* external name */ - name = SCHEME_CAR(v); /* internal name (maybe already a symbol) */ - protected = SCHEME_TRUEP(SCHEME_CDR(v)); - prnt_name = name; + v = provided->vals[i]; /* external name as symbol */ + name = SCHEME_CAR(v); /* internal identifier */ + protected = SCHEME_TRUEP(SCHEME_CDR(v)); + prnt_name = name; - name = extract_free_id_name(name, phase, genv, 1, &implicit, - NULL, NULL, NULL, - NULL, NULL); + binding = scheme_stx_lookup_w_nominal(name, phase, + 0, + NULL, NULL, NULL, + NULL, + &nominal_mod, &nominal_name, + &nominal_in_phase, + &nominal_src_phase); - if (!implicit - && genv - && lookup(genv, phase, 0, (const char *)name)) { - /* Defined locally */ - exs[count] = provided->keys[i]; - exsns[count] = name; - exss[count] = scheme_false; /* means "self" */ - exsnoms[count] = scheme_null; /* since "self" */ - exps[count] = protected; - exets[count] = SCHEME_INT_VAL(phase); - count++; - } else if (!implicit - && genv - && lookup(genv, phase, 1, (const char *)name)) { - /* Skip syntax for now. */ - } else if (implicit) { - /* Rename-transformer redirect; skip for now. */ - } else if ((v = scheme_hash_get(required, name))) { - /* Required */ - if (protected) { - name = SCHEME_CAR(provided->vals[i]); - scheme_wrong_syntax("module", NULL, name, "cannot protect imported identifier with re-provide"); + if (SCHEME_VECTORP(binding)) { + defined = SAME_OBJ(SCHEME_VEC_ELS(binding)[0], genv->module->self_modidx); + name = SCHEME_VEC_ELS(binding)[1]; + } else { + defined = 0; + name = scheme_false; } - if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[3])) { - Scheme_Object *noms; + + if (defined && lookup(name_env, k, name)) { + /* Defined locally */ exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(v)[2]; - exss[count] = SCHEME_VEC_ELS(v)[1]; - noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); - exsnoms[count] = noms; + exsns[count] = name; + exss[count] = scheme_false; /* means "self" */ + exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; - exets[count] = SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[8]); - + exets[count] = SCHEME_INT_VAL(phase); count++; - } - } else { - /* Not defined! */ - char buf[32], *phase_expl; - if (phase) { - if (SCHEME_FALSEP(phase)) { - phase_expl = " for-label"; - } else { - sprintf(buf, " for phase %" PRIdPTR, SCHEME_INT_VAL(phase)); - phase_expl = scheme_strdup(buf); + } else if (defined && lookup(name_env, 1-k, name)) { + /* Skip definition for other round */ + } else if (!defined + && SCHEME_VECTORP(binding) + && (v = scheme_hash_get(required, require_binding_to_key(required, + binding, + SCHEME_STX_VAL(prnt_name))))) { + /* Required */ + if (protected) { + name = SCHEME_CAR(provided->vals[i]); + scheme_wrong_syntax("module", NULL, name, "cannot protect imported identifier with re-provide"); } - } else - phase_expl = ""; - scheme_wrong_syntax("module", prnt_name, form, - "provided identifier not defined or imported%s", - phase_expl); - } - } - } - - exvcount = count; - - for (i = provided->size; i--; ) { - if (provided->vals[i]) { - Scheme_Object *name, *v; - int protected; - - v = provided->vals[i]; - name = SCHEME_CAR(v); /* internal name (maybe already a symbol) */ - protected = SCHEME_TRUEP(SCHEME_CDR(v)); - - name = extract_free_id_name(name, phase, genv, 0, &implicit, - &implicit_src, &implicit_src_name, - &implicit_mod_phase, - &implicit_nominal_name, &implicit_nominal_mod); - - if (!implicit - && genv - && lookup(genv, phase, 1, (const char *)name)) { - /* Defined locally */ - exs[count] = provided->keys[i]; - exsns[count] = name; - exss[count] = scheme_false; /* means "self" */ - exsnoms[count] = scheme_null; /* since "self" */ - exps[count] = protected; - exets[count] = SCHEME_INT_VAL(phase); - count++; - } else if (implicit) { - /* We record all free-id=?-based exports as syntax, even though they may be values. */ - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = implicit_src_name; - exss[count] = implicit_src; - noms = adjust_for_rename(exs[count], implicit_nominal_name, cons(implicit_nominal_mod, scheme_null)); - exsnoms[count] = noms; - exps[count] = protected; - count++; - } else if ((v = scheme_hash_get(required, name))) { - /* Required */ - if (SCHEME_FALSEP(SCHEME_VEC_ELS(v)[3])) { - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(v)[2]; - exss[count] = SCHEME_VEC_ELS(v)[1]; - noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); - exsnoms[count] = noms; - exps[count] = protected; - exets[count] = SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[8]); - count++; + if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[3]) == (k == 0)) { + Scheme_Object *noms; + exs[count] = provided->keys[i]; + exsns[count] = SCHEME_VEC_ELS(v)[2]; + exss[count] = SCHEME_VEC_ELS(v)[1]; + noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); + exsnoms[count] = noms; + exps[count] = protected; + exets[count] = SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[8]); + count++; + } + } else if (!defined && SCHEME_VECTORP(binding)) { + if (k == 1) { + /* Exporting a binding that was not explicitly imported --- must be + due to a rename transformer or a macro-introduced `provide`. + We treat all such bindings as syntax, even though they + may correspond to variables. */ + Scheme_Object *noms; + exs[count] = provided->keys[i]; + exsns[count] = SCHEME_VEC_ELS(binding)[1]; + exss[count] = SCHEME_VEC_ELS(binding)[0]; + noms = adjust_for_rename(exs[count], nominal_name, cons(nominal_mod, scheme_null)); + exsnoms[count] = noms; + exps[count] = protected; + count++; + } + } else { + /* Not defined, imported, or otherwise bound */ + char buf[32], *phase_expl; + if (phase) { + if (SCHEME_FALSEP(phase)) { + phase_expl = " for-label"; + } else { + sprintf(buf, " for phase %" PRIdPTR, SCHEME_INT_VAL(phase)); + phase_expl = scheme_strdup(buf); + } + } else + phase_expl = ""; + scheme_wrong_syntax("module", prnt_name, form, + "provided identifier not defined or imported%s", + phase_expl); } } } + + if (!k) + exvcount = count; } excount = count; @@ -10975,19 +10786,20 @@ static Scheme_Object *expand_provide(Scheme_Object *e, int at_phase, Scheme_Comp_Env *xenv; mz_jmp_buf newbuf, * volatile savebuf; - xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_FOR_STOPS), + xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME + | SCHEME_FOR_STOPS), + NULL, cenv); stop = scheme_get_stop_expander(); scheme_add_local_syntax(1, xenv); if (!at_phase) - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); + scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv, 0); else scheme_set_local_syntax(0, scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, - scheme_sys_wraps_phase_worker(at_phase), + scheme_sys_wraps_phase(scheme_make_integer(at_phase)), 0, 0), - stop, xenv); + stop, xenv, 0); scheme_init_expand_recs(rec, drec, &erec1, 1); erec1.value_name = scheme_false; @@ -11170,7 +10982,7 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, else { rest = SCHEME_CAR(p); if (!SCHEME_STX_SYMBOLP(rest) - || !scheme_stx_module_eq_x(scheme_begin_stx, rest, at_phase)) { + || !scheme_stx_free_eq_x(scheme_begin_stx, rest, at_phase)) { p = NULL; } } @@ -11319,7 +11131,7 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, names = scheme_make_struct_names(base, fields, SCHEME_STRUCT_EXPTIME, &len); for (i = 0; i < len; i++) { - /* Wrap local name with prnt_base in case there are marks that + /* Wrap local name with prnt_base in case there are scopes that trigger "gensym"ing */ p = scheme_datum_to_syntax(names[i], scheme_false, prnt_base, 0, 0); check_already_provided(provided, names[i], p, protect_cnt, e, phase); @@ -11614,7 +11426,7 @@ static int expression_starts(Scheme_Object *expr, Scheme_Object *id, int phase) if (SCHEME_STX_PAIRP(expr)) { expr = SCHEME_STX_CAR(expr); if (SCHEME_STX_SYMBOLP(expr)) { - if (scheme_stx_module_eq_x(id, expr, phase)) + if (scheme_stx_free_eq_x(id, expr, phase)) return 1; } } @@ -11631,7 +11443,7 @@ static int expression_starts_app(Scheme_Object *expr, Scheme_Object *id, int pha /* would explicit `#%app' be the core one? */ id = scheme_datum_to_syntax(SCHEME_STX_VAL(app_stx), expr, expr, 0, 0); id = scheme_stx_taint_rearm(id, expr); - if (scheme_stx_module_eq_x(app_stx, id, phase)) + if (scheme_stx_free_eq_x(app_stx, id, phase)) return 1; } @@ -11732,7 +11544,7 @@ static int phaseless_constant_expression(Scheme_Object *val, int phase) a = SCHEME_STX_VAL(datum_stx); val = scheme_stx_taint_rearm(scheme_datum_to_syntax(a, val, val, 0, 0), val); - if (scheme_stx_module_eq_x(datum_stx, val, phase)) + if (scheme_stx_free_eq_x(datum_stx, val, phase)) return 1; return 0; } @@ -11810,52 +11622,43 @@ static int phaseless_rhs(Scheme_Object *val, int var_count, int phase) void add_single_require(Scheme_Module_Exports *me, /* from module */ Scheme_Object *only_phase, - Scheme_Object *src_phase_index, /* import from pahse 0 to src_phase_index */ + Scheme_Object *src_phase_index, /* import from phase 0 to src_phase_index */ Scheme_Object *idx, /* from module's idx; may be saved for unmarshalling */ - Scheme_Env *orig_env, /* env for mark_src or copy_vars */ - Scheme_Object *rn_set, /* add requires to renames in this set when no mark_src */ - Scheme_Object *post_ex_rn_set, /* add requires to this rename when mark_src */ - Scheme_Object *single_rn, /* instead of rn_set */ + Scheme_Env *orig_env, /* env for scope_src or copy_vars */ + Scheme_Object *rn_set, /* add requires to renames in this set when no scope_src */ + Scheme_Object *rn_stx, /* module context-as-stx that corresponds to all_simple */ Scheme_Object *exns, /* NULL or [syntax] list of [syntax] symbols not to import */ Scheme_Hash_Table *onlys, /* NULL or hash table of names to import; the hash table is mutated */ Scheme_Object *prefix, /* NULL or prefix symbol */ Scheme_Object *iname, /* NULL or symbol for a single import */ Scheme_Object *orig_ename, /* NULL or symbol for a single import */ - Scheme_Object *mark_src, /* default mark_src; if onlys, each is also mark_src */ - int unpack_kern, int copy_vars, int for_unmarshal, - int can_save_marshal, + Scheme_Object *scope_src, /* default scope_src; if onlys, each is also scope_src */ + int copy_vars, int *all_simple, Check_Func ck, /* NULL or called for each addition */ void *data, - Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *cki /* ck args */ - ) + Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *cki, /* ck args */ + Scheme_Hash_Table *collapse_table) /* hints for collapsing to a shared table */ { int j, var_count; - Scheme_Object *orig_idx = idx, *to_phase; - Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null; + Scheme_Object *to_phase; + Scheme_Object **exs, **exsns, **exss; int *exets; - int has_context, save_marshal_info = 0; - Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename, *bdg; + Scheme_Object *nominal_modidx, *one_exn, *name, *rn, *ename = orig_ename; Scheme_Hash_Table *orig_onlys; - int k, skip_rename, do_copy_vars; + int k, shared_rename, do_copy_vars; Scheme_Env *name_env; + int can_save_marshal = 1; - if (mark_src) { - /* Check whether there's context for this import (which - leads to generated local names). */ - context_marks = scheme_stx_extract_marks(mark_src); - bdg = scheme_stx_moduleless_env(mark_src); - has_context = !SCHEME_NULLP(context_marks) || !SCHEME_FALSEP(bdg); - if (has_context) { - if (all_simple) - *all_simple = 0; - } - } else { - has_context = 0; /* computed later */ - bdg = NULL; + if (scope_src) { + if (all_simple + && *all_simple + && rn_stx + && !scheme_stx_equal_module_context(scope_src, rn_stx)) + *all_simple = 0; } - if (iname || ename || onlys || for_unmarshal || unpack_kern) + if (iname || ename || onlys) can_save_marshal = 0; if (onlys) @@ -11888,11 +11691,12 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ name_env = orig_env; if (pt) { - if (SCHEME_FALSEP(pt->phase_index)) + if (SCHEME_FALSEP(pt->phase_index) + || SCHEME_FALSEP(src_phase_index)) { to_phase = scheme_false; - else if (SCHEME_FALSEP(src_phase_index)) - to_phase = scheme_false; - else { + scheme_prepare_label_env(name_env); + name_env = name_env->label_env; + } else { if (orig_env) { to_phase = pt->phase_index; while (SCHEME_INT_VAL(to_phase) > 0) { @@ -11916,12 +11720,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ nominal_modidx = idx; - if (single_rn) - rn = single_rn; - else - rn = scheme_get_module_rename_from_set(((has_context && post_ex_rn_set) ? post_ex_rn_set : rn_set), - to_phase, - 1); + rn = scheme_module_context_at_phase(rn_set, to_phase); if (copy_vars) do_copy_vars = !orig_env->module && !orig_env->phase && SAME_OBJ(src_phase_index, scheme_make_integer(0)) && (k == -3); @@ -11929,25 +11728,23 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ do_copy_vars = 0; if (can_save_marshal - && !exns - && !prefix && !orig_ename && pt->num_provides && !do_copy_vars) { - /* Simple "import everything" whose mappings can be shared via the exporting module: */ + /* Simple "import everything" (possibly with prefix and exceptions) + whose mappings can be shared via the exporting module: */ if (!pt->src_modidx && me->src_modidx) pt->src_modidx = me->src_modidx; - scheme_extend_module_rename_with_shared(rn, idx, pt, pt->phase_index, src_phase_index, context_marks, bdg, 1); - skip_rename = 1; + shared_rename = 1; } else - skip_rename = 0; + shared_rename = 0; exs = pt->provides; exsns = pt->provide_src_names; exss = pt->provide_srcs; exets = pt->provide_src_phases; var_count = pt->num_var_provides; - + for (j = pt->num_provides; j--; ) { Scheme_Object *modidx; @@ -11958,13 +11755,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ name = scheme_hash_get(orig_onlys, exs[j]); if (!name) continue; /* we don't want this one. */ - mark_src = name; - { - Scheme_Object *l; - l = scheme_stx_extract_marks(mark_src); - bdg = scheme_stx_moduleless_env(mark_src); - has_context = !SCHEME_NULLP(l) || !SCHEME_FALSEP(bdg); - } + scope_src = name; /* Remove to indicate that it's been imported: */ scheme_hash_set(onlys, exs[j], NULL); } else { @@ -12006,20 +11797,18 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ if (prefix) iname = scheme_symbol_append(prefix, iname); - prnt_iname = iname; - if (has_context) { - /* The `require' expression has a set of marks in its - context, which means that we need to generate a name. */ - iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); - iname = scheme_tl_id_sym(name_env, iname, bdg, skip_rename ? 3 : 2, to_phase, NULL); - if (all_simple) - *all_simple = 0; + if (scope_src) + iname = scheme_datum_to_syntax(iname, scheme_false, scope_src, 0, 0); + else { + iname = scheme_datum_to_syntax(iname, scheme_false, scheme_false, 0, 0); + iname = scheme_stx_add_module_context(iname, rn); } if (ck) - ck(prnt_iname, iname, nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0, + ck(iname, (orig_env->module ? orig_env->module->self_modidx : NULL), + nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0, (j < var_count), - data, cki, form, err_src, mark_src, to_phase, src_phase_index, pt->phase_index); + data, cki, form, err_src, scope_src, to_phase, src_phase_index, pt->phase_index); { int done; @@ -12031,7 +11820,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ modname = scheme_module_resolve(modidx, 1); menv = scheme_module_access(modname, orig_env, 0); val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]); - b = scheme_global_bucket(iname, orig_env); + b = scheme_global_bucket(scheme_global_binding(iname, orig_env), orig_env); scheme_set_global_bucket(((copy_vars == 2) ? "namespace-require/constant" : "namespace-require/copy"), @@ -12040,25 +11829,25 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; done = 0; } else { - scheme_shadow(orig_env, iname, 1); + scheme_shadow(orig_env, (Scheme_Object *)b->key, val, 1); done = 1; } } else done = 0; - if (done) { - } else if (!for_unmarshal || !has_context) { - if (!skip_rename) { - if (!save_marshal_info && !has_context && can_save_marshal) - save_marshal_info = 1; + if (!pt->src_modidx && me->src_modidx) + pt->src_modidx = me->src_modidx; - scheme_extend_module_rename(rn, - modidx, iname, exsns[j], nominal_modidx, exs[j], - exets ? exets[j] : 0, - src_phase_index, - pt->phase_index, - (for_unmarshal || (!has_context && can_save_marshal)) ? 1 : 0); - } + if (!done && !shared_rename) { + scheme_add_module_binding_w_nominal(iname, to_phase, + modidx, exsns[j], (exets + ? scheme_make_integer(exets[j]) + : scheme_make_integer(0)), + scheme_module_context_inspector(rn), + nominal_modidx, exs[j], + src_phase_index, + pt->phase_index, + pt, collapse_table); } } @@ -12070,31 +11859,26 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ } } - if (save_marshal_info) { - Scheme_Object *info, *a; - + if (shared_rename) { + Scheme_Hash_Tree *excepts; + if (exns) { - /* Convert to a list of symbols: */ - info = scheme_null; - for (; SCHEME_STX_PAIRP(exns); exns = SCHEME_STX_CDR(exns)) { - a = SCHEME_STX_CAR(exns); - if (SCHEME_STXP(a)) + Scheme_Object *l, *a; + excepts = scheme_make_hash_tree(0); + for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + if (SCHEME_STXP(a)) a = SCHEME_STX_VAL(a); - info = cons(a, info); + excepts = scheme_hash_tree_set(excepts, a, scheme_true); } - exns = info; } else - exns = scheme_null; + excepts = NULL; - /* The format of this data is checked in "syntax.c" for unmarshaling - a Module_Renames. Also the idx must be first, to support shifting. */ - info = cons(orig_idx, cons(pt->phase_index, - cons(src_phase_index, - cons(exns, prefix ? prefix : scheme_false)))); - - scheme_save_module_rename_unmarshal(rn, info); - - save_marshal_info = 0; + scheme_extend_module_context_with_shared(rn, idx, pt, + (prefix ? prefix : scheme_false), + excepts, + src_phase_index, scope_src, + NULL); } } } @@ -12105,69 +11889,27 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ } } -void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info, - Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, - Scheme_Hash_Table *export_registry) +void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *req_modidx, + Scheme_Object *context, + Scheme_Object *bind_phase, Scheme_Object *pt_phase, Scheme_Object *src_phase, + Scheme_Object *prefix, /* a sybmol; not included in `excepts` keys */ + Scheme_Hash_Tree *excepts, /* NULL => empty */ + Scheme_Hash_Table *export_registry, Scheme_Object *insp_desc, + Scheme_Object *replace_at) { - Scheme_Object *orig_idx, *exns, *prefix, *idx, *name, *pt_phase, *src_phase_index, *marks, *bdg; + Scheme_Object *name; Scheme_Module_Exports *me; Scheme_Env *env; - int share_all; + Scheme_Module *mod; + Scheme_Module_Phase_Exports *pt; - idx = SCHEME_CAR(info); - orig_idx = idx; - info = SCHEME_CDR(info); - pt_phase = SCHEME_CAR(info); - info = SCHEME_CDR(info); + name = scheme_module_resolve(modidx, 0); - if (SCHEME_PAIRP(info) && (SCHEME_PAIRP(SCHEME_CAR(info)) - || SCHEME_VECTORP(SCHEME_CAR(info)))) { - marks = SCHEME_CAR(info); - info = SCHEME_CDR(info); - } else - marks = scheme_null; - - if (SCHEME_VECTORP(marks)) { - bdg = SCHEME_VEC_ELS(marks)[1]; - marks = SCHEME_VEC_ELS(marks)[0]; - } else - bdg = scheme_false; - - if (SCHEME_INTP(info) - || SCHEME_FALSEP(info)) { - share_all = 1; - src_phase_index = info; - - exns = NULL; - prefix = NULL; - } else { - share_all = 0; - src_phase_index = SCHEME_CAR(info); - info = SCHEME_CDR(info); - exns = SCHEME_CAR(info); - prefix = SCHEME_CDR(info); - - if (SCHEME_FALSEP(prefix)) - prefix = NULL; - if (SCHEME_NULLP(exns)) - exns = NULL; - } - - if (modidx_shift_from) - idx = scheme_modidx_shift(idx, - modidx_shift_from, - modidx_shift_to); - - name = scheme_module_resolve(idx, 0); - - { - Scheme_Module *mod; - mod = get_special_module(name); - if (mod) - me = mod->me; - else - me = NULL; - } + mod = get_special_module(name); + if (mod) + me = mod->me; + else + me = NULL; if (!me) { if (!export_registry) { @@ -12185,35 +11927,25 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info, } } - if (share_all) { - Scheme_Module_Phase_Exports *pt; - - if (SAME_OBJ(pt_phase, scheme_make_integer(0))) - pt = me->rt; - else if (SAME_OBJ(pt_phase, scheme_make_integer(1))) - pt = me->et; - else if (SAME_OBJ(pt_phase, scheme_false)) - pt = me->dt; - else - pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(me->other_phases, pt_phase); - - if (pt) { - if (!pt->src_modidx && me->src_modidx) - pt->src_modidx = me->src_modidx; - scheme_extend_module_rename_with_shared(rn, orig_idx, pt, pt->phase_index, src_phase_index, marks, bdg, 0); - } - } else { - if (!SCHEME_NULLP(marks) || SCHEME_TRUEP(bdg)) - scheme_signal_error("internal error: unexpected marks/bdg"); - - add_single_require(me, pt_phase, src_phase_index, orig_idx, NULL, - NULL, NULL, rn, - exns, NULL, prefix, NULL, NULL, - NULL, - 0, 0, 1, 0, - NULL/* _all_simple */, - NULL /* ck */, NULL /* data */, - NULL, NULL, NULL); + if (SAME_OBJ(pt_phase, scheme_make_integer(0))) + pt = me->rt; + else if (SAME_OBJ(pt_phase, scheme_make_integer(1))) + pt = me->et; + else if (SAME_OBJ(pt_phase, scheme_false)) + pt = me->dt; + else if (me->other_phases) + pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(me->other_phases, pt_phase); + else + pt = NULL; + + if (pt) { + if (!pt->src_modidx && me->src_modidx) + pt->src_modidx = me->src_modidx; + scheme_extend_module_context_with_shared(scheme_make_pair(bind_phase, insp_desc), + req_modidx, pt, + prefix, excepts, + src_phase, context, + replace_at); } } @@ -12226,10 +11958,10 @@ void parse_requires(Scheme_Object *form, int at_phase, Scheme_Object *base_modidx, Scheme_Env *main_env, Scheme_Module *for_m, - Scheme_Object *rn_set, Scheme_Object *post_ex_rn_set, + Scheme_Object *rn_set, Check_Func ck, void *data, Scheme_Object *redef_modname, - int unpack_kern, int copy_vars, int can_save_marshal, + int copy_vars, int eval_exp, int eval_run, int *all_simple, Scheme_Hash_Table *modidx_cache, @@ -12240,10 +11972,11 @@ void parse_requires(Scheme_Object *form, int at_phase, Scheme_Object *ll = form, *mode = scheme_make_integer(0), *just_mode = NULL, *x_mode, *x_just_mode; Scheme_Module *m; Scheme_Object *idxstx, *idx, *name, *i, *exns, *prefix, *iname, *ename, *aa, *aav; - Scheme_Object *mark_src, *err_src; + Scheme_Object *scope_src, *err_src; Scheme_Hash_Table *onlys; Scheme_Env *env; int skip_one, mode_cnt = 0, just_mode_cnt = 0, is_mpi; + Scheme_Hash_Table *collapse_table; if (SAME_TYPE(SCHEME_TYPE(form), scheme_module_index_type)) { ll = scheme_make_pair(scheme_false, scheme_make_pair(form, scheme_null)); @@ -12253,6 +11986,8 @@ void parse_requires(Scheme_Object *form, int at_phase, scheme_wrong_syntax(NULL, NULL, form, IMPROPER_LIST_FORM); is_mpi = 0; } + + collapse_table = scheme_make_hash_table(SCHEME_hash_ptr); for (ll = SCHEME_STX_CDR(ll); !SCHEME_STX_NULLP(ll); ll = SCHEME_STX_CDR(ll)) { i = SCHEME_STX_CAR(ll); @@ -12267,14 +12002,14 @@ void parse_requires(Scheme_Object *form, int at_phase, } err_src = i; - mark_src = i; + scope_src = i; skip_one = 0; if (is_mpi) { idxstx = i; exns = NULL; prefix = NULL; - mark_src = NULL; + scope_src = NULL; } else if (SAME_OBJ(for_syntax_symbol, aav) || SAME_OBJ(for_template_symbol, aav) || SAME_OBJ(for_label_symbol, aav) @@ -12453,7 +12188,7 @@ void parse_requires(Scheme_Object *form, int at_phase, rest = SCHEME_STX_CDR(rest); } - mark_src = NULL; + scope_src = NULL; exns = NULL; prefix = NULL; } else if (aa && SAME_OBJ(rename_symbol, SCHEME_STX_VAL(aa))) { @@ -12494,7 +12229,7 @@ void parse_requires(Scheme_Object *form, int at_phase, if (!SCHEME_STX_SYMBOLP(ename)) scheme_wrong_syntax(NULL, i, form, "external name is not an identifier"); - mark_src = iname; + scope_src = iname; iname = SCHEME_STX_VAL(iname); @@ -12611,7 +12346,7 @@ void parse_requires(Scheme_Object *form, int at_phase, Scheme_Hash_Table *oht; oht = main_env->module->other_requires; if (!oht) { - oht = scheme_make_hash_table_equal(); + oht = scheme_make_hash_table_eqv(); main_env->module->other_requires = oht; } reqs = scheme_hash_get(oht, x_mode); @@ -12622,14 +12357,18 @@ void parse_requires(Scheme_Object *form, int at_phase, } } + if (SAME_TYPE(SCHEME_TYPE(idx), scheme_resolved_module_path_type)) + idx = resolved_module_path_to_modidx(idx); + add_single_require(m->me, x_just_mode, x_mode, idx, rename_env, - rn_set, post_ex_rn_set, NULL, + rn_set, (for_m ? for_m->rn_stx : NULL), exns, onlys, prefix, iname, ename, - mark_src, - unpack_kern, copy_vars, 0, can_save_marshal, + scope_src, + copy_vars, all_simple, ck, data, - form, err_src, i); + form, err_src, i, + collapse_table); if (onlys && onlys->count) { /* Something required in `only' wasn't provided by the module */ @@ -12654,49 +12393,45 @@ void parse_requires(Scheme_Object *form, int at_phase, } } -static void check_dup_require(Scheme_Object *prnt_name, Scheme_Object *name, +static void check_dup_require(Scheme_Object *id, Scheme_Object *self_modidx, Scheme_Object *nominal_modidx, Scheme_Object *nominal_name, Scheme_Object *modidx, Scheme_Object *srcname, int exet, int isval, void *ht, Scheme_Object *e, Scheme_Object *form, - Scheme_Object *err_src, Scheme_Object *mark_src, + Scheme_Object *err_src, Scheme_Object *scope_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase) { - Scheme_Object *i; + Scheme_Object *binding; - if (ht) { - Scheme_Hash_Table *pht; - - pht = (Scheme_Hash_Table *)scheme_hash_get((Scheme_Hash_Table *)ht, to_phase); - if (!pht) { - pht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set((Scheme_Hash_Table *)ht, name, (Scheme_Object *)pht); - } - - i = scheme_hash_get(pht, name); - - if (i) { - if (same_resolved_modidx(modidx, SCHEME_CAR(i)) && SAME_OBJ(srcname, SCHEME_CDR(i))) - return; /* same source */ - scheme_wrong_syntax(NULL, prnt_name, form, "duplicate import identifier"); - } else - scheme_hash_set((Scheme_Hash_Table *)ht, name, scheme_make_pair(modidx, srcname)); + binding = scheme_stx_lookup_exact(id, to_phase); + if (SCHEME_FALSEP(binding)) { + /* not bound, so import is ok */ + } else if (SCHEME_VECTORP(binding) + && SAME_OBJ(SCHEME_VEC_ELS(binding)[1], srcname) + && SAME_OBJ(SCHEME_VEC_ELS(binding)[2], scheme_make_integer(exet)) + && same_resolved_modidx(SCHEME_VEC_ELS(binding)[0], modidx)) { + /* import is redunant, but ok */ + } else if (SCHEME_VECTORP(binding) + && SCHEME_FALSEP(SCHEME_VEC_ELS(binding)[0])) { + /* shadowing a top-level definition is ok */ + } else { + scheme_wrong_syntax(NULL, id, form, "duplicate import identifier"); } } -static Scheme_Object * -do_require_execute(Scheme_Env *env, Scheme_Object *form) +static Scheme_Object *check_require_form(Scheme_Env *env, Scheme_Object *form) { Scheme_Hash_Table *ht; - Scheme_Object *rn_set, *modidx; - Scheme_Object *rest, *insp; + Scheme_Object *rest, *modidx; + Scheme_Env *tmp_env; if (env->module) modidx = env->module->self_modidx; else modidx = scheme_false; - /* Don't check for dups if we import from less that two sources: */ + /* Don't check for dups if we import from less that two sources, + since dup checking for a single source happens at that source: */ rest = SCHEME_STX_CDR(form); if (SCHEME_STX_NULLP(rest)) { rest = NULL; @@ -12710,27 +12445,55 @@ do_require_execute(Scheme_Env *env, Scheme_Object *form) scheme_prepare_exp_env(env); scheme_prepare_template_env(env); - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - rn_set = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL, insp); - if (rest) { + /* Parse into dummy environment, first, then parse + into top-level if that works without error. We need those two + steps to avoid creating some bindings before discovering a + collision, and also for checking for duplicates in the spec as + opposed to duplicates with existing imports. */ ht = scheme_make_hash_table_equal(); - } else { - ht = NULL; + + tmp_env = scheme_make_env_like(env); + scheme_prepare_exp_env(tmp_env); + scheme_prepare_template_env(tmp_env); + + /* add a scope to form so that it doesn't collide with anything: */ + form = scheme_stx_add_scope(form, scheme_new_scope(SCHEME_STX_MACRO_SCOPE), scheme_env_phase(env)); + + parse_requires(form, tmp_env->phase, modidx, tmp_env, NULL, + tmp_env->stx_context, + check_dup_require, ht, + NULL, + 0, + 1, 0, + NULL, NULL, NULL, + NULL); } + return modidx; +} + +static Scheme_Object * +do_require_execute(Scheme_Env *env, Scheme_Object *form) +{ + Scheme_Object *modidx; + + /* Check for collisions again, in case there's a difference between + compile and run times: */ + modidx = check_require_form(env, form); + + /* Use the current top-level context: */ + form = scheme_stx_push_module_context(form, env->stx_context); + parse_requires(form, env->phase, modidx, env, NULL, - rn_set, rn_set, - check_dup_require, ht, + env->stx_context, + NULL, NULL, NULL, - !env->module, 0, 0, + 0, -1, 1, NULL, NULL, NULL, NULL); - scheme_append_rename_set_to_env(rn_set, env); - return scheme_void; } @@ -12751,41 +12514,18 @@ scheme_top_level_require_jit(Scheme_Object *data) static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec) { - Scheme_Hash_Table *ht; - Scheme_Object *rn_set, *dummy, *modidx, *data, *insp; - Scheme_Env *genv; + Scheme_Object *dummy, *data; if (!scheme_is_toplevel(env)) scheme_wrong_syntax(NULL, NULL, form, "not at top-level or in module body"); /* If we get here, it must be a top-level require. */ - - /* Hash table is for checking duplicate names in require list: */ - ht = scheme_make_hash_table_equal(); - - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - rn_set = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL, insp); - - genv = env->genv; - scheme_prepare_exp_env(genv); - scheme_prepare_template_env(genv); - - if (genv->module) - modidx = genv->module->self_modidx; - else - modidx = scheme_false; - - parse_requires(form, genv->phase, modidx, genv, NULL, - rn_set, rn_set, - check_dup_require, ht, - NULL, - 0, 0, 0, - 1, 0, - NULL, NULL, NULL, - NULL); + + (void)check_require_form(env->genv, form); if (rec && rec[drec].comp) { + form = scheme_revert_use_site_scopes(form, env); + /* Dummy lets us access a top-level environment: */ dummy = scheme_make_environment_dummy(env); @@ -12818,11 +12558,13 @@ require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, intptr_t phase, Scheme_Comp_Env *cenv, - Scheme_Object *mark) + Scheme_Object *scope) { Scheme_Object *form; - form = make_require_form(module_path, phase, phase, mark); + form = make_require_form(module_path, phase, scope, cenv->genv->phase); + + form = scheme_revert_use_site_scopes(form, cenv); do_require_execute(cenv->genv, form); diff --git a/racket/src/racket/src/mzmark_compenv.inc b/racket/src/racket/src/mzmark_compenv.inc index ee590e8f4f..f9a584175e 100644 --- a/racket/src/racket/src/mzmark_compenv.inc +++ b/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->base.insp, gc); - gcMARK2(e->base.prefix, gc); - gcMARK2(e->base.next, gc); - gcMARK2(e->base.values, gc); - gcMARK2(e->base.renames, gc); - gcMARK2(e->base.uid, gc); - gcMARK2(e->base.uids, gc); - gcMARK2(e->base.dup_check, gc); - gcMARK2(e->base.intdef_name, gc); - gcMARK2(e->base.in_modidx, gc); - gcMARK2(e->base.skip_table, gc); + gcMARK2(e->genv, gc); + gcMARK2(e->insp, gc); + gcMARK2(e->prefix, gc); + gcMARK2(e->next, gc); + gcMARK2(e->scopes, gc); + gcMARK2(e->binders, gc); + gcMARK2(e->bindings, gc); + gcMARK2(e->vals, gc); + gcMARK2(e->shadower_deltas, gc); + gcMARK2(e->dup_check, gc); + gcMARK2(e->intdef_name, gc); + gcMARK2(e->in_modidx, gc); + gcMARK2(e->skip_table, gc); - gcMARK2(e->data.const_names, gc); - gcMARK2(e->data.const_vals, gc); - gcMARK2(e->data.const_uids, gc); - gcMARK2(e->data.sealed, gc); - gcMARK2(e->data.use, gc); - gcMARK2(e->data.lifts, gc); + gcMARK2(e->use, gc); + gcMARK2(e->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->base.insp, gc); - gcFIXUP2(e->base.prefix, gc); - gcFIXUP2(e->base.next, gc); - gcFIXUP2(e->base.values, gc); - gcFIXUP2(e->base.renames, gc); - gcFIXUP2(e->base.uid, gc); - gcFIXUP2(e->base.uids, gc); - gcFIXUP2(e->base.dup_check, gc); - gcFIXUP2(e->base.intdef_name, gc); - gcFIXUP2(e->base.in_modidx, gc); - gcFIXUP2(e->base.skip_table, gc); + gcFIXUP2(e->genv, gc); + gcFIXUP2(e->insp, gc); + gcFIXUP2(e->prefix, gc); + gcFIXUP2(e->next, gc); + gcFIXUP2(e->scopes, gc); + gcFIXUP2(e->binders, gc); + gcFIXUP2(e->bindings, gc); + gcFIXUP2(e->vals, gc); + gcFIXUP2(e->shadower_deltas, gc); + gcFIXUP2(e->dup_check, gc); + gcFIXUP2(e->intdef_name, gc); + gcFIXUP2(e->in_modidx, gc); + gcFIXUP2(e->skip_table, gc); - gcFIXUP2(e->data.const_names, gc); - gcFIXUP2(e->data.const_vals, gc); - gcFIXUP2(e->data.const_uids, gc); - gcFIXUP2(e->data.sealed, gc); - gcFIXUP2(e->data.use, gc); - gcFIXUP2(e->data.lifts, gc); + gcFIXUP2(e->use, gc); + gcFIXUP2(e->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 diff --git a/racket/src/racket/src/mzmark_hash.inc b/racket/src/racket/src/mzmark_hash.inc index e548bbeb38..e28f995745 100644 --- a/racket/src/racket/src/mzmark_hash.inc +++ b/racket/src/racket/src/mzmark_hash.inc @@ -1,72 +1,37 @@ /* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */ static int hash_tree_val_SIZE(void *p, struct NewGC *gc) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)p; + int popcount = hamt_popcount(ht->bitmap); return - gcBYTES_TO_WORDS(sizeof(Scheme_Hash_Tree)); + gcBYTES_TO_WORDS(HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(ht), popcount)); } static int hash_tree_val_MARK(void *p, struct NewGC *gc) { Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)p; - - gcMARK2(ht->root, gc); + int popcount = hamt_popcount(ht->bitmap); + int i; + for (i = ((SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) ? 2 : 1) * popcount; i--; ) { + gcMARK2(ht->els[i], gc); + } return - gcBYTES_TO_WORDS(sizeof(Scheme_Hash_Tree)); + gcBYTES_TO_WORDS(HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(ht), popcount)); } static int hash_tree_val_FIXUP(void *p, struct NewGC *gc) { Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)p; - - gcFIXUP2(ht->root, gc); + int popcount = hamt_popcount(ht->bitmap); + int i; + for (i = ((SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) ? 2 : 1) * popcount; i--; ) { + gcFIXUP2(ht->els[i], gc); + } return - gcBYTES_TO_WORDS(sizeof(Scheme_Hash_Tree)); + gcBYTES_TO_WORDS(HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(ht), popcount)); } #define hash_tree_val_IS_ATOMIC 0 -#define hash_tree_val_IS_CONST_SIZE 1 - - -static int mark_avl_node_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(AVLNode)); -} - -static int mark_avl_node_MARK(void *p, struct NewGC *gc) { - AVLNode *avl = (AVLNode *)p; - - /* Short-circuit on NULL pointers, which are especially likely */ - if (avl->left) { - gcMARK2(avl->left, gc); - } - if (avl->right) { - gcMARK2(avl->right, gc); - } - gcMARK2(avl->key, gc); - gcMARK2(avl->val, gc); - - return - gcBYTES_TO_WORDS(sizeof(AVLNode)); -} - -static int mark_avl_node_FIXUP(void *p, struct NewGC *gc) { - AVLNode *avl = (AVLNode *)p; - - /* Short-circuit on NULL pointers, which are especially likely */ - if (avl->left) { - gcFIXUP2(avl->left, gc); - } - if (avl->right) { - gcFIXUP2(avl->right, gc); - } - gcFIXUP2(avl->key, gc); - gcFIXUP2(avl->val, gc); - - return - gcBYTES_TO_WORDS(sizeof(AVLNode)); -} - -#define mark_avl_node_IS_ATOMIC 0 -#define mark_avl_node_IS_CONST_SIZE 1 +#define hash_tree_val_IS_CONST_SIZE 0 diff --git a/racket/src/racket/src/mzmark_print.inc b/racket/src/racket/src/mzmark_print.inc index 58950acbb2..ff4420170e 100644 --- a/racket/src/racket/src/mzmark_print.inc +++ b/racket/src/racket/src/mzmark_print.inc @@ -39,13 +39,13 @@ static int mark_marshal_tables_SIZE(void *p, struct NewGC *gc) { static int mark_marshal_tables_MARK(void *p, struct NewGC *gc) { Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p; gcMARK2(mt->symtab, gc); - gcMARK2(mt->rns, gc); - gcMARK2(mt->rn_refs, gc); gcMARK2(mt->st_refs, gc); gcMARK2(mt->st_ref_stack, gc); - gcMARK2(mt->reverse_map, gc); - gcMARK2(mt->same_map, gc); - gcMARK2(mt->shift_map, gc); + gcMARK2(mt->reachable_scopes, gc); + gcMARK2(mt->reachable_scope_stack, gc); + gcMARK2(mt->pending_reachable_ids, gc); + gcMARK2(mt->intern_map, gc); + gcMARK2(mt->identity_map, gc); gcMARK2(mt->top_map, gc); gcMARK2(mt->key_map, gc); gcMARK2(mt->delay_map, gc); @@ -60,13 +60,13 @@ static int mark_marshal_tables_MARK(void *p, struct NewGC *gc) { static int mark_marshal_tables_FIXUP(void *p, struct NewGC *gc) { Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p; gcFIXUP2(mt->symtab, gc); - gcFIXUP2(mt->rns, gc); - gcFIXUP2(mt->rn_refs, gc); gcFIXUP2(mt->st_refs, gc); gcFIXUP2(mt->st_ref_stack, gc); - gcFIXUP2(mt->reverse_map, gc); - gcFIXUP2(mt->same_map, gc); - gcFIXUP2(mt->shift_map, gc); + gcFIXUP2(mt->reachable_scopes, gc); + gcFIXUP2(mt->reachable_scope_stack, gc); + gcFIXUP2(mt->pending_reachable_ids, gc); + gcFIXUP2(mt->intern_map, gc); + gcFIXUP2(mt->identity_map, gc); gcFIXUP2(mt->top_map, gc); gcFIXUP2(mt->key_map, gc); gcFIXUP2(mt->delay_map, gc); diff --git a/racket/src/racket/src/mzmark_read.inc b/racket/src/racket/src/mzmark_read.inc index 5f833447df..1675c8d255 100644 --- a/racket/src/racket/src/mzmark_read.inc +++ b/racket/src/racket/src/mzmark_read.inc @@ -36,6 +36,7 @@ static int mark_cport_MARK(void *p, struct NewGC *gc) { gcMARK2(cp->magic_val, gc); gcMARK2(cp->shared_offsets, gc); gcMARK2(cp->delay_info, gc); + gcMARK2(cp->symtab_refs, gc); return gcBYTES_TO_WORDS(sizeof(CPort)); } @@ -52,6 +53,7 @@ static int mark_cport_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(cp->magic_val, gc); gcFIXUP2(cp->shared_offsets, gc); gcFIXUP2(cp->delay_info, gc); + gcFIXUP2(cp->symtab_refs, gc); return gcBYTES_TO_WORDS(sizeof(CPort)); } diff --git a/racket/src/racket/src/mzmark_syntax.inc b/racket/src/racket/src/mzmark_syntax.inc index 5f8af6f940..a9dbae7105 100644 --- a/racket/src/racket/src/mzmark_syntax.inc +++ b/racket/src/racket/src/mzmark_syntax.inc @@ -1,79 +1,5 @@ /* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */ -static int mark_rename_table_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Module_Renames)); -} - -static int mark_rename_table_MARK(void *p, struct NewGC *gc) { - Module_Renames *rn = (Module_Renames *)p; - gcMARK2(rn->phase, gc); - gcMARK2(rn->ht, gc); - gcMARK2(rn->nomarshal_ht, gc); - gcMARK2(rn->unmarshal_info, gc); - gcMARK2(rn->shared_pes, gc); - gcMARK2(rn->set_identity, gc); - gcMARK2(rn->marked_names, gc); - gcMARK2(rn->free_id_renames, gc); - gcMARK2(rn->insp, gc); - return - gcBYTES_TO_WORDS(sizeof(Module_Renames)); -} - -static int mark_rename_table_FIXUP(void *p, struct NewGC *gc) { - Module_Renames *rn = (Module_Renames *)p; - gcFIXUP2(rn->phase, gc); - gcFIXUP2(rn->ht, gc); - gcFIXUP2(rn->nomarshal_ht, gc); - gcFIXUP2(rn->unmarshal_info, gc); - gcFIXUP2(rn->shared_pes, gc); - gcFIXUP2(rn->set_identity, gc); - gcFIXUP2(rn->marked_names, gc); - gcFIXUP2(rn->free_id_renames, gc); - gcFIXUP2(rn->insp, gc); - return - gcBYTES_TO_WORDS(sizeof(Module_Renames)); -} - -#define mark_rename_table_IS_ATOMIC 0 -#define mark_rename_table_IS_CONST_SIZE 1 - - -static int mark_rename_table_set_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Module_Renames_Set)); -} - -static int mark_rename_table_set_MARK(void *p, struct NewGC *gc) { - Module_Renames_Set *rns = (Module_Renames_Set *)p; - gcMARK2(rns->et, gc); - gcMARK2(rns->rt, gc); - gcMARK2(rns->other_phases, gc); - gcMARK2(rns->share_marked_names, gc); - gcMARK2(rns->set_identity, gc); - gcMARK2(rns->prior_contexts, gc); - gcMARK2(rns->insp, gc); - return - gcBYTES_TO_WORDS(sizeof(Module_Renames_Set)); -} - -static int mark_rename_table_set_FIXUP(void *p, struct NewGC *gc) { - Module_Renames_Set *rns = (Module_Renames_Set *)p; - gcFIXUP2(rns->et, gc); - gcFIXUP2(rns->rt, gc); - gcFIXUP2(rns->other_phases, gc); - gcFIXUP2(rns->share_marked_names, gc); - gcFIXUP2(rns->set_identity, gc); - gcFIXUP2(rns->prior_contexts, gc); - gcFIXUP2(rns->insp, gc); - return - gcBYTES_TO_WORDS(sizeof(Module_Renames_Set)); -} - -#define mark_rename_table_set_IS_ATOMIC 0 -#define mark_rename_table_set_IS_CONST_SIZE 1 - - static int mark_srcloc_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Srcloc)); @@ -97,64 +23,96 @@ static int mark_srcloc_FIXUP(void *p, struct NewGC *gc) { #define mark_srcloc_IS_CONST_SIZE 1 -static int mark_wrapchunk_SIZE(void *p, struct NewGC *gc) { - Wrap_Chunk *wc = (Wrap_Chunk *)p; +static int mark_scope_SIZE(void *p, struct NewGC *gc) { + Scheme_Scope *m = (Scheme_Scope *)p; + int for_multi = SCHEME_SCOPE_HAS_OWNER(m); return - gcBYTES_TO_WORDS(sizeof(Wrap_Chunk) + ((wc->len - mzFLEX_DELTA) * sizeof(Scheme_Object *))); + (for_multi + ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); } -static int mark_wrapchunk_MARK(void *p, struct NewGC *gc) { - Wrap_Chunk *wc = (Wrap_Chunk *)p; - int i; - for (i = wc->len; i--; ) { - gcMARK2(wc->a[i], gc); +static int mark_scope_MARK(void *p, struct NewGC *gc) { + Scheme_Scope *m = (Scheme_Scope *)p; + int for_multi = SCHEME_SCOPE_HAS_OWNER(m); + gcMARK2(m->bindings, gc); + if (for_multi) { + gcMARK2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); + gcMARK2(((Scheme_Scope_With_Owner *)m)->phase, gc); } return - gcBYTES_TO_WORDS(sizeof(Wrap_Chunk) + ((wc->len - mzFLEX_DELTA) * sizeof(Scheme_Object *))); + (for_multi + ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); } -static int mark_wrapchunk_FIXUP(void *p, struct NewGC *gc) { - Wrap_Chunk *wc = (Wrap_Chunk *)p; - int i; - for (i = wc->len; i--; ) { - gcFIXUP2(wc->a[i], gc); +static int mark_scope_FIXUP(void *p, struct NewGC *gc) { + Scheme_Scope *m = (Scheme_Scope *)p; + int for_multi = SCHEME_SCOPE_HAS_OWNER(m); + gcFIXUP2(m->bindings, gc); + if (for_multi) { + gcFIXUP2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); + gcFIXUP2(((Scheme_Scope_With_Owner *)m)->phase, gc); } return - gcBYTES_TO_WORDS(sizeof(Wrap_Chunk) + ((wc->len - mzFLEX_DELTA) * sizeof(Scheme_Object *))); + (for_multi + ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); } -#define mark_wrapchunk_IS_ATOMIC 0 -#define mark_wrapchunk_IS_CONST_SIZE 0 +#define mark_scope_IS_ATOMIC 0 +#define mark_scope_IS_CONST_SIZE 0 -static int lex_rib_SIZE(void *p, struct NewGC *gc) { +static int mark_scope_table_SIZE(void *p, struct NewGC *gc) { return - gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); + gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); } -static int lex_rib_MARK(void *p, struct NewGC *gc) { - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; - gcMARK2(rib->rename, gc); - gcMARK2(rib->timestamp, gc); - gcMARK2(rib->sealed, gc); - gcMARK2(rib->mapped_names, gc); - gcMARK2(rib->next, gc); +static int mark_scope_table_MARK(void *p, struct NewGC *gc) { + Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; + gcMARK2(m->simple_scopes, gc); + gcMARK2(m->multi_scopes, gc); return - gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); + gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); } -static int lex_rib_FIXUP(void *p, struct NewGC *gc) { - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; - gcFIXUP2(rib->rename, gc); - gcFIXUP2(rib->timestamp, gc); - gcFIXUP2(rib->sealed, gc); - gcFIXUP2(rib->mapped_names, gc); - gcFIXUP2(rib->next, gc); +static int mark_scope_table_FIXUP(void *p, struct NewGC *gc) { + Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; + gcFIXUP2(m->simple_scopes, gc); + gcFIXUP2(m->multi_scopes, gc); return - gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); + gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); } -#define lex_rib_IS_ATOMIC 0 -#define lex_rib_IS_CONST_SIZE 1 +#define mark_scope_table_IS_ATOMIC 0 +#define mark_scope_table_IS_CONST_SIZE 1 + + +static int mark_propagate_table_SIZE(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); +} + +static int mark_propagate_table_MARK(void *p, struct NewGC *gc) { + Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; + mark_scope_table_MARK(&m->st, gc); + gcMARK2(m->prev, gc); + gcMARK2(m->phase_shift, gc); + return + gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); +} + +static int mark_propagate_table_FIXUP(void *p, struct NewGC *gc) { + Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; + mark_scope_table_FIXUP(&m->st, gc); + gcFIXUP2(m->prev, gc); + gcFIXUP2(m->phase_shift, gc); + return + gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); +} + +#define mark_propagate_table_IS_ATOMIC 0 +#define mark_propagate_table_IS_CONST_SIZE 1 diff --git a/racket/src/racket/src/mzmark_type.inc b/racket/src/racket/src/mzmark_type.inc index 549875afef..a5006620d3 100644 --- a/racket/src/racket/src/mzmark_type.inc +++ b/racket/src/racket/src/mzmark_type.inc @@ -1831,7 +1831,8 @@ static int thread_val_MARK(void *p, struct NewGC *gc) { gcMARK2(pr->returned_marks, gc); gcMARK2(pr->current_local_env, gc); - gcMARK2(pr->current_local_mark, gc); + gcMARK2(pr->current_local_scope, gc); + gcMARK2(pr->current_local_use_scope, gc); gcMARK2(pr->current_local_name, gc); gcMARK2(pr->current_local_modidx, gc); gcMARK2(pr->current_local_menv, gc); @@ -1948,7 +1949,8 @@ static int thread_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(pr->returned_marks, gc); gcFIXUP2(pr->current_local_env, gc); - gcFIXUP2(pr->current_local_mark, gc); + gcFIXUP2(pr->current_local_scope, gc); + gcFIXUP2(pr->current_local_use_scope, gc); gcFIXUP2(pr->current_local_name, gc); gcFIXUP2(pr->current_local_modidx, gc); gcFIXUP2(pr->current_local_menv, gc); @@ -2288,9 +2290,7 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) { gcMARK2(e->guard_insp, gc); gcMARK2(e->access_insp, gc); - gcMARK2(e->rename_set, gc); - gcMARK2(e->temp_marked_names, gc); - gcMARK2(e->post_ex_rename_set, gc); + gcMARK2(e->stx_context, gc); gcMARK2(e->syntax, gc); gcMARK2(e->exp_env, gc); @@ -2320,6 +2320,8 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) { gcMARK2(e->weak_self_link, gc); + gcMARK2(e->binding_names, gc); + return gcBYTES_TO_WORDS(sizeof(Scheme_Env)); } @@ -2333,9 +2335,7 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(e->guard_insp, gc); gcFIXUP2(e->access_insp, gc); - gcFIXUP2(e->rename_set, gc); - gcFIXUP2(e->temp_marked_names, gc); - gcFIXUP2(e->post_ex_rename_set, gc); + gcFIXUP2(e->stx_context, gc); gcFIXUP2(e->syntax, gc); gcFIXUP2(e->exp_env, gc); @@ -2365,6 +2365,8 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(e->weak_self_link, gc); + gcFIXUP2(e->binding_names, gc); + return gcBYTES_TO_WORDS(sizeof(Scheme_Env)); } @@ -2491,6 +2493,7 @@ static int resolve_prefix_val_MARK(void *p, struct NewGC *gc) { gcMARK2(rp->toplevels, gc); gcMARK2(rp->stxes, gc); gcMARK2(rp->delay_info_rpair, gc); + gcMARK2(rp->src_insp_desc, gc); return gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); @@ -2501,6 +2504,7 @@ static int resolve_prefix_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(rp->toplevels, gc); gcFIXUP2(rp->stxes, gc); gcFIXUP2(rp->delay_info_rpair, gc); + gcFIXUP2(rp->src_insp_desc, gc); return gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); @@ -2577,11 +2581,11 @@ static int stx_val_MARK(void *p, struct NewGC *gc) { Scheme_Stx *stx = (Scheme_Stx *)p; gcMARK2(stx->val, gc); gcMARK2(stx->srcloc, gc); - gcMARK2(stx->wraps, gc); + gcMARK2(stx->scopes, gc); + gcMARK2(stx->u.to_propagate, gc); + gcMARK2(stx->shifts, gc); gcMARK2(stx->taints, gc); gcMARK2(stx->props, gc); - if (!(MZ_OPT_HASH_KEY(&(stx)->iso) & STX_SUBSTX_FLAG)) - gcMARK2(stx->u.modinfo_cache, gc); return gcBYTES_TO_WORDS(sizeof(Scheme_Stx)); } @@ -2590,11 +2594,11 @@ static int stx_val_FIXUP(void *p, struct NewGC *gc) { Scheme_Stx *stx = (Scheme_Stx *)p; gcFIXUP2(stx->val, gc); gcFIXUP2(stx->srcloc, gc); - gcFIXUP2(stx->wraps, gc); + gcFIXUP2(stx->scopes, gc); + gcFIXUP2(stx->u.to_propagate, gc); + gcFIXUP2(stx->shifts, gc); gcFIXUP2(stx->taints, gc); gcFIXUP2(stx->props, gc); - if (!(MZ_OPT_HASH_KEY(&(stx)->iso) & STX_SUBSTX_FLAG)) - gcFIXUP2(stx->u.modinfo_cache, gc); return gcBYTES_TO_WORDS(sizeof(Scheme_Stx)); } @@ -2655,6 +2659,10 @@ static int module_val_MARK(void *p, struct NewGC *gc) { gcMARK2(m->self_modidx, gc); + gcMARK2(m->binding_names, gc); + gcMARK2(m->et_binding_names, gc); + gcMARK2(m->other_binding_names, gc); + gcMARK2(m->insp, gc); gcMARK2(m->lang_info, gc); @@ -2705,6 +2713,10 @@ static int module_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(m->self_modidx, gc); + gcFIXUP2(m->binding_names, gc); + gcFIXUP2(m->et_binding_names, gc); + gcFIXUP2(m->other_binding_names, gc); + gcFIXUP2(m->insp, gc); gcFIXUP2(m->lang_info, gc); diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 5bfd37cbe5..ae4c9cda28 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -738,7 +738,8 @@ thread_val { gcMARK2(pr->returned_marks, gc); gcMARK2(pr->current_local_env, gc); - gcMARK2(pr->current_local_mark, gc); + gcMARK2(pr->current_local_scope, gc); + gcMARK2(pr->current_local_use_scope, gc); gcMARK2(pr->current_local_name, gc); gcMARK2(pr->current_local_modidx, gc); gcMARK2(pr->current_local_menv, gc); @@ -920,9 +921,7 @@ namespace_val { gcMARK2(e->guard_insp, gc); gcMARK2(e->access_insp, gc); - gcMARK2(e->rename_set, gc); - gcMARK2(e->temp_marked_names, gc); - gcMARK2(e->post_ex_rename_set, gc); + gcMARK2(e->stx_context, gc); gcMARK2(e->syntax, gc); gcMARK2(e->exp_env, gc); @@ -952,6 +951,8 @@ namespace_val { gcMARK2(e->weak_self_link, gc); + gcMARK2(e->binding_names, gc); + size: gcBYTES_TO_WORDS(sizeof(Scheme_Env)); } @@ -1000,6 +1001,7 @@ resolve_prefix_val { gcMARK2(rp->toplevels, gc); gcMARK2(rp->stxes, gc); gcMARK2(rp->delay_info_rpair, gc); + gcMARK2(rp->src_insp_desc, gc); size: gcBYTES_TO_WORDS(sizeof(Resolve_Prefix)); @@ -1032,11 +1034,11 @@ stx_val { Scheme_Stx *stx = (Scheme_Stx *)p; gcMARK2(stx->val, gc); gcMARK2(stx->srcloc, gc); - gcMARK2(stx->wraps, gc); + gcMARK2(stx->scopes, gc); + gcMARK2(stx->u.to_propagate, gc); + gcMARK2(stx->shifts, gc); gcMARK2(stx->taints, gc); gcMARK2(stx->props, gc); - if (!(MZ_OPT_HASH_KEY(&(stx)->iso) & STX_SUBSTX_FLAG)) - gcMARK2(stx->u.modinfo_cache, gc); size: gcBYTES_TO_WORDS(sizeof(Scheme_Stx)); } @@ -1074,6 +1076,10 @@ module_val { gcMARK2(m->self_modidx, gc); + gcMARK2(m->binding_names, gc); + gcMARK2(m->et_binding_names, gc); + gcMARK2(m->other_binding_names, gc); + gcMARK2(m->insp, gc); gcMARK2(m->lang_info, gc); @@ -1244,30 +1250,27 @@ START compenv; mark_comp_env { mark: - 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->base.insp, gc); - gcMARK2(e->base.prefix, gc); - gcMARK2(e->base.next, gc); - gcMARK2(e->base.values, gc); - gcMARK2(e->base.renames, gc); - gcMARK2(e->base.uid, gc); - gcMARK2(e->base.uids, gc); - gcMARK2(e->base.dup_check, gc); - gcMARK2(e->base.intdef_name, gc); - gcMARK2(e->base.in_modidx, gc); - gcMARK2(e->base.skip_table, gc); + gcMARK2(e->genv, gc); + gcMARK2(e->insp, gc); + gcMARK2(e->prefix, gc); + gcMARK2(e->next, gc); + gcMARK2(e->scopes, gc); + gcMARK2(e->binders, gc); + gcMARK2(e->bindings, gc); + gcMARK2(e->vals, gc); + gcMARK2(e->shadower_deltas, gc); + gcMARK2(e->dup_check, gc); + gcMARK2(e->intdef_name, gc); + gcMARK2(e->in_modidx, gc); + gcMARK2(e->skip_table, gc); - gcMARK2(e->data.const_names, gc); - gcMARK2(e->data.const_vals, gc); - gcMARK2(e->data.const_uids, gc); - gcMARK2(e->data.sealed, gc); - gcMARK2(e->data.use, gc); - gcMARK2(e->data.lifts, gc); + gcMARK2(e->use, gc); + gcMARK2(e->lifts, gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Full_Comp_Env)); + gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env)); } END compenv; @@ -1517,31 +1520,16 @@ END fun; START hash; hash_tree_val { - mark: Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)p; - - gcMARK2(ht->root, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Hash_Tree)); -} - -mark_avl_node { + int popcount = hamt_popcount(ht->bitmap); mark: - AVLNode *avl = (AVLNode *)p; - - /* Short-circuit on NULL pointers, which are especially likely */ - if (avl->left) { - gcMARK2(avl->left, gc); + int i; + for (i = ((SCHEME_HASHTR_FLAGS(ht) & HASHTR_HAS_VAL) ? 2 : 1) * popcount; i--; ) { + gcMARK2(ht->els[i], gc); } - if (avl->right) { - gcMARK2(avl->right, gc); - } - gcMARK2(avl->key, gc); - gcMARK2(avl->val, gc); size: - gcBYTES_TO_WORDS(sizeof(AVLNode)); + gcBYTES_TO_WORDS(HASH_TREE_RECORD_SIZE(SCHEME_HASHTR_KIND(ht), popcount)); } END hash; @@ -1808,13 +1796,13 @@ mark_marshal_tables { mark: Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p; gcMARK2(mt->symtab, gc); - gcMARK2(mt->rns, gc); - gcMARK2(mt->rn_refs, gc); gcMARK2(mt->st_refs, gc); gcMARK2(mt->st_ref_stack, gc); - gcMARK2(mt->reverse_map, gc); - gcMARK2(mt->same_map, gc); - gcMARK2(mt->shift_map, gc); + gcMARK2(mt->reachable_scopes, gc); + gcMARK2(mt->reachable_scope_stack, gc); + gcMARK2(mt->pending_reachable_ids, gc); + gcMARK2(mt->intern_map, gc); + gcMARK2(mt->identity_map, gc); gcMARK2(mt->top_map, gc); gcMARK2(mt->key_map, gc); gcMARK2(mt->delay_map, gc); @@ -2281,6 +2269,7 @@ mark_cport { gcMARK2(cp->magic_val, gc); gcMARK2(cp->shared_offsets, gc); gcMARK2(cp->delay_info, gc); + gcMARK2(cp->symtab_refs, gc); size: gcBYTES_TO_WORDS(sizeof(CPort)); } @@ -2396,36 +2385,6 @@ END string; START syntax; -mark_rename_table { - mark: - Module_Renames *rn = (Module_Renames *)p; - gcMARK2(rn->phase, gc); - gcMARK2(rn->ht, gc); - gcMARK2(rn->nomarshal_ht, gc); - gcMARK2(rn->unmarshal_info, gc); - gcMARK2(rn->shared_pes, gc); - gcMARK2(rn->set_identity, gc); - gcMARK2(rn->marked_names, gc); - gcMARK2(rn->free_id_renames, gc); - gcMARK2(rn->insp, gc); - size: - gcBYTES_TO_WORDS(sizeof(Module_Renames)); -} - -mark_rename_table_set { - mark: - Module_Renames_Set *rns = (Module_Renames_Set *)p; - gcMARK2(rns->et, gc); - gcMARK2(rns->rt, gc); - gcMARK2(rns->other_phases, gc); - gcMARK2(rns->share_marked_names, gc); - gcMARK2(rns->set_identity, gc); - gcMARK2(rns->prior_contexts, gc); - gcMARK2(rns->insp, gc); - size: - gcBYTES_TO_WORDS(sizeof(Module_Renames_Set)); -} - mark_srcloc { mark: Scheme_Stx_Srcloc *s = (Scheme_Stx_Srcloc *)p; @@ -2434,27 +2393,38 @@ mark_srcloc { gcBYTES_TO_WORDS(sizeof(Scheme_Stx_Srcloc)); } -mark_wrapchunk { - Wrap_Chunk *wc = (Wrap_Chunk *)p; +mark_scope { + Scheme_Scope *m = (Scheme_Scope *)p; + int for_multi = SCHEME_SCOPE_HAS_OWNER(m); mark: - int i; - for (i = wc->len; i--; ) { - gcMARK2(wc->a[i], gc); + gcMARK2(m->bindings, gc); + if (for_multi) { + gcMARK2(((Scheme_Scope_With_Owner *)m)->owner_multi_scope, gc); + gcMARK2(((Scheme_Scope_With_Owner *)m)->phase, gc); } size: - gcBYTES_TO_WORDS(sizeof(Wrap_Chunk) + ((wc->len - mzFLEX_DELTA) * sizeof(Scheme_Object *))); + (for_multi + ? gcBYTES_TO_WORDS(sizeof(Scheme_Scope_With_Owner)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Scope))); } -lex_rib { +mark_scope_table { mark: - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)p; - gcMARK2(rib->rename, gc); - gcMARK2(rib->timestamp, gc); - gcMARK2(rib->sealed, gc); - gcMARK2(rib->mapped_names, gc); - gcMARK2(rib->next, gc); + Scheme_Scope_Table *m = (Scheme_Scope_Table *)p; + gcMARK2(m->simple_scopes, gc); + gcMARK2(m->multi_scopes, gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); + gcBYTES_TO_WORDS(sizeof(Scheme_Scope_Table)); +} + +mark_propagate_table { + mark: + Scheme_Propagate_Table *m = (Scheme_Propagate_Table *)p; + mark_scope_table_MARK(&m->st, gc); + gcMARK2(m->prev, gc); + gcMARK2(m->phase_shift, gc); + size: + gcBYTES_TO_WORDS(sizeof(Scheme_Propagate_Table)); } END syntax; diff --git a/racket/src/racket/src/optimize.c b/racket/src/racket/src/optimize.c index 91121ff308..0239a6f157 100644 --- a/racket/src/racket/src/optimize.c +++ b/racket/src/racket/src/optimize.c @@ -6357,6 +6357,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i /* We can simplify letrec to let* */ SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE; SCHEME_LET_FLAGS(head) |= SCHEME_LET_STAR; + is_rec = 0; } { diff --git a/racket/src/racket/src/portfun.c b/racket/src/racket/src/portfun.c index c46d335260..520750eb0d 100644 --- a/racket/src/racket/src/portfun.c +++ b/racket/src/racket/src/portfun.c @@ -4730,8 +4730,8 @@ static Scheme_Object *do_load_handler(void *data) /* ... end special support for module loading ... */ - if (!as_module && genv->rename_set) - obj = scheme_add_rename(obj, genv->rename_set); + if (!as_module && genv->stx_context) + obj = scheme_top_introduce(obj, genv); last_val = _scheme_apply_multi_with_prompt(scheme_get_param(config, MZCONFIG_EVAL_HANDLER), 1, &obj); diff --git a/racket/src/racket/src/print.c b/racket/src/racket/src/print.c index 116a8a6655..002f9412ab 100644 --- a/racket/src/racket/src/print.c +++ b/racket/src/racket/src/print.c @@ -544,7 +544,8 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht || scheme_is_writable_struct(obj))) || (pp->print_hash_table && (SAME_TYPE(t, scheme_hash_table_type) - || SAME_TYPE(t, scheme_hash_tree_type)))) { + || ((t >= scheme_hash_tree_type) + && (t <= scheme_hash_tree_indirection_type))))) { val = scheme_hash_get(ht, obj); if (val) return SCHEME_INT_VAL(val); @@ -1618,7 +1619,7 @@ static void print_symtab_ref(PrintParams *pp, Scheme_Object *idx) static int add_symtab(Scheme_Marshal_Tables *mt, Scheme_Object *obj) { - if (!mt->pass) { + if (mt->pass < 1) { int l; l = mt->symtab->count + 1; scheme_hash_set(mt->symtab, obj, scheme_make_integer(l)); @@ -1692,36 +1693,51 @@ void scheme_marshal_push_refs(Scheme_Marshal_Tables *mt) Scheme_Object *p; Scheme_Hash_Table *st_refs; - p = scheme_make_pair((Scheme_Object *)mt->st_refs, - mt->st_ref_stack); - mt->st_ref_stack = p; - - st_refs = scheme_make_hash_table(SCHEME_hash_ptr); - - mt->st_refs = st_refs; + if (mt->pass >= 0) { + p = scheme_make_pair((Scheme_Object *)mt->st_refs, + mt->st_ref_stack); + mt->st_ref_stack = p; + + st_refs = scheme_make_hash_table(SCHEME_hash_ptr); + + mt->st_refs = st_refs; + } } void scheme_marshal_pop_refs(Scheme_Marshal_Tables *mt, int keep) { Scheme_Hash_Table *st_refs = mt->st_refs; - mt->st_refs = (Scheme_Hash_Table *)SCHEME_CAR(mt->st_ref_stack); - mt->st_ref_stack = SCHEME_CDR(mt->st_ref_stack); + if (mt->pass >= 0) { + mt->st_refs = (Scheme_Hash_Table *)SCHEME_CAR(mt->st_ref_stack); + mt->st_ref_stack = SCHEME_CDR(mt->st_ref_stack); - if (keep) { - if (!mt->st_refs->count) - mt->st_refs = st_refs; - else { - intptr_t i; - for (i = 0; i < st_refs->size; i++) { - if (st_refs->vals[i]) { - scheme_hash_set(mt->st_refs, st_refs->keys[i], st_refs->vals[i]); + if (keep) { + if (!mt->st_refs->count) + mt->st_refs = st_refs; + else { + intptr_t i; + for (i = 0; i < st_refs->size; i++) { + if (st_refs->vals[i]) { + scheme_hash_set(mt->st_refs, st_refs->keys[i], st_refs->vals[i]); + } } } } } } +Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v) +{ + Scheme_Object *b; + + b = scheme_alloc_small_object(); + b->type = scheme_marshal_share_type; + SCHEME_PTR_VAL(b) = v; + + return b; +} + static void print_escaped(PrintParams *pp, int notdisplay, Scheme_Object *obj, Scheme_Hash_Table *ht, Scheme_Marshal_Tables *mt, int shared) @@ -2415,12 +2431,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, closed = 1; } - else if (compact && SCHEME_HASHTP(obj)) - { - /* since previous case didn't catch this table, it has a 0x1 flag - and should be marshalled as #t */ - print_compact(pp, CPT_TRUE); - } else if (SAME_OBJ(obj, scheme_true)) { if (compact) @@ -2939,21 +2949,101 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, cannot_print(pp, notdisplay, obj, ht, compact); } } - else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) + else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_inspector_type)) + { + /* For use by syntax objects, we map each inspector to an uninterned symbol */ + Scheme_Object *sym; + if (!mt->identity_map) { + Scheme_Hash_Table *id_map; + id_map = scheme_make_hash_table(SCHEME_hash_ptr); + mt->identity_map = id_map; + } + sym = scheme_hash_get(mt->identity_map, obj); + if (!sym) { + int id = mt->inspector_counter++; + char buf[32]; + sprintf(buf, "insp%d", id); + sym = scheme_make_symbol(buf); /* uninterned */ + scheme_hash_set(mt->identity_map, obj, sym); + } + closed = print(sym, notdisplay, 1, ht, mt, pp); + } + else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_scope_type) + && (compact || pp->print_unreadable)) + { + if (compact) { + Scheme_Object *idx; + + idx = scheme_stx_root_scope(); + if (SAME_OBJ(idx, obj)) { + print_compact(pp, CPT_ROOT_SCOPE); + } else { + idx = get_symtab_idx(mt, obj); + if (idx) { + print_symtab_ref(pp, idx); + } else { + print_compact(pp, CPT_SCOPE); + print_symtab_set(pp, mt, obj); + idx = get_symtab_idx(mt, obj); + print(scheme_scope_marshal_content(obj, mt), notdisplay, 1, ht, mt, pp); + } + } + } else { + print_utf8_string(pp, "#", 0, 1); + } + } + else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) { Scheme_Object *idx; - idx = get_symtab_idx(mt, obj); - if (idx) { - print_symtab_ref(pp, idx); + if (compact) { + idx = get_symtab_idx(mt, obj); + if (idx) { + print_symtab_ref(pp, idx); + } else { + print_compact(pp, CPT_MODULE_INDEX); + print(((Scheme_Modidx *)obj)->path, notdisplay, 1, ht, mt, pp); + print(((Scheme_Modidx *)obj)->base, notdisplay, 1, ht, mt, pp); + if (SCHEME_FALSEP(((Scheme_Modidx *)obj)->path) + && SCHEME_FALSEP(((Scheme_Modidx *)obj)->base)) + print(scheme_modidx_submodule(obj), notdisplay, 1, ht, mt, pp); + symtab_set(pp, mt, obj); + } } else { - print_compact(pp, CPT_MODULE_INDEX); - print(((Scheme_Modidx *)obj)->path, notdisplay, 1, ht, mt, pp); - print(((Scheme_Modidx *)obj)->base, notdisplay, 1, ht, mt, pp); - if (SCHEME_FALSEP(((Scheme_Modidx *)obj)->path) - && SCHEME_FALSEP(((Scheme_Modidx *)obj)->base)) - print(scheme_modidx_submodule(obj), notdisplay, 1, ht, mt, pp); - symtab_set(pp, mt, obj); + Scheme_Object *l = scheme_null; + Scheme_Modidx *modidx = (Scheme_Modidx *)obj; + print_utf8_string(pp, "#path)) { + l = scheme_make_pair(modidx->path, l); + if (SCHEME_FALSEP(modidx->base)) + break; + else if (SAME_TYPE(SCHEME_TYPE(modidx->base), scheme_resolved_module_path_type)) { + l = scheme_make_pair(modidx->base, l); + break; + } + modidx = (Scheme_Modidx *)modidx->base; + } + if (0 && SCHEME_FALSEP(modidx->path)) { + /* use hash code as identity of ending "self": */ + uintptr_t key; + key = scheme_hash_key((Scheme_Object *)modidx); + l = scheme_make_pair(scheme_make_integer_value_from_unsigned(key), + l); + } + l = scheme_reverse(l); + print(l, 1, 0, ht, mt, pp); + print_utf8_string(pp, ">", 0, 1); } } else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type)) @@ -3167,7 +3257,9 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, } else { key = SCHEME_PTR_VAL(obj); - if (!mt->pass) { + if (mt->pass < 0) { + /* nothing to do, yet */ + } else if (!mt->pass) { if (!mt->delay_map) { Scheme_Hash_Table *delay_map; delay_map = scheme_make_hash_table(SCHEME_hash_ptr); @@ -3188,6 +3280,26 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, set_symtab_shared(mt, obj); } } + else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_marshal_share_type)) + { + if (compact) { + Scheme_Object *idx; + + idx = get_symtab_idx(mt, obj); + if (idx) { + print_symtab_ref(pp, idx); + } else { + int l; + l = add_symtab(mt, obj); + obj = SCHEME_PTR_VAL(obj); + if (l) + print_general_symtab_ref(pp, scheme_make_integer(l), CPT_SHARED); + print(obj, notdisplay, 1, ht, mt, pp); + } + } else { + print(SCHEME_PTR_VAL(obj), notdisplay, 0, ht, mt, pp); + } + } else if (!compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_compilation_top_type) && SAME_TYPE(SCHEME_TYPE(((Scheme_Compilation_Top *)obj)->code), scheme_module_type) @@ -3287,15 +3399,32 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, if (compact) closed = print(v, notdisplay, 1, NULL, mt, pp); else { - Scheme_Hash_Table *st_refs, *symtab, *rns, *tht; + Scheme_Hash_Table *st_refs, *symtab, *reachable_scopes; intptr_t *shared_offsets; intptr_t st_len, j, shared_offset, start_offset; mt = MALLOC_ONE_RT(Scheme_Marshal_Tables); SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info); - scheme_current_thread->current_mt = mt; + /* "Print" the string once to find out which scopes are reachable; + dropping unreachable scopes drops potentialy large binding tables. */ + mt->pass = -1; + reachable_scopes = scheme_make_hash_table(SCHEME_hash_ptr); + mt->reachable_scopes = reachable_scopes; + mt->reachable_scope_stack = scheme_null; + symtab = scheme_make_hash_table(SCHEME_hash_ptr); + mt->symtab = symtab; + print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 0, NULL); + scheme_iterate_reachable_scopes(mt); + + mt->pending_reachable_ids = NULL; + + mt = MALLOC_ONE_RT(Scheme_Marshal_Tables); + SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info); + scheme_current_thread->current_mt = mt; + mt->reachable_scopes = reachable_scopes; + /* Track which shared values are referenced: */ st_refs = scheme_make_hash_table(SCHEME_hash_ptr); mt->st_refs = st_refs; @@ -3308,11 +3437,6 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, later passes. */ symtab = scheme_make_hash_table(SCHEME_hash_ptr); mt->symtab = symtab; - rns = scheme_make_hash_table(SCHEME_hash_ptr); - mt->rns = rns; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - mt->shift_map = tht; - mt->reverse_map = NULL; mt->pass = 0; scheme_hash_set(symtab, scheme_void, scheme_true); /* indicates registration phase */ print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 0, NULL); @@ -3327,10 +3451,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, mt->shared_offsets = shared_offsets; symtab = scheme_make_hash_table(SCHEME_hash_ptr); mt->symtab = symtab; - rns = scheme_make_hash_table(SCHEME_hash_ptr); - mt->rns = rns; - mt->reverse_map = NULL; - mt->top_map = NULL; + mt->top_map = NULL; mt->pass = 1; print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 1, &st_len); @@ -3338,10 +3459,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, /* "Print" the string again to get a measurement and symtab size. */ symtab = scheme_make_hash_table(SCHEME_hash_ptr); mt->symtab = symtab; - rns = scheme_make_hash_table(SCHEME_hash_ptr); - mt->rns = rns; - mt->reverse_map = NULL; - mt->top_map = NULL; + mt->top_map = NULL; mt->pass = 2; print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, -1, &st_len); @@ -3377,14 +3495,11 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, print_number(pp, st_len); print_number(pp, slen); - /* Make symtab and rns again to ensure the same results + /* Make symtab again to ensure the same results for the final print: */ symtab = scheme_make_hash_table(SCHEME_hash_ptr); mt->symtab = symtab; - rns = scheme_make_hash_table(SCHEME_hash_ptr); - mt->rns = rns; - mt->reverse_map = NULL; - mt->top_map = NULL; + mt->top_map = NULL; mt->pass = 3; start_offset = pp->print_offset; diff --git a/racket/src/racket/src/read.c b/racket/src/racket/src/read.c index 6670a4ebd5..9d3323c25f 100644 --- a/racket/src/racket/src/read.c +++ b/racket/src/racket/src/read.c @@ -2216,8 +2216,11 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, } /* Create `t' to be overwritten, and create `base' to extend. */ - t = scheme_make_hash_tree(kind); base = scheme_make_hash_tree(kind); + if (SCHEME_NULLP(lst)) + t = base; + else + t = scheme_make_hash_tree_placeholder(kind); result = (Scheme_Object *)t; scheme_hash_set(dht, obj, result); @@ -2231,9 +2234,9 @@ static Scheme_Object *resolve_references(Scheme_Object *obj, base = scheme_hash_tree_set(base, key, val); } - - t->count = base->count; - t->root = base->root; + + if (base->count) + scheme_hash_tree_tie_placeholder(t, base); } else if (SCHEME_HASHTP(obj)) { int i; Scheme_Object *key, *val, *l = scheme_null, *orig_l; @@ -4379,6 +4382,7 @@ typedef struct CPort { int unsafe_ok; Scheme_Object *orig_port; Scheme_Hash_Table **ht; + Scheme_Object *symtab_refs; Scheme_Unmarshal_Tables *ut; Scheme_Object **symtab; Scheme_Object *magic_sym, *magic_val; @@ -4415,6 +4419,27 @@ static void unsafe_disallowed(struct CPort *port) "read (compiled): unsafe values disallowed"); } +static void make_ut(CPort *port) +{ + Scheme_Unmarshal_Tables *ut; + Scheme_Hash_Table *rht; + char *decoded; + + ut = MALLOC_ONE_RT(Scheme_Unmarshal_Tables); + SET_REQUIRED_TAG(ut->type = scheme_rt_unmarshal_info); + port->ut = ut; + ut->rp = port; + if (port->delay_info) + port->delay_info->ut = ut; + + decoded = (char *)scheme_malloc_atomic(port->symtab_size); + memset(decoded, 0, port->symtab_size); + ut->decoded = decoded; + + rht = scheme_make_hash_table(SCHEME_hash_ptr); + port->ut->rns = rht; +} + /* Since read_compact_number is called often, we want it to be a cheap call in 3m, so avoid anything that allocated --- even error reporting, since we can make up a valid number. */ @@ -4574,6 +4599,29 @@ static Scheme_Object *read_compact_escape(CPort *port) return read_escape_from_string(s, len, port->relto, port->ht); } +static Scheme_Object *resolve_symtab_refs(Scheme_Object *v, CPort *port) +{ + Scheme_Object *l; + + if (SCHEME_NULLP(port->symtab_refs)) + return v; + + v = scheme_make_pair(v, port->symtab_refs); + + v = resolve_references(v, port->orig_port, NULL, + scheme_make_hash_table(SCHEME_hash_ptr), + scheme_make_hash_table(SCHEME_hash_ptr), + 0, 0); + + for (l = SCHEME_CDR(v); !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + port->symtab[SCHEME_INT_VAL(SCHEME_CAR(SCHEME_CAR(l)))] = SCHEME_CDR(SCHEME_CAR(l)); + } + + port->symtab_refs = scheme_null; + + return SCHEME_CAR(v); +} + static Scheme_Object *read_compact(CPort *port, int use_stack); static Scheme_Object *read_compact_k(void) @@ -4775,12 +4823,12 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) l = scheme_make_pair(scheme_make_pair(k, v), l); } - if (!(*port->ht)) { - /* So that resolve_references is called to build the table: */ - Scheme_Hash_Table *tht; - tht = scheme_make_hash_table(SCHEME_hash_ptr); - *(port->ht) = tht; - } + if (!(*port->ht)) { + /* So that resolve_references is called to build the table: */ + Scheme_Hash_Table *tht; + tht = scheme_make_hash_table(SCHEME_hash_ptr); + *(port->ht) = tht; + } /* Let resolve_references complete the table construction: */ v = scheme_alloc_object(); @@ -4793,32 +4841,17 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) { Scheme_Hash_Table *save_ht; - if (!port->ut) { - Scheme_Unmarshal_Tables *ut; - Scheme_Hash_Table *rht; - char *decoded; - - ut = MALLOC_ONE_RT(Scheme_Unmarshal_Tables); - SET_REQUIRED_TAG(ut->type = scheme_rt_unmarshal_info); - port->ut = ut; - ut->rp = port; - if (port->delay_info) - port->delay_info->ut = ut; - - decoded = (char *)scheme_malloc_atomic(port->symtab_size); - memset(decoded, 0, port->symtab_size); - ut->decoded = decoded; - - rht = scheme_make_hash_table(SCHEME_hash_ptr); - port->ut->rns = rht; - } + if (!port->ut) + make_ut(port); save_ht = *port->ht; *port->ht = NULL; v = read_compact(port, 1); - if (*port->ht) { + if (!SCHEME_NULLP(port->symtab_refs)) + v = resolve_symtab_refs(v, port); + else if (*port->ht) { *port->ht = NULL; v = resolve_references(v, port->orig_port, NULL, scheme_make_hash_table(SCHEME_hash_ptr), @@ -5191,6 +5224,56 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) return (Scheme_Object *)app; } break; + case CPT_SCOPE: + { + Scheme_Object *v2; + + if (!port->ut) + make_ut(port); + + v = scheme_box(scheme_false); + l = read_compact_number(port); + + if (l) { + RANGE_POS_CHECK(l, < port->symtab_size); + port->symtab[l] = v; + } + + v2 = read_compact(port, 0); + SCHEME_BOX_VAL(v) = v2; + + return v; + } + break; + case CPT_ROOT_SCOPE: + return scheme_stx_root_scope(); + case CPT_SHARED: + { + Scheme_Object *ph; + + if (!port->ut) + make_ut(port); + + ph = scheme_alloc_small_object(); + ph->type = scheme_placeholder_type; + SCHEME_PTR_VAL(ph) = scheme_false; + + l = read_compact_number(port); + RANGE_POS_CHECK(l, < port->symtab_size); + + port->symtab[l] = ph; + + v = scheme_make_pair(scheme_make_pair(scheme_make_integer(l), + ph), + port->symtab_refs); + port->symtab_refs = v; + + v = read_compact(port, 0); + SCHEME_PTR_VAL(ph) = v; + + return ph; + } + break; default: v = NULL; break; @@ -5581,6 +5664,8 @@ static Scheme_Object *read_compiled(Scheme_Object *port, rp->shared_offsets = so; rp->delay_info = delay_info; + rp->symtab_refs = scheme_null; + if (!delay_info) { /* Read shared parts: */ intptr_t j, len; @@ -5589,6 +5674,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port, for (j = 1; j < len; j++) { if (!symtab[j]) { v = read_compact(rp, 0); + v = resolve_symtab_refs(v, rp); symtab[j] = v; } else { if (j+1 < len) @@ -5859,6 +5945,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in rp->relto = delay_info->relto; rp->shared_offsets = delay_info->shared_offsets; rp->delay_info = delay_info; + rp->symtab_refs = scheme_null; rp->pos = delay_info->shared_offsets[which - 1]; @@ -5877,6 +5964,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in scheme_current_thread->reading_delayed = NULL; /* Clean up: */ + v = resolve_symtab_refs(v, rp); delay_info->current_rp = old_rp; if (delay_info->ut) @@ -6659,7 +6747,7 @@ static Scheme_Object *expected_lang(const char *prefix, int ch, } /*========================================================================*/ -/* precise GC traversers */ +/* precise GC traversers g*/ /*========================================================================*/ #ifdef MZ_PRECISE_GC diff --git a/racket/src/racket/src/resolve.c b/racket/src/racket/src/resolve.c index 4c26880e62..0d5ab6f2e8 100644 --- a/racket/src/racket/src/resolve.c +++ b/racket/src/racket/src/resolve.c @@ -753,7 +753,7 @@ static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_In names = SCHEME_VEC_ELS(data)[2]; val = SCHEME_VEC_ELS(data)[3]; - rp = scheme_resolve_prefix(1, cp, 1); + rp = scheme_resolve_prefix(1, cp, info->prefix->src_insp_desc); dummy = scheme_resolve_expr(dummy, info); @@ -800,7 +800,7 @@ static Scheme_Object *begin_for_syntax_resolve(Scheme_Object *data, Resolve_Info dummy = SCHEME_VEC_ELS(data)[1]; l = SCHEME_VEC_ELS(data)[2]; - rp = scheme_resolve_prefix(1, cp, 1); + rp = scheme_resolve_prefix(1, cp, info->prefix->src_insp_desc); dummy = scheme_resolve_expr(dummy, info); @@ -2257,6 +2257,27 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, /* module */ /*========================================================================*/ +static int has_syntax_constants(Scheme_Module *m) +{ + int i, j; + Scheme_Object *e; + Resolve_Prefix *rp; + + if (m->prefix->num_stxes) + return 1; + + for (j = m->num_phases; j-- > 1; ) { + for (i = SCHEME_VEC_SIZE(m->bodies[j]); i--; ) { + e = SCHEME_VEC_ELS(m->bodies[j])[i]; + rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; + if (rp->num_stxes) + return 1; + } + } + + return 0; +} + static Scheme_Object * module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) { @@ -2271,7 +2292,7 @@ module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) return (Scheme_Object *)m; } - rp = scheme_resolve_prefix(0, m->comp_prefix, 1); + rp = scheme_resolve_prefix(0, m->comp_prefix, m->insp); m->comp_prefix = NULL; b = scheme_resolve_expr(m->dummy, old_rslv); @@ -2313,6 +2334,49 @@ module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) /* Exp-time body was resolved during compilation */ + /* If there are no syntax objects in the module, then there are no + macros that can reach bindings in the bindings table whose marks + are not a subset of the module context. */ + if (m->rn_stx && SCHEME_STXP(m->rn_stx) && !has_syntax_constants(m)) { + if (m->binding_names) { + b = scheme_prune_bindings_table(m->binding_names, m->rn_stx, scheme_make_integer(0)); + m->binding_names = b; + } + if (m->et_binding_names) { + b = scheme_prune_bindings_table(m->et_binding_names, m->rn_stx, scheme_make_integer(1)); + m->et_binding_names = b; + } + if (m->other_binding_names) { + intptr_t i; + Scheme_Object *k, *val; + Scheme_Hash_Tree *ht; + + ht = scheme_make_hash_tree(1); + + if (SCHEME_HASHTRP(m->other_binding_names)) { + Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)m->other_binding_names; + 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); + val = scheme_prune_bindings_table(val, m->rn_stx, k); + ht = scheme_hash_tree_set(ht, k, val); + } + } else { + Scheme_Hash_Table *t = (Scheme_Hash_Table *)m->other_binding_names; + for (i = t->size; i--; ) { + if (t->vals[i]) { + k = t->keys[i]; + val = t->vals[i]; + val = scheme_prune_bindings_table(val, m->rn_stx, k); + ht = scheme_hash_tree_set(ht, k, val); + } + } + } + + m->other_binding_names = (Scheme_Object *)ht; + } + } + + { /* resolve submodules */ int k; @@ -2494,10 +2558,10 @@ Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info) /* compile-time env for resolve */ /*========================================================================*/ -Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify) +Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, Scheme_Object *insp_desc) { Resolve_Prefix *rp; - Scheme_Object **tls, **stxes, *simplify_cache, *m; + Scheme_Object **tls, **stxes, *m; Scheme_Hash_Table *ht; int i; @@ -2535,21 +2599,17 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify) } } - if (simplify) - simplify_cache = scheme_new_stx_simplify_cache(); - else - simplify_cache = NULL; - ht = cp->stxes; if (ht) { for (i = 0; i < ht->size; i++) { if (ht->vals[i]) { - scheme_simplify_stx(ht->keys[i], simplify_cache); stxes[SCHEME_LOCAL_POS(ht->vals[i])] = ht->keys[i]; } } } + rp->src_insp_desc = insp_desc; + return rp; } diff --git a/racket/src/racket/src/schcpt.h b/racket/src/racket/src/schcpt.h index b616925279..b6026b206d 100644 --- a/racket/src/racket/src/schcpt.h +++ b/racket/src/racket/src/schcpt.h @@ -36,13 +36,16 @@ enum { CPT_DELAY_REF, CPT_PREFAB, CPT_LET_ONE_UNUSED, + CPT_SCOPE, + CPT_ROOT_SCOPE, + CPT_SHARED, _CPT_COUNT_ }; -#define CPT_SMALL_NUMBER_START 36 -#define CPT_SMALL_NUMBER_END 60 +#define CPT_SMALL_NUMBER_START 39 +#define CPT_SMALL_NUMBER_END 62 -#define CPT_SMALL_SYMBOL_START 60 +#define CPT_SMALL_SYMBOL_START 62 #define CPT_SMALL_SYMBOL_END 80 #define CPT_SMALL_MARSHALLED_START 80 diff --git a/racket/src/racket/src/schemef.h b/racket/src/racket/src/schemef.h index 8acc2aec85..6dd4307695 100644 --- a/racket/src/racket/src/schemef.h +++ b/racket/src/racket/src/schemef.h @@ -511,6 +511,7 @@ MZ_EXTERN Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *ht); MZ_EXTERN void scheme_clear_hash_table(Scheme_Hash_Table *ht); MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree(int kind); +MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree_set(int kind); MZ_EXTERN Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val); MZ_EXTERN Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key); XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key); @@ -1140,8 +1141,8 @@ MZ_EXTERN intptr_t scheme_equal_hash_key(Scheme_Object *o); MZ_EXTERN intptr_t scheme_equal_hash_key2(Scheme_Object *o); MZ_EXTERN intptr_t scheme_recur_equal_hash_key(Scheme_Object *o, void *cycle_data); MZ_EXTERN intptr_t scheme_recur_equal_hash_key2(Scheme_Object *o, void *cycle_data); -MZ_EXTERN intptr_t scheme_eqv_hash_key(Scheme_Object *o); -MZ_EXTERN intptr_t scheme_eqv_hash_key2(Scheme_Object *o); +XFORM_NONGCING MZ_EXTERN intptr_t scheme_eqv_hash_key(Scheme_Object *o); +XFORM_NONGCING MZ_EXTERN intptr_t scheme_eqv_hash_key2(Scheme_Object *o); MZ_EXTERN void scheme_set_type_equality(Scheme_Type type, Scheme_Equal_Proc f, diff --git a/racket/src/racket/src/schemex.h b/racket/src/racket/src/schemex.h index f0ec4b2cb6..1592de93ce 100644 --- a/racket/src/racket/src/schemex.h +++ b/racket/src/racket/src/schemex.h @@ -403,6 +403,7 @@ int (*scheme_is_hash_table_eqv)(Scheme_Object *o); Scheme_Hash_Table *(*scheme_clone_hash_table)(Scheme_Hash_Table *ht); void (*scheme_clear_hash_table)(Scheme_Hash_Table *ht); Scheme_Hash_Tree *(*scheme_make_hash_tree)(int kind); +Scheme_Hash_Tree *(*scheme_make_hash_tree_set)(int kind); Scheme_Hash_Tree *(*scheme_hash_tree_set)(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val); Scheme_Object *(*scheme_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key); Scheme_Object *(*scheme_eq_hash_tree_get)(Scheme_Hash_Tree *tree, Scheme_Object *key); diff --git a/racket/src/racket/src/schemex.inc b/racket/src/racket/src/schemex.inc index 9e937caeff..505d5026a6 100644 --- a/racket/src/racket/src/schemex.inc +++ b/racket/src/racket/src/schemex.inc @@ -299,6 +299,7 @@ scheme_extension_table->scheme_clone_hash_table = scheme_clone_hash_table; scheme_extension_table->scheme_clear_hash_table = scheme_clear_hash_table; scheme_extension_table->scheme_make_hash_tree = scheme_make_hash_tree; + scheme_extension_table->scheme_make_hash_tree_set = scheme_make_hash_tree_set; scheme_extension_table->scheme_hash_tree_set = scheme_hash_tree_set; scheme_extension_table->scheme_hash_tree_get = scheme_hash_tree_get; scheme_extension_table->scheme_eq_hash_tree_get = scheme_eq_hash_tree_get; diff --git a/racket/src/racket/src/schemexm.h b/racket/src/racket/src/schemexm.h index 6fd65edfa4..47c0fc3096 100644 --- a/racket/src/racket/src/schemexm.h +++ b/racket/src/racket/src/schemexm.h @@ -299,6 +299,7 @@ #define scheme_clone_hash_table (scheme_extension_table->scheme_clone_hash_table) #define scheme_clear_hash_table (scheme_extension_table->scheme_clear_hash_table) #define scheme_make_hash_tree (scheme_extension_table->scheme_make_hash_tree) +#define scheme_make_hash_tree_set (scheme_extension_table->scheme_make_hash_tree_set) #define scheme_hash_tree_set (scheme_extension_table->scheme_hash_tree_set) #define scheme_hash_tree_get (scheme_extension_table->scheme_hash_tree_get) #define scheme_eq_hash_tree_get (scheme_extension_table->scheme_eq_hash_tree_get) diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index 094ce84ec1..0e2a470120 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -14,7 +14,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1131 +#define EXPECTED_PRIM_COUNT 1134 #define EXPECTED_UNSAFE_COUNT 106 #define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_EXTFL_COUNT 45 diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 65a9f47bb8..d11639198e 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -407,6 +407,8 @@ void scheme_init_module_resolver(void); void scheme_finish_kernel(Scheme_Env *env); +void scheme_init_syntax_bindings(void); + Scheme_Object *scheme_make_initial_inspectors(void); Scheme_Object *scheme_get_current_inspector(void); XFORM_NONGCING Scheme_Object *scheme_get_initial_inspector(void); @@ -510,14 +512,14 @@ extern Scheme_Object *scheme_date; extern Scheme_Object *scheme_liberal_def_ctx_type; -extern Scheme_Object *scheme_module_stx; -extern Scheme_Object *scheme_modulestar_stx; -extern Scheme_Object *scheme_begin_stx; -extern Scheme_Object *scheme_module_begin_stx; -extern Scheme_Object *scheme_define_values_stx; -extern Scheme_Object *scheme_define_syntaxes_stx; -extern Scheme_Object *scheme_begin_for_syntax_stx; -extern Scheme_Object *scheme_top_stx; +THREAD_LOCAL_DECL(extern Scheme_Object *scheme_module_stx); +THREAD_LOCAL_DECL(extern Scheme_Object *scheme_modulestar_stx); +THREAD_LOCAL_DECL(extern Scheme_Object *scheme_begin_stx); +THREAD_LOCAL_DECL(extern Scheme_Object *scheme_module_begin_stx); +THREAD_LOCAL_DECL(extern Scheme_Object *scheme_define_values_stx); +THREAD_LOCAL_DECL(extern Scheme_Object *scheme_define_syntaxes_stx); +THREAD_LOCAL_DECL(extern Scheme_Object *scheme_begin_for_syntax_stx); +THREAD_LOCAL_DECL(extern Scheme_Object *scheme_top_stx); extern Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write_special_symbol; @@ -853,14 +855,20 @@ scheme_get_primitive_global(Scheme_Object *var, Scheme_Env *env, void scheme_add_bucket_to_table(Scheme_Bucket_Table *table, Scheme_Bucket *b); Scheme_Bucket *scheme_bucket_or_null_from_table(Scheme_Bucket_Table *table, const char *key, int add); -struct Scheme_Hash_Tree -{ - Scheme_Inclhash_Object iso; /* 0x1 flag => equal?-based hashing; 0x2 flag => eqv?-based hashing */ +typedef unsigned int hash_tree_bitmap_t; /* must be unsigned int */ +struct Scheme_Hash_Tree { + Scheme_Inclhash_Object iso; /* 0 => keys only; 0x1 => keys and values; 0x3 => keys, values, and codes */ + hash_tree_bitmap_t bitmap; intptr_t count; - struct AVLNode *root; + Scheme_Object *els[mzFLEX_ARRAY_DECL]; /* keys, then vals (if any), then codes (if any) */ }; #define SCHEME_HASHTR_FLAGS(tr) MZ_OPT_HASH_KEY(&(tr)->iso) +#define SCHEME_HASHTR_KIND(tr) (SCHEME_HASHTR_FLAGS(tr) & 0x3) + +#define SCHEME_HASHTR_TYPE(tr) (SAME_TYPE(SCHEME_TYPE(tr), scheme_hash_tree_indirection_type) \ + ? SCHEME_TYPE(((Scheme_Hash_Tree *)tr)->els[0]) \ + : SCHEME_TYPE(tr)) Scheme_Object *scheme_intern_literal_string(Scheme_Object *str); Scheme_Object *scheme_intern_literal_number(Scheme_Object *num); @@ -1072,15 +1080,24 @@ typedef struct Scheme_Stx_Srcloc { #define STX_SUBSTX_FLAG 0x1 #define STX_ARMED_FLAG 0x2 +typedef struct Scheme_Scope_Set Scheme_Scope_Set; + +typedef struct Scheme_Scope_Table { + Scheme_Object so; /* scheme_scope_table_type or scheme_propagate_table_type */ + Scheme_Scope_Set *simple_scopes; /* scopes that span all phases */ + Scheme_Object *multi_scopes; /* list of (cons multi-scope phase-shift) or fallback chain */ +} Scheme_Scope_Table; + typedef struct Scheme_Stx { Scheme_Inclhash_Object iso; /* 0x1 and 0x2 of keyex used */ Scheme_Object *val; Scheme_Stx_Srcloc *srcloc; - Scheme_Object *wraps; + Scheme_Scope_Table *scopes; union { - intptr_t lazy_prefix; /* # of initial items in wraps to propagate; -1 => taint to propagate */ - Scheme_Object *modinfo_cache; + Scheme_Scope_Table *to_propagate; + Scheme_Object *cache; } u; + Scheme_Object *shifts; /* or (vector ) */ Scheme_Object *taints; /* taint or taint-arming */ Scheme_Object *props; } Scheme_Stx; @@ -1101,16 +1118,11 @@ Scheme_Object *scheme_make_stx_w_offset(Scheme_Object *val, intptr_t line, intptr_t col, intptr_t pos, intptr_t span, Scheme_Object *src, Scheme_Object *props); -Scheme_Object *scheme_make_renamed_stx(Scheme_Object *sym, - Scheme_Object *rn); - -Scheme_Object *scheme_new_stx_simplify_cache(void); -void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *simplify_cache); Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src, Scheme_Object *stx_wraps, int cangraph, int copyprops); -Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks, +Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_scopes, struct Scheme_Marshal_Tables *mt); Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o, struct Scheme_Unmarshal_Tables *ut, @@ -1120,145 +1132,169 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya, Scheme_Object *old, Scheme_Object *origin); -int scheme_stx_has_empty_wraps(Scheme_Object *); +int scheme_stx_has_empty_wraps(Scheme_Object *stx, Scheme_Object *phase); -Scheme_Object *scheme_new_mark(void); -Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m); +XFORM_NONGCING Scheme_Object *scheme_stx_root_scope(); +Scheme_Object *scheme_new_scope(int kind); +Scheme_Object *scheme_scope_printed_form(Scheme_Object *m); +Scheme_Object *scheme_stx_scope(Scheme_Object *o, Scheme_Object *m, int mode); -Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c); -void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname); +#define SCHEME_STX_MODULE_SCOPE 0 +#define SCHEME_STX_MODULE_MULTI_SCOPE 1 +#define SCHEME_STX_MACRO_SCOPE 2 +#define SCHEME_STX_LOCAL_BIND_SCOPE 3 +#define SCHEME_STX_INTDEF_SCOPE 4 +#define SCHEME_STX_USE_SITE_SCOPE 5 -#define SCHEME_RIBP(v) SAME_TYPE(scheme_lexical_rib_type, SCHEME_TYPE(v)) -Scheme_Object *scheme_make_rename_rib(void); -void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename); -void scheme_drop_first_rib_rename(Scheme_Object *ro); -Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro); -void scheme_stx_seal_rib(Scheme_Object *rib); -int *scheme_stx_get_rib_sealed(Scheme_Object *rib); +#define SCHEME_STX_SCOPE_KIND_SHIFT 3 +#define SCHEME_STX_SCOPE_KIND_MASK ((1 << SCHEME_STX_SCOPE_KIND_SHIFT) - 1) -Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename); -Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib); -Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs); +#define SCHEME_STX_ADD 0 +#define SCHEME_STX_REMOVE 1 +#define SCHEME_STX_FLIP 2 +#define SCHEME_STX_PUSH 4 +#define SCHEME_STX_MUTATE 16 /* or'ed */ +#define SCHEME_STX_PROPONLY 32 /* or'ed, internal */ +Scheme_Object *scheme_stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode); +Scheme_Object *scheme_stx_add_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); +Scheme_Object *scheme_stx_remove_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); +Scheme_Object *scheme_stx_flip_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase); +Scheme_Object *scheme_stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode); -Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to, - Scheme_Object *uid); +Scheme_Scope_Set *scheme_module_context_scopes(Scheme_Object *mc); +Scheme_Object *scheme_module_context_frame_scopes(Scheme_Object *mc, Scheme_Object *keep_intdef_scopes); +void scheme_module_context_add_use_site_scope(Scheme_Object *mc, Scheme_Object *use_site_scope); +Scheme_Object *scheme_stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); +Scheme_Object *scheme_stx_adjust_frame_bind_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); +Scheme_Object *scheme_stx_adjust_frame_use_site_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode); + +Scheme_Object *scheme_make_frame_scopes(Scheme_Object *scope); +Scheme_Object *scheme_add_frame_use_site_scope(Scheme_Object *frame_scopes, Scheme_Object *use_site_scope); +Scheme_Object *scheme_add_frame_intdef_scope(Scheme_Object *frame_scopes, Scheme_Object *intdef_scope); + +Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, + Scheme_Object *old_midx, Scheme_Object *new_midx, + Scheme_Hash_Table *export_registry, + Scheme_Object *src_insp_desc, Scheme_Object *insp); +Scheme_Object *scheme_stx_add_shift(Scheme_Object *o, Scheme_Object *shift); +Scheme_Object *scheme_stx_add_shifts(Scheme_Object *o, Scheme_Object *shift); +Scheme_Object *scheme_stx_shift(Scheme_Object *stx, + Scheme_Object *phase_delta, + Scheme_Object *old_midx, Scheme_Object *new_midx, + Scheme_Hash_Table *export_registry, + Scheme_Object *src_insp_desc, Scheme_Object *insp); Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv); - -void scheme_install_free_id_rename(Scheme_Object *id, - Scheme_Object *orig_id, - Scheme_Object *rename_rib, - Scheme_Object *phase); - -#define mzMOD_RENAME_TOPLEVEL 0 -#define mzMOD_RENAME_NORMAL 1 -#define mzMOD_RENAME_MARKED 2 +int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv); struct Scheme_Module_Phase_Exports; /* forward declaration */ -Scheme_Object *scheme_make_module_rename_set(int kind, Scheme_Object *share_marked_names, Scheme_Object *insp); -void scheme_add_module_rename_to_set(Scheme_Object *set, Scheme_Object *rn); -Scheme_Object *scheme_get_module_rename_from_set(Scheme_Object *set, Scheme_Object *phase, int create); +Scheme_Object *scheme_make_module_context(Scheme_Object *insp, + Scheme_Object *shift_or_shifts, + Scheme_Object *name); +Scheme_Object *scheme_module_context_at_phase(Scheme_Object *mc, Scheme_Object *phase); -Scheme_Hash_Table *scheme_get_module_rename_marked_names(Scheme_Object *set, Scheme_Object *phase, int create); +Scheme_Object *scheme_stx_add_module_context(Scheme_Object *stx, Scheme_Object *mc); +Scheme_Object *scheme_stx_add_module_frame_context(Scheme_Object *stx, Scheme_Object *mc); +Scheme_Object *scheme_stx_adjust_module_use_site_context(Scheme_Object *stx, Scheme_Object *mc, int mode); +Scheme_Object *scheme_stx_introduce_to_module_context(Scheme_Object *stx, Scheme_Object *mc); +Scheme_Object *scheme_stx_unintroduce_from_module_context(Scheme_Object *stx, Scheme_Object *mc); +Scheme_Object *scheme_stx_push_module_context(Scheme_Object *stx, Scheme_Object *mc); +Scheme_Object *scheme_stx_push_introduce_module_context(Scheme_Object *stx, Scheme_Object *mc); -void scheme_append_rename_set_to_env(Scheme_Object *rns, Scheme_Env *env); -void scheme_install_prior_contexts_to_env(Scheme_Object *prior, Scheme_Env *env); -Scheme_Object *scheme_accum_prior_contexts(Scheme_Object *rns, Scheme_Object *prior); +Scheme_Object *scheme_module_context_to_stx(Scheme_Object *mc, Scheme_Object *orig_src); +Scheme_Object *scheme_stx_to_module_context(Scheme_Object *stx); -void scheme_seal_module_rename(Scheme_Object *rn, int level); -void scheme_seal_module_rename_set(Scheme_Object *rns, int level); -#define STX_SEAL_BOUND 1 -#define STX_SEAL_ALL 2 +Scheme_Object *scheme_module_context_use_site_frame_scopes(Scheme_Object *mc); +Scheme_Object *scheme_module_context_inspector(Scheme_Object *mc); -Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *mns, - Scheme_Object *insp, Scheme_Object *set_identity); -Scheme_Object* scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname, - Scheme_Object *locname, Scheme_Object *exname, - Scheme_Object *nominal_src, Scheme_Object *nominal_ex, - intptr_t mod_phase, Scheme_Object *src_phase_index, - Scheme_Object *nom_export_phase, - int mode); -void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, - struct Scheme_Module_Phase_Exports *pt, - Scheme_Object *unmarshal_phase_index, - Scheme_Object *src_phase_index, - Scheme_Object *marks, Scheme_Object *bdg, - int save_unmarshal); -void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info); -void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info, - Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, - Scheme_Hash_Table *export_registry); -Scheme_Object *scheme_get_kernel_modidx(void); -void scheme_remove_module_rename(Scheme_Object *mrn, - Scheme_Object *localname); -void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest, int with_unmarshal); -void scheme_list_module_rename(Scheme_Object *src, Scheme_Hash_Table *ht, Scheme_Hash_Table *export_registry); +void scheme_module_context_add_mapped_symbols(Scheme_Object *mc, Scheme_Hash_Table *mapped); -Scheme_Object *scheme_rename_to_stx(Scheme_Object *rn); -Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx); -Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Object *new_insp); -Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *mrns, Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Object *new_insp); -Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn); -Scheme_Object *scheme_rename_set_identity(Scheme_Object *rn_set); +XFORM_NONGCING void scheme_stx_set(Scheme_Object *q_stx, Scheme_Object *val, Scheme_Object *context); + +void scheme_extend_module_context(Scheme_Object *mc, Scheme_Object *ctx, Scheme_Object *modidx, + Scheme_Object *locname, Scheme_Object *exname, + Scheme_Object *nominal_src, Scheme_Object *nominal_ex, + intptr_t mod_phase, Scheme_Object *src_phase_index, + Scheme_Object *nom_export_phase); +void scheme_extend_module_context_with_shared(Scheme_Object *mc, Scheme_Object *modidx, + struct Scheme_Module_Phase_Exports *pt, + Scheme_Object *prefix, + Scheme_Hash_Tree *excepts, + Scheme_Object *src_phase_index, + Scheme_Object *context, + Scheme_Object *replace_at); + +void scheme_do_module_context_unmarshal(Scheme_Object *modidx, Scheme_Object *req_modidx, + Scheme_Object *context, + Scheme_Object *bind_phase, Scheme_Object *pt_phase, Scheme_Object *src_phase, + Scheme_Object *prefix, + Scheme_Hash_Tree *excepts, + Scheme_Hash_Table *export_registry, Scheme_Object *insp, + Scheme_Object *replace_at); + +int scheme_stx_equal_module_context(Scheme_Object *stx, Scheme_Object *mc_as_stx); Scheme_Object *scheme_stx_content(Scheme_Object *o); Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist); -int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase); -int scheme_stx_module_eq_x(Scheme_Object *a, Scheme_Object *b, intptr_t b_phase); -int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym); -int scheme_stx_module_eq3(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *a_phase, Scheme_Object *b_phase, - Scheme_Object *asym); -Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase); -Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *recur, - Scheme_Object **name, Scheme_Object *phase, - Scheme_Object **nominal_modidx, - Scheme_Object **nominal_name, - Scheme_Object **mod_phase, - Scheme_Object **src_phase_index, - Scheme_Object **nominal_src_phase, - Scheme_Object **lex_env, - int *_sealed, - Scheme_Object **rename_insp, - int *_binding_marks_skipped); -Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a); -int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx); +int scheme_stx_could_bind(Scheme_Object *bind_id, Scheme_Object *ref_id, Scheme_Object *phase); -int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs); +int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase); +int scheme_stx_free_eq_x(Scheme_Object *a, Scheme_Object *b, intptr_t b_phase); +int scheme_stx_free_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); +int scheme_stx_free_eq3(Scheme_Object *a, Scheme_Object *b, + Scheme_Object *a_phase, Scheme_Object *b_phase); +Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase); + +void scheme_add_local_binding(Scheme_Object *o, Scheme_Object *phase, Scheme_Object *binding_sym); +void scheme_add_module_binding(Scheme_Object *o, Scheme_Object *phase, + Scheme_Object *modidx, Scheme_Object *inspector, + Scheme_Object *sym, Scheme_Object *defn_phase); +void scheme_add_module_binding_w_nominal(Scheme_Object *o, Scheme_Object *phase, + Scheme_Object *modidx, Scheme_Object *defn_name, Scheme_Object *defn_phase, + Scheme_Object *inspector, + Scheme_Object *nominal_mod, Scheme_Object *nominal_name, + Scheme_Object *nominal_import_phase, + Scheme_Object *nominal_export_phase, + struct Scheme_Module_Phase_Exports *from_pt, + Scheme_Hash_Table *collapse_table); +void scheme_add_binding_copy(Scheme_Object *o, Scheme_Object *from_o, Scheme_Object *phase); + +Scheme_Object *scheme_stx_lookup(Scheme_Object *o, Scheme_Object *phase); +Scheme_Object *scheme_stx_lookup_stop_at_free_eq(Scheme_Object *o, Scheme_Object *phase, int *_exact_match); +Scheme_Object *scheme_stx_lookup_exact(Scheme_Object *o, Scheme_Object *phase); +Scheme_Object *scheme_stx_lookup_w_nominal(Scheme_Object *o, Scheme_Object *phase, + int stop_at_free_eq, + int *_exact_match, int *_ambiguous, + Scheme_Scope_Set **_binding_scopes, + Scheme_Object **insp, /* access-granting inspector */ + Scheme_Object **nominal_modidx, /* how it was imported */ + Scheme_Object **nominal_name, /* imported as name */ + Scheme_Object **src_phase, /* phase level of import from nominal modidx */ + Scheme_Object **nominal_src_phase); /* phase level of export from nominal modidx */ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); -int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase); -int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, +int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase); +int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *a_phase, Scheme_Object *b_phase); +Scheme_Object *scheme_stx_binding_union(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase); +Scheme_Object *scheme_stx_binding_subtract(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase); + Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source); +char *scheme_stx_describe_context(Scheme_Object *stx, Scheme_Object *phase, int always); + Scheme_Object *scheme_stx_property(Scheme_Object *_stx, Scheme_Object *key, Scheme_Object *val); -Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, Scheme_Object *shift, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *insp, - Scheme_Object *ignore_old_identity); -Scheme_Object *scheme_stx_phase_shift_as_rename(Scheme_Object *shift, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *insp, - Scheme_Object *ignore_old_identity); - int scheme_stx_list_length(Scheme_Object *list); int scheme_stx_proper_list_length(Scheme_Object *list); Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj); -Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *stx); - #define SCHEME_STX_VAL(s) ((Scheme_Stx *)s)->val #define SCHEME_STX_PAIRP(o) (SCHEME_PAIRP(o) || (SCHEME_STXP(o) && SCHEME_PAIRP(SCHEME_STX_VAL(o)))) @@ -1286,12 +1322,12 @@ Scheme_Object *scheme_syntax_taint_arm(Scheme_Object *stx, Scheme_Object *insp, Scheme_Object *scheme_syntax_taint_rearm(Scheme_Object *o, Scheme_Object *arm_from); Scheme_Object *scheme_syntax_taint_disarm(Scheme_Object *o, Scheme_Object *insp); -Scheme_Object *scheme_delayed_rename(Scheme_Object **o, intptr_t i); +Scheme_Object *scheme_delayed_shift(Scheme_Object **o, intptr_t i); struct Resolve_Prefix; void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i); -XFORM_NONGCING Scheme_Object *scheme_phase_index_symbol(int src_phase_index); +Scheme_Object *scheme_stx_force_delayed(Scheme_Object *stx); Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht); void scheme_populate_pt_ht(struct Scheme_Module_Phase_Exports * pt); @@ -1300,6 +1336,17 @@ Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from); int scheme_is_predefined_module_p(Scheme_Object *name); +Scheme_Object *scheme_get_kernel_modidx(void); + +Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, struct Scheme_Marshal_Tables *mt); +void scheme_iterate_reachable_scopes(struct Scheme_Marshal_Tables *mt); + +void scheme_stx_debug_print(Scheme_Object *stx, Scheme_Object *phase, int level); + +Scheme_Object *scheme_revert_use_site_scopes(Scheme_Object *o, struct Scheme_Comp_Env *env); + +Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv); + /*========================================================================*/ /* syntax run-time structures */ /*========================================================================*/ @@ -1592,13 +1639,15 @@ void scheme_flush_stack_copy_cache(void); typedef struct Scheme_Dynamic_State { struct Scheme_Comp_Env * volatile current_local_env; - Scheme_Object * volatile mark; + Scheme_Object * volatile scope; + Scheme_Object * volatile use_scope; Scheme_Object * volatile name; Scheme_Object * volatile modidx; Scheme_Env * volatile menv; } Scheme_Dynamic_State; -void scheme_set_dynamic_state(Scheme_Dynamic_State *state, struct Scheme_Comp_Env *env, Scheme_Object *mark, +void scheme_set_dynamic_state(Scheme_Dynamic_State *state, struct Scheme_Comp_Env *env, + Scheme_Object *scope, Scheme_Object *use_scope, Scheme_Object *name, Scheme_Env *menv, Scheme_Object *modidx); @@ -2502,17 +2551,22 @@ typedef struct Scheme_Comp_Env { MZTAG_IF_REQUIRED short flags; /* used for expanding/compiling */ - mzshort num_bindings; /* number of `values' slots */ Scheme_Env *genv; /* top-level environment */ Scheme_Object *insp; /* code inspector for checking protected */ Comp_Prefix *prefix; /* stack base info: globals and stxes */ - struct Scheme_Object **values; /* names bound in this frame */ + Scheme_Object *scopes; /* can be NULL, a scope, a scope set, or (cons scope-set nobind-scope) */ - Scheme_Object *uid; /* renaming symbol for syntax, if all the same */ - struct Scheme_Object **uids; /* renaming symbol for syntax when multiple are needed */ - - struct Scheme_Object *renames; /* an stx lexical rename or a list of them */ + /* local bindings; */ + mzshort num_bindings; /* number of `values' slots */ + Scheme_Object **binders; /* identifiers */ + Scheme_Object **bindings; /* symbols */ + Scheme_Object **vals; /* compile-time values */ + Scheme_Object **shadower_deltas; + int *use; + int min_use, any_use; + + Scheme_Object *lifts; mzshort rename_var_count; /* number of non-NULL `values' when `renames' was computed */ mzshort rename_rstart; /* leftover rstart from previous round; see env.c */ @@ -2522,7 +2576,7 @@ typedef struct Scheme_Comp_Env Scheme_Object *in_modidx; /* during lookup/expand in macro */ - Scheme_Hash_Table *skip_table; /* for jumping ahead in the chain */ + Scheme_Hash_Tree *skip_table; /* for jumping ahead in the chain */ int skip_depth; /* depth in simple frames, used to trigger skip_table creation */ struct Scheme_Comp_Env *next; @@ -2550,6 +2604,7 @@ typedef struct Scheme_Compile_Expand_Info char resolve_module_ids; char pre_unwrapped; char testing_constantness; + char substitute_bindings; int depth; int env_already; } Scheme_Compile_Expand_Info; @@ -2568,6 +2623,11 @@ typedef struct Resolve_Prefix Scheme_Object **toplevels; Scheme_Object **stxes; /* simplified */ Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */ + /* An inspector or symbol to identify bindings that are created as + part of the module's expansion, so that a suitable inspector can + be associated with those bindings (through a syntax-object + "shift") when the code is re-loaded. */ + Scheme_Object *src_insp_desc; } Resolve_Prefix; typedef struct Resolve_Info Resolve_Info; @@ -2754,22 +2814,21 @@ Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, i #define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */ -Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int flags); -Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, int flags); +Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags); +Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, Scheme_Object *scopes, int flags); Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, Scheme_Object **_id, int *_use_map); -Scheme_Object *scheme_find_local_shadower(Scheme_Object *sym, Scheme_Object *sym_marks, - Scheme_Comp_Env *env, Scheme_Object **_free_id); +Scheme_Object *scheme_get_shadower(Scheme_Object *sym, Scheme_Comp_Env *env, int only_generated); Scheme_Object *scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object *argv[]); Scheme_Object *scheme_local_lift_context(Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, +Scheme_Object *scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env); Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form, - intptr_t phase, Scheme_Object *local_mark, + intptr_t phase, Scheme_Object *local_scope, Scheme_Comp_Env *env); -Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_mark, +Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_scope, Scheme_Comp_Env *env); Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env); @@ -2781,30 +2840,34 @@ void scheme_check_identifier(const char *formname, Scheme_Object *id, Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *erec, int drec, - int int_def_pos, Scheme_Object **current_val, - Scheme_Comp_Env **_xenv, - Scheme_Object *ctx, int keep_name); Scheme_Object *scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *f, 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_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, + Scheme_Object *scope, Scheme_Comp_Env *env); void scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *frame); -Scheme_Comp_Env *scheme_add_compilation_frame(Scheme_Object *vals, +void scheme_add_compilation_frame_use_site_scope(Scheme_Comp_Env *frame, + Scheme_Object *use_site_scope); +void scheme_add_compilation_frame_intdef_scope(Scheme_Comp_Env *frame, + Scheme_Object *intdef_scope); +Scheme_Comp_Env *scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Object *scope, Scheme_Comp_Env *env, int flags); -Scheme_Comp_Env *scheme_require_renames(Scheme_Comp_Env *env); -Scheme_Object *scheme_lookup_binding(Scheme_Object *symbol, Scheme_Comp_Env *env, int flags, +Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env); + +Scheme_Object *scheme_compile_lookup(Scheme_Object *symbol, Scheme_Comp_Env *env, int flags, Scheme_Object *in_modidx, Scheme_Env **_menv, int *_protected, - Scheme_Object **_lexical_binding_id, + Scheme_Object **_local_binder, int *_need_macro_scope, Scheme_Object **_inline_variant); int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env); @@ -2814,11 +2877,6 @@ Scheme_Object *scheme_extract_extfl(Scheme_Object *o); Scheme_Object *scheme_extract_futures(Scheme_Object *o); Scheme_Object *scheme_extract_foreign(Scheme_Object *o); -Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env, - Scheme_Comp_Env *upto); - -Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env); - typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *); void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, Scheme_Object *end_stmts, Scheme_Object *context_key, @@ -2834,16 +2892,17 @@ Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env); Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, intptr_t phase, Scheme_Comp_Env *cenv, - Scheme_Object *mark); + Scheme_Object *scope); Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, intptr_t phase, - Scheme_Object *mark, + Scheme_Object *scope, void *data, - Scheme_Object **_ref_expr); + Scheme_Object **_ref_expr, + struct Scheme_Comp_Env *cenv); void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env); void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val, - Scheme_Comp_Env *env); + Scheme_Comp_Env *env, int replace_value); Scheme_Object *scheme_clone_vector(Scheme_Object *data, int skip, int set_type); @@ -2882,7 +2941,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos, Scheme_Object *rename_rib); + int *_pos, Scheme_Object *rename_rib, int replace_value); int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env); typedef struct SFS_Info { @@ -2958,7 +3017,7 @@ int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed, int can_be Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info); -Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify); +Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, Scheme_Object *insp_desc); Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri); Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp); @@ -2984,16 +3043,8 @@ int scheme_expr_produces_local_type(Scheme_Object *expr); Scheme_Object *scheme_make_compiled_syntax(Scheme_Syntax *syntax, Scheme_Syntax_Expander *exp); -Scheme_Object *scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int app_position); - Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); -Scheme_Object *scheme_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec); Scheme_Object *scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); @@ -3055,6 +3106,7 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Inf int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count); int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame); int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos); +void scheme_mark_all_use(Scheme_Comp_Env *frame); /* flags reported by scheme_env_get_flags */ #define SCHEME_WAS_USED 0x1 @@ -3076,19 +3128,23 @@ int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos); #define SCHEME_INFO_TYPED_VAL_MASK (SCHEME_MAX_LOCAL_TYPE_MASK << SCHEME_INFO_TYPED_VAL_SHIFT) /* flags used with scheme_new_frame */ -#define SCHEME_TOPLEVEL_FRAME 1 -#define SCHEME_MODULE_FRAME 2 -#define SCHEME_MODULE_BEGIN_FRAME 4 -#define SCHEME_LAMBDA_FRAME 8 -#define SCHEME_INTDEF_FRAME 16 -#define SCHEME_NO_RENAME 32 -#define SCHEME_CAPTURE_WITHOUT_RENAME 64 -#define SCHEME_FOR_STOPS 128 -#define SCHEME_FOR_INTDEF 256 -#define SCHEME_CAPTURE_LIFTED 512 -#define SCHEME_INTDEF_SHADOW 1024 -#define SCHEME_POST_BIND_FRAME 2048 -#define SCHEME_NESTED_MODULE_FRAME 4096 +#define SCHEME_TOPLEVEL_FRAME (1 << 0) +#define SCHEME_MODULE_FRAME (1 << 1) +#define SCHEME_MODULE_BEGIN_FRAME (1 << 2) +#define SCHEME_LAMBDA_FRAME (1 << 3) +#define SCHEME_INTDEF_FRAME (1 << 4) +#define SCHEME_USE_SCOPES_TO_NEXT (1 << 5) +#define SCHEME_CAPTURE_WITHOUT_RENAME (1 << 6) +#define SCHEME_FOR_STOPS (1 << 7) +#define SCHEME_FOR_INTDEF (1 << 8) +#define SCHEME_CAPTURE_LIFTED (1 << 9) +#define SCHEME_INTDEF_SHADOW (1 << 10) +#define SCHEME_POST_BIND_FRAME (1 << 11) +#define SCHEME_NESTED_MODULE_FRAME (1 << 12) +#define SCHEME_KEEP_SCOPES_FRAME (1 << 13) + +#define SCHEME_REC_BINDING_FRAME (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_BEGIN_FRAME \ + | SCHEME_INTDEF_FRAME | SCHEME_FOR_INTDEF) /* Flags used with scheme_static_distance */ #define SCHEME_ELIM_CONST 1 @@ -3105,14 +3161,13 @@ int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos); #define SCHEME_NO_CERT_CHECKS 2048 #define SCHEME_REFERENCING 4096 #define SCHEME_OUT_OF_CONTEXT_LOCAL 8192 +#define SCHEME_STOP_AT_FREE_EQ 16384 Scheme_Hash_Table *scheme_map_constants_to_globals(void); const char *scheme_look_for_primitive(void *code); Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -Scheme_Object *scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec); Scheme_Object *scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); @@ -3133,13 +3188,14 @@ int scheme_is_toplevel(Scheme_Comp_Env *env); int scheme_is_nested_module(Scheme_Comp_Env *env); Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env); -Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env); - Scheme_Env *scheme_make_empty_env(void); void scheme_prepare_exp_env(Scheme_Env *env); void scheme_prepare_template_env(Scheme_Env *env); void scheme_prepare_label_env(Scheme_Env *env); -void scheme_prepare_env_renames(Scheme_Env *env, int kind); +void scheme_prepare_env_stx_context(Scheme_Env *env); + +XFORM_NONGCING Scheme_Object *scheme_env_phase(Scheme_Env *env); +Scheme_Env *scheme_find_env_at_phase(Scheme_Env *env, Scheme_Object *phase); int scheme_used_app_only(Scheme_Comp_Env *env, int which); int scheme_used_ever(Scheme_Comp_Env *env, int which); @@ -3201,14 +3257,14 @@ void scheme_define_parse(Scheme_Object *form, Scheme_Comp_Env *env, int no_toplevel_check); -void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo); +void scheme_shadow(Scheme_Env *env, Scheme_Object *n, Scheme_Object *val, int as_var); +void scheme_binding_names_from_module(Scheme_Env *menv); int scheme_prefix_depth(Resolve_Prefix *rp); Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, Scheme_Object *src_modix, Scheme_Object *now_modix, int src_phase, int now_phase, - Scheme_Env *dummy_env, - Scheme_Object *insp); + Scheme_Env *dummy_env, Scheme_Object *insp); void scheme_pop_prefix(Scheme_Object **rs); Scheme_Object *scheme_suspend_prefix(Scheme_Object **rs); Scheme_Object **scheme_resume_prefix(Scheme_Object *v); @@ -3253,21 +3309,22 @@ typedef struct Scheme_Marshal_Tables { MZTAG_IF_REQUIRED int pass, print_now; Scheme_Hash_Table *symtab; - Scheme_Hash_Table *rns; - Scheme_Hash_Table *rn_refs; Scheme_Hash_Table *st_refs; Scheme_Object *st_ref_stack; - Scheme_Hash_Table *reverse_map; /* used on first pass */ - Scheme_Hash_Table *same_map; /* set on first pass, used on later passes */ - Scheme_Hash_Table *shift_map; /* effectively set on first pass */ + Scheme_Hash_Table *reachable_scopes; /* filled on -1 pass */ + Scheme_Object *reachable_scope_stack; /* used on -1 pass */ + Scheme_Hash_Table *pending_reachable_ids; /* use on -1 pass */ + Scheme_Hash_Table *intern_map; /* filled on first pass */ + Scheme_Hash_Table *identity_map; /* filled on first pass */ Scheme_Hash_Table *top_map; /* used on every pass */ Scheme_Hash_Table *key_map; /* set after first pass, used on later passes */ Scheme_Hash_Table *delay_map; /* set during first pass, used on later passes */ Scheme_Hash_Table *rn_saved; /* maps each original object to generated marshaling */ Scheme_Object **cdata_map; /* for delay-load wrappers */ int cdata_counter; /* used with cdata_map */ - intptr_t *shared_offsets; /* set in second pass */ + intptr_t *shared_offsets; /* set in second pass */ intptr_t sorted_keys_count; + intptr_t inspector_counter; /* for deterministic symbol allocation */ Scheme_Object **sorted_keys; } Scheme_Marshal_Tables; @@ -3291,6 +3348,8 @@ void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut, Scheme_Object *wraps_key, Scheme_Object *v); +Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v); + int scheme_is_rename_transformer(Scheme_Object *o); int scheme_is_binding_rename_transformer(Scheme_Object *o); Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o); @@ -3325,12 +3384,10 @@ struct Scheme_Env { Scheme_Module_Registry *module_registry; Scheme_Module_Registry *module_pre_registry; /* for expanding submodules */ Scheme_Object *guard_insp; /* instantiation-time inspector, for granting - protected access */ - Scheme_Object *access_insp; /* for graining protected access */ + protected access */ + Scheme_Object *access_insp; /* for gaining protected access */ - Scheme_Object *rename_set; - Scheme_Hash_Table *temp_marked_names; /* used to correlate imports with re-exports */ - Scheme_Object *post_ex_rename_set; /* during module expansion */ + Scheme_Object *stx_context; /* encapsulates scopes, shifts, etc. */ Scheme_Bucket_Table *syntax; struct Scheme_Env *exp_env; @@ -3363,6 +3420,11 @@ struct Scheme_Env { Scheme_Object *weak_self_link; /* for Scheme_Bucket_With_Home */ + /* The `binding_names` table can be an immutable or mutable hash table: */ + Scheme_Object *binding_names; /* maps symbols to identifiers */ + short binding_names_need_shift; /* => binding names are from module, and need a shift */ + short interactive_bindings; /* => module namespace is interactive and shadowing is needed */ + int id_counter; }; @@ -3416,6 +3478,15 @@ typedef struct Scheme_Module Scheme_Object *self_modidx; + /* These tables are unshifted, so they are relative to self_modidx + and must be shifted as they are installed into an environment. + The tables can be immutable or immutable hash tables, or they can + be a vectors that should be converted to an immutable hash + table. */ + Scheme_Object *binding_names; /* maps symbols to identifiers */ + Scheme_Object *et_binding_names; /* maps symbols to identifiers */ + Scheme_Object *other_binding_names; /* maps phases to maps symbols to identifiers */ + Scheme_Object *insp; /* declaration-time inspector, for module instantiation and enabling access to protected imports */ @@ -3528,9 +3599,8 @@ void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Sc } while(0) -Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int mode, - Scheme_Object *phase, int *_skipped); -int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym); +Scheme_Object *scheme_global_binding(Scheme_Object *id, Scheme_Env *env); +Scheme_Object *scheme_future_global_binding(Scheme_Object *id, Scheme_Env *env); Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env); Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase); @@ -3542,6 +3612,8 @@ Scheme_Env *scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree, int new_pre_registry); int scheme_is_module_env(Scheme_Comp_Env *env); +Scheme_Env *scheme_make_env_like(Scheme_Env *base); + Scheme_Object *scheme_module_resolve(Scheme_Object *modidx, int load_it); Scheme_Env *scheme_module_access(Scheme_Object *modname, Scheme_Env *env, intptr_t rev_mod_phase); @@ -3549,10 +3621,9 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem Scheme_Module_Exports *scheme_make_module_exports(); -Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx, +Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *in_modidx, Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *certs, Scheme_Object *unexp_insp, - Scheme_Object *rename_insp, + Scheme_Object *current_insp, Scheme_Object *binding_insp, int position, int want_pos, int *_protected, int *_unexported, Scheme_Env *from_env, int *_would_complain, @@ -3621,6 +3692,8 @@ Scheme_Object *scheme_annotate_existing_submodules(Scheme_Object *orig_fm, int i Scheme_Object *scheme_get_modsrc(Scheme_Module *m); +Scheme_Object *scheme_prune_bindings_table(Scheme_Object *bindings, Scheme_Object *rn_stx, Scheme_Object *phase); + /*========================================================================*/ /* errors and exceptions */ /*========================================================================*/ @@ -3667,6 +3740,7 @@ void scheme_raise_out_of_memory(const char *where, const char *msg, ...); char *scheme_make_srcloc_string(Scheme_Object *stx, intptr_t *len); uintptr_t scheme_get_max_symbol_length(); +void scheme_ensure_max_symbol_length(uintptr_t); char *scheme_make_arity_expect_string(const char *map_name, Scheme_Object *proc, @@ -4074,9 +4148,21 @@ int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Object *orig_t int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Object *orig_t1, Scheme_Hash_Tree *t2, Scheme_Object *orig_t2, void *eql); +Scheme_Object *scheme_hash_tree_copy(Scheme_Object *v); +Scheme_Hash_Tree *scheme_make_hash_tree_of_type(Scheme_Type stype); + +Scheme_Hash_Tree *scheme_make_hash_tree_placeholder(int kind); +void scheme_hash_tree_tie_placeholder(Scheme_Hash_Tree *t, Scheme_Hash_Tree *base); +XFORM_NONGCING Scheme_Hash_Tree *scheme_hash_tree_resolve_placeholder(Scheme_Hash_Tree *t); +int scheme_hash_tree_kind(Scheme_Hash_Tree *t); +XFORM_NONGCING int scheme_eq_hash_tree_subset_of(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2); +intptr_t scheme_hash_tree_key_hash(Scheme_Hash_Tree *t1); void scheme_set_root_param(int p, Scheme_Object *v); +int scheme_equal_modix_eq(Scheme_Object *obj1, Scheme_Object *obj2); +Scheme_Hash_Table *scheme_make_hash_table_equal_modix_eq(); + Scheme_Object *scheme_intern_exact_parallel_symbol(const char *name, uintptr_t len); Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2); Scheme_Object *scheme_copy_list(Scheme_Object *l); @@ -4092,6 +4178,7 @@ void scheme_clear_rx_buffers(void); int scheme_regexp_match_p(Scheme_Object *regexp, Scheme_Object *target); +Scheme_Object *scheme_gensym(Scheme_Object *base); Scheme_Object *scheme_symbol_to_string(Scheme_Object *sym); #ifdef SCHEME_BIG_ENDIAN diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 52ed52b5a4..67e7c080ef 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.2.0.5" +#define MZSCHEME_VERSION "6.2.900.4" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 2 -#define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 5 +#define MZSCHEME_VERSION_Z 900 +#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 1e13bee4e2..7feeb86c6d 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -6,6 +6,7 @@ " and or" " cond" " let let* letrec" +" let*-values" " parameterize" " define)" "(begin-for-syntax " @@ -86,6 +87,16 @@ "(list* 'let-values()(cdr s))" "(list 'let(list(car fst))" "(list* 'let*(cdr fst)(cdr s)))))))))" +"(define-syntaxes(let*-values)" +"(lambda(stx)" +"(let-values(((s)(cdr(syntax->list stx))))" +"(let-values(((fst)(syntax->list(car s))))" +"(datum->syntax " +" here-stx" +"(if(null? fst)" +"(list* 'let-values()(cdr s))" +"(list 'let-values(list(car fst))" +"(list* 'let*-values(cdr fst)(cdr s)))))))))" "(define-syntaxes(parameterize)" "(lambda(stx)" "(let-values(((s)(cdr(syntax->list stx))))" diff --git a/racket/src/racket/src/startup.rktl b/racket/src/racket/src/startup.rktl index 0ec0a6e397..58eada16bc 100644 --- a/racket/src/racket/src/startup.rktl +++ b/racket/src/racket/src/startup.rktl @@ -38,6 +38,7 @@ and or cond let let* letrec + let*-values parameterize define) @@ -127,6 +128,17 @@ (list 'let (list (car fst)) (list* 'let* (cdr fst) (cdr s))))))))) + (define-syntaxes (let*-values) + (lambda (stx) + (let-values ([(s) (cdr (syntax->list stx))]) + (let-values ([(fst) (syntax->list (car s))]) + (datum->syntax + here-stx + (if (null? fst) + (list* 'let-values () (cdr s)) + (list 'let-values (list (car fst)) + (list* 'let*-values (cdr fst) (cdr s))))))))) + (define-syntaxes (parameterize) (lambda (stx) (let-values ([(s) (cdr (syntax->list stx))]) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 1f08d4c73c..958ce74892 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -978,6 +978,8 @@ int scheme_is_subinspector(Scheme_Object *i, Scheme_Object *sup) if (SCHEME_FALSEP(i)) return 1; + if (SCHEME_FALSEP(sup)) + return 0; ins = (Scheme_Inspector *)i; superior = (Scheme_Inspector *)sup; diff --git a/racket/src/racket/src/stypes.h b/racket/src/racket/src/stypes.h index 72980d9833..8a0ed41ec3 100644 --- a/racket/src/racket/src/stypes.h +++ b/racket/src/racket/src/stypes.h @@ -99,202 +99,207 @@ enum { scheme_macro_type, /* 75 */ scheme_box_type, /* 76 */ scheme_thread_type, /* 77 */ - scheme_stx_offset_type, /* 78 */ - scheme_cont_mark_set_type, /* 79 */ - scheme_sema_type, /* 80 */ - scheme_hash_table_type, /* 81 */ - scheme_hash_tree_type, /* 82 */ - scheme_cpointer_type, /* 83 */ - scheme_prefix_type, /* 84 */ - scheme_weak_box_type, /* 85 */ - scheme_ephemeron_type, /* 86 */ - scheme_struct_type_type, /* 87 */ - scheme_module_index_type, /* 88 */ - scheme_set_macro_type, /* 89 */ - scheme_listener_type, /* 90 */ - scheme_namespace_type, /* 91 */ - scheme_config_type, /* 92 */ - scheme_stx_type, /* 93 */ - scheme_will_executor_type, /* 94 */ - scheme_custodian_type, /* 95 */ - scheme_random_state_type, /* 96 */ - scheme_regexp_type, /* 97 */ - scheme_bucket_type, /* 98 */ - scheme_bucket_table_type, /* 99 */ - scheme_subprocess_type, /* 100 */ - scheme_compilation_top_type, /* 101 */ - scheme_wrap_chunk_type, /* 102 */ - scheme_eval_waiting_type, /* 103 */ - scheme_tail_call_waiting_type, /* 104 */ - scheme_undefined_type, /* 105 */ - scheme_struct_property_type, /* 106 */ - scheme_chaperone_property_type, /* 107 */ - scheme_multiple_values_type, /* 108 */ - scheme_placeholder_type, /* 109 */ - scheme_table_placeholder_type, /* 110 */ - scheme_rename_table_type, /* 111 */ - scheme_rename_table_set_type, /* 112 */ - scheme_svector_type, /* 113 */ - scheme_resolve_prefix_type, /* 114 */ - scheme_security_guard_type, /* 115 */ - scheme_indent_type, /* 116 */ - scheme_udp_type, /* 117 */ - scheme_udp_evt_type, /* 118 */ - scheme_tcp_accept_evt_type, /* 119 */ - scheme_id_macro_type, /* 120 */ - scheme_evt_set_type, /* 121 */ - scheme_wrap_evt_type, /* 122 */ - scheme_handle_evt_type, /* 123 */ - scheme_replace_evt_type, /* 124 */ - scheme_active_replace_evt_type, /* 125 */ - scheme_nack_guard_evt_type, /* 126 */ - scheme_semaphore_repost_type, /* 127 */ - scheme_channel_type, /* 128 */ - scheme_channel_put_type, /* 129 */ - scheme_thread_resume_type, /* 130 */ - scheme_thread_suspend_type, /* 131 */ - scheme_thread_dead_type, /* 132 */ - scheme_poll_evt_type, /* 133 */ - scheme_nack_evt_type, /* 134 */ - scheme_module_registry_type, /* 135 */ - scheme_thread_set_type, /* 136 */ - scheme_string_converter_type, /* 137 */ - scheme_alarm_type, /* 138 */ - scheme_thread_recv_evt_type, /* 139 */ - scheme_thread_cell_type, /* 140 */ - scheme_channel_syncer_type, /* 141 */ - scheme_special_comment_type, /* 142 */ - scheme_write_evt_type, /* 143 */ - scheme_always_evt_type, /* 144 */ - scheme_never_evt_type, /* 145 */ - scheme_progress_evt_type, /* 146 */ - scheme_place_dead_type, /* 147 */ - scheme_already_comp_type, /* 148 */ - scheme_readtable_type, /* 149 */ - scheme_intdef_context_type, /* 150 */ - scheme_lexical_rib_type, /* 151 */ - scheme_thread_cell_values_type, /* 152 */ - scheme_global_ref_type, /* 153 */ - scheme_cont_mark_chain_type, /* 154 */ - scheme_raw_pair_type, /* 155 */ - scheme_prompt_type, /* 156 */ - scheme_prompt_tag_type, /* 157 */ - scheme_continuation_mark_key_type, /* 158 */ - scheme_expanded_syntax_type, /* 159 */ - scheme_delay_syntax_type, /* 160 */ - scheme_cust_box_type, /* 161 */ - scheme_resolved_module_path_type, /* 162 */ - scheme_module_phase_exports_type, /* 163 */ - scheme_logger_type, /* 164 */ - scheme_log_reader_type, /* 165 */ - scheme_free_id_info_type, /* 166 */ - scheme_rib_delimiter_type, /* 167 */ - scheme_noninline_proc_type, /* 168 */ - scheme_prune_context_type, /* 169 */ - scheme_future_type, /* 170 */ - scheme_flvector_type, /* 171 */ - scheme_extflvector_type, /* 172 */ - scheme_fxvector_type, /* 173 */ - scheme_place_type, /* 174 */ - scheme_place_object_type, /* 175 */ - scheme_place_async_channel_type, /* 176 */ - scheme_place_bi_channel_type, /* 177 */ - scheme_once_used_type, /* 178 */ - scheme_serialized_symbol_type, /* 179 */ - scheme_serialized_keyword_type, /* 180 */ - scheme_serialized_structure_type, /* 181 */ - scheme_fsemaphore_type, /* 182 */ - scheme_serialized_tcp_fd_type, /* 183 */ - scheme_serialized_file_fd_type, /* 184 */ - scheme_port_closed_evt_type, /* 185 */ - scheme_proc_shape_type, /* 186 */ - scheme_struct_proc_shape_type, /* 187 */ - scheme_phantom_bytes_type, /* 188 */ - scheme_environment_variables_type, /* 189 */ - scheme_filesystem_change_evt_type, /* 190 */ - scheme_ctype_type, /* 191 */ - scheme_plumber_type, /* 192 */ - scheme_plumber_handle_type, /* 193 */ + scheme_scope_type, /* 78 */ + scheme_stx_offset_type, /* 79 */ + scheme_cont_mark_set_type, /* 80 */ + scheme_sema_type, /* 81 */ + scheme_hash_table_type, /* 82 */ + scheme_hash_tree_type, /* 83 */ + scheme_eq_hash_tree_type, /* 84 */ + scheme_eqv_hash_tree_type, /* 85 */ + scheme_hash_tree_subtree_type, /* 86 */ + scheme_hash_tree_collision_type, /* 87 */ + scheme_hash_tree_indirection_type, /* 88 */ + scheme_cpointer_type, /* 89 */ + scheme_prefix_type, /* 90 */ + scheme_weak_box_type, /* 91 */ + scheme_ephemeron_type, /* 92 */ + scheme_struct_type_type, /* 93 */ + scheme_module_index_type, /* 94 */ + scheme_set_macro_type, /* 95 */ + scheme_listener_type, /* 96 */ + scheme_namespace_type, /* 97 */ + scheme_config_type, /* 98 */ + scheme_stx_type, /* 99 */ + scheme_will_executor_type, /* 100 */ + scheme_custodian_type, /* 101 */ + scheme_random_state_type, /* 102 */ + scheme_regexp_type, /* 103 */ + scheme_bucket_type, /* 104 */ + scheme_bucket_table_type, /* 105 */ + scheme_subprocess_type, /* 106 */ + scheme_compilation_top_type, /* 107 */ + scheme_wrap_chunk_type, /* 108 */ + scheme_eval_waiting_type, /* 109 */ + scheme_tail_call_waiting_type, /* 110 */ + scheme_undefined_type, /* 111 */ + scheme_struct_property_type, /* 112 */ + scheme_chaperone_property_type, /* 113 */ + scheme_multiple_values_type, /* 114 */ + scheme_placeholder_type, /* 115 */ + scheme_table_placeholder_type, /* 116 */ + scheme_scope_table_type, /* 117 */ + scheme_propagate_table_type, /* 118 */ + scheme_svector_type, /* 119 */ + scheme_resolve_prefix_type, /* 120 */ + scheme_security_guard_type, /* 121 */ + scheme_indent_type, /* 122 */ + scheme_udp_type, /* 123 */ + scheme_udp_evt_type, /* 124 */ + scheme_tcp_accept_evt_type, /* 125 */ + scheme_id_macro_type, /* 126 */ + scheme_evt_set_type, /* 127 */ + scheme_wrap_evt_type, /* 128 */ + scheme_handle_evt_type, /* 129 */ + scheme_replace_evt_type, /* 130 */ + scheme_active_replace_evt_type, /* 131 */ + scheme_nack_guard_evt_type, /* 132 */ + scheme_semaphore_repost_type, /* 133 */ + scheme_channel_type, /* 134 */ + scheme_channel_put_type, /* 135 */ + scheme_thread_resume_type, /* 136 */ + scheme_thread_suspend_type, /* 137 */ + scheme_thread_dead_type, /* 138 */ + scheme_poll_evt_type, /* 139 */ + scheme_nack_evt_type, /* 140 */ + scheme_module_registry_type, /* 141 */ + scheme_thread_set_type, /* 142 */ + scheme_string_converter_type, /* 143 */ + scheme_alarm_type, /* 144 */ + scheme_thread_recv_evt_type, /* 145 */ + scheme_thread_cell_type, /* 146 */ + scheme_channel_syncer_type, /* 147 */ + scheme_special_comment_type, /* 148 */ + scheme_write_evt_type, /* 149 */ + scheme_always_evt_type, /* 150 */ + scheme_never_evt_type, /* 151 */ + scheme_progress_evt_type, /* 152 */ + scheme_place_dead_type, /* 153 */ + scheme_already_comp_type, /* 154 */ + scheme_readtable_type, /* 155 */ + scheme_intdef_context_type, /* 156 */ + scheme_lexical_rib_type, /* 157 */ + scheme_thread_cell_values_type, /* 158 */ + scheme_global_ref_type, /* 159 */ + scheme_cont_mark_chain_type, /* 160 */ + scheme_raw_pair_type, /* 161 */ + scheme_prompt_type, /* 162 */ + scheme_prompt_tag_type, /* 163 */ + scheme_continuation_mark_key_type, /* 164 */ + scheme_expanded_syntax_type, /* 165 */ + scheme_delay_syntax_type, /* 166 */ + scheme_cust_box_type, /* 167 */ + scheme_resolved_module_path_type, /* 168 */ + scheme_module_phase_exports_type, /* 169 */ + scheme_logger_type, /* 170 */ + scheme_log_reader_type, /* 171 */ + scheme_marshal_share_type, /* 172 */ + scheme_rib_delimiter_type, /* 173 */ + scheme_noninline_proc_type, /* 174 */ + scheme_prune_context_type, /* 175 */ + scheme_future_type, /* 176 */ + scheme_flvector_type, /* 177 */ + scheme_extflvector_type, /* 178 */ + scheme_fxvector_type, /* 179 */ + scheme_place_type, /* 180 */ + scheme_place_object_type, /* 181 */ + scheme_place_async_channel_type, /* 182 */ + scheme_place_bi_channel_type, /* 183 */ + scheme_once_used_type, /* 184 */ + scheme_serialized_symbol_type, /* 185 */ + scheme_serialized_keyword_type, /* 186 */ + scheme_serialized_structure_type, /* 187 */ + scheme_fsemaphore_type, /* 188 */ + scheme_serialized_tcp_fd_type, /* 189 */ + scheme_serialized_file_fd_type, /* 190 */ + scheme_port_closed_evt_type, /* 191 */ + scheme_proc_shape_type, /* 192 */ + scheme_struct_proc_shape_type, /* 193 */ + scheme_phantom_bytes_type, /* 194 */ + scheme_environment_variables_type, /* 195 */ + scheme_filesystem_change_evt_type, /* 196 */ + scheme_ctype_type, /* 197 */ + scheme_plumber_type, /* 198 */ + scheme_plumber_handle_type, /* 199 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 194 */ + _scheme_last_normal_type_, /* 200 */ - scheme_rt_weak_array, /* 195 */ + scheme_rt_weak_array, /* 201 */ - scheme_rt_comp_env, /* 196 */ - scheme_rt_constant_binding, /* 197 */ - scheme_rt_resolve_info, /* 198 */ - scheme_rt_unresolve_info, /* 199 */ - scheme_rt_optimize_info, /* 200 */ - scheme_rt_compile_info, /* 201 */ - scheme_rt_cont_mark, /* 202 */ - scheme_rt_saved_stack, /* 203 */ - scheme_rt_reply_item, /* 204 */ - scheme_rt_closure_info, /* 205 */ - scheme_rt_overflow, /* 206 */ - scheme_rt_overflow_jmp, /* 207 */ - scheme_rt_meta_cont, /* 208 */ - scheme_rt_dyn_wind_cell, /* 209 */ - scheme_rt_dyn_wind_info, /* 210 */ - scheme_rt_dyn_wind, /* 211 */ - scheme_rt_dup_check, /* 212 */ - scheme_rt_thread_memory, /* 213 */ - scheme_rt_input_file, /* 214 */ - scheme_rt_input_fd, /* 215 */ - scheme_rt_oskit_console_input, /* 216 */ - scheme_rt_tested_input_file, /* 217 */ - scheme_rt_tested_output_file, /* 218 */ - scheme_rt_indexed_string, /* 219 */ - scheme_rt_output_file, /* 220 */ - scheme_rt_load_handler_data, /* 221 */ - scheme_rt_pipe, /* 222 */ - scheme_rt_beos_process, /* 223 */ - scheme_rt_system_child, /* 224 */ - scheme_rt_tcp, /* 225 */ - scheme_rt_write_data, /* 226 */ - scheme_rt_tcp_select_info, /* 227 */ - scheme_rt_param_data, /* 228 */ - scheme_rt_will, /* 229 */ - scheme_rt_linker_name, /* 230 */ - scheme_rt_param_map, /* 231 */ - scheme_rt_finalization, /* 232 */ - scheme_rt_finalizations, /* 233 */ - scheme_rt_cpp_object, /* 234 */ - scheme_rt_cpp_array_object, /* 235 */ - scheme_rt_stack_object, /* 236 */ - scheme_rt_preallocated_object, /* 237 */ - scheme_thread_hop_type, /* 238 */ - scheme_rt_srcloc, /* 239 */ - scheme_rt_evt, /* 240 */ - scheme_rt_syncing, /* 241 */ - scheme_rt_comp_prefix, /* 242 */ - scheme_rt_user_input, /* 243 */ - scheme_rt_user_output, /* 244 */ - scheme_rt_compact_port, /* 245 */ - scheme_rt_read_special_dw, /* 246 */ - scheme_rt_regwork, /* 247 */ - scheme_rt_rx_lazy_string, /* 248 */ - scheme_rt_buf_holder, /* 249 */ - scheme_rt_parameterization, /* 250 */ - scheme_rt_print_params, /* 251 */ - scheme_rt_read_params, /* 252 */ - scheme_rt_native_code, /* 253 */ - scheme_rt_native_code_plus_case, /* 254 */ - scheme_rt_jitter_data, /* 255 */ - scheme_rt_module_exports, /* 256 */ - scheme_rt_delay_load_info, /* 257 */ - scheme_rt_marshal_info, /* 258 */ - scheme_rt_unmarshal_info, /* 259 */ - scheme_rt_runstack, /* 260 */ - scheme_rt_sfs_info, /* 261 */ - scheme_rt_validate_clearing, /* 262 */ - scheme_rt_avl_node, /* 263 */ - scheme_rt_lightweight_cont, /* 264 */ - scheme_rt_export_info, /* 265 */ - scheme_rt_cont_jmp, /* 266 */ - scheme_rt_letrec_check_frame, /* 267 */ + scheme_rt_comp_env, /* 202 */ + scheme_rt_constant_binding, /* 203 */ + scheme_rt_resolve_info, /* 204 */ + scheme_rt_unresolve_info, /* 205 */ + scheme_rt_optimize_info, /* 206 */ + scheme_rt_compile_info, /* 207 */ + scheme_rt_cont_mark, /* 208 */ + scheme_rt_saved_stack, /* 209 */ + scheme_rt_reply_item, /* 210 */ + scheme_rt_closure_info, /* 211 */ + scheme_rt_overflow, /* 212 */ + scheme_rt_overflow_jmp, /* 213 */ + scheme_rt_meta_cont, /* 214 */ + scheme_rt_dyn_wind_cell, /* 215 */ + scheme_rt_dyn_wind_info, /* 216 */ + scheme_rt_dyn_wind, /* 217 */ + scheme_rt_dup_check, /* 218 */ + scheme_rt_thread_memory, /* 219 */ + scheme_rt_input_file, /* 220 */ + scheme_rt_input_fd, /* 221 */ + scheme_rt_oskit_console_input, /* 222 */ + scheme_rt_tested_input_file, /* 223 */ + scheme_rt_tested_output_file, /* 224 */ + scheme_rt_indexed_string, /* 225 */ + scheme_rt_output_file, /* 226 */ + scheme_rt_load_handler_data, /* 227 */ + scheme_rt_pipe, /* 228 */ + scheme_rt_beos_process, /* 229 */ + scheme_rt_system_child, /* 230 */ + scheme_rt_tcp, /* 231 */ + scheme_rt_write_data, /* 232 */ + scheme_rt_tcp_select_info, /* 233 */ + scheme_rt_param_data, /* 234 */ + scheme_rt_will, /* 235 */ + scheme_rt_linker_name, /* 236 */ + scheme_rt_param_map, /* 237 */ + scheme_rt_finalization, /* 238 */ + scheme_rt_finalizations, /* 239 */ + scheme_rt_cpp_object, /* 240 */ + scheme_rt_cpp_array_object, /* 241 */ + scheme_rt_stack_object, /* 242 */ + scheme_rt_preallocated_object, /* 243 */ + scheme_thread_hop_type, /* 244 */ + scheme_rt_srcloc, /* 245 */ + scheme_rt_evt, /* 246 */ + scheme_rt_syncing, /* 247 */ + scheme_rt_comp_prefix, /* 248 */ + scheme_rt_user_input, /* 249 */ + scheme_rt_user_output, /* 250 */ + scheme_rt_compact_port, /* 251 */ + scheme_rt_read_special_dw, /* 252 */ + scheme_rt_regwork, /* 253 */ + scheme_rt_rx_lazy_string, /* 254 */ + scheme_rt_buf_holder, /* 255 */ + scheme_rt_parameterization, /* 256 */ + scheme_rt_print_params, /* 257 */ + scheme_rt_read_params, /* 258 */ + scheme_rt_native_code, /* 259 */ + scheme_rt_native_code_plus_case, /* 260 */ + scheme_rt_jitter_data, /* 261 */ + scheme_rt_module_exports, /* 262 */ + scheme_rt_delay_load_info, /* 263 */ + scheme_rt_marshal_info, /* 264 */ + scheme_rt_unmarshal_info, /* 265 */ + scheme_rt_runstack, /* 266 */ + scheme_rt_sfs_info, /* 267 */ + scheme_rt_validate_clearing, /* 268 */ + scheme_rt_lightweight_cont, /* 269 */ + scheme_rt_export_info, /* 270 */ + scheme_rt_cont_jmp, /* 271 */ + scheme_rt_letrec_check_frame, /* 272 */ #endif - scheme_deferred_expr_type, /* 268 */ + scheme_deferred_expr_type, /* 273 */ _scheme_last_type_ }; diff --git a/racket/src/racket/src/symbol.c b/racket/src/racket/src/symbol.c index d53b927fdd..c90f4024ec 100644 --- a/racket/src/racket/src/symbol.c +++ b/racket/src/racket/src/symbol.c @@ -352,6 +352,17 @@ uintptr_t scheme_get_max_symbol_length() { return scheme_max_symbol_length; } +void scheme_ensure_max_symbol_length(uintptr_t len) +{ +#ifdef MZ_USE_PLACES + mzrt_ensure_max_cas(&scheme_max_symbol_length, len); +#else + if (len > scheme_max_symbol_length) { + scheme_max_symbol_length = len; + } +#endif +} + static Scheme_Object * make_a_symbol(const char *name, uintptr_t len, int kind) @@ -366,15 +377,9 @@ make_a_symbol(const char *name, uintptr_t len, int kind) memcpy(sym->s, name, len); sym->s[len] = 0; -#ifdef MZ_USE_PLACES - mzrt_ensure_max_cas(&scheme_max_symbol_length, len); -#else - if ( len > scheme_max_symbol_length ) { - scheme_max_symbol_length = len; - } -#endif + scheme_ensure_max_symbol_length(len); - return (Scheme_Object *) sym; + return (Scheme_Object *)sym; } Scheme_Object * @@ -928,6 +933,7 @@ static Scheme_Object *gensym(int argc, Scheme_Object *argv[]) { char buffer[100], *str; Scheme_Object *r; + Scheme_Thread *p; if (argc) r = argv[0]; @@ -937,6 +943,18 @@ static Scheme_Object *gensym(int argc, Scheme_Object *argv[]) if (r && !SCHEME_SYMBOLP(r) && !SCHEME_CHAR_STRINGP(r)) scheme_wrong_contract("gensym", "(or/c symbol? string?)", 0, argc, argv); + if (!r) { + /* Generate a name using an enclosing module name during compilation, if available */ + p = scheme_current_thread; + if (p->current_local_env && p->current_local_env->genv->module) { + r = SCHEME_PTR_VAL(p->current_local_env->genv->module->modname); + if (SCHEME_PAIRP(r)) + r = SCHEME_CAR(r); + if (!SCHEME_SYMBOLP(r)) + r = NULL; + } + } + if (r) { char buf[64]; if (SCHEME_CHAR_STRINGP(r)) { @@ -955,6 +973,13 @@ static Scheme_Object *gensym(int argc, Scheme_Object *argv[]) return r; } +Scheme_Object *scheme_gensym(Scheme_Object *base) +{ + Scheme_Object *a[1]; + a[0] = base; + return gensym(1, a); +} + Scheme_Object *scheme_symbol_append(Scheme_Object *s1, Scheme_Object *s2) { char *s; diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index aca03a31aa..8166ac15e3 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -23,21 +23,6 @@ #include "schmach.h" #include "schexpobs.h" -/* The implementation of syntax objects is extremely complex due to - two levels of optimization: - - 1. Different kinds of binding are handled in different ways, - because they'll have different usage patterns. For example, - module-level bindings are handled differently than local - bindings, because modules can't be nested. - - 2. To save time and space, the data structures involved have lots - of caches, and syntax objects to be marshaled undergo a - simplification pass. - - In addition, the need to marshal syntax objects to bytecode - introduces some other complications. */ - ROSYM static Scheme_Object *source_symbol; /* uninterned! */ ROSYM static Scheme_Object *share_symbol; /* uninterned! */ ROSYM static Scheme_Object *origin_symbol; @@ -45,21 +30,71 @@ ROSYM static Scheme_Object *lexical_symbol; ROSYM static Scheme_Object *protected_symbol; ROSYM static Scheme_Object *nominal_id_symbol; +ROSYM static Scheme_Object *module_symbol; +ROSYM static Scheme_Object *top_symbol; +ROSYM static Scheme_Object *macro_symbol; +ROSYM static Scheme_Object *local_symbol; +ROSYM static Scheme_Object *intdef_symbol; +ROSYM static Scheme_Object *use_site_symbol; + +ROSYM static Scheme_Object *name_symbol; +ROSYM static Scheme_Object *context_symbol; +ROSYM static Scheme_Object *bindings_symbol; +ROSYM static Scheme_Object *matchp_symbol; +ROSYM static Scheme_Object *cycle_symbol; +ROSYM static Scheme_Object *free_symbol; +ROSYM static Scheme_Object *fallbacks_symbol; + READ_ONLY Scheme_Object *scheme_syntax_p_proc; -READ_ONLY static Scheme_Stx_Srcloc *empty_srcloc; -READ_ONLY static Scheme_Object *empty_simplified; +READ_ONLY Scheme_Hash_Tree *empty_hash_tree; +READ_ONLY Scheme_Scope_Table *empty_scope_table; +READ_ONLY Scheme_Scope_Table *empty_propagate_table; +READ_ONLY Scheme_Scope_Set *empty_scope_set; -THREAD_LOCAL_DECL(static Scheme_Object *nominal_ipair_cache); -THREAD_LOCAL_DECL(static Scheme_Object *mark_id); -THREAD_LOCAL_DECL(static Scheme_Object *current_rib_timestamp); -THREAD_LOCAL_DECL(static Scheme_Hash_Table *quick_hash_table); +READ_ONLY static Scheme_Stx_Srcloc *empty_srcloc; + +typedef struct Scheme_Scope { + Scheme_Inclhash_Object iso; /* 0x1 => Scheme_Scope_With_Owner */ + mzlonglong id; /* low SCHEME_STX_SCOPE_KIND_SHIFT bits indicate kind */ + Scheme_Object *bindings; /* NULL, vector for one binding, hash table for multiple bindings, + or (rcons hash-table (rcons pes-info ... NULL)); + each hash table maps symbols to (cons scope-set binding) + or (mlist (cons scope-set binding) ...) */ +} Scheme_Scope; + +/* For a scope that is for a particular phase within a set of phase-specific scopes: */ +typedef struct Scheme_Scope_With_Owner { + Scheme_Scope m; + Scheme_Object *owner_multi_scope; + Scheme_Object *phase; +} Scheme_Scope_With_Owner; + +#define SCHEME_SCOPE_FLAGS(m) MZ_OPT_HASH_KEY(&(m)->iso) +#define SCHEME_SCOPE_HAS_OWNER(m) (SCHEME_SCOPE_FLAGS(m) & 0x1) + +#define SCHEME_SCOPE_KIND(m) (((Scheme_Scope *)(m))->id & SCHEME_STX_SCOPE_KIND_MASK) + +READ_ONLY static Scheme_Object *root_scope; + +/* For lazy propagation of scope changes: */ +typedef struct Scheme_Propagate_Table { + Scheme_Scope_Table st; /* Maps scopes to actions, instead of just holding a set of scopes; + action compositions can be collased to an action: + SCHEME_STX_ADD + SCHEME_STX_FLIP = SCHEME_STX_REMOVE, etc. */ + Scheme_Scope_Table *prev; /* points to old scope table as a shortcut; + the old table plus these actions equals + the owning object's current table */ + Scheme_Object *phase_shift; /* or (box ); latter converts only to #f */ +} Scheme_Propagate_Table; + +THREAD_LOCAL_DECL(static mzlonglong scope_counter); THREAD_LOCAL_DECL(static Scheme_Object *last_phase_shift); -THREAD_LOCAL_DECL(static Scheme_Object *unsealed_dependencies); -THREAD_LOCAL_DECL(static Scheme_Hash_Table *id_marks_ht); /* a cache */ -THREAD_LOCAL_DECL(static Scheme_Hash_Table *than_id_marks_ht); /* a cache */ -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *interned_skip_ribs); +THREAD_LOCAL_DECL(static Scheme_Object *nominal_ipair_cache); THREAD_LOCAL_DECL(static Scheme_Bucket_Table *taint_intern_table); +THREAD_LOCAL_DECL(static struct Binding_Cache_Entry *binding_cache_table); +THREAD_LOCAL_DECL(static intptr_t binding_cache_pos); +THREAD_LOCAL_DECL(static intptr_t binding_cache_len); static Scheme_Object *syntax_p(int argc, Scheme_Object **argv); @@ -82,15 +117,15 @@ static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv); static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv); static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_templ_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_binding(int argc, Scheme_Object **argv); -static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv); -static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv); -static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv); -static Scheme_Object *module_binding_symbol(int argc, Scheme_Object **argv); +static Scheme_Object *free_eq(int argc, Scheme_Object **argv); +static Scheme_Object *free_trans_eq(int argc, Scheme_Object **argv); +static Scheme_Object *free_templ_eq(int argc, Scheme_Object **argv); +static Scheme_Object *free_label_eq(int argc, Scheme_Object **argv); +static Scheme_Object *free_binding(int argc, Scheme_Object **argv); +static Scheme_Object *free_trans_binding(int argc, Scheme_Object **argv); +static Scheme_Object *free_templ_binding(int argc, Scheme_Object **argv); +static Scheme_Object *free_label_binding(int argc, Scheme_Object **argv); +static Scheme_Object *free_binding_symbol(int argc, Scheme_Object **argv); static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv); static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv); static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv); @@ -100,25 +135,87 @@ static Scheme_Object *syntax_disarm(int argc, Scheme_Object **argv); static Scheme_Object *syntax_rearm(int argc, Scheme_Object **argv); static Scheme_Object *syntax_taint(int argc, Scheme_Object **argv); -static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj); -static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj); +static Scheme_Object *syntax_debug_info(int argc, Scheme_Object **argv); -static Scheme_Object *raw_stx_content(Scheme_Object *o); -static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp, int need_clone); +static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp, int *mutate); #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -static void preemptive_chunk(Scheme_Stx *stx); +XFORM_NONGCING static int is_armed(Scheme_Object *v); +static Scheme_Object *add_taint_to_stx(Scheme_Object *o, int *mutate); + +static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at); + +static Scheme_Object *make_unmarshal_info(Scheme_Object *phase, Scheme_Object *prefix, Scheme_Object *excepts); +XFORM_NONGCING static Scheme_Object *extract_unmarshal_phase(Scheme_Object *unmarshal_info); +XFORM_NONGCING static Scheme_Object *extract_unmarshal_prefix(Scheme_Object *unmarshal_info); +static Scheme_Hash_Tree *extract_unmarshal_excepts(Scheme_Object *unmarshal_info); +static Scheme_Object *unmarshal_lookup_adjust(Scheme_Object *sym, Scheme_Object *pes); +static Scheme_Object *unmarshal_key_adjust(Scheme_Object *sym, Scheme_Object *pes); + +XFORM_NONGCING static int scopes_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b); +static Scheme_Object *remove_at_scope_list(Scheme_Object *l, Scheme_Object *p); +static Scheme_Object *add_to_scope_list(Scheme_Object *l, Scheme_Object *p); + +static Scheme_Object *wraps_to_datum(Scheme_Stx *stx, Scheme_Marshal_Tables *mt); +static Scheme_Object *scope_unmarshal_content(Scheme_Object *c, struct Scheme_Unmarshal_Tables *utx); + +static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes); +static void sort_vector_symbols(Scheme_Object *vec); + +XFORM_NONGCING static void extract_module_binding_parts(Scheme_Object *l, + Scheme_Object *phase, + Scheme_Object **_insp_desc, + Scheme_Object **_modidx, + Scheme_Object **_exportname, + Scheme_Object **_nominal_modidx, + Scheme_Object **_mod_phase, + Scheme_Object **_nominal_name, + Scheme_Object **_src_phase, + Scheme_Object **_nominal_src_phase); + +static Scheme_Object *stx_debug_info(Scheme_Stx *stx, Scheme_Object *phase, Scheme_Object *seen, int all_bindings); + +static void init_binding_cache(void); +XFORM_NONGCING static void clear_binding_cache(void); +XFORM_NONGCING static void clear_binding_cache_for(Scheme_Object *sym); +XFORM_NONGCING static void clear_binding_cache_stx(Scheme_Stx *stx); #define CONS scheme_make_pair #define ICONS scheme_make_pair +/* "substx" means that we need to propagate marks to nested syntax objects */ #define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj)) #define HAS_CHAPERONE_SUBSTX(obj) (HAS_SUBSTX(obj) || (SCHEME_NP_CHAPERONEP(obj) && HAS_SUBSTX(SCHEME_CHAPERONE_VAL(obj)))) #define SCHEME_INSPECTORP(obj) SAME_TYPE(scheme_inspector_type, SCHEME_TYPE(obj)) +#define SCHEME_INSPECTOR_DESCP(obj) (SCHEME_INSPECTORP(obj) || SCHEME_SYMBOLP(obj)) +#define SCHEME_MODIDXP(l) SAME_TYPE(SCHEME_TYPE(l), scheme_module_index_type) +#define SCHEME_PHASEP(a) (SCHEME_INTP(a) || SCHEME_BIGNUMP(a) || SCHEME_FALSEP(a)) + +#define SCHEME_PHASE_SHIFTP(a) (SCHEME_PHASEP(a) || (SCHEME_BOXP(a) && SCHEME_PHASEP(SCHEME_BOX_VAL(a)))) +/* #f as a phase shift is an alias for (box 0) */ + +#define SCHEME_MULTI_SCOPEP(o) SCHEME_HASHTP(o) +#define SCHEME_SCOPEP(x) (SAME_TYPE(SCHEME_TYPE(x), scheme_scope_type)) + +#define SCHEME_TL_MULTI_SCOPEP(o) (MZ_OPT_HASH_KEY(&(((Scheme_Hash_Table *)o)->iso)) & 0x2) + +/* Represent fallback as vectors, either of size 2 (for normal scope + sets) or size 4 (for sets of propagation instructions, because adding + a fallback layer is an action): */ +#define SCHEME_FALLBACKP(o) SCHEME_VECTORP(o) +#define SCHEME_FALLBACK_QUADP(o) (SCHEME_VEC_SIZE(o) == 4) +#define SCHEME_FALLBACK_FIRST(o) (SCHEME_VEC_ELS(o)[0]) +#define SCHEME_FALLBACK_REST(o) (SCHEME_VEC_ELS(o)[1]) +#define SCHEME_FALLBACK_SCOPE(o) (SCHEME_VEC_ELS(o)[2]) +#define SCHEME_FALLBACK_PHASE(o) (SCHEME_VEC_ELS(o)[3]) + +/* Bindings of the form "everything from module" */ +#define PES_UNMARSHAL_DESCP(v) (SCHEME_VEC_SIZE(v) == 4) +#define PES_BINDINGP(v) (SCHEME_VEC_SIZE(v) == 5) XFORM_NONGCING static int prefab_p(Scheme_Object *o) { @@ -132,72 +229,18 @@ XFORM_NONGCING static int prefab_p(Scheme_Object *o) #define STX_KEY(stx) MZ_OPT_HASH_KEY(&(stx)->iso) -typedef struct Module_Renames { - Scheme_Object so; /* scheme_rename_table_type */ - char kind, needs_unmarshal; - char sealed; /* 1 means bound won't change; 2 means unbound won't change, either */ - Scheme_Object *phase; - Scheme_Object *set_identity; - Scheme_Hash_Table *ht; /* localname -> modidx OR - (cons modidx exportname) OR - (cons modidx nominal_modidx) OR - (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR - (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) - nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase) - import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */ - Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */ - Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase_and_marks)) - phase_and_marks -> phase-index-int OR - (cons marks phase-index-int) - marks -> (nonempty-listof mark) OR - (vector (listof mark) bdg) - like nomarshal ht, but shared from provider */ - Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module; - this table maps a top-level-bound identifier with a non-empty mark - set to a gensym created for the binding */ - Scheme_Object *unmarshal_info; /* stores some renamings as information needed to consult - imported modules and restore renames from their exports */ - Scheme_Hash_Table *free_id_renames; /* like `ht', but only for free-id=? checking, - and targets can also include: - id => resolve id (but cache if possible; never appears after simplifying) - (box (cons sym #f)) => top-level binding - (box (cons sym sym)) => lexical binding */ - Scheme_Object *insp; /* code inspector to enable access to imports */ -} Module_Renames; +#define MUTATE_STX_OBJ 1 +#define MUTATE_STX_SCOPE_TABLE 2 +#define MUTATE_STX_PROP_TABLE 4 -static void unmarshal_rename(Module_Renames *mrn, - Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, - Scheme_Hash_Table *export_registry); - -typedef struct Module_Renames_Set { - Scheme_Object so; /* scheme_rename_table_set_type */ - char kind, sealed; - Scheme_Object *set_identity; - Scheme_Object *prior_contexts; /* for module->namespace */ - Module_Renames *rt, *et; - Scheme_Hash_Table *other_phases; - Scheme_Object *share_marked_names; /* a Module_Renames_Set */ - Scheme_Object *insp; /* code inspector to enable access to imports */ -} Module_Renames_Set; - -#define SCHEME_RENAME_LEN(vec) ((SCHEME_VEC_SIZE(vec) - 2) >> 1) - -typedef struct Scheme_Lexical_Rib { - Scheme_Object so; - Scheme_Object *rename; /* a vector for a lexical rename */ - Scheme_Object *timestamp; - int *sealed; - Scheme_Object *mapped_names; /* only in the initial link; int or hash table */ - struct Scheme_Lexical_Rib *next; -} Scheme_Lexical_Rib; - -#define SCHEME_RENAMESP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_type)) -#define SCHEME_RENAMES_SETP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type)) - -#define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) -#define SCHEME_RIB_DELIMP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rib_delimiter_type)) - -#define SCHEME_PRUNEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_prune_context_type)) +#if 0 +int stx_alloc_obj, stx_skip_alloc_obj; +int stx_alloc_scope_table, stx_skip_alloc_scope_table; +int stx_alloc_prop_table, stx_skip_alloc_prop_table; +# define COUNT_MUTATE_ALLOCS(x) x +#else +# define COUNT_MUTATE_ALLOCS(x) /* empty */ +#endif /* A `taints' field is one of - NULL => clean @@ -206,203 +249,29 @@ typedef struct Scheme_Lexical_Rib { - => clean, but inspector needs to be proagated to children - (list ...+) [interned] => armed; first inspector is to propagate */ -XFORM_NONGCING static int is_member(Scheme_Object *a, Scheme_Object *l) +#ifdef OS_X +# define CHECK_STX_ASSERTS +#endif + +#ifdef CHECK_STX_ASSERTS +# include +# define STX_ASSERT(x) assert(x) +#else +# define STX_ASSERT(x) /* empty */ +#endif + +static Scheme_Object *make_vector3(Scheme_Object *a, Scheme_Object *b, Scheme_Object *c) { - while (SCHEME_PAIRP(l)) { - if (SAME_OBJ(a, SCHEME_CAR(l))) - return 1; - l = SCHEME_CDR(l); - } - return 0; + Scheme_Object *vec; + + vec = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(vec)[0] = a; + SCHEME_VEC_ELS(vec)[1] = b; + SCHEME_VEC_ELS(vec)[2] = c; + + return vec; } -/* Wraps: - - A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a - "vector" (a scheme_wrap_chunk_type) of wrap-elems. - - Each wrap-elem has one of several shapes: - - - A wrap-elem <+num> is a mark - - - A wrap-elem (vector ..._0 ..._0) is a lexical rename - env (sym var : - ->pos) void => not yet computed - or #f sym => var-resolved is answer to replace #f - for nozero skipped ribs - (rlistof (rcons skipped sym)) => generalization of sym - (mcons var-resolved next) => depends on unsealed rib, - will be cleared when rib set - or: - (cons (cons )) => - free-id=? renaming to on match - - A wrap-elem (vector ..._0 ..._0) is also a lexical rename - bool var resolved: sym or (cons ), - where is module/lexical binding info: - (cons #f) => top-level binding - (cons ) => lexical binding - (free-eq-info ...) => module-binding - where the variables have already been resolved and filtered (no mark - or lexical-env comparison needed with the remaining wraps) - - - A wrap-elem (make-rib vector rib) - is an extensible set of lexical renames; it is the same as - having the vectors inline in place of the rib, except that - new vectors can be added imperatively; simplification turns this - into a vector - - - A wrap-elem (make-rib-delimiter ) - appears in pairs around rib elements; the deeper is just a - bracket, while the shallow one contains a non-empty list of - ribs; for each environment name defined within the set of - ribs, no rib within the set can build on a binding to that - environment past the end delimiter; this is used by `local-expand' - when given a list of ribs, and simplifcation eliminates - rib delimiters - - - A wrap-elem (make-prune ) - restricts binding information to that relevant for - as a datum - - - A wrap-elem is a module rename set - the hash table maps renamed syms to modname-srcname pairs - - - A wrap-elem is a set of s for - different phases. - - - A wrap-elem is a chain-specific cache; it maps - identifiers to #t, and 0 to a deeper part of the chain; a - resolution for an identifier can safely skip to the deeper - part if the identifier does not have a mapping; this skips - simple lexical renames (not ribs) and marks, only, and it's - inserted into a chain heuristically - - - A wrap-elem (box (vector )) - is a phase shift by , remapping the first to the - second ; the part is for finding - modules to unmarshal import renamings; cancels - treatment of a following module rename with a matching id - as an "old" environment - - [Don't add a pair case, because sometimes we test for element - versus list-of-element.] - - The lazy_prefix field of a syntax object keeps track of how many of - the first wraps (items and chunks in the list) need to be propagated - to sub-syntax. It is set to -1 to mean no wraps to propagate, but - some taints to propagate. */ - -#define IS_POSMARK(x) (SCHEME_INTP(x) ? (SCHEME_INT_VAL(x) >= 0) : SCHEME_BIGPOS(x)) -#define SCHEME_MARKP(x) (SCHEME_INTP(x) || SCHEME_BIGNUMP(x)) - -XFORM_NONGCING static int nom_mod_p(Scheme_Object *p) -{ - p = SCHEME_CDR(p); - return !SCHEME_PAIRP(p) && !SCHEME_SYMBOLP(p); -} - -/*========================================================================*/ -/* wrap chunks */ -/*========================================================================*/ - -typedef struct { - Scheme_Type type; - mzshort len; - Scheme_Object *a[mzFLEX_ARRAY_DECL]; -} Wrap_Chunk; - -#define MALLOC_WRAP_CHUNK(n) (Wrap_Chunk *)scheme_malloc_tagged(sizeof(Wrap_Chunk) + ((n - mzFLEX_DELTA) * sizeof(Scheme_Object *))) - -/* Macros for iterating over the elements of a wrap. */ - -typedef struct { - Scheme_Object *l; - Scheme_Object *a; - int is_limb; - int pos; -} Wrap_Pos; - -XFORM_NONGCING static void WRAP_POS_SET_FIRST(Wrap_Pos *w) -{ - if (!SCHEME_NULLP(w->l)) { - Scheme_Object *a; - a = SCHEME_CAR(w->l); - if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { - w->is_limb = 1; - w->pos = 0; - w->a = ((Wrap_Chunk *)a)->a[0]; - } else { - w->is_limb = 0; - w->a = a; - } - } - /* silence gcc "may be used uninitialized in this function" warnings */ - else { - w->a = NULL; - w->is_limb = 0; - } -} - -XFORM_NONGCING static MZ_INLINE void DO_WRAP_POS_INC(Wrap_Pos *w) -{ - Scheme_Object *a; - if (w->is_limb && (w->pos + 1 < ((Wrap_Chunk *)SCHEME_CAR(w->l))->len)) { - a = SCHEME_CAR(w->l); - w->pos++; - w->a = ((Wrap_Chunk *)a)->a[w->pos]; - } else { - w->l = SCHEME_CDR(w->l); - if (!SCHEME_NULLP(w->l)) { - a = SCHEME_CAR(w->l); - if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { - w->is_limb = 1; - w->pos = 0; - w->a = ((Wrap_Chunk *)a)->a[0]; - } else { - w->is_limb = 0; - w->a = a; - } - } else - w->is_limb = 0; - } -} - -#define WRAP_POS Wrap_Pos -#define WRAP_POS_INIT(w, wr) (w.l = wr, WRAP_POS_SET_FIRST(&w)) - -#define WRAP_POS_INC(w) DO_WRAP_POS_INC(&w) - -#define WRAP_POS_INIT_END(w) (w.l = scheme_null, w.a = NULL, w.is_limb = 0, w.pos = 0) -#define WRAP_POS_END_P(w) SCHEME_NULLP(w.l) -#define WRAP_POS_FIRST(w) w.a -#define WRAP_POS_COPY(w, w2) (w.l = (w2).l, w.a = (w2).a, w.is_limb = (w2).is_limb, w.pos = (w2).pos) - -/* Walking backwards through one chunk: */ - -XFORM_NONGCING static void DO_WRAP_POS_REVINIT(Wrap_Pos *w, Scheme_Object *k) -{ - Scheme_Object *a; - a = SCHEME_CAR(k); - if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { - w->is_limb = 1; - w->l = k; - w->pos = ((Wrap_Chunk *)a)->len - 1; - w->a = ((Wrap_Chunk *)a)->a[w->pos]; - } else { - w->l = k; - w->a = a; - w->is_limb = 0; - w->pos = 0; - } -} - -#define WRAP_POS_KEY(w) w.l -#define WRAP_POS_REVINIT(w, k) DO_WRAP_POS_REVINIT(&w, k) -#define WRAP_POS_REVEND_P(w) (w.pos < 0) -#define WRAP_POS_DEC(w) --w.pos; if (w.pos >= 0) w.a = ((Wrap_Chunk *)SCHEME_CAR(w.l))->a[w.pos] - -#define WRAP_POS_PLAIN_TAIL(w) (w.is_limb ? (w.pos ? NULL : w.l) : w.l) - /*========================================================================*/ /* initialization */ /*========================================================================*/ @@ -415,6 +284,23 @@ void scheme_init_stx(Scheme_Env *env) register_traversers(); #endif + REGISTER_SO(empty_hash_tree); + REGISTER_SO(empty_scope_table); + REGISTER_SO(empty_propagate_table); + REGISTER_SO(empty_scope_set); + empty_hash_tree = scheme_make_hash_tree(0); + empty_scope_set = (Scheme_Scope_Set *)scheme_make_hash_tree_set(0); + empty_scope_table = MALLOC_ONE_TAGGED(Scheme_Scope_Table); + empty_scope_table->so.type = scheme_scope_table_type; + empty_scope_table->simple_scopes = empty_scope_set; + empty_scope_table->multi_scopes = scheme_null; + empty_propagate_table = (Scheme_Scope_Table *)MALLOC_ONE_TAGGED(Scheme_Propagate_Table); + memcpy(empty_propagate_table, empty_scope_table, sizeof(Scheme_Scope_Table)); + empty_propagate_table->simple_scopes = (Scheme_Scope_Set *)empty_hash_tree; + empty_propagate_table->so.type = scheme_propagate_table_type; + ((Scheme_Propagate_Table *)empty_propagate_table)->phase_shift = scheme_make_integer(0); + ((Scheme_Propagate_Table *)empty_propagate_table)->prev = NULL; + REGISTER_SO(scheme_syntax_p_proc); o = scheme_make_folding_prim(syntax_p, "syntax?", 1, 1, 1); scheme_syntax_p_proc = o; @@ -422,7 +308,7 @@ void scheme_init_stx(Scheme_Env *env) scheme_add_global_constant("syntax?", o, env); GLOBAL_FOLDING_PRIM("syntax->datum", syntax_to_datum, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("datum->syntax", datum_to_syntax, 2, 5, 1, env); + GLOBAL_IMMED_PRIM("datum->syntax", datum_to_syntax, 2, 5, env); GLOBAL_FOLDING_PRIM_UNARY_INLINED("syntax-e", scheme_checked_syntax_e, 1, 1, 1, env); @@ -443,19 +329,19 @@ void scheme_init_stx(Scheme_Env *env) GLOBAL_IMMED_PRIM("syntax-shift-phase-level" , syntax_shift_phase , 2, 2, env); GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 4, env); - GLOBAL_IMMED_PRIM("free-identifier=?" , module_eq , 2, 4, env); - GLOBAL_IMMED_PRIM("free-transformer-identifier=?" , module_trans_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("free-template-identifier=?" , module_templ_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("free-label-identifier=?" , module_label_eq , 2, 2, env); + GLOBAL_IMMED_PRIM("free-identifier=?" , free_eq , 2, 4, env); + GLOBAL_IMMED_PRIM("free-transformer-identifier=?" , free_trans_eq , 2, 2, env); + GLOBAL_IMMED_PRIM("free-template-identifier=?" , free_templ_eq , 2, 2, env); + GLOBAL_IMMED_PRIM("free-label-identifier=?" , free_label_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("identifier-binding" , module_binding , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-transformer-binding" , module_trans_binding , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-template-binding" , module_templ_binding , 1, 1, env); - GLOBAL_IMMED_PRIM("identifier-label-binding" , module_label_binding , 1, 1, env); + GLOBAL_IMMED_PRIM("identifier-binding" , free_binding , 1, 2, env); + GLOBAL_IMMED_PRIM("identifier-transformer-binding" , free_trans_binding , 1, 2, env); + GLOBAL_IMMED_PRIM("identifier-template-binding" , free_templ_binding , 1, 1, env); + GLOBAL_IMMED_PRIM("identifier-label-binding" , free_label_binding , 1, 1, env); GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env); GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env); - GLOBAL_IMMED_PRIM("identifier-binding-symbol" , module_binding_symbol , 1, 2, env); + GLOBAL_IMMED_PRIM("identifier-binding-symbol" , free_binding_symbol , 1, 2, env); GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env); @@ -463,7 +349,9 @@ void scheme_init_stx(Scheme_Env *env) GLOBAL_IMMED_PRIM("syntax-arm" , syntax_arm , 1, 3, env); GLOBAL_IMMED_PRIM("syntax-disarm" , syntax_disarm , 2, 2, env); GLOBAL_IMMED_PRIM("syntax-rearm" , syntax_rearm , 2, 3, env); - GLOBAL_IMMED_PRIM("syntax-taint" , syntax_taint , 1,1, env); + GLOBAL_IMMED_PRIM("syntax-taint" , syntax_taint , 1, 1, env); + + GLOBAL_IMMED_PRIM("syntax-debug-info" , syntax_debug_info , 1, 3, env); REGISTER_SO(source_symbol); REGISTER_SO(share_symbol); @@ -478,10 +366,33 @@ void scheme_init_stx(Scheme_Env *env) protected_symbol = scheme_intern_symbol("protected"); nominal_id_symbol = scheme_intern_symbol("nominal-id"); - REGISTER_SO(mark_id); - REGISTER_SO(current_rib_timestamp); - mark_id = scheme_make_integer(0); - current_rib_timestamp = scheme_make_integer(0); + REGISTER_SO(module_symbol); + REGISTER_SO(top_symbol); + REGISTER_SO(macro_symbol); + REGISTER_SO(local_symbol); + REGISTER_SO(intdef_symbol); + REGISTER_SO(use_site_symbol); + module_symbol = scheme_intern_symbol("module"); + top_symbol = scheme_intern_symbol("top"); + macro_symbol = scheme_intern_symbol("macro"); + local_symbol = scheme_intern_symbol("local"); + intdef_symbol = scheme_intern_symbol("intdef"); + use_site_symbol = scheme_intern_symbol("use-site"); + + REGISTER_SO(name_symbol); + REGISTER_SO(context_symbol); + REGISTER_SO(bindings_symbol); + REGISTER_SO(matchp_symbol); + REGISTER_SO(cycle_symbol); + REGISTER_SO(free_symbol); + REGISTER_SO(fallbacks_symbol); + name_symbol = scheme_intern_symbol("name"); + context_symbol = scheme_intern_symbol("context"); + bindings_symbol = scheme_intern_symbol("bindings"); + matchp_symbol = scheme_intern_symbol("match?"); + cycle_symbol = scheme_intern_symbol("cycle"); + free_symbol = scheme_intern_symbol("free-identifier=?"); + fallbacks_symbol = scheme_intern_symbol("fallbacks"); REGISTER_SO(empty_srcloc); empty_srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); @@ -493,32 +404,15 @@ void scheme_init_stx(Scheme_Env *env) empty_srcloc->col = -1; empty_srcloc->pos = -1; - REGISTER_SO(empty_simplified); - empty_simplified = scheme_make_vector(2, scheme_false); - - scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix); - scheme_install_type_reader(scheme_free_id_info_type, read_free_id_info_prefix); + REGISTER_SO(root_scope); + root_scope = scheme_new_scope(SCHEME_STX_MODULE_SCOPE); } void scheme_init_stx_places(int initial_main_os_thread) { - REGISTER_SO(last_phase_shift); - REGISTER_SO(nominal_ipair_cache); - REGISTER_SO(quick_hash_table); - REGISTER_SO(id_marks_ht); - REGISTER_SO(than_id_marks_ht); - REGISTER_SO(interned_skip_ribs); - REGISTER_SO(unsealed_dependencies); REGISTER_SO(taint_intern_table); - - if (!initial_main_os_thread) { - REGISTER_SO(mark_id); - REGISTER_SO(current_rib_timestamp); - mark_id = scheme_make_integer(0); - current_rib_timestamp = scheme_make_integer(0); - } - - interned_skip_ribs = scheme_make_weak_equal_table(); taint_intern_table = scheme_make_weak_equal_table(); + + init_binding_cache(); } /*========================================================================*/ @@ -536,44 +430,53 @@ Scheme_Object *scheme_make_stx(Scheme_Object *val, STX_KEY(stx) = HAS_SUBSTX(val) ? STX_SUBSTX_FLAG : 0; stx->val = val; stx->srcloc = srcloc; - stx->wraps = scheme_null; + stx->scopes = empty_scope_table; + stx->u.to_propagate = NULL; + stx->shifts = scheme_null; stx->props = props; return (Scheme_Object *)stx; } -Scheme_Object *clone_stx(Scheme_Object *to) +Scheme_Object *clone_stx(Scheme_Object *to, GC_CAN_IGNORE int *mutate) +/* the `mutate` argument tracks whether we can mutate `to` */ { Scheme_Stx *stx = (Scheme_Stx *)to; - Scheme_Object *wraps, *modinfo_cache; - Scheme_Object *taints; - intptr_t lazy_prefix; - int dp; + Scheme_Object *taints, *shifts; + Scheme_Scope_Table *scopes; + Scheme_Scope_Table *to_propagate; + int armed; - wraps = stx->wraps; - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - modinfo_cache = NULL; - lazy_prefix = stx->u.lazy_prefix; - dp = STX_KEY(stx) & STX_ARMED_FLAG; - } else { - modinfo_cache = stx->u.modinfo_cache; - lazy_prefix = 0; - dp = 0; + STX_ASSERT(SCHEME_STXP(to)); + + if (mutate && (*mutate & MUTATE_STX_OBJ)) { + COUNT_MUTATE_ALLOCS(stx_skip_alloc_obj++); + return to; } + taints = stx->taints; + scopes = stx->scopes; + shifts = stx->shifts; + to_propagate = stx->u.to_propagate; + armed = (STX_KEY(stx) & STX_ARMED_FLAG); stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = wraps; - if (modinfo_cache) - stx->u.modinfo_cache = modinfo_cache; - else - stx->u.lazy_prefix = lazy_prefix; /* same as NULL modinfo if no SUBSTX */ + stx->scopes = scopes; + if (STX_KEY(stx) & STX_SUBSTX_FLAG) { + stx->u.to_propagate = to_propagate; + if (armed) + STX_KEY(stx) |= STX_ARMED_FLAG; + } stx->taints = taints; - if (dp) - STX_KEY(stx) |= STX_ARMED_FLAG; + stx->shifts = shifts; + + if (mutate) { + COUNT_MUTATE_ALLOCS(stx_alloc_obj++); + *mutate |= MUTATE_STX_OBJ; + } return (Scheme_Object *)stx; } @@ -598,21 +501,6 @@ Scheme_Object *scheme_make_stx_w_offset(Scheme_Object *val, return scheme_make_stx(val, srcloc, props); } -Scheme_Object *scheme_make_renamed_stx(Scheme_Object *sym, - Scheme_Object *rn) -{ - Scheme_Object *stx; - - stx = scheme_make_stx(sym, empty_srcloc, NULL); - - if (rn) { - rn = scheme_make_pair(rn, scheme_null); - ((Scheme_Stx *)stx)->wraps = rn; - } - - return stx; -} - Scheme_Object *scheme_stx_track(Scheme_Object *naya, Scheme_Object *old, Scheme_Object *origin) @@ -762,1472 +650,1055 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya, } /* Clone nstx, keeping wraps, changing props to ne */ - nstx = (Scheme_Stx *)clone_stx((Scheme_Object *)nstx); + nstx = (Scheme_Stx *)clone_stx((Scheme_Object *)nstx, NULL); nstx->props = ne; return (Scheme_Object *)nstx; } -/******************** chain cache ********************/ - -static int maybe_add_chain_cache(Scheme_Stx *stx) +void scheme_stx_set(Scheme_Object *q_stx, Scheme_Object *val, Scheme_Object *context) { - WRAP_POS awl; - Scheme_Object *p; - int skipable = 0, pos = 1; + clear_binding_cache_stx((Scheme_Stx *)q_stx); - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + ((Scheme_Stx *)q_stx)->val = val; - while (!WRAP_POS_END_P(awl)) { - /* Skip over renames, cancelled marks, and negative marks: */ - p = WRAP_POS_FIRST(awl); - if (SCHEME_VECTORP(p)) { - skipable++; - } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) { - /* ok to skip, but don't count toward needing a cache */ - } else if (SCHEME_HASHTP(p)) { - /* Hack: we store the depth of the table in the chain - in the `size' fields, at least until the table is initialized: */ - Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p; - if (!ht2->count) - pos = ht2->size; - else { - p = scheme_hash_get(ht2, scheme_make_integer(2)); - pos = SCHEME_INT_VAL(p); - } - pos++; - break; - } else - break; - WRAP_POS_INC(awl); + if (context) { + ((Scheme_Stx *)q_stx)->scopes = ((Scheme_Stx *)context)->scopes; + ((Scheme_Stx *)q_stx)->shifts = ((Scheme_Stx *)context)->shifts; + } else { + ((Scheme_Stx *)q_stx)->scopes = NULL; + ((Scheme_Stx *)q_stx)->shifts = NULL; } - if (skipable >= 32) { - /* Insert a cache placeholder. We'll fill it if - it's ever used in resolve_env(). */ - Scheme_Hash_Table *ht; + ((Scheme_Stx *)q_stx)->u.to_propagate = NULL; + ((Scheme_Stx *)q_stx)->taints = NULL; +} - ht = scheme_make_hash_table(SCHEME_hash_ptr); +/******************** scopes ********************/ - ht->size = pos; +Scheme_Object *scheme_stx_root_scope() +{ + /* The root scope is an all-phases scope used by all top-level namespaces + (and not by module namespaces): */ + return root_scope; +} - p = scheme_make_pair((Scheme_Object *)ht, stx->wraps); - stx->wraps = p; +Scheme_Object *scheme_new_scope(int kind) +{ + mzlonglong id; + Scheme_Object *m; + + if (kind == SCHEME_STX_MODULE_MULTI_SCOPE) { + m = scheme_malloc_small_tagged(sizeof(Scheme_Scope_With_Owner)); + SCHEME_SCOPE_FLAGS((Scheme_Scope *)m) |= 0x1; + } else + m = scheme_malloc_small_tagged(sizeof(Scheme_Scope)); + + ((Scheme_Scope *)m)->iso.so.type = scheme_scope_type; + id = ((++scope_counter) << SCHEME_STX_SCOPE_KIND_SHIFT) | kind; + ((Scheme_Scope *)m)->id = id; + + return m; +} + +static Scheme_Object *new_multi_scope(Scheme_Object *debug_name) +/* a multi-scope is a set of phase-specific scopes that are + always added, removed, or flipped as a group */ +{ + Scheme_Hash_Table *multi_scope; + + /* Maps a phase to a scope, where each scope is created on demand: */ + multi_scope = scheme_make_hash_table(SCHEME_hash_ptr); + + if (SCHEME_FALSEP(debug_name)) + MZ_OPT_HASH_KEY(&(multi_scope->iso)) |= 0x2; + + if (SAME_TYPE(SCHEME_TYPE(debug_name), scheme_resolved_module_path_type)) + debug_name = scheme_resolved_module_path_value(debug_name); + if (SCHEME_FALSEP(debug_name)) + debug_name = scheme_gensym(top_symbol); + + scheme_hash_set(multi_scope, scheme_void, debug_name); + + return (Scheme_Object *)multi_scope; +} + +Scheme_Object *scheme_scope_printed_form(Scheme_Object *m) +{ + int kind = ((Scheme_Scope *)m)->id & SCHEME_STX_SCOPE_KIND_MASK; + Scheme_Object *num, *kind_sym, *vec, *name; + + num = scheme_make_integer_value_from_long_long(((Scheme_Scope *)m)->id >> SCHEME_STX_SCOPE_KIND_SHIFT); + + switch (kind) { + case SCHEME_STX_MODULE_SCOPE: + case SCHEME_STX_MODULE_MULTI_SCOPE: + if (SAME_OBJ(m, root_scope)) + kind_sym = top_symbol; + else + kind_sym = module_symbol; + break; + case SCHEME_STX_MACRO_SCOPE: + kind_sym = macro_symbol; + break; + case SCHEME_STX_LOCAL_BIND_SCOPE: + kind_sym = local_symbol; + break; + case SCHEME_STX_INTDEF_SCOPE: + kind_sym = intdef_symbol; + break; + case SCHEME_STX_USE_SITE_SCOPE: + kind_sym = use_site_symbol; + break; + default: + kind_sym = scheme_false; + break; + } + + if (SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)m)) { + Scheme_Object *multi_scope = ((Scheme_Scope_With_Owner *)m)->owner_multi_scope; + name = scheme_eq_hash_get((Scheme_Hash_Table *)multi_scope, scheme_void); + if (!name) name = scheme_false; + + if (SCHEME_TL_MULTI_SCOPEP(multi_scope)) + kind_sym = top_symbol; - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - if (stx->u.lazy_prefix < 0) - stx->u.lazy_prefix = 0; - stx->u.lazy_prefix++; + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[2] = name; + SCHEME_VEC_ELS(vec)[3] = ((Scheme_Scope_With_Owner *)m)->phase; + } else { + vec = scheme_make_vector(2, NULL); + } + + SCHEME_VEC_ELS(vec)[0] = num; + SCHEME_VEC_ELS(vec)[1] = kind_sym; + + return vec; +} + +#define SCHEME_SCOPE_SETP(m) SCHEME_HASHTRP((Scheme_Object *)(m)) + +XFORM_NONGCING static intptr_t scope_set_count(Scheme_Scope_Set *s) +{ + return ((Scheme_Hash_Tree *)s)->count; +} + +XFORM_NONGCING static Scheme_Object *scope_set_get(Scheme_Scope_Set *s, Scheme_Object *key) +{ + return scheme_eq_hash_tree_get((Scheme_Hash_Tree *)s, key); +} + +static Scheme_Scope_Set *scope_set_set(Scheme_Scope_Set *s, Scheme_Object *key, Scheme_Object *val) +{ + return (Scheme_Scope_Set *)scheme_hash_tree_set((Scheme_Hash_Tree *)s, key, val); +} + +XFORM_NONGCING static mzlonglong scope_set_next(Scheme_Scope_Set *s, mzlonglong pos) +{ + return scheme_hash_tree_next((Scheme_Hash_Tree *)s, pos); +} + +XFORM_NONGCING static int scope_set_index(Scheme_Scope_Set *s, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val) +{ + return scheme_hash_tree_index((Scheme_Hash_Tree *)s, pos, _key, _val); +} + +XFORM_NONGCING static int scope_subset(Scheme_Scope_Set *sa, Scheme_Scope_Set *sb) +{ + return scheme_eq_hash_tree_subset_of((Scheme_Hash_Tree *)sa, + (Scheme_Hash_Tree *)sb); +} + +static int scopes_equal(Scheme_Scope_Set *a, Scheme_Scope_Set *b) +{ + return (scope_set_count(a) == scope_set_count(b)) && scope_subset(a, b); +} + +static Scheme_Object *make_fallback_pair(Scheme_Object *a, Scheme_Object *b) +{ + a = scheme_make_vector(2, a); + SCHEME_VEC_ELS(a)[1] = b; + return a; +} + +static Scheme_Object *make_fallback_quad(Scheme_Object *a, Scheme_Object *b, + Scheme_Object *c, Scheme_Object *d) +{ + a = scheme_make_vector(4, a); + SCHEME_VEC_ELS(a)[1] = b; + SCHEME_VEC_ELS(a)[2] = c; + SCHEME_VEC_ELS(a)[3] = d; + return a; +} + +Scheme_Object *extract_simple_scope(Scheme_Object *multi_scope, Scheme_Object *phase) +{ + Scheme_Hash_Table *ht = (Scheme_Hash_Table *)multi_scope; + Scheme_Object *m; + + if (SCHEME_TRUEP(phase) && !SCHEME_INTP(phase)) { + /* make sure phases are interned (in case of a bignum phase, which should be very rare): */ + phase = scheme_intern_literal_number(phase); + } + + m = scheme_eq_hash_get(ht, phase); + if (!m) { + m = scheme_new_scope(SCHEME_STX_MODULE_MULTI_SCOPE); + ((Scheme_Scope_With_Owner *)m)->owner_multi_scope = (Scheme_Object *)ht; + ((Scheme_Scope_With_Owner *)m)->phase = phase; + scheme_hash_set(ht, phase, m); + } + + return m; +} + +static Scheme_Object *extract_simple_scope_from_shifted(Scheme_Object *multi_scope_and_phase, Scheme_Object *phase) +{ + Scheme_Object *ph; + + ph = SCHEME_CDR(multi_scope_and_phase); + if (SCHEME_FALSEP(phase)) { + if (!SCHEME_BOXP(ph)) { + /* number phase shift, so look for #f */ + ph = scheme_false; + } else { + /* phase shift of some to #f, so look for */ + ph = SCHEME_BOX_VAL(ph); } - - return 1; - } - - return 0; + } else if (SCHEME_BOXP(ph)) { + /* we want a number phase, but this is shifted to #f */ + return NULL; + } else + ph = scheme_bin_minus(phase, ph); + + return extract_simple_scope(SCHEME_CAR(multi_scope_and_phase), ph); } -static void set_wraps_to_skip(Scheme_Hash_Table *ht, WRAP_POS *wraps) +static Scheme_Scope_Set *extract_scope_set_from_scope_list(Scheme_Scope_Set *scopes, + Scheme_Object *multi_scopes, + Scheme_Object *phase) { - Scheme_Object *v; + Scheme_Object *m; - v = scheme_hash_get(ht, scheme_make_integer(0)); - wraps->l = v; - v = scheme_hash_get(ht, scheme_make_integer(1)); - if (SCHEME_TRUEP(v)) { - wraps->pos = SCHEME_INT_VAL(v); - wraps->is_limb = 1; - wraps->a = ((Wrap_Chunk *)SCHEME_CAR(wraps->l))->a[wraps->pos]; + /* Combine scopes that exist at all phases with a specific scope for + each set of phase-specific scopes */ + + if (SCHEME_FALLBACKP(multi_scopes)) + multi_scopes = SCHEME_FALLBACK_FIRST(multi_scopes); + + for (; !SCHEME_NULLP(multi_scopes); multi_scopes= SCHEME_CDR(multi_scopes)) { + m = extract_simple_scope_from_shifted(SCHEME_CAR(multi_scopes), phase); + if (m) + scopes = scope_set_set(scopes, m, scheme_true); + } + + return scopes; +} + +static Scheme_Scope_Set *extract_scope_set(Scheme_Stx *stx, Scheme_Object *phase) +{ + Scheme_Scope_Table *st = stx->scopes; + return extract_scope_set_from_scope_list(st->simple_scopes, st->multi_scopes, phase); +} + +static Scheme_Scope_Set *adjust_scope(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode) +/* operate on a single scope within a set */ +{ + STX_ASSERT(SAME_TYPE(SCHEME_TYPE(m), scheme_scope_type)); + + if (scope_set_get(scopes, m)) { + if ((mode == SCHEME_STX_FLIP) || (mode == SCHEME_STX_REMOVE)) + return scope_set_set(scopes, m, NULL); + else + return scopes; } else { - wraps->is_limb = 0; - if (!SCHEME_NULLP(wraps->l)) - wraps->a = SCHEME_CAR(wraps->l); + if (mode == SCHEME_STX_REMOVE) + return scopes; + else + return scope_set_set(scopes, m, scheme_true); } } -static void fill_chain_cache(Scheme_Object *wraps) +Scheme_Object *adjust_scope_list(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode) +/* operate on a set of phase-specific scopes within a set */ { - int pos, max_depth, limit; - Scheme_Hash_Table *ht; - Scheme_Object *p, *id; - WRAP_POS awl; + Scheme_Object *l; - ht = (Scheme_Hash_Table *)SCHEME_CAR(wraps); - - p = scheme_hash_get(ht, scheme_make_integer(5)); - if (p) { - limit = SCHEME_INT_VAL(p); - - /* Extend the chain cache to deeper: */ - set_wraps_to_skip(ht, &awl); - - p = scheme_hash_get(ht, scheme_make_integer(2)); - pos = SCHEME_INT_VAL(p); - - scheme_hash_set(ht, scheme_make_integer(5), NULL); - } else { - pos = ht->size; - ht->size = 0; - - wraps = SCHEME_CDR(wraps); - - WRAP_POS_INIT(awl, wraps); - - limit = 4; - } - - /* Limit how much of the cache we build, in case we never - reuse this cache: */ - max_depth = limit; - - while (!WRAP_POS_END_P(awl)) { - if (!(max_depth--)) { - limit *= 2; - scheme_hash_set(ht, scheme_make_integer(5), scheme_make_integer(limit)); + l = multi_scopes; + if (SCHEME_FALLBACKP(l)) + l = SCHEME_FALLBACK_FIRST(l); + + for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + if (SAME_OBJ(m, SCHEME_CAR(SCHEME_CAR(l))) + && SAME_OBJ(phase, SCHEME_CDR(SCHEME_CAR(l)))) { + if ((mode == SCHEME_STX_ADD) || (mode == SCHEME_STX_PUSH)) + return multi_scopes; break; } + } - p = WRAP_POS_FIRST(awl); - if (SCHEME_VECTORP(p)) { - int i, len; - len = SCHEME_RENAME_LEN(p); - for (i = 0; i < len; i++) { - id = SCHEME_VEC_ELS(p)[i+2]; - if (SCHEME_STXP(id)) - id = SCHEME_STX_VAL(id); - scheme_hash_set(ht, id, scheme_true); - } - } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) { - /* ok to skip */ - } else if (SCHEME_HASHTP(p)) { - /* Hack: we store the depth of the table in the chain - in the `size' fields, at least until the table is initialized: */ - Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p; - int pos2; - if (!ht2->count) - pos2 = ht2->size; - else { - p = scheme_hash_get(ht2, scheme_make_integer(2)); - pos2 = SCHEME_INT_VAL(p); - } - /* The theory here is the same as the `mapped' table: - every power of two covers the whole range, etc. */ - if ((pos & pos2) == pos2) - break; + if (mode == SCHEME_STX_PUSH) { + if (!SCHEME_NULLP(multi_scopes)) + return make_fallback_pair(scheme_make_pair(scheme_make_pair(m, phase), + (SCHEME_FALLBACKP(multi_scopes) + ? SCHEME_FALLBACK_FIRST(multi_scopes) + : multi_scopes)), + multi_scopes); + } + + if ((mode == SCHEME_STX_REMOVE) && SCHEME_NULLP(l)) + return multi_scopes; + else if ((mode == SCHEME_STX_REMOVE) + || ((mode == SCHEME_STX_FLIP && !SCHEME_NULLP(l)))) { + return remove_at_scope_list(multi_scopes, l); + } else + return add_to_scope_list(scheme_make_pair(m, phase), multi_scopes); +} + +static Scheme_Scope_Set *combine_scope(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode) +/* operate on a single scope within a set of propagation instructions */ +{ + Scheme_Object *old_mode; + + STX_ASSERT(SAME_TYPE(SCHEME_TYPE(m), scheme_scope_type)); + + old_mode = scope_set_get(scopes, m); + + if (old_mode) { + if (SCHEME_INT_VAL(old_mode) == mode) { + if (mode == SCHEME_STX_FLIP) + return scope_set_set(scopes, m, NULL); + else + return scopes; + } else if (mode == SCHEME_STX_FLIP) { + mode = SCHEME_INT_VAL(old_mode); + mode = ((mode == SCHEME_STX_REMOVE) ? SCHEME_STX_ADD : SCHEME_STX_REMOVE); + return scope_set_set(scopes, m, scheme_make_integer(mode)); } else - break; - WRAP_POS_INC(awl); - } - - /* Record skip destination: */ - scheme_hash_set(ht, scheme_make_integer(0), awl.l); - if (!awl.is_limb) { - scheme_hash_set(ht, scheme_make_integer(1), scheme_false); - } else { - scheme_hash_set(ht, scheme_make_integer(1), scheme_make_integer(awl.pos)); - } - scheme_hash_set(ht, scheme_make_integer(2), scheme_make_integer(pos)); + return scope_set_set(scopes, m, scheme_make_integer(mode)); + } else + return scope_set_set(scopes, m, scheme_make_integer(mode)); } -/******************** marks ********************/ - -Scheme_Object *scheme_new_mark() +Scheme_Object *combine_scope_list(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode) +/* operate on a set of phase-specific scopes within a set of propagation instructions */ { - mark_id = scheme_add1(1, &mark_id); - return mark_id; + Scheme_Object *l; + + l = multi_scopes; + if (SCHEME_FALLBACKP(l)) { + if ((mode == SCHEME_STX_PUSH) + && SAME_OBJ(SCHEME_FALLBACK_SCOPE(l), m) + && SAME_OBJ(SCHEME_FALLBACK_PHASE(l), phase)) + return multi_scopes; + l = SCHEME_FALLBACK_FIRST(l); + } + + for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + if (SAME_OBJ(m, SCHEME_VEC_ELS(SCHEME_CAR(l))[0]) + && SAME_OBJ(phase, SCHEME_VEC_ELS(SCHEME_CAR(l))[1])) { + int prev_mode = SCHEME_INT_VAL(SCHEME_VEC_ELS(SCHEME_CAR(l))[2]); + if (mode == SCHEME_STX_PUSH) { + if (prev_mode == SCHEME_STX_ADD) + return multi_scopes; + break; + } else if (mode == SCHEME_STX_FLIP) { + if (prev_mode == SCHEME_STX_FLIP) + return remove_at_scope_list(multi_scopes, l); + else { + if (prev_mode == SCHEME_STX_ADD) + mode = SCHEME_STX_REMOVE; + else + mode = SCHEME_STX_ADD; + multi_scopes = remove_at_scope_list(multi_scopes, l); + break; + } + } else if (mode != prev_mode) { + multi_scopes = remove_at_scope_list(multi_scopes, l); + break; + } else + return multi_scopes; + } + } + + if (mode == SCHEME_STX_PUSH) + return make_fallback_quad(scheme_null, multi_scopes, m, phase); + else + return add_to_scope_list(make_vector3(m, phase, scheme_make_integer(mode)), + multi_scopes); } -Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m) +static Scheme_Object *reconstruct_fallback(Scheme_Object *fb, Scheme_Object *r) +/* update actions for first (maybe only) in fallback chain */ +{ + if (fb) { + if (SCHEME_FALLBACK_QUADP(fb)) + return make_fallback_quad(r, + SCHEME_FALLBACK_REST(fb), + SCHEME_FALLBACK_SCOPE(fb), + SCHEME_FALLBACK_PHASE(fb)); + else + return make_fallback_pair(r, SCHEME_FALLBACK_REST(fb)); + } else + return r; +} + +static Scheme_Object *clone_fallback_chain(Scheme_Object *fb) +{ + Scheme_Object *first = NULL, *last = NULL, *p; + + while (SCHEME_FALLBACKP(fb)) { + p = reconstruct_fallback(fb, SCHEME_FALLBACK_FIRST(fb)); + if (last) + SCHEME_FALLBACK_REST(last) = p; + else + first = p; + last = p; + fb = SCHEME_FALLBACK_REST(fb); + } + + return first; +} + +static Scheme_Object *remove_at_scope_list(Scheme_Object *l, Scheme_Object *p) +/* remove element at `p` within `l` */ +{ + Scheme_Object *fb; + Scheme_Object *r = SCHEME_CDR(p); + + if (SCHEME_FALLBACKP(l)) { + fb = l; + l = SCHEME_FALLBACK_FIRST(fb); + } else + fb = NULL; + + while (!SAME_OBJ(l, p)) { + r = scheme_make_pair(SCHEME_CAR(l), r); + l = SCHEME_CDR(l); + } + + return reconstruct_fallback(fb, r); +} + +static Scheme_Object *add_to_scope_list(Scheme_Object *p, Scheme_Object *l) +{ + if (SCHEME_FALLBACKP(l)) + return reconstruct_fallback(l, scheme_make_pair(p, SCHEME_FALLBACK_FIRST(l))); + else + return scheme_make_pair(p, l); +} + +static Scheme_Scope_Table *clone_scope_table(Scheme_Scope_Table *st, Scheme_Scope_Table *prev, + GC_CAN_IGNORE int *mutate) +/* If prev is non-NULL, then `st` is a propagate table */ +{ + Scheme_Scope_Table *st2; + + if (!prev) { + if (*mutate & MUTATE_STX_SCOPE_TABLE) { + st2 = st; + COUNT_MUTATE_ALLOCS(stx_skip_alloc_scope_table++); + } else { + st2 = MALLOC_ONE_TAGGED(Scheme_Scope_Table); + memcpy(st2, st, sizeof(Scheme_Scope_Table)); + *mutate |= MUTATE_STX_SCOPE_TABLE; + COUNT_MUTATE_ALLOCS(stx_alloc_scope_table++); + } + } else { + if (*mutate & MUTATE_STX_PROP_TABLE) { + st2 = st; + COUNT_MUTATE_ALLOCS(stx_skip_alloc_prop_table++); + } else { + st2 = (Scheme_Scope_Table *)MALLOC_ONE_TAGGED(Scheme_Propagate_Table); + memcpy(st2, st, sizeof(Scheme_Propagate_Table)); + if (SAME_OBJ(st, empty_propagate_table)) + ((Scheme_Propagate_Table *)st2)->prev = prev; + *mutate |= MUTATE_STX_PROP_TABLE; + COUNT_MUTATE_ALLOCS(stx_alloc_prop_table++); + } + } + + return st2; +} + +typedef Scheme_Scope_Set *(*do_scope_t)(Scheme_Scope_Set *scopes, Scheme_Object *m, int mode); +typedef Scheme_Object *(do_scope_list_t)(Scheme_Object *multi_scopes, Scheme_Object *m, Scheme_Object *phase, int mode); + +static Scheme_Scope_Table *do_scope_at_phase(Scheme_Scope_Table *st, Scheme_Object *m, Scheme_Object *phase, int mode, + do_scope_t do_scope, do_scope_list_t do_scope_list, Scheme_Scope_Table *prev, + GC_CAN_IGNORE int *mutate) +/* operate on a scope or set of phase specific scopes, + either on a scope set or a set of propagation instructions */ +{ + Scheme_Object *l; + Scheme_Scope_Set *scopes; + + if (SCHEME_SCOPEP(m) && SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)m)) { + if (!SCHEME_FALSEP(phase)) + phase = scheme_bin_minus(phase, ((Scheme_Scope_With_Owner *)m)->phase); + m = ((Scheme_Scope_With_Owner *)m)->owner_multi_scope; + } + + if (SCHEME_MULTI_SCOPEP(m)) { + l = do_scope_list(st->multi_scopes, m, phase, mode); + if (SAME_OBJ(l, st->multi_scopes)) + return st; + st = clone_scope_table(st, prev, mutate); + st->multi_scopes = l; + return st; + } else { + scopes = do_scope(st->simple_scopes, m, mode); + if (SAME_OBJ(scopes, st->simple_scopes)) + return st; + st = clone_scope_table(st, prev, mutate); + st->simple_scopes = scopes; + return st; + } +} + +static Scheme_Object *stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode, + GC_CAN_IGNORE int *mutate) { Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *wraps; - Scheme_Object *taints; - intptr_t lp; - int dp; + Scheme_Scope_Table *scopes; + Scheme_Scope_Table *to_propagate; + Scheme_Object *taints, *shifts; - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - lp = stx->u.lazy_prefix; - if (lp < 0) lp = 0; - dp = STX_KEY(stx) & STX_ARMED_FLAG; + STX_ASSERT(SCHEME_STXP(o)); + + if (mode & SCHEME_STX_PROPONLY) { + scopes = stx->scopes; + mode -= SCHEME_STX_PROPONLY; } else { - lp = 1; - dp = 0; + scopes = do_scope_at_phase(stx->scopes, m, phase, mode, adjust_scope, adjust_scope_list, NULL, mutate); + if ((stx->scopes == scopes) + && !(STX_KEY(stx) & STX_SUBSTX_FLAG)) { + return (Scheme_Object *)stx; + } } - wraps = stx->wraps; - if (SCHEME_PAIRP(wraps) - && SAME_OBJ(m, SCHEME_CAR(wraps)) - && lp) { - --lp; - wraps = SCHEME_CDR(wraps); - } else { - if (maybe_add_chain_cache(stx)) - lp++; - wraps = stx->wraps; - lp++; - wraps = CONS(m, wraps); - } - - taints = stx->taints; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = wraps; - stx->taints = taints; - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - if (!lp && stx->taints && (SCHEME_VOIDP(stx->taints) - || SCHEME_INSPECTORP(stx->taints) - || (SCHEME_PAIRP(stx->taints) - && SCHEME_INSPECTORP(SCHEME_CAR(stx->taints))))) - lp = -1; - stx->u.lazy_prefix = lp; - if (dp) + to_propagate = (stx->u.to_propagate ? stx->u.to_propagate : empty_propagate_table); + to_propagate = do_scope_at_phase(to_propagate, m, phase, mode, combine_scope, combine_scope_list, stx->scopes, mutate); + if ((stx->u.to_propagate == to_propagate) + && (stx->scopes == scopes)) + return (Scheme_Object *)stx; + } else + to_propagate = NULL; /* => clear cache */ + + if (*mutate & MUTATE_STX_OBJ) { + stx->scopes = scopes; + stx->u.to_propagate = to_propagate; + } else { + int armed = (STX_KEY(stx) & STX_ARMED_FLAG); + taints = stx->taints; + shifts = stx->shifts; + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); + stx->scopes = scopes; + stx->u.to_propagate = to_propagate; + stx->taints = taints; + stx->shifts = shifts; + if (armed) STX_KEY(stx) |= STX_ARMED_FLAG; + *mutate |= MUTATE_STX_OBJ; } - /* else cache should stay zeroed */ return (Scheme_Object *)stx; } -/******************** lexical renames ********************/ - -#define RENAME_HT_THRESHOLD 15 - -Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) +Scheme_Object *scheme_stx_adjust_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase, int mode) { - Scheme_Object *v; - int i; + int mutate = 0; + return stx_adjust_scope(o, m, phase, mode, &mutate); +} - v = scheme_make_vector((2 * c) + 2, NULL); - SCHEME_VEC_ELS(v)[0] = newname; - if (c > RENAME_HT_THRESHOLD) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; - } else - SCHEME_VEC_ELS(v)[1] = scheme_false; +Scheme_Object *scheme_stx_add_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) +{ + return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_ADD); +} - for (i = 0; i < c; i++) { - SCHEME_VEC_ELS(v)[2 + c + i] = scheme_void; +Scheme_Object *scheme_stx_remove_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) +{ + return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_REMOVE); +} + +Scheme_Object *scheme_stx_flip_scope(Scheme_Object *o, Scheme_Object *m, Scheme_Object *phase) +{ + return scheme_stx_adjust_scope(o, m, phase, SCHEME_STX_FLIP); +} + +static Scheme_Object *stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode, + GC_CAN_IGNORE int *mutate) +{ + Scheme_Object *key, *val; + intptr_t i; + + i = scope_set_next(scopes, -1); + while (i != -1) { + scope_set_index(scopes, i, &key, &val); + + o = stx_adjust_scope(o, key, phase, mode, mutate); + + i = scope_set_next(scopes, i); } - return v; + return o; } -static void maybe_install_rename_hash_table(Scheme_Object *v) +Scheme_Object *scheme_stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scopes, Scheme_Object *phase, int mode) { - if (SCHEME_VEC_SIZE(v) > ((2 * RENAME_HT_THRESHOLD) + 2)) { - Scheme_Hash_Table *ht; - int i; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1; - for (i = (SCHEME_VEC_SIZE(v) - 2) >> 1; i--; ) { - scheme_hash_set(ht, SCHEME_VEC_ELS(v)[i + 2], scheme_make_integer(i)); - } - SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; - } + int mutate = 0; + return stx_adjust_scopes(o, scopes, phase, mode, &mutate); } -void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname) +/* For each continuation frame, we need to keep track of various sets of scopes: + - bind scopes (normally 0 or 1) are created for the binding context + - use-site scopes are created for macro expansions that need them + - intdef scopes are for immediately nested internal-definition contexts; + they're treated the same as bind scopes + + frame-scopes = main-scopes + . | (vector bind-scopes use-site-scopes intdef-scopes) + bind-scopes = some-scopes + use-site-scopes = some-scopes + intdef-scopes = some-scopes + some-scopes = #f | scope | scope-set */ + +static Scheme_Object *stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, int which, Scheme_Object *phase, int mode) { - /* Every added name must be symbolicly distinct! */ + if (SCHEME_VECTORP(scope)) { + scope = SCHEME_VEC_ELS(scope)[which]; + } else if (which != 0) + return o; - SCHEME_VEC_ELS(rnm)[2 + pos] = oldname; - - /* Add ht mapping, if there's a hash table: */ - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rnm)[1])) { - Scheme_Hash_Table *ht; - ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(rnm)[1]; - if (scheme_hash_get(ht, SCHEME_STX_VAL(oldname))) - pos = -1; /* -1 means multiple entries matching a name */ - scheme_hash_set(ht, SCHEME_STX_VAL(oldname), scheme_make_integer(pos)); - } -} - -Scheme_Object *scheme_make_rename_rib() -{ - Scheme_Lexical_Rib *rib; - int *sealed; - - rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); - rib->so.type = scheme_lexical_rib_type; - rib->timestamp = current_rib_timestamp; - - sealed = (int *)scheme_malloc_atomic(sizeof(int)); - *sealed = 0; - rib->sealed = sealed; - - current_rib_timestamp = scheme_add1(1, ¤t_rib_timestamp); - - return (Scheme_Object *)rib; -} - -void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) -{ - Scheme_Lexical_Rib *rib, *naya; - Scheme_Object *next; - Scheme_Hash_Table *mapped_names; - int i; - - naya = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); - naya->so.type = scheme_lexical_rib_type; - naya->rename = rename; - - rib = (Scheme_Lexical_Rib *)ro; - naya->next = rib->next; - rib->next = naya; - - naya->timestamp = rib->timestamp; - naya->sealed = rib->sealed; - - while (unsealed_dependencies) { - next = SCHEME_CDR(unsealed_dependencies); - SCHEME_CAR(unsealed_dependencies) = NULL; - SCHEME_CDR(unsealed_dependencies) = NULL; - unsealed_dependencies = next; - } - - if (!rib->mapped_names) - rib->mapped_names = scheme_make_integer(1); - else if (SCHEME_INTP(rib->mapped_names)) { - rib->mapped_names = scheme_make_integer(SCHEME_INT_VAL(rib->mapped_names) + 1); - if (SCHEME_INT_VAL(rib->mapped_names) > 32) { - /* Build the initial table */ - mapped_names = scheme_make_hash_table(SCHEME_hash_ptr); - while (naya) { - for (i = SCHEME_RENAME_LEN(naya->rename); i--; ) { - scheme_hash_set(mapped_names, - SCHEME_STX_SYM(SCHEME_VEC_ELS(naya->rename)[2+i]), - scheme_true); - } - naya = naya->next; - } - rib->mapped_names = (Scheme_Object *)mapped_names; - } - } else { - for (i = SCHEME_RENAME_LEN(naya->rename); i--; ) { - scheme_hash_set((Scheme_Hash_Table *)rib->mapped_names, - SCHEME_STX_SYM(SCHEME_VEC_ELS(naya->rename)[2+i]), - scheme_true); - } - } -} - -void scheme_drop_first_rib_rename(Scheme_Object *ro) -{ - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro; - rib->next = rib->next->next; -} - -void scheme_stx_seal_rib(Scheme_Object *rib) -{ - *((Scheme_Lexical_Rib *)rib)->sealed = 1; -} - -int *scheme_stx_get_rib_sealed(Scheme_Object *rib) -{ - return ((Scheme_Lexical_Rib *)rib)->sealed; -} - -Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro) -{ - Scheme_Object *v; - int count = 0, rib_count = 0; - WRAP_POS awl; - Wrap_Chunk *wc; - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro, *rib2; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - while (!WRAP_POS_END_P(awl)) { - count++; - v = WRAP_POS_FIRST(awl); - if (SCHEME_RIBP(v)) { - rib2 = (Scheme_Lexical_Rib *)v; - if (SAME_OBJ(rib2->timestamp, rib->timestamp)) - rib_count++; - } - WRAP_POS_INC(awl); - } - - if (!rib_count) - return stx; - - count -= rib_count; - - wc = MALLOC_WRAP_CHUNK(count); - wc->type = scheme_wrap_chunk_type; - wc->len = count; - - count = 0; - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - while (!WRAP_POS_END_P(awl)) { - v = WRAP_POS_FIRST(awl); - if (SCHEME_RIBP(v)) { - rib2 = (Scheme_Lexical_Rib *)v; - if (SAME_OBJ(rib2->timestamp, rib->timestamp)) - v = NULL; - } - if (v) { - wc->a[count++] = v; - } - WRAP_POS_INC(awl); - } - - v = scheme_make_pair((Scheme_Object *)wc, scheme_null); - - stx = scheme_add_rename(stx, scheme_make_integer(0)); - ((Scheme_Stx *)stx)->wraps = v; - - return stx; -} - -static Scheme_Object *make_prune_context(Scheme_Object *a) -{ - Scheme_Object *p; - - p = scheme_alloc_small_object(); - p->type = scheme_prune_context_type; - SCHEME_BOX_VAL(p) = a; - - return p; -} - -/******************** module renames ********************/ - -static int same_phase(Scheme_Object *a, Scheme_Object *b) -{ - if (SAME_OBJ(a, b)) - return 1; - else if (SCHEME_INTP(a) || SCHEME_INTP(b) - || SCHEME_FALSEP(a) || SCHEME_FALSEP(b) - || SCHEME_VOIDP(a) || SCHEME_VOIDP(b)) - return 0; - else - return scheme_eqv(a, b); -} - -Scheme_Object *scheme_make_module_rename_set(int kind, Scheme_Object *share_marked_names, Scheme_Object *insp) -{ - Module_Renames_Set *mrns; - Scheme_Object *mk; - - if (share_marked_names) - mk = ((Module_Renames_Set *)share_marked_names)->set_identity; - else - mk = scheme_new_mark(); - - mrns = MALLOC_ONE_TAGGED(Module_Renames_Set); - mrns->so.type = scheme_rename_table_set_type; - mrns->kind = kind; - mrns->share_marked_names = share_marked_names; - mrns->set_identity = mk; - mrns->insp = insp; - - return (Scheme_Object *)mrns; -} - -void scheme_add_module_rename_to_set(Scheme_Object *set, Scheme_Object *rn) -{ - Module_Renames_Set *mrns = (Module_Renames_Set *)set; - Module_Renames *mrn = (Module_Renames *)rn; - - mrn->set_identity = mrns->set_identity; - - if (same_phase(mrn->phase, scheme_make_integer(0))) - mrns->rt = mrn; - else if (same_phase(mrn->phase, scheme_make_integer(1))) - mrns->et = mrn; + if (SCHEME_FALSEP(scope)) + return o; + else if (SCHEME_SCOPEP(scope)) + return scheme_stx_adjust_scope(o, scope, phase, mode); else { - Scheme_Hash_Table *ht; - ht = mrns->other_phases; - if (!ht) { - ht = scheme_make_hash_table_equal(); - mrns->other_phases = ht; - } - scheme_hash_set(ht, mrn->phase, (Scheme_Object *)mrn); + STX_ASSERT(SCHEME_SCOPE_SETP(scope)); + return scheme_stx_adjust_scopes(o, (Scheme_Scope_Set *)scope, phase, mode); } } -Scheme_Object *scheme_get_module_rename_from_set(Scheme_Object *set, Scheme_Object *phase, int create) +Scheme_Object *scheme_stx_adjust_frame_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) { - Module_Renames_Set *mrns = (Module_Renames_Set *)set; - Module_Renames *mrn; + o = scheme_stx_adjust_frame_use_site_scopes(o, scope, phase, mode); + o = scheme_stx_adjust_frame_bind_scopes(o, scope, phase, mode); + return stx_adjust_frame_scopes(o, scope, 2, phase, mode); +} - if (same_phase(phase, scheme_make_integer(0))) - mrn = mrns->rt; - else if (same_phase(phase, scheme_make_integer(1))) - mrn = mrns->et; - else if (mrns->other_phases) - mrn = (Module_Renames *)scheme_hash_get(mrns->other_phases, phase); - else - mrn = NULL; +Scheme_Object *scheme_stx_adjust_frame_bind_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) +{ + return stx_adjust_frame_scopes(o, scope, 0, phase, mode); +} - if (!mrn && create) { - Scheme_Hash_Table *marked_names; +Scheme_Object *scheme_stx_adjust_frame_use_site_scopes(Scheme_Object *o, Scheme_Object *scope, Scheme_Object *phase, int mode) +{ + return stx_adjust_frame_scopes(o, scope, 1, phase, mode); +} - if (mrns->share_marked_names) - marked_names = scheme_get_module_rename_marked_names(mrns->share_marked_names, phase, 1); +Scheme_Object *scheme_make_frame_scopes(Scheme_Object *scope) +{ + return scope; +} + +static Scheme_Object *add_frame_scope(Scheme_Object *frame_scopes, Scheme_Object *scope, int pos) +{ + Scheme_Object *scopes; + + if (!frame_scopes) { + if (pos == 0) + return scope; else - marked_names = NULL; - - mrn = (Module_Renames *)scheme_make_module_rename(phase, mrns->kind, marked_names, mrns->insp, - mrns->set_identity); - - scheme_add_module_rename_to_set(set, (Scheme_Object *)mrn); + frame_scopes = scheme_false; } - return (Scheme_Object *)mrn; + if (SCHEME_VECTORP(frame_scopes)) + scopes = SCHEME_VEC_ELS(frame_scopes)[pos]; + else if (pos == 0) + scopes = frame_scopes; + else + scopes = scheme_false; + + if (SCHEME_FALSEP(scopes)) + scopes = scope; + else { + STX_ASSERT(!SCHEME_MULTI_SCOPEP(scopes)); + if (SCHEME_SCOPEP(scopes)) + scopes = (Scheme_Object *)scope_set_set(empty_scope_set, scopes, scheme_true); + scopes = (Scheme_Object *)scope_set_set((Scheme_Scope_Set *)scopes, scope, scheme_true); + } + + if (SCHEME_VECTORP(frame_scopes)) + frame_scopes = make_vector3(SCHEME_VEC_ELS(frame_scopes)[0], + SCHEME_VEC_ELS(frame_scopes)[1], + SCHEME_VEC_ELS(frame_scopes)[2]); + else + frame_scopes = make_vector3(frame_scopes, scheme_false, scheme_false); + + SCHEME_VEC_ELS(frame_scopes)[pos] = scopes; + + return frame_scopes; } -Scheme_Hash_Table *scheme_get_module_rename_marked_names(Scheme_Object *set, Scheme_Object *phase, int create) +Scheme_Object *scheme_add_frame_use_site_scope(Scheme_Object *frame_scopes, Scheme_Object *use_site_scope) { - Scheme_Object *rn; + return add_frame_scope(frame_scopes, use_site_scope, 1); +} - rn = scheme_get_module_rename_from_set(set, phase, create); - if (!rn) +Scheme_Object *scheme_add_frame_intdef_scope(Scheme_Object *frame_scopes, Scheme_Object *scope) +{ + return add_frame_scope(frame_scopes, scope, 2); +} + +static Scheme_Object *add_intdef_scopes_of(Scheme_Object *scopes, Scheme_Object *keep_intdef_scopes) +{ + if (SCHEME_VECTORP(keep_intdef_scopes) + && SCHEME_TRUEP(SCHEME_VEC_ELS(keep_intdef_scopes)[2])) { + if (scopes && SCHEME_VECTORP(scopes)) { + if (SCHEME_TRUEP(SCHEME_VEC_ELS(scopes)[2])) + scheme_signal_error("internal error: cannot currently merge intdef scopes"); + return make_vector3(SCHEME_VEC_ELS(scopes)[0], + SCHEME_VEC_ELS(scopes)[1], + SCHEME_VEC_ELS(keep_intdef_scopes)[2]); + } else + return make_vector3(scopes ? scopes : scheme_false, + scheme_false, + SCHEME_VEC_ELS(keep_intdef_scopes)[2]); + } + + return scopes; +} + +int scheme_stx_has_empty_wraps(Scheme_Object *stx, Scheme_Object *phase) +{ + return (scope_set_count(extract_scope_set((Scheme_Stx *)stx, phase)) == 0); +} + +/******************** shifts ********************/ + +/* Shifts includes both phase shifts (in the sense of + `syntax-shift-phase-level`) and shifting a module reference based + on one modix (at compile time, say) to a different one (at run + time, say). A modidx kind of shift can also include an inspector + substution (e.g., a load-time inspectr to take the place of the + compile-time one) and an export registry for restoring lazily load + bulk-import bindings (for when all exports of a module are + imported, and we go find the imported module on demand). */ + +XFORM_NONGCING static int same_phase(Scheme_Object *a, Scheme_Object *b) +{ + return ((SAME_OBJ(a, b) || scheme_eqv(a, b)) + ? 1 + : 0); +} + +static Scheme_Object *add_shifts(Scheme_Object *old_shift, Scheme_Object *shift) +/* The new `shift` is allowed to be #f, but `old_shift` and the result are + normalized to `(box 0)` */ +{ + if (SCHEME_BOXP(shift) && SCHEME_FALSEP(SCHEME_BOX_VAL(shift))) { + /* (box #f) is an impossible shift, so discard */ + return NULL; + } + + if ((SCHEME_FALSEP(shift) || SCHEME_BOXP(shift)) + && SCHEME_BOXP(old_shift)) { + /* shifting some numbered phase when already shifted to #f; discard */ + return NULL; + } + + if (SCHEME_BOXP(old_shift)) { + /* numbered shift on already shifted to #f => no change */ + return old_shift; + } + + if (SCHEME_FALSEP(shift)) { + /* shift of before shifting 0 to #f => shift - to #f */ + return scheme_box(scheme_bin_minus(scheme_make_integer(0), old_shift)); + } else if (SCHEME_BOXP(shift)) { + /* shift of before shifting to #f => shift - to #f */ + if (SAME_OBJ(old_shift, scheme_make_integer(0))) + return shift; + else + return scheme_box(scheme_bin_minus(SCHEME_BOX_VAL(shift), old_shift)); + } else + return scheme_bin_plus(old_shift, shift); +} + +static Scheme_Object *shift_multi_scope(Scheme_Object *p, Scheme_Object *shift) +/* shift all phase-specific scopes in a set */ +{ + shift = add_shifts(SCHEME_CDR(p), shift); + + if (!shift) return NULL; - if (((Module_Renames *)rn)->marked_names) - return ((Module_Renames *)rn)->marked_names; + if (SAME_OBJ(shift, SCHEME_CDR(p))) + return p; - if (create) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ((Module_Renames *)rn)->marked_names = ht; - return ht; + return scheme_make_pair(SCHEME_CAR(p), shift); +} + +static Scheme_Object *shift_prop_multi_scope(Scheme_Object *p, Scheme_Object *shift) + /* shift all phase-specific scopes in a set of propagation instructions */ +{ + Scheme_Object *p2; + + shift = add_shifts(SCHEME_VEC_ELS(p)[1], shift); + if (!shift) + return NULL; + + if (SAME_OBJ(shift, SCHEME_VEC_ELS(p)[1])) + return p; + + p2 = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(p2)[0] = SCHEME_VEC_ELS(p)[0]; + SCHEME_VEC_ELS(p2)[1] = shift; + SCHEME_VEC_ELS(p2)[2] = SCHEME_VEC_ELS(p)[2]; + + return p2; +} + +typedef Scheme_Object *(shift_multi_scope_t)(Scheme_Object *p, Scheme_Object *shift); + +static Scheme_Scope_Table *shift_scope_table(Scheme_Scope_Table *st, Scheme_Object *shift, + shift_multi_scope_t shift_mm, Scheme_Scope_Table *prev, + GC_CAN_IGNORE int *mutate) +{ + Scheme_Scope_Table *st2; + Scheme_Object *l, *key, *val, *fbs; + + if (SAME_OBJ(st, empty_scope_table)) { + STX_ASSERT(!prev); + return st; } - return NULL; -} + if ((SCHEME_NULLP(st->multi_scopes) + || (SCHEME_FALLBACKP(st->multi_scopes) + && SCHEME_NULLP(SCHEME_FALLBACK_FIRST(st->multi_scopes)))) + && !prev) + return st; -Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *marked_names, - Scheme_Object *insp, Scheme_Object *set_identity) -{ - Module_Renames *mr; - Scheme_Hash_Table *ht; + st2 = clone_scope_table(st, prev, mutate); - if (!set_identity) - set_identity = scheme_new_mark(); - - mr = MALLOC_ONE_TAGGED(Module_Renames); - mr->so.type = scheme_rename_table_type; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - - mr->ht = ht; - mr->phase = phase; - mr->kind = kind; - mr->set_identity = set_identity; - mr->marked_names = marked_names; - mr->shared_pes = scheme_null; - mr->unmarshal_info = scheme_null; - mr->insp = insp; - - return (Scheme_Object *)mr; -} - -void scheme_seal_module_rename(Scheme_Object *rn, int level) -{ - ((Module_Renames *)rn)->sealed = level; -} - -void scheme_seal_module_rename_set(Scheme_Object *_rns, int level) -{ - Module_Renames_Set *rns = (Module_Renames_Set *)_rns; - - rns->sealed = level; - if (rns->rt) - rns->rt->sealed = level; - if (rns->et) - rns->et->sealed = level; - if (rns->other_phases) { - int i; - for (i = 0; i < rns->other_phases->size; i++) { - if (rns->other_phases->vals[i]) { - ((Module_Renames *)rns->other_phases->vals[i])->sealed = level; - } - } - } -} - -Scheme_Object *scheme_rename_set_identity(Scheme_Object *rn_set) -{ - return ((Module_Renames_Set *)rn_set)->set_identity; -} - -static void check_not_sealed(Module_Renames *mrn) -{ - if (mrn->sealed >= STX_SEAL_ALL) - scheme_signal_error("internal error: attempt to change sealed module rename"); -} - -static Scheme_Object *phase_to_index(Scheme_Object *phase) -{ - return phase; -} - -Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, - Scheme_Object *modname, /* actual source module */ - Scheme_Object *localname, /* name in local context */ - Scheme_Object *exname, /* name in definition context */ - Scheme_Object *nominal_mod, /* nominal source module */ - Scheme_Object *nominal_ex, /* nominal import before local renaming */ - intptr_t mod_phase, /* phase of source defn */ - Scheme_Object *src_phase_index, /* nominal import phase */ - Scheme_Object *nom_phase, /* nominal export phase */ - int mode) /* 1 => can be reconstructed from unmarshal info - 2 => free-id=? renaming - 3 => return info */ -{ - Scheme_Object *elem; - Scheme_Object *phase_index; - - if (mode != 3) - check_not_sealed((Module_Renames *)mrn); - - phase_index = phase_to_index(((Module_Renames *)mrn)->phase); - if (!src_phase_index) - src_phase_index = phase_index; - if (!nom_phase) - nom_phase = scheme_make_integer(mod_phase); - - if (SAME_OBJ(modname, nominal_mod) - && SAME_OBJ(exname, nominal_ex) - && !mod_phase - && same_phase(src_phase_index, phase_index) - && same_phase(nom_phase, scheme_make_integer(mod_phase))) { - if (SAME_OBJ(localname, exname)) - elem = modname; - else - elem = CONS(modname, exname); - } else if (SAME_OBJ(exname, nominal_ex) - && SAME_OBJ(localname, exname) - && !mod_phase - && same_phase(src_phase_index, phase_index) - && same_phase(nom_phase, scheme_make_integer(mod_phase))) { - /* It's common that a sequence of similar mappings shows up, - e.g., '(#%kernel . mzscheme) */ - if (nominal_ipair_cache - && SAME_OBJ(SCHEME_CAR(nominal_ipair_cache), modname) - && SAME_OBJ(SCHEME_CDR(nominal_ipair_cache), nominal_mod)) - elem = nominal_ipair_cache; - else { - elem = ICONS(modname, nominal_mod); - nominal_ipair_cache = elem; - } - } else { - if (same_phase(nom_phase, scheme_make_integer(mod_phase))) { - if (same_phase(src_phase_index, phase_index)) - elem = nominal_mod; - else - elem = CONS(nominal_mod, src_phase_index); - } else { - elem = CONS(nominal_mod, CONS(src_phase_index, nom_phase)); - } - elem = CONS(exname, CONS(elem, nominal_ex)); - if (mod_phase) - elem = CONS(scheme_make_integer(mod_phase), elem); - elem = CONS(modname, elem); - } - - if (mode == 1) { - if (!((Module_Renames *)mrn)->nomarshal_ht) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ((Module_Renames *)mrn)->nomarshal_ht = ht; - } - scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, elem); - } else if (mode == 2) { - scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, elem); - } else if (mode == 3) { - return elem; + l = st->multi_scopes; + if (SCHEME_FALLBACKP(l)) { + l = clone_fallback_chain(l); + st2->multi_scopes = l; + fbs = l; } else - scheme_hash_set(((Module_Renames *)mrn)->ht, localname, elem); + fbs = scheme_false; + /* loop to cover all fallbacks; fbs is #f for + no fallback handling, otherwise it's always + a fallback record and the updated list goes + in first or rest */ + while (1) { + int was_fb; + if (SCHEME_FALLBACKP(l)) { + l = SCHEME_FALLBACK_FIRST(l); + was_fb = 1; + } else + was_fb = 0; - return NULL; -} - -void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, - Scheme_Module_Phase_Exports *pt, - Scheme_Object *unmarshal_phase_index, - Scheme_Object *src_phase_index, - Scheme_Object *marks, - Scheme_Object *bdg, - int save_unmarshal) -{ - Module_Renames *mrn = (Module_Renames *)rn; - Scheme_Object *pr, *index_plus_marks; - - check_not_sealed(mrn); - - if (!bdg) bdg = scheme_false; - - if (SCHEME_PAIRP(marks) || SCHEME_TRUEP(bdg)) { - if (SCHEME_TRUEP(bdg)) { - marks = scheme_make_vector(2, marks); - SCHEME_VEC_ELS(marks)[1] = bdg; + /* Loop through one list of multi scopes: */ + val = scheme_null; + for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + key = shift_mm(SCHEME_CAR(l), shift); + if (key) + val = scheme_make_pair(key, val); } - index_plus_marks = scheme_make_pair(marks, src_phase_index); - } else - index_plus_marks = src_phase_index; - pr = scheme_make_pair(scheme_make_pair(modidx, - scheme_make_pair((Scheme_Object *)pt, - index_plus_marks)), - mrn->shared_pes); - mrn->shared_pes = pr; - - if (save_unmarshal) { - pr = scheme_make_pair(scheme_make_pair(modidx, - scheme_make_pair(unmarshal_phase_index, - index_plus_marks)), - mrn->unmarshal_info); - mrn->unmarshal_info = pr; - } -} - -void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info) -{ - Scheme_Object *l; - - l = scheme_make_pair(info, ((Module_Renames *)rn)->unmarshal_info); - ((Module_Renames *)rn)->unmarshal_info = l; -} - -static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, - Scheme_Object *old_midx, Scheme_Object *new_midx, - int do_pes, int do_unm) -{ - Scheme_Hash_Table *ht, *hts, *drop_ht; - Scheme_Object *v; - int i, t; - - check_not_sealed((Module_Renames *)dest); - - if (do_pes) { - if (!SCHEME_NULLP(((Module_Renames *)src)->shared_pes)) { - Scheme_Object *first = NULL, *last = NULL, *pr, *l; - for (l = ((Module_Renames *)src)->shared_pes; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - pr = scheme_make_pair(SCHEME_CAR(l), scheme_null); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; + if (SCHEME_FALLBACKP(fbs)) { + if (was_fb) { + SCHEME_FALLBACK_FIRST(fbs) = val; + l = SCHEME_FALLBACK_REST(fbs); + if (SCHEME_FALLBACKP(l)) + fbs = l; + } else { + SCHEME_FALLBACK_REST(fbs) = val; + break; } - SCHEME_CDR(last) = ((Module_Renames *)dest)->shared_pes; - ((Module_Renames *)dest)->shared_pes = first; - } - } - - if (do_unm) { - if (!SCHEME_NULLP(((Module_Renames *)src)->unmarshal_info)) { - Scheme_Object *first = NULL, *last = NULL, *pr, *l; - for (l = ((Module_Renames *)src)->unmarshal_info; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - pr = scheme_make_pair(SCHEME_CAR(l), scheme_null); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - } - SCHEME_CDR(last) = ((Module_Renames *)dest)->unmarshal_info; - ((Module_Renames *)dest)->unmarshal_info = first; - - ((Module_Renames *)dest)->needs_unmarshal = 1; - } - } - - for (t = 0; t < 2; t++) { - if (!t) { - ht = ((Module_Renames *)dest)->ht; - hts = ((Module_Renames *)src)->ht; - drop_ht = ((Module_Renames *)dest)->nomarshal_ht; } else { - hts = ((Module_Renames *)src)->nomarshal_ht; - if (!hts) - break; - ht = ((Module_Renames *)dest)->nomarshal_ht; - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ((Module_Renames *)dest)->nomarshal_ht = ht; - } - drop_ht = ((Module_Renames *)dest)->ht; - } - - /* Mappings in src overwrite mappings in dest: */ - - for (i = hts->size; i--; ) { - if (hts->vals[i]) { - v = hts->vals[i]; - if (old_midx) { - /* Shift the modidx part */ - if (SCHEME_PAIRP(v)) { - if (SCHEME_PAIRP(SCHEME_CDR(v))) { - /* (list* modidx [mod-phase] exportname nominal_modidx+index nominal_exportname) */ - Scheme_Object *midx1, *midx2; - intptr_t mod_phase; - midx1 = SCHEME_CAR(v); - v = SCHEME_CDR(v); - if (SCHEME_INTP(SCHEME_CAR(v))) { - mod_phase = SCHEME_INT_VAL(SCHEME_CAR(v)); - v = SCHEME_CDR(v); - } else - mod_phase = 0; - midx2 = SCHEME_CAR(SCHEME_CDR(v)); - midx1 = scheme_modidx_shift(midx1, old_midx, new_midx); - if (SCHEME_PAIRP(midx2)) { - midx2 = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(midx2), old_midx, new_midx), - SCHEME_CDR(midx2)); - } else { - midx2 = scheme_modidx_shift(midx2, old_midx, new_midx); - } - v = CONS(SCHEME_CAR(v), CONS(midx2, SCHEME_CDR(SCHEME_CDR(v)))); - if (mod_phase) - v = CONS(scheme_make_integer(mod_phase), v); - v = CONS(midx1, v); - } else if (nom_mod_p(v)) { - /* (cons modidx nominal_modidx) */ - v = ICONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx), - scheme_modidx_shift(SCHEME_CDR(v), old_midx, new_midx)); - } else { - /* (cons modidx exportname) */ - v = CONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx), - SCHEME_CDR(v)); - } - } else { - /* modidx */ - v = scheme_modidx_shift(v, old_midx, new_midx); - } - } - scheme_hash_set(ht, hts->keys[i], v); - if (drop_ht) - scheme_hash_set(drop_ht, hts->keys[i], NULL); - } + st2->multi_scopes = val; + break; } } - /* Need to share marked names: */ - - if (((Module_Renames *)src)->marked_names) { - ((Module_Renames *)dest)->marked_names = ((Module_Renames *)src)->marked_names; + if (prev) { + /* record accumulated shift for propagation */ + shift = add_shifts(((Scheme_Propagate_Table *)st)->phase_shift, shift); + if (!shift) + shift = scheme_box(scheme_false); /* i.e., the impossible shift */ + ((Scheme_Propagate_Table *)st2)->phase_shift = shift; } + + return st2; } -void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest, int do_unm) -{ - do_append_module_rename(src, dest, NULL, NULL, 1, do_unm); -} - -void scheme_append_rename_set_to_env(Scheme_Object *_mrns, Scheme_Env *env) -{ - Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns; - Scheme_Object *mrns2; - int i; - - scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); - mrns2 = env->rename_set; - - if (mrns->rt) { - scheme_append_module_rename((Scheme_Object *)mrns->rt, - scheme_get_module_rename_from_set(mrns2, scheme_make_integer(0), 1), - 1); - } - if (mrns->et) { - scheme_append_module_rename((Scheme_Object *)mrns->et, - scheme_get_module_rename_from_set(mrns2, scheme_make_integer(1), 1), - 1); - } - if (mrns->other_phases) { - for (i = 0; i < mrns->other_phases->size; i++) { - if (mrns->other_phases->vals[i]) { - scheme_append_module_rename(mrns->other_phases->vals[i], - scheme_get_module_rename_from_set(mrns2, - mrns->other_phases->keys[i], - 1), - 1); - } - } - } -} - -void scheme_install_prior_contexts_to_env(Scheme_Object *prior, Scheme_Env *env) -{ - if (prior) { - prior = SCHEME_CDR(prior); - if (!SCHEME_NULLP(prior)) { - ((Module_Renames_Set *)env->rename_set)->prior_contexts = prior; - } - } -} - -Scheme_Object *scheme_accum_prior_contexts(Scheme_Object *rns, Scheme_Object *prior) -{ - if (!prior) - prior = scheme_null; - return scheme_make_pair(((Module_Renames_Set *)rns)->set_identity, prior); -} - -void scheme_remove_module_rename(Scheme_Object *mrn, - Scheme_Object *localname) -{ - check_not_sealed((Module_Renames *)mrn); - scheme_hash_set(((Module_Renames *)mrn)->ht, localname, NULL); - if (((Module_Renames *)mrn)->nomarshal_ht) - scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, NULL); - if (((Module_Renames *)mrn)->free_id_renames) - scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, NULL); -} - -void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht, - Scheme_Hash_Table *export_registry) -{ - /* Put every name mapped by src into ht: */ - Scheme_Object *pr; - Scheme_Hash_Table *hts; - int i, t; - Scheme_Module_Phase_Exports *pt; - Module_Renames *src; - - if (SCHEME_RENAMES_SETP(set)) - src = ((Module_Renames_Set *)set)->rt; - else - src = (Module_Renames *)set; - - if (!src) - return; - - if (src->needs_unmarshal) { - unmarshal_rename(src, NULL, NULL, export_registry); - } - - for (t = 0; t < 2; t++) { - if (!t) - hts = src->ht; - else { - hts = src->nomarshal_ht; - } - - if (hts) { - for (i = hts->size; i--; ) { - if (hts->vals[i]) { - scheme_hash_set(ht, hts->keys[i], scheme_false); - } - } - } - } - - for (pr = src->shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { - pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr)); - for (i = pt->num_provides; i--; ) { - scheme_hash_set(ht, pt->provides[i], scheme_false); - } - } -} - - -Scheme_Object *scheme_rename_to_stx(Scheme_Object *mrn) -{ - Scheme_Object *stx; - stx = scheme_make_stx(scheme_false, empty_srcloc, NULL); - return scheme_add_rename(stx, mrn); -} - -Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx) -{ - Scheme_Object *rns = NULL, *v; - WRAP_POS wl; - - WRAP_POS_INIT(wl, ((Scheme_Stx *)stx)->wraps); - while (!WRAP_POS_END_P(wl)) { - v = WRAP_POS_FIRST(wl); - if (SCHEME_RENAMES_SETP(v)) { - if (rns) - scheme_signal_error("can't convert syntax to rename (two sets)"); - rns = v; - } else if (SCHEME_RENAMESP(v)) { - if (!rns) { - rns = scheme_make_module_rename_set(((Module_Renames *)v)->kind, NULL, NULL); - ((Module_Renames_Set *)rns)->set_identity = ((Module_Renames *)v)->set_identity; - } else if (!SAME_OBJ(((Module_Renames_Set *)rns)->set_identity, - ((Module_Renames *)v)->set_identity)) { - scheme_signal_error("can't convert syntax to rename (identity mismatch)"); - } - scheme_add_module_rename_to_set(rns, v); - } else { - scheme_signal_error("can't convert syntax to rename (non-rename in wrap)"); - } - WRAP_POS_INC(wl); - } - - if (!rns) - scheme_signal_error("can't convert syntax to rename (empty)"); - - return rns; -} - -Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Object *new_insp) -{ - Scheme_Object *nmrn, *a, *l, *nl, *first, *last; - - nmrn = scheme_make_module_rename(((Module_Renames *)mrn)->phase, - mzMOD_RENAME_NORMAL, - NULL, new_insp, - ((Module_Renames *)mrn)->set_identity); - - /* use "append" to copy most info: */ - do_append_module_rename(mrn, nmrn, old_midx, new_midx, 0, 0); - - /* Manually copy unmarshal_infos, where we have to shift anyway: */ - - l = ((Module_Renames *)mrn)->unmarshal_info; - first = scheme_null; - last = NULL; - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx), - SCHEME_CDR(a)), - scheme_null); - if (last) - SCHEME_CDR(last) = nl; - else - first = nl; - last = nl; - l = SCHEME_CDR(l); - } - ((Module_Renames *)nmrn)->unmarshal_info = first; - - l = ((Module_Renames *)mrn)->shared_pes; - first = scheme_null; - last = NULL; - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx), - SCHEME_CDR(a)), - scheme_null); - if (last) - SCHEME_CDR(last) = nl; - else - first = nl; - last = nl; - l = SCHEME_CDR(l); - } - ((Module_Renames *)nmrn)->shared_pes = first; - - if (((Module_Renames *)mrn)->needs_unmarshal) { - ((Module_Renames *)nmrn)->needs_unmarshal = 1; - } - - ((Module_Renames *)nmrn)->sealed = ((Module_Renames *)mrn)->sealed; - - return nmrn; -} - -Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *_mrns, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Object *new_insp) -{ - Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns; - Scheme_Object *mrn, *mrns2; - int i; - - mrns2 = scheme_make_module_rename_set(mrns->kind, NULL, new_insp); - ((Module_Renames_Set *)mrns2)->sealed = mrns->sealed; - ((Module_Renames_Set *)mrns2)->set_identity = mrns->set_identity; - - if (mrns->rt) { - mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->rt, old_midx, new_midx, new_insp); - scheme_add_module_rename_to_set(mrns2, mrn); - } - if (mrns->et) { - mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->et, old_midx, new_midx, new_insp); - scheme_add_module_rename_to_set(mrns2, mrn); - } - if (mrns->other_phases) { - for (i = 0; i < mrns->other_phases->size; i++) { - if (mrns->other_phases->vals[i]) { - mrn = scheme_stx_shift_rename(mrns->other_phases->vals[i], old_midx, new_midx, new_insp); - scheme_add_module_rename_to_set(mrns2, mrn); - } - } - } - - return (Scheme_Object *)mrns2; -} - - -Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn) -{ - return ((Module_Renames *)rn)->marked_names; -} - -static void unmarshal_rename(Module_Renames *mrn, - Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, - Scheme_Hash_Table *export_registry) -{ - Scheme_Object *l; - int sealed; - - mrn->needs_unmarshal = 0; - - sealed = mrn->sealed; - if (sealed) - mrn->sealed = 0; - - l = scheme_reverse(mrn->unmarshal_info); - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - scheme_do_module_rename_unmarshal((Scheme_Object *)mrn, SCHEME_CAR(l), - modidx_shift_from, modidx_shift_to, - export_registry); - } - - if (sealed) - mrn->sealed = sealed; -} - -/******************** wrap manipulations ********************/ - -Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename) +static Scheme_Object *shift_scopes(Scheme_Object *o, Scheme_Object *shift, int prop_only, + GC_CAN_IGNORE int *mutate) { Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *wraps; - Scheme_Object *taints; - intptr_t lp; - int dp; + Scheme_Scope_Table *st, *p_st; + if (prop_only) + st = stx->scopes; + else + st = shift_scope_table(stx->scopes, shift, shift_multi_scope, NULL, mutate); if (STX_KEY(stx) & STX_SUBSTX_FLAG) - preemptive_chunk(stx); + p_st = shift_scope_table((stx->u.to_propagate ? stx->u.to_propagate : empty_propagate_table), + shift, shift_prop_multi_scope, stx->scopes, + mutate); + else + p_st = NULL; + + if (SAME_OBJ(stx->scopes, st) + && (!(STX_KEY(stx) & STX_SUBSTX_FLAG) + || SAME_OBJ(stx->u.to_propagate, p_st))) + return (Scheme_Object *)stx; - /* relative order matters: chunk first, so that chunking - doesn't immediately throw away a chain cache */ + stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); - maybe_add_chain_cache(stx); + stx->scopes = st; + if (p_st) + stx->u.to_propagate = p_st; + + return (Scheme_Object *)stx; +} - wraps = CONS(rename, stx->wraps); - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - lp = stx->u.lazy_prefix; - if (lp < 0) - lp = 1; - else - lp++; - dp = STX_KEY(stx) & STX_ARMED_FLAG; - } else { - lp = 0; - dp = 0; +static Scheme_Object *do_stx_add_shift(Scheme_Object *o, Scheme_Object *shift, GC_CAN_IGNORE int *mutate) +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + Scheme_Object *vec, *shifts; + + if (!shift) return (Scheme_Object *)stx; + + if (SCHEME_PHASE_SHIFTP(shift)) { + if (SAME_OBJ(shift, scheme_make_integer(0))) + return (Scheme_Object *)stx; + return shift_scopes((Scheme_Object *)stx, shift, 0, mutate); } - taints = stx->taints; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = wraps; - stx->taints = taints; + if (SCHEME_VECTORP(shift) + && (SCHEME_VEC_SIZE(shift) == 6) + && (SCHEME_VEC_ELS(shift)[5] != scheme_make_integer(0))) { + /* Handle phase shift by itself, first: */ + stx = (Scheme_Stx *)do_stx_add_shift((Scheme_Object *)stx, SCHEME_VEC_ELS(shift)[5], mutate); + /* strip away phase shift: */ + vec = scheme_make_vector(6, NULL); + SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(shift)[0]; + SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(shift)[1]; + SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(shift)[2]; + SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(shift)[3]; + SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(shift)[4]; + SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(0); + shift = vec; + } - stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */ - if (dp) - STX_KEY(stx) |= STX_ARMED_FLAG; + /* Drop useless shift (identidy modidx shift and no inspector or exports): */ + if (SAME_OBJ(SCHEME_VEC_ELS(shift)[0], SCHEME_VEC_ELS(shift)[1]) + && ((SCHEME_VEC_SIZE(shift) <= 3) + || SCHEME_FALSEP(SCHEME_VEC_ELS(shift)[3])) + && ((SCHEME_VEC_SIZE(shift) <= 4) + || SCHEME_FALSEP(SCHEME_VEC_ELS(shift)[4]))) + return (Scheme_Object *)stx; + + if (STX_KEY(stx) & STX_SUBSTX_FLAG) { + /* Keep track of shifts that need to be propagated */ + vec = scheme_make_vector(3, NULL); + if (SCHEME_VECTORP(stx->shifts)) { + shifts = scheme_make_pair(shift, SCHEME_VEC_ELS(stx->shifts)[1]); + SCHEME_VEC_ELS(vec)[1] = shifts; + SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(stx->shifts)[2]; + shifts = SCHEME_VEC_ELS(stx->shifts)[0]; + } else { + shifts = scheme_make_pair(shift, scheme_null); + SCHEME_VEC_ELS(vec)[1] = shifts; + SCHEME_VEC_ELS(vec)[2] = stx->shifts; + shifts = stx->shifts; + } + shifts = scheme_make_pair(shift, shifts); + SCHEME_VEC_ELS(vec)[0] = shifts; + shifts = vec; + } else { + /* No need to propagate, so it's a simple addition. */ + shifts = scheme_make_pair(shift, stx->shifts); + } + + stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); + stx->shifts = shifts; + + if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && !stx->u.to_propagate) + stx->u.to_propagate = empty_propagate_table; return (Scheme_Object *)stx; } -void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i) +Scheme_Object *scheme_stx_add_shift(Scheme_Object *o, Scheme_Object *shift) { - Scheme_Object *stx; - int c; - - stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]), - (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair)); - rp->stxes[i] = stx; - c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair)); - --c; - SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c); - if (!c) { - SCHEME_CDR(rp->delay_info_rpair) = NULL; - rp->delay_info_rpair = NULL; - } + int mutate = 0; + return do_stx_add_shift(o, shift, &mutate); } -Scheme_Object *scheme_delayed_rename(Scheme_Object **o, intptr_t i) +Scheme_Object *scheme_stx_add_shifts(Scheme_Object *o, Scheme_Object *l) { - Scheme_Object *rename, *v; - Resolve_Prefix *rp; + int mutate = 0; - rename = o[0]; - - if (!rename) return scheme_false; /* happens only with corrupted .zo! */ - - rp = (Resolve_Prefix *)o[1]; - - v = rp->stxes[i]; - - if (SCHEME_INTP(v)) { - scheme_load_delayed_syntax(rp, i); - v = rp->stxes[i]; + for (l = scheme_reverse(l); !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + o = do_stx_add_shift(o, SCHEME_CAR(l), &mutate); } - v = scheme_add_rename(v, rename); + return o; +} + +Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, + Scheme_Object *old_midx, Scheme_Object *new_midx, + Scheme_Hash_Table *export_registry, + Scheme_Object *src_insp_desc, Scheme_Object *insp) +{ + Scheme_Object *exr; - /* Phase shift... */ - rename = SCHEME_BOX_VAL(rename); - rename = SCHEME_VEC_ELS(rename)[4]; - if (!SCHEME_FALSEP(rename)) { - /* need to propagate the inspector for dye packs, too */ - (void)set_false_insp((Scheme_Object *)v, rename, 0); + if (!phase_delta) + phase_delta = scheme_make_integer(0); + + if (!new_midx) { + old_midx = scheme_false; + new_midx = scheme_false; } + if (!src_insp_desc) + src_insp_desc = scheme_false; + if (!insp) + insp = scheme_false; + if (!export_registry) + exr = scheme_false; + else + exr = (Scheme_Object *)export_registry; - return v; -} - -Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib) -{ -#if 0 - WRAP_POS wl; - - /* Shortcut: there's a good chance that o already has the renaming rib */ - WRAP_POS_INIT(wl, ((Scheme_Stx *)o)->wraps); - if (!WRAP_POS_END_P(wl)) { - if (SAME_OBJ(rib, WRAP_POS_FIRST(wl))) { - return o; - } - } -#endif - - return scheme_add_rename(o, rib); -} - -Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs) -{ - Scheme_Object *s; - - s = scheme_alloc_small_object(); - s->type = scheme_rib_delimiter_type; - SCHEME_BOX_VAL(s) = ribs; - - return scheme_add_rename(o, s); -} - -static int is_in_rib_delim(Scheme_Object *envname, Scheme_Object *rib_delim) -{ - Scheme_Object *l = SCHEME_BOX_VAL(rib_delim); - Scheme_Lexical_Rib *rib; - - while (!SCHEME_NULLP(l)) { - rib = (Scheme_Lexical_Rib *)SCHEME_CAR(l); - while (rib) { - if (rib->rename && SAME_OBJ(envname, SCHEME_VEC_ELS(rib->rename)[0])) - return 1; - rib = rib->next; - } - l = SCHEME_CDR(l); - } - return 0; -} - -static Scheme_Hash_Table *make_recur_table() -{ - if (quick_hash_table) { - GC_CAN_IGNORE Scheme_Hash_Table *t; - t = quick_hash_table; - quick_hash_table = NULL; - return t; - } else - return scheme_make_hash_table(SCHEME_hash_ptr); -} - -static void release_recur_table(Scheme_Hash_Table *free_id_recur) -{ - if (!free_id_recur->size && !quick_hash_table) { - quick_hash_table = free_id_recur; - } -} - -static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, - Scheme_Object *id, - Scheme_Object *orig_id, - int *_sealed, - Scheme_Hash_Table *free_id_recur) -{ - Scheme_Object *result; - Scheme_Object *modname; - Scheme_Object *nominal_modidx; - Scheme_Object *nominal_name, *nom2; - Scheme_Object *mod_phase; - Scheme_Object *src_phase_index; - Scheme_Object *nominal_src_phase; - Scheme_Object *lex_env; - Scheme_Object *rename_insp; - - if (scheme_hash_get(free_id_recur, id)) { - *_sealed = 1; - return id; - } - scheme_hash_set(free_id_recur, id, id); - - nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); - - modname = scheme_stx_module_name(free_id_recur, - &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, - &nominal_name, - &mod_phase, - &src_phase_index, - &nominal_src_phase, - &lex_env, - _sealed, - &rename_insp, - NULL); - - if (SCHEME_SYMBOLP(nom2)) - nominal_name = nom2; - - if (!modname) - result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false)); - else if (SAME_OBJ(modname, scheme_undefined)) - result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), lex_env)); - else { - /* dropping rename_insp means that a free-id=? re-export loses - some permissions (that it really shouldn't have been giving out - anyway */ - result = scheme_extend_module_rename(mrn, - modname, - id, /* name in local context */ - orig_id, /* name in definition context */ - nominal_modidx, /* nominal source module */ - nominal_name, /* nominal import before local renaming */ - SCHEME_INT_VAL(mod_phase), /* phase of source defn */ - src_phase_index, /* nominal import phase */ - nominal_src_phase, /* nominal export phase */ - 3); - } - - if (*_sealed) { - /* cache the result */ - scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, id, result); - } - - return result; -} - -void scheme_install_free_id_rename(Scheme_Object *id, - Scheme_Object *orig_id, - Scheme_Object *rename_rib, - Scheme_Object *phase) -{ - Scheme_Object *v = NULL, *env, *r_id; - Scheme_Lexical_Rib *rib = NULL; - - if (rename_rib && (SCHEME_RENAMESP(rename_rib) || SCHEME_RENAMES_SETP(rename_rib))) { - /* Install a Module_Rename-level free-id=? rename, instead of at - the level of a lexical-rename. In this case, id is a symbol instead - of an identifier. */ - Module_Renames *rn; - - if (SCHEME_RENAMES_SETP(rename_rib)) - rename_rib = scheme_get_module_rename_from_set(rename_rib, phase, 1); - rn = (Module_Renames *)rename_rib; - - if (!rn->free_id_renames) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - rn->free_id_renames = ht; - } - - scheme_hash_set(rn->free_id_renames, id, orig_id); - - return; - } - - env = scheme_stx_moduleless_env(id); - - if (rename_rib) { - rib = (Scheme_Lexical_Rib *)rename_rib; - } else { - WRAP_POS wl; - - WRAP_POS_INIT(wl, ((Scheme_Stx *)id)->wraps); - while (!WRAP_POS_END_P(wl)) { - v = WRAP_POS_FIRST(wl); - if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) { - break; - } if (SCHEME_RIBP(v)) { - rib = (Scheme_Lexical_Rib *)v; - while (rib) { - if (rib->rename) { - v = rib->rename; - if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) - break; - v = NULL; - } - rib = rib->next; - } - } else - v = NULL; - WRAP_POS_INC(wl); - } - } - - while (v || rib) { - if (!v) { - while (rib) { - if (rib->rename) { - v = rib->rename; - if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) - break; - v = NULL; - } - rib = rib->next; - } - } - - if (v) { - int i, sz; - - sz = SCHEME_RENAME_LEN(v); - for (i = 0; i < sz; i++) { - r_id = SCHEME_VEC_ELS(v)[i+2]; - if (SAME_OBJ(SCHEME_STX_SYM(r_id), SCHEME_STX_VAL(id))) { - /* Install rename: */ - env = SCHEME_VEC_ELS(v)[i+sz+2]; - if (SCHEME_PAIRP(env)) env = SCHEME_CAR(env); - env = CONS(env, CONS(orig_id, phase)); - SCHEME_VEC_ELS(v)[i+sz+2] = env; - return; - } - } - } - - v = NULL; - if (rib) rib = rib->next; - } -} - -Scheme_Object *scheme_stx_phase_shift_as_rename(Scheme_Object *shift, Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, Scheme_Object *insp, - Scheme_Object *ignore_old_identity) -{ - if (!shift) - shift = scheme_make_integer(0); - - if (!SCHEME_INTP(shift) || SCHEME_INT_VAL(shift) || new_midx || export_registry || insp) { + if (new_midx || export_registry || insp) { Scheme_Object *vec; + + vec = last_phase_shift; - if (last_phase_shift - && ((vec = SCHEME_BOX_VAL(last_phase_shift))) - && (SCHEME_VEC_ELS(vec)[0] == shift) - && (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false)) - && (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false)) - && (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false)) - && (SCHEME_VEC_ELS(vec)[4] == (insp ? insp : scheme_false)) - && (SCHEME_VEC_ELS(vec)[5] == (ignore_old_identity ? ignore_old_identity : scheme_false))) { + if (vec + && (SCHEME_VEC_ELS(vec)[0] == old_midx) + && (SCHEME_VEC_ELS(vec)[1] == new_midx) + && (SCHEME_VEC_ELS(vec)[2] == src_insp_desc) + && (SCHEME_VEC_ELS(vec)[3] == insp) + && (SCHEME_VEC_ELS(vec)[4] == exr) + && (SCHEME_VEC_ELS(vec)[5] == phase_delta)) { /* use the old one */ } else { vec = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(vec)[0] = shift; - SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false); - SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false); - SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false); - SCHEME_VEC_ELS(vec)[4] = (insp ? insp : scheme_false); - SCHEME_VEC_ELS(vec)[5] = (ignore_old_identity ? ignore_old_identity : scheme_false); - - last_phase_shift = scheme_box(vec); + SCHEME_VEC_ELS(vec)[0] = old_midx; + SCHEME_VEC_ELS(vec)[1] = new_midx; + SCHEME_VEC_ELS(vec)[2] = src_insp_desc; + SCHEME_VEC_ELS(vec)[3] = insp; + SCHEME_VEC_ELS(vec)[4] = exr; + SCHEME_VEC_ELS(vec)[5] = phase_delta; + + last_phase_shift = vec; } return last_phase_shift; @@ -2235,22 +1706,88 @@ Scheme_Object *scheme_stx_phase_shift_as_rename(Scheme_Object *shift, Scheme_Obj return NULL; } -Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, Scheme_Object *shift, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry, - Scheme_Object *insp, - Scheme_Object *ignore_old_identity) -/* Shifts the phase on a syntax object in a module. A 0 shift might be - used just to re-direct relative module paths. new_midx might be - NULL to shift without redirection. And so on. */ +void scheme_clear_shift_cache(void) { - Scheme_Object *ps; + last_phase_shift = NULL; + nominal_ipair_cache = NULL; + clear_binding_cache(); +} - ps = scheme_stx_phase_shift_as_rename(shift, old_midx, new_midx, export_registry, insp, ignore_old_identity); - if (ps) - return scheme_add_rename(stx, ps); +Scheme_Object *scheme_stx_shift(Scheme_Object *stx, + Scheme_Object *phase_delta, + Scheme_Object *old_midx, Scheme_Object *new_midx, + Scheme_Hash_Table *export_registry, + Scheme_Object *src_insp_desc, Scheme_Object *insp) +/* Shifts the modidx on a syntax object in a module as well as the phase of scopes. */ +{ + Scheme_Object *s; + + s = scheme_make_shift(phase_delta, old_midx, new_midx, export_registry, src_insp_desc, insp); + if (s) + stx = scheme_stx_add_shift(stx, s); + + return stx; +} + +static Scheme_Object *apply_modidx_shifts(Scheme_Object *shifts, Scheme_Object *modidx, + Scheme_Object **_insp, Scheme_Hash_Table **_export_registry) +{ +#define QUICK_SHIFT_LEN 5 + Scheme_Object *vec, *dest, *src, *insp_desc; + Scheme_Object *quick_a[QUICK_SHIFT_LEN], **a; + intptr_t i, len; + + /* Strip away propagation layer, if any: */ + if (SCHEME_VECTORP(shifts)) + shifts = SCHEME_VEC_ELS(shifts)[0]; + + if (_insp && *_insp) + insp_desc = *_insp; else - return stx; + insp_desc = scheme_false; + + /* The `shifts` list is in the reverse order that we want... */ + + len = scheme_list_length(shifts); + if (len <= QUICK_SHIFT_LEN) + a = quick_a; + else + a = MALLOC_N(Scheme_Object *, len); + + i = len; + while (!SCHEME_NULLP(shifts)) { + a[--i] = SCHEME_CAR(shifts); + shifts = SCHEME_CDR(shifts); + } + + if (_export_registry) + *_export_registry = NULL; + + for (i = 0; i < len; i++) { + vec = a[i]; + + src = SCHEME_VEC_ELS(vec)[0]; + dest = SCHEME_VEC_ELS(vec)[1]; + + modidx = scheme_modidx_shift(modidx, src, dest); + + if (SCHEME_VEC_SIZE(vec) > 2) { + if (SCHEME_SYMBOLP(insp_desc) + && SAME_OBJ(insp_desc, SCHEME_VEC_ELS(vec)[2])) { + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[3])) + insp_desc = SCHEME_VEC_ELS(vec)[3]; + if (_export_registry + && (SCHEME_VEC_SIZE(vec) > 4) + && !SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[4])) + *_export_registry = (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[4]; + } + } + } + + if (_insp && (!*_insp || !SCHEME_INSPECTORP(*_insp))) + *_insp = insp_desc; + + return modidx; } static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv) @@ -2263,275 +1800,366 @@ static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv) if (SCHEME_INTP(argv[1]) && !SCHEME_INT_VAL(argv[1])) return argv[0]; - return scheme_stx_phase_shift(argv[0], argv[1], NULL, NULL, NULL, NULL, NULL); + return scheme_stx_add_shift(argv[0], argv[1]); } -void scheme_clear_shift_cache(void) +/******************** lazy propagation ********************/ + +#define DO_COUNT_PROPAGATES 0 +#if DO_COUNT_PROPAGATES +# define COUNT_PROPAGATES(x) x +int stx_shorts, stx_meds, stx_longs, stx_couldas; +#else +# define COUNT_PROPAGATES(x) /* empty */ +#endif + +static Scheme_Object *propagate_scope_set(Scheme_Scope_Set *props, Scheme_Object *o, + Scheme_Object *phase, int flag, + GC_CAN_IGNORE int *mutate) { - last_phase_shift = NULL; -} + intptr_t i; + Scheme_Object *key, *val; -static Scheme_Object *make_chunk(int len, Scheme_Object *owner_wraps) -/* Result is a single wrap element (possibly a chunk) or a list - of elements in reverse order. */ -{ - Wrap_Chunk *wc; - Scheme_Object *l, *a, *max_chunk_start_list = NULL, *ml; - int i, count = 0, j, max_chunk_size = 0, max_chunk_start_pos = 0; + i = scope_set_next(props, -1); + while (i != -1) { + scope_set_index(props, i, &key, &val); - if (len > 1) { - for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) { - j = ((Wrap_Chunk *)a)->len; - if (j > max_chunk_size) { - max_chunk_start_list = l; - max_chunk_start_pos = i; - max_chunk_size = j; - } - count += j; - } else if (SCHEME_NUMBERP(a)) { - if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l))) - count++; - else { - /* Skip canceling marks */ - i++; - l = SCHEME_CDR(l); - } - } else if (SCHEME_HASHTP(a)) { - /* Don't propagate chain-specific table */ - } else - count++; - } + STX_ASSERT(!SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)key)); - if ((max_chunk_size > 8) && ((max_chunk_size * 2) > count)) { - /* It's not worth copying a big existing chunk into - a new chunk. First copy over the part before new chunk, - then the new chunk, and finally the rest. */ - Scheme_Object *ml2; - if (max_chunk_start_pos) { - ml = make_chunk(max_chunk_start_pos, owner_wraps); - if (!SCHEME_PAIRP(ml) && !SCHEME_NULLP(ml)) - ml = scheme_make_pair(ml, scheme_null); - } else - ml = scheme_null; - ml = scheme_make_pair(SCHEME_CAR(max_chunk_start_list), ml); - if (max_chunk_start_pos + 1 < len) { - ml2 = make_chunk(len - 1 - max_chunk_start_pos, - SCHEME_CDR(max_chunk_start_list)); - if (!SCHEME_NULLP(ml2)) { - if (SCHEME_PAIRP(ml2)) - ml = scheme_append(ml2, ml); - else - ml = scheme_make_pair(ml2, ml); - } - } - } else { - if (!count) { - ml = scheme_null; /* everything disappeared! */ - } else { - wc = MALLOC_WRAP_CHUNK(count); - wc->type = scheme_wrap_chunk_type; - wc->len = count; - - ml = NULL; /* to make compiler happy */ - - j = 0; - for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) { - int k, cl = ((Wrap_Chunk *)a)->len; - for (k = 0; k < cl; k++) { - wc->a[j++] = ((Wrap_Chunk *)a)->a[k]; - } - } else if (SCHEME_NUMBERP(a)) { - if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l))) - wc->a[j++] = a; - else { - /* Skip canceling marks */ - i++; - l = SCHEME_CDR(l); - } - } else if (SCHEME_HASHTP(a)) { - /* Skip chain-specific table */ - } else - wc->a[j++] = a; - } - - /* Despite our best efforts, some adjacent canceling - marks may have gotten through to this point. Check - one last time. */ - j = 0; - for (i = 0; i < count - 1; i++) { - if (SCHEME_NUMBERP(wc->a[i]) && SAME_OBJ(wc->a[i], wc->a[i+1])) { - i++; - } else { - if (j < i) - wc->a[j] = wc->a[i]; - j++; - } - } - if (j < i) { - if (i < count) - wc->a[j++] = wc->a[i]; - count = j; - wc->len = count; - if (!count) - return scheme_null; - } - - if (count == 1) /* in case mark removal left only one */ - ml = wc->a[0]; - else - ml = (Scheme_Object *)wc; - } - } - } else { - ml = SCHEME_CAR(owner_wraps); - if (SCHEME_HASHTP(ml)) - return scheme_null; - } - - return ml; -} - -#define PREEMPTIVE_CHUNK_THRESHOLD 32 - -static void preemptive_chunk(Scheme_Stx *stx) -{ - int wl_count; - int new_count; - Scheme_Object *here_wraps, *ml; - - /* If the lazy prefix is long, transform it into a chunk. Probably, - some syntax object derived from this one will be unpacked, and - then the lazy prefix will need to be pushed down. - - This chunking fights somewhat with the chain-cache heuristic, - since a chain cache can't be included in a chunk. Still, the - combination seems to work better than either alone for deeply - nested scopes. - - It might also interact badly with simplication or marshaling, - since it decreases chain sharing. This is seems unlikely to - matter, since deeply nested syntax information will be expensive - in any case, and nodes in the wraps are still shared. */ - - wl_count = stx->u.lazy_prefix; - if (wl_count < 0) wl_count = 0; - - if (wl_count > PREEMPTIVE_CHUNK_THRESHOLD) { - /* Chunk it */ - here_wraps = stx->wraps; - - ml = make_chunk(wl_count, here_wraps); + o = stx_adjust_scope(o, key, phase, SCHEME_INT_VAL(val) | flag, mutate); - if (SCHEME_PAIRP(ml) || SCHEME_NULLP(ml)) { - new_count = scheme_list_length(ml); - if (new_count == 1) - ml = SCHEME_CAR(ml); - } else { - new_count = 1; - } - - while (wl_count--) { - here_wraps = SCHEME_CDR(here_wraps); - } - wl_count = new_count; - - if (new_count == 1) - here_wraps = scheme_make_pair(ml, here_wraps); - else { - while (new_count--) { - here_wraps = scheme_make_pair(SCHEME_CAR(ml), here_wraps); - ml = SCHEME_CDR(ml); - } - } - - stx->wraps = here_wraps; - stx->u.lazy_prefix = wl_count; - } -} - -static Scheme_Object *propagate_wraps(Scheme_Object *o, - int len, Scheme_Object **_ml, - Scheme_Object *owner_wraps) -{ - int i; - Scheme_Object *ml, *a; - - /* Would adding the wraps generate a list equivalent to owner_wraps? - If so, use owner_wraps directly. But if len is too big, then it - takes too long to check, and so it's better to start chunking. */ - if (len < 128) { - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *p1 = owner_wraps; - Scheme_Object *taints; - - /* Find list after |wl| items in owner_wraps: */ - for (i = 0; i < len; i++) { - p1 = SCHEME_CDR(p1); - } - /* p1 is the list after wl... */ - - if (SAME_OBJ(stx->wraps, p1)) { - /* So, we can use owner_wraps directly instead of building - new wraps. */ - intptr_t lp; - int dp; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - lp = stx->u.lazy_prefix; - if (len) { - if (lp < 0) - lp = len; - else - lp += len; - } - dp = STX_KEY(stx) & STX_ARMED_FLAG; - } else { - lp = 0; - dp = 0; - } - - taints = stx->taints; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = owner_wraps; - stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */ - if (dp) - STX_KEY(stx) |= STX_ARMED_FLAG; - stx->taints = taints; - - return (Scheme_Object *)stx; - } - } - - ml = *_ml; - if (!ml) { - ml = make_chunk(len, owner_wraps); - *_ml = ml; - } - - if (SCHEME_PAIRP(ml)) { - while (SCHEME_PAIRP(ml)) { - a = SCHEME_CAR(ml); - if (SCHEME_NUMBERP(a)) { - o = scheme_add_remove_mark(o, a); - } else { - o = scheme_add_rename(o, a); - } - ml = SCHEME_CDR(ml); - } - } else if (SCHEME_NUMBERP(ml)) - o = scheme_add_remove_mark(o, ml); - else if (SCHEME_NULLP(ml)) { - /* nothing to add */ - } else - o = scheme_add_rename(o, ml); + i = scope_set_next(props, i); + } return o; } +XFORM_NONGCING static int equiv_scope_tables(Scheme_Scope_Table *a, Scheme_Scope_Table *b) +/* try to cheaply detect equivalent tables to enable shortcuts */ +{ + if (a == b) + return 1; + + if (((a->simple_scopes == b->simple_scopes) + || (!scope_set_count(a->simple_scopes) + && !scope_set_count(b->simple_scopes))) + && SAME_OBJ(a->multi_scopes, b->multi_scopes)) + return 1; + + return 0; +} + +static Scheme_Object *propagate_scopes(Scheme_Object *o, Scheme_Scope_Table *to_propagate, + Scheme_Scope_Table *parent_scopes, int flag, + GC_CAN_IGNORE int *mutate) +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + Scheme_Object *key, *val, *fb; + + if (!to_propagate || (to_propagate == empty_propagate_table)) + return o; + + /* Check whether the child scopes currently match the + parent's scopes before the propagated changes: */ + if (!(flag & SCHEME_STX_PROPONLY) + && equiv_scope_tables(((Scheme_Propagate_Table *)to_propagate)->prev, stx->scopes)) { + /* Yes, so we can take a shortcut: child scopes still match parent. + Does the child need to propagate, and if so, does it just + get the parent's propagation? */ + if (!(STX_KEY(stx) & STX_SUBSTX_FLAG) + || !stx->u.to_propagate + || SAME_OBJ(stx->u.to_propagate, empty_propagate_table)) { + /* Yes, child matches the parent in all relevant dimensions */ + stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, mutate); + stx->scopes = parent_scopes; + *mutate -= (*mutate & MUTATE_STX_SCOPE_TABLE); + if (STX_KEY(stx) & STX_SUBSTX_FLAG) { + stx->u.to_propagate = to_propagate; + *mutate -= (*mutate & MUTATE_STX_PROP_TABLE); + } + COUNT_PROPAGATES(stx_shorts++); + return (Scheme_Object *)stx; + } else { + /* Child scopes match parent, so we don't need to reconstruct + the scope set, but we need to build a new propagation set + to augment the propagate set already here */ + flag |= SCHEME_STX_PROPONLY; + COUNT_PROPAGATES(stx_meds++); + } + } else { + COUNT_PROPAGATES(stx_longs++); + } + + val = ((Scheme_Propagate_Table *)to_propagate)->phase_shift; + if (!SAME_OBJ(val, scheme_make_integer(0))) { + o = shift_scopes(o, val, flag & SCHEME_STX_PROPONLY, mutate); + } + + o = propagate_scope_set(to_propagate->simple_scopes, o, scheme_true, flag, mutate); + + /* fallbacks here mean that we need to propagate fallback creations, + as well as propagating actions at each fallback layer: */ + + fb = to_propagate->multi_scopes; + if (SCHEME_FALLBACKP(fb)) { + /* reverse the fallback list so we can replay them in the right order: */ + key = scheme_null; + while (SCHEME_FALLBACKP(fb)) { + key = make_fallback_quad(SCHEME_FALLBACK_FIRST(fb), + key, + SCHEME_FALLBACK_SCOPE(fb), + SCHEME_FALLBACK_PHASE(fb)); + fb = SCHEME_FALLBACK_REST(fb); + } + fb = make_fallback_pair(fb, key); + } + + while (fb) { + if (SCHEME_FALLBACKP(fb)) { + if (SCHEME_FALLBACK_QUADP(fb)) { + o = stx_adjust_scope(o, SCHEME_FALLBACK_SCOPE(fb), SCHEME_FALLBACK_PHASE(fb), + SCHEME_STX_PUSH | flag, mutate); + } + key = SCHEME_FALLBACK_FIRST(fb); + } else + key = fb; + + for (; !SCHEME_NULLP(key); key = SCHEME_CDR(key)) { + val = SCHEME_CAR(key); + STX_ASSERT(SCHEME_MULTI_SCOPEP(SCHEME_VEC_ELS(val)[0])); + o = stx_adjust_scope(o, SCHEME_VEC_ELS(val)[0], SCHEME_VEC_ELS(val)[1], + SCHEME_INT_VAL(SCHEME_VEC_ELS(val)[2]) | flag, mutate); + } + + if (SCHEME_FALLBACKP(fb)) + fb = SCHEME_FALLBACK_REST(fb); + else + fb = NULL; + } + + if (flag & SCHEME_STX_PROPONLY) { + o = clone_stx(o, mutate); + ((Scheme_Stx *)o)->scopes = parent_scopes; + *mutate -= (*mutate & MUTATE_STX_SCOPE_TABLE); + } + +#if DO_COUNT_PROPAGATES + if (!(flag & SCHEME_STX_PROPONLY)) { + if (scheme_equal((Scheme_Object *)parent_scopes->simple_scopes, + (Scheme_Object *)((Scheme_Stx *)o)->scopes->simple_scopes) + && scheme_equal(parent_scopes->multi_scopes, + ((Scheme_Stx *)o)->scopes->multi_scopes)) + stx_couldas++; + } +#endif + + return o; +} + +static Scheme_Object *propagate_shifts(Scheme_Object *result, Scheme_Object *shifts, GC_CAN_IGNORE int *mutate) +{ + Scheme_Stx *stx = (Scheme_Stx *)result; + Scheme_Object *l; + + if (SAME_OBJ(stx->shifts, SCHEME_VEC_ELS(shifts)[2])) { + result = clone_stx(result, mutate); + stx = (Scheme_Stx *)result; + + if ((STX_KEY(stx) & STX_SUBSTX_FLAG)) { + stx->shifts = shifts; + if (!stx->u.to_propagate) + stx->u.to_propagate = empty_propagate_table; + } else + stx->shifts = SCHEME_VEC_ELS(shifts)[0]; + return result; + } + + for (l = scheme_reverse(SCHEME_VEC_ELS(shifts)[1]); !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + result = do_stx_add_shift(result, SCHEME_CAR(l), mutate); + } + + return result; +} + +static Scheme_Object *propagate(Scheme_Object *result, + Scheme_Scope_Table *to_propagate, + Scheme_Scope_Table *parent_scopes, + Scheme_Object *shifts, + int add_taint, Scheme_Object *false_insp) +{ + int mutate = 0; + + result = propagate_scopes(result, to_propagate, parent_scopes, 0, &mutate); + + if (shifts) + result = propagate_shifts(result, shifts, &mutate); + + if (add_taint) + result = add_taint_to_stx(result, &mutate); + else if (false_insp) + result = set_false_insp(result, false_insp, &mutate); + + return result; +} + +int propagate_count; + +static Scheme_Object *raw_stx_content(Scheme_Object *o) + /* Propagates wraps and taints while getting a syntax object's content. */ +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + + /* The fast-path tests are duplicated in jit.c. */ + + if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && stx->u.to_propagate) { + Scheme_Object *v = stx->val, *result; + Scheme_Scope_Table *to_propagate; + Scheme_Object *false_insp, *shifts; + int add_taint; + + to_propagate = stx->u.to_propagate; + false_insp = stx->taints; + if (false_insp && SCHEME_VOIDP(false_insp)) { + add_taint = 1; + } else { + add_taint = 0; + if (false_insp) { + if (SCHEME_PAIRP(false_insp)) + false_insp = SCHEME_CAR(false_insp); + if (!SCHEME_INSPECTORP(false_insp)) + false_insp = NULL; + } + } + + shifts = stx->shifts; + if (!SCHEME_VECTORP(stx->shifts)) + shifts = NULL; + + if (SCHEME_PAIRP(v)) { + Scheme_Object *last = NULL, *first = NULL; + + while (SCHEME_PAIRP(v)) { + Scheme_Object *p; + result = SCHEME_CAR(v); + result = propagate(result, to_propagate, stx->scopes, + shifts, + add_taint, false_insp); + p = scheme_make_pair(result, scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + v = SCHEME_CDR(v); + } + if (!SCHEME_NULLP(v)) { + result = v; + result = propagate(result, to_propagate, stx->scopes, + shifts, + add_taint, false_insp); + if (last) + SCHEME_CDR(last) = result; + else + first = result; + } + v = first; + } else if (SCHEME_BOXP(v)) { + result = SCHEME_BOX_VAL(v); + result = propagate(result, to_propagate, stx->scopes, + shifts, + add_taint, false_insp); + v = scheme_box(result); + } else if (SCHEME_VECTORP(v)) { + Scheme_Object *v2; + int size = SCHEME_VEC_SIZE(v), i; + + v2 = scheme_make_vector(size, NULL); + + for (i = 0; i < size; i++) { + result = SCHEME_VEC_ELS(v)[i]; + result = propagate(result, to_propagate, stx->scopes, + shifts, + add_taint, false_insp); + SCHEME_VEC_ELS(v2)[i] = result; + } + + v = v2; + } else if (SCHEME_HASHTRP(v)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; + Scheme_Object *key, *val; + mzlonglong i; + + ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); + + i = scheme_hash_tree_next(ht, -1); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = propagate(val, to_propagate, stx->scopes, + shifts, + add_taint, false_insp); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + + v = (Scheme_Object *)ht2; + } else if (prefab_p(v)) { + Scheme_Structure *s = (Scheme_Structure *)v; + Scheme_Object *r; + int size, i; + + s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); + + size = s->stype->num_slots; + for (i = 0; i < size; i++) { + r = s->slots[i]; + r = propagate(r, to_propagate, stx->scopes, + shifts, + add_taint, false_insp); + s->slots[i] = r; + } + + v = (Scheme_Object *)s; + } + + stx->u.to_propagate = NULL; + stx->val = v; + if (add_taint) { + /* if we're setting taints, we must be propagating + taints to touch; change "taints" to "propagated" or "none": */ + stx->taints = scheme_true; + } else if (false_insp) { + /* If we're propagating an inspector with no dye packs, + we're now done propagating. */ + if (!SCHEME_PAIRP(stx->taints)) + stx->taints = NULL; + } + if (shifts) + stx->shifts = SCHEME_VEC_ELS(shifts)[0]; + } + + return stx->val; +} + +Scheme_Object *scheme_stx_content(Scheme_Object *o) +/* Propagates wraps while getting a syntax object's content. */ +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + + if (!(STX_KEY(stx) & STX_ARMED_FLAG) || !is_armed((Scheme_Object *)stx)) + return raw_stx_content(o); + + /* force propagation: */ + raw_stx_content(o); + + /* taint */ + o = add_taint_to_stx(o, NULL); + + /* return tainted content */ + return raw_stx_content(o); +} + +/******************** taints ********************/ + static Scheme_Object *taint_intern(Scheme_Object *v) { Scheme_Bucket *b; @@ -2593,22 +2221,21 @@ static int has_taint_arming(Scheme_Object *l, Scheme_Object *t, Scheme_Object *f return 0; } -static Scheme_Object *add_taint_to_stx(Scheme_Object *o, int need_clone) +static Scheme_Object *add_taint_to_stx(Scheme_Object *o, GC_CAN_IGNORE int *mutate) { Scheme_Stx *stx; if (is_tainted(o)) return o; - if (need_clone) - o = clone_stx(o); + o = clone_stx(o, mutate); stx = (Scheme_Stx *)o; stx->taints = scheme_void; /* taint to propagate */ - /* Set lazy_prefix to indicate taint to propagate: */ + /* Set to_propagate to indicate taint to propagate: */ if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - if (!stx->u.lazy_prefix) - stx->u.lazy_prefix = -1; + if (!stx->u.to_propagate) + stx->u.to_propagate = empty_propagate_table; if (STX_KEY(stx) & STX_ARMED_FLAG) STX_KEY(stx) -= STX_ARMED_FLAG; } @@ -2616,7 +2243,7 @@ static Scheme_Object *add_taint_to_stx(Scheme_Object *o, int need_clone) return o; } -static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp, int need_clone) +static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp, GC_CAN_IGNORE int *mutate) { Scheme_Stx *stx; @@ -2631,17 +2258,17 @@ static Scheme_Object *set_false_insp(Scheme_Object *o, Scheme_Object *false_insp return o; } - if (need_clone) - o = clone_stx(o); + o = clone_stx(o, mutate); stx = (Scheme_Stx *)o; if (stx->taints) false_insp = taint_intern(scheme_make_pair(false_insp, SCHEME_CDR(stx->taints))); + stx->taints = false_insp; /* Set lazy_prefix to indicate inspector to propagate: */ if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - if (!stx->u.lazy_prefix) - stx->u.lazy_prefix = -1; + if (!stx->u.to_propagate) + stx->u.to_propagate = empty_propagate_table; } return o; @@ -2703,13 +2330,13 @@ static Scheme_Object *do_add_taint_armings_to_stx(Scheme_Object *o, Scheme_Objec } if (need_clone) - o = clone_stx(o); + o = clone_stx(o, NULL); stx = (Scheme_Stx *)o; stx->taints = new_taints; if (STX_KEY(stx) & STX_SUBSTX_FLAG) STX_KEY(stx) |= STX_ARMED_FLAG; - + return o; } @@ -2725,7 +2352,7 @@ static Scheme_Object *add_taint_armings_to_stx(Scheme_Object *o, Scheme_Object * Scheme_Object *scheme_stx_taint(Scheme_Object *o) { - return add_taint_to_stx(o, 1); + return add_taint_to_stx(o, NULL); } Scheme_Object *scheme_stx_taint_arm(Scheme_Object *o, Scheme_Object *insp) @@ -2741,7 +2368,7 @@ Scheme_Object *scheme_stx_taint_rearm(Scheme_Object *o, Scheme_Object *copy_from if (is_tainted(o) || is_clean(copy_from)) return o; else if (is_tainted(copy_from)) - return add_taint_to_stx(o, 1); + return add_taint_to_stx(o, NULL); else return add_taint_armings_to_stx(o, ((Scheme_Stx *)copy_from)->taints, 1); } @@ -2784,7 +2411,7 @@ Scheme_Object *scheme_stx_taint_disarm(Scheme_Object *o, Scheme_Object *insp) } else l2 = scheme_null; - o = clone_stx(o); + o = clone_stx(o, NULL); if (SCHEME_NULLP(l2)) { if (SCHEME_INSPECTORP(false_insp)) @@ -2801,687 +2428,1694 @@ Scheme_Object *scheme_stx_taint_disarm(Scheme_Object *o, Scheme_Object *insp) return o; } -static Scheme_Object *stx_content(Scheme_Object *o, int add_taint, int keep) - /* Propagates wraps and taints while getting a syntax object's content. */ +/******************** bindings ********************/ + +XFORM_NONGCING static Scheme_Scope *extract_max_scope(Scheme_Scope_Set *scopes) { - Scheme_Stx *stx = (Scheme_Stx *)o; + intptr_t i; + Scheme_Object *key, *val; + Scheme_Scope *scope; + mzlonglong scope_id_val, id_val; - /* The fast-path tests are duplicated in jit.c. */ + i = scope_set_next(scopes, -1); + scope_set_index(scopes, i, &key, &val); - if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && (stx->u.lazy_prefix || add_taint)) { - Scheme_Object *v = stx->val, *result; - Scheme_Object *here_wraps, *false_insp; - Scheme_Object *ml = NULL; - int wl_count = 0; + scope = (Scheme_Scope *)key; + scope_id_val = scope->id; - here_wraps = stx->wraps; - wl_count = stx->u.lazy_prefix; - stx->u.lazy_prefix = 0; - if (wl_count < 0) { - wl_count = 0; - if (add_taint) { - false_insp = NULL; - } else { - false_insp = stx->taints; - if (SCHEME_PAIRP(false_insp)) - false_insp = SCHEME_CAR(false_insp); - if (!SCHEME_INSPECTORP(false_insp)) - false_insp = NULL; - } - } else - false_insp = NULL; + i = scope_set_next(scopes, i); + while (i != -1) { + scope_set_index(scopes, i, &key, &val); - if (SCHEME_PAIRP(v)) { - Scheme_Object *last = NULL, *first = NULL; - - while (SCHEME_PAIRP(v)) { - Scheme_Object *p; - result = SCHEME_CAR(v); - if (wl_count) - result = propagate_wraps(result, wl_count, &ml, here_wraps); - if (add_taint) - result = add_taint_to_stx(result, 1); - else if (false_insp) - result = set_false_insp(result, false_insp, 1); - p = scheme_make_pair(result, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - v = SCHEME_CDR(v); - } - if (!SCHEME_NULLP(v)) { - result = v; - if (wl_count) - result = propagate_wraps(result, wl_count, &ml, here_wraps); - if (add_taint) - result = add_taint_to_stx(result, 1); - else if (false_insp) - result = set_false_insp(result, false_insp, 1); - if (last) - SCHEME_CDR(last) = result; - else - first = result; - } - v = first; - } else if (SCHEME_BOXP(v)) { - result = SCHEME_BOX_VAL(v); - if (wl_count) - result = propagate_wraps(result, wl_count, &ml, here_wraps); - if (add_taint) - result = add_taint_to_stx(result, 1); - else if (false_insp) - result = set_false_insp(result, false_insp, 1); - v = scheme_box(result); - } else if (SCHEME_VECTORP(v)) { - Scheme_Object *v2; - int size = SCHEME_VEC_SIZE(v), i; - - v2 = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - result = SCHEME_VEC_ELS(v)[i]; - if (wl_count) - result = propagate_wraps(result, wl_count, &ml, here_wraps); - if (add_taint) - result = add_taint_to_stx(result, 1); - else if (false_insp) - result = set_false_insp(result, false_insp, 1); - SCHEME_VEC_ELS(v2)[i] = result; - } - - v = v2; - } else if (SCHEME_HASHTRP(v)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; - Scheme_Object *key, *val; - mzlonglong i; - - ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - if (wl_count) - val = propagate_wraps(val, wl_count, &ml, here_wraps); - if (add_taint) - val = add_taint_to_stx(val, 1); - else if (false_insp) - val = set_false_insp(val, false_insp, 1); - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht, i); - } - - v = (Scheme_Object *)ht2; - } else if (prefab_p(v)) { - Scheme_Structure *s = (Scheme_Structure *)v; - Scheme_Object *r; - int size, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - - size = s->stype->num_slots; - for (i = 0; i < size; i++) { - r = s->slots[i]; - if (wl_count) - r = propagate_wraps(r, wl_count, &ml, here_wraps); - if (add_taint) - r = add_taint_to_stx(r, 1); - else if (false_insp) - r = set_false_insp(r, false_insp, 1); - s->slots[i] = r; - } - - v = (Scheme_Object *)s; - } - - if (!keep) - return v; - - stx->val = v; - if (add_taint) { - /* if we're setting taints and `keep' is 1, we must be propagating - taints to touch; change "taints" to "propagated" or "none": */ - stx->taints = scheme_true; - } else if (false_insp) { - /* If we're propagating an inspector with no dye packs, - we're now done propagating. */ - if (!SCHEME_PAIRP(stx->taints)) - stx->taints = NULL; + id_val = ((Scheme_Scope *)key)->id; + if (id_val > scope_id_val) { + scope = (Scheme_Scope *)key; + scope_id_val = id_val; } + + i = scope_set_next(scopes, i); } - return stx->val; + return scope; } -static Scheme_Object *raw_stx_content(Scheme_Object *o) +#define SCHEME_BINDING_SCOPES(p) ((Scheme_Scope_Set *)SCHEME_CAR(p)) +#define SCHEME_BINDING_VAL(p) SCHEME_CDR(p) + +#define SCHEME_VEC_BINDING_KEY(p) (SCHEME_VEC_ELS(p)[0]) +#define SCHEME_VEC_BINDING_SCOPES(p) ((Scheme_Scope_Set *)(SCHEME_VEC_ELS(p)[1])) +#define SCHEME_VEC_BINDING_VAL(p) (SCHEME_VEC_ELS(p)[2]) + +#define CONV_RETURN_UNLESS(p) if (!p) return + +static void check_for_conversion(Scheme_Object *sym, + Scheme_Scope *scope, + Scheme_Module_Phase_Exports *pt, + Scheme_Hash_Table *collapse_table, + Scheme_Hash_Tree *ht, + Scheme_Scope_Set *scopes, + Scheme_Object *phase, + Scheme_Object *bind) +/* Due to `require` macros, importing a whole module can turn into + individual imports from the module. Detect when everything that a + module exports (at a given phase) is imported as a set of bindings, + and collapse them to a bulk-import "pes". */ { - Scheme_Object *taints = ((Scheme_Stx *)o)->taints; - if (SCHEME_VOIDP(taints)) - return stx_content(o, 1, 1); - else - return stx_content(o, 0, 1); -} + Scheme_Hash_Table *mht; + Scheme_Object *v, *v2, *cnt; + int i; -Scheme_Object *scheme_stx_content(Scheme_Object *o) -/* Propagates wraps while getting a syntax object's content. */ -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - if (!(STX_KEY(stx) & STX_ARMED_FLAG) || !is_armed((Scheme_Object *)stx)) - return raw_stx_content(o); - - /* force propagation: */ - raw_stx_content(o); - - /* return tainted content */ - return stx_content(o, 1, 0); -} - -Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx) -{ - WRAP_POS awl; - Scheme_Object *acur_mark, *p, *marks = scheme_null; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - - while (1) { - /* Skip over renames, immediately-canceled marks, and negative marks: */ - acur_mark = NULL; - while (1) { - if (WRAP_POS_END_P(awl)) - break; - p = WRAP_POS_FIRST(awl); - if (SCHEME_NUMBERP(p)) { - if (acur_mark) { - if (SAME_OBJ(acur_mark, p)) { - acur_mark = NULL; - WRAP_POS_INC(awl); - } else - break; - } else { - acur_mark = p; - WRAP_POS_INC(awl); - } - } else { - WRAP_POS_INC(awl); - } - } - - if (acur_mark) { - if (SCHEME_PAIRP(marks) && SAME_OBJ(acur_mark, SCHEME_CAR(marks))) - marks = SCHEME_CDR(marks); - else - marks = scheme_make_pair(acur_mark, marks); - } - - if (WRAP_POS_END_P(awl)) - return scheme_reverse(marks); - } -} - -Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *_stx) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - WRAP_POS awl; - int mod_ctx_count = 0, skipped = 0; - Scheme_Object *v; - Wrap_Chunk *chunk; - - /* Check for module context, first: */ - WRAP_POS_INIT(awl, stx->wraps); - while (!WRAP_POS_END_P(awl)) { - v = WRAP_POS_FIRST(awl); - if (SCHEME_RENAMESP(v) || SCHEME_BOXP(v) || SCHEME_RENAMES_SETP(v)) { - mod_ctx_count++; - } - WRAP_POS_INC(awl); - skipped++; + mht = (Scheme_Hash_Table *)scheme_eq_hash_get(collapse_table, (Scheme_Object *)scope); + if (!mht) { + mht = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(collapse_table, (Scheme_Object *)scope, (Scheme_Object *)mht); } - if (!mod_ctx_count) - return _stx; + cnt = scheme_eq_hash_get(mht, (Scheme_Object *)pt); + if (!cnt) + cnt = scheme_make_integer(1); + else + cnt = scheme_bin_plus(cnt, scheme_make_integer(1)); + scheme_hash_set(mht, (Scheme_Object *)pt, cnt); - if (mod_ctx_count == skipped) { - /* Everything was a module context? An unlikely but easy case. */ - return scheme_make_stx(stx->val, stx->srcloc, stx->props); - } else { - /* Copy everything else into a new chunk. */ - chunk = MALLOC_WRAP_CHUNK((skipped - mod_ctx_count)); - chunk->type = scheme_wrap_chunk_type; - chunk->len = skipped - mod_ctx_count; - skipped = 0; - WRAP_POS_INIT(awl, stx->wraps); - while (!WRAP_POS_END_P(awl)) { - v = WRAP_POS_FIRST(awl); - if (!SCHEME_RENAMESP(v) && !SCHEME_BOXP(v) && !SCHEME_RENAMES_SETP(v)) { - chunk->a[skipped] = v; - skipped++; - } - WRAP_POS_INC(awl); + if (bind && (SCHEME_INT_VAL(cnt) == pt->num_provides)) { + Scheme_Object *modidx, *modidx2, *insp_desc, *insp_desc2, *src_phase; + Scheme_Object *exportname, *nominal_modidx, *nominal_modidx2, *mod_phase, *nominal_name; + Scheme_Object *nominal_src_phase; + Scheme_Object *pes; + + nominal_modidx = NULL; + + extract_module_binding_parts(SCHEME_BINDING_VAL(bind), phase, + &insp_desc, + &modidx, + &exportname, + &nominal_modidx, + &mod_phase, + NULL, + NULL, + NULL); + + if (!nominal_modidx) + nominal_modidx = modidx; + + /* since we've mapped N identifiers from a source of N identifiers, + maybe we mapped all of them. */ + for (i = pt->num_provides; i--; ) { + v2 = scheme_eq_hash_tree_get(ht, pt->provides[i]); + CONV_RETURN_UNLESS(v2); + + /* For now, allow only a single binding: */ + CONV_RETURN_UNLESS(SCHEME_PAIRP(v2) + || (SCHEME_MPAIRP(v2) && SCHEME_NULLP(SCHEME_CDR(v2)))); + if (SCHEME_MPAIRP(v2)) + v2 = SCHEME_CAR(v2); + + CONV_RETURN_UNLESS(scopes_equal(scopes, SCHEME_BINDING_SCOPES(v2))); + + /* Pull apart module bindings to make sure they're consistent: */ + exportname = pt->provides[i]; + nominal_modidx2 = NULL; + mod_phase = pt->phase_index; + nominal_name = exportname; + src_phase = scheme_make_integer(0); + nominal_src_phase = NULL; + mod_phase = pt->phase_index; + + extract_module_binding_parts(SCHEME_BINDING_VAL(v2), phase, + &insp_desc2, + &modidx, + &exportname, + &nominal_modidx2, + &mod_phase, + &nominal_name, + &src_phase, + &nominal_src_phase); + + if (!nominal_modidx2) + nominal_modidx2 = modidx; + if (!nominal_src_phase) + nominal_src_phase = mod_phase; + + CONV_RETURN_UNLESS(SAME_OBJ(insp_desc2, insp_desc)); + modidx2 = (pt->provide_srcs ? pt->provide_srcs[i] : scheme_false); + if (SCHEME_FALSEP(modidx2)) + modidx2 = nominal_modidx; + else if (pt->src_modidx) + modidx2 = scheme_modidx_shift(modidx2, pt->src_modidx, nominal_modidx); + CONV_RETURN_UNLESS(scheme_equal(modidx, modidx2)); + CONV_RETURN_UNLESS(SAME_OBJ(exportname, pt->provide_src_names[i])); + CONV_RETURN_UNLESS(scheme_equal(nominal_modidx2, nominal_modidx)); + CONV_RETURN_UNLESS(scheme_eqv(mod_phase, (pt->provide_src_phases + ? scheme_make_integer(pt->provide_src_phases[i]) + : pt->phase_index))); + CONV_RETURN_UNLESS(SAME_OBJ(nominal_name, pt->provides[i])); + CONV_RETURN_UNLESS(scheme_eqv(src_phase, phase)); + CONV_RETURN_UNLESS(scheme_eqv(nominal_src_phase, pt->phase_index)); } + + /* found a match; convert to a pes: */ + pes = scheme_make_vector(5, NULL); + SCHEME_VEC_ELS(pes)[0] = nominal_modidx; + SCHEME_VEC_ELS(pes)[1] = (Scheme_Object *)pt; + SCHEME_VEC_ELS(pes)[2] = phase; + SCHEME_VEC_ELS(pes)[3] = pt->phase_index; + SCHEME_VEC_ELS(pes)[4] = insp_desc; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - v = scheme_make_pair((Scheme_Object *)chunk, scheme_null); - stx->wraps = v; - return (Scheme_Object *)stx; - } -} - -int scheme_stx_has_empty_wraps(Scheme_Object *o) -{ - WRAP_POS awl; - Scheme_Object *mark = NULL, *v; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)o)->wraps); - while (!WRAP_POS_END_P(awl)) { - v = WRAP_POS_FIRST(awl); - if (mark) { - if (!SAME_OBJ(mark, v)) - return 0; - mark = NULL; - } else - mark = v; - WRAP_POS_INC(awl); - } - - return !mark; -} - -/*========================================================================*/ -/* stx comparison */ -/*========================================================================*/ - -static Scheme_Object *get_old_module_env(Scheme_Object *stx) -/* If an identifier has two or more module contexts, return a - representation of the prior contexts. We use the rename's - identity mark or a list of marks to represent the context. - Return #f if there's no old context. */ -{ - WRAP_POS awl; - Scheme_Object *a, *last_id = NULL, *cancel_rename_id = scheme_false; - Scheme_Object *result_id = scheme_false, *last_pr = NULL, *pr; - int saw_rename = 0; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - - while (!WRAP_POS_END_P(awl)) { - - a = WRAP_POS_FIRST(awl); - - if (SCHEME_RENAMESP(a) - || SCHEME_RENAMES_SETP(a)) { - int kind; - Scheme_Object *set_identity; - - if (SCHEME_RENAMESP(a)) { - Module_Renames *mrn = (Module_Renames *)a; + bind = scheme_make_pair((Scheme_Object *)scopes, pes); - kind = mrn->kind; - set_identity = mrn->set_identity; - } else { - Module_Renames_Set *mrns = (Module_Renames_Set *)a; - - kind = mrns->kind; - set_identity = mrns->set_identity; - - if (mrns->prior_contexts) { - /* A rename-set with a prior context should be last */ - if (SCHEME_FALSEP(result_id)) { - result_id = mrns->prior_contexts; - if (SCHEME_NULLP(SCHEME_CDR(result_id))) - result_id = SCHEME_CAR(result_id); - } else { - if (!SCHEME_PAIRP(result_id)) { - result_id = scheme_make_pair(result_id, scheme_null); - last_pr = result_id; - } - SCHEME_CDR(last_pr) = mrns->prior_contexts; - } - } - } - - if ((kind != mzMOD_RENAME_TOPLEVEL) - && (!SAME_OBJ(cancel_rename_id, set_identity))) { - if (last_id) { - if (!SAME_OBJ(last_id, set_identity)) { - if (SCHEME_FALSEP(result_id)) - result_id = set_identity; - else { - if (!SCHEME_PAIRP(result_id)) { - result_id = scheme_make_pair(result_id, scheme_null); - last_pr = result_id; - } - pr = scheme_make_pair(set_identity, scheme_null); - SCHEME_CDR(last_pr) = pr; - last_pr = pr; - } - } - } - last_id = set_identity; - } - - /* Only cancel via phase shift after we've seen a rename. - Canceling makes submodule contexts work, while not canceling - until after a rename makes inspection of a fully-expanded - module work in the case that a binding's indentifier cam from - another module. */ - saw_rename = 1; - } else if (SCHEME_BOXP(a)) { - /* Phase shift: */ - Scheme_Object *vec; - - vec = SCHEME_BOX_VAL(a); - a = SCHEME_VEC_ELS(vec)[5]; - if (saw_rename && !SCHEME_FALSEP(a)) - cancel_rename_id = a; + /* install pes: */ + v = scope->bindings; + if (!SCHEME_RPAIRP(v)) { + STX_ASSERT(SCHEME_HASHTRP(v)); + v = scheme_make_raw_pair(v, NULL); + scope->bindings = v; } + v = scheme_make_raw_pair(bind, SCHEME_CDR(v)); + SCHEME_CDR(scope->bindings) = v; - WRAP_POS_INC(awl); + /* remove per-symbol bindings: */ + for (i = pt->num_provides; i--; ) { + ht = scheme_hash_tree_set(ht, pt->provides[i], NULL); + } + SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; } - - return result_id; } -#define EXPLAIN_RESOLVE 0 -#if EXPLAIN_RESOLVE -int scheme_explain_resolves = 1; -# define EXPLAIN(x) if (scheme_explain_resolves) { x; } -# define EXPLAIN_FOR_ID "..." -#else -# define EXPLAIN(x) /* empty */ +static Scheme_Object *replace_matching_scopes(Scheme_Object *l, Scheme_Scope_Set *scopes) +/* Takes a list of scope--value pairs for a binding table and removes + any match to `scopes` */ +{ + Scheme_Object *p; + int c = 0; + + if (SCHEME_PAIRP(l)) { + /* only one item to check */ + if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(l))) + return NULL; + else + return l; + } + + for (p = l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { + if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(SCHEME_CAR(p)))) { + break; + } + c++; + } + + if (SCHEME_NULLP(p)) + return l; + + p = SCHEME_CDR(p); + while (c--) { + p = scheme_make_pair(SCHEME_CAR(l), p); + l = SCHEME_CDR(l); + } + + /* down to one item? */ + if (SCHEME_NULLP(SCHEME_CDR(p))) + return SCHEME_CAR(p); + + /* no items? */ + if (SCHEME_NULLP(p)) + return NULL; + + return p; +} + +static void clear_matching_bindings(Scheme_Object *pes, + Scheme_Scope_Set *scopes, + Scheme_Object *l) +/* a new bulk import needs to override any individual imports; this + should only matter for top-level interactions, since modules only + allow shadowing of the initial bulk import */ +{ + Scheme_Hash_Tree *excepts; + Scheme_Object *prefix; + Scheme_Module_Phase_Exports *pt; + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)SCHEME_CAR(l), *new_ht; + Scheme_Object *key, *val, *new_val; + intptr_t i; + + pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; + + if (!pt->ht) { + /* Lookup table (which is created lazily) not yet created, so do that now... */ + scheme_populate_pt_ht(pt); + } + + new_ht = ht; + + excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); + prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); + + if ((ht->count < pt->ht->count) + || SCHEME_TRUEP(prefix) + || excepts) { + /* faster to scan per-symbol binding table */ + i = -1; + while ((i = scheme_hash_tree_next(ht, i)) != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + if (scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(key, pes))) { + new_val = replace_matching_scopes(val, scopes); + if (!SAME_OBJ(val, new_val)) + new_ht = scheme_hash_tree_set(new_ht, key, new_val); + } + } + } else { + /* faster to scan export table */ + for (i = pt->ht->size; i--; ) { + if (pt->ht->vals[i]) { + key = pt->ht->keys[i]; + val = scheme_eq_hash_tree_get(new_ht, key); + if (val) { + new_val = replace_matching_scopes(val, scopes); + if (!SAME_OBJ(val, new_val)) + new_ht = scheme_hash_tree_set(new_ht, key, new_val); + } + } + } + } + + if (!SAME_OBJ(new_ht, ht)) + SCHEME_CAR(l) = (Scheme_Object *)new_ht; +} + +XFORM_NONGCING static void save_old_value(Scheme_Object *mp, Scheme_Object *old_val) +{ + if (SCHEME_MPAIRP(old_val)) + SCHEME_CAR(mp) = SCHEME_CAR(old_val); + else + SCHEME_CAR(mp) = old_val; +} + +static void add_binding(Scheme_Object *sym, Scheme_Object *phase, Scheme_Scope_Set *scopes, + Scheme_Object *val, + Scheme_Module_Phase_Exports *from_pt, /* to detect collapse conversion */ + Scheme_Hash_Table *collapse_table) /* to triggere collapse detection */ +/* `val` can be a symbol (local binding), a modidx/pair/#f + (module/global binding), a shared-binding vector (i.e., a pes), or + a syntax object (for a `free-identifier=?` equivalence) to be + mutable-paired with the existing binding; the `sym` argument should + be NULL when `val` is a shared-binding vector */ + +{ + Scheme_Hash_Tree *ht; + Scheme_Scope *scope; + Scheme_Object *l, *p, *bind; + + if (scope_set_count(scopes)) { + /* We add the binding to the maximum-valued scope, because it's + likely to be in the least number of binding sets so far. */ + scope = extract_max_scope(scopes); + if (SAME_OBJ((Scheme_Object*)scope, root_scope)) + scheme_signal_error("internal error: cannot bind with only a root scope"); + } else { + scheme_signal_error("internal error: cannot bind identifier with an empty context"); + return; + } + STX_ASSERT(SCHEME_STXP(val) + || SCHEME_FALSEP(val) + || SCHEME_MODIDXP(val) + || SCHEME_PAIRP(val) + || SCHEME_VECTORP(val) + || SCHEME_SYMBOLP(val)); + + if (SCHEME_STXP(val)) + val = scheme_make_mutable_pair(scheme_false, scheme_make_pair(val, phase)); + + l = scope->bindings; + if (!l) { + if (sym) { + /* simple case: a single binding */ + STX_ASSERT(SCHEME_SYMBOLP(sym)); + bind = make_vector3(sym, (Scheme_Object *)scopes, val); + scope->bindings = bind; + clear_binding_cache_for(sym); + if (from_pt) { + /* don't convert, but record addition for potential conversion */ + check_for_conversion(sym, scope, from_pt, collapse_table, NULL, scopes, phase, NULL); + } + return; + } + ht = empty_hash_tree; + l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); + scope->bindings = l; + } else if (SCHEME_VECTORP(l)) { + /* convert simple case to more general case */ + ht = scheme_hash_tree_set(empty_hash_tree, + SCHEME_VEC_BINDING_KEY(l), + scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(l), + SCHEME_VEC_BINDING_VAL(l))); + if (sym) { + /* more complex case: table of bindings */ + scope->bindings = (Scheme_Object *)ht; + } else { + /* need most complex form */ + l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); + scope->bindings = l; + } + } else if (SCHEME_RPAIRP(l)) { + /* already in complex form */ + ht = (Scheme_Hash_Tree *)SCHEME_CAR(l); + } else { + STX_ASSERT(SCHEME_HASHTRP(l)); + ht = (Scheme_Hash_Tree *)l; + if (!sym) { + /* need most complex form */ + l = scheme_make_raw_pair((Scheme_Object *)ht, NULL); + scope->bindings = l; + } + } + + bind = scheme_make_pair((Scheme_Object *)scopes, val); + + if (sym) { + STX_ASSERT(SCHEME_SYMBOLP(sym)); + clear_binding_cache_for(sym); + l = scheme_eq_hash_tree_get(ht, sym); + if (!l) { + ht = scheme_hash_tree_set(ht, sym, bind); + if (SCHEME_RPAIRP(scope->bindings)) + SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; + else + scope->bindings = (Scheme_Object *)ht; + } else { + if (!SCHEME_MPAIRP(l)) + l = scheme_make_mutable_pair(l, scheme_null); + for (p = l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { + if (scopes_equal(scopes, SCHEME_BINDING_SCOPES(SCHEME_CAR(p)))) { + if (SCHEME_MPAIRP(val)) + save_old_value(val, SCHEME_BINDING_VAL(SCHEME_CAR(p))); + SCHEME_CAR(p) = bind; + break; + } + } + if (SCHEME_NULLP(p)) { + l = scheme_make_mutable_pair(bind, l); + ht = scheme_hash_tree_set(ht, sym, l); + } else if (SCHEME_NULLP(SCHEME_CDR(l))) { + ht = scheme_hash_tree_set(ht, sym, SCHEME_CAR(l)); + from_pt = NULL; /* single binding; no benefit from pes conversion */ + } + + if (SCHEME_RPAIRP(scope->bindings)) + SCHEME_CAR(scope->bindings) = (Scheme_Object *)ht; + else + scope->bindings = (Scheme_Object *)ht; + } + if (from_pt) + check_for_conversion(sym, scope, from_pt, collapse_table, ht, scopes, phase, bind); + } else { + /* Order matters: the new bindings should hide any existing bindings for the same name. */ + clear_binding_cache(); + p = scheme_make_raw_pair(bind, SCHEME_CDR(l)); + SCHEME_CDR(l) = p; + + /* Remove any matching mappings form the hash table, since it gets checked first. */ + clear_matching_bindings(val, scopes, l); + } +} + +void scheme_add_local_binding(Scheme_Object *o, Scheme_Object *phase, Scheme_Object *binding_sym) +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + + STX_ASSERT(SCHEME_SYMBOLP(binding_sym)); + + add_binding(stx->val, phase, extract_scope_set(stx, phase), binding_sym, NULL, NULL); +} + +static void do_add_module_binding(Scheme_Scope_Set *scopes, Scheme_Object *localname, Scheme_Object *phase, + Scheme_Object *modidx, Scheme_Object *exname, Scheme_Object *defn_phase, + Scheme_Object *insp_desc, + Scheme_Object *nominal_mod, Scheme_Object *nominal_ex, + Scheme_Object *src_phase, + Scheme_Object *nom_phase, + Scheme_Module_Phase_Exports *from_pt, + Scheme_Hash_Table *collapse_table) +{ + Scheme_Object *elem; + int mod_phase; + + if (SCHEME_FALSEP(modidx)) { + if (SAME_OBJ(localname, exname)) + add_binding(localname, phase, scopes, scheme_false, NULL, NULL); + else + add_binding(localname, phase, scopes, scheme_make_pair(scheme_false, exname), NULL, NULL); + return; + } + + STX_ASSERT(SCHEME_MODIDXP(modidx)); + + /* + This encoding is meant to be progressively less compact for + progressively less-common cases: + + binding ::= mod_binding + . | (cons inspector-desc mod_binding) + mod_binding ::= modidx ; mod-phase = 0 + . | (cons modidx exportname) + . | (cons modidx nominal_modidx) + . | (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) + . | (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) + nominal_modix_plus_phase ::= nominal_modix ; import-phase-level is 0, nom-phase = mod-phase + . | (cons nominal_modix import_phase_plus_nominal_phase) + import_phase_plus_nominal_phase ::= import-phase-level ; nom-phase = mod-phase + . | (cons import-phase-level nom-phase) + inspector-desc = inspector + . | symbol + */ + + mod_phase = SCHEME_INT_VAL(defn_phase); + + if (!src_phase) + src_phase = phase; + if (!nom_phase) + nom_phase = scheme_make_integer(mod_phase); + + if (SAME_OBJ(modidx, nominal_mod) + && SAME_OBJ(exname, nominal_ex) + && !mod_phase + && same_phase(src_phase, scheme_make_integer(0)) + && same_phase(nom_phase, scheme_make_integer(mod_phase))) { + if (SAME_OBJ(localname, exname)) + elem = modidx; + else + elem = CONS(modidx, exname); + } else if (SAME_OBJ(exname, nominal_ex) + && SAME_OBJ(localname, exname) + && !mod_phase + && same_phase(src_phase, scheme_make_integer(0)) + && same_phase(nom_phase, scheme_make_integer(mod_phase))) { + /* It's common that a sequence of similar mappings shows up, + e.g., '(#%kernel . mzscheme) */ + if (nominal_ipair_cache + && SAME_OBJ(SCHEME_CAR(nominal_ipair_cache), modidx) + && SAME_OBJ(SCHEME_CDR(nominal_ipair_cache), nominal_mod)) + elem = nominal_ipair_cache; + else { + elem = ICONS(modidx, nominal_mod); + nominal_ipair_cache = elem; + } + } else { + if (same_phase(nom_phase, scheme_make_integer(mod_phase))) { + if (same_phase(src_phase, scheme_make_integer(0))) + elem = nominal_mod; + else + elem = CONS(nominal_mod, src_phase); + } else { + elem = CONS(nominal_mod, CONS(src_phase, nom_phase)); + } + elem = CONS(exname, CONS(elem, nominal_ex)); + if (mod_phase) + elem = CONS(scheme_make_integer(mod_phase), elem); + elem = CONS(modidx, elem); + } + + if (!SCHEME_FALSEP(insp_desc)) + elem = CONS(insp_desc, elem); + + add_binding(localname, phase, scopes, elem, from_pt, collapse_table); +} + +void extract_module_binding_parts(Scheme_Object *l, + Scheme_Object *phase, + Scheme_Object **_insp_desc, /* required */ + Scheme_Object **_modidx, /* required */ + Scheme_Object **_exportname, /* required, maybe unset */ + Scheme_Object **_nominal_modidx, /* maybe unset */ + Scheme_Object **_mod_phase, /* required, maybe unset */ + Scheme_Object **_nominal_name, /* maybe unset */ + Scheme_Object **_src_phase, /* maybe unset */ + Scheme_Object **_nominal_src_phase) /* maybe unset */ +/* unpack an encodings created by do_add_module_binding() */ +{ + if (SCHEME_PAIRP(l) + && SCHEME_INSPECTOR_DESCP(SCHEME_CAR(l))) { + *_insp_desc = SCHEME_CAR(l); + l = SCHEME_CDR(l); + } else + *_insp_desc = scheme_false; + + if (SCHEME_MODIDXP(l)) + *_modidx = l; + else { + *_modidx = SCHEME_CAR(l); + l = SCHEME_CDR(l); + + if (SCHEME_SYMBOLP(l)) { + /* l is exportname */ + *_exportname = l; + } else if (SCHEME_MODIDXP(l)) { + /* l is nominal_modidx */ + if (_nominal_modidx) *_nominal_modidx = l; + } else { + if (SCHEME_INTP(SCHEME_CAR(l)) || SCHEME_BIGNUMP(SCHEME_CAR(l))) { + /* mod-phase before rest */ + *_mod_phase = SCHEME_CAR(l); + l = SCHEME_CDR(l); + } + + /* l is (list* exportname nominal_modidx_plus_phase nominal_exportname) */ + *_exportname = SCHEME_CAR(l); + l = SCHEME_CDR(l); + if (_nominal_name) + *_nominal_name = SCHEME_CDR(l); + l = SCHEME_CAR(l); + /* l is nominal_modidx_plus_phase */ + if (SCHEME_PAIRP(l)) { + if (_nominal_modidx) *_nominal_modidx = SCHEME_CAR(l); + l = SCHEME_CDR(l); + if (SCHEME_PAIRP(l)) { + if (_src_phase) *_src_phase = SCHEME_CAR(l); + if (_nominal_src_phase) *_nominal_src_phase = SCHEME_CDR(l); + } else { + if (_src_phase) *_src_phase = l; + if (_nominal_src_phase) *_nominal_src_phase = *_mod_phase; + } + } else { + if (_nominal_modidx) *_nominal_modidx = l; + } + } + } +} + +void scheme_add_module_binding(Scheme_Object *o, Scheme_Object *phase, + Scheme_Object *modidx, Scheme_Object *inspector, + Scheme_Object *sym, Scheme_Object *defn_phase) +{ + STX_ASSERT(SCHEME_SYMBOLP(((Scheme_Stx *)o)->val)); + + do_add_module_binding(extract_scope_set((Scheme_Stx *)o, phase), SCHEME_STX_VAL(o), phase, + modidx, sym, defn_phase, + inspector, + modidx, sym, + NULL, NULL, + NULL, NULL); +} + +void scheme_add_module_binding_w_nominal(Scheme_Object *o, Scheme_Object *phase, + Scheme_Object *modidx, Scheme_Object *defn_name, Scheme_Object *defn_phase, + Scheme_Object *inspector, + Scheme_Object *nominal_mod, Scheme_Object *nominal_name, + Scheme_Object *nominal_import_phase, + Scheme_Object *nominal_export_phase, + Scheme_Module_Phase_Exports *from_pt, + Scheme_Hash_Table *collapse_table) +{ + STX_ASSERT(SCHEME_STXP(o)); + do_add_module_binding(extract_scope_set((Scheme_Stx *)o, phase), SCHEME_STX_VAL(o), phase, + modidx, defn_name, defn_phase, + inspector, + nominal_mod, nominal_name, + nominal_import_phase, nominal_export_phase, + from_pt, collapse_table); +} + +/******************** debug-info ********************/ + +static Scheme_Object *scopes_to_printed_list(Scheme_Scope_Set *scopes) +{ + Scheme_Object *l, *val, *key; + + l = scopes_to_sorted_list(scopes); + val = scheme_null; + for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + key = SCHEME_CAR(l); + val = scheme_make_pair(scheme_scope_printed_form(key), val); + } + + return val; +} + +Scheme_Object *add_bindings_info(Scheme_Object *bindings, Scheme_Object *key, Scheme_Object *l, + Scheme_Stx *stx, int all_bindings, Scheme_Object *seen) +{ + Scheme_Hash_Tree *bind_desc; + Scheme_Object *val; + + if (SCHEME_PAIRP(l)) { + l = scheme_make_mutable_pair(l, scheme_null); + } + + while (!SCHEME_NULLP(l)) { + if (all_bindings || SAME_OBJ(key, stx->val)) { + bind_desc = empty_hash_tree; + bind_desc = scheme_hash_tree_set(bind_desc, name_symbol, key); + + val = SCHEME_BINDING_VAL(SCHEME_CAR(l)); + if (SCHEME_MPAIRP(val)) { + bind_desc = scheme_hash_tree_set(bind_desc, free_symbol, + stx_debug_info((Scheme_Stx *)SCHEME_CAR(SCHEME_CDR(val)), + SCHEME_CDR(SCHEME_CDR(val)), + scheme_make_pair((Scheme_Object *)stx, seen), + all_bindings)); + val = SCHEME_CAR(val); + } + + if (SCHEME_SYMBOLP(val)) + bind_desc = scheme_hash_tree_set(bind_desc, local_symbol, val); + else { + if (SCHEME_PAIRP(val)) { + if (SCHEME_INSPECTOR_DESCP(SCHEME_CAR(val))) + val = SCHEME_CDR(val); + val = SCHEME_CAR(val); + } + if (SCHEME_MODIDXP(val)) + val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); + bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); + } + + bind_desc = scheme_hash_tree_set(bind_desc, context_symbol, + scopes_to_printed_list(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)))); + + bindings = scheme_make_pair((Scheme_Object *)bind_desc, bindings); + } + + l = SCHEME_CDR(l); + } + + return bindings; +} + +#ifdef DO_STACK_CHECK +static Scheme_Object *stx_debug_info_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Stx *stx = (Scheme_Stx *)p->ku.k.p1; + Scheme_Object *phase = (Scheme_Object *)p->ku.k.p2; + Scheme_Object *seen = (Scheme_Object *)p->ku.k.p3; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + + return stx_debug_info(stx, phase, seen, p->ku.k.i1); +} #endif -XFORM_NONGCING static int is_from_rib(Scheme_Object *other_env) +static Scheme_Object *stx_debug_info(Scheme_Stx *stx, Scheme_Object *phase, Scheme_Object *seen, int all_bindings) { - /* The symbol for a renaming starts with "e" for a normal one - or "r" for one within a rib. */ - if (SCHEME_SYMBOLP(other_env) && (SCHEME_SYM_VAL(other_env)[0] == 'r')) - return 1; - else - return 0; -} + Scheme_Hash_Tree *desc, *bind_desc; + Scheme_Hash_Tree *ht; + Scheme_Object *key, *val, *l, *pes, *descs = scheme_null, *bindings; + intptr_t i, j; + Scheme_Scope *scope; + Scheme_Scope_Set *scopes; + Scheme_Module_Phase_Exports *pt; + Scheme_Object *multi_scopes; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; -static Scheme_Object *reverse_phase_shift(Scheme_Object *phase, Scheme_Object *n) -{ - if (SCHEME_TRUEP(n) && !SCHEME_VOIDP(phase)) { - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_minus(phase, n); - } else { - /* phase shift to #f shifts only phase-0 bindings: */ - if (SCHEME_FALSEP(phase)) - phase = scheme_make_integer(0); - else - phase = scheme_void; /* don't match any phase */ + p->ku.k.p1 = (void *)stx; + p->ku.k.p2 = (void *)phase; + p->ku.k.p3 = (void *)seen; + p->ku.k.i1 = all_bindings; + + return scheme_handle_stack_overflow(stx_debug_info_k); + } } - return phase; -} +#endif -static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env) -/* Compares the marks in two wraps lists. The `barrier_env' argument cuts - off the mark list if a rib containing a `barrier_env' renaming is found; - effectively, the barrier causes marks between the first and last instance - of the rib to be discarded, which is how re-expansion correctly matches - uses (perhaps macro-introduced) that have extra marks relative to their - bindings. For example, in - (begin-with-definitions - (define x 1) - (define-syntax-rule (m) x) - (m)) - the expansion of `m' will have an extra mark relative to the binding. That - extra mark shouldn't prevent `(letrec ([x 1]) ...)' from binding the use of - `x' as expansion continues with the result of `begin-with-definitions'. Since - `local-expand' adds the int-def context before and after an expansion, the - extra mark can be discarded when checking the `letrec' layer of marks. - Note that it's ok to just cut off the marks at the ribs, because any - further differences in the mark lists would correspond to different renamings - within the rib. */ -{ - WRAP_POS awl; - WRAP_POS bwl; - Scheme_Object *acur_mark, *bcur_mark; -# define FAST_STACK_SIZE 4 - Scheme_Object *a_mark_stack_fast[FAST_STACK_SIZE], *b_mark_stack_fast[FAST_STACK_SIZE]; - Scheme_Object **a_mark_stack = a_mark_stack_fast, **b_mark_stack = b_mark_stack_fast, **naya; - int a_mark_cnt = 0, a_mark_size = FAST_STACK_SIZE, b_mark_cnt = 0, b_mark_size = FAST_STACK_SIZE; - int used_barrier = 0; + { + int up = 0; + for (l = seen; !SCHEME_NULLP(l); l = SCHEME_CDR(l), up++) { + if (SAME_OBJ((Scheme_Object *)stx, SCHEME_CAR(l))) { + return scheme_make_pair(cycle_symbol, + scheme_make_pair(scheme_make_integer(up), + scheme_null)); + } + } + } - WRAP_POS_COPY(awl, *_awl); - WRAP_POS_COPY(bwl, *_bwl); - - if (!is_from_rib(barrier_env)) barrier_env = scheme_false; - - /* A simple way to compare marks would be to make two lists of - marks. The loop below attempts to speed up that process by - discovering common and canceled marks early, so they can be - omitted from the lists. The "stack" arrays accumulate the parts - of the list that can't be skipped that way. */ + multi_scopes = stx->scopes->multi_scopes; + /* Loop for top-level fallbacks: */ while (1) { - /* Skip over renames and canceled marks: */ - acur_mark = NULL; - while (1) { /* loop for canceling stack */ - /* this loop handles immediately canceled marks */ - while (1) { - if (WRAP_POS_END_P(awl)) - break; - if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) { - if (acur_mark) { - if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { - acur_mark = NULL; - WRAP_POS_INC(awl); - } else - break; - } else { - acur_mark = WRAP_POS_FIRST(awl); - WRAP_POS_INC(awl); - } - } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) { - if (SCHEME_FALSEP(barrier_env)) { - WRAP_POS_INC(awl); - } else { - /* See if the barrier environment is in this rib. */ - Scheme_Lexical_Rib *rib; - rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(awl); - for (rib = rib->next; rib; rib = rib->next) { - if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) - break; - } - if (!rib) { - WRAP_POS_INC(awl); - } else { - WRAP_POS_INIT_END(awl); - used_barrier = 1; - } - } + scopes = extract_scope_set_from_scope_list(stx->scopes->simple_scopes, multi_scopes, phase); + + desc = empty_hash_tree; + + if (SCHEME_SYMBOLP(stx->val)) + desc = scheme_hash_tree_set(desc, name_symbol, stx->val); + desc = scheme_hash_tree_set(desc, context_symbol, scopes_to_printed_list(scopes)); + + /* Describe other bindings */ + bindings = scheme_null; + i = scope_set_next(scopes, -1); + while (i != -1) { + scope_set_index(scopes, i, &key, &val); + + scope = (Scheme_Scope *)key; + if (scope->bindings) { + if (SCHEME_VECTORP(scope->bindings)) { + l = scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(scope->bindings), + SCHEME_VEC_BINDING_VAL(scope->bindings)); + bindings = add_bindings_info(bindings, SCHEME_VEC_BINDING_KEY(scope->bindings), l, + stx, all_bindings, seen); + l = NULL; } else { - WRAP_POS_INC(awl); - } - } - /* Maybe cancel a mark on the stack */ - if (acur_mark && a_mark_cnt) { - if (SAME_OBJ(acur_mark, a_mark_stack[a_mark_cnt - 1])) { - --a_mark_cnt; - if (a_mark_cnt) { - acur_mark = a_mark_stack[a_mark_cnt - 1]; - --a_mark_cnt; - break; - } else - acur_mark = NULL; - } else - break; - } else - break; - } - - bcur_mark = NULL; - while (1) { /* loop for canceling stack */ - while (1) { - if (WRAP_POS_END_P(bwl)) - break; - if (SCHEME_NUMBERP(WRAP_POS_FIRST(bwl))) { - if (bcur_mark) { - if (SAME_OBJ(bcur_mark, WRAP_POS_FIRST(bwl))) { - bcur_mark = NULL; - WRAP_POS_INC(bwl); - } else - break; - } else { - bcur_mark = WRAP_POS_FIRST(bwl); - WRAP_POS_INC(bwl); + l = scope->bindings; + if (SCHEME_RPAIRP(l)) + ht = (Scheme_Hash_Tree *)SCHEME_CAR(scope->bindings); + else { + STX_ASSERT(SCHEME_HASHTRP(l)); + ht = (Scheme_Hash_Tree *)l; } - } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) { - if (SCHEME_FALSEP(barrier_env)) { - WRAP_POS_INC(bwl); - } else { - /* See if the barrier environment is in this rib. */ - Scheme_Lexical_Rib *rib; - rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(bwl); - for (rib = rib->next; rib; rib = rib->next) { - if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) - break; - } - if (!rib) { - WRAP_POS_INC(bwl); - } else { - WRAP_POS_INIT_END(bwl); - used_barrier = 1; - } + + j = -1; + while ((j = scheme_hash_tree_next(ht, j)) != -1) { + scheme_hash_tree_index(ht, j, &key, &val); + bindings = add_bindings_info(bindings, key, val, stx, all_bindings, seen); } - } else { - WRAP_POS_INC(bwl); + + l = scope->bindings; + if (SCHEME_RPAIRP(l)) + l = SCHEME_CDR(l); + else + l = NULL; + } + + while (l) { + STX_ASSERT(SCHEME_RPAIRP(l)); + + bind_desc = empty_hash_tree; + + bind_desc = scheme_hash_tree_set(bind_desc, context_symbol, + scopes_to_printed_list(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)))); + + pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); + val = SCHEME_VEC_ELS(pes)[0]; + if (SCHEME_MODIDXP(val)) + val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); + bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); + + if (PES_UNMARSHAL_DESCP(pes)) { + /* unmarshal hasn't happened */ + } else { + pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; + if (!pt->ht) + scheme_populate_pt_ht(pt); + + if (scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, pes))) + bind_desc = scheme_hash_tree_set(bind_desc, matchp_symbol, scheme_true); + else + bind_desc = scheme_hash_tree_set(bind_desc, matchp_symbol, scheme_false); + } + + bindings = scheme_make_pair((Scheme_Object *)bind_desc, bindings); + + l = SCHEME_CDR(l); } } - /* Maybe cancel a mark on the stack */ - if (bcur_mark && b_mark_cnt) { - if (SAME_OBJ(bcur_mark, b_mark_stack[b_mark_cnt - 1])) { - --b_mark_cnt; - if (b_mark_cnt) { - bcur_mark = b_mark_stack[b_mark_cnt - 1]; - --b_mark_cnt; - break; - } else - bcur_mark = NULL; - } else - break; - } else - break; - } - - /* Same mark? */ - if (a_mark_cnt || b_mark_cnt || !SAME_OBJ(acur_mark, bcur_mark)) { - /* Not the same, so far; push onto stacks in case they're - cancelled later */ - if (acur_mark) { - if (a_mark_cnt >= a_mark_size) { - a_mark_size *= 2; - naya = MALLOC_N(Scheme_Object*, a_mark_size); - memcpy(naya, a_mark_stack, sizeof(Scheme_Object *)*a_mark_cnt); - a_mark_stack = naya; - } - a_mark_stack[a_mark_cnt++] = acur_mark; - } - if (bcur_mark) { - if (b_mark_cnt >= b_mark_size) { - b_mark_size *= 2; - naya = MALLOC_N(Scheme_Object*, b_mark_size); - memcpy(naya, b_mark_stack, sizeof(Scheme_Object *)*b_mark_cnt); - b_mark_stack = naya; - } - b_mark_stack[b_mark_cnt++] = bcur_mark; - } - } - - /* Done if both reached the end: */ - if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) { - EXPLAIN(fprintf(stderr, " %d vs. %d marks\n", a_mark_cnt, b_mark_cnt)); - if (a_mark_cnt == b_mark_cnt) { - while (a_mark_cnt--) { - if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt])) - return 0; - } - return used_barrier + 1; - } else - return 0; - } - } -} - -static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, - Scheme_Object **marks_cache, Scheme_Object *bdg2, - int depth, int *_skipped, int *_bdg_skipped) -{ - int l1, l2; - Scheme_Object *m1, *m2, *bdg1; - - p = SCHEME_CDR(p); /* skip modidx */ - p = SCHEME_CDR(p); /* skip phase_export */ - if (SCHEME_PAIRP(p)) { - /* has marks */ - int skip = 0, bdg_skip = 0; - EXPLAIN(fprintf(stderr, "%d has marks\n", depth)); + i = scope_set_next(scopes, i); + } - m1 = SCHEME_CAR(p); - if (SCHEME_VECTORP(m1)) { - bdg1 = SCHEME_VEC_ELS(m1)[1]; - m1 = SCHEME_VEC_ELS(m1)[0]; + if (!SCHEME_NULLP(bindings)) + desc = scheme_hash_tree_set(desc, bindings_symbol, scheme_reverse(bindings)); + + descs = scheme_make_pair((Scheme_Object *)desc, descs); + + if (SCHEME_FALLBACKP(multi_scopes)) { + multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); } else - bdg1 = scheme_false; + break; + } - EXPLAIN(fprintf(stderr, "%d %s vs. %s\n", depth, - scheme_write_to_string(bdg1, NULL), - scheme_write_to_string(bdg2, NULL))); - - /* check that bdg1 is a tail of bdg2, first */ - while (1) { - if (SAME_OBJ(bdg1, bdg2) - || (SCHEME_TRUEP(bdg1) && SCHEME_TRUEP(bdg2) && scheme_equal(bdg1, bdg2))) - break; - bdg_skip++; - if (SCHEME_PAIRP(bdg2)) { - bdg2 = SCHEME_CDR(bdg2); - if (SCHEME_PAIRP(bdg2) && SCHEME_NULLP(SCHEME_CDR(bdg2))) - bdg2 = SCHEME_CAR(bdg2); - } else if (SCHEME_FALSEP(bdg2)) { - *_bdg_skipped = -1; - return -1; /* no match */ - } else - bdg2 = scheme_false; - } - *_bdg_skipped = bdg_skip; - - if (*marks_cache) { - m2 = *marks_cache; - } else { - EXPLAIN(fprintf(stderr, "%d extract marks\n", depth)); - m2 = scheme_stx_extract_marks(orig_id); - *marks_cache = m2; - } - - l1 = scheme_list_length(m1); - l2 = scheme_list_length(m2); - - if (l2 < l1) return -1; /* no match */ - - while (l2 > l1) { - m2 = SCHEME_CDR(m2); - l2--; - skip++; - } - - if (scheme_equal(m1, m2)) { - if (_skipped ) *_skipped = skip; - return l1; /* matches */ - } else - return -1; /* no match */ - } else { - if (_skipped) *_skipped = -1; - if (_bdg_skipped) *_bdg_skipped = 0; - return 0; /* match empty mark set */ + if (SCHEME_NULLP(SCHEME_CDR(descs))) + return SCHEME_CAR(descs); + else { + descs = scheme_reverse(descs); + return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)SCHEME_CAR(descs), + fallbacks_symbol, + SCHEME_CDR(descs)); } } +void scheme_stx_debug_print(Scheme_Object *_stx, Scheme_Object *phase, int level) +{ + Scheme_Stx *stx = (Scheme_Stx *)_stx; + Scheme_Object *info; + + STX_ASSERT(SCHEME_STXP(_stx)); + + info = stx_debug_info(stx, phase, scheme_null, level > 1); + if (!level) { + info = scheme_hash_tree_get((Scheme_Hash_Tree *)info, context_symbol); + if (!info) info = scheme_false; + } + + printf("%s at phase %s:\n", + scheme_write_to_string(stx->val, NULL), + scheme_write_to_string(phase, NULL)); + printf(" %s\n", + scheme_write_to_string(info, NULL)); +} + +static void fprint_string(Scheme_Object *o, const char *s) +{ + (void)scheme_put_byte_string("describe", o, s, 0, strlen(s), 1); +} + +static void fprint_label_string(Scheme_Object *o, int rename_level, Scheme_Object *rename_sym, const char *s) +{ + fprint_string(o, "\n "); + if (rename_level) { + while (rename_level--) { + fprint_string(o, "="); + } + fprint_string(o, "> "); + scheme_write(rename_sym, o); + fprint_string(o, " "); + } + fprint_string(o, s); +} + +static void write_context(Scheme_Object *l, Scheme_Object *o) +{ + intptr_t col = 2, len; + char *s; + + while (!SCHEME_NULLP(l)) { + s = scheme_write_to_string(SCHEME_CAR(l), &len); + if ((col > 2) && (col + len + 1 > 80)) { + col = 2; + fprint_string(o, "\n "); + } + fprint_string(o, " "); + scheme_put_byte_string("describe", o, s, 0, len, 1); + col += len; + + l = SCHEME_CDR(l); + } +} + +static int context_matches(Scheme_Object *l1, Scheme_Object *l2) +/* Check whether the sorted list l2 is a subset of the sorted list l1 */ +{ + while (!SCHEME_NULLP(l2)) { + if (SCHEME_NULLP(l1)) + return 0; + + if (scheme_equal(SCHEME_CAR(l1), SCHEME_CAR(l2))) { + l1 = SCHEME_CDR(l1); + l2 = SCHEME_CDR(l2); + } else + l1 = SCHEME_CDR(l1); + } + + return 1; +} + +static Scheme_Object *describe_bindings(Scheme_Object *o, Scheme_Object *di, + int rename_level, Scheme_Object *rename_sym, + int always) +{ + Scheme_Object *l, *report, *val, *free_id; + Scheme_Hash_Tree *dit, *bt; + int fallback; + + fallback = 0; + while (!SCHEME_NULLP(di)) { + if (SCHEME_PAIRP(di)) + dit = (Scheme_Hash_Tree *)SCHEME_CAR(di); + else + dit = (Scheme_Hash_Tree *)di; + + l = scheme_hash_tree_get(dit, bindings_symbol); + if (l) { + report = scheme_null; + while (!SCHEME_NULLP(l)) { + bt = (Scheme_Hash_Tree *)SCHEME_CAR(l); + + val = scheme_hash_tree_get(bt, matchp_symbol); + + if ((val && SCHEME_TRUEP(val)) + || scheme_hash_tree_get(bt, name_symbol)) + report = scheme_make_pair((Scheme_Object *)bt, report); + + l = SCHEME_CDR(l); + } + + if (!SCHEME_NULLP(report) || always) { + if (!o) + o = scheme_make_byte_string_output_port(); + + fprint_label_string(o, rename_level, rename_sym, "context"); + if (fallback) { + fprint_string(o, " at layer "); + scheme_display(scheme_make_integer(fallback), o); + } + fprint_string(o, "...:\n "); + write_context(scheme_hash_tree_get(dit, context_symbol), o); + + while (!SCHEME_NULLP(report)) { + bt = (Scheme_Hash_Tree *)SCHEME_CAR(report); + + if (context_matches(scheme_hash_tree_get(dit, context_symbol), + scheme_hash_tree_get(bt, context_symbol))) + fprint_label_string(o, rename_level, rename_sym, "matching binding"); + else + fprint_label_string(o, rename_level, rename_sym, "other binding"); + if (fallback) { + fprint_string(o, " at layer "); + scheme_display(scheme_make_integer(fallback), o); + } + fprint_string(o, "...:\n "); + val = scheme_hash_tree_get(bt, module_symbol); + if (!val) { + fprint_string(o, "local "); + val = scheme_hash_tree_get(bt, local_symbol); + } + scheme_write(val, o); + fprint_string(o, "\n "); + write_context(scheme_hash_tree_get(bt, context_symbol), o); + + free_id = scheme_hash_tree_get(bt, free_symbol); + if (free_id) { + fprint_string(o, "\n free-identifier=? to "); + if (SCHEME_PAIRP(free_id) + && SAME_OBJ(SCHEME_CAR(free_id), cycle_symbol)) { + int up = SCHEME_INT_VAL(SCHEME_CAR(SCHEME_CDR(free_id))); + if (!up) + fprint_string(o, "[cycle to self]"); + else { + fprint_string(o, "[cycle, up "); + scheme_write(scheme_make_integer(up), o); + fprint_string(o, " levels]"); + } + } else { + if (SCHEME_HASHTRP(free_id)) + val = scheme_hash_tree_get((Scheme_Hash_Tree *)free_id, name_symbol); + else + val = NULL; + if (val) { + scheme_write(val, o); + o = describe_bindings(o, free_id, rename_level + 1, val, always); + } else { + fprint_string(o, "[unknown]"); + } + } + } + + report = SCHEME_CDR(report); + } + } + } + + if (SCHEME_PAIRP(di)) + di = SCHEME_CDR(di); + else { + di = scheme_hash_tree_get(dit, fallbacks_symbol); + if (!di) + di = scheme_null; + } + fallback++; + } + + return o; +} + +char *scheme_stx_describe_context(Scheme_Object *stx, Scheme_Object *phase, int always) +{ + Scheme_Object *di, *o = NULL; + intptr_t len; + char *r; + + if (!stx) + return ""; + + di = stx_debug_info((Scheme_Stx *)stx, phase, scheme_null, 0); + + o = describe_bindings(o, di, 0, NULL, always); + + if (o) { + r = scheme_get_sized_byte_string_output(o, &len); + /* make sure error buffer is allocated large enough: */ + scheme_ensure_max_symbol_length(len); + return r; + } + else + return ""; +} + +static void add_scopes_mapped_names(Scheme_Scope_Set *scopes, Scheme_Hash_Table *mapped) +{ + int retry; + Scheme_Hash_Tree *ht; + Scheme_Object *key, *val, *l, *pes; + intptr_t i, j; + Scheme_Scope *scope; + Scheme_Scope_Set *binding_scopes; + Scheme_Module_Phase_Exports *pt; + + do { + retry = 0; + i = scope_set_next(scopes, -1); + while (i != -1) { + scope_set_index(scopes, i, &key, &val); + + scope = (Scheme_Scope *)key; + if (scope->bindings) { + if (SCHEME_VECTORP(scope->bindings)) { + if (scope_subset(SCHEME_VEC_BINDING_SCOPES(scope->bindings), scopes)) + scheme_hash_set(mapped, SCHEME_VEC_BINDING_KEY(scope->bindings), scheme_true); + } else { + /* Check table of symbols */ + if (SCHEME_RPAIRP(scope->bindings)) + ht = (Scheme_Hash_Tree *)SCHEME_CAR(scope->bindings); + else { + STX_ASSERT(SCHEME_HASHTRP(scope->bindings)); + ht = (Scheme_Hash_Tree *)scope->bindings; + } + j = -1; + while ((j = scheme_hash_tree_next(ht, j)) != -1) { + scheme_hash_tree_index(ht, j, &key, &val); + l = val; + if (l) { + if (SCHEME_PAIRP(l)) { + if (scope_subset(SCHEME_BINDING_SCOPES(l), scopes)) + scheme_hash_set(mapped, key, scheme_true); + } else { + while (!SCHEME_NULLP(l)) { + STX_ASSERT(SCHEME_MPAIRP(l)); + if (scope_subset(SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), scopes)) { + scheme_hash_set(mapped, key, scheme_true); + break; + } + l = SCHEME_CDR(l); + } + } + } + } + } + + /* Check list of shared-binding tables */ + if (SCHEME_RPAIRP(scope->bindings)) + l = SCHEME_CDR(scope->bindings); + else + l = NULL; + while (l) { + STX_ASSERT(SCHEME_RPAIRP(l)); + binding_scopes = SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); + if (scope_subset(binding_scopes, scopes)) { + pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); + if (PES_UNMARSHAL_DESCP(pes)) { + if (SCHEME_TRUEP(SCHEME_VEC_ELS(pes)[0])) { + unmarshal_module_context_additions(NULL, pes, binding_scopes, l); + retry = 1; + } + } else { + pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; + if (!pt->ht) + scheme_populate_pt_ht(pt); + for (j = pt->ht->size; j--; ) { + if (pt->ht->vals[j]) { + val = unmarshal_key_adjust(pt->ht->keys[j], pes); + if (val) + scheme_hash_set(mapped, val, scheme_true); + } + } + } + } + l = SCHEME_CDR(l); + } + } + i = scope_set_next(scopes, i); + } + } while (retry); +} + +/******************** lookup ********************/ + +static Scheme_Object *do_stx_lookup(Scheme_Stx *stx, Scheme_Scope_Set *scopes, + Scheme_Scope_Set *check_subset, + GC_CAN_IGNORE int *_exact_match, + GC_CAN_IGNORE int *_ambiguous, + GC_CAN_IGNORE Scheme_Object **_sole_result) +/* the core lookup operation: walk through an identifier's marks, + and walk through the bindings attached to each of those marks */ +{ + int j, invalid, matches = 0; + intptr_t i; + Scheme_Object *key, *val, *result_best_so_far, *l, *pes; + Scheme_Scope *scope; + Scheme_Scope_Set *binding_scopes, *best_so_far; + Scheme_Module_Phase_Exports *pt; + + do { + invalid = 0; /* to indicate retry if we unmarshal */ + best_so_far = NULL; + result_best_so_far = NULL; + + i = scope_set_next(scopes, -1); + while ((i != -1) && !invalid) { + scope_set_index(scopes, i, &key, &val); + + scope = (Scheme_Scope *)key; + if (scope->bindings) { + for (j = 0; j < 2; j++) { + l = scope->bindings; + if (!j) { + if (SCHEME_VECTORP(l)) { + if (!SAME_OBJ(SCHEME_VEC_BINDING_KEY(l), stx->val)) + l = NULL; + /* l is NULL or a vector-form binding */ + } else if (SCHEME_HASHTRP(l)) { + l = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)l, stx->val); + /* l is a pair or mlist */ + } else { + STX_ASSERT(SCHEME_RPAIRP(l)); + l = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)SCHEME_CAR(l), + stx->val); + /* l is a pair or mlist */ + } + } else { + if (SCHEME_RPAIRP(l)) + l = SCHEME_CDR(l); + else + l = NULL; + /* l is an rlist */ + } + + /* l can have many different forms; see above */ + + while (l && !SCHEME_NULLP(l) && !invalid) { + if (SCHEME_VECTORP(l)) + binding_scopes = SCHEME_VEC_BINDING_SCOPES(l); + else if (SCHEME_PAIRP(l)) + binding_scopes = SCHEME_BINDING_SCOPES(l); + else { + STX_ASSERT(SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)); + binding_scopes = SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); + } + + if (j) { + STX_ASSERT(SCHEME_RPAIRP(l)); + pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); + if (PES_UNMARSHAL_DESCP(pes)) { + /* Not a pes; an unmarshal */ + if (SCHEME_TRUEP(SCHEME_VEC_ELS(pes)[0])) { + /* Need unmarshal --- but only if the scope set is relevant */ + if (scope_subset(binding_scopes, scopes)) { + /* unmarshal and note that we must restart */ + unmarshal_module_context_additions(stx, pes, binding_scopes, l); + invalid = 1; + /* Shouldn't encounter this on a second pass: */ + STX_ASSERT(!check_subset); + } + } + binding_scopes = NULL; + } else { + /* Check for id in pes */ + pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(pes)[1]; + if (!pt->ht) { + /* Lookup table (which is created lazily) not yet created, so do that now... */ + scheme_populate_pt_ht(pt); + } + + if (!scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, pes))) + binding_scopes = NULL; + } + } + + if (binding_scopes && scope_subset(binding_scopes, scopes)) { + if (check_subset && !scope_subset(binding_scopes, check_subset)) { + if (_ambiguous) *_ambiguous = 1; + return NULL; /* ambiguous */ + } + matches++; + if (!best_so_far + || ((scope_set_count(binding_scopes) > scope_set_count(best_so_far)) + && (!check_subset + || (scope_set_count(binding_scopes) == scope_set_count(check_subset))))) { + best_so_far = binding_scopes; + if (SCHEME_VECTORP(l)) + result_best_so_far = SCHEME_VEC_BINDING_VAL(l); + else if (SCHEME_PAIRP(l)) + result_best_so_far = SCHEME_BINDING_VAL(l); + else { + STX_ASSERT(SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)); + result_best_so_far = SCHEME_BINDING_VAL(SCHEME_CAR(l)); + } + STX_ASSERT(SCHEME_FALSEP(result_best_so_far) + || SCHEME_MODIDXP(result_best_so_far) + || SCHEME_PAIRP(result_best_so_far) + || SCHEME_VECTORP(result_best_so_far) + || SCHEME_SYMBOLP(result_best_so_far) + || SCHEME_MPAIRP(result_best_so_far)); + if (_exact_match) *_exact_match = (scope_set_count(binding_scopes) == scope_set_count(scopes)); + } + } + + if (SCHEME_RPAIRP(l) || SCHEME_MPAIRP(l)) + l = SCHEME_CDR(l); + else + l = NULL; + } + } + } + + i = scope_set_next(scopes, i); + } + } while (invalid); + + if (!best_so_far) + return NULL; + + if (check_subset) + return result_best_so_far; + else { + if (matches == 1) + *_sole_result = result_best_so_far; + else + *_sole_result = NULL; + return (Scheme_Object *)best_so_far; + } +} + +static Scheme_Object *do_stx_lookup_nonambigious(Scheme_Stx *stx, Scheme_Object *phase, + GC_CAN_IGNORE int *_exact_match, + GC_CAN_IGNORE int *_ambiguous, + Scheme_Scope_Set **_binding_scopes) +{ + Scheme_Scope_Set *scopes, *best_set; + Scheme_Object *multi_scopes, *result; + + multi_scopes = stx->scopes->multi_scopes; + + /* Loop for top-level fallbacks: */ + while (1) { + scopes = extract_scope_set_from_scope_list(stx->scopes->simple_scopes, multi_scopes, phase); + + best_set = (Scheme_Scope_Set *)do_stx_lookup(stx, scopes, + NULL, + _exact_match, _ambiguous, + &result); + if (best_set) { + if (_binding_scopes) *_binding_scopes = best_set; + + if (!result) { + /* Find again, this time checking to ensure no ambiguity: */ + result = do_stx_lookup(stx, scopes, + best_set, + _exact_match, _ambiguous, + NULL); + } + + if (!result && SCHEME_FALLBACKP(multi_scopes)) { + if (_ambiguous) *_ambiguous = 0; + if (_exact_match) *_exact_match = 0; + multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); + } else + return result; + } else if (SCHEME_FALLBACKP(multi_scopes)) + multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); + else + return NULL; + } +} + +static Scheme_Object *apply_accumulated_shifts(Scheme_Object *result, Scheme_Object *prev_shifts, + GC_CAN_IGNORE Scheme_Object **_insp, + GC_CAN_IGNORE Scheme_Object **nominal_modidx, + Scheme_Stx *stx, Scheme_Object *orig_name, Scheme_Object *phase) +/* Adjust result to take the `free-id=?` chain into account: adjust a + `#f` result to add in the original name, or adjust a module name + for modidx shifts */ +{ + Scheme_Object *o; + + if (SCHEME_VECTORP(result)) { + if (!SCHEME_NULLP(prev_shifts) + || (SCHEME_FALSEP(SCHEME_VEC_ELS(result)[0]) + && !SAME_OBJ(stx->val, orig_name))) { + /* Clone result vector */ + o = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(o)[0] = SCHEME_VEC_ELS(result)[0]; + SCHEME_VEC_ELS(o)[1] = SCHEME_VEC_ELS(result)[1]; + SCHEME_VEC_ELS(o)[2] = SCHEME_VEC_ELS(result)[2]; + result = o; + + if (SCHEME_FALSEP(SCHEME_VEC_ELS(result)[1])) + SCHEME_VEC_ELS(result)[1] = stx->val; + + for (; !SCHEME_NULLP(prev_shifts); prev_shifts = SCHEME_CDR(prev_shifts)) { + o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), SCHEME_VEC_ELS(result)[0], _insp, NULL); + SCHEME_VEC_ELS(result)[0] = o; + if (nominal_modidx) { + o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), *nominal_modidx, NULL, NULL); + *nominal_modidx = o; + } + } + } + } else if (SCHEME_FALSEP(result) && !SAME_OBJ(stx->val, orig_name)) { + result = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(result)[0] = scheme_false; + SCHEME_VEC_ELS(result)[1] = stx->val; + SCHEME_VEC_ELS(result)[2] = phase; + } + + if (_insp && *_insp && SCHEME_SYMBOLP(*_insp)) + *_insp = scheme_false; /* wasn't shifted, for some reason */ + + return result; +} + +#define BINDING_CACHE_SIZE 32 + +typedef struct Binding_Cache_Entry { + Scheme_Stx *id; + Scheme_Object *phase; + Scheme_Object *result; + Scheme_Scope_Set *binding_scopes; + Scheme_Object *insp_desc; + Scheme_Object *free_eq; +} Binding_Cache_Entry; + +static void init_binding_cache(void) +{ + REGISTER_SO(binding_cache_table); + binding_cache_table = MALLOC_N_ATOMIC(Binding_Cache_Entry, BINDING_CACHE_SIZE); +} + +static void clear_binding_cache(void) +{ + binding_cache_len = 0; +} + +static void clear_binding_cache_for(Scheme_Object *sym) +{ + clear_binding_cache(); +} + +static void clear_binding_cache_stx(Scheme_Stx *stx) +{ + Binding_Cache_Entry *binding_cache = binding_cache_table; + int i; + + for (i = binding_cache_len; i--; ) { + if (SAME_OBJ(binding_cache[i].id, stx)) + binding_cache[i].id = NULL; + } +} + +XFORM_NONGCING static int find_in_binding_cache(Scheme_Stx *id, Scheme_Object *phase) +{ + Binding_Cache_Entry *binding_cache = binding_cache_table; + int i; + + for (i = binding_cache_len; i--; ) { + if (SAME_OBJ(binding_cache[i].id, id) + && SAME_OBJ(binding_cache[i].phase, phase)){ + return i; + } + } + + return -1; +} + +XFORM_NONGCING static void save_in_binding_cache(Scheme_Stx *id, Scheme_Object *phase, + Scheme_Object *result, + Scheme_Scope_Set *binding_scopes, Scheme_Object *insp_desc, + Scheme_Object *free_eq) +{ + Binding_Cache_Entry *binding_cache = binding_cache_table; + int i; + + if (binding_cache_len < BINDING_CACHE_SIZE) { + i = binding_cache_len++; + } else if (binding_cache_pos < binding_cache_len) { + i = binding_cache_pos; + binding_cache_pos++; + } else { + i = 0; + binding_cache_pos = 1; + } + + binding_cache[i].id = id; + binding_cache[i].phase = phase; + binding_cache[i].result = result; + binding_cache[i].binding_scopes = binding_scopes; + binding_cache[i].insp_desc = insp_desc; + binding_cache[i].free_eq = free_eq; +} + +Scheme_Object *scheme_stx_lookup_w_nominal(Scheme_Object *o, Scheme_Object *phase, + int stop_at_free_eq, + GC_CAN_IGNORE int *_exact_match, + GC_CAN_IGNORE int *_ambiguous, + GC_CAN_IGNORE Scheme_Scope_Set **_binding_scopes, + GC_CAN_IGNORE Scheme_Object **_insp, /* access-granting inspector */ + GC_CAN_IGNORE Scheme_Object **nominal_modidx, /* how it was imported */ + GC_CAN_IGNORE Scheme_Object **nominal_name, /* imported as name */ + GC_CAN_IGNORE Scheme_Object **src_phase, /* phase level of import from nominal modidx */ + GC_CAN_IGNORE Scheme_Object **nominal_src_phase) /* phase level of export from nominal modidx */ +/* Result is either a representation of a local binding (probably a symbol), + a vector of the form (vector ), or + #f */ +{ + Scheme_Stx *stx; + Scheme_Object *result, *insp_desc; + Scheme_Scope_Set *binding_scopes; + Scheme_Object *free_eq, *prev_shifts = scheme_null, *orig_name; + Scheme_Hash_Table *free_id_seen = NULL; + int cache_pos; + + STX_ASSERT(SCHEME_STXP(o)); + + orig_name = SCHEME_STX_VAL(o); + + while (1) { /* loop for `free-identifier=?` chains */ + stx = (Scheme_Stx *)o; + + if (_ambiguous) *_ambiguous = 0; + + if (nominal_name) + cache_pos = -1; + else + cache_pos = find_in_binding_cache(stx, phase); + + if (cache_pos >= 0) { + /* must extract from cache before a GC: */ + GC_CAN_IGNORE Binding_Cache_Entry *binding_cache = binding_cache_table; + + result = binding_cache[cache_pos].result; + binding_scopes = binding_cache[cache_pos].binding_scopes; + if (_insp) *_insp = binding_cache[cache_pos].insp_desc; + free_eq = binding_cache[cache_pos].free_eq; + + if (_binding_scopes) + *_binding_scopes = binding_scopes; + if (_exact_match) { + if (binding_scopes + && (scope_set_count(binding_scopes) == scope_set_count(extract_scope_set(stx, phase)))) + *_exact_match = 1; + else + *_exact_match = 0; + } + + if (free_eq) { + if (!stop_at_free_eq) { + o = SCHEME_CAR(free_eq); + phase = SCHEME_CDR(free_eq); + /* recur to handle `free-identifier=?` chain */ + if (!free_id_seen) + free_id_seen = scheme_make_hash_table(SCHEME_hash_ptr); + if (scheme_eq_hash_get(free_id_seen, o)) + return scheme_false; /* found a cycle */ + scheme_hash_set(free_id_seen, o, scheme_true); + prev_shifts = scheme_make_pair(stx->shifts, prev_shifts); + continue; + } else + return apply_accumulated_shifts(result, prev_shifts, _insp, NULL, + stx, orig_name, phase); + } else + return apply_accumulated_shifts(result, prev_shifts, _insp, NULL, + stx, orig_name, phase); + } + + binding_scopes = NULL; + if (_exact_match) *_exact_match = 0; + + result = do_stx_lookup_nonambigious(stx, phase, + _exact_match, _ambiguous, + &binding_scopes); + + if (_binding_scopes) *_binding_scopes = binding_scopes; + + if (!result) { + save_in_binding_cache(stx, phase, scheme_false, + NULL, NULL, NULL); + return apply_accumulated_shifts(scheme_false, scheme_null, NULL, NULL, + stx, orig_name, phase); + } + + /* + `result` can be: + - a symbol for a lexical binding, + - a pair, modidx, or #f for a module import + - a vector for a pes (shared export table from a module) + - a mutable pair of the above plus an identifier for a `free-identifier=?` link + */ + if (SCHEME_MPAIRP(result)) { + free_eq = SCHEME_CDR(result); + result = SCHEME_CAR(result); + } else + free_eq = NULL; + + if (!SCHEME_SYMBOLP(result)) { + /* Generate a result vector: (vector ) */ + Scheme_Object *l = result; + + result = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(result)[1] = stx->val; + SCHEME_VEC_ELS(result)[2] = scheme_make_integer(0); + + if (nominal_modidx) *nominal_modidx = NULL; + if (nominal_name) *nominal_name = NULL; + if (src_phase) *src_phase = NULL; + if (nominal_src_phase) *nominal_src_phase = NULL; + + if (SCHEME_FALSEP(l)) { + /* top-level bound */ + SCHEME_VEC_ELS(result)[0] = scheme_false; + /* phase of defn must be binding phase: */ + SCHEME_VEC_ELS(result)[2] = phase; + insp_desc = scheme_false; + } else if (SCHEME_MODIDXP(l)) { + SCHEME_VEC_ELS(result)[0] = l; + insp_desc = scheme_false; + } else if (SCHEME_PAIRP(l)) { + /* A list for a module import */ + Scheme_Object *modidx; + Scheme_Object *exportname = SCHEME_VEC_ELS(result)[1]; + Scheme_Object *mod_phase = SCHEME_VEC_ELS(result)[2]; + + extract_module_binding_parts(l, + SCHEME_VEC_ELS(result)[2], + &insp_desc, + &modidx, /* required */ + &exportname, /* required */ + nominal_modidx, + &mod_phase, /* required */ + nominal_name, + src_phase, + nominal_src_phase); + + SCHEME_VEC_ELS(result)[0] = modidx; + SCHEME_VEC_ELS(result)[1] = exportname; + SCHEME_VEC_ELS(result)[2] = mod_phase; + } else { + /* A vector for a pes */ + Scheme_Module_Phase_Exports *pt; + Scheme_Object *pos, *mod; + + STX_ASSERT(SCHEME_VECTORP(l)); + + pt = (Scheme_Module_Phase_Exports *)SCHEME_VEC_ELS(l)[1]; + insp_desc = SCHEME_VEC_ELS(l)[4]; + + pos = scheme_eq_hash_get(pt->ht, unmarshal_lookup_adjust(stx->val, l)); + + if (pt->provide_srcs) { + mod = pt->provide_srcs[SCHEME_INT_VAL(pos)]; + if (SCHEME_FALSEP(mod)) + mod = SCHEME_VEC_ELS(l)[0]; + else + mod = scheme_modidx_shift(mod, + pt->src_modidx, + SCHEME_VEC_ELS(l)[0]); + } else + mod = SCHEME_VEC_ELS(l)[0]; + + SCHEME_VEC_ELS(result)[0] = mod; + + if (nominal_modidx) + *nominal_modidx = SCHEME_VEC_ELS(l)[0]; + + SCHEME_VEC_ELS(result)[1] = pt->provide_src_names[SCHEME_INT_VAL(pos)]; + + if (nominal_name) + *nominal_name = pt->provides[SCHEME_INT_VAL(pos)]; + + if (pt->provide_src_phases) + SCHEME_VEC_ELS(result)[2] = scheme_make_integer(pt->provide_src_phases[SCHEME_INT_VAL(pos)]); + + if (src_phase) *src_phase = SCHEME_VEC_ELS(l)[2]; + if (nominal_src_phase) *nominal_src_phase = pt->phase_index; + } + + if (nominal_name && !*nominal_name) + *nominal_name = stx->val; + if (nominal_modidx && !*nominal_modidx) + *nominal_modidx = SCHEME_VEC_ELS(result)[0]; + if (src_phase && !*src_phase) + *src_phase = scheme_make_integer(0); + if (nominal_src_phase && !*nominal_src_phase) + *nominal_src_phase = SCHEME_VEC_ELS(result)[2]; + + l = apply_modidx_shifts(stx->shifts, SCHEME_VEC_ELS(result)[0], &insp_desc, NULL); + SCHEME_VEC_ELS(result)[0] = l; + + if (nominal_modidx) { + l = apply_modidx_shifts(stx->shifts, *nominal_modidx, NULL, NULL); + *nominal_modidx = l; + } + } else + insp_desc = scheme_false; + + save_in_binding_cache(stx, phase, result, + binding_scopes, insp_desc, + free_eq); + + if (_insp) *_insp = insp_desc; + + if (!free_eq || stop_at_free_eq) + return apply_accumulated_shifts(result, prev_shifts, _insp, nominal_modidx, + stx, orig_name, phase); + + /* Recur for `free-identifier=?` mapping */ + phase = SCHEME_CDR(free_eq); + o = SCHEME_CAR(free_eq); + prev_shifts = scheme_make_pair(stx->shifts, prev_shifts); + + if (!free_id_seen) + free_id_seen = scheme_make_hash_table(SCHEME_hash_ptr); + if (scheme_eq_hash_get(free_id_seen, o)) + return scheme_false; /* found a cycle */ + } +} + +Scheme_Object *scheme_stx_lookup(Scheme_Object *o, Scheme_Object *phase) +{ + return scheme_stx_lookup_w_nominal(o, phase, 0, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL); +} + +Scheme_Object *scheme_stx_lookup_stop_at_free_eq(Scheme_Object *o, Scheme_Object *phase, int *_exact_match) +{ + return scheme_stx_lookup_w_nominal(o, phase, 1, _exact_match, NULL, NULL, NULL, NULL, NULL, NULL, NULL); +} + +Scheme_Object *scheme_stx_lookup_exact(Scheme_Object *o, Scheme_Object *phase) +{ + int exact; + Scheme_Object *b; + + b = scheme_stx_lookup_w_nominal(o, phase, 1, &exact, NULL, NULL, NULL, NULL, NULL, NULL, NULL); + + if (!exact) + return scheme_false; + else + return b; +} void scheme_populate_pt_ht(Scheme_Module_Phase_Exports * pt) { if (!pt->ht) { @@ -3496,1618 +4130,851 @@ void scheme_populate_pt_ht(Scheme_Module_Phase_Exports * pt) { } } -static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, - Scheme_Object *glob_id, Scheme_Object *orig_id, - Scheme_Object *bdg, - Scheme_Object **get_names, int get_orig_name, - int depth, - int *_skipped) +void scheme_add_binding_copy(Scheme_Object *o, Scheme_Object *from_o, Scheme_Object *phase) { - Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL; - Scheme_Module_Phase_Exports *pt; - int i, phase, best_match_len = -1, best_match_bdg_skip = -1, skip = 0, bdg_skip = -1; - Scheme_Object *marks_cache = NULL; + Scheme_Stx *stx = (Scheme_Stx *)o; - for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { - pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr)); + STX_ASSERT(SCHEME_STXP(o)); + STX_ASSERT(SCHEME_STXP(from_o)); - EXPLAIN(fprintf(stderr, "%d pes table %s\n", depth, - pt->src_modidx - ? scheme_write_to_string(scheme_module_resolve(pt->src_modidx, 0), NULL) - : "?")); - - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - EXPLAIN(fprintf(stderr, "%d {create lookup}\n", depth)); - scheme_populate_pt_ht(pt); - } - - pos = scheme_hash_get(pt->ht, glob_id); - if (pos) { - /* Found it, maybe. Check marks & bdg. */ - int mark_len; - EXPLAIN(fprintf(stderr, "%d found %p\n", depth, pos)); - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, bdg, depth, &skip, &bdg_skip); - if ((best_match_bdg_skip == -1) && (mark_len >= 0)) best_match_bdg_skip = bdg_skip + 1; - if (((bdg_skip < best_match_bdg_skip) && (mark_len >= 0)) - || ((bdg_skip == best_match_bdg_skip) && (mark_len > best_match_len))) { - /* Marks and bdg match and improve on previously found match. Build suitable rename: */ - best_match_len = mark_len; - best_match_bdg_skip = bdg_skip; - if (_skipped) *_skipped = skip; - - idx = SCHEME_CAR(SCHEME_CAR(pr)); - - i = SCHEME_INT_VAL(pos); - - if (get_orig_name) - best_match = pt->provide_src_names[i]; - else { - if (pt->provide_srcs) - src = pt->provide_srcs[i]; - else - src = scheme_false; - - if (get_names) { - /* If module bound, result is module idx, and get_names[0] is set to source name, - get_names[1] is set to the nominal source module, get_names[2] is set to - the nominal source module's export, get_names[3] is set to the phase of - the source definition, get_names[4] is set to the module import phase index, - and get_names[5] is set to the nominal export phase */ - - if (pt->provide_src_phases) - phase = pt->provide_src_phases[i]; - else - phase = 0; - - EXPLAIN(fprintf(stderr, "%d srcname %s\n", depth, SCHEME_SYM_VAL(pt->provide_src_names[i]))); - EXPLAIN(fprintf(stderr, "%d mod phase %d\n", depth, phase)); - get_names[0] = pt->provide_src_names[i]; - get_names[1] = idx; - get_names[2] = glob_id; - get_names[3] = scheme_make_integer(phase); - get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr))); - if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */ - get_names[4] = SCHEME_CDR(get_names[4]); - get_names[5] = pt->phase_index; - } - - if (SCHEME_FALSEP(src)) { - src = idx; - } else { - src = scheme_modidx_shift(src, pt->src_modidx, idx); - } - - best_match = src; - } - } - } - } - - return best_match; + /* Passing an identifier as the "value" adds to the existing binding, + instead of replacing it: */ + add_binding(stx->val, phase, extract_scope_set(stx, phase), from_o, NULL, NULL); } -static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object *phase) +/******************** module contexts ********************/ + +/* A module context is a convenience record to track the scopes, + inspector, etc. that are related to expanding a `module` form */ + +Scheme_Object *scheme_make_module_context(Scheme_Object *insp, + Scheme_Object *shift_or_shifts, + Scheme_Object *debug_name) { - if (SAME_OBJ(phase, scheme_make_integer(0))) - return mrns->rt; - else if (SAME_OBJ(phase, scheme_make_integer(1))) - return mrns->et; - else if (mrns->other_phases) - return (Module_Renames *)scheme_hash_get(mrns->other_phases, phase); + Scheme_Object *vec; + Scheme_Object *body_scopes; + Scheme_Object *intro_multi_scope; + + /* The `intro_multi_scope` is the home for all bindings in a given context. + It is added to any form that emerges into a module context via + macro expansion. + In the case of top-level forms, this context is sometimes stripped away + and replaced with a new top-level context. */ + intro_multi_scope = new_multi_scope(debug_name); + body_scopes = scheme_make_pair(intro_multi_scope, scheme_null); + + /* An additional scope identifies the original module home of an + identifier (i.e., not added to things that are macro-introduced + into the module context). The root scope serves to unify all + top-level contexts. */ + if (SCHEME_FALSEP(debug_name)) + body_scopes = scheme_make_pair(root_scope, body_scopes); else + body_scopes = scheme_make_pair(scheme_new_scope(SCHEME_STX_MODULE_SCOPE), body_scopes); + + if (!shift_or_shifts) + shift_or_shifts = scheme_null; + else if (!SCHEME_PAIRP(shift_or_shifts) && !SCHEME_NULLP(shift_or_shifts)) + shift_or_shifts = scheme_make_pair(shift_or_shifts, scheme_null); + + /* A module context consists of + - A list of scopes, multi-scopes, and (cons multi-scope phase) that + corresponds to the module body + - A phase used for extracting scopes (not a shift for the intro scope) + - An inspector + - A list of module-index shifts + - A multi-scope for binding/introduction (included in body scopes) + - A list of scopes that correspond to macro uses; + this scopes must be stripped away from a definition + */ + + vec = scheme_make_vector(6, NULL); + SCHEME_VEC_ELS(vec)[0] = body_scopes; + SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(0); + SCHEME_VEC_ELS(vec)[2] = insp; + SCHEME_VEC_ELS(vec)[3] = shift_or_shifts; + SCHEME_VEC_ELS(vec)[4] = intro_multi_scope; + SCHEME_VEC_ELS(vec)[5] = (Scheme_Object *)empty_scope_set; + + return vec; +} + +Scheme_Scope_Set *scheme_module_context_scopes(Scheme_Object *mc) +{ + Scheme_Object *body_scopes = SCHEME_VEC_ELS(mc)[0], *scope; + Scheme_Object *phase = SCHEME_VEC_ELS(mc)[1]; + Scheme_Scope_Set *scopes = empty_scope_set; + + while (!SCHEME_NULLP(body_scopes)) { + scope = SCHEME_CAR(body_scopes); + if (!SCHEME_SCOPEP(scope)) { + if (SCHEME_PAIRP(scope)) + scope = extract_simple_scope_from_shifted(scope, phase); + else + scope = extract_simple_scope(scope, phase); + } + if (scope) + scopes = scope_set_set(scopes, scope, scheme_true); + body_scopes = SCHEME_CDR(body_scopes); + } + + return scopes; +} + +Scheme_Object *scheme_module_context_frame_scopes(Scheme_Object *mc, Scheme_Object *keep_intdef_scopes) +{ + Scheme_Object *scopes; + + scopes = (Scheme_Object *)scheme_module_context_scopes(mc); + + if (keep_intdef_scopes) + scopes = add_intdef_scopes_of(scopes, keep_intdef_scopes); + + return scopes; +} + +void scheme_module_context_add_use_site_scope(Scheme_Object *mc, Scheme_Object *use_site_scope) +{ + Scheme_Scope_Set *use_site_scopes = (Scheme_Scope_Set *)SCHEME_VEC_ELS(mc)[5]; + + STX_ASSERT(SCHEME_SCOPEP(use_site_scope)); + + use_site_scopes = scope_set_set(use_site_scopes, use_site_scope, scheme_true); + + SCHEME_VEC_ELS(mc)[5] = (Scheme_Object *)use_site_scopes; +} + +Scheme_Object *scheme_module_context_use_site_frame_scopes(Scheme_Object *mc) +{ + Scheme_Scope_Set *use_site_scopes; + + use_site_scopes = (Scheme_Scope_Set *)SCHEME_VEC_ELS(mc)[5]; + if (SAME_OBJ(use_site_scopes, empty_scope_set)) + return NULL; + else + return make_vector3(scheme_false, (Scheme_Object *)use_site_scopes, scheme_false); +} + +Scheme_Object *scheme_module_context_inspector(Scheme_Object *mc) +{ + return SCHEME_VEC_ELS(mc)[2]; +} + +void scheme_module_context_add_mapped_symbols(Scheme_Object *mc, Scheme_Hash_Table *mapped) +{ + add_scopes_mapped_names(scheme_module_context_scopes(mc), mapped); +} + +Scheme_Object *scheme_module_context_at_phase(Scheme_Object *mc, Scheme_Object *phase) +{ + Scheme_Object *vec; + + /* Clones the module context, but with a different convenience phase */ + + if (SAME_OBJ(SCHEME_VEC_ELS(mc)[1], phase)) + return mc; + + vec = scheme_make_vector(6, NULL); + SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(mc)[0]; + SCHEME_VEC_ELS(vec)[1] = phase; + SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(mc)[2]; + SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(mc)[3]; + SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(mc)[4]; + /* Any use-site scope from the from another phase don't apply here. This + set only matters for module contexts that are attached to environments, + anyway: */ + SCHEME_VEC_ELS(vec)[5] = (Scheme_Object *)empty_scope_set; + + return vec; +} + +static Scheme_Object *adjust_module_context_except(Scheme_Object *stx, Scheme_Object *mc, Scheme_Object *skip, + int mode) +{ + Scheme_Object *body_scopes = SCHEME_VEC_ELS(mc)[0], *scope; + Scheme_Object *phase = SCHEME_VEC_ELS(mc)[1]; + + while (!SCHEME_NULLP(body_scopes)) { + scope = SCHEME_CAR(body_scopes); + if (skip && SAME_OBJ(scope, skip)) + scope = NULL; + else if (!SCHEME_SCOPEP(scope)) { + if (SCHEME_PAIRP(scope)) + scope = extract_simple_scope_from_shifted(scope, phase); + else + scope = extract_simple_scope(scope, phase); + } + if (scope) + stx = scheme_stx_adjust_scope(stx, scope, phase, mode); + body_scopes = SCHEME_CDR(body_scopes); + } + + if (mode == SCHEME_STX_ADD) + stx = scheme_stx_add_shifts(stx, SCHEME_VEC_ELS(mc)[3]); + + return stx; +} + +Scheme_Object *scheme_stx_add_module_context(Scheme_Object *stx, Scheme_Object *mc) +{ + return adjust_module_context_except(stx, mc, NULL, SCHEME_STX_ADD); +} + +Scheme_Object *scheme_stx_push_module_context(Scheme_Object *stx, Scheme_Object *mc) +{ + Scheme_Object *intro_multi_scope = SCHEME_VEC_ELS(mc)[4]; + + stx = scheme_stx_adjust_scope(stx, intro_multi_scope, scheme_make_integer(0), SCHEME_STX_PUSH); + stx = adjust_module_context_except(stx, mc, intro_multi_scope, SCHEME_STX_ADD); + + return stx; +} + +Scheme_Object *scheme_stx_push_introduce_module_context(Scheme_Object *stx, Scheme_Object *mc) +{ + Scheme_Object *intro_multi_scope = SCHEME_VEC_ELS(mc)[4]; + + return scheme_stx_adjust_scope(stx, intro_multi_scope, scheme_make_integer(0), SCHEME_STX_PUSH); +} + +Scheme_Object *scheme_stx_add_module_frame_context(Scheme_Object *stx, Scheme_Object *mc) +{ + return scheme_stx_add_module_context(stx, mc); +} + +Scheme_Object *scheme_stx_introduce_to_module_context(Scheme_Object *stx, Scheme_Object *mc) +{ + Scheme_Object *multi_scope; + + STX_ASSERT(SCHEME_VECTORP(mc)); + + multi_scope = SCHEME_VEC_ELS(mc)[4]; + + return scheme_stx_add_scope(stx, multi_scope, scheme_make_integer(0)); +} + +Scheme_Object *scheme_stx_unintroduce_from_module_context(Scheme_Object *stx, Scheme_Object *mc) +{ + return adjust_module_context_except(stx, mc, NULL, SCHEME_STX_REMOVE); +} + +Scheme_Object *scheme_stx_adjust_module_use_site_context(Scheme_Object *stx, Scheme_Object *mc, int mode) +{ + Scheme_Scope_Set *scopes = (Scheme_Scope_Set *)SCHEME_VEC_ELS(mc)[5]; + + return scheme_stx_adjust_scopes(stx, scopes, SCHEME_VEC_ELS(mc)[1], mode); +} + +void scheme_extend_module_context(Scheme_Object *mc, /* (vector ...) */ + Scheme_Object *ctx, /* binding context (as stx) or NULL */ + Scheme_Object *modidx, /* actual source module */ + Scheme_Object *localname, /* name in local context */ + Scheme_Object *exname, /* name in definition context */ + Scheme_Object *nominal_mod, /* nominal source module */ + Scheme_Object *nominal_ex, /* nominal import before local renaming */ + intptr_t mod_phase, /* phase of source defn */ + Scheme_Object *src_phase, /* nominal import phase */ + Scheme_Object *nom_phase) /* nominal export phase */ +{ + Scheme_Scope_Set *scopes; + + if (ctx) + scopes = extract_scope_set((Scheme_Stx *)ctx, SCHEME_VEC_ELS(mc)[1]); + else + scopes = scheme_module_context_scopes(mc); + + do_add_module_binding(scopes, localname, SCHEME_VEC_ELS(mc)[1], + modidx, exname, scheme_make_integer(mod_phase), + SCHEME_VEC_ELS(mc)[2], + nominal_mod, nominal_ex, + src_phase, nom_phase, + NULL, NULL); +} + +void scheme_extend_module_context_with_shared(Scheme_Object *mc, /* (vector ) or (cons ) */ + Scheme_Object *modidx, + Scheme_Module_Phase_Exports *pt, + Scheme_Object *prefix, /* a sybmol; not included in `excepts` keys */ + Scheme_Hash_Tree *excepts, /* NULL => empty */ + Scheme_Object *src_phase, /* nominal import phase */ + Scheme_Object *context, + Scheme_Object *replace_at) +/* create a bulk import */ +{ + Scheme_Object *phase, *pes, *insp_desc, *unmarshal_info; + Scheme_Scope_Set *scopes; + + if (SCHEME_VECTORP(mc)) { + phase = SCHEME_VEC_ELS(mc)[1]; + insp_desc = SCHEME_VEC_ELS(mc)[2]; + } else { + phase = SCHEME_CAR(mc); + insp_desc = SCHEME_CDR(mc); + } + + if (context) + scopes = extract_scope_set((Scheme_Stx *)context, phase); + else + scopes = scheme_module_context_scopes(mc); + + unmarshal_info = make_unmarshal_info(pt->phase_index, prefix, (Scheme_Object *)excepts); + + pes = scheme_make_vector(5, NULL); + SCHEME_VEC_ELS(pes)[0] = modidx; + SCHEME_VEC_ELS(pes)[1] = (Scheme_Object *)pt; + SCHEME_VEC_ELS(pes)[2] = src_phase; + SCHEME_VEC_ELS(pes)[3] = unmarshal_info; + SCHEME_VEC_ELS(pes)[4] = insp_desc; + + if (replace_at) { + SCHEME_BINDING_VAL(SCHEME_CAR(replace_at)) = pes; + } else { + add_binding(NULL, phase, scopes, pes, NULL, NULL); + } +} + +static Scheme_Object *make_unmarshal_info(Scheme_Object *phase, + Scheme_Object *prefix, + Scheme_Object *excepts) +{ + Scheme_Object *unmarshal_info; + + /* unmarshal_info = phase + . | (cons phase adjusts) + adjusts = prefix + . | (cons excepts-ht prefix) + . | excepts-list + excepts-ht = (hasheq symbol #t ... ...) + */ + unmarshal_info = prefix; + if (excepts) { + if (SCHEME_FALSEP(unmarshal_info)) + unmarshal_info = excepts; + else + unmarshal_info = scheme_make_pair(excepts, prefix); + } + if (SCHEME_FALSEP(unmarshal_info)) + unmarshal_info = phase; + else + unmarshal_info = scheme_make_pair(phase, unmarshal_info); + + return unmarshal_info; +} + +XFORM_NONGCING static Scheme_Object *extract_unmarshal_phase(Scheme_Object *unmarshal_info) +{ + if (SCHEME_PAIRP(unmarshal_info)) + return SCHEME_CAR(unmarshal_info); + else + return unmarshal_info; +} + +XFORM_NONGCING static Scheme_Object *extract_unmarshal_prefix(Scheme_Object *unmarshal_info) +{ + if (SCHEME_PAIRP(unmarshal_info)) { + unmarshal_info = SCHEME_CDR(unmarshal_info); + if (SCHEME_PAIRP(unmarshal_info)) + unmarshal_info = SCHEME_CDR(unmarshal_info); + + if (SCHEME_SYMBOLP(unmarshal_info)) + return unmarshal_info; + else + return scheme_false; + } else + return scheme_false; +} + +static Scheme_Hash_Tree *unmarshal_vector_to_excepts(Scheme_Object *unmarshal_info, + Scheme_Object *ht_target, + int ht_to_cdr) +{ + Scheme_Hash_Tree *ht = empty_hash_tree; + intptr_t i; + + for (i = SCHEME_VEC_SIZE(unmarshal_info); i--; ) { + if (SCHEME_SYMBOLP(SCHEME_VEC_ELS(unmarshal_info)[i])) + ht = scheme_hash_tree_set(ht, SCHEME_VEC_ELS(unmarshal_info)[i], scheme_true); + } + + if (ht_to_cdr) + SCHEME_CDR(ht_target) = (Scheme_Object *)ht; + else + SCHEME_CAR(ht_target) = (Scheme_Object *)ht; + + return ht; +} + +static Scheme_Hash_Tree *extract_unmarshal_excepts(Scheme_Object *unmarshal_info) +{ + if (SCHEME_PAIRP(unmarshal_info)) { + Scheme_Object *ht_target = unmarshal_info; + int ht_to_cdr = 1; + + unmarshal_info = SCHEME_CDR(unmarshal_info); + if (SCHEME_PAIRP(unmarshal_info)) { + ht_target = unmarshal_info; + ht_to_cdr = 0; + unmarshal_info = SCHEME_CAR(unmarshal_info); + } + + if (SCHEME_HASHTRP(unmarshal_info)) + return (Scheme_Hash_Tree *)unmarshal_info; + else if (SCHEME_VECTORP(unmarshal_info)) { + /* Hash table was converted to a vector in a marshaled unmarshal request */ + return unmarshal_vector_to_excepts(unmarshal_info, ht_target, ht_to_cdr); + } else + return NULL; + } else return NULL; } -static int nonempty_rib(Scheme_Lexical_Rib *rib) +static Scheme_Object *unmarshal_excepts_to_vector(Scheme_Object *unmarshal_info) { - rib = rib->next; - - while (rib) { - if (SCHEME_RENAME_LEN(rib->rename)) - return 1; - rib = rib->next; - } - - return 0; -} - -static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) -{ - if (!skip_ribs) - return 0; + Scheme_Hash_Tree *ht; - if (scheme_hash_tree_get((Scheme_Hash_Tree *)skip_ribs, timestamp)) - return 1; - - return 0; -} + ht = extract_unmarshal_excepts(unmarshal_info); + if (ht) { + intptr_t i = -1, j = 0; + Scheme_Object *vec, *key, *val; -static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) -{ - if (in_skip_set(timestamp, skip_ribs)) - return skip_ribs; - - if (!skip_ribs) - skip_ribs = (Scheme_Object *)scheme_make_hash_tree(1); - - skip_ribs = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)skip_ribs, timestamp, scheme_true); + vec = scheme_make_vector(ht->count, NULL); - { - Scheme_Bucket *b; - scheme_start_atomic(); - b = scheme_bucket_from_table(interned_skip_ribs, (const char *)skip_ribs); - scheme_end_atomic_no_swap(); - if (!b->val) - b->val = scheme_true; - - skip_ribs = (Scheme_Object *)HT_EXTRACT_WEAK(b->key); - } - - return skip_ribs; -} - -XFORM_NONGCING static int same_skipped_ribs(Scheme_Object *a, Scheme_Object *b) -{ - return SAME_OBJ(a, b); -} - -XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, Scheme_Object *skip_ribs) -{ - Scheme_Object *p; - - if (SCHEME_PAIRP(other_env)) { - /* paired with free-id=? rename */ - other_env = SCHEME_CAR(other_env); - } - - if (SCHEME_MPAIRP(other_env)) { - other_env = SCHEME_CAR(other_env); - if (!other_env) - return scheme_void; - } - - if (SCHEME_RPAIRP(other_env)) { - while (other_env) { - p = SCHEME_CAR(other_env); - if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) { - return SCHEME_CDR(p); - } - other_env = SCHEME_CDR(other_env); - } - return scheme_void; - } else if (!skip_ribs) - return other_env; - else - return scheme_void; -} - -static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *other_env, Scheme_Object *skip_ribs, - int depends_on_unsealed_rib) -{ - Scheme_Object *in_mpair = NULL; - Scheme_Object *free_id_rename = NULL; - - if (SCHEME_PAIRP(orig)) { - free_id_rename = SCHEME_CDR(orig); - orig = SCHEME_CAR(orig); - } - - if (SCHEME_MPAIRP(orig)) { - in_mpair = orig; - orig = SCHEME_CAR(orig); - if (!depends_on_unsealed_rib && !orig) { - /* no longer depends on unsealed rib: */ - in_mpair = NULL; - orig = scheme_void; - } else { - /* (some) still depends on unsealed rib: */ - if (!orig) { - /* re-register in list of dependencies */ - SCHEME_CDR(in_mpair) = unsealed_dependencies; - unsealed_dependencies = in_mpair; - orig = scheme_void; - } - } - } else if (depends_on_unsealed_rib) { - /* register dependency: */ - in_mpair = scheme_make_mutable_pair(NULL, unsealed_dependencies); - unsealed_dependencies = in_mpair; - } - - if (SCHEME_VOIDP(orig) && !skip_ribs) { - orig = other_env; - } else { - if (!SCHEME_RPAIRP(orig)) - orig = scheme_make_raw_pair(scheme_make_raw_pair(NULL, orig), NULL); - - orig = scheme_make_raw_pair(scheme_make_raw_pair(skip_ribs, other_env), orig); - } - - if (in_mpair) { - SCHEME_CAR(in_mpair) = orig; - orig = in_mpair; - } - - if (free_id_rename) { - orig = CONS(orig, free_id_rename); - } - - return orig; -} - -static void extract_lex_range(Scheme_Object *rename, Scheme_Object *a, int *_istart, int *_iend) -{ - int istart, iend, c; - - c = SCHEME_RENAME_LEN(rename); - - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { - void *pos; - pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), a); - if (pos) { - istart = SCHEME_INT_VAL(pos); - if (istart < 0) { - /* -1 indicates multiple slots matching this name. */ - istart = 0; - iend = c; - } else - iend = istart + 1; - } else { - istart = 0; - iend = 0; - } - } else { - istart = 0; - iend = c; - } - - *_istart = istart; - *_iend = iend; -} - -/* This needs to be a multiple of 4: */ -#define QUICK_STACK_SIZE 16 - -/* Although resolve_env may call itself recursively, the recursion - depth is bounded (by the fact that modules can't be nested, - etc.). */ - -static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, - int w_mod, Scheme_Object **get_names, - Scheme_Object *skip_ribs, int *_binding_marks_skipped, - int *_depends_on_unsealed_rib, int depth, - Scheme_Hash_Table *free_id_recur) -/* Module binding ignored if w_mod is 0. - If module bound, result is module idx, and get_names[0] is set to source name, - get_names[1] is set to the nominal source module, get_names[2] is set to - the nominal source module's export, get_names[3] is set to the phase of - the source definition, and get_names[4] is set to the nominal import phase index, - and get_names[5] is set to the nominal export phase; get_names[6] is set to - an access-granting inspector, NULL, or #f. - If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined; - get_names[1] is set if a free-id=? rename provides a different name for the bindig. - If neither, result is #f and get_names[0] is either unchanged or NULL; get_names[1] - is set if a free-id=? rename provides a different name. */ -{ - WRAP_POS wraps; - Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; - Scheme_Object *mresult = scheme_false, *mresult_insp = NULL; - Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; - Scheme_Object *rename_stack[QUICK_STACK_SIZE], *rib_delim = scheme_false; - int stack_pos = 0, no_lexical = 0; - int is_in_module = 0, skip_other_mods = 0; - Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL; - Scheme_Object *phase = orig_phase; - Scheme_Object *bdg = NULL; - Scheme_Hash_Table *export_registry = NULL; - int mresult_skipped = -1; - int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0; - -#ifdef EXPLAIN_FOR_ID - if (!strcmp(EXPLAIN_FOR_ID, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))) - scheme_explain_resolves++; -#endif - - EXPLAIN(fprintf(stderr, "%d Resolving %s@%d [skips: %s]: -------------\n", - depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), SCHEME_INT_VAL(orig_phase), - scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); - WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); - - while (1) { - if (WRAP_POS_END_P(wraps)) { - /* See rename case for info on rename_stack: */ - Scheme_Object *result, *result_free_rename, *key, *rd; - int did_lexical = 0; - - EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); - - result = scheme_false; - result_free_rename = scheme_false; - rib_delim = scheme_null; - while (!SCHEME_NULLP(o_rename_stack)) { - key = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[0]; - if (SAME_OBJ(key, result)) { - EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); - did_lexical = 1; - rd = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[3]; - if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) { - /* not a match, due to rib delimiter */ - } else { - result = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[1]; - result_free_rename = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[2]; - rib_delim = rd; - } - } else { - EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); - if (SAME_OBJ(key, scheme_true)) { - /* marks a module-level renaming that overrides lexical renaming */ - did_lexical = 0; - } - } - o_rename_stack = SCHEME_CDR(o_rename_stack); - } - while (stack_pos) { - key = rename_stack[stack_pos - 1]; - if (SAME_OBJ(key, result)) { - EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); - rd = rename_stack[stack_pos - 4]; - if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) { - /* not a match, due to rib delimiter */ - } else { - result = rename_stack[stack_pos - 2]; - result_free_rename = rename_stack[stack_pos - 3]; - rib_delim = rd; - did_lexical = 1; - } - } else { - EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); - if (SAME_OBJ(key, scheme_true)) { - /* marks a module-level renaming that overrides lexical renaming */ - did_lexical = 0; - } - } - stack_pos -= 4; - } - if (!did_lexical) { - result = mresult; - if (_binding_marks_skipped) - *_binding_marks_skipped = mresult_skipped; - if (mresult_depends_unsealed) - depends_on_unsealed_rib = 1; - } else { - if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) { - Scheme_Object *orig; - int rib_dep = 0; - orig = result_free_rename; - result_free_rename = SCHEME_VEC_ELS(orig)[0]; - if (SCHEME_PAIRP(result_free_rename) && SCHEME_STXP(SCHEME_CAR(result_free_rename))) { - phase = SCHEME_CDR(result_free_rename); - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(orig)[1])) - phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]); - if (get_names) - get_names[1] = NULL; - result = SCHEME_CAR(result_free_rename); - if (!scheme_hash_get(free_id_recur, result)) { - scheme_hash_set(free_id_recur, result, scheme_true); - result = resolve_env(result, phase, - w_mod, get_names, - NULL, _binding_marks_skipped, - &rib_dep, depth + 1, free_id_recur); - } - if (get_names && !get_names[1]) - if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0])) - get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename)); - } else if (SCHEME_PAIRP(result_free_rename) && SCHEME_SYMBOLP(SCHEME_CDR(result_free_rename))) { - if (get_names) - get_names[1] = SCHEME_CAR(result_free_rename); - result = SCHEME_CDR(result_free_rename); - if (get_names) - get_names[0] = scheme_undefined; - } else if (SAME_OBJ(SCHEME_TYPE(result_free_rename), scheme_free_id_info_type)) { - result = SCHEME_VEC_ELS(result_free_rename)[0]; - if (get_names) { - get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1]; - get_names[1] = SCHEME_VEC_ELS(result_free_rename)[2]; - get_names[2] = SCHEME_VEC_ELS(result_free_rename)[3]; - get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4]; - get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5]; - get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6]; - get_names[6] = SCHEME_VEC_ELS(result_free_rename)[7]; - if (SCHEME_FALSEP(get_names[6])) - get_names[6] = mresult_insp; - } - } else { - if (get_names) - get_names[1] = SCHEME_CAR(result_free_rename); - result = scheme_false; - } - if (rib_dep) - depends_on_unsealed_rib = 1; - if (SAME_TYPE(SCHEME_TYPE(result), scheme_module_index_type)) - result = scheme_modidx_shift(result, SCHEME_VEC_ELS(orig)[2], SCHEME_VEC_ELS(orig)[3]); - } else { - if (get_names) { - get_names[0] = scheme_undefined; - get_names[1] = NULL; - } - } - } - - if (_depends_on_unsealed_rib) - *_depends_on_unsealed_rib = depends_on_unsealed_rib; - - if (SCHEME_MODIDXP(result)) { - EXPLAIN(fprintf(stderr, "%d Result: <%s,%s>\n", depth, - scheme_write_to_string(((Scheme_Modidx *)result)->path, NULL), - scheme_write_to_string(((Scheme_Modidx *)result)->base, NULL))); - } else { - EXPLAIN(fprintf(stderr, "%d Result: %s %p\n", depth, scheme_write_to_string(result, NULL), result)); - } - if (get_names) { - EXPLAIN(fprintf(stderr, "%d phase %s\n", depth, scheme_write_to_string(get_names[3], NULL))); - } - -#ifdef EXPLAIN_FOR_ID - if (!strcmp(EXPLAIN_FOR_ID, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))) - --scheme_explain_resolves; -#endif - - return result; - } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) - || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps))) - && w_mod) { - /* Module rename: */ - Module_Renames *mrn; - int skipped; - - if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) { - mrn = (Module_Renames *)WRAP_POS_FIRST(wraps); - } else { - /* Extract the relevant phase, if available */ - Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps); - - if (mrns->kind != mzMOD_RENAME_TOPLEVEL) - is_in_module = 1; - - mrn = extract_renames(mrns, phase); - } - - EXPLAIN(fprintf(stderr, "%d Rename/set %d %d\n", depth, - mrn ? SCHEME_INT_VAL(mrn->set_identity) : -1, - mrn ? mrn->kind : -1)); - - if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) - && !skip_other_mods) { - if (mrn->kind != mzMOD_RENAME_TOPLEVEL) - is_in_module = 1; - - if (same_phase(phase, mrn->phase)) { - Scheme_Object *rename, *nominal = NULL, *glob_id; - int get_names_done; - - EXPLAIN(fprintf(stderr, "%d use rename %p %d\n", depth, mrn->phase, mrn->kind)); - - if (mrn->needs_unmarshal) { - EXPLAIN(fprintf(stderr, "%d {unmarshal}\n", depth)); - unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry); - } - - if (mrn->marked_names && mrn->marked_names->count) { - /* Resolve based on binding ignoring modules: */ - EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); - if (!bdg) { - EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); - bdg = resolve_env(a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL); - if (SCHEME_FALSEP(bdg)) - bdg = get_old_module_env(a); - EXPLAIN(fprintf(stderr, "%d is %s\n", depth, - scheme_write_to_string(bdg, NULL))); - } - /* Remap id based on marks and rest-of-wraps resolution: */ - glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, &skipped); - EXPLAIN(fprintf(stderr, "%d is sym %s\n", depth, - scheme_write_to_string(glob_id, NULL))); - - if (SCHEME_TRUEP(bdg) - && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { - /* Even if this module doesn't match, the lex-renamed id - has been top-level bound in its scope, so ignore all - lexical renamings. (If the id was further renamed, then - the further renaming would show up in bdg, and bdg wouldn't - have matched in marked_names.) */ - no_lexical = 1; - stack_pos = 0; - o_rename_stack = scheme_null; - } - } else { - skipped = -1; - glob_id = SCHEME_STX_VAL(a); - } - - EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); - - if (free_id_recur && mrn->free_id_renames) { - rename = scheme_hash_get(mrn->free_id_renames, glob_id); - if (rename && SCHEME_STXP(rename)) { - int sealed; - rename = extract_module_free_id_binding((Scheme_Object *)mrn, - glob_id, - rename, - &sealed, - free_id_recur); - if (!sealed) - mresult_depends_unsealed = 1; - } - } else - rename = NULL; - if (!rename) - rename = scheme_hash_get(mrn->ht, glob_id); - if (!rename && mrn->nomarshal_ht) - rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); - get_names_done = 0; - if (!rename) { - EXPLAIN(fprintf(stderr, "%d in pes\n", depth)); - if (!bdg) { - EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); - bdg = resolve_env(a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL); - if (SCHEME_FALSEP(bdg)) - bdg = get_old_module_env(a); - EXPLAIN(fprintf(stderr, "%d is %s\n", depth, - scheme_write_to_string(bdg, NULL))); - } - rename = search_shared_pes(mrn->shared_pes, glob_id, a, bdg, get_names, 0, depth, &skipped); - if (rename) - get_names_done = 1; - } - - EXPLAIN(fprintf(stderr, "%d search result: %p\n", depth, rename)); - - if (rename) { - if ((mrn->sealed < STX_SEAL_BOUND) && is_in_module) - mresult_depends_unsealed = 1; - - if (mrn->kind == mzMOD_RENAME_MARKED) { - /* One job of a mzMOD_RENAME_MARKED renamer is to replace any - binding that might have come from the identifier in its source - module, instead of the module where it was eventually bound - (after being introduced by a macro in the source module). */ - skip_other_mods = 1; - } - - /* match; set mresult, which is used in the case of no lexical capture: */ - mresult_skipped = skipped; - - if (SCHEME_BOXP(rename)) { - /* This should only happen for mappings from free_id_renames */ - mresult = SCHEME_BOX_VAL(rename); - if (get_names) { - if (SCHEME_FALSEP(SCHEME_CDR(mresult))) - get_names[0] = NULL; - else - get_names[0] = scheme_undefined; - get_names[1] = SCHEME_CAR(mresult); - } - mresult = SCHEME_CDR(mresult); - } else { - if (SCHEME_PAIRP(rename)) { - mresult = SCHEME_CAR(rename); - } else - mresult = rename; - - if (modidx_shift_from) { - EXPLAIN(fprintf(stderr, "%d shift %p->%p: %p\n", - depth, modidx_shift_from, modidx_shift_to, - mresult)); - mresult = scheme_modidx_shift(mresult, - modidx_shift_from, - modidx_shift_to); - EXPLAIN(fprintf(stderr, "%d = %p\n", depth, mresult)); - } - - if (get_names) { - int no_shift = 0; - - if (!get_names_done) { - if (SCHEME_PAIRP(rename)) { - if (nom_mod_p(rename)) { - /* (cons modidx nominal_modidx) case */ - get_names[0] = glob_id; - get_names[1] = SCHEME_CDR(rename); - get_names[2] = get_names[0]; - } else { - rename = SCHEME_CDR(rename); - if (SCHEME_PAIRP(rename)) { - /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ - if (SCHEME_INTP(SCHEME_CAR(rename)) - || SCHEME_FALSEP(SCHEME_CAR(rename))) { - get_names[3] = SCHEME_CAR(rename); - rename = SCHEME_CDR(rename); - } - get_names[0] = SCHEME_CAR(rename); - get_names[1] = SCHEME_CADR(rename); - if (SCHEME_PAIRP(get_names[1])) { - get_names[4] = SCHEME_CDR(get_names[1]); - get_names[1] = SCHEME_CAR(get_names[1]); - if (SCHEME_PAIRP(get_names[4])) { - get_names[5] = SCHEME_CDR(get_names[4]); - get_names[4] = SCHEME_CAR(get_names[4]); - } else { - get_names[5] = get_names[3]; - } - } - get_names[2] = SCHEME_CDDR(rename); - } else { - /* (cons modidx exportname) case */ - get_names[0] = rename; - get_names[2] = NULL; /* finish below */ - } - } - } else { - get_names[0] = glob_id; - get_names[2] = NULL; /* finish below */ - } - - if (!get_names[2]) { - get_names[2] = get_names[0]; - if (nominal) - get_names[1] = nominal; - else { - no_shift = 1; - get_names[1] = mresult; - } - } - if (!get_names[4]) { - GC_CAN_IGNORE Scheme_Object *pi; - pi = phase_to_index(mrn->phase); - get_names[4] = pi; - } - if (!get_names[5]) { - get_names[5] = get_names[3]; - } - } - - if (modidx_shift_from && !no_shift) { - Scheme_Object *nom; - nom = get_names[1]; - nom = scheme_modidx_shift(nom, - modidx_shift_from, - modidx_shift_to); - get_names[1] = nom; - } - } - } - - if (get_names) - get_names[6] = (mrn->insp ? mrn->insp : mresult_insp); - EXPLAIN(fprintf(stderr, "%d mresult_insp %p %p\n", depth, mresult_insp, mrn->insp)); - } else { - if ((mrn->sealed < STX_SEAL_ALL) && is_in_module) - mresult_depends_unsealed = 1; - mresult = scheme_false; - mresult_skipped = -1; - if (get_names) - get_names[0] = NULL; - } - } - } - } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps)) && w_mod) { - /* Phase shift */ - Scheme_Object *vec, *n, *dest, *src, *insp; - - vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); - n = SCHEME_VEC_ELS(vec)[0]; - - EXPLAIN(fprintf(stderr, "%d phase shift by %d\n", depth, SCHEME_INT_VAL(n))); - - phase = reverse_phase_shift(phase, n); - - src = SCHEME_VEC_ELS(vec)[1]; - dest = SCHEME_VEC_ELS(vec)[2]; - insp = SCHEME_VEC_ELS(vec)[4]; - - EXPLAIN(fprintf(stderr, "%d insp %p\n", depth, (SCHEME_FALSEP(insp) ? NULL : insp))); - - /* If src is #f, shift is just for phase; no redirection */ - - if (!SCHEME_FALSEP(src)) { - if (!modidx_shift_to) { - EXPLAIN(fprintf(stderr, "%d shift to %p\n", depth, dest)); - modidx_shift_to = dest; - } else if (!SAME_OBJ(modidx_shift_from, dest)) { - modidx_shift_to = scheme_modidx_shift(dest, - modidx_shift_from, - modidx_shift_to); - EXPLAIN(fprintf(stderr, "%d shift %p->%p; %d\n", - depth, modidx_shift_from, - modidx_shift_to, SAME_OBJ(dest, modidx_shift_to))); - } - modidx_shift_from = src; - } - - { - Scheme_Object *er; - er = SCHEME_VEC_ELS(vec)[3]; - if (SCHEME_TRUEP(er)) - export_registry = (Scheme_Hash_Table *)er; - } - - if (SCHEME_TRUEP(insp)) - mresult_insp = insp; - } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) - && !no_lexical)) { - /* Lexical rename: */ - Scheme_Object *rename, *renamed; - int ri, c, istart, iend; - Scheme_Lexical_Rib *is_rib; - - if (rib) { - rename = rib->rename; - is_rib = rib; - rib = rib->next; - } else { - rename = WRAP_POS_FIRST(wraps); - is_rib = NULL; - did_rib = NULL; - } - - EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0, - SCHEME_VEC_SIZE(rename), - SCHEME_SYMBOLP(SCHEME_VEC_ELS(rename)[0]) ? SCHEME_SYM_VAL(SCHEME_VEC_ELS(rename)[0]) : "", - SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash")); - - c = SCHEME_RENAME_LEN(rename); - - /* Get index from hash table, if there is one: */ - extract_lex_range(rename, SCHEME_STX_VAL(a), &istart, &iend); - - for (ri = istart; ri < iend; ri++) { - renamed = SCHEME_VEC_ELS(rename)[2+ri]; - EXPLAIN(fprintf(stderr, " ? %s @ %p\n", SCHEME_SYM_VAL(SCHEME_STX_SYM(renamed)), rename)); - if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) { - int same; - - { - Scheme_Object *other_env, *envname, *free_id_rename; - - if (SCHEME_SYMBOLP(renamed)) { - /* Simplified table */ - other_env = scheme_false; - envname = SCHEME_VEC_ELS(rename)[2+c+ri]; - if (SCHEME_PAIRP(envname)) { - free_id_rename = SCHEME_CDR(envname); - envname = SCHEME_CAR(envname); - } else - free_id_rename = scheme_void; - same = 1; - no_lexical = 1; /* simplified table always has final result */ - EXPLAIN(fprintf(stderr, "%d Target %s <- %s %p\n", depth, - scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0), - free_id_rename)); - } else { - envname = SCHEME_VEC_ELS(rename)[0]; - other_env = SCHEME_VEC_ELS(rename)[2+c+ri]; - if (SCHEME_PAIRP(other_env)) - free_id_rename = SCHEME_CDR(other_env); - else - free_id_rename = scheme_void; - other_env = filter_cached_env(other_env, recur_skip_ribs); - - if (SCHEME_VOIDP(other_env)) { - int rib_dep = 0; - SCHEME_USE_FUEL(1); - other_env = resolve_env(renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL); - { - Scheme_Object *e; - e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, - (is_rib && !(*is_rib->sealed)) || rib_dep); - SCHEME_VEC_ELS(rename)[2+c+ri] = e; - } - if (rib_dep) - depends_on_unsealed_rib = 1; - SCHEME_USE_FUEL(1); - } - - EXPLAIN(fprintf(stderr, "%d Target %s <- %s (%d)\n", depth, - scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0), - nom_mod_p(rename))); - - { - WRAP_POS w2; - WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps); - same = same_marks(&w2, &wraps, other_env); - if (!same) { - EXPLAIN(fprintf(stderr, "%d Different marks\n", depth)); - } - } - } - - if (same) { - /* If it turns out that we're going to return - other_env, then return envname instead. - It's tempting to try to compare envname to the - top element of the stack and combine the two - mappings, but the intermediate name may be needed - (for other_env values that don't come from this stack). */ - if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) { - /* Need to remember phase and shifts for free-id=? rename: */ - Scheme_Object *vec; - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = free_id_rename; - SCHEME_VEC_ELS(vec)[1] = phase; - SCHEME_VEC_ELS(vec)[2] = modidx_shift_from; - SCHEME_VEC_ELS(vec)[3] = modidx_shift_to; - free_id_rename = vec; - } - if (stack_pos < QUICK_STACK_SIZE) { - rename_stack[stack_pos++] = rib_delim; - rename_stack[stack_pos++] = free_id_rename; - rename_stack[stack_pos++] = envname; - rename_stack[stack_pos++] = other_env; - } else { - Scheme_Object *vec; - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = other_env; - SCHEME_VEC_ELS(vec)[1] = envname; - SCHEME_VEC_ELS(vec)[2] = free_id_rename; - SCHEME_VEC_ELS(vec)[3] = rib_delim; - o_rename_stack = CONS(vec, o_rename_stack); - } - if (is_rib) { - /* skip future instances of the same rib; - used to skip the rest of the current rib, too, but - that's wrong in the case that the same symbolic - name with multiple binding contexts is re-bound - in a rib */ - skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs); - } - } - - break; - } - } - } - } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) { - /* Lexical-rename rib. Splice in the names. */ - rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); - EXPLAIN(fprintf(stderr, "%d Rib: %p...\n", depth, rib)); - if (skip_ribs) { - if (in_skip_set(rib->timestamp, skip_ribs)) { - EXPLAIN(fprintf(stderr, "%d Skip rib\n", depth)); - rib = NULL; - } - } - if (rib) { - if (!*rib->sealed) - depends_on_unsealed_rib = 1; - if (nonempty_rib(rib)) { - if (SAME_OBJ(did_rib, rib)) { - EXPLAIN(fprintf(stderr, "%d Did rib\n", depth)); - rib = NULL; - } else { - recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs); - did_rib = rib; - if (rib->mapped_names - && !SCHEME_INTP(rib->mapped_names) - && !scheme_hash_get((Scheme_Hash_Table *)rib->mapped_names, SCHEME_STX_VAL(a))) - rib = NULL; /* no need to check individual renames */ - else - rib = rib->next; /* First rib record has no rename */ - } - } else - rib = NULL; - } - } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(wraps))) { - rib_delim = WRAP_POS_FIRST(wraps); - if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) - rib_delim = scheme_false; - did_rib = NULL; - } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { - EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps))); - did_rib = NULL; - } else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) { - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps); - - EXPLAIN(fprintf(stderr, "%d forwarding table...\n", depth)); - - did_rib = NULL; - - if (!ht->count - /* Table isn't finished if 5 is mapped to a limit: */ - || scheme_hash_get(ht, scheme_make_integer(5))) { - fill_chain_cache(wraps.l); - } - - if (!scheme_hash_get(ht, SCHEME_STX_VAL(a))) { - EXPLAIN(fprintf(stderr, "%d forwarded\n", depth)); - set_wraps_to_skip(ht, &wraps); - - continue; /* <<<<< ------ */ - } - } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) { - if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) { - /* Doesn't match pruned-to sym; already produce #f */ - if (_depends_on_unsealed_rib) - *_depends_on_unsealed_rib = depends_on_unsealed_rib; -#ifdef EXPLAIN_FOR_ID - if (!strcmp(EXPLAIN_FOR_ID, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))) - --scheme_explain_resolves; -#endif - return scheme_false; - } + while ((i = scheme_hash_tree_next(ht, i)) != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + SCHEME_VEC_ELS(vec)[j++] = key; } - if (!rib) - WRAP_POS_INC(wraps); + sort_vector_symbols(vec); + + return make_unmarshal_info(extract_unmarshal_phase(unmarshal_info), + extract_unmarshal_prefix(unmarshal_info), + vec); } + + return unmarshal_info; } -static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, - Scheme_Hash_Table *free_id_recur) - /* Gets a module source name under the assumption that the identifier - is not lexically renamed. This is used as a quick pre-test for - free-identifier=?. We do have to look at lexical renames to check for - equivalences installed on detection of make-rename-transformer, but at least - we can normally cache the result. */ +static Scheme_Object *unmarshal_lookup_adjust(Scheme_Object *sym, Scheme_Object *pes) { - WRAP_POS wraps; - Scheme_Object *result; - int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL; - int no_lexical = !free_id_recur; - Scheme_Object *phase = orig_phase; - Scheme_Object *bdg = NULL; + Scheme_Hash_Tree *excepts; + Scheme_Object *prefix; - result = ((Scheme_Stx *)a)->u.modinfo_cache; - if (result && SAME_OBJ(phase, scheme_make_integer(0))) { - return result; - } - - WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); - - result = NULL; - - while (1) { - if (WRAP_POS_END_P(wraps)) { - int can_cache = (sealed >= STX_SEAL_ALL); - - if (result) - can_cache = (sealed >= STX_SEAL_BOUND); /* If it becomes bound, it can't become unbound. */ - - if (free_id_recur && free_id_recur->count) - can_cache = 0; - - if (!result) - result = SCHEME_STX_VAL(a); - -#if 0 - printf("%p %p %s (%d) %d %p\n", - a, orig_phase, SCHEME_SYMBOLP(result) ? SCHEME_SYM_VAL(result) : "!?", - can_cache, sealed, free_id_recur); -#endif - - if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0))) - ((Scheme_Stx *)a)->u.modinfo_cache = result; + excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); + prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); - return result; - } else if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) - || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps))) { - Module_Renames *mrn; - - if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) { - mrn = (Module_Renames *)WRAP_POS_FIRST(wraps); - } else { - /* Extract the relevant phase, if available */ - Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps); - - if (mrns->kind != mzMOD_RENAME_TOPLEVEL) - is_in_module = 1; - - if ((!is_in_module || (mrns->kind != mzMOD_RENAME_TOPLEVEL)) - && !skip_other_mods) { - if (mrns->sealed < sealed) - sealed = mrns->sealed; - } - - mrn = extract_renames(mrns, phase); - } - - if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) - && !skip_other_mods) { - if (mrn->kind != mzMOD_RENAME_TOPLEVEL) - is_in_module = 1; - - if (same_phase(phase, mrn->phase)) { - /* Module rename: */ - Scheme_Object *rename, *glob_id; - - if (mrn->sealed < sealed) - sealed = mrn->sealed; - - if (mrn->needs_unmarshal) { - /* Use resolve_env to trigger unmarshal, so that we - don't have to implement top/from shifts here: */ - resolve_env(a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, NULL); - } - - if (mrn->marked_names && mrn->marked_names->count) { - /* Resolve based on binding ignoring modules: */ - if (!bdg) { - bdg = resolve_env(a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL); - if (SCHEME_FALSEP(bdg)) - bdg = get_old_module_env(a); - } - /* Remap id based on marks and rest-of-wraps resolution: */ - glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL); - - if (SCHEME_TRUEP(bdg) - && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { - /* See "Even if this module doesn't match, the lex-renamed id" in resolve_env() */ - no_lexical = 1; - } - } else - glob_id = SCHEME_STX_VAL(a); - - if (free_id_recur && mrn->free_id_renames) { - rename = scheme_hash_get(mrn->free_id_renames, glob_id); - if (rename && SCHEME_STXP(rename)) { - int sd; - rename = extract_module_free_id_binding((Scheme_Object *)mrn, - glob_id, - rename, - &sd, - free_id_recur); - if (!sd) - sealed = 0; - } - } else - rename = NULL; - if (!rename) - rename = scheme_hash_get(mrn->ht, glob_id); - if (!rename && mrn->nomarshal_ht) - rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); - - if (!rename) { - if (!bdg) { - bdg = resolve_env(a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL); - if (SCHEME_FALSEP(bdg)) - bdg = get_old_module_env(a); - } - rename = search_shared_pes(mrn->shared_pes, glob_id, a, bdg, NULL, 1, 0, NULL); - if (rename) { - if (mrn->kind == mzMOD_RENAME_MARKED) - skip_other_mods = 1; - result = rename; - } - } else { - /* match; set result: */ - if (mrn->kind == mzMOD_RENAME_MARKED) - skip_other_mods = 1; - if (SCHEME_BOXP(rename)) { - /* only happens with free_id_renames */ - rename = SCHEME_BOX_VAL(rename); - if (no_lexical || SCHEME_TRUEP(SCHEME_CDR(rename))) - result = SCHEME_CAR(rename); - else - rename = NULL; - } else if (SCHEME_PAIRP(rename)) { - if (nom_mod_p(rename)) { - result = glob_id; - } else { - result = SCHEME_CDR(rename); - if (SCHEME_PAIRP(result)) { - if (SCHEME_INTP(SCHEME_CAR(result))) /* phase? */ - result = SCHEME_CDR(result); - result = SCHEME_CAR(result); - } - } - } else - result = glob_id; - } - } - } - } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps))) { - /* Phase shift */ - Scheme_Object *n, *vec; - vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); - n = SCHEME_VEC_ELS(vec)[0]; - phase = reverse_phase_shift(phase, n); - } else if (!no_lexical - && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) - || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) { - /* Lexical rename */ - Scheme_Object *rename, *renamed, *renames; - Scheme_Lexical_Rib *rib; - int ri, istart, iend; - - rename = WRAP_POS_FIRST(wraps); - if (SCHEME_RIBP(rename)) { - rib = (Scheme_Lexical_Rib *)rename; - if (rib->mapped_names - && !SCHEME_INTP(rib->mapped_names) - && !scheme_hash_get((Scheme_Hash_Table *)rib->mapped_names, SCHEME_STX_VAL(a))) - rib = NULL; /* no need to check individual renames */ + if (SCHEME_TRUEP(prefix) && !SCHEME_SYM_WEIRDP(sym)) { + int plen = SCHEME_SYM_LEN(prefix); + if (SCHEME_SYM_LEN(sym) >= plen) { + if (!scheme_strncmp(SCHEME_SYM_VAL(sym), SCHEME_SYM_VAL(prefix), plen)) { + char buf[64], *b; + int slen = SCHEME_SYM_LEN(sym) - plen; + if (slen < 64) + b = buf; else - rib = rib->next; - rename = NULL; - } else { - rib = NULL; - if (SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[0])) { - /* No free-id=? renames here. */ - rename = NULL; - } - } - - do { - if (rib) { - if (!*rib->sealed) sealed = 0; - rename = rib->rename; - rib = rib->next; - } - - if (rename) { - int c = SCHEME_RENAME_LEN(rename); - - /* Get index from hash table, if there is one: */ - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { - void *pos; - pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), SCHEME_STX_VAL(a)); - if (pos) { - istart = SCHEME_INT_VAL(pos); - if (istart < 0) { - /* -1 indicates multiple slots matching this name. */ - istart = 0; - iend = c; - } else - iend = istart + 1; - } else { - istart = 0; - iend = 0; - } - } else { - istart = 0; - iend = c; - } - - for (ri = istart; ri < iend; ri++) { - renamed = SCHEME_VEC_ELS(rename)[2+ri]; - if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) { - /* Check for free-id mapping: */ - renames = SCHEME_VEC_ELS(rename)[2 + ri + c]; - if (SCHEME_PAIRP(renames)) { - /* Has a relevant-looking free-id mapping. - Give up on the "fast" traversal. */ - Scheme_Object *modname, *names[7]; - int rib_dep = 0; - - names[0] = NULL; - names[1] = NULL; - names[3] = scheme_make_integer(0); - names[4] = NULL; - names[5] = NULL; - names[6] = NULL; - - modname = resolve_env(a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur); - if (rib_dep) - sealed = 0; - - if (!SCHEME_FALSEP(modname) - && !SAME_OBJ(names[0], scheme_undefined)) { - result = names[0]; - } else { - result = names[1]; /* can be NULL or alternate name */ - } - - WRAP_POS_INIT_END(wraps); - rib = NULL; - break; - } - } - } - } - } while (rib); - } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) { - if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) { - /* Doesn't match pruned-to sym, so no binding */ - return SCHEME_STX_VAL(a); - } - } - - /* Keep looking: */ - if (!WRAP_POS_END_P(wraps)) - WRAP_POS_INC(wraps); + b = scheme_malloc_atomic(slen+1); + memcpy(b, SCHEME_SYM_VAL(sym) + plen, slen+1); + sym = scheme_intern_exact_symbol(b, slen); + } else + return scheme_false; /* so lookup will fail */ + } else + return scheme_false; } + + if (excepts) { + if (scheme_eq_hash_tree_get(excepts, sym)) + return scheme_false; /* so lookup will fail */ + } + + return sym; } -int scheme_stx_module_eq3(Scheme_Object *a, Scheme_Object *b, - Scheme_Object *a_phase, Scheme_Object *b_phase, - Scheme_Object *asym) +static Scheme_Object *unmarshal_key_adjust(Scheme_Object *sym, Scheme_Object *pes) { - Scheme_Object *bsym; - Scheme_Hash_Table *free_id_recur; - int must_be_lex; + Scheme_Hash_Tree *excepts; + Scheme_Object *prefix; + + excepts = extract_unmarshal_excepts(SCHEME_VEC_ELS(pes)[3]); + prefix = extract_unmarshal_prefix(SCHEME_VEC_ELS(pes)[3]); - if (!a || !b) - return (a == b); + if (excepts && scheme_eq_hash_tree_get(excepts, sym)) + return NULL; - if (SCHEME_STXP(b)) { - if (!asym) - free_id_recur = make_recur_table(); + if (SCHEME_TRUEP(prefix)) { + int plen = SCHEME_SYM_LEN(prefix); + int slen = SCHEME_SYM_LEN(sym) + plen; + char buf[64], *b; + + if (slen < 64) + b = buf; else - free_id_recur = NULL; - bsym = get_module_src_name(b, b_phase, free_id_recur); - if (!asym) - release_recur_table(free_id_recur); - } else - bsym = b; - if (!asym) { - if (SCHEME_STXP(a)) { - free_id_recur = make_recur_table(); - asym = get_module_src_name(a, a_phase, free_id_recur); - release_recur_table(free_id_recur); - } else - asym = a; + b = scheme_malloc_atomic(slen+1); + memcpy(b, SCHEME_SYM_VAL(prefix), plen); + memcpy(b+plen, SCHEME_SYM_VAL(sym), SCHEME_SYM_LEN(sym)+1); + sym = scheme_intern_exact_symbol(b, slen); } - must_be_lex = 0; + return sym; +} - /* Same name? */ - if (!SAME_OBJ(asym, bsym)) { - /* It's ok to have different names if they have - the same symbolic name and the same lexical binding, - so double-check that our shortcut worked... */ - if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_VAL(b))) - must_be_lex = 1; +static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *vec, Scheme_Scope_Set *scopes, Scheme_Object *replace_at) +{ + Scheme_Object *req_modidx, *modidx, *unmarshal_info, *context, *src_phase, *pt_phase, *bind_phase, *insp; + Scheme_Hash_Table *export_registry; + + req_modidx = SCHEME_VEC_ELS(vec)[0]; + insp = SCHEME_VEC_ELS(vec)[3]; + + if (stx) { + modidx = apply_modidx_shifts(stx->shifts, req_modidx, &insp, &export_registry); + } else { + modidx = req_modidx; + export_registry = NULL; + insp = scheme_false; + } + + src_phase = SCHEME_VEC_ELS(vec)[1]; + unmarshal_info = SCHEME_VEC_ELS(vec)[2]; + pt_phase = extract_unmarshal_phase(unmarshal_info); + + SCHEME_VEC_ELS(vec)[0] = scheme_false; + SCHEME_VEC_ELS(vec)[1] = scheme_false; + SCHEME_VEC_ELS(vec)[2] = scheme_false; + + if (SCHEME_FALSEP(src_phase) || SCHEME_FALSEP(pt_phase)) + bind_phase = scheme_false; + else + bind_phase = scheme_bin_plus(src_phase, pt_phase); + + context = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); + context = scheme_stx_adjust_scopes(context, scopes, bind_phase, SCHEME_STX_ADD); + + scheme_do_module_context_unmarshal(modidx, req_modidx, context, + bind_phase, pt_phase, src_phase, + extract_unmarshal_prefix(unmarshal_info), + extract_unmarshal_excepts(unmarshal_info), + export_registry, insp, + replace_at); +} + +Scheme_Object *scheme_module_context_to_stx(Scheme_Object *mc, Scheme_Object *orig_src) +{ + Scheme_Object *plain, *o, *for_intro, *vec; + + plain = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); + + if (orig_src) + o = scheme_datum_to_syntax(scheme_true, scheme_false, orig_src, 0, 0); + else + o = scheme_stx_add_module_context(plain, mc); + + /* Keep track of intro scope separately: */ + for_intro = scheme_stx_introduce_to_module_context(plain, mc); + vec = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(vec)[0] = o; + SCHEME_VEC_ELS(vec)[1] = for_intro; + return scheme_datum_to_syntax(vec, scheme_false, scheme_false, 0, 0); +} + +Scheme_Object *scheme_stx_to_module_context(Scheme_Object *_stx) +{ + Scheme_Stx *stx = (Scheme_Stx *)_stx; + Scheme_Object *vec, *shifts, *a, *body_scopes, *phase = scheme_make_integer(0); + Scheme_Object *intro_multi_scope = NULL; + + if (SCHEME_VECTORP(stx->val) && (SCHEME_VEC_SIZE(stx->val) >= 2)) { + (void)scheme_stx_content((Scheme_Object *)stx); /* propagate */ + intro_multi_scope = SCHEME_VEC_ELS(stx->val)[1]; + stx = (Scheme_Stx *)SCHEME_VEC_ELS(stx->val)[0]; + } + + shifts = stx->shifts; + if (SCHEME_VECTORP(shifts)) + shifts = SCHEME_VEC_ELS(shifts)[0]; + + phase = scheme_make_integer(0); + + body_scopes = scheme_null; + a = stx->scopes->multi_scopes; + if (SCHEME_FALLBACKP(a)) + a = SCHEME_FALLBACK_FIRST(a); + for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) { + if (SAME_OBJ(phase, SCHEME_CDR(SCHEME_CAR(a)))) + body_scopes = scheme_make_pair(SCHEME_CAR(SCHEME_CAR(a)), body_scopes); + else + body_scopes = scheme_make_pair(SCHEME_CAR(a), body_scopes); + } + { + Scheme_Object *key, *val; + intptr_t i; + i = -1; + while ((i = scope_set_next(stx->scopes->simple_scopes, i)) != -1) { + scope_set_index(stx->scopes->simple_scopes, i, &key, &val); + body_scopes = scheme_make_pair(key, body_scopes); + } + } + + if (intro_multi_scope) { + stx = (Scheme_Stx *)intro_multi_scope; + if (!SCHEME_FALLBACKP(stx->scopes->multi_scopes) + && SCHEME_PAIRP(stx->scopes->multi_scopes)) { + intro_multi_scope = SCHEME_CAR(SCHEME_CAR(stx->scopes->multi_scopes)); + } + } + if (!intro_multi_scope) { + /* This won't happen for a well-formed representation */ + intro_multi_scope = new_multi_scope(scheme_false); + } + + vec = scheme_make_vector(6, NULL); + SCHEME_VEC_ELS(vec)[0] = body_scopes; + SCHEME_VEC_ELS(vec)[1] = phase; + SCHEME_VEC_ELS(vec)[2] = scheme_false; /* not sure this is right */ + SCHEME_VEC_ELS(vec)[3] = shifts; + SCHEME_VEC_ELS(vec)[4] = intro_multi_scope; + SCHEME_VEC_ELS(vec)[5] = (Scheme_Object *)empty_scope_set; + + return vec; +} + +int scheme_stx_equal_module_context(Scheme_Object *other_stx, Scheme_Object *mc_or_stx) +{ + Scheme_Stx *stx; + Scheme_Object *phase; + + if (SCHEME_STXP(mc_or_stx)) { + stx = (Scheme_Stx *)mc_or_stx; + if (SCHEME_VECTORP(stx->val) && (SCHEME_VEC_SIZE(stx->val) >= 2)) + stx = (Scheme_Stx *)SCHEME_VEC_ELS(stx->val)[0]; + } else { + Scheme_Object *plain; + plain = scheme_datum_to_syntax(scheme_false, scheme_false, scheme_false, 0, 0); + mc_or_stx = scheme_stx_add_module_context(plain, mc_or_stx); + stx = (Scheme_Stx *)mc_or_stx; + } + + phase = scheme_make_integer(0); + + return scopes_equal(extract_scope_set((Scheme_Stx *)other_stx, phase), + extract_scope_set(stx, phase)); +} + +/******************** lazy syntax-object unmarshaling ********************/ + +void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i) +{ + Scheme_Object *stx; + int c; + + stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]), + (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair)); + rp->stxes[i] = stx; + c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair)); + --c; + SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c); + if (!c) { + SCHEME_CDR(rp->delay_info_rpair) = NULL; + rp->delay_info_rpair = NULL; + } +} + +Scheme_Object *scheme_delayed_shift(Scheme_Object **o, intptr_t i) +{ + Scheme_Object *shift, *v; + Resolve_Prefix *rp; + int mutate = 0; + + shift = o[0]; + + if (!shift) return scheme_false; /* happens only with corrupted .zo! */ + + rp = (Resolve_Prefix *)o[1]; + + v = rp->stxes[i]; + + if (SCHEME_INTP(v)) { + scheme_load_delayed_syntax(rp, i); + v = rp->stxes[i]; + } + + v = do_stx_add_shift(v, shift, &mutate); + + shift = SCHEME_VEC_ELS(shift)[3]; + if (!SCHEME_FALSEP(shift)) { + /* need to propagate the inspector for dye packs, too */ + (void)set_false_insp((Scheme_Object *)v, shift, &mutate); + } + + return v; +} + +Scheme_Object *scheme_stx_force_delayed(Scheme_Object *stx) +{ + if (SCHEME_RPAIRP(stx)) + return scheme_load_delayed_code(SCHEME_INT_VAL(SCHEME_CAR(stx)), + (struct Scheme_Load_Delay *)SCHEME_CDR(stx)); + else + return stx; +} + +/*========================================================================*/ +/* stx comparison */ +/*========================================================================*/ + +int scheme_stx_could_bind(Scheme_Object *bind_id, Scheme_Object *ref_id, Scheme_Object *phase) +{ + Scheme_Stx *bind = (Scheme_Stx *)bind_id; + Scheme_Stx *ref = (Scheme_Stx *)ref_id; + + if (!SAME_OBJ(ref->val, bind->val)) + return 0; + + return scope_subset(extract_scope_set(bind, phase), + extract_scope_set(ref, phase)); +} + +int scheme_stx_free_eq3(Scheme_Object *a, Scheme_Object *b, + Scheme_Object *a_phase, Scheme_Object *b_phase) +{ + Scheme_Object *a_bind, *b_bind; + + STX_ASSERT(SCHEME_STXP(a)); + STX_ASSERT(SCHEME_STXP(b)); + + a_bind = scheme_stx_lookup(a, a_phase); + b_bind = scheme_stx_lookup(b, b_phase); + + if (SCHEME_SYMBOLP(a_bind) || SCHEME_SYMBOLP(b_bind)) { + return SAME_OBJ(a_bind, b_bind); + } + + if (SCHEME_FALSEP(a_bind) || SCHEME_FALSEP(b_bind)) { + /* A `#f` binding can be equal to a vector that starts `#f` */ + if (SCHEME_FALSEP(a_bind)) + a = SCHEME_STX_VAL(a); + else if (SCHEME_VECTORP(a_bind) + && SCHEME_FALSEP(SCHEME_VEC_ELS(a_bind)[0]) + && SAME_OBJ(SCHEME_VEC_ELS(a_bind)[2], a_phase)) { + a = SCHEME_VEC_ELS(a_bind)[1]; + a_bind = scheme_false; + } + + if (SCHEME_FALSEP(b_bind)) + b = SCHEME_STX_VAL(b); + else if (SCHEME_VECTORP(b_bind) + && SCHEME_FALSEP(SCHEME_VEC_ELS(b_bind)[0]) + && SAME_OBJ(SCHEME_VEC_ELS(b_bind)[2], b_phase)) { + b = SCHEME_VEC_ELS(b_bind)[1]; + b_bind = scheme_false; + } + + if (SCHEME_FALSEP(a_bind) && SCHEME_FALSEP(b_bind)) + return SAME_OBJ(a, b); else return 0; } - if ((a == asym) || (b == bsym)) - return 1; - - free_id_recur = make_recur_table(); - a = resolve_env(a, a_phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); - release_recur_table(free_id_recur); - - if (must_be_lex && !SCHEME_SYMBOLP(a)) + /* Comparison of names & definition phases is fast, so try that next: */ + if (!SAME_OBJ(SCHEME_VEC_ELS(a_bind)[1], SCHEME_VEC_ELS(b_bind)[1]) + || !SAME_OBJ(SCHEME_VEC_ELS(a_bind)[2], SCHEME_VEC_ELS(b_bind)[2])) { return 0; + } - free_id_recur = make_recur_table(); - b = resolve_env(b, b_phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); - release_recur_table(free_id_recur); + /* Need to compare modidxs: */ - if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) - a = scheme_module_resolve(a, 0); - if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) - b = scheme_module_resolve(b, 0); + a_bind = scheme_module_resolve(SCHEME_VEC_ELS(a_bind)[0], 0); + b_bind = scheme_module_resolve(SCHEME_VEC_ELS(b_bind)[0], 0); - /* Same binding environment? */ - return SAME_OBJ(a, b); + return SAME_OBJ(a_bind, b_bind); } -int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym) +int scheme_stx_free_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase) { - return scheme_stx_module_eq3(a, b, phase, phase, asym); + return scheme_stx_free_eq3(a, b, phase, phase); } -int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase) +int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase) { - return scheme_stx_module_eq3(a, b, scheme_make_integer(phase), scheme_make_integer(phase), NULL); + return scheme_stx_free_eq3(a, b, scheme_make_integer(phase), scheme_make_integer(phase)); } -int scheme_stx_module_eq_x(Scheme_Object *a, Scheme_Object *b, intptr_t b_phase) +int scheme_stx_free_eq_x(Scheme_Object *a, Scheme_Object *b, intptr_t b_phase) { - return scheme_stx_module_eq3(a, b, scheme_make_integer(0), scheme_make_integer(b_phase), NULL); + return scheme_stx_free_eq3(a, b, scheme_make_integer(0), scheme_make_integer(b_phase)); } -Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase) +Scheme_Object *scheme_stx_get_free_eq_sym(Scheme_Object *a, Scheme_Object *phase) { - if (SCHEME_STXP(a)) - return get_module_src_name(a, phase, NULL); - else + if (SCHEME_STXP(a)) { + a = scheme_stx_lookup(a, phase); + if (SCHEME_VECTORP(a)) + return SCHEME_VEC_ELS(a)[1]; + else + return a; + } else return a; } -Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, - Scheme_Object **a, Scheme_Object *phase, - Scheme_Object **nominal_modidx, /* how it was imported */ - Scheme_Object **nominal_name, /* imported as name */ - Scheme_Object **mod_phase, /* original defn phase level */ - Scheme_Object **src_phase_index, /* phase level of import from nominal modidx */ - Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */ - Scheme_Object **lex_env, - int *_sealed, - Scheme_Object **insp, - int *_binding_marks_skipped) - /* If module bound, result is module idx, and a is set to source name. - If lexically bound, result is scheme_undefined, a is unchanged, - and nominal_name is NULL or a free_id=? renamed id. - If neither, result is NULL, a is unchanged, and - and nominal_name is NULL or a free_id=? renamed id. */ -{ - if (SCHEME_STXP(*a)) { - Scheme_Object *modname, *names[7]; - int rib_dep; - - names[0] = NULL; - names[1] = NULL; - names[3] = scheme_make_integer(0); - names[4] = NULL; - names[5] = NULL; - names[6] = NULL; - - modname = resolve_env(*a, phase, 1, names, NULL, _binding_marks_skipped, - _sealed ? &rib_dep : NULL, 0, free_id_recur); - - if (_sealed) *_sealed = !rib_dep; - - if (names[0]) { - if (SAME_OBJ(names[0], scheme_undefined)) { - if (lex_env) - *lex_env = modname; - if (nominal_name) - *nominal_name = names[1]; - return scheme_undefined; - } else { - *a = names[0]; - if (nominal_modidx) - *nominal_modidx = names[1]; - if (nominal_name) - *nominal_name = names[2]; - if (mod_phase) - *mod_phase = names[3]; - if (src_phase_index) - *src_phase_index = names[4]; - if (nominal_src_phase) - *nominal_src_phase = names[5]; - if (insp) - *insp = names[6]; - return modname; - } - } else { - if (nominal_name) *nominal_name = names[1]; - return NULL; - } - } else { - if (nominal_name) *nominal_name = NULL; - if (_sealed) *_sealed = 1; - if (_binding_marks_skipped) *_binding_marks_skipped = -1; - return NULL; - } -} - -int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) -{ - Scheme_Object *m1, *m2, *skips = NULL; - - while (SCHEME_PAIRP(skip_ribs)) { - skips = add_skip_set(((Scheme_Lexical_Rib *)SCHEME_CAR(skip_ribs))->timestamp, - skips); - skip_ribs = SCHEME_CDR(skip_ribs); - } - - m1 = resolve_env(a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, NULL); - m2 = resolve_env(a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, NULL); - - return !SAME_OBJ(m1, m2); -} - -Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) - /* Returns either false, a lexical-rename symbol, or an mark/mark-list - for a prior module */ -{ - if (SCHEME_STXP(a)) { - Scheme_Object *r; - - r = resolve_env(a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, NULL); - - if (SCHEME_FALSEP(r)) - r = get_old_module_env(a); - - if (r) - return r; - } - return scheme_false; -} - -int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, +int scheme_stx_env_bound_eq2(Scheme_Object *_a, Scheme_Object *_b, Scheme_Object *a_phase, Scheme_Object *b_phase) - /* If uid is given, it's the environment for b. */ { - Scheme_Object *asym, *bsym, *ae, *be; + Scheme_Stx *a = (Scheme_Stx *)_a; + Scheme_Stx *b = (Scheme_Stx *)_b; - if (!a || !b) - return (a == b); + STX_ASSERT(SCHEME_STXP(_a)); + STX_ASSERT(SCHEME_STXP(_b)); - if (SCHEME_STXP(a)) - asym = SCHEME_STX_VAL(a); - else - asym = a; - if (SCHEME_STXP(b)) - bsym = SCHEME_STX_VAL(b); - else - bsym = b; - - /* Same name? */ - if (!SAME_OBJ(asym, bsym)) + if (!SAME_OBJ(a->val, b->val)) return 0; - ae = resolve_env(a, a_phase, 0, NULL, NULL, NULL, NULL, 0, NULL); - /* No need to module_resolve ae, because we ignored module renamings. */ - - if (uid) - be = uid; - else { - be = resolve_env(b, b_phase, 0, NULL, NULL, NULL, NULL, 0, NULL); - /* No need to module_resolve be, because we ignored module renamings. */ - } - - /* Same binding environment? */ - if (!SAME_OBJ(ae, be)) - return 0; - - /* Same marks? (If not lexically bound, ignore mark barriers.) */ - if (!uid) { - WRAP_POS aw; - WRAP_POS bw; - WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps); - WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps); - if (!same_marks(&aw, &bw, ae)) - return 0; - } - - return 1; -} - -int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase) -{ - return scheme_stx_env_bound_eq2(a, b, uid, phase, phase); + return scopes_equal(extract_scope_set(a, a_phase), extract_scope_set(b, b_phase)); } int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase) { - return scheme_stx_env_bound_eq2(a, b, NULL, phase, phase); + return scheme_stx_env_bound_eq2(a, b, phase, phase); } -#if EXPLAIN_RESOLVE -Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) -{ - scheme_explain_resolves++; - a = resolve_env(a, 0, 0, NULL, NULL, NULL, NULL, 0, NULL); - --scheme_explain_resolves; - return a; -} -#endif - Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source) { - /* Inspect the wraps to look for a self-modidx shift: */ - WRAP_POS w; - Scheme_Object *srcmod = scheme_false, *chain_from = NULL, *er; - Scheme_Hash_Table *export_registry = NULL; + /* Look for the oldest "self" modidx that has a resolution: */ + Scheme_Object *l = ((Scheme_Stx *)stx)->shifts, *a, *src; + Scheme_Hash_Table *export_registry; - WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); + if (SCHEME_VECTORP(l)) + l = SCHEME_VEC_ELS(l)[0]; - while (!WRAP_POS_END_P(w)) { - if (SCHEME_BOXP(WRAP_POS_FIRST(w))) { - /* Phase shift: */ - Scheme_Object *vec, *dest, *src; - - vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(w)); - - src = SCHEME_VEC_ELS(vec)[1]; - dest = SCHEME_VEC_ELS(vec)[2]; - - /* If src is #f, shift is just for phase; no redirection */ - if (!SCHEME_FALSEP(src)) { - - if (!chain_from) { - srcmod = dest; - } else if (!SAME_OBJ(chain_from, dest)) { - srcmod = scheme_modidx_shift(dest, - chain_from, - srcmod); - } - - chain_from = src; - - if (!export_registry) { - er = SCHEME_VEC_ELS(vec)[3]; - if (SCHEME_TRUEP(er)) - export_registry = (Scheme_Hash_Table *)er; - } - } - } - - WRAP_POS_INC(w); - } - - if (SCHEME_TRUEP(srcmod)) { - if (resolve) { - srcmod = scheme_module_resolve(srcmod, 0); - if (export_registry && source) { - er = scheme_hash_get(export_registry, srcmod); - if (er) - srcmod = ((Scheme_Module_Exports *)er)->modsrc; - } - srcmod = SCHEME_PTR_VAL(srcmod); - } - } - - return srcmod; -} - -int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx) -{ - /* Inspect the wraps to look for a binding: */ - WRAP_POS w; - - WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); - - while (!WRAP_POS_END_P(w)) { - if (SCHEME_RENAMESP(WRAP_POS_FIRST(w))) { - /* Module rename. For simplicity, we look at all renames, even - if they're in the wrong phase, or for the wrong module, - etc. */ - Module_Renames *mrn = (Module_Renames *)WRAP_POS_FIRST(w); - - if (scheme_tl_id_is_sym_used(mrn->marked_names, sym)) - return 1; - } else if (SCHEME_RENAMES_SETP(WRAP_POS_FIRST(w))) { - Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(w); - int i; - - if (mrns->rt && scheme_tl_id_is_sym_used(mrns->rt->marked_names, sym)) - return 1; - if (mrns->et && scheme_tl_id_is_sym_used(mrns->et->marked_names, sym)) - return 1; - - if (mrns->other_phases) { - for (i = 0; i < mrns->other_phases->size; i++) { - if (mrns->other_phases->vals[i]) - scheme_tl_id_is_sym_used(((Module_Renames *)mrns->other_phases->vals[i])->marked_names, - sym); - } - } - } - WRAP_POS_INC(w); - } + l = scheme_reverse(l); - return 0; -} + while (!SCHEME_NULLP(l)) { + a = SCHEME_CAR(l); + if (SCHEME_VECTORP(a)) { + src = SCHEME_VEC_ELS(a)[1]; -Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to, - Scheme_Object *uid) -{ - WRAP_POS aw; - WRAP_POS bw; - - WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps); - WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps); - - if (!same_marks(&aw, &bw, scheme_false)) { - Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps; - if (uid) { - /* Add a rename record: */ - Scheme_Object *rn; - rn = scheme_make_rename(uid, 1); - scheme_set_rename(rn, 0, relative_to); - wraps = scheme_make_pair(rn, wraps); + if (SCHEME_MODIDXP(src)) { + if (SCHEME_FALSEP(((Scheme_Modidx *)src)->path)) { + src = apply_modidx_shifts(((Scheme_Stx *)stx)->shifts, src, + NULL, &export_registry); + if (!SCHEME_FALSEP(((Scheme_Modidx *)src)->path) + || !SCHEME_FALSEP(((Scheme_Modidx *)src)->resolved)) { + if (resolve) { + src = scheme_module_resolve(src, 0); + if (export_registry && source) { + a = scheme_hash_get(export_registry, src); + if (a) + src = ((Scheme_Module_Exports *)a)->modsrc; + } + src = SCHEME_PTR_VAL(src); + } + return src; + } + } + } } - { - Scheme_Stx *stx = (Scheme_Stx *)a; - Scheme_Object *taints; - taints = stx->taints; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = wraps; - stx->taints = taints; - a = (Scheme_Object *)stx; - } - } + l = SCHEME_CDR(l); + } - return a; + return scheme_false; } /*========================================================================*/ @@ -5283,1306 +5150,624 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist) /* wraps->datum */ /*========================================================================*/ -/* Used for marshaling syntax objects. Note that we build a reverse - list for wraps. (Unmarshaler will reverse it back.) - - The wraps->datum tools are also used to simplify syntax object (to - minimize the occupied space among a set of objects). */ - -#define EXPLAIN_SIMP 0 -#if EXPLAIN_SIMP -#define EXPLAIN_S(x) if (explain_simp) x -static int explain_simp = 1; -static void print_skips(Scheme_Object *skips) +static void add_reachable_scopes(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt) { - while (skips) { - if (SCHEME_PAIRP(skips)) { - fprintf(stderr, " skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL)); - skips = SCHEME_CDR(skips); - } else { - fprintf(stderr, " skip val %s\n", scheme_write_to_string(skips, NULL)); - skips = NULL; + intptr_t i; + Scheme_Object *key, *val; + + i = -1; + while ((i = scope_set_next(scopes, i)) != -1) { + scope_set_index(scopes, i, &key, &val); + if (!scheme_eq_hash_get(mt->reachable_scopes, key)) { + scheme_hash_set(mt->reachable_scopes, key, scheme_true); + val = scheme_make_pair(key, mt->reachable_scope_stack); + mt->reachable_scope_stack = val; } } } -#else -#define EXPLAIN_S(x) /* empty */ + +static void add_reachable_multi_scopes(Scheme_Object *multi_scopes, Scheme_Marshal_Tables *mt) +{ + Scheme_Hash_Table *ht; + Scheme_Object *scope, *l; + int j; + + while (1) { + l = multi_scopes; + if (SCHEME_FALLBACKP(l)) + l = SCHEME_FALLBACK_FIRST(l); + + for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + ht = (Scheme_Hash_Table *)SCHEME_CAR(SCHEME_CAR(l)); + for (j = ht->size; j--; ) { + scope = ht->vals[j]; + if (scope) { + if (!SCHEME_VOIDP(ht->keys[j])) { + if (!scheme_eq_hash_get(mt->reachable_scopes, scope)) { + scheme_hash_set(mt->reachable_scopes, scope, scheme_true); + scope = scheme_make_pair(scope, mt->reachable_scope_stack); + mt->reachable_scope_stack = scope; + } + } + } + } + } + + if (SCHEME_FALLBACKP(multi_scopes)) + multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); + else + break; + } +} + +static Scheme_Object *any_unreachable_scope(Scheme_Scope_Set *scopes, Scheme_Marshal_Tables *mt) +{ + intptr_t i; + Scheme_Object *key, *val; + + i = -1; + while ((i = scope_set_next(scopes, i)) != -1) { + scope_set_index(scopes, i, &key, &val); + if (!scheme_eq_hash_get(mt->reachable_scopes, key)) + return key; + } + + return NULL; +} + +static void possiblly_reachable_free_id(Scheme_Object *val, + Scheme_Scope_Set *scopes, + Scheme_Marshal_Tables *mt) +{ + Scheme_Stx *free_id = (Scheme_Stx *)SCHEME_CAR(SCHEME_CDR(val)); + Scheme_Object *unreachable_scope, *l; + Scheme_Hash_Table *ht; + + unreachable_scope = any_unreachable_scope(scopes, mt); + + if (!unreachable_scope) { + /* causes the free-id mapping's scopes to be reachable: */ + (void)wraps_to_datum(free_id, mt); + } else { + /* the mapping will become reachable only if `unreachable_scope` becomes reachable */ + if (!mt->pending_reachable_ids) { + ht = scheme_make_hash_table(SCHEME_hash_ptr); + mt->pending_reachable_ids = ht; + } + l = scheme_eq_hash_get(mt->pending_reachable_ids, unreachable_scope); + if (!l) l = scheme_null; + scheme_hash_set(mt->pending_reachable_ids, unreachable_scope, + scheme_make_pair(scheme_make_pair((Scheme_Object *)free_id, + (Scheme_Object *)scopes), + l)); + } +} + +void scheme_iterate_reachable_scopes(Scheme_Marshal_Tables *mt) +{ + Scheme_Scope *scope; + Scheme_Object *l, *val, *key; + Scheme_Hash_Tree *ht; + int j; + + /* For each scope, recur on `free-identifier=?` mappings */ + while (!SCHEME_NULLP(mt->reachable_scope_stack)) { + scope = (Scheme_Scope *)SCHEME_CAR(mt->reachable_scope_stack); + mt->reachable_scope_stack = SCHEME_CDR(mt->reachable_scope_stack); + + if (scope->bindings) { + val = scope->bindings; + if (SCHEME_VECTORP(val)) { + l = SCHEME_VEC_BINDING_VAL(val); + if (SCHEME_MPAIRP(l)) { + /* It's a free-id mapping: */ + possiblly_reachable_free_id(l, SCHEME_VEC_BINDING_SCOPES(val), mt); + } + } else { + if (SCHEME_RPAIRP(val)) + ht = (Scheme_Hash_Tree *)SCHEME_CAR(val); + else { + STX_ASSERT(SCHEME_HASHTRP(val)); + ht = (Scheme_Hash_Tree *)val; + } + j = -1; + while ((j = scheme_hash_tree_next(ht, j)) != -1) { + scheme_hash_tree_index(ht, j, &key, &val); + l = val; + if (SCHEME_PAIRP(l)) { + val = SCHEME_BINDING_VAL(l); + if (SCHEME_MPAIRP(val)) { + /* It's a free-id mapping: */ + possiblly_reachable_free_id(val, SCHEME_BINDING_SCOPES(l), mt); + } + } else { + STX_ASSERT(SCHEME_MPAIRP(l)); + for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + val = SCHEME_BINDING_VAL(SCHEME_CAR(l)); + if (SCHEME_MPAIRP(val)) { + /* It's a free-id mapping: */ + possiblly_reachable_free_id(val, SCHEME_BINDING_SCOPES(SCHEME_CAR(l)), mt); + } + } + } + } + } + } + + /* Check for any free-id mappings whose reachbility depended on `scope`: */ + if (mt->pending_reachable_ids) { + l = scheme_eq_hash_get(mt->pending_reachable_ids, (Scheme_Object *)scope); + if (l) { + scheme_hash_set(mt->pending_reachable_ids, (Scheme_Object *)scope, NULL); + while (!SCHEME_NULLP(l)) { + val = SCHEME_CAR(l); + possiblly_reachable_free_id(SCHEME_CAR(val), (Scheme_Scope_Set *)SCHEME_CDR(val), mt); + l = SCHEME_CDR(l); + } + } + } + } +} + +static Scheme_Object *intern_one(Scheme_Object *v, Scheme_Hash_Table *ht) +{ + Scheme_Object *result; + + result = scheme_hash_get(ht, v); + if (!result) { + result = scheme_make_marshal_shared(v); + scheme_hash_set(ht, v, result); + } + + return result; +} + +static Scheme_Object *intern_tails(Scheme_Object *l, Scheme_Hash_Table *ht) +{ + Scheme_Object *r, *result; + + r = scheme_null; + do { + if (SCHEME_NULLP(l)) + result = scheme_null; + else + result = scheme_hash_get(ht, l); + if (!result) { + r = scheme_make_pair(SCHEME_CAR(l), r); + l = SCHEME_CDR(l); + } + } while (!result); + + while (!SCHEME_NULLP(r)) { + result = scheme_make_pair(SCHEME_CAR(r), result); + l = scheme_make_pair(SCHEME_CAR(r), l); + result = scheme_make_marshal_shared(result); + scheme_hash_set(ht, l, result); + r = SCHEME_CDR(r); + } + + return result; +} + +static Scheme_Object *intern_fallback_tails(Scheme_Object *l, Scheme_Hash_Table *ht) +{ + Scheme_Object *r, *result; + + r = scheme_null; + do { + if (!SCHEME_FALLBACKP(l)) + result = l; + else + result = scheme_hash_get(ht, l); + if (!result) { + r = scheme_make_pair(SCHEME_FALLBACK_FIRST(l), r); + l = SCHEME_FALLBACK_REST(l); + } + } while (!result); + + while (!SCHEME_NULLP(r)) { + result = make_fallback_pair(SCHEME_CAR(r), result); + l = make_fallback_pair(SCHEME_CAR(r), l); + result = scheme_make_marshal_shared(result); + scheme_hash_set(ht, l, result); + r = SCHEME_CDR(r); + } + + return result; +} + +#ifdef MZ_XFORM +START_XFORM_SKIP; +#endif +#include "../gc2/my_qsort.c" +#ifdef MZ_XFORM +END_XFORM_SKIP; #endif -static Scheme_Object *extract_free_id_info(Scheme_Object *id) +typedef int (*compar_t)(const void *, const void *); + +static int compare_scopes(const void *a, const void *b) { - Scheme_Object *bind; - Scheme_Object *nominal_modidx; - Scheme_Object *nominal_name, *nom2; - Scheme_Object *mod_phase; - Scheme_Object *src_phase_index; - Scheme_Object *nominal_src_phase; - Scheme_Object *lex_env = NULL; - Scheme_Object *vec, *phase, *insp; - Scheme_Hash_Table *free_id_recur; + if (*(void **)a == *(void **)b) + return 0; + else if ((*(Scheme_Scope **)a)->id > (*(Scheme_Scope **)b)->id) + return -1; + else + return 1; +} - phase = SCHEME_CDR(id); - id = SCHEME_CAR(id); +static Scheme_Object *scopes_to_sorted_list(Scheme_Scope_Set *scopes) +{ + Scheme_Object **a, *r, *key, *val; + intptr_t i, j = 0; - nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); + i = scope_set_count(scopes); + a = MALLOC_N(Scheme_Object *, i); - free_id_recur = make_recur_table(); - bind = scheme_stx_module_name(free_id_recur, - &id, phase, &nominal_modidx, &nominal_name, - &mod_phase, &src_phase_index, &nominal_src_phase, - &lex_env, NULL, &insp, NULL); - release_recur_table(free_id_recur); + i = scope_set_next(scopes, -1); + while (i != -1) { + scope_set_index(scopes, i, &key, &val); + a[j++] = key; + i = scope_set_next(scopes, i); + } + + my_qsort(a, j, sizeof(Scheme_Object *), compare_scopes); - if (SCHEME_SYMBOLP(nom2)) - nominal_name = nom2; - if (!nominal_name) - nominal_name = SCHEME_STX_VAL(id); + r = scheme_null; + for (i = j; i--; ) { + r = scheme_make_pair(a[i], r); + } - if (!bind) - return CONS(nominal_name, scheme_false); - else if (SAME_OBJ(bind, scheme_undefined)) - return CONS(nominal_name, lex_env); - else { - vec = scheme_make_vector(8, NULL); - vec->type = scheme_free_id_info_type; - SCHEME_VEC_ELS(vec)[0] = bind; - SCHEME_VEC_ELS(vec)[1] = id; - SCHEME_VEC_ELS(vec)[2] = nominal_modidx; - SCHEME_VEC_ELS(vec)[3] = nominal_name; - SCHEME_VEC_ELS(vec)[4] = mod_phase; - SCHEME_VEC_ELS(vec)[5] = src_phase_index; - SCHEME_VEC_ELS(vec)[6] = nominal_src_phase; - SCHEME_VEC_ELS(vec)[7] = (insp ? insp : scheme_false); + return r; +} + +static int compare_syms(const void *_a, const void *_b) +{ + Scheme_Object *a = (Scheme_Object *)_a; + Scheme_Object *b = (Scheme_Object *)_b; + intptr_t l = SCHEME_SYM_LEN(a), i; + + if (SCHEME_SYM_LEN(b) < l) + l = SCHEME_SYM_LEN(b); + + for (i = 0; i < l; i++) { + if (SCHEME_SYM_VAL(a)[i] != SCHEME_SYM_VAL(b)[i]) + return (SCHEME_SYM_VAL(a)[i] - SCHEME_SYM_VAL(b)[i]); + } + + return SCHEME_SYM_LEN(a) - SCHEME_SYM_LEN(b); +} + +static void sort_vector_symbols(Scheme_Object *vec) +{ + my_qsort(SCHEME_VEC_ELS(vec), SCHEME_VEC_SIZE(vec), sizeof(Scheme_Object *), compare_syms); +} + +static Scheme_Object *drop_export_registries(Scheme_Object *shifts) +{ + Scheme_Object *l, *a, *vec, *p, *first = scheme_null, *last = NULL; + int same_insp; + + if (SCHEME_VECTORP(shifts)) + shifts = SCHEME_VEC_ELS(shifts)[0]; + + for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + same_insp = ((SCHEME_VEC_SIZE(a) <= 2) + || SAME_OBJ(SCHEME_VEC_ELS(a)[2], SCHEME_VEC_ELS(a)[3]) + || SCHEME_FALSEP(SCHEME_VEC_ELS(a)[3])); + if (!SAME_OBJ(SCHEME_VEC_ELS(a)[0], SCHEME_VEC_ELS(a)[1]) + || !same_insp) { + if (same_insp) + vec = scheme_make_vector(2, NULL); + else + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = SCHEME_VEC_ELS(a)[0]; + SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(a)[1]; + if (!same_insp) { + SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(a)[2]; + SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(a)[3]; + } + + p = scheme_make_pair(vec, scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + } + } + + return first; +} + +static void init_identity_map(Scheme_Marshal_Tables *mt) +{ + Scheme_Hash_Table *id_map; + id_map = scheme_make_hash_table(SCHEME_hash_ptr); + mt->identity_map = id_map; +} + +static Scheme_Object *multi_scope_to_vector(Scheme_Object *multi_scope, Scheme_Marshal_Tables *mt) +{ + Scheme_Object *vec; + Scheme_Hash_Table *scopes = (Scheme_Hash_Table *)multi_scope; + intptr_t i, j; + + if (!mt->identity_map) + init_identity_map(mt); + + vec = scheme_hash_get(mt->identity_map, multi_scope); + if (vec) return vec; + + vec = scheme_make_vector((2 * scopes->count) - 1, scheme_void); + j = 0; + for (i = scopes->size; i--; ) { + if (scopes->vals[i]) { + if (!SCHEME_VOIDP(scopes->keys[i])) { + SCHEME_VEC_ELS(vec)[j++] = scopes->keys[i]; /* a phase */ + SCHEME_VEC_ELS(vec)[j++] = scopes->vals[i]; /* a scope */ + } else { + SCHEME_VEC_ELS(vec)[SCHEME_VEC_SIZE(vec)-1] = scopes->vals[i]; /* debug name */ + } + } } + + vec = scheme_make_marshal_shared(vec); + + scheme_hash_set(mt->identity_map, multi_scope, vec); + + return vec; } -static int not_in_rename(Scheme_Object *constrain_to_syms, Scheme_Object *rename) +static Scheme_Object *marshal_multi_scopes(Scheme_Object *multi_scopes, Scheme_Marshal_Tables *mt, Scheme_Hash_Table *ht) { - int istart, iend, ri; - Scheme_Object *renamed, *s; + Scheme_Object *l, *p, *first, *last; + Scheme_Object *fb_first = scheme_null, *fb_last = NULL; - while (SCHEME_PAIRP(constrain_to_syms)) { - - s = SCHEME_CAR(constrain_to_syms); - extract_lex_range(rename, s, &istart, &iend); + while (1) { + l = multi_scopes; + if (SCHEME_FALLBACKP(l)) + l = SCHEME_FALLBACK_FIRST(l); + + first = scheme_null; + last = NULL; - for (ri = istart; ri < iend; ri++) { - renamed = SCHEME_VEC_ELS(rename)[2+ri]; - if (SAME_OBJ(renamed, s)) - return 0; - } - - constrain_to_syms = SCHEME_CDR(constrain_to_syms); - } - - return 1; -} - -static int not_in_rib(Scheme_Object *constrain_to_syms, Scheme_Lexical_Rib *rib) -{ - for (rib = rib->next; rib; rib = rib->next) { - if (!not_in_rename(constrain_to_syms, rib->rename)) - return 0; - } - return 1; -} - -#define EXPLAIN_R(x) /* empty */ - -static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache, - Scheme_Object *stx_datum) -{ - WRAP_POS w, prev, w2; - Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs, *prev_prec_ribs; - Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false, *constrain_to_syms = NULL; - Scheme_Object *v, *v2, *v2l, *v2rdl, *stx, *name, *svl, *end_mutable = NULL, **v2_rib_delims = NULL, *svrdl; - Scheme_Lexical_Rib *did_rib = NULL; - Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; - int copy_on_write, no_rib_mutation = 1, rib_count = 0; - intptr_t size, vsize, psize, i, j, pos; - - /* Although it makes no sense to simplify the rename table itself, - we can simplify it in the context of a particular wrap suffix. - (But don't mutate the wrap list, because that will stomp on - tables that might be needed by a propagation.) - - A lex_cache maps wrap starts within `w' to lists of simplified - tables. This helps avoid re-simplifying when the result is - clearly going to be the same. A lex_cache is read and modified by - this function, only. - - In addition to depending on the rest of the wraps, a resolved - binding can depend on preceding wraps due to rib skipping. For - now, simplifications that depend on preceding wraps are not - cached (though individual computed renamings are cached to save - space). - - The simplification stragegy mostly works inside out: since later - renames depend on earlier renames, we simplify the earlier ones - first, and then collapse to a flattened rename while working - outward. This also lets us track shared tails in some common - cases. - - A catch with the inside-out approach has to do with ribs (again). - Preceding ribs determine the recur_skip_ribs set, so we can - simply track that as we recur into the wraps initially to build - our worklist. However, whether we process a rib at all (on the - way out in the second pass) for a given id depends on whether any - preceding instance of the same rib (i.e., further out) matches - the symbol and marks. So, we have to compute that summary as we - go in. */ - - if (SCHEME_SYMBOLP(stx_datum)) { - /* Search for prunings */ - WRAP_POS_INIT(w, wraps); - old_key = NULL; - prec_ribs = NULL; - while (!WRAP_POS_END_P(w)) { - if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) - || SCHEME_RIBP(WRAP_POS_FIRST(w))) { - /* Lexical rename --- maybe an already-simplified point */ - key = WRAP_POS_KEY(w); - if (!SAME_OBJ(key, old_key)) { - v = scheme_hash_get(lex_cache, key); - if (v && SCHEME_HASHTP(v)) { - v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false); - } else if (prec_ribs) - v = NULL; - } else - v = NULL; - old_key = key; - - if (v) { - /* Tables here are already simplified. */ - break; - } - - if (SCHEME_RIBP(WRAP_POS_FIRST(w))) { - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(w); - if (!nonempty_rib(rib)) - prec_ribs = add_skip_set(rib->timestamp, prec_ribs); - } - } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(w))) { - v = SCHEME_BOX_VAL(WRAP_POS_FIRST(w)); - if (is_member(stx_datum, v)) { - if (!constrain_to_syms) - constrain_to_syms = v; - else { - v2 = scheme_null; - while (SCHEME_PAIRP(v)) { - if (is_member(SCHEME_CAR(v), constrain_to_syms)) - v2 = scheme_make_pair(SCHEME_CAR(v), v2); - v = SCHEME_CDR(v); - } - constrain_to_syms = v2; - } - } else - constrain_to_syms = scheme_null; - } - WRAP_POS_INC(w); - } - } - - WRAP_POS_INIT(w, wraps); - WRAP_POS_INIT_END(prev); - - old_key = NULL; - prec_ribs = NULL; - - v2l = scheme_null; - v2rdl = NULL; - - EXPLAIN_S(fprintf(stderr, "[in simplify %s]\n", scheme_write_to_string(stx_datum, NULL))); - - EXPLAIN_R(printf("Simplifying %p %s\n", lex_cache, scheme_write_to_string(stx_datum, NULL))); - - while (!WRAP_POS_END_P(w)) { - if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) - || SCHEME_RIBP(WRAP_POS_FIRST(w))) { - /* Lexical rename */ - key = WRAP_POS_KEY(w); - EXPLAIN_R(printf(" key %p\n", key)); - if (!SAME_OBJ(key, old_key)) { - v = scheme_hash_get(lex_cache, key); - if (v && SCHEME_HASHTP(v)) { - v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false); - } else if (prec_ribs) - v = NULL; - } else - v = NULL; - old_key = key; - prev_prec_ribs = prec_ribs; - prev_skip_ribs_ht = skip_ribs_ht; - - if (v) { - /* Tables here are already simplified. */ - v2l = v; /* build on simplify chain extracted from cache */ - end_mutable = v2l; - /* No non-simplified table can follow a simplified one */ - break; - } else { - int add = 0, skip_this = 0; - - v = WRAP_POS_FIRST(w); - if (SCHEME_RIBP(v)) { - /* A rib certainly isn't simplified yet. */ - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v; - no_rib_mutation = 0; - add = 1; - if (!*rib->sealed) { - scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); - return NULL; - } - if (SAME_OBJ(did_rib, rib) - || !nonempty_rib(rib) - || (constrain_to_syms && !not_in_rib(constrain_to_syms, rib))) { - skip_this = 1; - if (!nonempty_rib(rib)) - prec_ribs = add_skip_set(rib->timestamp, prec_ribs); - EXPLAIN_S(fprintf(stderr, " to skip %p=%s\n", rib, - scheme_write_to_string(rib->timestamp, NULL))); - } else { - rib_count++; - did_rib = rib; - prec_ribs = add_skip_set(rib->timestamp, prec_ribs); - - EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, - scheme_write_to_string(rib->timestamp, NULL))); - EXPLAIN_S(print_skips(prec_ribs)); - - copy_on_write = 1; - - EXPLAIN_R(printf(" rib %p\n", rib->timestamp)); - - /* Compute, per id, whether to skip later instances of rib: */ - for (rib = rib->next; rib; rib = rib->next) { - vsize = SCHEME_RENAME_LEN(rib->rename); - for (i = 0; i < vsize; i++) { - stx = SCHEME_VEC_ELS(rib->rename)[2+i]; - - EXPLAIN_S(fprintf(stderr, " skip? %s %p=%s %s\n", - scheme_write_to_string(SCHEME_STX_VAL(stx), NULL), - rib, - scheme_write_to_string(rib->timestamp, NULL), - scheme_write_to_string(SCHEME_VEC_ELS(rib->rename)[0], NULL))); - - /* already skipped? */ - if ((!constrain_to_syms || is_member(SCHEME_STX_VAL(stx), constrain_to_syms)) - && (!skip_ribs_ht - || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp)))) { - /* No. Should we skip? */ - Scheme_Object *other_env; - other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i]; - other_env = filter_cached_env(other_env, prec_ribs); - if (SCHEME_VOIDP(other_env)) { - int rib_dep; - other_env = resolve_env(stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); - if (rib_dep) { - scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); - return NULL; - } - { - Scheme_Object *e; - e = extend_cached_env(SCHEME_VEC_ELS(rib->rename)[2+vsize+i], other_env, prec_ribs, 0); - SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = e; - } - } - WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (same_marks(&w2, &w, other_env)) { - /* yes, skip */ - EXPLAIN_S(fprintf(stderr, " skip! %s\n", - scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); - if (!skip_ribs_ht) - skip_ribs_ht = scheme_make_hash_table_equal(); - else if (copy_on_write) - skip_ribs_ht = scheme_clone_hash_table(skip_ribs_ht); - copy_on_write = 0; - scheme_hash_set(skip_ribs_ht, - scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp), - scheme_true); - } - } else { - EXPLAIN_S(fprintf(stderr, " already skipped %s\n", - scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); - } - } - } - } - } else { - /* Need to simplify this vector? */ - if (SCHEME_VEC_SIZE(v) == 1) - v = SCHEME_VEC_ELS(v)[0]; - if ((SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */ - && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2])) { - add = 1; - - if (constrain_to_syms) { - /* Maybe pruned so that we don't need to resolve: */ - if (not_in_rename(constrain_to_syms, v)) - skip_this = 1; - } - } - EXPLAIN_R(printf(" lex reset\n")); - did_rib = NULL; - } - - if (add) { - if (skip_this) { - ribs_stack = scheme_make_pair(scheme_false, ribs_stack); - } else { - ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs, - scheme_make_pair((Scheme_Object *)prev_skip_ribs_ht, - rib_delim)), - ribs_stack); - } - - /* Need to simplify, but do deepest first: */ - if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_VEC_ELS(SCHEME_CAR(stack))[0], key)) { - v = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(v)[0] = key; - SCHEME_VEC_ELS(v)[1] = prev_prec_ribs; - stack = CONS(v, stack); - } - } else { - /* This is already simplified. Remember it and stop, because - no non-simplified table can follow a simplified one. */ - WRAP_POS_COPY(prev, w); - break; - } - } - } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(w))) { - rib_delim = WRAP_POS_FIRST(w); - if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) - rib_delim = scheme_false; - if (rib_count > 1) { - EXPLAIN_R(if (did_rib) printf(" reset delim %d\n", rib_count)); - did_rib = NULL; - } - rib_count = 0; - } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(w))) { - v = WRAP_POS_FIRST(w); - WRAP_POS_COPY(w2, w); - WRAP_POS_INC(w2); - if (!WRAP_POS_END_P(w2) && SAME_OBJ(v, WRAP_POS_FIRST(w2))) { - WRAP_POS_INC(w); - } else { - EXPLAIN_R(printf(" reset by mark\n")); - did_rib = NULL; - } - } else { - EXPLAIN_R(if (did_rib) printf(" reset %d\n", SCHEME_TYPE(WRAP_POS_FIRST(w)))); - did_rib = NULL; - } - - WRAP_POS_INC(w); - } - - EXPLAIN_R(printf(" ... phase2\n")); - - while (!SCHEME_NULLP(stack)) { - key = SCHEME_CAR(stack); - prev_prec_ribs = SCHEME_VEC_ELS(key)[1]; - key = SCHEME_VEC_ELS(key)[0]; - - WRAP_POS_REVINIT(w, key); - - while (!WRAP_POS_REVEND_P(w)) { - v = WRAP_POS_FIRST(w); - - if (SCHEME_RIBP(v) - || (SCHEME_VECTORP(v) - && (SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */ - && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2]))) { - /* This is the place to simplify: */ - Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL; - Scheme_Object *local_ribs; - int ii, vvsize, done_rib_pos = 0; - - rib_delim = scheme_false; - - if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) { - EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v, - scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL))); - ribs_stack = SCHEME_CDR(ribs_stack); - vsize = 0; - local_ribs = NULL; - } else { - rib_delim = SCHEME_CAR(ribs_stack); - prec_ribs = SCHEME_CAR(rib_delim); - rib_delim = SCHEME_CDR(rib_delim); - skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CAR(rib_delim); - rib_delim = SCHEME_CDR(rib_delim); - ribs_stack = SCHEME_CDR(ribs_stack); - - if (SCHEME_RIBP(v)) { - init_rib = (Scheme_Lexical_Rib *)v; - EXPLAIN_S(fprintf(stderr, " up rib %p=%s\n", init_rib, - scheme_write_to_string(init_rib->timestamp, NULL))); - EXPLAIN_S(print_skips(prec_ribs)); - rib = init_rib->next; - vsize = 0; - local_ribs = NULL; - while (rib) { - /* We need to process the renamings in reverse order: */ - local_ribs = scheme_make_raw_pair((Scheme_Object *)rib, local_ribs); - - vsize += SCHEME_RENAME_LEN(rib->rename); - rib = rib->next; - } - if (local_ribs) { - rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); - local_ribs = SCHEME_CDR(local_ribs); - } - } else { - vsize = SCHEME_RENAME_LEN(v); - local_ribs = NULL; - } - } - - /* Initial size; may shrink: */ - size = vsize; - - v2 = scheme_make_vector(2 + (2 * size), NULL); - v2_rib_delims = MALLOC_N(Scheme_Object *, size); - - pos = 0; /* counter for used slots */ - - /* Local vector (different from i when we have a rib) */ - ii = 0; - vvsize = vsize; - - for (i = 0; i < vsize; i++) { - if (rib) { - v = rib->rename; - vvsize = SCHEME_RENAME_LEN(v); - while (ii >= vvsize) { - ii = 0; - done_rib_pos = pos; - rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); - local_ribs = SCHEME_CDR(local_ribs); - v = rib->rename; - vvsize = SCHEME_RENAME_LEN(v); - } - } - stx = SCHEME_VEC_ELS(v)[2+ii]; - name = SCHEME_STX_VAL(stx); - SCHEME_VEC_ELS(v2)[2+pos] = name; - - if ((!constrain_to_syms || is_member(name, constrain_to_syms)) - && (!rib - || !skip_ribs_ht - || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(name, rib->timestamp)))) { - /* Either this name is in prev, in which case the answer - must match this rename's target, or this rename's - answer applies. */ - Scheme_Object *ok = NULL, *ok_replace = NULL, **ok_replace_rd = NULL; - int ok_replace_index = 0, ok_replace_rd_index = 0; - Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env; - - if (rib) { - EXPLAIN_S(fprintf(stderr, " resolve %s %s (%d)\n", - scheme_write_to_string(name, NULL), - scheme_write_to_string(rib->timestamp, NULL), - done_rib_pos)); - } - - other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; - if (SCHEME_PAIRP(other_env)) - free_id_rename = extract_free_id_info(SCHEME_CDR(other_env)); - else - free_id_rename = NULL; - other_env = filter_cached_env(other_env, prec_ribs); - if (SCHEME_VOIDP(other_env)) { - int rib_dep; - other_env = resolve_env(stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); - if (rib_dep) { - scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); - return NULL; - } - if (!prec_ribs) { - if (free_id_rename) - ok = CONS(other_env, free_id_rename); - else - ok = other_env; - SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; - ok = NULL; - } else { - ok = extend_cached_env(SCHEME_VEC_ELS(v)[2+vvsize+ii], other_env, prec_ribs, 0); - SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; - ok = NULL; - } - } - - if (!WRAP_POS_END_P(prev) - || SCHEME_PAIRP(v2l)) { - WRAP_POS w3; - Scheme_Object *vp, **vrdp; - - /* Check marks (now that we have the correct barriers). */ - WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (!same_marks(&w2, &w, other_env)) { - other_env = NULL; - } - - if (other_env) { - /* A simplified table needs to have the final answer, so - fold conversions from the rest of the wraps. In the case - of ribs, the "rest" can include earlier rib renamings. - Otherwise, check simplications accumulated in v2l (possibly from a - previously simplified tail in the same cache). Finally, - try prev (from a previously simplified tail in an earlier - round of simplifying). */ - int rib_found = 0; - if (done_rib_pos) { - for (j = 0; j < done_rib_pos; j++) { - if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+j], name)) { - rib_found = 1; - prev_env = SCHEME_VEC_ELS(v2)[2+size+j]; - orig_prev_env = prev_env; - if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); - if (SAME_OBJ(prev_env, other_env)) { - if (SCHEME_FALSEP(rib_delim) - || SAME_OBJ(v2_rib_delims[j], rib_delim) - || !is_in_rib_delim(prev_env, rib_delim)) { - ok = SCHEME_VEC_ELS(v)[0]; - ok_replace = v2; - ok_replace_index = 2 + size + j; - ok_replace_rd = v2_rib_delims; - if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) - free_id_rename = SCHEME_CDR(orig_prev_env); - } - } else { - EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); - ok = NULL; - } - break; - } - } - } - if (!rib_found) { - int passed_mutable = 0; - WRAP_POS_COPY(w3, prev); - svl = v2l; - svrdl = v2rdl; - for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) { - if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1; - if (SCHEME_PAIRP(svl)) { - vp = SCHEME_CAR(svl); - if (svrdl) - vrdp = (Scheme_Object **)SCHEME_CAR(svrdl); - else - vrdp = NULL; - } else { - vp = WRAP_POS_FIRST(w3); - vrdp = NULL; - } - if (SCHEME_VECTORP(vp)) { - psize = SCHEME_RENAME_LEN(vp); - for (j = 0; j < psize; j++) { - if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+j], name)) { - prev_env = SCHEME_VEC_ELS(vp)[2+psize+j]; - orig_prev_env = prev_env; - if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); - if (SAME_OBJ(prev_env, other_env) - && (SCHEME_FALSEP(rib_delim) - || (vrdp && (SAME_OBJ(vrdp[j], rib_delim))) - || !is_in_rib_delim(prev_env, rib_delim))) { - ok = SCHEME_VEC_ELS(v)[0]; - if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) - free_id_rename = SCHEME_CDR(orig_prev_env); - } else { - EXPLAIN_S(fprintf(stderr, - " not matching deeper %s\n", - scheme_write_to_string(other_env, NULL))); - ok = NULL; - /* Alternate time/space tradeoff: could be - SCHEME_VEC_ELS(vp)[2+psize+j], - which is the value from prev */ - } - if (ok && SCHEME_PAIRP(svl) && !passed_mutable - && (SCHEME_FALSEP(rib_delim) || vrdp)) { - /* Can overwrite old map, instead - of adding a new one. */ - ok_replace = vp; - ok_replace_index = 2 + psize + j; - ok_replace_rd = vrdp; - ok_replace_rd_index = j; - } - break; - } - } - if (j < psize) - break; - } - if (SCHEME_PAIRP(svl)) { - svl = SCHEME_CDR(svl); - if (svrdl) svrdl = SCHEME_CDR(svrdl); - } else { - WRAP_POS_INC(w3); - } - } - if (WRAP_POS_END_P(w3) && SCHEME_NULLP(svl) && SCHEME_FALSEP(other_env)) - ok = SCHEME_VEC_ELS(v)[0]; - } - } else - ok = NULL; - } else { - if (!SCHEME_FALSEP(other_env)) { - EXPLAIN_S(fprintf(stderr, " not based on #f\n")); - ok = NULL; - } else { - WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (same_marks(&w2, &w, scheme_false)) - ok = SCHEME_VEC_ELS(v)[0]; - else { - EXPLAIN_S(fprintf(stderr, " not matching marks\n")); - ok = NULL; - } - } - } - - if (ok) { - if (free_id_rename) - ok = CONS(ok, free_id_rename); - if (ok_replace) { - EXPLAIN_S(fprintf(stderr, " replace mapping %s\n", - scheme_write_to_string(ok, NULL))); - SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok; - ok_replace_rd[ok_replace_rd_index] = rib_delim; - } else { - EXPLAIN_S(fprintf(stderr, " add mapping %s\n", - scheme_write_to_string(ok, NULL))); - SCHEME_VEC_ELS(v2)[2+size+pos] = ok; - v2_rib_delims[pos] = rib_delim; - pos++; - } - } else { - EXPLAIN_S(fprintf(stderr, " no mapping %s\n", - scheme_write_to_string(name, NULL))); - } - } else { - EXPLAIN_S(fprintf(stderr, " skip %s %s %p\n", - scheme_write_to_string(name, NULL), - scheme_write_to_string(rib->timestamp, NULL), - rib)); - } - ii++; - } - - if (!pos) - v2 = empty_simplified; - else { - if (pos != size) { - /* Shrink simplified vector */ - v = v2; - v2 = scheme_make_vector(2 + (2 * pos), NULL); - for (i = 0; i < pos; i++) { - SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i]; - SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i]; - } - } - - SCHEME_VEC_ELS(v2)[0] = scheme_false; - for (i = 0; i < pos; i++) { - if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(v2)[2+pos+i])) - SCHEME_VEC_ELS(v2)[0] = scheme_true; - } - - SCHEME_VEC_ELS(v2)[1] = scheme_false; - maybe_install_rename_hash_table(v2); - - if (no_rib_mutation) { - /* Sometimes we generate the same simplified lex table, so - look for an equivalent one in the cache. */ - v = scheme_hash_get(lex_cache, scheme_true); - if (!v) { - v = (Scheme_Object *)scheme_make_hash_table_equal(); - scheme_hash_set(lex_cache, scheme_true, v); - } - svl = scheme_hash_get((Scheme_Hash_Table *)v, v2); - if (svl) - v2 = svl; - else - scheme_hash_set((Scheme_Hash_Table *)v, v2, v2); - } - } - - EXPLAIN_S({ - int k; - for (k = 2; k < SCHEME_VEC_SIZE(v2); k++) { - fprintf(stderr, " %p[%d]: %s\n", v2, k, scheme_write_to_string(SCHEME_VEC_ELS(v2)[k], NULL)); - } - }); - - v2l = CONS(v2, v2l); - v2rdl = scheme_make_raw_pair((Scheme_Object *)v2_rib_delims, v2rdl); - } - - WRAP_POS_DEC(w); - } - - if (!constrain_to_syms) { - v = scheme_hash_get(lex_cache, key); - if (!v && !prev_prec_ribs) { - /* no dependency on ribs, so we can simply cache this result: */ - scheme_hash_set(lex_cache, key, v2l); - } else { - Scheme_Hash_Table *ht; - if (v && SCHEME_HASHTP(v)) - ht = (Scheme_Hash_Table *)v; - else { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - } - if (v && !SCHEME_HASHTP(v)) - scheme_hash_set(ht, scheme_false, v); - scheme_hash_set(ht, prev_prec_ribs ? prev_prec_ribs : scheme_false, v2l); - scheme_hash_set(lex_cache, key, (Scheme_Object *)ht); - } - end_mutable = v2l; - } - - stack = SCHEME_CDR(stack); - } - - EXPLAIN_R(printf(" ... done\n")); - - return v2l; -} - -static Scheme_Object *add_rename_to_stack(Module_Renames* mrn, Scheme_Object *stack, - Scheme_Marshal_Tables *mt, - Scheme_Object *a) -{ - Scheme_Object *local_key; - - local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn); - if (!local_key) { - /* Convert hash table to vector, etc.: */ - int i, j, count = 0; - Scheme_Hash_Table *ht; - Scheme_Object *l, *fil; - - ht = mrn->ht; - count = ht->count; - l = scheme_make_vector(count * 2, NULL); - for (i = ht->size, j = 0; i--; ) { - if (ht->vals[i]) { - SCHEME_VEC_ELS(l)[j++] = ht->keys[i]; - fil = ht->vals[i]; - SCHEME_VEC_ELS(l)[j++] = fil; - } - } - - ht = mrn->free_id_renames; - if (ht && ht->count) { - count = ht->count; - fil = scheme_make_vector(count * 2, NULL); - for (i = ht->size, j = 0; i--; ) { - if (ht->vals[i]) { - SCHEME_VEC_ELS(fil)[j++] = ht->keys[i]; - SCHEME_VEC_ELS(fil)[j++] = ht->vals[i]; - } - } - } else - fil = NULL; - - if (mrn->marked_names && mrn->marked_names->count) { - Scheme_Object *d = scheme_null, *p; - - for (i = mrn->marked_names->size; i--; ) { - if (mrn->marked_names->vals[i] - /* #f mapping used to store reverse-map cache: */ - && !SCHEME_FALSEP(mrn->marked_names->keys[i])) { - p = CONS(mrn->marked_names->keys[i], - mrn->marked_names->vals[i]); - d = CONS(p, d); - } - } - - if (fil) - fil = CONS(fil, d); + while (!SCHEME_NULLP(l)) { + p = scheme_make_pair(scheme_make_pair(multi_scope_to_vector(SCHEME_CAR(SCHEME_CAR(l)), mt), + SCHEME_CDR(SCHEME_CAR(l))), + scheme_null); + if (last) + SCHEME_CDR(last) = p; else - fil = d; - } else if (fil) - fil = CONS(fil, scheme_null); + first = p; + last = p; + l = SCHEME_CDR(l); + } + + first = intern_tails(first, ht); + + if (SCHEME_FALLBACKP(multi_scopes)) + first = make_fallback_pair(first, scheme_false); + + if (fb_last) + SCHEME_FALLBACK_REST(fb_last) = first; else - fil = scheme_null; - - l = CONS(l, fil); - - if (SCHEME_PAIRP(mrn->unmarshal_info)) - l = CONS(mrn->unmarshal_info, l); - - l = CONS(mrn->set_identity, l); - l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l); - l = CONS(mrn->phase, l); - - local_key = scheme_marshal_lookup(mt, a); - if (local_key) - scheme_marshal_using_key(mt, a); - else { - local_key = scheme_marshal_wrap_set(mt, a, l); - } - } else { - scheme_marshal_using_key(mt, (Scheme_Object *)mrn); + fb_first = first; + fb_last = first; + + if (SCHEME_FALLBACKP(multi_scopes)) + multi_scopes = SCHEME_FALLBACK_REST(multi_scopes); + else + break; } - return CONS(local_key, stack); + + if (SCHEME_FALLBACKP(fb_first)) + fb_first = intern_fallback_tails(fb_first, ht); + + return fb_first; } -static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, - Scheme_Object *w_in, - Scheme_Marshal_Tables *mt, - Scheme_Hash_Table *rns, - int just_simplify) +static Scheme_Object *wraps_to_datum(Scheme_Stx *stx, Scheme_Marshal_Tables *mt) { - Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *prec_ribs = scheme_null; - WRAP_POS w; - Scheme_Hash_Table *lex_cache, *reverse_map; - int stack_size = 0, specific_to_datum = 0; + Scheme_Hash_Table *ht; + Scheme_Object *shifts, *simples, *multi, *v, *vec; - if (!rns) - rns = mt->rns; - - if (just_simplify) { - a = scheme_hash_get(rns, w_in); - } else { - if (mt->same_map) { - a = scheme_hash_get(mt->same_map, w_in); - if (a) - w_in = a; - } - a = scheme_marshal_lookup(mt, w_in); + if (mt->pass < 0) { + /* This is the pass to discover reachable scopes. */ + add_reachable_scopes(stx->scopes->simple_scopes, mt); + add_reachable_multi_scopes(stx->scopes->multi_scopes, mt); + return scheme_void; } - if (a) { - if (just_simplify) - return a; + + ht = mt->intern_map; + if (!ht) { + /* We need to compare a modidx using `eq?`, because shifting + is based on `eq`ness. */ + ht = scheme_make_hash_table_equal_modix_eq(); + mt->intern_map = ht; + } + + shifts = intern_tails(drop_export_registries(stx->shifts), ht); + simples = intern_tails(scopes_to_sorted_list(stx->scopes->simple_scopes), ht); + multi = marshal_multi_scopes(stx->scopes->multi_scopes, mt, ht); + + vec = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(vec)[0] = shifts; + SCHEME_VEC_ELS(vec)[1] = simples; + SCHEME_VEC_ELS(vec)[2] = multi; + + v = scheme_hash_get(ht, vec); + if (!v) { + v = scheme_make_marshal_shared(vec); + scheme_hash_set(ht, vec, v); + } + + return v; +} + +static Scheme_Object *marshal_free_id_info(Scheme_Object *id_plus_phase, Scheme_Marshal_Tables *mt) +{ + Scheme_Stx *stx = (Scheme_Stx *)SCHEME_CAR(id_plus_phase); + + return scheme_make_pair(scheme_make_pair(stx->val, wraps_to_datum(stx, mt)), + SCHEME_CDR(id_plus_phase)); +} + +static Scheme_Object *marshal_bindings(Scheme_Object *l, Scheme_Marshal_Tables *mt) +/* l is a pair for one binding, or an mlist of bindings */ +{ + Scheme_Object *r, *scopes, *v; + + r = scheme_null; + + while (!SCHEME_NULLP(l)) { + if (SCHEME_PAIRP(l)) + scopes = (Scheme_Object *)SCHEME_BINDING_SCOPES(l); else { - scheme_marshal_using_key(mt, w_in); - return a; + STX_ASSERT(SCHEME_MPAIRP(l)); + scopes = (Scheme_Object *)SCHEME_BINDING_SCOPES(SCHEME_CAR(l)); } - } - WRAP_POS_INIT(w, w_in); - - stack = scheme_null; - - lex_cache = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_void); - if (!lex_cache) { - lex_cache = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(rns, scheme_void, (Scheme_Object *)lex_cache); - } - - if (!just_simplify) - stx_datum = scheme_false; - - /* Ensures that all lexical tables in w have been simplified */ - simplifies = simplify_lex_renames(w_in, lex_cache, stx_datum); - - if (mt) - scheme_marshal_push_refs(mt); - - while (!WRAP_POS_END_P(w)) { - a = WRAP_POS_FIRST(w); - old_key = WRAP_POS_KEY(w); - WRAP_POS_INC(w); - if (SCHEME_NUMBERP(a)) { - /* Mark numbers get parenthesized */ - if (!WRAP_POS_END_P(w) && SAME_OBJ(a, WRAP_POS_FIRST(w))) - WRAP_POS_INC(w); /* delete cancelled mark */ - else { - if (just_simplify) - stack = CONS(a, stack); - else - stack = CONS(CONS(a, scheme_null), stack); - stack_size++; - } - } else if (SCHEME_VECTORP(a) - || SCHEME_RIBP(a)) { - if (SCHEME_RIBP(a) || (SCHEME_VEC_SIZE(a) > 2)) { - - if (SCHEME_RIBP(a) || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[2])) { - /* a is not a simplified table; need to look it up; if - simplifies is non-null, then we already have found a list - of simplified tables for the current wrap segment. */ - if (SCHEME_RIBP(a)) { - if (nonempty_rib((Scheme_Lexical_Rib *)a)) - prec_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, prec_ribs); - } - a = SCHEME_CAR(simplifies); - /* used up one simplification: */ - simplifies = SCHEME_CDR(simplifies); - } - - /* Simplification may have left us with the null table: */ - if (SCHEME_VEC_SIZE(a) > 2) { - if (just_simplify) { - stack = CONS(a, stack); - } else { - Scheme_Object *local_key; - - local_key = scheme_marshal_lookup(mt, a); - if (local_key) { - scheme_marshal_using_key(mt, a); - a = local_key; - } else { - a = scheme_marshal_wrap_set(mt, a, a); - } - stack = CONS(a, stack); - } - stack_size++; - } - } - /* else empty simplified vector, which we drop */ - } else if (SCHEME_RIB_DELIMP(a)) { - /* simpliciation eliminates the need for rib delimiters */ - } else if (SCHEME_RENAMESP(a) - || SCHEME_RENAMES_SETP(a)) { - int which = 0, all_redundant = 1; - - while (1) { - Module_Renames *mrn; - int redundant = 0; - - if (SCHEME_RENAMESP(a)) { - if (!which) { - mrn = (Module_Renames *)a; - which++; - } else - break; - } else { - /* flatten sets */ - Module_Renames_Set *s = (Module_Renames_Set *)a; - mrn = NULL; - while (!mrn - && (which - 2 < (s->other_phases - ? s->other_phases->size - : 0))) { - if (!which) - mrn = s->rt; - else if (which == 1) - mrn = s->et; - else - mrn = (Module_Renames *)s->other_phases->vals[which - 2]; - which++; - } - if (!mrn - && (which - 2 >= (s->other_phases - ? s->other_phases->size - : 0))) - break; - } - - if (mrn) { - if (mrn->kind == mzMOD_RENAME_MARKED) { - /* Not useful if there's no marked names. */ - redundant = ((mrn->sealed >= STX_SEAL_ALL) - && (!mrn->marked_names || !mrn->marked_names->count) - && (!mrn->free_id_renames || !mrn->free_id_renames->count) - && SCHEME_NULLP(mrn->shared_pes)); - if (!redundant) { - /* Otherwise, watch out for multiple instances of the same rename: */ - WRAP_POS l; - Scheme_Object *la; - - WRAP_POS_COPY(l,w); - - for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { - la = WRAP_POS_FIRST(l); - if (SAME_OBJ(a, la)) { - redundant = 1; - break; - } - } - } - } else { - /* Check for later [non]module rename at the same phase: */ - Scheme_Object *phase; - WRAP_POS l; - Scheme_Object *la; - - WRAP_POS_COPY(l,w); - - phase = mrn->phase; - - for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { - la = WRAP_POS_FIRST(l); - if (SCHEME_RENAMESP(la)) { - Module_Renames *lrn = (Module_Renames *)WRAP_POS_FIRST(l); - if ((lrn->kind == mrn->kind) - && (same_phase(lrn->phase, phase))) { - /* mrn is redundant */ - redundant = 1; - break; - } - } else if (SCHEME_RENAMES_SETP(la)) { - Module_Renames_Set *s = (Module_Renames_Set *)WRAP_POS_FIRST(l); - if ((s->kind == mrn->kind) - && extract_renames(s, phase)) { - redundant = 1; - break; - } - } else if (SCHEME_BOXP(la)) - phase = reverse_phase_shift(phase, SCHEME_VEC_ELS(SCHEME_BOX_VAL(la))[0]); - } - } - - if (!redundant) { - all_redundant = 0; - if (just_simplify) { - stack = CONS((Scheme_Object *)mrn, stack); - } else { - if (mrn->free_id_renames) { - /* resolve all renamings */ - int i; - Scheme_Object *b; - for (i = mrn->free_id_renames->size; i--; ) { - if (mrn->free_id_renames->vals[i]) { - if (SCHEME_STXP(mrn->free_id_renames->vals[i])) { - int sealed; - Scheme_Hash_Table *free_id_recur; - - free_id_recur = make_recur_table(); - b = extract_module_free_id_binding((Scheme_Object *)mrn, - mrn->free_id_renames->keys[i], - mrn->free_id_renames->vals[i], - &sealed, - free_id_recur); - release_recur_table(free_id_recur); - if (!sealed) { - free_id_recur = make_recur_table(); - extract_module_free_id_binding((Scheme_Object *)mrn, - mrn->free_id_renames->keys[i], - mrn->free_id_renames->vals[i], - &sealed, - free_id_recur); - scheme_signal_error("write: unsealed local-definition or module context" - " found in syntax object"); - } - scheme_hash_set(mrn->free_id_renames, mrn->free_id_renames->keys[i], b); - } - } - } - } - - if (mrn->kind == mzMOD_RENAME_TOPLEVEL) { - if (same_phase(mrn->phase, scheme_make_integer(0))) - stack = CONS(scheme_true, stack); - else - stack = CONS(scheme_false, stack); - } else { - stack = add_rename_to_stack(mrn, stack, mt, a); - } - } - stack_size++; - } - } - } - - if (all_redundant) { - /* The rename isn't actually redundant if we need to keep the - rename-set identity --- but we can simplify to just the - identity. */ - WRAP_POS l; - Scheme_Object *la, *this_set_identity, *set_identity; - int kind; - - if (SCHEME_RENAMESP(a)) { - this_set_identity = ((Module_Renames *)a)->set_identity; - kind = ((Module_Renames *)a)->kind; - } else { - this_set_identity = ((Module_Renames_Set *)a)->set_identity; - kind = ((Module_Renames_Set *)a)->kind; - } - - if (kind != mzMOD_RENAME_TOPLEVEL) { - WRAP_POS_COPY(l,w); - - for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { - la = WRAP_POS_FIRST(l); - if (SCHEME_RENAMESP(la)) - set_identity = ((Module_Renames *)la)->set_identity; - else if (SCHEME_RENAMES_SETP(la)) - set_identity = ((Module_Renames_Set *)la)->set_identity; - else if (SCHEME_BOXP(la)) { - set_identity = SCHEME_VEC_ELS(SCHEME_BOX_VAL(la))[5]; - if (SAME_OBJ(set_identity, this_set_identity)) - set_identity = scheme_false; - else - set_identity = NULL; - } else - set_identity = NULL; - - if (set_identity) { - if (SAME_OBJ(set_identity, this_set_identity)) { - all_redundant = 0; - break; - } else - break; - } - } - - if (all_redundant) { - Scheme_Hash_Table *identity_map; - Scheme_Object *key; - - identity_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_eof); - if (!identity_map) { - identity_map = scheme_make_hash_table_equal(); - scheme_hash_set(rns, scheme_eof, (Scheme_Object *)identity_map); - } - - key = scheme_make_pair(scheme_make_integer(kind), this_set_identity); - - la = scheme_hash_get(identity_map, key); - if (!la) { - la = scheme_make_module_rename(scheme_make_integer(0), kind, NULL, NULL, this_set_identity); - ((Module_Renames *)la)->sealed = STX_SEAL_ALL; - scheme_hash_set(identity_map, key, la); - } - - if (just_simplify) - stack = CONS(la, stack); - else - stack = add_rename_to_stack((Module_Renames *)la, stack, mt, a); - stack_size++; - } - } - } - } else if (SCHEME_SYMBOLP(a)) { - /* mark barrier */ - stack = CONS(a, stack); - stack_size++; - } else if (SCHEME_HASHTP(a)) { - /* chain-specific cache; drop it */ - } else if (SCHEME_PRUNEP(a)) { - if (SCHEME_SYMBOLP(stx_datum)) { - /* Assuming that there are lex renames later, then this chain is - specific to this wrap. */ - specific_to_datum = 1; - } - if (!just_simplify) - a = scheme_box(SCHEME_BOX_VAL(a)); - stack = CONS(a, stack); - stack_size++; - } else { - /* box, a phase shift */ - /* We used to drop a phase shift if there are no following - rename tables. However, the phase shift also identifies - the source module, which can be relevant. So, keep the - phase shift. */ - /* Need the phase shift, but drop the export table, if any: */ - Scheme_Object *local_key; - Scheme_Object *aa; - - aa = SCHEME_BOX_VAL(a); - if (SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[3]) - || (!just_simplify && SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[4]))) { - if (mt) - a = scheme_hash_get(mt->shift_map, aa); - else - a = scheme_hash_get(rns, aa); - if (!a) { - a = scheme_make_vector(6, NULL); - SCHEME_VEC_ELS(a)[0] = SCHEME_VEC_ELS(aa)[0]; - SCHEME_VEC_ELS(a)[1] = SCHEME_VEC_ELS(aa)[1]; - SCHEME_VEC_ELS(a)[2] = SCHEME_VEC_ELS(aa)[2]; - SCHEME_VEC_ELS(a)[3] = scheme_false; - if (just_simplify) - SCHEME_VEC_ELS(a)[4] = SCHEME_VEC_ELS(aa)[4]; - else - SCHEME_VEC_ELS(a)[4] = scheme_false; - SCHEME_VEC_ELS(a)[5] = SCHEME_VEC_ELS(aa)[5]; - a = scheme_box(a); - scheme_hash_set(rns, aa, a); - } - } - - if (!just_simplify) { - local_key = scheme_marshal_lookup(mt, a); - if (local_key) { - scheme_marshal_using_key(mt, a); - a = local_key; - } else { - a = scheme_marshal_wrap_set(mt, a, a); - } - } - - stack = CONS(a, stack); - stack_size++; - } - } - - /* Double-check for equivalent list in table (after simplification): */ - if (mt && mt->pass) { - /* No need to check for later passes, since mt->same_map - covers the equivalence. */ - } else { - if (mt) { - reverse_map = mt->reverse_map; - } else { - reverse_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_undefined); - } - if (!reverse_map) { - reverse_map = scheme_make_hash_table_equal(); - if (mt) - mt->reverse_map = reverse_map; + if (!any_unreachable_scope((Scheme_Scope_Set *)scopes, mt)) { + if (SCHEME_PAIRP(l)) + v = SCHEME_BINDING_VAL(l); else - scheme_hash_set(rns, scheme_undefined, (Scheme_Object *)reverse_map); + v = SCHEME_BINDING_VAL(SCHEME_CAR(l)); + if (SCHEME_MPAIRP(v)) { + /* has a `free-id=?` equivalence; the marshaled form of a scope's content + cannot contain a syntax object, so we keep just the syntax object's symbol + and scopes */ + v = scheme_make_pair(SCHEME_CAR(v), marshal_free_id_info(SCHEME_CDR(v), mt)); + v = scheme_box(v); /* a box indicates `free-id=?` info */ + } + v = intern_one(v, mt->intern_map); + scopes = intern_tails(scopes_to_sorted_list((Scheme_Scope_Set *)scopes), + mt->intern_map); + r = scheme_make_pair(intern_one(scheme_make_pair(scopes, v), mt->intern_map), r); } - old_key = scheme_hash_get(reverse_map, stack); - if (old_key) { - if (just_simplify) { - return scheme_hash_get(rns, old_key); + + if (SCHEME_MPAIRP(l)) + l = SCHEME_CDR(l); + else + l = scheme_null; + } + + if (!SCHEME_NULLP(r)) + r = intern_one(r, mt->intern_map); + + return r; +} + +Scheme_Object *scheme_scope_marshal_content(Scheme_Object *m, Scheme_Marshal_Tables *mt) +{ + Scheme_Hash_Tree *ht; + Scheme_Object *v, *l, *r, *l2, *tab, *scopes, *key, *val; + intptr_t i, j; + + if (!mt->identity_map) + init_identity_map(mt); + + v = scheme_hash_get(mt->identity_map, m); + if (v) + return v; + + v = ((Scheme_Scope *)m)->bindings; + if (v) { + int count; + + if (SCHEME_VECTORP(v)) { + ht = NULL; + l2 = NULL; + count = 1; + } else { + if (SCHEME_RPAIRP(v)) { + ht = (Scheme_Hash_Tree *)SCHEME_CAR(v); + l2 = SCHEME_CDR(v); } else { - a = scheme_marshal_lookup(mt, old_key); - if (!mt->same_map) { - Scheme_Hash_Table *same_map; - same_map = scheme_make_hash_table(SCHEME_hash_ptr); - mt->same_map = same_map; + STX_ASSERT(SCHEME_HASHTRP(v)); + ht = (Scheme_Hash_Tree *)v; + l2 = NULL; + } + count = ht->count; + } + + /* convert to a vector, pruning unreachable and adjusting + encoding of `free-identifier=?` equivalences */ + tab = scheme_make_vector(2 * count, NULL); + j = 0; + if (!ht) { + STX_ASSERT(SCHEME_VECTORP(v)); + r = marshal_bindings(scheme_make_pair((Scheme_Object *)SCHEME_VEC_BINDING_SCOPES(v), + SCHEME_VEC_BINDING_VAL(v)), + mt); + if (SCHEME_NULLP(r)) { + /* no reachable bindings */ + } else { + SCHEME_VEC_ELS(tab)[j++] = SCHEME_VEC_BINDING_KEY(v); + SCHEME_VEC_ELS(tab)[j++] = r; + } + } else { + i = -1; + while ((i = scheme_hash_tree_next(ht, i)) != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + r = marshal_bindings(val, mt); + + if (SCHEME_NULLP(r)) { + /* no reachable bindings */ + } else { + STX_ASSERT(j < (2 * count)); + SCHEME_VEC_ELS(tab)[j++] = key; + SCHEME_VEC_ELS(tab)[j++] = r; } - scheme_hash_set(mt->same_map, w_in, old_key); - /* nevermind references that we saw when creating `stack': */ - scheme_marshal_pop_refs(mt, 0); - scheme_marshal_using_key(mt, old_key); - return a; } } - if (!specific_to_datum) - scheme_hash_set(reverse_map, stack, w_in); - } - - /* Convert to a chunk if just simplifying. - (Note that we do this after looking for equivalent stacks.) */ - if (just_simplify) { - if (stack_size) { - Wrap_Chunk *wc; - int i; - wc = MALLOC_WRAP_CHUNK(stack_size); - wc->type = scheme_wrap_chunk_type; - wc->len = stack_size; - for (i = stack_size; i--; stack = SCHEME_CDR(stack)) { - wc->a[i] = SCHEME_CAR(stack); - } - stack = CONS((Scheme_Object *)wc, scheme_null); + if (j < SCHEME_VEC_SIZE(tab)) { + /* shrink vector: */ + r = scheme_make_vector(j, NULL); + memcpy(SCHEME_VEC_ELS(r), SCHEME_VEC_ELS(tab), j * sizeof(Scheme_Object *)); } else - stack= scheme_null; - } - - if (mt) { - /* preserve references that we saw when creating `stack': */ - scheme_marshal_pop_refs(mt, 1); - } + r = tab; - /* Remember this wrap set: */ - if (just_simplify) { - if (!specific_to_datum) - scheme_hash_set(rns, w_in, stack); - return stack; - } else { - return scheme_marshal_wrap_set(mt, w_in, stack); - } + /* convert scopes+pes to scope + unmarshal request */ + for (l = l2; l; l = SCHEME_CDR(l)) { + STX_ASSERT(SCHEME_RPAIRP(l)); + v = SCHEME_CDR(SCHEME_CAR(l)); + if (PES_BINDINGP(v)) { + l2 = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(l2)[0] = SCHEME_VEC_ELS(v)[0]; + SCHEME_VEC_ELS(l2)[1] = SCHEME_VEC_ELS(v)[2]; + SCHEME_VEC_ELS(l2)[3] = SCHEME_VEC_ELS(v)[4]; + v = unmarshal_excepts_to_vector(SCHEME_VEC_ELS(v)[3]); + SCHEME_VEC_ELS(l2)[2] = v; + v = l2; + } else if (PES_UNMARSHAL_DESCP(v)) { + if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[0])) { + /* never unmarshaled, so keep it */ + } else { + /* this shouldn't happen, because it should have been + replaced on unmarshal, but discard it if we get here */ + v = NULL; + } + } else { + STX_ASSERT(0); + } + if (v) { + scopes = intern_tails(scopes_to_sorted_list((Scheme_Scope_Set *)SCHEME_CAR(SCHEME_CAR(l))), + mt->intern_map); + r = scheme_make_pair(scheme_make_pair(scopes, v), r); + } + } + + v = scheme_make_pair(scheme_make_integer(SCHEME_SCOPE_KIND(m)), r); + } else + v = scheme_make_integer(SCHEME_SCOPE_KIND(m)); + + scheme_hash_set(mt->identity_map, m, v); + + return v; } /*========================================================================*/ @@ -6605,7 +5790,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, ; where is not a pair, vector, or box */ -static Scheme_Object *extract_for_common_wrap(Scheme_Object *a, int get_mark, int pair_ok) +static Scheme_Object *extract_for_common_wrap(Scheme_Object *a, int get_scope, int pair_ok) { /* We only share wraps for things constucted with pairs and atomic (w.r.t. syntax) values. */ @@ -6617,14 +5802,14 @@ static Scheme_Object *extract_for_common_wrap(Scheme_Object *a, int get_mark, in if (SCHEME_PAIRP(v)) { if (pair_ok && SAME_OBJ(SCHEME_CAR(v), scheme_true)) { /* A pair with shared wraps for its elements */ - if (get_mark) + if (get_scope) return SCHEME_CDR(a); else return SCHEME_CDR(v); } } else if (!SCHEME_NULLP(v) && !SCHEME_BOXP(v) && !SCHEME_VECTORP(v) && !SCHEME_HASHTRP(v) && !prefab_p(v)) { /* It's atomic. */ - if (get_mark) + if (get_scope) return SCHEME_CDR(a); else return v; @@ -6654,7 +5839,7 @@ static void lift_common_wraps(Scheme_Object *l, Scheme_Object *common_wraps, int #ifdef DO_STACK_CHECK static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, - int with_marks, + int with_scopes, Scheme_Marshal_Tables *mt); static Scheme_Object *syntax_to_datum_k(void) @@ -6671,7 +5856,7 @@ static Scheme_Object *syntax_to_datum_k(void) #endif static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, - int with_marks, /* abs > 1 => marshal; negative => implicitly tainted */ + int with_scopes, /* abs > 1 => marshal; negative => implicitly tainted */ Scheme_Marshal_Tables *mt) { Scheme_Stx *stx = (Scheme_Stx *)o; @@ -6684,7 +5869,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, { Scheme_Thread *p = scheme_current_thread; p->ku.k.p1 = (void *)o; - p->ku.k.i1 = with_marks; + p->ku.k.i1 = with_scopes; p->ku.k.p3 = (void *)mt; return scheme_handle_stack_overflow(syntax_to_datum_k); } @@ -6692,13 +5877,13 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, #endif SCHEME_USE_FUEL(1); - if (with_marks) { + if (with_scopes) { /* Propagate wraps: */ scheme_stx_content((Scheme_Object *)stx); - if (with_marks > 0) { + if (with_scopes > 0) { if (is_tainted((Scheme_Object *)stx)) { add_taint = 1; - with_marks = -with_marks; + with_scopes = -with_scopes; } else if (is_armed((Scheme_Object *)stx)) { add_taint = 2; } @@ -6716,7 +5901,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, cnt++; - a = syntax_to_datum_inner(SCHEME_CAR(v), with_marks, mt); + a = syntax_to_datum_inner(SCHEME_CAR(v), with_scopes, mt); p = CONS(a, scheme_null); @@ -6727,7 +5912,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, last = p; v = SCHEME_CDR(v); - if (with_marks) { + if (with_scopes) { a = extract_for_common_wrap(a, 1, 1); if (!common_wraps) { if (a) @@ -6739,13 +5924,13 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, } } if (!SCHEME_NULLP(v)) { - v = syntax_to_datum_inner(v, with_marks, mt); + v = syntax_to_datum_inner(v, with_scopes, mt); SCHEME_CDR(last) = v; - if (with_marks) { + if (with_scopes) { v = extract_for_common_wrap(v, 1, 0); if (v && SAME_OBJ(common_wraps, v)) { - converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0); + converted_wraps = wraps_to_datum(stx, mt); if (SAME_OBJ(common_wraps, converted_wraps)) lift_common_wraps(first, common_wraps, cnt, 1); else @@ -6754,7 +5939,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, common_wraps = scheme_false; } - if (((with_marks > 1) || (with_marks < -1)) && SCHEME_FALSEP(common_wraps)) { + if (((with_scopes > 1) || (with_scopes < -1)) && SCHEME_FALSEP(common_wraps)) { /* v is likely a pair, and v's car might be a pair, which means that the datum->syntax part won't be able to detect that v is a "non-pair" @@ -6762,21 +5947,21 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, length before the terminal to datum->syntax: */ first = scheme_make_pair(scheme_make_integer(cnt), first); } - } else if (with_marks && SCHEME_TRUEP(common_wraps)) { - converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0); + } else if (with_scopes && SCHEME_TRUEP(common_wraps)) { + converted_wraps = wraps_to_datum(stx, mt); if (SAME_OBJ(common_wraps, converted_wraps)) lift_common_wraps(first, common_wraps, cnt, 0); else common_wraps = scheme_false; } - if (with_marks && SCHEME_TRUEP(common_wraps)) { + if (with_scopes && SCHEME_TRUEP(common_wraps)) { first = scheme_make_pair(scheme_true, first); } result = first; } else if (SCHEME_BOXP(v)) { - v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), with_marks, mt); + v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), with_scopes, mt); result = scheme_box(v); SCHEME_SET_IMMUTABLE(result); } else if (SCHEME_VECTORP(v)) { @@ -6786,7 +5971,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, r = scheme_make_vector(size, NULL); for (i = 0; i < size; i++) { - a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], with_marks, mt); + a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], with_scopes, mt); SCHEME_VEC_ELS(r)[i] = a; } @@ -6797,12 +5982,12 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, Scheme_Object *key, *val; mzlonglong i; - ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); + ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht)); i = scheme_hash_tree_next(ht, -1); while (i != -1) { scheme_hash_tree_index(ht, i, &key, &val); - val = syntax_to_datum_inner(val, with_marks, mt); + val = syntax_to_datum_inner(val, with_scopes, mt); ht2 = scheme_hash_tree_set(ht2, key, val); i = scheme_hash_tree_next(ht, i); } @@ -6815,7 +6000,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); for (i = 0; i < size; i++) { - a = syntax_to_datum_inner(s->slots[i], with_marks, mt); + a = syntax_to_datum_inner(s->slots[i], with_scopes, mt); s->slots[i] = a; } @@ -6823,9 +6008,9 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, } else result = v; - if ((with_marks > 1) || (with_marks < -1)) { + if ((with_scopes > 1) || (with_scopes < -1)) { if (!converted_wraps) - converted_wraps = wraps_to_datum(stx->val, stx->wraps, mt, NULL, 0); + converted_wraps = wraps_to_datum(stx, mt); result = CONS(result, converted_wraps); if (add_taint == 1) result = scheme_make_vector(1, result); /* vector of size 1 => tainted */ @@ -6838,17 +6023,17 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, return result; } -Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks, +Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_scopes, Scheme_Marshal_Tables *mt) { Scheme_Object *v; - if (mt) + if (mt && (mt->pass >= 0)) scheme_marshal_push_refs(mt); - v = syntax_to_datum_inner(stx, with_marks, mt); + v = syntax_to_datum_inner(stx, with_scopes, mt); - if (mt) { + if (mt && (mt->pass >= 0)) { /* A symbol+wrap combination is likely to be used multiple times. This is a relatively minor optimization in .zo size, since v is already fairly compact, but it also avoids @@ -6879,73 +6064,174 @@ Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks, } /*========================================================================*/ -/* datum->wraps */ +/* datum->syntax */ /*========================================================================*/ -static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Object *n, *a = _a; +#define return_NULL return NULL - if (SCHEME_INTP(a) && IS_POSMARK(a)) - a = scheme_make_integer(-SCHEME_INT_VAL(a)); - else if (!SCHEME_NUMBERP(a)) - return NULL; - else - a = scheme_intern_symbol(scheme_number_to_string(10, a)); - - /* Picked a mapping yet? */ - n = scheme_hash_get(ut->rns, a); - if (!n) { - /* Map marshaled mark to a new mark. */ - n = scheme_new_mark(); - scheme_hash_set(ut->rns, a, n); +Scheme_Scope_Set *list_to_scope_set(Scheme_Object *l, Scheme_Unmarshal_Tables *ut) +{ + Scheme_Scope_Set *scopes = NULL; + Scheme_Object *r = scheme_null, *scope; + + while (!SCHEME_NULLP(l)) { + if (!SCHEME_PAIRP(l)) return_NULL; + scopes = (Scheme_Scope_Set *)scheme_hash_get(ut->rns, l); + if (scopes) + break; + r = scheme_make_pair(l, r); + l = SCHEME_CDR(l); } - - /* Really a mark? */ - if (!SCHEME_NUMBERP(n)) - return NULL; - return n; + if (!scopes) scopes = empty_scope_set; + + while (!SCHEME_NULLP(r)) { + l = SCHEME_CAR(r); + + scope = scope_unmarshal_content(SCHEME_CAR(l), ut); + if (!scope) return_NULL; + + scopes = scope_set_set(scopes, scope, scheme_true); + scheme_hash_set(ut->rns, l, (Scheme_Object *)scopes); + + r = SCHEME_CDR(r); + } + + return scopes; } -#if 0 -# define return_NULL return (printf("%d\n", __LINE__), NULL) -#else -# define return_NULL return NULL -#endif - -static int ok_phase(Scheme_Object *o) { - return (SCHEME_INTP(o) || SCHEME_BIGNUMP(o) || SCHEME_FALSEP(o)); -} -static int ok_phase_index(Scheme_Object *o) { - return ok_phase(o); -} - -static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok, - Scheme_Unmarshal_Tables *ut) +static Scheme_Hash_Table *vector_to_multi_scope(Scheme_Object *mht, Scheme_Unmarshal_Tables *ut) { - int count, i; - Scheme_Object *key, *p0, *p; + /* Convert multi-scope vector to hash table */ + intptr_t i, len; + Scheme_Hash_Table *multi_scope; + Scheme_Object *scope; - if (!SCHEME_VECTORP(a)) return_NULL; - count = SCHEME_VEC_SIZE(a); - if (count & 0x1) return_NULL; + if (!SCHEME_VECTORP(mht)) return_NULL; - for (i = 0; i < count; i+= 2) { - key = SCHEME_VEC_ELS(a)[i]; - p0 = SCHEME_VEC_ELS(a)[i+1]; - - if (!SCHEME_SYMBOLP(key)) return_NULL; + multi_scope = (Scheme_Hash_Table *)scheme_hash_get(ut->rns, mht); + if (multi_scope) return multi_scope; - p = p0; + multi_scope = scheme_make_hash_table(SCHEME_hash_ptr); + len = SCHEME_VEC_SIZE(mht); + if (!(len & 1)) return_NULL; + + multi_scope = (Scheme_Hash_Table *)new_multi_scope(SCHEME_VEC_ELS(mht)[len-1]); + len -= 1; + + /* A multi-scope might refer back to itself via free-id=? info: */ + scheme_hash_set(ut->rns, mht, (Scheme_Object *)multi_scope); + + for (i = 0; i < len; i += 2) { + if (!SCHEME_PHASEP(SCHEME_VEC_ELS(mht)[i])) + return_NULL; + scope = SCHEME_VEC_ELS(mht)[i+1]; + scope = scope_unmarshal_content(scope, ut); + if (!scope) return_NULL; + if (!SCHEME_SCOPE_HAS_OWNER((Scheme_Scope *)scope)) + return_NULL; + if (((Scheme_Scope_With_Owner *)scope)->owner_multi_scope) + return_NULL; + scheme_hash_set(multi_scope, SCHEME_VEC_ELS(mht)[i], scope); + ((Scheme_Scope_With_Owner *)scope)->owner_multi_scope = (Scheme_Object *)multi_scope; + ((Scheme_Scope_With_Owner *)scope)->phase = SCHEME_VEC_ELS(mht)[i]; + } + + return multi_scope; +} + +Scheme_Object *unmarshal_multi_scopes(Scheme_Object *multi_scopes, + Scheme_Unmarshal_Tables *ut) +{ + Scheme_Hash_Table *multi_scope; + Scheme_Object *l, *mm_l; + + mm_l = multi_scopes; + + while (1) { + l = mm_l; + if (SCHEME_FALLBACKP(l)) + l = SCHEME_FALLBACK_FIRST(l); + + for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + if (!SCHEME_PAIRP(l)) return_NULL; + if (!SCHEME_PAIRP(SCHEME_CAR(l))) return_NULL; + if (SCHEME_VECTORP(SCHEME_CAR(SCHEME_CAR(l)))) { + multi_scope = vector_to_multi_scope(SCHEME_CAR(SCHEME_CAR(l)), ut); + if (!multi_scope) return_NULL; + SCHEME_CAR(SCHEME_CAR(l)) = (Scheme_Object *)multi_scope; + } else { + /* rest of list must be converted already, too */ + break; + } + } + + if (SCHEME_FALLBACKP(mm_l)) + mm_l = SCHEME_FALLBACK_REST(mm_l); + else + break; + } + + return multi_scopes; +} + + +static Scheme_Object *datum_to_wraps(Scheme_Object *w, + Scheme_Unmarshal_Tables *ut) +{ + Scheme_Scope_Table *st; + Scheme_Scope_Set *scopes; + Scheme_Object *l; + + l = scheme_hash_get(ut->rns, w); + if (l) { + if (!SCHEME_PAIRP(l) + || !SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_scope_table_type)) + return NULL; + return l; + } + + if (!SCHEME_VECTORP(w) + || ((SCHEME_VEC_SIZE(w) != 3) + && (SCHEME_VEC_SIZE(w) != 4))) + return_NULL; + + st = MALLOC_ONE_TAGGED(Scheme_Scope_Table); + st->so.type = scheme_scope_table_type; + + scopes = list_to_scope_set(SCHEME_VEC_ELS(w)[1], ut); + if (!scopes) return NULL; + st->simple_scopes = scopes; + + l = unmarshal_multi_scopes(SCHEME_VEC_ELS(w)[2], ut); + if (!l) return NULL; + st->multi_scopes = l; + + l = scheme_make_pair((Scheme_Object *)st, SCHEME_VEC_ELS(w)[0]); + scheme_hash_set(ut->rns, w, l); + + return l; +} + +static Scheme_Object *validate_binding(Scheme_Object *p) +{ + if (SCHEME_SYMBOLP(p)) { + /* Ok: local binding */ + } else { + if (SCHEME_PAIRP(p) && SCHEME_SYMBOLP(SCHEME_CAR(p))) { + /* Inpsector descriptor ok */ + p = SCHEME_CDR(p); + } + if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { - /* Ok */ + /* Ok */ } else if (SCHEME_PAIRP(p)) { Scheme_Object *midx; midx = SCHEME_CAR(p); - if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) + if (SCHEME_TRUEP(midx) + && !SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) return_NULL; if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { @@ -6985,9 +6271,9 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl ap = SCHEME_CDR(ap); /* import_phase_plus_nominal_phase */ if (SCHEME_PAIRP(ap)) { - if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL; - if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL; - } else if (!ok_phase_index(ap)) + if (!SCHEME_PHASE_SHIFTP(SCHEME_CAR(ap))) return_NULL; + if (!SCHEME_PHASE_SHIFTP(SCHEME_CDR(ap))) return_NULL; + } else if (!SCHEME_PHASE_SHIFTP(ap)) return_NULL; } else return_NULL; @@ -6997,488 +6283,124 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl if (!SCHEME_SYMBOLP(ap)) return_NULL; } - } else if (lex_ok) { - Scheme_Object *ap; - if (!SCHEME_BOXP(p)) - return_NULL; - ap = SCHEME_BOX_VAL(p); - if (!SCHEME_PAIRP(ap)) - return_NULL; - if (!SCHEME_SYMBOLP(SCHEME_CAR(ap))) - return_NULL; - ap = SCHEME_CDR(ap); - if (!SCHEME_SYMBOLP(ap) && !SCHEME_FALSEP(ap)) - return_NULL; - } else - return_NULL; - - scheme_hash_set(ht, key, p0); + } } return scheme_true; } -static Scheme_Object *datum_to_wraps(Scheme_Object *w, - Scheme_Unmarshal_Tables *ut) +static Scheme_Object *unmarshal_free_id_info(Scheme_Object *p, Scheme_Unmarshal_Tables *ut) { - Scheme_Object *a, *wraps_key, *local_key; - int stack_size, decoded; - Wrap_Chunk *wc; + Scheme_Object *o, *phase; - /* ut->rns maps numbers (table indices) to renaming tables, and negative - numbers (negated fixnum marks) and symbols (interned marks) to marks.*/ + phase = SCHEME_CDR(p); + p = SCHEME_CAR(p); + o = scheme_make_stx(SCHEME_CAR(p), NULL, NULL); + p = datum_to_wraps(SCHEME_CDR(p), ut); + if (!p) return_NULL; - /* This function has to be defensive, since `w' can originate in - untrusted .zo bytecodes. Return NULL for bad wraps. */ + ((Scheme_Stx *)o)->scopes = (Scheme_Scope_Table *)SCHEME_CAR(p); + STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)o)->scopes), scheme_scope_table_type)); + ((Scheme_Stx *)o)->shifts = SCHEME_CDR(p); - if (SCHEME_INTP(w)) { - wraps_key = w; - w = scheme_unmarshal_wrap_get(ut, wraps_key, &decoded); - if (decoded && (!w || !SCHEME_LISTP(w))) /* list => a wrap, as opposed to a mark, etc. */ - return_NULL; - if (decoded) - return w; - } else { - /* not shared */ - wraps_key = NULL; - } - - stack_size = scheme_proper_list_length(w); - if (stack_size < 1) { - scheme_unmarshal_wrap_set(ut, wraps_key, scheme_null); - return scheme_null; - } else if (stack_size < 2) { - wc = NULL; - } else { - wc = MALLOC_WRAP_CHUNK(stack_size); - wc->type = scheme_wrap_chunk_type; - wc->len = stack_size; - } - - a = NULL; - - while (!SCHEME_NULLP(w)) { - a = SCHEME_CAR(w); - if (SCHEME_NUMBERP(a)) { - /* Re-use rename table or env rename */ - local_key = a; - a = scheme_unmarshal_wrap_get(ut, local_key, &decoded); - if (decoded && (!a || SCHEME_LISTP(a))) /* list => a whole wrap, no good as an element */ - return_NULL; - } else { - /* Not shared */ - local_key = NULL; - decoded = 0; - } - - if (decoded) { - /* done */ - } else if (SCHEME_PAIRP(a) - && SCHEME_NULLP(SCHEME_CDR(a)) - && SCHEME_NUMBERP(SCHEME_CAR(a))) { - /* Mark */ - a = unmarshal_mark(SCHEME_CAR(a), ut); - if (!a) return_NULL; - } else if (SCHEME_VECTORP(a)) { - /* A (simplified) rename table. */ - int sz = SCHEME_VEC_SIZE(a), cnt, i, any_free_id_renames = 0; - Scheme_Object *v; - - /* Make sure that it's a well-formed rename table. */ - if (sz < 2) - return_NULL; - cnt = (sz - 2) >> 1; - for (i = 0; i < cnt; i++) { - if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i + 2])) - return_NULL; - v = SCHEME_VEC_ELS(a)[i + cnt + 2]; - if (SCHEME_SYMBOLP(v)) { - /* simple target-environment symbol */ - } else if (SCHEME_PAIRP(v)) { - /* target-environment symbol paired with free-id=? rename info */ - any_free_id_renames = 1; - if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) - return_NULL; - v = SCHEME_CDR(v); - if (SCHEME_PAIRP(v)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) - return_NULL; - v = SCHEME_CDR(v); - if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v)) - return_NULL; - } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_free_id_info_type)) { - if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0]) - || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1]) - || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2]) - || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[3]) - || !ok_phase(SCHEME_VEC_ELS(v)[4]) - || !ok_phase(SCHEME_VEC_ELS(v)[5]) - || !ok_phase(SCHEME_VEC_ELS(v)[6])) - return_NULL; - } else - return_NULL; - } else - return_NULL; - } - - SCHEME_VEC_ELS(a)[0] = (any_free_id_renames ? scheme_true : scheme_false); - - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) { - SCHEME_VEC_ELS(a)[1] = scheme_false; - maybe_install_rename_hash_table(a); - } - - /* It's ok: */ - scheme_unmarshal_wrap_set(ut, local_key, a); - } else if (SCHEME_PAIRP(a)) { - /* A rename table: - - ([#t] [unmarshal] #( ...) - . (( ( . ) ...) ...)) ; <- marked_names - where a is actually two values, one of: - - - - ( . ) - */ - Scheme_Object *mns; - Module_Renames *mrn; - Scheme_Object *p, *key; - int kind; - Scheme_Object *phase, *set_identity; - - if (!SCHEME_PAIRP(a)) return_NULL; - - /* Convert list to rename table: */ - - if (SAME_OBJ(SCHEME_CAR(a), scheme_true)) { - scheme_signal_error("leftover plus-kernel"); - } - - if (!SCHEME_PAIRP(a)) return_NULL; - phase = SCHEME_CAR(a); - if (!ok_phase(phase)) return_NULL; - a = SCHEME_CDR(a); - - if (!SCHEME_PAIRP(a)) return_NULL; - if (SCHEME_TRUEP(SCHEME_CAR(a))) - kind = mzMOD_RENAME_MARKED; - else - kind = mzMOD_RENAME_NORMAL; - a = SCHEME_CDR(a); - - if (!SCHEME_PAIRP(a)) return_NULL; - set_identity = unmarshal_mark(SCHEME_CAR(a), ut); - if (!set_identity) return_NULL; - a = SCHEME_CDR(a); - - mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, - NULL, NULL, - set_identity); - - if (!SCHEME_PAIRP(a)) return_NULL; - mns = SCHEME_CDR(a); - a = SCHEME_CAR(a); - - if (!SCHEME_VECTORP(a)) { - /* Unmarshall info: */ - Scheme_Object *ml = a, *mli, *first = scheme_null, *last = NULL, *ai; - while (SCHEME_PAIRP(ml)) { - ai = SCHEME_CAR(ml); - mli = ai; - if (!SCHEME_PAIRP(mli)) return_NULL; - - /* A module path index: */ - p = SCHEME_CAR(mli); - if (!(SCHEME_SYMBOLP(p) - || SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type))) - return_NULL; - mli = SCHEME_CDR(mli); - - if (!SCHEME_PAIRP(mli)) return_NULL; - - /* A phase/dimension index k */ - p = SCHEME_CAR(mli); - if (!ok_phase_index(p)) - return_NULL; - - p = SCHEME_CDR(mli); - if (SCHEME_PAIRP(p) && (SCHEME_PAIRP(SCHEME_CAR(p)) - || SCHEME_VECTORP(SCHEME_CAR(p)))) { - /* list of marks or a vector of marks and bdg: */ - Scheme_Object *m_first = scheme_null, *m_last = NULL, *mp, *after_marks, *bdg; - - after_marks = SCHEME_CDR(p); - mli = SCHEME_CAR(p); - - if (SCHEME_VECTORP(mli)) { - if (SCHEME_VEC_SIZE(mli) != 2) return_NULL; - bdg = SCHEME_VEC_ELS(mli)[1]; - mli = SCHEME_VEC_ELS(mli)[0]; - } else - bdg = NULL; - - while (SCHEME_PAIRP(mli)) { - p = SCHEME_CAR(mli); - p = unmarshal_mark(p, ut); - if (!p) return_NULL; - - mp = scheme_make_pair(p, scheme_null); - if (m_last) - SCHEME_CDR(m_last) = mp; - else - m_first = mp; - m_last = mp; - - mli = SCHEME_CDR(mli); - } - if (!SCHEME_NULLP(mli)) return_NULL; - - mli = m_first; - - if (bdg) { - if (!SCHEME_SYMBOLP(bdg) && !SCHEME_FALSEP(bdg)) { - if (SCHEME_MARKP(bdg)) - bdg = unmarshal_mark(bdg, ut); - else { - m_first = scheme_null; - m_last = NULL; - while (SCHEME_PAIRP(bdg)) { - p = SCHEME_CAR(bdg); - if (!SCHEME_MARKP(p)) return_NULL; - p = unmarshal_mark(p, ut); - mp = scheme_make_pair(p, scheme_null); - if (m_last) - SCHEME_CDR(m_last) = mp; - else - m_first = mp; - m_last = mp; - bdg = SCHEME_CDR(bdg); - } - if (!SCHEME_NULLP(bdg) - || !SCHEME_PAIRP(m_first) - || !SCHEME_PAIRP(SCHEME_CDR(m_first))) - return_NULL; - bdg = m_first; - } - } - mli = scheme_make_vector(2, mli); - SCHEME_VEC_ELS(mli)[1] = bdg; - } - - /* Rebuild for unmarshaled marks: */ - ai = scheme_make_pair(SCHEME_CAR(ai), - scheme_make_pair(SCHEME_CADR(ai), - scheme_make_pair(mli, after_marks))); - - p = after_marks; - } - - if (ok_phase_index(p)) { - /* For a shared table: src-phase-index */ - } else { - /* For a non-shared table: (list* src-phase-index exceptions prefix), after k */ - mli = p; - if (!SCHEME_PAIRP(mli)) return_NULL; - - p = SCHEME_CAR(mli); - if (!ok_phase_index(p)) - return_NULL; - mli = SCHEME_CDR(mli); - - if (!SCHEME_PAIRP(mli)) return_NULL; - - /* A list of symbols: */ - p = SCHEME_CAR(mli); - while (SCHEME_PAIRP(p)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return_NULL; - p = SCHEME_CDR(p); - } - if (!SCHEME_NULLP(p)) return_NULL; - - /* #f or a symbol: */ - p = SCHEME_CDR(mli); - if (!SCHEME_SYMBOLP(p) && !SCHEME_FALSEP(p)) return_NULL; - } - - ml = SCHEME_CDR(ml); - - /* rebuild, in case we converted marks */ - p = scheme_make_pair(ai, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - if (!SCHEME_NULLP(ml)) return_NULL; - - mrn->unmarshal_info = first; - if (SCHEME_PAIRP(first)) - mrn->needs_unmarshal = 1; - - if (!SCHEME_PAIRP(mns)) return_NULL; - a = SCHEME_CAR(mns); - mns = SCHEME_CDR(mns); - } - - if (!datum_to_module_renames(a, mrn->ht, 0, ut)) - return_NULL; - - /* Extract free-id=? renames, if any */ - if (SCHEME_PAIRP(mns) && SCHEME_VECTORP(SCHEME_CAR(mns))) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - mrn->free_id_renames = ht; - if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1, ut)) - return_NULL; - mns = SCHEME_CDR(mns); - } - - /* Extract the mark-rename table, if any: */ - if (SCHEME_PAIRP(mns)) { - Scheme_Hash_Table *ht; - Scheme_Object *ll, *kkey, *kfirst, *klast, *kp; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - for (; SCHEME_PAIRP(mns); mns = SCHEME_CDR(mns)) { - p = SCHEME_CAR(mns); - if (!SCHEME_PAIRP(p)) return_NULL; - key = SCHEME_CAR(p); - p = SCHEME_CDR(p); - if (!SCHEME_SYMBOLP(key)) return_NULL; - - ll = scheme_null; - - /* Convert marks */ - for (; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) { - a = SCHEME_CAR(p); - if (!SCHEME_PAIRP(a)) return_NULL; - kkey = SCHEME_CDR(a); - if (!SCHEME_SYMBOLP(kkey)) return_NULL; - - kfirst = scheme_null; - klast = NULL; - a = SCHEME_CAR(a); - if (SCHEME_MARKP(a)) { - kfirst = unmarshal_mark(a, ut); - } else { - Scheme_Object *bdg = NULL; - - if (SCHEME_VECTORP(a)) { - if (SCHEME_VEC_SIZE(a) != 2) return_NULL; - bdg = SCHEME_VEC_ELS(a)[1]; - if (SCHEME_SYMBOLP(bdg)) { - /* ok */ - } else if (SCHEME_MARKP(bdg)) { - bdg = unmarshal_mark(bdg, ut); - } else { - Scheme_Object *bl = scheme_null; - while (SCHEME_PAIRP(bdg)) { - if (SCHEME_MARKP(SCHEME_CAR(bdg))) - bl = scheme_make_pair(unmarshal_mark(SCHEME_CAR(bdg), ut), - bl); - else - break; - bdg = SCHEME_CDR(bdg); - } - if (!SCHEME_NULLP(bdg)) - return_NULL; - bdg = scheme_reverse(bl); - } - a = SCHEME_VEC_ELS(a)[0]; - } - - for (; SCHEME_PAIRP(a); a = SCHEME_CDR(a)) { - kp = CONS(unmarshal_mark(SCHEME_CAR(a), ut), scheme_null); - if (!klast) - kfirst = kp; - else - SCHEME_CDR(klast) = kp; - klast = kp; - } - if (!SCHEME_NULLP(a)) { - if (bdg && SCHEME_MARKP(a) && SCHEME_NULLP(kfirst)) - kfirst = unmarshal_mark(a, ut); - else - return_NULL; - } - - if (bdg) { - a = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(a)[0] = kfirst; - SCHEME_VEC_ELS(a)[1] = bdg; - kfirst = a; - } - } - - ll = CONS(CONS(kfirst, kkey), ll); - } - - scheme_hash_set(ht, key, ll); - - if (!SCHEME_NULLP(p)) return_NULL; - } - if (!SCHEME_NULLP(mns)) return_NULL; - - mrn->marked_names = ht; - } - - scheme_unmarshal_wrap_set(ut, local_key, (Scheme_Object *)mrn); - - scheme_seal_module_rename((Scheme_Object *)mrn, STX_SEAL_ALL); - - a = (Scheme_Object *)mrn; - } else if (SAME_OBJ(a, scheme_true) - || SCHEME_FALSEP(a)) { - /* current env rename */ - Scheme_Env *env; - - env = scheme_get_env(NULL); - scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); - a = scheme_get_module_rename_from_set(env->rename_set, - (SCHEME_FALSEP(a) - ? scheme_make_integer(1) - : scheme_make_integer(0)), - 1); - } else if (SCHEME_SYMBOLP(a)) { - /* mark barrier */ - } else if (SCHEME_BOXP(a)) { - if (SCHEME_PAIRP(SCHEME_BOX_VAL(a))) { - /* prune context */ - a = make_prune_context(SCHEME_BOX_VAL(a)); - } else { - /* must be a phase shift */ - Scheme_Object *vec, *cancel_id; - vec = SCHEME_BOX_VAL(a); - if (!SCHEME_VECTORP(vec)) return_NULL; - if (SCHEME_VEC_SIZE(vec) != 6) return_NULL; - - cancel_id = SCHEME_VEC_ELS(vec)[5]; - if (SCHEME_TRUEP(cancel_id)) { - cancel_id = unmarshal_mark(cancel_id, ut); - SCHEME_VEC_ELS(vec)[5] = cancel_id; - } - } - } else { - return_NULL; - } - - if (wc) - wc->a[--stack_size] = a; - - w = SCHEME_CDR(w); - } - - if (wc) - a = (Scheme_Object *)wc; - a = CONS(a, scheme_null); - - scheme_unmarshal_wrap_set(ut, wraps_key, a); - - return a; + return scheme_make_pair(o, phase); } -/*========================================================================*/ -/* datum->syntax */ -/*========================================================================*/ +Scheme_Object *scope_unmarshal_content(Scheme_Object *box, Scheme_Unmarshal_Tables *ut) +{ + Scheme_Object *l = NULL, *l2, *r, *b, *m, *c, *free_id; + Scheme_Hash_Tree *ht; + Scheme_Scope_Set *scopes; + intptr_t i, len; + + if (SAME_OBJ(box, root_scope)) + return root_scope; + + r = scheme_hash_get(ut->rns, box); + if (r) + return r; + + if (!SCHEME_BOXP(box)) return_NULL; + c = SCHEME_BOX_VAL(box); + + if (SCHEME_INTP(c)) { + m = scheme_new_scope(SCHEME_INT_VAL(c)); + c = NULL; + } else if (SCHEME_PAIRP(c)) { + m = scheme_new_scope(SCHEME_INT_VAL(SCHEME_CAR(c))); + c = SCHEME_CDR(c); + } else + m = scheme_new_scope(SCHEME_STX_MACRO_SCOPE); + scheme_hash_set(ut->rns, box, m); + /* Since we've created the scope before unmarshaling its content, + cycles among scopes are ok. */ + + if (!c) return m; + + while (SCHEME_PAIRP(c)) { + if (!SCHEME_PAIRP(SCHEME_CAR(c))) return_NULL; + scopes = list_to_scope_set(SCHEME_CAR(SCHEME_CAR(c)), ut); + l = scheme_make_raw_pair(scheme_make_pair((Scheme_Object *)scopes, + SCHEME_CDR(SCHEME_CAR(c))), + l); + c = SCHEME_CDR(c); + } + + if (!SCHEME_VECTORP(c)) return_NULL; + + len = SCHEME_VEC_SIZE(c); + if (len & 1) return_NULL; + + /* If the vector length is 2, and if the only key has a single + binding, then we could generate the compact vector form of + bindings. For now, we just build the hash table. */ + + ht = empty_hash_tree; + for (i = 0; i < len; i += 2) { + l2 = SCHEME_VEC_ELS(c)[i+1]; + r = scheme_null; + while (SCHEME_PAIRP(l2)) { + if (!SCHEME_PAIRP(SCHEME_CAR(l2))) return_NULL; + scopes = list_to_scope_set(SCHEME_CAR(SCHEME_CAR(l2)), ut); + if (!scopes) return_NULL; + + b = SCHEME_CDR(SCHEME_CAR(l2)); + if (SCHEME_BOXP(b)) { + /* has `free-id=?` info */ + b = SCHEME_BOX_VAL(b); + free_id = unmarshal_free_id_info(SCHEME_CDR(b), ut); + if (!free_id) return_NULL; + b = SCHEME_CAR(b); + } else + free_id = NULL; + if (!validate_binding(b)) return_NULL; + + if (free_id) + b = scheme_make_mutable_pair(b, free_id); + + b = scheme_make_pair((Scheme_Object *)scopes, b); + + if (SCHEME_NULLP(r) && SCHEME_NULLP(SCHEME_CDR(l2))) { + /* leave r as a single binding */ + r = b; + } else + r = scheme_make_mutable_pair(b, r); + + l2 = SCHEME_CDR(l2); + } + + ht = scheme_hash_tree_set(ht, SCHEME_VEC_ELS(c)[i], r); + } + + if (!l) + l = (Scheme_Object *)ht; + else + l = scheme_make_raw_pair((Scheme_Object *)ht, l); + + ((Scheme_Scope *)m)->bindings = l; + + return m; +} #ifdef DO_STACK_CHECK @@ -7599,6 +6521,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, all nested objects (as indicated by a box for stx_wraps). */ wraps = datum_to_wraps(wraps, ut); + if (!wraps) return_NULL; do_not_unpack_wraps = 1; sub_stx_wraps = (Scheme_Stx *)scheme_box(wraps); o = SCHEME_CDR(o); @@ -7685,7 +6608,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, else ht1 = (Scheme_Hash_Tree *)o; - ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht1) & 0x3); + ht2 = scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(ht1)); i = scheme_hash_tree_next(ht1, -1); while (i != -1) { @@ -7725,8 +6648,10 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, else result = scheme_make_stx(result, stx_src->srcloc, NULL); - if (tainted) - (void)add_taint_to_stx(result, 0); + if (tainted) { + int mutate = MUTATE_STX_OBJ; + (void)add_taint_to_stx(result, &mutate); + } else if (armed) { /* Arm with #f as the inspector; #f is replaced by a specific inspector when the encloding code is instanted */ @@ -7742,12 +6667,18 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, if (!wraps) return_NULL; } - ((Scheme_Stx *)result)->wraps = wraps; + ((Scheme_Stx *)result)->scopes = (Scheme_Scope_Table *)SCHEME_CAR(wraps); + STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)result)->scopes), scheme_scope_table_type)); + ((Scheme_Stx *)result)->shifts = SCHEME_CDR(wraps); } else if (SCHEME_FALSEP((Scheme_Object *)stx_wraps)) { /* wraps already nulled */ } else { /* Note: no propagation will be needed for SUBSTX */ - ((Scheme_Stx *)result)->wraps = stx_wraps->wraps; + ((Scheme_Stx *)result)->scopes = stx_wraps->scopes; + STX_ASSERT(SAME_TYPE(SCHEME_TYPE(((Scheme_Stx *)result)->scopes), scheme_scope_table_type)); + ((Scheme_Stx *)result)->shifts = stx_wraps->shifts; + if (SCHEME_VECTORP(((Scheme_Stx *)result)->shifts)) + ((Scheme_Stx *)result)->shifts = SCHEME_VEC_ELS(((Scheme_Stx *)result)->shifts)[0]; } if (hashed) { @@ -7776,7 +6707,7 @@ static Scheme_Object *general_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src, Scheme_Object *stx_wraps, int can_graph, int copy_props) - /* If stx_wraps is a hash table, then `o' includes marks. + /* If stx_wraps is a hash table, then `o' includes scopes. If copy_props > 0, properties are copied from src. If copy_props != 1 or 0, then taint armings are copied from src, too, but src must not be tainted. */ @@ -7859,131 +6790,6 @@ Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o, return general_datum_to_syntax(o, ut, scheme_false, scheme_false, can_graph, 0); } -/*========================================================================*/ -/* simplify */ -/*========================================================================*/ - -#ifdef DO_STACK_CHECK -static void simplify_syntax_inner(Scheme_Object *o, - Scheme_Hash_Table *rns); - -static Scheme_Object *simplify_syntax_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Hash_Table *rns = (Scheme_Hash_Table *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - simplify_syntax_inner(o, rns); - - return NULL; -} -#endif - -static void simplify_syntax_inner(Scheme_Object *o, - Scheme_Hash_Table *rns) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *v; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)o; - p->ku.k.p2 = (void *)rns; - scheme_handle_stack_overflow(simplify_syntax_k); - return; - } - } -#endif - SCHEME_USE_FUEL(1); - - /* Propagate wraps: */ - scheme_stx_content((Scheme_Object *)stx); - - if (rns) { - v = wraps_to_datum(stx->val, stx->wraps, NULL, rns, 1); - stx->wraps = v; - } - - v = stx->val; - - if (SCHEME_PAIRP(v)) { - while (SCHEME_PAIRP(v)) { - simplify_syntax_inner(SCHEME_CAR(v), rns); - v = SCHEME_CDR(v); - } - if (!SCHEME_NULLP(v)) { - simplify_syntax_inner(v, rns); - } - } else if (SCHEME_BOXP(v)) { - simplify_syntax_inner(SCHEME_BOX_VAL(v), rns); - } else if (SCHEME_VECTORP(v)) { - int size = SCHEME_VEC_SIZE(v), i; - - for (i = 0; i < size; i++) { - simplify_syntax_inner(SCHEME_VEC_ELS(v)[i], rns); - } - } else if (SCHEME_HASHTRP(v)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v; - Scheme_Object *key, *val; - mzlonglong i; - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - simplify_syntax_inner(val, rns); - i = scheme_hash_tree_next(ht, i); - } - } else if (prefab_p(v)) { - Scheme_Structure *s = (Scheme_Structure *)v; - int size = s->stype->num_slots, i; - - for (i = 0; i < size; i++) { - simplify_syntax_inner(s->slots[i], rns); - } - } -} - -Scheme_Object *scheme_new_stx_simplify_cache() -{ - return (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr); -} - -void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) -{ -#if 0 - if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) { - fprintf(stderr, - "simplifying... %s\n", - scheme_write_to_string(resolve_env(stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), - NULL)); - explain_simp = 1; - } -#endif - - if (cache) { - Scheme_Hash_Table *rns; - - rns = (Scheme_Hash_Table *)cache; - - simplify_syntax_inner(stx, rns); - } - -#if 0 - if (explain_simp) { - explain_simp = 0; - fprintf(stderr, "simplified: %s\n", - scheme_write_to_string(resolve_env(stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), - NULL)); - } -#endif -} - /*========================================================================*/ /* Racket functions and helpers */ /*========================================================================*/ @@ -8126,7 +6932,8 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv) } if (!SCHEME_FALSEP(argv[0]) && !is_clean(argv[0])) { - add_taint_to_stx(src, 0); + int mutate = MUTATE_STX_OBJ; + add_taint_to_stx(src, &mutate); } return src; @@ -8236,8 +7043,8 @@ static Scheme_Object *syntax_tainted_p(int argc, Scheme_Object **argv) static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) { Scheme_Stx *stx; - WRAP_POS awl; - WRAP_POS ewl; + Scheme_Object *key, *val; + intptr_t i; if (!SCHEME_STXP(argv[0])) scheme_wrong_contract("syntax-original?", "syntax?", 0, argc, argv); @@ -8246,7 +7053,7 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) if (stx->props) { if (SAME_OBJ(stx->props, STX_SRCTAG)) { - /* Check for marks... */ + /* Check for scopes... */ } else { Scheme_Object *e; @@ -8262,13 +7069,18 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) } else return scheme_false; - WRAP_POS_INIT(awl, stx->wraps); - WRAP_POS_INIT_END(ewl); + /* Look for any non-original scope: */ + i = scope_set_next(stx->scopes->simple_scopes, -1); + while (i != -1) { + scope_set_index(stx->scopes->simple_scopes, i, &key, &val); - if (same_marks(&awl, &ewl, scheme_false)) - return scheme_true; - else - return scheme_false; + if (SCHEME_SCOPE_KIND(key) == SCHEME_STX_MACRO_SCOPE) + return scheme_false; + + i = scope_set_next(stx->scopes->simple_scopes, i); + } + + return scheme_true; } Scheme_Object *scheme_stx_property(Scheme_Object *_stx, @@ -8331,7 +7143,7 @@ Scheme_Object *scheme_stx_property(Scheme_Object *_stx, if (val) { l = CONS(CONS(key, val), l); - stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx); + stx = (Scheme_Stx *)clone_stx((Scheme_Object *)stx, NULL); stx->props = l; return (Scheme_Object *)stx; @@ -8396,7 +7208,7 @@ static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv) Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from) { if (!SAME_OBJ(((Scheme_Stx *)from)->srcloc, empty_srcloc)) { - to = clone_stx(to); + to = clone_stx(to, NULL); ((Scheme_Stx *)to)->srcloc = ((Scheme_Stx *)from)->srcloc; } @@ -8405,19 +7217,21 @@ Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from) static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], Scheme_Object *p) { - Scheme_Object *r, *delta, *taint_p; + Scheme_Object *r, *delta, *taint_p, *phase; + int mode = SCHEME_STX_ADD; r = argv[0]; + if (argc > 1) + mode = scheme_get_introducer_mode("syntax-delta-introducer", 1, argc, argv); if (!SCHEME_STXP(r)) - scheme_wrong_contract("delta-introducer", "syntax?", 0, argc, argv); + scheme_wrong_contract("syntax-delta-introducer", "syntax?", 0, argc, argv); delta = SCHEME_PRIM_CLOSURE_ELS(p)[0]; taint_p = SCHEME_PRIM_CLOSURE_ELS(p)[1]; + phase = SCHEME_PRIM_CLOSURE_ELS(p)[2]; - for(; !SCHEME_NULLP(delta); delta = SCHEME_CDR(delta)) { - r = scheme_add_remove_mark(r, SCHEME_CAR(delta)); - } + r = scheme_stx_adjust_scopes(r, (Scheme_Scope_Set *)delta, phase, mode); if (SCHEME_TRUEP(taint_p)) r = scheme_stx_taint(r); @@ -8455,11 +7269,28 @@ static Scheme_Object *extract_phase(const char *who, int pos, int argc, Scheme_O return phase; } +static Scheme_Object *syntax_debug_info(int argc, Scheme_Object **argv) +{ + Scheme_Object *phase; + int all_bindings; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-debug-info", "syntax?", 0, argc, argv); + + phase = extract_phase("syntax-debug-info", 1, argc, argv, + scheme_make_integer(0), 0); + + all_bindings = ((argc > 2) && SCHEME_TRUEP(argv[2])); + + return stx_debug_info((Scheme_Stx *)argv[0], phase, scheme_null, all_bindings); +} + Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) { - Scheme_Object *orig_m1, *m1, *m2, *delta, *a[2]; - int l1, l2; + Scheme_Object *a[3], *key, *val, *src; Scheme_Object *phase; + Scheme_Scope_Set *delta, *m2; + intptr_t i; if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) scheme_wrong_contract("make-syntax-delta-introducer", "identifier?", 0, argc, argv); @@ -8468,74 +7299,89 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) phase = extract_phase("make-syntax-delta-introducer", 2, argc, argv, scheme_make_integer(0), 1); - m1 = scheme_stx_extract_marks(argv[0]); - orig_m1 = m1; - l1 = scheme_list_length(m1); - delta = scheme_null; - if (SCHEME_FALSEP(argv[1])) { - m2 = scheme_false; - } else { - m2 = scheme_stx_extract_marks(argv[1]); + delta = extract_scope_set((Scheme_Stx *)argv[0], phase); - l2 = scheme_list_length(m2); + src = argv[1]; + if (!SCHEME_FALSEP(src)) { + m2 = extract_scope_set((Scheme_Stx *)src, phase); + if (!scope_subset(m2, delta)) + m2 = NULL; + } else + m2 = NULL; - while (l1 > l2) { - delta = CONS(SCHEME_CAR(m1), delta); - m1 = SCHEME_CDR(m1); - l1--; + if (!m2) { + src = scheme_stx_lookup_w_nominal(argv[1], phase, 1, + NULL, NULL, &m2, + NULL, NULL, NULL, NULL, NULL); + if (SCHEME_FALSEP(src)) + m2 = NULL; + } + + if (m2) { + i = scope_set_next(m2, -1); + while (i != -1) { + scope_set_index(m2, i, &key, &val); + if (scope_set_get(delta, key)) + delta = scope_set_set(delta, key, NULL); + + i = scope_set_next(m2, i); } } - if (!scheme_equal(m1, m2)) { - /* tails don't match, so keep all marks --- except - those that determine a module binding */ - int skipped = -1; - Scheme_Object *mod; - - mod = resolve_env(argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, - scheme_make_hash_table(SCHEME_hash_ptr)); - - if ((skipped == -1) && SCHEME_FALSEP(mod)) { - /* For top-level bindings, need to check the current environment's table, - because the identifier might not have the top level in its renamings. */ - Scheme_Env *env; - - if (scheme_current_thread->current_local_env) - env = scheme_current_thread->current_local_env->genv; - else - env = NULL; - if (!env) env = scheme_get_env(NULL); - if (env) { - scheme_tl_id_sym(env, argv[0], NULL, 0, NULL, &skipped); - } - } - - if (skipped > -1) { - /* Just keep the first `skipped' marks. */ - delta = scheme_null; - m1 = orig_m1; - while (skipped) { - delta = CONS(SCHEME_CAR(m1), delta); - m1 = SCHEME_CDR(m1); - skipped--; - } - } else { - /* Keep them all */ - while (l1) { - delta = CONS(SCHEME_CAR(m1), delta); - m1 = SCHEME_CDR(m1); - l1--; - } - } - } - - a[0] = delta; + a[0] = (Scheme_Object *)delta; if (scheme_stx_is_clean(argv[0])) a[1] = scheme_false; else a[1] = scheme_true; + a[2] = phase; - return scheme_make_prim_closure_w_arity(delta_introducer, 2, a, "delta-introducer", 1, 1); + return scheme_make_prim_closure_w_arity(delta_introducer, 3, a, "delta-introducer", 1, 2); +} + +Scheme_Object *scheme_stx_binding_union(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase) +{ + Scheme_Scope_Set *current, *m2; + Scheme_Object *key, *val; + intptr_t i; + int mutate = 0; + + current = extract_scope_set((Scheme_Stx *)o, phase); + m2 = extract_scope_set((Scheme_Stx *)b, phase); + + i = scope_set_next(m2, -1); + while (i != -1) { + scope_set_index(m2, i, &key, &val); + if (!scope_set_get(current, key)) { + o = stx_adjust_scope(o, key, phase, SCHEME_STX_ADD, &mutate); + } + + i = scope_set_next(m2, i); + } + + return o; +} + +Scheme_Object *scheme_stx_binding_subtract(Scheme_Object *o, Scheme_Object *b, Scheme_Object *phase) +{ + Scheme_Scope_Set *current, *m2; + Scheme_Object *key, *val; + intptr_t i; + int mutate = 0; + + current = extract_scope_set((Scheme_Stx *)o, phase); + m2 = extract_scope_set((Scheme_Stx *)b, phase); + + i = scope_set_next(m2, -1); + while (i != -1) { + scope_set_index(m2, i, &key, &val); + if (scope_set_get(current, key)) { + o = stx_adjust_scope(o, key, phase, SCHEME_STX_REMOVE, &mutate); + } + + i = scope_set_next(m2, i); + } + + return o; } static Scheme_Object *bound_eq(int argc, Scheme_Object **argv) @@ -8549,14 +7395,15 @@ static Scheme_Object *bound_eq(int argc, Scheme_Object **argv) phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0); - return (scheme_stx_env_bound_eq2(argv[0], argv[1], NULL, phase, phase) + return (scheme_stx_env_bound_eq2(argv[0], argv[1], phase, phase) ? scheme_true : scheme_false); } -static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_Object **argv) +static Scheme_Object *do_free_eq(const char *who, int delta, int argc, Scheme_Object **argv) { Scheme_Object *phase, *phase2; + int v; if (!SCHEME_STX_IDP(argv[0])) scheme_wrong_contract(who, "identifier?", 0, argc, argv); @@ -8573,33 +7420,35 @@ static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_ else phase2 = phase; - return (scheme_stx_module_eq3(argv[0], argv[1], phase, phase2, NULL) + v = scheme_stx_free_eq3(argv[0], argv[1], phase, phase2); + + return (v ? scheme_true : scheme_false); } -static Scheme_Object *module_eq(int argc, Scheme_Object **argv) +static Scheme_Object *free_eq(int argc, Scheme_Object **argv) { - return do_module_eq("free-identifier=?", 0, argc, argv); + return do_free_eq("free-identifier=?", 0, argc, argv); } -static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv) +static Scheme_Object *free_trans_eq(int argc, Scheme_Object **argv) { - return do_module_eq("free-transformer-identifier=?", 1, argc, argv); + return do_free_eq("free-transformer-identifier=?", 1, argc, argv); } -static Scheme_Object *module_templ_eq(int argc, Scheme_Object **argv) +static Scheme_Object *free_templ_eq(int argc, Scheme_Object **argv) { - return do_module_eq("free-template-identifier=?", -1, argc, argv); + return do_free_eq("free-template-identifier=?", -1, argc, argv); } -static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv) +static Scheme_Object *free_label_eq(int argc, Scheme_Object **argv) { - return do_module_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv); + return do_free_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv); } -static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv, - Scheme_Object *dphase, int get_symbol) +static Scheme_Object *do_free_binding(char *name, int argc, Scheme_Object **argv, + Scheme_Object *dphase, int get_symbol) { Scheme_Object *a, *m, *nom_mod, *nom_a, *phase; Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase; @@ -8628,67 +7477,70 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar phase = scheme_bin_plus(dphase, phase); } - m = scheme_stx_module_name(scheme_make_hash_table(SCHEME_hash_ptr), - &a, - phase, - &nom_mod, &nom_a, - &mod_phase, - &src_phase_index, - &nominal_src_phase, - NULL, - NULL, - NULL, - NULL); + m = scheme_stx_lookup_w_nominal(a, phase, 0, + NULL, NULL, NULL, NULL, + &nom_mod, &nom_a, + &src_phase_index, + &nominal_src_phase); if (get_symbol) { - if ((!m || SAME_OBJ(m, scheme_undefined)) && nom_a) - a = nom_a; - if (SCHEME_STXP(a)) - a = SCHEME_STX_VAL(a); - return a; + if (SCHEME_VECTORP(m)) + return SCHEME_VEC_ELS(m)[1]; + else + return SCHEME_STX_VAL(a); } - if (!m) + if (SCHEME_FALSEP(m)) return scheme_false; - else if (SAME_OBJ(m, scheme_undefined)) { + else if (SCHEME_SYMBOLP(m)) return lexical_symbol; - } else + else { + a = SCHEME_VEC_ELS(m)[1]; + mod_phase = SCHEME_VEC_ELS(m)[2]; + m = SCHEME_VEC_ELS(m)[0]; + + if (SCHEME_FALSEP(m)) { + /* loses information; improve API in the future? */ + return scheme_false; + } + return CONS(m, CONS(a, CONS(nom_mod, CONS(nom_a, CONS(mod_phase, CONS(src_phase_index, CONS(nominal_src_phase, scheme_null))))))); + } } -static Scheme_Object *module_binding(int argc, Scheme_Object **argv) +static Scheme_Object *free_binding(int argc, Scheme_Object **argv) { - return do_module_binding("identifier-binding", argc, argv, scheme_make_integer(0), 0); + return do_free_binding("identifier-binding", argc, argv, scheme_make_integer(0), 0); } -static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv) +static Scheme_Object *free_trans_binding(int argc, Scheme_Object **argv) { - return do_module_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1), 0); + return do_free_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1), 0); } -static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv) +static Scheme_Object *free_templ_binding(int argc, Scheme_Object **argv) { - return do_module_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1), 0); + return do_free_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1), 0); } -static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv) +static Scheme_Object *free_label_binding(int argc, Scheme_Object **argv) { - return do_module_binding("identifier-label-binding", argc, argv, scheme_false, 0); + return do_free_binding("identifier-label-binding", argc, argv, scheme_false, 0); } -static Scheme_Object *module_binding_symbol(int argc, Scheme_Object **argv) +static Scheme_Object *free_binding_symbol(int argc, Scheme_Object **argv) { - return do_module_binding("identifier-binding-symbol", argc, argv, scheme_make_integer(0), 1); + return do_free_binding("identifier-binding-symbol", argc, argv, scheme_make_integer(0), 1); } static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv) { - Scheme_Object *a = argv[0], *p, *l; + Scheme_Object *a = argv[0], *l; if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) scheme_wrong_contract("identifier-prune-lexical-context", "identifier?", 0, argc, argv); @@ -8707,45 +7559,22 @@ static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv) l = scheme_make_pair(SCHEME_STX_VAL(a), scheme_null); } - p = make_prune_context(l); + /* FIXME: implement pruning */ - return scheme_add_rename(a, p); + return a; } static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv) { - WRAP_POS w; Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - Scheme_Object *l = scheme_null; + Scheme_Object *shifts; if (!SCHEME_STXP(argv[0]) || !SCHEME_STX_SYMBOLP(argv[0])) scheme_wrong_contract("identifier-prune-to-source-module", "identifier?", 0, argc, argv); - /* Keep only redirecting phase shifts */ - - WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); - while (!WRAP_POS_END_P(w)) { - if (SCHEME_BOXP(WRAP_POS_FIRST(w))) { - /* Phase shift: */ - Scheme_Object *vec, *src; - - vec = SCHEME_BOX_VAL(WRAP_POS_FIRST(w)); - - src = SCHEME_VEC_ELS(vec)[1]; - - /* If src is #f, shift is just for phase; no redirection */ - if (!SCHEME_FALSEP(src)) { - l = scheme_make_pair(WRAP_POS_FIRST(w), l); - } - } - - WRAP_POS_INC(w); - } - - l = scheme_reverse(l); - + shifts = stx->shifts; stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = l; + stx->shifts = shifts; return (Scheme_Object *)stx; } @@ -8818,7 +7647,7 @@ static Scheme_Object *syntax_taint(int argc, Scheme_Object **argv) if (!SCHEME_STXP(argv[0])) scheme_wrong_contract("syntax-taint", "syntax?", 0, argc, argv); - return add_taint_to_stx(argv[0], 1); + return add_taint_to_stx(argv[0], NULL); } @@ -8826,72 +7655,6 @@ static Scheme_Object *syntax_taint(int argc, Scheme_Object **argv) /* Debugging */ /**********************************************************************/ -static Scheme_Object *explode_wraps(Scheme_Object *wraps, Scheme_Hash_Table *ht) -{ - Scheme_Object *key, *prev_key = NULL, *pr, *first = scheme_null, *last = NULL, *v; - WRAP_POS awl; - - WRAP_POS_INIT(awl, wraps); - - while (!WRAP_POS_END_P(awl)) { - key = WRAP_POS_KEY(awl); - if (key != prev_key) { - pr = scheme_hash_get(ht, key); - if (pr) { - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - break; - } else { - pr = scheme_make_pair(scheme_void, scheme_null); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - pr = scheme_make_pair(scheme_false, scheme_null); - scheme_hash_set(ht, key, pr); - } - prev_key = key; - } else { - pr = scheme_make_pair(scheme_false, scheme_null); - } - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - - v = WRAP_POS_FIRST(awl); - - if (SCHEME_RENAMESP(v)) { - Module_Renames *mrn = (Module_Renames *)v; - Scheme_Object *o; - - v = scheme_hash_get(ht, (Scheme_Object *)mrn); - if (!v) { - v = scheme_make_vector(7, NULL); - o = scheme_intern_symbol("rename:"); - SCHEME_VEC_ELS(v)[0] = o; - SCHEME_VEC_ELS(v)[1] = mrn->phase; - SCHEME_VEC_ELS(v)[2] = (Scheme_Object *)mrn->ht; - SCHEME_VEC_ELS(v)[3] = (mrn->nomarshal_ht ? (Scheme_Object *)mrn->nomarshal_ht : scheme_false); - SCHEME_VEC_ELS(v)[4] = scheme_true; /* mrn->shared_pes; */ - SCHEME_VEC_ELS(v)[5] = (mrn->marked_names ? (Scheme_Object *)mrn->marked_names : scheme_false); - SCHEME_VEC_ELS(v)[6] = (Scheme_Object *)mrn->unmarshal_info; - scheme_hash_set(ht, (Scheme_Object *)mrn, v); - } - } - - SCHEME_CAR(pr) = v; - - WRAP_POS_INC(awl); - } - - return first; -} - Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht) { Scheme_Object *vec, *v; @@ -8919,47 +7682,8 @@ Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht) v = ((Scheme_Stx *)stx)->taints; SCHEME_VEC_ELS(vec)[1] = (v ? v : scheme_null); - v = explode_wraps(((Scheme_Stx *)stx)->wraps, ht); - SCHEME_VEC_ELS(vec)[2] = v; - - return vec; -} - -/**********************************************************************/ - -static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj) -{ - Scheme_Object *vec; - int i; - - vec = scheme_make_vector(8, NULL); - for (i = 0; i < 8; i++) { - SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; - } - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) - SCHEME_VEC_ELS(vec)[7] = scheme_true; - - return vec; -} - -static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj) -{ - Scheme_Object *vec; - int i; - - if (!SCHEME_VECTORP(obj) - || (SCHEME_VEC_SIZE(obj) != 8)) - return NULL; - - vec = scheme_make_vector(8, NULL); - for (i = 0; i < 8; i++) { - SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; - } - - SCHEME_VEC_ELS(vec)[7] = scheme_false; - - vec->type = scheme_free_id_info_type; - + SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)((Scheme_Stx *)stx)->scopes; + return vec; } @@ -8973,11 +7697,10 @@ START_XFORM_SKIP; static void register_traversers(void) { - GC_REG_TRAV(scheme_rename_table_type, mark_rename_table); - GC_REG_TRAV(scheme_rename_table_set_type, mark_rename_table_set); GC_REG_TRAV(scheme_rt_srcloc, mark_srcloc); - GC_REG_TRAV(scheme_wrap_chunk_type, mark_wrapchunk); - GC_REG_TRAV(scheme_lexical_rib_type, lex_rib); + GC_REG_TRAV(scheme_scope_type, mark_scope); + GC_REG_TRAV(scheme_scope_table_type, mark_scope_table); + GC_REG_TRAV(scheme_propagate_table_type, mark_propagate_table); } END_XFORM_SKIP; diff --git a/racket/src/racket/src/type.c b/racket/src/racket/src/type.c index 02dd6ad084..a131b57ac6 100644 --- a/racket/src/racket/src/type.c +++ b/racket/src/racket/src/type.c @@ -129,6 +129,7 @@ scheme_init_type () set_name(scheme_begin0_sequence_type, ""); set_name(scheme_splice_sequence_type, ""); set_name(scheme_module_type, ""); + set_name(scheme_inline_variant_type, ""); set_name(scheme_set_bang_type, ""); set_name(scheme_boxenv_type, ""); set_name(scheme_require_form_type, ""); @@ -197,6 +198,11 @@ scheme_init_type () set_name(scheme_channel_put_type, ""); set_name(scheme_hash_table_type, ""); set_name(scheme_hash_tree_type, ""); + set_name(scheme_eq_hash_tree_type, ""); + set_name(scheme_eqv_hash_tree_type, ""); + set_name(scheme_hash_tree_indirection_type, ""); + set_name(scheme_hash_tree_subtree_type, ""); + set_name(scheme_hash_tree_collision_type, ""); set_name(scheme_bucket_table_type, ""); set_name(scheme_module_registry_type, ""); set_name(scheme_case_closure_type, ""); @@ -215,7 +221,9 @@ scheme_init_type () set_name(scheme_will_executor_type, ""); set_name(scheme_random_state_type, ""); set_name(scheme_regexp_type, ""); - set_name(scheme_rename_table_type, ""); + set_name(scheme_scope_table_type, ""); + set_name(scheme_propagate_table_type, ""); + set_name(scheme_scope_type, ""); set_name(scheme_bucket_type, ""); set_name(scheme_prefix_type, ""); set_name(scheme_resolve_prefix_type, ""); @@ -711,6 +719,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_global_ref_type, twoptr_obj); GC_REG_TRAV(scheme_delay_syntax_type, small_object); + GC_REG_TRAV(scheme_marshal_share_type, small_object); GC_REG_TRAV(scheme_resolved_module_path_type, small_object); @@ -719,8 +728,6 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_rt_runstack, runstack_val); - GC_REG_TRAV(scheme_free_id_info_type, vector_obj); - GC_REG_TRAV(scheme_rib_delimiter_type, small_object); GC_REG_TRAV(scheme_noninline_proc_type, small_object); GC_REG_TRAV(scheme_prune_context_type, small_object);