suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

switch to set-of-scopes expander

Browse Source 
The development history for set-of-scopes is preserved in a "scope"
branch in the main Racket repository, which is commit
 ae88c96f50
This commit is contained in:
Matthew Flatt 2015-07-16 10:12:25 -06:00
parent bfc2b27d65
commit fc5e32e526
126 changed files with 15656 additions and 14594 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

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

5
pkgs/racket-benchmarks/tests/racket/benchmarks/places/place-processes.rkt
View File

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

9
pkgs/racket-doc/scribblings/raco/zo-parse.scrbl
View File

@ -75,3 +75,12 @@ The @racketmodname[compiler/zo-parse] module re-exports
or @racket[mod] structure indicates the list of global variables and or @racket[mod] structure indicates the list of global variables and
quoted syntax that need to be instantiated (and put into an array on quoted syntax that need to be instantiated (and put into an array on
the stack) before evaluating expressions that might use them.} 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.}

316
pkgs/racket-doc/scribblings/raco/zo-struct.scrbl
View File

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

6
pkgs/racket-doc/scribblings/reference/define-struct.scrbl
View File

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

1
pkgs/racket-doc/scribblings/reference/logging.scrbl
View File

@ -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.}]} @history[#:changed "6.1.1.3" @elem{Added the @racket[topic] argument.}]}
@defproc[(log-max-level [logger logger?] @defproc[(log-max-level [logger logger?]
[topic (or/c symbol? #f) #f]) [topic (or/c symbol? #f) #f])
(or/c #f 'fatal 'error 'warning 'info 'debug)]{ (or/c #f 'fatal 'error 'warning 'info 'debug)]{

2
pkgs/racket-doc/scribblings/reference/notation.scrbl
View File

@ -62,7 +62,7 @@ as in the grammar for @racket[if]:
(if test-expr then-expr else-expr)] (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 objects}, parentheses in a grammar specification indicate a @tech{syntax
object} wrapping a list, and the leading @racket[if] is an identifier object} wrapping a list, and the leading @racket[if] is an identifier
that starts the list whose @tech{binding} is the @racket[if] binding that starts the list whose @tech{binding} is the @racket[if] binding

6
pkgs/racket-doc/scribblings/reference/shared.scrbl
View File

@ -59,12 +59,12 @@ production take precedence over later variants:
The @|maker| identifier above matches three kinds of references. The The @|maker| identifier above matches three kinds of references. The
first kind is any binding whose name has @racketidfont{make-} in 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 structure information with a full set of mutator bindings; see
@secref["structinfo"]. The second kind is an identifier that itself has a @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} 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 information. A @racket[_shell-id], meanwhile, must be one of the
@racket[id]s bound by the @racket[shared] form to a @racket[id]s bound by the @racket[shared] form to a
@racket[_shell-expr]. @racket[_shell-expr].

4
pkgs/racket-doc/scribblings/reference/struct.scrbl
View File

@ -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 is specified, the @racket[parent-id] must be bound to a parent
structure type of @racket[id]. 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 encapsulates information about a structure type (i.e., like the
initial identifier bound by @racket[struct]), and the binding initial identifier bound by @racket[struct]), and the binding
must supply a constructor, a predicate, and all field accessors. 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} @section[#:tag "structinfo"]{Structure Type Transformer Binding}
The @racket[struct] form binds the name of a structure type as 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 to the structure type, the constructor procedure, the predicate
procedure, and the field accessor and mutator procedures. This procedure, and the field accessor and mutator procedures. This
information can be used during the expansion of other expressions via information can be used during the expansion of other expressions via

57
pkgs/racket-doc/scribblings/reference/stx-ops.scrbl
View File

@ -381,5 +381,62 @@ context does not include any bindings.}
For backward compatibility only; returns @racket[new-stx].} 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] @close-eval[stx-eval]

225
pkgs/racket-doc/scribblings/reference/stx-trans.scrbl
View File

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

489
pkgs/racket-doc/scribblings/reference/syntax-model.scrbl
View File

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

116
pkgs/racket-doc/scribblings/reference/syntax.scrbl
View File

@ -280,21 +280,6 @@ form. See also @racket[module-compiled-language-info],
@racket[module->language-info], and @racket[module->language-info], and
@racketmodname[racket/language-info]. @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"]. See also @secref["module-eval-model"] and @secref["mod-parse"].
@defexamples[#:eval (syntax-eval) @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] @history[#:changed "6.2.0.4" @elem{Changed @racket[define-syntaxes]
and @racket[define-values] to 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 ...) @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] Instead of a @racket[module-path] after @racket[id], @racket[#f]
indicates that all bindings from the enclosing module are visible in indicates that all bindings from the enclosing module are visible in
the submodule; @racket[begin-for-syntax] forms that wrap the the submodule. In that case, @racket[begin-for-syntax] forms that wrap
@racket[module*] form shift the @tech{phase level} of the enclosing the @racket[module*] form shift the @tech{phase level} of the
module's bindings relative to the submodule. When a enclosing module's bindings relative to the submodule. The macro
@racket[module*] form has a @racket[module-path], the submodule expander handles such nesting by shifting the @tech{phase level} of
starts with an empty lexical context in the same way as a top-level the @racket[module*] form so that it's body starts at @tech{phase
@racket[module] form, and enclosing @racket[begin-for-syntax] forms level} 0, expanding, and then reverting the @tech{phase level} shift;
have no effect on the submodule.} beware that this process can leave @tech{syntax objects} as
@racket['origin] @tech{syntax property} values out-of-sync with the
expanded module.
When a @racket[module*] form has a @racket[module-path], the submodule
expansion starts by removing the @tech{scopes} of the enclosing
module, the same as the @racket[module] form. No shifting compensates
for any @racket[begin-for-syntax] forms that may wrap the submodule.}
@defform[(module+ id form ...)]{ @defform[(module+ id form ...)]{
@ -389,7 +385,8 @@ Legal only in a @tech{module begin context}, and handled by the
@defform[(#%declare declaration-keyword ...) @defform[(#%declare declaration-keyword ...)
#:grammar #:grammar
([declaration-keyword #:cross-phase-persistent])]{ ([declaration-keyword #:cross-phase-persistent
#:empty-namespace])]{
Declarations that affect run-time or reflective properties of the Declarations that affect run-time or reflective properties of the
module: module:
@ -401,6 +398,12 @@ module:
error if the module does not meet the import or syntactic error if the module does not meet the import or syntactic
constraints of a @tech{cross-phase persistent} module.} 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 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[declaration-keyword] can be declared at most once within a
@racket[module] body. @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 @defsubform[(struct-out id)]{Exports the bindings associated with a
structure type @racket[id]. Typically, @racket[id] is bound with structure type @racket[id]. Typically, @racket[id] is bound with
@racket[(struct id ....)]; more generally, @racket[id] must have a @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 @tech{phase level}; see @secref["structinfo"]. Furthermore, for
each identifier mentioned in the structure-type information, the each identifier mentioned in the structure-type information, the
enclosing module must define or import one identifier that is enclosing module must define or import one identifier that is
@racket[free-identifier=?]. If the structure-type information @racket[free-identifier=?]. If the structure-type information
includes a super-type identifier, and if the identifier has a 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} accessor and mutator bindings of the super-type are @italic{not}
included by @racket[struct-out] for export. included by @racket[struct-out] for export.
@ -1603,7 +1606,7 @@ and finishes the expansion.
@defform/none[id]{ @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, not bound as a transformer (see @secref["expansion"]). At run-time,
the reference evaluates to the value in the @tech{location} associated with the reference evaluates to the value in the @tech{location} associated with
the binding. the binding.
@ -1621,12 +1624,13 @@ x
((lambda (x) x) 2) ((lambda (x) x) 2)
]} ]}
@defform[(#%top . id)]{ @defform[(#%top . id)]{
Refers to a module-level or top-level definition. If @racket[id] has a Equivalent to @racket[id] when @racket[id] is bound to a module-level
local binding in its context, then @racket[(#%top . id)] refers to a or top-level variable. In a top-level context, @racket[(#%top . id)]
top-level definition, but a reference to a top-level definition is always refers to a top-level variable, even if @racket[id] is
disallowed within a module. @tech{unbound} or otherwise bound.
Within a @racket[module] form, @racket[(#%top . id)] expands to just Within a @racket[module] form, @racket[(#%top . id)] expands to just
@racket[id]---with the obligation that @racket[id] is defined within @racket[id]---with the obligation that @racket[id] is defined within
@ -1642,7 +1646,11 @@ introduces @racketidfont{#%top} identifiers.
@examples[ @examples[
(define x 12) (define x 12)
(let ([x 5]) (#%top . x)) (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]} @section{Locations: @racket[#%variable-reference]}
@ -2048,7 +2056,7 @@ and in the @racket[body]s.
@margin-note/ref{See also @racket[splicing-let-syntax].} @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 @secref["transformer-model"]) of each @racket[id] with the value of
@racket[trans-expr], which is an expression at @tech{phase level} 1 @racket[trans-expr], which is an expression at @tech{phase level} 1
relative to the surrounding context. (See @secref["id-model"] for 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 @tech{internal-definition contexts} expand to it. In a fully expanded
expression (see @secref["fully-expanded"]), the @racket[trans-id] expression (see @secref["fully-expanded"]), the @racket[trans-id]
bindings are discarded and the form reduces to a combination of bindings are discarded and the form reduces to a combination of
@racket[letrec-values] or @racket[let-values], but @racket[letrec-values] or @racket[let-values].
@racket[letrec-syntaxes+values] can appear in the result of
@racket[local-expand] with an empty stop list.
For variables bound by @racket[letrec-syntaxes+values], the For variables bound by @racket[letrec-syntaxes+values], the
@tech{location}-creation rules differ slightly from @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 @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-expr] is evaluated. Otherwise, @tech{locations} for all
@racket[val-id]s in a set are created just before the first @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 The end result of the @tech{location}-creation rules is that scoping
and evaluation order are the same as for @racket[letrec-values], but 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) @defform*[[(define-syntax id expr)
(define-syntax (head args) body ...+)]]{ (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 @secref["transformer-model"]) of @racket[id] with the value of
@racket[expr], which is an expression at @tech{phase level} 1 relative @racket[expr], which is an expression at @tech{phase level} 1 relative
to the surrounding context. (See @secref["id-model"] for information 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)]{ @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 for each @racket[id]. The @racket[expr] should produce as many values
as @racket[id]s, and each value is bound to the corresponding as @racket[id]s, and each value is bound to the corresponding
@racket[id]. @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 This form expands to @racket[define-syntax] with a use of
@racket[make-require-transformer] (see @secref["require-trans"] for @racket[make-require-transformer] (see @secref["require-trans"] for
more information), and the @tech{syntax object} passed to and from the 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 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 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 This form expands to @racket[define-syntax] with a use of
@racket[make-provide-transformer] (see @secref["provide-trans"] for @racket[make-provide-transformer] (see @secref["provide-trans"] for
more information), and the @tech{syntax object} passed to and from the 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 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 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)]{ @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 transformer}, as produced by @racket[make-set!-transformer] or as an
instance of a structure type with the @racket[prop:set!-transformer] instance of a structure type with the @racket[prop:set!-transformer]
property, then this form is expanded by calling the assignment property, then this form is expanded by calling the assignment
transformer with the full expressions. If @racket[id] has a 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 by @racket[make-rename-transformer] or as an instance of a structure
type with the @racket[prop:rename-transformer] property, then this type with the @racket[prop:rename-transformer] property, then this
form is expanded by replacing @racket[id] with the target identifier 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]} @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} Similar to @racket[quote], but produces a @tech{syntax object}
that preserves the @tech{lexical information} and source-location that preserves the @tech{lexical information} and source-location
information attached to @racket[datum] at expansion time. 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 Unlike @racket[syntax] (@litchar{#'}), @racket[quote-syntax] does
not substitute pattern variables bound by @racket[with-syntax], not substitute pattern variables bound by @racket[with-syntax],
@racket[syntax-parse], or @racket[syntax-case]. @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)) (quote-syntax (1 2 3))
(with-syntax ([a #'5]) (with-syntax ([a #'5])
(quote-syntax (a b c))) (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]} @section[#:tag "#%top-interaction"]{Interaction Wrapper: @racket[#%top-interaction]}

11
pkgs/racket-test-core/tests/racket/boundmap-test.rktl
View File

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

24
pkgs/racket-test-core/tests/racket/id-table-test.rktl
View File

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

165
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -232,11 +232,12 @@
(test #t 'free-identifier=?-of-rename-via-shadower (test #t 'free-identifier=?-of-rename-via-shadower
(let ([y 5]) (let ([y 5])
(let-syntax ([m (lambda (stx) (let-syntax ([m (lambda ()
#`(quote-syntax #,(syntax-local-get-shadower #'x)))]) (syntax-local-get-shadower #'x))])
(let-syntax ([x (make-rename-transformer #'y)]) (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 set!-transformer? (make-set!-transformer void))
(test #t rename-transformer? (make-rename-transformer #'void)) (test #t rename-transformer? (make-rename-transformer #'void))
@ -248,7 +249,7 @@
(arity-test make-set!-transformer 1 1) (arity-test make-set!-transformer 1 1)
(arity-test 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) (arity-test rename-transformer? 1 1)
;; Test inheritance of context when . is used in a pattern ;; 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))
(test 6 'plus (keep-context . (+ 1 2 3))) (test 6 'plus (keep-context . (+ 1 2 3)))
(unless building-flat-tests? (eval-syntax
(eval-syntax #'(test 6 'plus (discard-context keep-context . (+ 1 2 3))))
#'(test 6 'plus (discard-context keep-context . (+ 1 2 3)))))
(syntax-test #'(discard-context + 1 2 3)) (syntax-test #'(discard-context + 1 2 3))
(syntax-test #'(discard-context . (+ 1 2 3))) (syntax-test #'(discard-context . (+ 1 2 3)))
@ -503,47 +503,60 @@
(+ 1 2) (+ 1 2)
(module* q #f 10) (module* z #f 11)) (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 (module rename-transformer-tests racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(define x 12) (define x 12)
(define-syntax bar (let ([x 10])
(make-rename-transformer #'x)))
(define-syntax foo (make-rename-transformer #'x)) (define-syntax foo (make-rename-transformer #'x))
(list foo (list foo
(identifier-binding #'foo) (identifier-binding #'foo)
(free-identifier=? #'x #'foo)) (free-identifier=? #'x #'foo))
(identifier-binding #'bar)
(begin-for-syntax (begin-for-syntax
(define-struct rt (id) (define-struct rt (id)
#:property prop:rename-transformer 0 #:property prop:rename-transformer 0
#:omit-define-syntaxes)) #:omit-define-syntaxes))
(let-syntax ([q (make-rt #'x)]) (define-syntax v (make-rt #'x))
(list q (list v
(identifier-binding #'q) (identifier-binding #'v)
(free-identifier=? #'q #'x))) (free-identifier=? #'v #'x))
(let ([w 11]) (define w 11)
(letrec-syntax ([q (let () (define-syntax q (let ()
(define-struct rt () (define-struct rt ()
#:property prop:rename-transformer #'w) #:property prop:rename-transformer #'w)
(make-rt))]) (make-rt)))
(list q (list q
(identifier-binding #'q) (identifier-binding #'q)
(free-identifier=? #'q #'w)))) (free-identifier=? #'q #'w))
(letrec-syntax ([n (make-rename-transformer #'glob)]) (define-syntax n1 (make-rename-transformer #'glob))
(list (identifier-binding #'n) (list (identifier-binding #'n1)
(free-identifier=? #'n #'glob))) (free-identifier=? #'n1 #'glob))
(letrec-syntax ([i (make-rename-transformer #'glob)]) (define-syntax i (make-rename-transformer #'glob))
(letrec-syntax ([n (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f))]) (define-syntax n2 (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f)))
(list (identifier-binding #'n) (list (identifier-binding #'n2)
(free-identifier=? #'n #'glob))))) (free-identifier=? #'n2 #'glob)))
(let ([accum null]) (let ([accum null])
(parameterize ([current-print (lambda (v) (parameterize ([current-print (lambda (v)
@ -557,9 +570,8 @@
(dynamic-require ''rename-transformer-tests #f)) (dynamic-require ''rename-transformer-tests #f))
(test '((#f #t) (test '((#f #t)
(#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) (12 (mpi x mpi x 0 0 0) #t)
lexical
(12 (mpi x mpi x 0 0 0) #t)) (12 (mpi x mpi x 0 0 0) #t))
values accum)) 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)]) (parameterize ([current-namespace (make-base-namespace)])
(define m '(module m racket/base (define m '(module m racket/base
(require racket/splicing (require racket/splicing
@ -941,7 +927,7 @@
_ _
_ _
(#%plain-lambda {one:id} (#%plain-lambda {one:id}
(letrec-syntaxes+values _ _ two:id))) (let-values _ two:id)))
(let () (let ()
(when (bound-identifier=? #'one #'two) (when (bound-identifier=? #'one #'two)
@ -959,7 +945,7 @@
(syntax-parse stx (syntax-parse stx
[(_ unmarked . body) [(_ unmarked . body)
(define/syntax-parse marked (define/syntax-parse marked
(syntax-local-introduce (attribute unmarked))) (datum->syntax #f (syntax->datum (attribute unmarked))))
#'(#%plain-lambda {marked} #'(#%plain-lambda {marked}
(define-syntaxes {unmarked} (define-syntaxes {unmarked}
(make-rename-transformer #'marked)) (make-rename-transformer #'marked))
@ -971,12 +957,14 @@
(lam x x))) (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 (module consistency-free-id-A racket
(provide g (rename-out [*a a])) (provide g (rename-out [*a a]))
(define *a 10) (define *a 10)
(define a 10) (define a 11)
(define-syntax g #'a)) (define-syntax g #'a))
(module consistency-free-id-B racket (module consistency-free-id-B racket
@ -987,7 +975,7 @@
[(_ ref) [(_ ref)
(with-syntax ([in (syntax-local-introduce (with-syntax ([in (syntax-local-introduce
(syntax-local-value #'g))]) (syntax-local-value #'g))])
#'(let ([in 10]) ; BINDING #'(let ([in 12]) ; BINDING
(list (free-identifier=? #'in #'ref) (list (free-identifier=? #'in #'ref)
in in
ref)))])) ; REFERENCE ref)))])) ; REFERENCE
@ -995,7 +983,7 @@
(require 'consistency-free-id-B) (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: ;; Check `syntax-local-lift...` outside of macro:
@ -1134,6 +1122,55 @@
(rename-transformer-target (rename-transformer-target
(chaperone-struct (foo #'x) foo-id (lambda (f x) x))))) (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) (report-errs)

7
pkgs/racket-test-core/tests/racket/modprot.rktl
View File

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

96
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -148,7 +148,6 @@
(test 6 dynamic-require ''defines-car-that-overrides-import/stx 'car) (test 6 dynamic-require ''defines-car-that-overrides-import/stx 'car)
;; Can't redefine multiple times or import after definition: ;; 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 (#%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))) (require 'e 'b)))
(test '(d b d b c) values l) (test '(d b d b c) values l)
(eval `(require 'f)) (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) (test finished values l)
(namespace-attach-module n ''f) (eval '10) ; triggers `d` and `b`
(test finished values l) (let ([finished (append '(d b) finished)])
(parameterize ([current-namespace (make-empty-namespace)]) (test finished values l)
(namespace-attach-module n ''f) (namespace-attach-module n ''f)
(test finished values l) (test finished values l)
(namespace-require 'racket/base) (parameterize ([current-namespace (make-empty-namespace)])
(eval `(require 'a)) (namespace-attach-module n ''f)
(eval `(require 'f)) (test finished values l)
(test (list* 'd 'b 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)] (let* ([n (make-base-namespace)]
[l null] [l null]
@ -357,7 +361,6 @@
(module m 'mod_beg2 (module m 'mod_beg2
3))) 3)))
(test (void) eval (test (void) eval
'(begin '(begin
(module mod_beg2 racket/base (module mod_beg2 racket/base
@ -390,6 +393,60 @@
(define expand-test-use-toplevel? #f) (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)] (let ([f1 (make-temporary-file)]
@ -622,7 +679,7 @@
(test 5 eval 'five ns) (test 5 eval 'five ns)
(eval p-code ns) (eval p-code ns)
(eval '(require 'p) ns) (eval '(require 'p) ns)
(test #f eval 'same? ns) ; (test #f eval 'same? ns)
(let ([n-ns (eval '(module->namespace ''n) ns)]) (let ([n-ns (eval '(module->namespace ''n) ns)])
(test 5 eval '(lambda (x) x) n-ns))))) (test 5 eval '(lambda (x) x) n-ns)))))
@ -981,7 +1038,8 @@
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(begin-for-syntax (begin-for-syntax
(require 'm)))) (require 'm))))
(eval '(require 'n))) (eval '(require 'n))
(eval '10))
(test #"1\n1\n" get-output-bytes o)) (test #"1\n1\n" get-output-bytes o))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1012,7 +1070,7 @@
(module avail-y racket/base (module avail-y racket/base
(require 'avail-z) (require 'avail-z)
(eval #'(foo 10))) (eval-syntax #'(foo 10)))
(err/rt-test (dynamic-require ''avail-y #f) (err/rt-test (dynamic-require ''avail-y #f)
(lambda (exn) (and (exn? exn) (lambda (exn) (and (exn? exn)
@ -1171,6 +1229,12 @@
;; the enclosing module work, even though the identifier is missing ;; the enclosing module work, even though the identifier is missing
;; a module context. ;; 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 () (let ()
(define (mk mode wrap?) (define (mk mode wrap?)
`(module m racket `(module m racket
@ -1205,6 +1269,8 @@
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(eval (mk m wrap?))))) (eval (mk m wrap?)))))
|#
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that module caching doesn't cause submodules ;; Check that module caching doesn't cause submodules
;; to be loaded/declared too early ;; to be loaded/declared too early

34
pkgs/racket-test-core/tests/racket/namespac.rktl
View File

@ -284,11 +284,43 @@
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(let ([i (make-syntax-introducer)]) (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)))]) (let ([e (namespace-syntax-introduce (datum->syntax #f '(cons? #t)))])
(err/rt-test (eval e)) (err/rt-test (eval e))
(test #f eval (i 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) (report-errs)

5
pkgs/racket-test-core/tests/racket/object.rktl
View File

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

1
pkgs/racket-test-core/tests/racket/read.rktl
View File

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

20
pkgs/racket-test-core/tests/racket/sandbox.rktl
View File

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

276
pkgs/racket-test-core/tests/racket/stx.rktl
View File

@ -320,7 +320,7 @@
;; Check tracking of (formerly) primitive expanders ;; Check tracking of (formerly) primitive expanders
(test '(let) (tree-map syntax-e) (syntax-property (expand #'(let ([x 10]) x)) 'origin)) (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 '(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 '(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)) (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]) (parameterize ([read-accept-compiled #t])
(eval (read i)))))) (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. ;; eval versus eval-syntax, etc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -616,11 +802,10 @@
(test eval 'expand-to-top-form (eval (expand-syntax-to-top-form #'eval))) (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)))) (test #t syntax? (expand-syntax-to-top-form (datum->syntax #f 'eval))))
(let () (define-syntax @$@name 'dummy)
(define-syntax name 'dummy) (define-syntax @$@alias (make-rename-transformer #'@$@name))
(define-syntax alias (make-rename-transformer #'name)) (test (identifier-binding-symbol #'@$@name)
(test (identifier-binding-symbol #'name) identifier-binding-symbol #'@$@alias)
identifier-binding-symbol #'alias))
(require (only-in racket/base [add1 increment-by-one])) (require (only-in racket/base [add1 increment-by-one]))
(test (identifier-binding-symbol #'add1) (test (identifier-binding-symbol #'add1)
@ -760,7 +945,7 @@
(= 1 (length o)) (= 1 (length o))
(andmap identifier? db) (andmap identifier? db)
(identifier? (car o)) (identifier? (car o))
(ormap (lambda (db) (bound-identifier=? db (car o))) db))) (ormap (lambda (db) (free-identifier=? db (car o))) db)))
db o))))])))]) 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))]) () x)))
(check-expr #'(let () (letrec-syntaxes+values ([(x) (lambda (stx) #'(quote y))]) () (list 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-macro stx) (syntax-protect #'++x))
(define-syntax (++y-macro2 stx) (syntax-protect (datum->syntax stx '++x))) (define-syntax (++y-macro2 stx) (syntax-protect (datum->syntax stx '++x)))
(define-syntax (++u-macro stx) (syntax-protect #'++u)) (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-syntax ++u2 (make-rename-transformer (syntax-protect #'++u)))
(define ++u 8) ; unexported (define ++u 8) ; would be unexported, but export of rename transformer exports it
(provide ++y ++y-macro ++y-macro2 ++u-macro ++u2)) (define ++v 9) ; unexported
(provide ++y ++y-macro ++y-macro2 ++u-macro ++u2 ++v-macro))
(require '++n) (require '++n)
(test 10 values ++y) (test 10 values ++y)
(test 10 values ++y-macro) (test 10 values ++y-macro)
(test 8 values ++u-macro) (test 8 values ++u-macro)
(test 8 values ++u2) (test 8 values ++u2)
(test 9 values ++v-macro)
(require '++m) (require '++m)
@ -1232,7 +1420,6 @@
(printf "~a ~a\n" a b))) (printf "~a ~a\n" a b)))
(eval '(require 'mm)) (eval '(require 'mm))
(eval '(current-namespace (module->namespace ''mm))) (eval '(current-namespace (module->namespace ''mm)))
(eval '(define$ c 7)) (eval '(define$ c 7))
(test '(1 2 7) eval '(list a b c)) (test '(1 2 7) eval '(list a b c))
(eval '(define$ d 8)) (eval '(define$ d 8))
@ -1243,6 +1430,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; layers of lexical binding ;; layers of lexical binding
#|
This test is supposed to fail, now:
(test '(1 2) 'macro-nested-lexical (test '(1 2) 'macro-nested-lexical
(let () (let ()
(define-syntax (m stx) (define-syntax (m stx)
@ -1270,18 +1460,18 @@
(provide @!$get)) (provide @!$get))
(require '@!$m) (require '@!$m)
(test '(10 20 #t) '@!$get @!$get) (test '(10 20 #t) '@!$get @!$get)
|#
(unless building-flat-tests? (test '(12)
(test '(12) eval
eval (expand
(expand #'(let ([b 12])
#'(let ([b 12]) (let-syntax ([goo (lambda (stx)
(let-syntax ([goo (lambda (stx) #`(let ()
#`(let () (define #,(syntax-local-introduce #'b) 1)
(define #,(syntax-local-introduce #'b) 1) (define z (list b))
(define z (list b)) z))])
z))]) (goo)))))
(goo))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test lazy unmarshaling of renamings and module-name resolution ;; Test lazy unmarshaling of renamings and module-name resolution
@ -1319,7 +1509,6 @@
(parameterize ([read-accept-compiled #t]) (parameterize ([read-accept-compiled #t])
(read (open-input-bytes (get-output-bytes p))))))] (read (open-input-bytes (get-output-bytes p))))))]
[x-id (parameterize ([current-namespace (make-base-namespace)]) [x-id (parameterize ([current-namespace (make-base-namespace)])
(printf "here\n")
(eval a-code) (eval a-code)
(eval '(require 'a)) (eval '(require 'a))
(eval '#'x))]) (eval '#'x))])
@ -1330,7 +1519,9 @@
(test #t eval `(free-identifier=? (f) (quote-syntax ,x-id))) (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
(eval '(require 'a)) (eval '(require 'a))
(test #t eval '(free-identifier=? (f) #'x)) (test #t eval '(free-identifier=? (f) #'x))
;; check namespace fallbacks:
(test #t eval `(free-identifier=? (f) (quote-syntax ,x-id))) (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id)))
(test #t free-identifier=? (eval '(f)) x-id)
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(eval '(module a racket/base (eval '(module a racket/base
(provide y) (provide y)
@ -1611,7 +1802,7 @@
(let ([a-b-stx (parameterize ([current-namespace (make-base-namespace)]) (let ([a-b-stx (parameterize ([current-namespace (make-base-namespace)])
(eval '(define-syntax-rule (b e) (eval '(define-syntax-rule (b e)
(begin e))) (begin e)))
(expand #'(b 1)))]) (expand '(b 1)))])
(test #f free-identifier=? #'begin (datum->syntax a-b-stx 'begin)) (test #f free-identifier=? #'begin (datum->syntax a-b-stx 'begin))
(test #t free-identifier=? #'begin (syntax-case a-b-stx () (test #t free-identifier=? #'begin (syntax-case a-b-stx ()
[(b . _) (datum->syntax #'b 'begin)])))) [(b . _) (datum->syntax #'b 'begin)]))))
@ -1849,6 +2040,45 @@
(read i))) (read i)))
(test #t syntax? (cdr (syntax-e (eval s))))) (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) (report-errs)

42
pkgs/racket-test-core/tests/racket/stxparam.rktl
View File

@ -19,6 +19,11 @@
(test 'sub values (splicing-syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))]) (test 'sub values (splicing-syntax-parameterize ([tHIs (lambda (stx) #'(quote sub))])
(inDIRECt))) (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 (module check-splicing-stxparam-1 racket/base
(require (for-syntax racket/base) (require (for-syntax racket/base)
racket/stxparam racket/stxparam
@ -88,6 +93,43 @@
(test 11 dynamic-require ''check-splicing-stxparam-et 'q) (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) (report-errs)

15
pkgs/racket-test-core/tests/racket/submodule.rktl
View File

@ -379,7 +379,9 @@
[() 10])))))) [() 10]))))))
(eval (syntax-case m () (eval (syntax-case m ()
[(md m r/b (m-b cr mod)) [(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)]) (parameterize ([current-namespace (make-base-namespace)])
(eval (eval
@ -975,6 +977,17 @@
(regexp-match (regexp-quote "(submod 'variable-error-message-in-submodule m2)") (regexp-match (regexp-quote "(submod 'variable-error-message-in-submodule m2)")
(exn-message x))))) (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) (report-errs)

13
pkgs/racket-test-core/tests/racket/syntax.rktl
View File

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

16
pkgs/racket-test/tests/generic/syntax-errors.rkt
View File

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

63
pkgs/racket-test/tests/racket/package.rkt
View File

@ -48,8 +48,18 @@
(or (fail? e) e)) (or (fail? e) e))
(define (test-pack-seq* forms expr q-expr result) (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)]) (let ([orig (current-namespace)])
;; top level ;; top level
(printf "top\n")
(let ([ns (make-base-namespace)]) (let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(namespace-attach-module orig 'racket/package) (namespace-attach-module orig 'racket/package)
@ -60,6 +70,7 @@
(err/rt-test (eval (fail-expr expr)) result) (err/rt-test (eval (fail-expr expr)) result)
(test result q-expr (eval expr))))) (test result q-expr (eval expr)))))
;; let ;; let
(printf "let\n")
(let ([ns (make-base-namespace)]) (let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(namespace-attach-module orig 'racket/package) (namespace-attach-module orig 'racket/package)
@ -70,6 +81,7 @@
(err/rt-test (eval e) result) (err/rt-test (eval e) result)
(test result `(let ... ,q-expr) (eval e)))))) (test result `(let ... ,q-expr) (eval e))))))
;; nested let ;; nested let
(printf "nested let\n")
(let ([ns (make-base-namespace)]) (let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(namespace-attach-module orig 'racket/package) (namespace-attach-module orig 'racket/package)
@ -84,6 +96,7 @@
(err/rt-test (eval e) result) (err/rt-test (eval e) result)
(test result `(let ... ,q-expr) (eval e)))))) (test result `(let ... ,q-expr) (eval e))))))
;; module ;; module
(printf "module\n")
(let ([ns (make-base-namespace)]) (let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(namespace-attach-module orig 'racket/package) (namespace-attach-module orig 'racket/package)
@ -93,6 +106,56 @@
(begin . ,forms) (begin . ,forms)
(define result ,(fail-expr expr)) (define result ,(fail-expr expr))
(provide result))]) (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) (if (fail? expr)
(err/rt-test (eval m) exn:fail:syntax?) (err/rt-test (eval m) exn:fail:syntax?)
(begin (begin

19
pkgs/racket-test/tests/units/test-harness.rkt
View File

@ -1,7 +1,7 @@
(module test-harness mzscheme (module test-harness racket
(require syntax/stx) (require syntax/stx)
(provide (all-defined)) (provide (all-defined-out))
(define (lst-bound-id=? x y) (define (lst-bound-id=? x y)
(andmap bound-identifier=? x y)) (andmap bound-identifier=? x y))
@ -10,18 +10,23 @@
(cond (cond
((and (syntax? x) (eq? '_ (syntax-e x))) ((and (syntax? x) (eq? '_ (syntax-e x)))
#t) #t)
((and (stx-pair? x) ((and (syntax? x)
(not (syntax-e (stx-car x))) (vector? (syntax-e x))
(identifier? (stx-cdr x))) (= 2 (vector-length (syntax-e x))))
(and (identifier? y) (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)) ((and (stx-null? x) (stx-null? y))
#t) #t)
((and (stx-pair? x) (stx-pair? y)) ((and (stx-pair? x) (stx-pair? y))
(and (stx-bound-id=? (stx-car x) (stx-car y)) (and (stx-bound-id=? (stx-car x) (stx-car y))
(stx-bound-id=? (stx-cdr x) (stx-cdr y)))) (stx-bound-id=? (stx-cdr x) (stx-cdr y))))
((and (identifier? x) (identifier? 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)) ((and (syntax? x) (number? (syntax-e x))
(syntax? y) (number? (syntax-e y))) (syntax? y) (number? (syntax-e y)))
(= (syntax-e x) (syntax-e y))) (= (syntax-e x) (syntax-e y)))

24
pkgs/racket-test/tests/units/test-unit-contracts.rkt
View File

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

45
pkgs/racket-test/tests/units/test-unit.rkt
View File

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

1
racket/collects/compiler/private/xform.rkt
View File

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

35
racket/collects/pkg/main.rkt
View File

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

8
racket/collects/racket/block.rkt
View File

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

3
racket/collects/racket/class.rkt
View File

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

19
racket/collects/racket/contract/private/provide.rkt
View File

@ -232,8 +232,9 @@
;; the first syntax object is used for source locations ;; the first syntax object is used for source locations
(define-for-syntax (tl-code-for-one-id/new-name id-for-one-id (define-for-syntax (tl-code-for-one-id/new-name id-for-one-id
stx id reflect-id ctrct/no-prop user-rename-id stx id reflect-id ctrct/no-prop user-rename-id
[mangle-for-maker? #f] pos-module-source
[provide? #t]) mangle-for-maker?
provide?)
(define ex-id (or reflect-id id)) (define ex-id (or reflect-id id))
(define id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?)) (define id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?))
(with-syntax ([ctrct (syntax-property (with-syntax ([ctrct (syntax-property
@ -261,7 +262,7 @@
id-rename id-rename
(stx->srcloc-expr srcloc-id) (stx->srcloc-expr srcloc-id)
'provide/contract 'provide/contract
#'pos-module-source) pos-module-source)
#,@(if provide? #,@(if provide?
(list #`(provide (rename-out [#,id-rename external-name]))) (list #`(provide (rename-out [#,id-rename external-name])))
null))) null)))
@ -1050,11 +1051,18 @@
"provide/contract-id" "provide/contract-id"
(or user-rename-id reflect-id 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 (define (code-for-one-id/new-name stx id reflect-id ctrct/no-prop user-rename-id
[mangle-for-maker? #f] [mangle-for-maker? #f]
[provide? #t]) [provide? #t])
(tl-code-for-one-id/new-name id-for-one-id (tl-code-for-one-id/new-name id-for-one-id
stx id reflect-id ctrct/no-prop user-rename-id stx id reflect-id ctrct/no-prop user-rename-id
pos-module-source-id
mangle-for-maker? mangle-for-maker?
provide?)) provide?))
@ -1104,10 +1112,11 @@
[(struct (a b) ((fld ctc) ...) options ...) [(struct (a b) ((fld ctc) ...) options ...)
(add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))] (add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))]
[_ (void)])) [_ (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 (syntax
(begin (begin
(define pos-module-source (quote-module-name)) (define pos-module-source-id (quote-module-name))
bodies ...)))]))])) bodies ...)))]))]))

53
racket/collects/racket/contract/region.rkt
View File

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

2
racket/collects/racket/generic.rkt
View File

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

7
racket/collects/racket/local.rkt
View File

@ -5,4 +5,9 @@
(provide local) (provide local)
(define-syntax (local stx) (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)))))

124
racket/collects/racket/private/class-internal.rkt
View File

@ -30,50 +30,53 @@
(provide provide-public-names (provide provide-public-names
;; needed for Typed Racket ;; needed for Typed Racket
(protect-out do-make-object find-method/who)) (protect-out do-make-object find-method/who))
(define-syntax-rule (provide-public-names) (define-syntax (provide-public-names stx)
(provide class class* class/derived (datum->syntax
define-serializable-class define-serializable-class* stx
class? '(provide class class* class/derived
mixin define-serializable-class define-serializable-class*
interface interface* interface? class?
object% object? externalizable<%> printable<%> writable<%> equal<%> mixin
object=? object-or-false=? interface interface* interface?
new make-object instantiate object% object? externalizable<%> printable<%> writable<%> equal<%>
send send/apply send/keyword-apply send* send+ dynamic-send object=? object-or-false=?
class-field-accessor class-field-mutator with-method new make-object instantiate
get-field set-field! field-bound? field-names send send/apply send/keyword-apply send* send+ dynamic-send
dynamic-get-field dynamic-set-field! class-field-accessor class-field-mutator with-method
private* public* pubment* get-field set-field! field-bound? field-names
override* overment* dynamic-get-field dynamic-set-field!
augride* augment* private* public* pubment*
public-final* override-final* augment-final* override* overment*
define/private define/public define/pubment augride* augment*
define/override define/overment public-final* override-final* augment-final*
define/augride define/augment define/private define/public define/pubment
define/public-final define/override-final define/augment-final define/override define/overment
define-local-member-name define-member-name define/augride define/augment
member-name-key generate-member-key define/public-final define/override-final define/augment-final
member-name-key? member-name-key=? member-name-key-hash-code define-local-member-name define-member-name
generic make-generic send-generic member-name-key generate-member-key
is-a? subclass? implementation? interface-extension? member-name-key? member-name-key=? member-name-key-hash-code
object-interface object-info object->vector generic make-generic send-generic
object-method-arity-includes? is-a? subclass? implementation? interface-extension?
method-in-interface? interface->method-names class->interface class-info object-interface object-info object->vector
(struct-out exn:fail:object) object-method-arity-includes?
make-primitive-class method-in-interface? interface->method-names class->interface class-info
class/c ->m ->*m ->dm case->m object/c instanceof/c (struct-out exn:fail:object)
dynamic-object/c make-primitive-class
class-seal class-unseal class/c ->m ->*m ->dm case->m object/c instanceof/c
dynamic-object/c
class-seal class-unseal
;; "keywords": ;; "keywords":
private public override augment private public override augment
pubment overment augride pubment overment augride
public-final override-final augment-final public-final override-final augment-final
field init init-field init-rest field init init-field init-rest
rename-super rename-inner inherit inherit/super inherit/inner inherit-field rename-super rename-inner inherit inherit/super inherit/inner inherit-field
this this% super inner this this% super inner
super-make-object super-instantiate super-new super-make-object super-instantiate super-new
inspect absent abstract)) inspect absent abstract)
stx))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; keyword setup ;; keyword setup
@ -378,12 +381,16 @@
'expression 'expression
null)]) null)])
(syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx) (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) [(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...))) (andmap identifier? (syntax->list #'(id ...)))
(begin (let ([ids (map bind-local-id (syntax->list #'(id ...)))])
(map bind-local-id (syntax->list #'(id ...))) (with-syntax ([(id ...) ids])
(cons e (loop (cdr l))))] (cons (datum->syntax e (list #'define-values #'(id ...) #'rhs) e e)
(loop (cdr l)))))]
[_else [_else
(cons e (loop (cdr l)))])))))) (cons e (loop (cdr l)))]))))))
@ -419,9 +426,9 @@
(if alone (if alone
(map (lambda (i) (map (lambda (i)
(if (identifier? i) (if (identifier? i)
(alone i) (alone (syntax-local-identifier-as-binding i))
(cons (stx-car i) (cons (syntax-local-identifier-as-binding (stx-car i))
(stx-car (stx-cdr i))))) (syntax-local-identifier-as-binding (stx-car (stx-cdr i))))))
l) l)
l))) l)))
l))) l)))
@ -438,8 +445,8 @@
(cons (list a a) (stx-cdr i)) (cons (list a a) (stx-cdr i))
i))])) i))]))
(define (norm-init/field-iid norm) (stx-car (stx-car norm))) (define (norm-init/field-iid norm) (syntax-local-identifier-as-binding (stx-car (stx-car norm))))
(define (norm-init/field-eid norm) (stx-car (stx-cdr (stx-car norm)))) (define (norm-init/field-eid norm) (syntax-local-identifier-as-binding (stx-car (stx-cdr (stx-car norm)))))
;; expands an expression enough that we can check whether it has ;; expands an expression enough that we can check whether it has
;; the right form for a method; must use local syntax definitions ;; 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) (define (main stx super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
(let-values ([(this-id) #'this-id] (let-values ([(this-id) #'this-id]
[(the-obj) (datum->syntax (quote-syntax here) (gensym 'self))] [(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)] (let* ([def-ctx (syntax-local-make-definition-context)]
[localized-map (make-bound-identifier-mapping)] [localized-map (make-bound-identifier-mapping)]
@ -682,13 +689,15 @@
(unless (eq? id id2) (unless (eq? id id2)
(set! any-localized? #t)) (set! any-localized? #t))
id2))] id2))]
[bind-local-id (lambda (id) [bind-local-id (lambda (orig-id)
(let ([l (localize/set-flag id)]) (let ([l (localize/set-flag orig-id)]
[id (syntax-local-identifier-as-binding orig-id)])
(syntax-local-bind-syntaxes (list id) #f def-ctx) (syntax-local-bind-syntaxes (list id) #f def-ctx)
(bound-identifier-mapping-put! (bound-identifier-mapping-put!
localized-map localized-map
id id
l)))] l)
id))]
[lookup-localize (lambda (id) [lookup-localize (lambda (id)
(bound-identifier-mapping-get (bound-identifier-mapping-get
localized-map localized-map
@ -1300,8 +1309,7 @@
(generate-temporaries (map car inherit/inners)))] (generate-temporaries (map car inherit/inners)))]
[all-inherits (append inherits inherit/supers inherit/inners)] [all-inherits (append inherits inherit/supers inherit/inners)]
[definify (lambda (l) [definify (lambda (l)
(map bind-local-id l) (map bind-local-id l))])
l)])
;; ---- set up field and method mappings ---- ;; ---- set up field and method mappings ----
(with-syntax ([(rename-super-orig ...) (definify (map car rename-supers))] (with-syntax ([(rename-super-orig ...) (definify (map car rename-supers))]
@ -1692,8 +1700,6 @@
(cdr (syntax-e stx))))))))]) (cdr (syntax-e stx))))))))])
(letrec-syntaxes+values (letrec-syntaxes+values
([(plain-init-name) (make-init-redirect ([(plain-init-name) (make-init-redirect
(quote-syntax set!)
(quote-syntax #%plain-app)
(quote-syntax local-plain-init-name) (quote-syntax local-plain-init-name)
(quote-syntax plain-init-name-localized))] ...) (quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) unsafe-undefined] ...) ([(local-plain-init-name) unsafe-undefined] ...)

18
racket/collects/racket/private/class-undef.rkt
View File

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

66
racket/collects/racket/private/classidmap.rkt
View File

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

24
racket/collects/racket/private/generic-interfaces.rkt
View File

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

65
racket/collects/racket/private/generic-methods.rkt
View File

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

4
racket/collects/racket/private/generic.rkt
View File

@ -112,9 +112,11 @@
#'(begin #'(begin
(define-syntax generic-name (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 prop:pred)
(quote-syntax accessor-name) (quote-syntax accessor-name)
(list (quote-syntax method-name) ...)
(list (quote-syntax method-name) ...))) (list (quote-syntax method-name) ...)))
(define (prop:guard x info) (define (prop:guard x info)
(unless (and (vector? x) (= (vector-length x) 'size)) (unless (and (vector? x) (= (vector-length x) 'size))

41
racket/collects/racket/private/local.rkt
View File

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

2
racket/collects/racket/private/misc.rkt
View File

@ -5,7 +5,7 @@
(module misc '#%kernel (module misc '#%kernel
(#%require '#%utils ; built into racket (#%require '#%utils ; built into racket
"small-scheme.rkt" "define.rkt" "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"))
;; ------------------------------------------------------------------------- ;; -------------------------------------------------------------------------

1
racket/collects/racket/private/more-scheme.rkt
View File

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

2
racket/collects/racket/private/pre-base.rkt
View File

@ -149,7 +149,7 @@
stx) stx)
(raise-syntax-error #f "bad syntax" 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-except "misc.rkt" collection-path collection-file-path)
(all-from "define.rkt") (all-from "define.rkt")
(all-from-except "letstx-scheme.rkt" -define -define-syntax -define-struct old-cond) (all-from-except "letstx-scheme.rkt" -define -define-syntax -define-struct old-cond)

501
racket/collects/racket/private/qar.rkt Normal file
View File

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

128
racket/collects/racket/private/qq-and-or.rkt
View File

@ -5,19 +5,50 @@
(module qq-and-or '#%kernel (module qq-and-or '#%kernel
(#%require (for-syntax "stx.rkt" '#%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)] (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) (let-values ([(go)
(lambda (stx named? star? target) (lambda (stx named? star? target)
(define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x)))) (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?) (define-values (stx-2list?)
(lambda (x) (lambda (x)
(if (stx-pair? x) (if (stx-pair? x)
@ -97,39 +128,11 @@
(loop bindings))]) (loop bindings))])
(if star? (if star?
(void) (void)
(if ((length new-bindings) . > . 5) (check-for-duplicates new-bindings
(let-values ([(ht) (make-hasheq)]) (if name
(letrec-values ([(check) (lambda (l) car
(if (null? l) (lambda (v) (stx-car (stx-car v))))
(void) stx))
(let*-values ([(id) (if name
(caar l)
(stx-car (stx-car (car l))))]
[(idl) (hash-ref ht (syntax-e id) null)])
(if (id-in-list? id idl)
(raise-syntax-error
#f
"duplicate identifier"
stx
id)
(begin
(hash-set! ht (syntax-e id) (cons id idl))
(check (cdr l)))))))])
(check new-bindings)))
(letrec-values ([(check) (lambda (l accum)
(if (null? l)
(void)
(let-values ([(id) (if name
(caar l)
(stx-car (stx-car (car l))))])
(if (id-in-list? id accum)
(raise-syntax-error
#f
"duplicate identifier"
stx
id)
(check (cdr l) (cons id accum))))))])
(check new-bindings null))))
(datum->syntax (datum->syntax
lambda-stx lambda-stx
(if name (if name
@ -149,6 +152,44 @@
body)) body))
stx))))))]) stx))))))])
(values (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 #t #f (quote-syntax let-values)))
(lambda (stx) (go stx #f #t (quote-syntax let*-values))) (lambda (stx) (go stx #f #t (quote-syntax let*-values)))
(lambda (stx) (go stx #f #f (quote-syntax letrec-values))))))) (lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))
@ -458,5 +499,6 @@
"bad syntax" "bad syntax"
x)))))))) x))))))))
(#%provide let let* letrec (#%provide let*-values
let let* letrec
quasiquote and or)) quasiquote and or))

13
racket/collects/racket/private/reqprov.rkt
View File

@ -322,7 +322,9 @@
in)))] in)))]
;; General case: ;; General case:
[_ (let-values ([(imports sources) (expand-import in)]) [_ (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 (cons/syntax-track/form
#'(just-meta 0) #'(just-meta 0)
in in
@ -406,8 +408,13 @@
(current-load-relative-directory)) (current-load-relative-directory))
(list prefetches (current-load-relative-directory)) (list prefetches (current-load-relative-directory))
#f)) #f))
(syntax/loc stx (with-syntax ([(req-in ...)
(begin (require in) ...)))])))] (map (lambda (in)
(with-syntax ([in in])
(syntax/loc stx (require in))))
(syntax->list #'(in ...)))])
(syntax/loc stx
(begin req-in ...))))])))]
[else [else
(raise-syntax-error #f (raise-syntax-error #f
"not at module level or top level" "not at module level or top level"

3
racket/collects/racket/private/stxparam.rkt
View File

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

2
racket/collects/racket/private/stxparamkey.rkt
View File

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

2
racket/collects/racket/private/submodule.rkt
View File

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

100
racket/collects/racket/private/unit-compiletime.rkt
View File

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

31
racket/collects/racket/private/unit-syntax.rkt
View File

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

7
racket/collects/racket/signature/lang.rkt
View File

@ -9,7 +9,9 @@
(provide (rename-out [module-begin #%module-begin] (provide (rename-out [module-begin #%module-begin]
[struct~s struct]) [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/unit)
(all-from-out racket/contract) (all-from-out racket/contract)
(for-syntax (all-from-out racket/base))) (for-syntax (all-from-out racket/base)))
@ -25,7 +27,8 @@
(define-syntax (module-begin stx) (define-syntax (module-begin stx)
(parameterize ((error-syntax 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 () (syntax-case stx ()
((_ . x) ((_ . x)
(with-syntax ((((reqs ...) . (body ...)) (with-syntax ((((reqs ...) . (body ...))

329
racket/collects/racket/splicing.rkt
View File

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

6
racket/collects/racket/stream.rkt
View File

@ -45,9 +45,13 @@
stream/c) stream/c)
(define-syntax gen:stream (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-via-prop?)
(quote-syntax stream-get-generics) (quote-syntax stream-get-generics)
(list (quote-syntax stream-empty?)
(quote-syntax stream-first)
(quote-syntax stream-rest))
(list (quote-syntax stream-empty?) (list (quote-syntax stream-empty?)
(quote-syntax stream-first) (quote-syntax stream-first)
(quote-syntax stream-rest)))) (quote-syntax stream-rest))))

70
racket/collects/racket/trait.rkt
View File

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

81
racket/collects/racket/unit.rkt
View File

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

3
racket/collects/setup/setup-cmdline.rkt
View File

@ -73,6 +73,9 @@
[("-c" "--clean") "Delete existing compiled files; implies -nxiIFDK" [("-c" "--clean") "Delete existing compiled files; implies -nxiIFDK"
(add-flags (append '((clean #t)) (add-flags (append '((clean #t))
disable-action-flags))] 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" [("-n" "--no-zo") "Do not create \".zo\" files"
(add-flags '((make-zo #f)))] (add-flags '((make-zo #f)))]
[("--trust-zos") "Trust existing \".zo\"s (use only with prepackaged \".zo\"s)" [("--trust-zos") "Trust existing \".zo\"s (use only with prepackaged \".zo\"s)"

2
racket/collects/syntax/free-vars.rkt
View File

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

82
racket/collects/syntax/kerncase.rkt
View File

@ -6,35 +6,59 @@
(define-syntax kernel-syntax-case-internal (define-syntax kernel-syntax-case-internal
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ stxv phase rel? (extras ...) kernel-context clause ...) [(_ stxv phase rel? (extras ...) kernel-context [pattern . rhs] ...)
(quasisyntax/loc (let ()
stx (define kernel-ids (syntax-e
(syntax-case* stxv (extras ... (quote-syntax
#,@(map (quote
syntax-local-introduce quote-syntax #%top
(syntax-e #%plain-lambda case-lambda
(quote-syntax let-values letrec-values letrec-syntaxes+values
(quote begin begin0 set!
quote-syntax #%top with-continuation-mark
#%plain-lambda case-lambda if #%plain-app #%expression
let-values letrec-values letrec-syntaxes+values define-values define-syntaxes begin-for-syntax
begin begin0 set! module module*
with-continuation-mark #%plain-module-begin
if #%plain-app #%expression #%require #%provide #%declare
define-values define-syntaxes begin-for-syntax #%variable-reference))))
module module* (define (replace-same-free-id pat)
#%plain-module-begin (cond
#%require #%provide #%declare [(identifier? pat)
#%variable-reference))))) (or (for/or ([kernel-id (in-list kernel-ids)])
(let ([p phase]) (and (free-identifier=? pat kernel-id)
(cond (datum->syntax kernel-id (syntax-e kernel-id) pat pat)))
[(and #,(syntax-e #'rel?) (= p 0)) pat)]
free-identifier=?] [(pair? pat) (cons (replace-same-free-id (car pat))
[(and #,(syntax-e #'rel?) (= p 1)) (replace-same-free-id (cdr pat)))]
free-transformer-identifier=?] [(vector? pat)
[else (lambda (a b) (list->vector (map replace-same-free-id (vector->list pat)))]
(free-identifier=? a b p '#,(syntax-local-phase-level)))])) [(box? pat)
clause ...))]))) (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 (define-syntax kernel-syntax-case
(lambda (stx) (lambda (stx)

4
racket/collects/syntax/parse/private/runtime.rkt
View File

@ -55,10 +55,10 @@ residual.rkt.
(define-syntax-parameter fail-handler (define-syntax-parameter fail-handler
(lambda (stx) (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 (define-syntax-parameter cut-prompt
(lambda (stx) (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) (define-syntax-rule (wrap-user-code e)
(with ([fail-handler #f] (with ([fail-handler #f]

26
racket/src/configure vendored
View File

@ -5659,6 +5659,32 @@ $as_echo "$use_large_page_size" >&6; }
$as_echo "#define MZ_USE_LARGE_PAGE_SIZE 1" >>confdefs.h $as_echo "#define MZ_USE_LARGE_PAGE_SIZE 1" >>confdefs.h
fi 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 fi
if test "${enable_backtrace}" = "yes" ; then if test "${enable_backtrace}" = "yes" ; then

12
racket/src/racket/configure.ac
View File

@ -1215,6 +1215,18 @@ if test "${check_page_size}" = "yes" ; then
fi fi
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 if test "${enable_backtrace}" = "yes" ; then
GC2OPTIONS="$GC2OPTIONS -DMZ_GC_BACKTRACE" GC2OPTIONS="$GC2OPTIONS -DMZ_GC_BACKTRACE"
fi fi

1
racket/src/racket/gc2/gc2.h
View File

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

2
racket/src/racket/gc2/gc2_obj.h
View File

@ -10,7 +10,7 @@
#endif #endif
typedef struct objhead { typedef struct objhead {
/* the type and size of the object */ /* 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 */ /* these are the various mark bits we use */
uintptr_t mark : 1; uintptr_t mark : 1;
uintptr_t btc_mark : 1; uintptr_t btc_mark : 1;

3
racket/src/racket/gc2/mem_account.c
View File

@ -387,11 +387,10 @@ static void btc_overmem_abort(NewGC *gc)
static void propagate_accounting_marks(NewGC *gc) static void propagate_accounting_marks(NewGC *gc)
{ {
void *p; void *p;
Mark2_Proc *mark_table = gc->mark_table;
while(pop_ptr(gc, &p) && !gc->kill_propagation_loop) { 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)); */ /* 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) if(gc->kill_propagation_loop)
reset_pointer_stack(gc); reset_pointer_stack(gc);

775
racket/src/racket/gc2/newgc.c
View File

File diff suppressed because it is too large Load Diff

31
racket/src/racket/gc2/newgc.h
View File

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

3
racket/src/racket/gc2/vm.c
View File

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

3
racket/src/racket/gc2/weak.c
View File

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

5
racket/src/racket/gc2/xform.rkt
View File

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

1
racket/src/racket/include/mzwin.def
View File

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

1
racket/src/racket/include/mzwin3m.def
View File

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

1
racket/src/racket/include/racket.exp
View File

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

1
racket/src/racket/include/racket3m.exp
View File

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

8
racket/src/racket/include/scheme.h
View File

@ -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_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_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_VECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_vector_type)
#define SCHEME_MUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_MUTABLEP(obj)) #define SCHEME_MUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_MUTABLEP(obj))
@ -906,7 +906,7 @@ typedef struct {
typedef struct Scheme_Hash_Table 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 size; /* power of 2 */
intptr_t count; intptr_t count;
Scheme_Object **keys; Scheme_Object **keys;
@ -943,7 +943,6 @@ typedef struct Scheme_Bucket_Table
enum { enum {
SCHEME_hash_string, SCHEME_hash_string,
SCHEME_hash_ptr, SCHEME_hash_ptr,
SCHEME_hash_bound_id,
SCHEME_hash_weak_ptr, SCHEME_hash_weak_ptr,
SCHEME_hash_late_weak_ptr SCHEME_hash_late_weak_ptr
}; };
@ -1169,7 +1168,8 @@ typedef struct Scheme_Thread {
struct Scheme_Overflow *overflow; struct Scheme_Overflow *overflow;
struct Scheme_Comp_Env *current_local_env; 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_name;
Scheme_Object *current_local_modidx; Scheme_Object *current_local_modidx;
Scheme_Env *current_local_menv; Scheme_Env *current_local_menv;

55
racket/src/racket/include/schthread.h
View File

@ -89,6 +89,7 @@ MZ_EXTERN void scheme_init_os_thread(void);
#define STACK_COPY_CACHE_SIZE 10 #define STACK_COPY_CACHE_SIZE 10
#define BIGNUM_CACHE_SIZE 16 #define BIGNUM_CACHE_SIZE 16
#define STACK_CACHE_SIZE 32 #define STACK_CACHE_SIZE 32
#define NUM_MORE_CONSTANT_STXES 24
/* This structure must be 4 words: */ /* This structure must be 4 words: */
typedef struct { typedef struct {
@ -230,15 +231,13 @@ typedef struct Thread_Local_Variables {
void *stack_copy_cache_[STACK_COPY_CACHE_SIZE]; void *stack_copy_cache_[STACK_COPY_CACHE_SIZE];
intptr_t stack_copy_size_cache_[STACK_COPY_CACHE_SIZE]; intptr_t stack_copy_size_cache_[STACK_COPY_CACHE_SIZE];
int scc_pos_; int scc_pos_;
struct Scheme_Object *nominal_ipair_cache_; mzlonglong scope_counter_;
struct Scheme_Object *mark_id_;
struct Scheme_Object *current_rib_timestamp_;
struct Scheme_Hash_Table *quick_hash_table_;
struct Scheme_Object *last_phase_shift_; struct Scheme_Object *last_phase_shift_;
struct Scheme_Object *unsealed_dependencies_; struct Scheme_Object *nominal_ipair_cache_;
struct Scheme_Hash_Table *id_marks_ht_; struct Scheme_Bucket_Table *taint_intern_table_;
struct Scheme_Hash_Table *than_id_marks_ht_; struct Binding_Cache_Entry *binding_cache_table_;
struct Scheme_Bucket_Table *interned_skip_ribs_; intptr_t binding_cache_pos_;
intptr_t binding_cache_len_;
struct Scheme_Thread *scheme_current_thread_; struct Scheme_Thread *scheme_current_thread_;
struct Scheme_Thread *scheme_main_thread_; struct Scheme_Thread *scheme_main_thread_;
struct Scheme_Thread *scheme_first_thread_; struct Scheme_Thread *scheme_first_thread_;
@ -300,8 +299,6 @@ typedef struct Thread_Local_Variables {
struct Scheme_Env *initial_modules_env_; struct Scheme_Env *initial_modules_env_;
int num_initial_modules_; int num_initial_modules_;
struct Scheme_Object **initial_modules_; struct Scheme_Object **initial_modules_;
struct Scheme_Object *initial_renames_;
struct Scheme_Bucket_Table *initial_toplevel_;
int generate_lifts_count_; int generate_lifts_count_;
int special_is_ok_; int special_is_ok_;
int scheme_force_port_closed_; int scheme_force_port_closed_;
@ -361,7 +358,6 @@ typedef struct Thread_Local_Variables {
struct Scheme_Hash_Table *loaded_extensions_; struct Scheme_Hash_Table *loaded_extensions_;
struct Scheme_Hash_Table *fullpath_loaded_extensions_; struct Scheme_Hash_Table *fullpath_loaded_extensions_;
Scheme_Sleep_Proc scheme_place_sleep_; Scheme_Sleep_Proc scheme_place_sleep_;
struct Scheme_Bucket_Table *taint_intern_table_;
struct GHBN_Thread_Data *ghbn_thread_data_; struct GHBN_Thread_Data *ghbn_thread_data_;
Scheme_On_Atomic_Timeout_Proc on_atomic_timeout_; Scheme_On_Atomic_Timeout_Proc on_atomic_timeout_;
int atomic_timeout_auto_suspend_; int atomic_timeout_auto_suspend_;
@ -370,6 +366,17 @@ typedef struct Thread_Local_Variables {
struct Scheme_Object *configuration_callback_cache_[2]; struct Scheme_Object *configuration_callback_cache_[2];
struct FFI_Orig_Place_Call *cached_orig_place_todo_; struct FFI_Orig_Place_Call *cached_orig_place_todo_;
struct Scheme_Hash_Table *ffi_lock_ht_; 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; } Thread_Local_Variables;
#if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) #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 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 scc_pos XOA (scheme_get_thread_local_variables()->scc_pos_)
#define nominal_ipair_cache XOA (scheme_get_thread_local_variables()->nominal_ipair_cache_) #define nominal_ipair_cache XOA (scheme_get_thread_local_variables()->nominal_ipair_cache_)
#define mark_id XOA (scheme_get_thread_local_variables()->mark_id_) #define scope_counter XOA (scheme_get_thread_local_variables()->scope_counter_)
#define current_rib_timestamp XOA (scheme_get_thread_local_variables()->current_rib_timestamp_)
#define quick_hash_table XOA (scheme_get_thread_local_variables()->quick_hash_table_)
#define last_phase_shift XOA (scheme_get_thread_local_variables()->last_phase_shift_) #define last_phase_shift XOA (scheme_get_thread_local_variables()->last_phase_shift_)
#define unsealed_dependencies XOA (scheme_get_thread_local_variables()->unsealed_dependencies_) #define taint_intern_table XOA (scheme_get_thread_local_variables()->taint_intern_table_)
#define id_marks_ht XOA (scheme_get_thread_local_variables()->id_marks_ht_) #define binding_cache_table XOA (scheme_get_thread_local_variables()->binding_cache_table_)
#define than_id_marks_ht XOA (scheme_get_thread_local_variables()->than_id_marks_ht_) #define binding_cache_pos XOA (scheme_get_thread_local_variables()->binding_cache_pos_)
#define interned_skip_ribs XOA (scheme_get_thread_local_variables()->interned_skip_ribs_) #define binding_cache_len XOA (scheme_get_thread_local_variables()->binding_cache_len_)
#define scheme_current_thread XOA (scheme_get_thread_local_variables()->scheme_current_thread_) #define scheme_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_main_thread XOA (scheme_get_thread_local_variables()->scheme_main_thread_)
#define scheme_first_thread XOA (scheme_get_thread_local_variables()->scheme_first_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 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 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_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 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 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_) #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 loaded_extensions XOA (scheme_get_thread_local_variables()->loaded_extensions_)
#define fullpath_loaded_extensions XOA (scheme_get_thread_local_variables()->fullpath_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 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 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 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_) #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 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 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 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_)
/* **************************************** */ /* **************************************** */

3
racket/src/racket/mzconfig.h.in
View File

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

2
racket/src/racket/src/Makefile.in
View File

@ -211,7 +211,7 @@ future.@LTO@: $(srcdir)/future.c
gmp.@LTO@: $(srcdir)/gmp/gmp.c $(srcdir)/gmp/gmplonglong.h \ gmp.@LTO@: $(srcdir)/gmp/gmp.c $(srcdir)/gmp/gmplonglong.h \
$(srcdir)/../include/schthread.h $(srcdir)/../sconfig.h $(srcdir)/../include/schthread.h $(srcdir)/../sconfig.h
$(CC) $(ALL_CFLAGS) -c $(srcdir)/gmp/gmp.c -o gmp.@LTO@ $(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@ $(CC) $(ALL_CFLAGS) -c $(srcdir)/hash.c -o hash.@LTO@
jit.@LTO@: $(srcdir)/jit.c jit.@LTO@: $(srcdir)/jit.c
$(CC) $(ALL_CFLAGS) -c $(srcdir)/jit.c -o jit.@LTO@ $(CC) $(ALL_CFLAGS) -c $(srcdir)/jit.c -o jit.@LTO@

111
racket/src/racket/src/bool.c
View File

@ -60,6 +60,7 @@ typedef struct Equal_Info {
Scheme_Object *next, *next_next; Scheme_Object *next, *next_next;
Scheme_Object *insp; Scheme_Object *insp;
intptr_t for_chaperone; /* 3 => for impersonator */ intptr_t for_chaperone; /* 3 => for impersonator */
intptr_t eq_for_modidx;
} Equal_Info; } Equal_Info;
static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql); 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); 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 * static Scheme_Object *
equal_prim (int argc, Scheme_Object *argv[]) equal_prim (int argc, Scheme_Object *argv[])
{ {
Equal_Info eql; Equal_Info eql;
eql.depth = 1; init_equal_info(&eql);
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next = NULL;
eql.next_next = NULL;
eql.insp = NULL;
eql.for_chaperone = 0;
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false); 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); scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv);
eql.depth = 1; init_equal_info(&eql);
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next = NULL;
eql.next_next = argv[2]; eql.next_next = argv[2];
eql.insp = NULL;
eql.for_chaperone = 0;
return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false); 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: case scheme_char_type:
return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2); 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: default:
return -1; return -1;
} }
@ -418,14 +424,7 @@ int is_slow_equal (Scheme_Object *obj1, Scheme_Object *obj2)
{ {
Equal_Info eql; Equal_Info eql;
eql.depth = 1; init_equal_info(&eql);
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next_next = NULL;
eql.next = NULL;
eql.insp = NULL;
eql.for_chaperone = 0;
return is_equal(obj1, obj2, &eql); 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); 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) static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht)
{ {
Scheme_Object *v, *prev = obj1, *prev_prev = obj1; 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, /* 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 as long as the interpositions are the same and the underlying
values are `{impersonator,chaperone}-of?`: */ values are `{impersonator,chaperone}-of?`: */
if (SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj1)->val), scheme_hash_tree_type) if (SCHEME_HASHTRP(((Scheme_Chaperone *)obj1)->val)
&& SAME_TYPE(SCHEME_TYPE(((Scheme_Chaperone *)obj2)->val), scheme_hash_tree_type) && SCHEME_HASHTRP(((Scheme_Chaperone *)obj2)->val)
/* eq redirects means redirects were propagated: */ /* eq redirects means redirects were propagated: */
&& SAME_OBJ(((Scheme_Chaperone *)obj1)->redirects, && SAME_OBJ(((Scheme_Chaperone *)obj1)->redirects,
((Scheme_Chaperone *)obj2)->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)) { if (SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->val; obj1 = ((Scheme_Chaperone *)obj1)->val;
goto top_after_next; 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)) { if (SCHEME_CHAPERONEP(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->val; obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next; 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; return 0;
@ -810,6 +825,9 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
eql); eql);
} }
case scheme_hash_tree_type: 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" # include "mzeqchk.inc"
if (union_check(obj1, obj2, eql)) 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: case scheme_module_index_type:
{ {
Scheme_Modidx *midx1, *midx2; if (!eql->eq_for_modidx) {
Scheme_Modidx *midx1, *midx2;
# include "mzeqchk.inc" # include "mzeqchk.inc"
midx1 = (Scheme_Modidx *)obj1; midx1 = (Scheme_Modidx *)obj1;
midx2 = (Scheme_Modidx *)obj2; midx2 = (Scheme_Modidx *)obj2;
if (is_equal(midx1->path, midx2->path, eql)) { if (is_equal(midx1->path, midx2->path, eql)) {
obj1 = midx1->base; obj1 = midx1->base;
obj2 = midx2->base; obj2 = midx2->base;
goto top; goto top;
} else
return 0;
} else } else
return 0; 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: default:
if (!eql->for_chaperone && ((t1 == scheme_chaperone_type) if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) { || (t1 == scheme_proc_chaperone_type))) {
@ -968,13 +999,7 @@ int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
{ {
Equal_Info eql; Equal_Info eql;
eql.depth = 1; init_equal_info(&eql);
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next = NULL;
eql.next_next = NULL;
eql.insp = NULL;
eql.for_chaperone = 1; eql.for_chaperone = 1;
return is_equal(obj1, obj2, &eql); return is_equal(obj1, obj2, &eql);
@ -984,13 +1009,7 @@ int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2)
{ {
Equal_Info eql; Equal_Info eql;
eql.depth = 1; init_equal_info(&eql);
eql.car_depth = 1;
eql.ht = NULL;
eql.recur = NULL;
eql.next = NULL;
eql.next_next = NULL;
eql.insp = NULL;
eql.for_chaperone = 3; eql.for_chaperone = 3;
return is_equal(obj1, obj2, &eql); return is_equal(obj1, obj2, &eql);

1836
racket/src/racket/src/compenv.c
View File

File diff suppressed because it is too large Load Diff

937
racket/src/racket/src/compile.c
View File

File diff suppressed because it is too large Load Diff

3084
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

643
racket/src/racket/src/env.c
View File

@ -47,13 +47,17 @@ THREAD_LOCAL_DECL(int scheme_starting_up);
/* globals READ-ONLY SHARED */ /* globals READ-ONLY SHARED */
Scheme_Object *scheme_varref_const_p_proc; 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 *kernel_env;
READ_ONLY static Scheme_Env *unsafe_env; READ_ONLY static Scheme_Env *unsafe_env;
READ_ONLY static Scheme_Env *flfxnum_env; READ_ONLY static Scheme_Env *flfxnum_env;
READ_ONLY static Scheme_Env *extfl_env; READ_ONLY static Scheme_Env *extfl_env;
READ_ONLY static Scheme_Env *futures_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); THREAD_LOCAL_DECL(static int intdef_counter);
static int builtin_ref_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_phase_level(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_make_intdef_context(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_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 *intdef_context_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *id_intdef_remove(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_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_get_shadower(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_module_exports(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[]); 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 *local_lift_provide(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_introducer(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_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 *make_set_transformer(int argc, Scheme_Object *argv[]);
static Scheme_Object *set_transformer_p(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[]); 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_current_thread->name = sym;
} }
scheme_init_stx_places(initial_main_os_thread);
scheme_init_syntax_bindings();
scheme_init_module_resolver(); scheme_init_module_resolver();
#ifdef TIME_STARTUP_PROCESS #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_eval_places();
scheme_init_compile_places(); scheme_init_compile_places();
scheme_init_regexp_places(); scheme_init_regexp_places();
scheme_init_stx_places(initial_main_os_thread);
scheme_init_sema_places(); scheme_init_sema_places();
scheme_init_gmp_places(); scheme_init_gmp_places();
scheme_init_kqueue(); 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-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-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-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-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("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("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("syntax-local-introduce", local_introduce, 1, 1, env);
GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 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-make-delta-introducer", local_make_delta_introduce, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 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?", set_transformer_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 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?", rename_transformer_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 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); REGISTER_SO(kernel_symbol);
kernel_symbol = scheme_intern_symbol("#%kernel"); 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(); MARK_START_TIME();
scheme_finish_kernel(env); scheme_finish_kernel(env);
@ -856,18 +873,30 @@ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client
/* namespace constructors */ /* namespace constructors */
/*========================================================================*/ /*========================================================================*/
void scheme_prepare_env_renames(Scheme_Env *env, int kind) void scheme_prepare_env_stx_context(Scheme_Env *env)
{ {
if (!env->rename_set) { Scheme_Object *mc, *shift, *insp;
Scheme_Object *rns, *insp;
insp = env->access_insp; if (env->stx_context) return;
if (!insp)
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
rns = scheme_make_module_rename_set(kind, NULL, insp); insp = env->access_insp;
env->rename_set = rns; 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) 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); hash_table = scheme_make_hash_table(SCHEME_hash_ptr);
reg->loaded = hash_table; reg->loaded = hash_table;
hash_table = scheme_make_hash_table(SCHEME_hash_ptr); 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; reg->exports = hash_table;
env->label_env = NULL; env->label_env = NULL;
@ -946,6 +976,11 @@ static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size)
return env; return env;
} }
Scheme_Env *scheme_make_env_like(Scheme_Env *base)
{
return make_env(base, 10);
}
Scheme_Env * Scheme_Env *
scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, scheme_new_module_env(Scheme_Env *env, Scheme_Module *m,
int new_exp_module_tree, int new_pre_registry) 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) { if (!env->exp_env) {
Scheme_Env *eenv; Scheme_Env *eenv;
Scheme_Object *modchain; Scheme_Object *modchain, *mc;
scheme_prepare_label_env(env); scheme_prepare_label_env(env);
@ -1031,8 +1066,9 @@ void scheme_prepare_exp_env(Scheme_Env *env)
eenv->label_env = env->label_env; eenv->label_env = env->label_env;
eenv->instance_env = env->instance_env; eenv->instance_env = env->instance_env;
scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); scheme_prepare_env_stx_context(env);
eenv->rename_set = env->rename_set; mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv));
eenv->stx_context = mc;
if (env->disallow_unbound) if (env->disallow_unbound)
eenv->disallow_unbound = 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) { if (!env->template_env) {
Scheme_Env *eenv; Scheme_Env *eenv;
Scheme_Object *modchain; Scheme_Object *modchain, *mc;
scheme_prepare_label_env(env); scheme_prepare_label_env(env);
@ -1069,8 +1105,9 @@ void scheme_prepare_template_env(Scheme_Env *env)
} }
eenv->modchain = modchain; eenv->modchain = modchain;
scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); scheme_prepare_env_stx_context(env);
eenv->rename_set = env->rename_set; mc = scheme_module_context_at_phase(env->stx_context, scheme_env_phase(eenv));
eenv->stx_context = mc;
env->template_env = eenv; env->template_env = eenv;
eenv->exp_env = env; 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) 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 /* 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); scheme_do_add_global_symbol(env, name, obj, 0, 0);
} }
void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo) static Scheme_Object *vector_to_ht(Scheme_Object *vec, int kind)
{ {
Scheme_Object *rn; Scheme_Hash_Tree *ht;
Scheme_Object *key, *val;
intptr_t i;
if (!env) return; ht = scheme_make_hash_tree(kind);
if (env->rename_set) { i = SCHEME_VEC_SIZE(vec);
rn = scheme_get_module_rename_from_set(env->rename_set, if (i & 1) return (Scheme_Object *)ht; /* defend against bad bytecode */
scheme_make_integer(env->phase),
0); while (i -= 2) {
if (rn) { key = SCHEME_VEC_ELS(vec)[i];
scheme_remove_module_rename(rn, n); val = SCHEME_VEC_ELS(vec)[i+1];
if (env->module) {
scheme_extend_module_rename(rn, /* defend against bad bytecode here, too: */
env->module->self_modidx, if (kind) {
n, n, if (!SCHEME_INTP(key)
env->module->self_modidx, || !SCHEME_VECTORP(val))
n, key = NULL;
env->mod_phase, } else {
NULL, if (!SCHEME_SYMBOLP(key)
NULL, || ((!SCHEME_STXP(val)
0); || !SCHEME_SYMBOLP(SCHEME_STX_VAL(val)))
} && !SAME_OBJ(val, scheme_true)))
key = NULL;
} }
if (key) {
if (kind)
val = vector_to_ht(val, 0);
else if (!SAME_OBJ(val, scheme_true))
val = scheme_stx_force_delayed(val);
ht = scheme_hash_tree_set(ht, key, val);
}
}
return (Scheme_Object *)ht;
}
void scheme_binding_names_from_module(Scheme_Env *menv)
{
Scheme_Module *m;
Scheme_Object *binding_names;
if (menv->binding_names
|| !menv->module
|| menv->binding_names_need_shift)
return;
m = menv->module;
if (menv->phase == 0) {
binding_names = m->binding_names;
if (binding_names && SCHEME_VECTORP(binding_names)) {
binding_names = vector_to_ht(binding_names, 0);
m->binding_names = binding_names;
}
} else if (menv->phase == 1) {
binding_names = m->et_binding_names;
if (binding_names && SCHEME_VECTORP(binding_names)) {
binding_names = vector_to_ht(binding_names, 0);
m->et_binding_names = binding_names;
}
} else if (m->other_binding_names) {
binding_names = m->other_binding_names;
if (binding_names && SCHEME_VECTORP(binding_names)) {
binding_names = vector_to_ht(binding_names, 1);
m->other_binding_names = binding_names;
}
if (SCHEME_HASHTP(binding_names))
binding_names = scheme_hash_get((Scheme_Hash_Table *)binding_names, scheme_env_phase(menv));
else
binding_names = scheme_hash_tree_get((Scheme_Hash_Tree *)binding_names, scheme_env_phase(menv));
} else } else
rn = NULL; binding_names = NULL;
if (stxtoo) { menv->binding_names = binding_names;
if (!env->module || rn) { menv->binding_names_need_shift = 1;
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 { } else {
if (env->shadowed_syntax) if (env->shadowed_syntax)
scheme_hash_set(env->shadowed_syntax, n, NULL); 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 **********/ /********** Auxilliary tables **********/
@ -1625,9 +1782,7 @@ namespace_identifier(int argc, Scheme_Object *argv[])
obj = argv[0]; obj = argv[0];
obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0); obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0);
/* Renamings: */ obj = scheme_stx_add_module_context(obj, genv->stx_context);
if (genv->rename_set)
obj = scheme_add_rename(obj, genv->rename_set);
return obj; return obj;
} }
@ -1641,7 +1796,7 @@ namespace_module_identifier(int argc, Scheme_Object *argv[])
if (argc > 0) { if (argc > 0) {
if (SCHEME_NAMESPACEP(argv[0])) { if (SCHEME_NAMESPACEP(argv[0])) {
genv = (Scheme_Env *)argv[0]; genv = (Scheme_Env *)argv[0];
phase = scheme_make_integer(genv->phase); phase = scheme_env_phase(genv);
} else if (SCHEME_FALSEP(argv[0])) { } else if (SCHEME_FALSEP(argv[0])) {
phase = scheme_false; phase = scheme_false;
} else if (SCHEME_INTP(argv[0]) || SCHEME_BIGNUMP(argv[0])) { } else if (SCHEME_INTP(argv[0]) || SCHEME_BIGNUMP(argv[0])) {
@ -1652,7 +1807,7 @@ namespace_module_identifier(int argc, Scheme_Object *argv[])
} }
} else { } else {
genv = scheme_get_env(NULL); 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, return scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false,
@ -1672,7 +1827,7 @@ namespace_base_phase(int argc, Scheme_Object *argv[])
else else
genv = scheme_get_env(NULL); genv = scheme_get_env(NULL);
return scheme_make_integer(genv->phase); return scheme_env_phase(genv);
} }
static Scheme_Object * 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); scheme_set_global_bucket("namespace-set-variable-value!", bucket, argv[1], 1);
if ((argc > 2) && SCHEME_TRUEP(argv[2])) { 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; return scheme_void;
@ -1814,8 +1981,8 @@ namespace_mapped_symbols(int argc, Scheme_Object *argv[])
} }
} }
if (env->rename_set) if (env->stx_context)
scheme_list_module_rename(env->rename_set, mapped, env->module_registry->exports); scheme_module_context_add_mapped_symbols(env->stx_context, mapped);
l = scheme_null; l = scheme_null;
for (i = mapped->size; i--; ) { for (i = mapped->size; i--; ) {
@ -2054,19 +2221,23 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r
} }
} }
if (scheme_current_thread->current_local_mark) if (scheme_current_thread->current_local_scope)
sym = scheme_add_remove_mark(sym, scheme_current_thread->current_local_mark); sym = scheme_stx_flip_scope(sym, scheme_current_thread->current_local_scope,
scheme_env_phase(env->genv));
menv = NULL; menv = NULL;
while (1) { while (1) {
v = scheme_lookup_binding(sym, env, v = scheme_compile_lookup(sym, env,
(SCHEME_NULL_FOR_UNBOUND (SCHEME_NULL_FOR_UNBOUND
+ SCHEME_RESOLVE_MODIDS + SCHEME_RESOLVE_MODIDS
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + 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, scheme_current_thread->current_local_modidx,
&menv, NULL, NULL, NULL); &menv, NULL,
NULL, NULL,
NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(observer, sym); SCHEME_EXPAND_OBSERVE_RESOLVE(observer, sym);
@ -2204,7 +2375,7 @@ local_make_intdef_context(int argc, Scheme_Object *argv[])
Scheme_Object *c, *rib; Scheme_Object *c, *rib;
void **d; void **d;
d = MALLOC_N(void*, 3); d = MALLOC_N(void*, 4);
env = scheme_current_thread->current_local_env; env = scheme_current_thread->current_local_env;
if (!env) if (!env)
@ -2224,8 +2395,12 @@ local_make_intdef_context(int argc, Scheme_Object *argv[])
d[1] = argv[0]; d[1] = argv[0];
} }
d[0] = env; 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 = scheme_alloc_object();
c->type = scheme_intdef_context_type; 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", scheme_wrong_contract("internal-definition-context-seal",
"internal-definition-context?", 0, argc, argv); "internal-definition-context?", 0, argc, argv);
scheme_stx_seal_rib(SCHEME_PTR2_VAL(argv[0]));
return scheme_void; 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 * static Scheme_Object *
id_intdef_remove(int argc, Scheme_Object *argv[]) 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]))) if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
scheme_wrong_contract("identifier-remove-from-definition-context", scheme_wrong_contract("identifier-remove-from-definition-context",
@ -2280,21 +2480,16 @@ id_intdef_remove(int argc, Scheme_Object *argv[])
l = scheme_make_pair(l, scheme_null); l = scheme_make_pair(l, scheme_null);
res = argv[0]; 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)) { while (SCHEME_PAIRP(l)) {
res = scheme_stx_id_remove_rib(res, SCHEME_PTR2_VAL(SCHEME_CAR(l))); scope = SCHEME_PTR2_VAL(SCHEME_CAR(l));
skips = scheme_make_pair(SCHEME_PTR2_VAL(SCHEME_CAR(l)), skips); if (SCHEME_BOXP(scope)) scope = SCHEME_BOX_VAL(scope);
res = scheme_stx_remove_scope(res, scope, phase);
l = SCHEME_CDR(l); 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; return res;
} }
@ -2312,43 +2507,10 @@ local_introduce(int argc, Scheme_Object *argv[])
if (!SCHEME_STXP(s)) if (!SCHEME_STXP(s))
scheme_wrong_contract("syntax-local-introduce", "syntax?", 0, argc, argv); scheme_wrong_contract("syntax-local-introduce", "syntax?", 0, argc, argv);
if (scheme_current_thread->current_local_mark) if (scheme_current_thread->current_local_scope)
s = scheme_add_remove_mark(s, scheme_current_thread->current_local_mark); s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_scope, scheme_env_phase(env->genv));
if (scheme_current_thread->current_local_use_scope)
return s; s = scheme_stx_flip_scope(s, scheme_current_thread->current_local_use_scope, scheme_env_phase(env->genv));
}
static Scheme_Object *
local_module_introduce(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env;
Scheme_Object *s, *v;
env = scheme_current_thread->current_local_env;
if (!env)
not_currently_transforming("syntax-local-module-introduce");
s = argv[0];
if (!SCHEME_STXP(s))
scheme_wrong_contract("syntax-local-module-introduce", "syntax?", 0, argc, argv);
v = scheme_stx_source_module(s, 0, 0);
if (SCHEME_FALSEP(v)) {
if (env->genv->module
&& env->genv->module->rn_stx
&& SCHEME_VECTORP(env->genv->module->rn_stx)) {
/* This is a submodule, and `rn_stx' has renames for the enclosing modules */
int i;
for (i = SCHEME_VEC_SIZE(env->genv->module->rn_stx); i-- > 1; ) {
v = SCHEME_VEC_ELS(env->genv->module->rn_stx)[i];
s = scheme_add_rename(s, scheme_stx_to_rename(v));
}
}
if (env->genv->rename_set)
s = scheme_add_rename(s, env->genv->rename_set);
if (env->genv->post_ex_rename_set)
s = scheme_add_rename(s, env->genv->post_ex_rename_set);
}
return s; return s;
} }
@ -2357,188 +2519,94 @@ static Scheme_Object *
local_get_shadower(int argc, Scheme_Object *argv[]) local_get_shadower(int argc, Scheme_Object *argv[])
{ {
Scheme_Comp_Env *env; 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; env = scheme_current_thread->current_local_env;
if (!env) if (!env)
not_currently_transforming("syntax-local-get-shadower"); not_currently_transforming("syntax-local-get-shadower");
sym = argv[0]; sym = argv[0];
orig_sym = sym;
if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym)))) if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym))))
scheme_wrong_contract("syntax-local-get-shadower", "identifier?", 0, argc, argv); 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) { int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv)
uid = scheme_tl_id_sym(env->genv, sym, NULL, 0, {
scheme_make_integer(env->genv->phase), NULL); int mode = SCHEME_STX_FLIP;
if (!SAME_OBJ(uid, SCHEME_STX_VAL(sym))) {
/* has a toplevel biding via marks or context; keep it */
} else {
/* No lexical shadower, but strip module context, if any */
sym = scheme_stx_strip_module_context(sym);
/* Add current module context, if any */
sym = local_module_introduce(1, &sym);
if (!scheme_stx_is_clean(orig_sym)) if (SAME_OBJ(argv[which], flip_symbol))
sym = scheme_stx_taint(sym); 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 sym; return mode;
}
{
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;
}
} }
static Scheme_Object * static Scheme_Object *
introducer_proc(void *mark, int argc, Scheme_Object *argv[]) introducer_proc(void *info, int argc, Scheme_Object *argv[])
{ {
Scheme_Object *s; Scheme_Object *s;
int mode = SCHEME_STX_FLIP;
s = argv[0]; s = argv[0];
if (!SCHEME_STXP(s)) if (!SCHEME_STXP(s)) {
scheme_wrong_contract("syntax-introducer", "syntax?", 0, argc, argv); 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 * static Scheme_Object *
make_introducer(int argc, Scheme_Object *argv[]) make_introducer(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *mark; Scheme_Object *scope, **info;
Scheme_Env *genv;
mark = scheme_new_mark(); scope = scheme_new_scope(SCHEME_STX_MACRO_SCOPE);
info = MALLOC_N(Scheme_Object*, 2);
return scheme_make_closed_prim_w_arity(introducer_proc, mark, info[0] = scope;
"syntax-introducer", 1, 1); if (scheme_current_thread->current_local_env)
info[1] = scheme_env_phase(scheme_current_thread->current_local_env->genv);
else {
genv = (Scheme_Env *)scheme_get_param(scheme_current_config(), MZCONFIG_ENV);
info[1] = scheme_env_phase(genv);
}
return scheme_make_closed_prim_w_arity(introducer_proc, info,
"syntax-introducer", 1, 2);
} }
static Scheme_Object * static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[])
delta_introducer_proc(void *_i_plus_m, int argc, Scheme_Object *argv[])
{ {
Scheme_Object *p = (Scheme_Object *)_i_plus_m, *l, *v, *a[1]; scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "syntax-local-make-delta-introducer: " NOT_SUPPORTED_STR);
const char *who = "delta introducer attached to a rename transformer"; ESCAPED_BEFORE_HERE;
v = argv[0];
if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) {
scheme_wrong_contract(who, "identifier?", 0, argc, argv);
}
/* Apply mapping functions: */
l = SCHEME_CDR(p);
while (SCHEME_PAIRP(l)) {
a[0] = v;
v = _scheme_apply(SCHEME_CAR(l), 1, a);
l = SCHEME_CDR(l);
}
/* Apply delta-introducing functions: */
l = SCHEME_CAR(p);
while (SCHEME_PAIRP(l)) {
a[0] = v;
v = _scheme_apply(SCHEME_CAR(l), 1, a);
if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) {
a[0] = v;
scheme_wrong_contract(who, "identifier?", -1, -1, a);
}
l = SCHEME_CDR(l);
}
return v;
} }
static Scheme_Object * static Scheme_Object *local_binding_id(int argc, Scheme_Object **argv)
local_make_delta_introduce(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *sym, *binder, *introducer, *a[2], *v; Scheme_Object *a = argv[0];
Scheme_Object *introducers = scheme_null, *mappers = scheme_null;
int renamed = 0;
Scheme_Comp_Env *env;
env = scheme_current_thread->current_local_env; if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a))
if (!env) scheme_wrong_contract("syntax-local-identifier-as-binding", "identifier?", 0, argc, argv);
not_currently_transforming("syntax-local-make-delta-introducer");
if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) if (scheme_current_thread->current_local_env)
scheme_wrong_contract("syntax-local-make-delta-introducer", "identifier?", 0, argc, argv); return scheme_revert_use_site_scopes(a, scheme_current_thread->current_local_env);
else
sym = argv[0]; return a;
while (1) {
binder = NULL;
v = scheme_lookup_binding(sym, env,
(SCHEME_NULL_FOR_UNBOUND
+ SCHEME_RESOLVE_MODIDS
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST),
scheme_current_thread->current_local_modidx,
NULL, NULL, &binder, NULL);
/* Deref globals */
if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type))
v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val;
if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) {
scheme_contract_error("syntax-local-make-delta-introducer",
(renamed
? "not defined as syntax (after renaming)"
: "not defined as syntax"),
"identifier", 1, argv[0],
NULL);
}
if (!binder) {
/* Not a lexical biding. Tell make-syntax-delta-introducer to
use module-binding information. */
binder = scheme_false;
}
a[0] = sym;
a[1] = binder;
introducer = scheme_syntax_make_transfer_intro(2, a);
introducers = scheme_make_pair(introducer, introducers);
v = SCHEME_PTR_VAL(v);
if (scheme_is_rename_transformer(v)) {
sym = scheme_rename_transformer_id(v);
v = SCHEME_PTR2_VAL(v);
if (!SCHEME_FALSEP(v))
mappers = scheme_make_pair(v, mappers);
renamed = 1;
SCHEME_USE_FUEL(1);
} else {
/* that's the end of the chain */
mappers = scheme_reverse(mappers);
return scheme_make_closed_prim_w_arity(delta_introducer_proc,
scheme_make_pair(introducers, mappers),
"syntax-delta-introducer", 1, 1);
}
}
} }
Scheme_Object *scheme_get_local_inspector() Scheme_Object *scheme_get_local_inspector()
@ -2674,57 +2742,57 @@ static Scheme_Object *
local_lift_end_statement(int argc, Scheme_Object *argv[]) local_lift_end_statement(int argc, Scheme_Object *argv[])
{ {
Scheme_Comp_Env *env; Scheme_Comp_Env *env;
Scheme_Object *local_mark, *expr; Scheme_Object *local_scope, *expr;
expr = argv[0]; expr = argv[0];
if (!SCHEME_STXP(expr)) if (!SCHEME_STXP(expr))
scheme_wrong_contract("syntax-local-lift-module-end-declaration", "syntax?", 0, argc, argv); scheme_wrong_contract("syntax-local-lift-module-end-declaration", "syntax?", 0, argc, argv);
env = scheme_current_thread->current_local_env; 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) if (!env)
not_currently_transforming("syntax-local-lift-module-end-declaration"); 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[]) static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[])
{ {
Scheme_Comp_Env *env; Scheme_Comp_Env *env;
Scheme_Object *local_mark; Scheme_Object *local_scope;
intptr_t phase; intptr_t phase;
if (!SCHEME_STXP(argv[1])) if (!SCHEME_STXP(argv[1]))
scheme_wrong_contract("syntax-local-lift-require", "syntax?", 1, argc, argv); scheme_wrong_contract("syntax-local-lift-require", "syntax?", 1, argc, argv);
env = scheme_current_thread->current_local_env; 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) if (!env)
not_currently_transforming("syntax-local-lift-require"); not_currently_transforming("syntax-local-lift-require");
phase = env->genv->phase; 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[]) static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[])
{ {
Scheme_Comp_Env *env; Scheme_Comp_Env *env;
Scheme_Object *form, *local_mark; Scheme_Object *form, *local_scope;
form = argv[0]; form = argv[0];
if (!SCHEME_STXP(form)) if (!SCHEME_STXP(form))
scheme_wrong_contract("syntax-local-lift-provide", "syntax?", 1, argc, argv); scheme_wrong_contract("syntax-local-lift-provide", "syntax?", 1, argc, argv);
env = scheme_current_thread->current_local_env; 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) if (!env)
not_currently_transforming("syntax-local-lift-provide"); 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 * 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]))) if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
scheme_wrong_contract("make-rename-transformer", "identifier?", 0, argc, argv); 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 = scheme_alloc_object();
v->type = scheme_id_macro_type; v->type = scheme_id_macro_type;
SCHEME_PTR1_VAL(v) = argv[0]; 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; return v;
} }

25
racket/src/racket/src/error.c
View File

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

321
racket/src/racket/src/eval.c
View File

@ -869,9 +869,11 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
} }
if (check_access && !SAME_OBJ(menv, env)) { if (check_access && !SAME_OBJ(menv, env)) {
varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL, varname = scheme_check_accessible_in_module(menv, NULL, varname, NULL,
insp, NULL, pos, 0, NULL, NULL, env, NULL, NULL, insp,
NULL); pos, 0,
NULL, NULL,
env, NULL, NULL);
} }
} }
@ -2002,14 +2004,14 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro,
SCHEME_PTR_VAL(macro) = values[i]; SCHEME_PTR_VAL(macro) = values[i];
scheme_set_global_bucket("define-syntaxes", b, macro, 1); 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 { } else {
Scheme_Prefix *toplevels; Scheme_Prefix *toplevels;
toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)];
scheme_set_global_bucket("define-values", b, values[i], 1); 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 (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) {
if (is_st) 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_PTR_VAL(macro) = vals;
scheme_set_global_bucket("define-syntaxes", b, macro, 1); 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 { } else {
Scheme_Prefix *toplevels; Scheme_Prefix *toplevels;
toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)];
scheme_set_global_bucket("define-values", b, vals, 1); 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) { if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) {
int flags = GLOB_IS_IMMUTATED; 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]; 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) if (!dm_env)
dm_env = scheme_environment_from_dummy(dummy); 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_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); 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)) { if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_syntaxes_type)) {
(void)define_execute_with_dynamic_state(form, 4, 1, rp, dm_env, &dyn_state); (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]; v = globs->a[i+pos+1];
if (!v) { if (!v) {
v = globs->a[pos]; 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; globs->a[i+pos+1] = v;
} }
@ -3891,36 +3895,32 @@ Scheme_Object **scheme_current_argument_stack()
/* eval/compile/expand starting points */ /* eval/compile/expand starting points */
/*========================================================================*/ /*========================================================================*/
static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env *genv) Scheme_Object *scheme_top_introduce(Scheme_Object *form, Scheme_Env *genv)
{ {
if (genv->rename_set) { scheme_prepare_env_stx_context(genv);
if (SCHEME_STX_PAIRP(form)) {
Scheme_Object *a, *d, *module_stx;
a = SCHEME_STX_CAR(form); if (SCHEME_STX_PAIRP(form)) {
if (SCHEME_STX_SYMBOLP(a)) { Scheme_Object *a, *d, *module_stx;
a = scheme_add_rename(a, genv->rename_set);
module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), a = SCHEME_STX_CAR(form);
scheme_false, if (SCHEME_STX_SYMBOLP(a)) {
scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), a = scheme_stx_push_module_context(a, genv->stx_context);
0, 0); module_stx = scheme_datum_to_syntax(module_symbol,
if (scheme_stx_module_eq(a, module_stx, genv->phase)) { scheme_false,
/* Don't add renames to the whole module; let the scheme_sys_wraps_phase(scheme_make_integer(genv->phase)),
module's language take over. */ 0, 0);
d = SCHEME_STX_CDR(form); if (scheme_stx_free_eq(a, module_stx, genv->phase)) {
a = scheme_make_pair(a, d); /* Don't add context to the whole module, since the
form = scheme_datum_to_syntax(a, form, form, 0, 1); `module` form will just discard it: */
return form; 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_stx_push_module_context(form, genv->stx_context);
form = scheme_add_rename(form, genv->rename_set);
/* this "phase shift" just attaches the namespace's module registry: */
form = scheme_stx_phase_shift(form, NULL, NULL, NULL, genv->module_registry->exports, NULL, NULL);
}
return form; return form;
} }
@ -3963,7 +3963,7 @@ static int get_comp_flags(Scheme_Config *config)
static void *compile_k(void) static void *compile_k(void)
{ {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
Scheme_Object *form; Scheme_Object *form, *frame_scopes;
int writeable, for_eval, rename, enforce_consts, comp_flags; int writeable, for_eval, rename, enforce_consts, comp_flags;
Scheme_Env *genv; Scheme_Env *genv;
Scheme_Compile_Info rec, rec2; Scheme_Compile_Info rec, rec2;
@ -3991,14 +3991,7 @@ static void *compile_k(void)
/* Renamings for requires: */ /* Renamings for requires: */
if (rename) { if (rename) {
form = add_renames_unless_module(form, genv); form = scheme_top_introduce(form, genv);
if (genv->module) {
form = scheme_stx_phase_shift(form, NULL,
genv->module->me->src_modidx,
genv->module->self_modidx,
genv->module_registry->exports,
NULL, NULL);
}
} }
tl_queue = scheme_null; tl_queue = scheme_null;
@ -4013,19 +4006,36 @@ static void *compile_k(void)
comp_flags |= COMP_ENFORCE_CONSTS; 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) { while (1) {
scheme_prepare_compile_env(genv); scheme_prepare_compile_env(genv);
rec.comp = 1; rec.comp = 1;
rec.dont_mark_local_use = 0; rec.dont_mark_local_use = 0;
rec.resolve_module_ids = !writeable && !genv->module; rec.resolve_module_ids = !writeable && !genv->module;
rec.substitute_bindings = 1;
rec.value_name = scheme_false; rec.value_name = scheme_false;
rec.observer = NULL; rec.observer = NULL;
rec.pre_unwrapped = 0; rec.pre_unwrapped = 0;
rec.env_already = 0; rec.env_already = 0;
rec.comp_flags = comp_flags; 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) { if (for_eval) {
/* Need to look for top-level `begin', and if we /* 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); scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false);
form = scheme_check_immediate_macro(form, form = scheme_check_immediate_macro(form,
cenv, &rec, 0, cenv, &rec, 0,
0, &gval, NULL, NULL, &gval,
1); 1);
if (SAME_OBJ(gval, scheme_begin_syntax)) { if (SAME_OBJ(gval, scheme_begin_syntax)) {
if (scheme_stx_proper_list_length(form) > 1){ if (scheme_stx_proper_list_length(form) > 1){
form = scheme_stx_push_introduce_module_context(form, genv->stx_context);
form = SCHEME_STX_CDR(form); form = SCHEME_STX_CDR(form);
tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL), tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL),
tl_queue); tl_queue);
@ -4054,12 +4065,15 @@ static void *compile_k(void)
o = scheme_frame_get_lifts(cenv); o = scheme_frame_get_lifts(cenv);
if (!SCHEME_NULLP(o) if (!SCHEME_NULLP(o)
|| !SCHEME_NULLP(rl)) { || !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_make_pair(form, tl_queue);
tl_queue = scheme_append(o, tl_queue); tl_queue = scheme_append(o, tl_queue);
tl_queue = scheme_append(rl, tl_queue); tl_queue = scheme_append(rl, tl_queue);
form = SCHEME_CAR(tl_queue); form = SCHEME_CAR(tl_queue);
tl_queue = SCHEME_CDR(tl_queue); tl_queue = SCHEME_CDR(tl_queue);
} } else
form = scheme_stx_push_introduce_module_context(form, genv->stx_context);
break; break;
} }
} }
@ -4117,7 +4131,7 @@ static void *compile_k(void)
scheme_optimize_info_never_inline(oi); scheme_optimize_info_never_inline(oi);
o = scheme_optimize_expr(o, oi, 0); 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); ri = scheme_resolve_info_create(rp);
scheme_resolve_info_enforce_const(ri, enforce_consts); scheme_resolve_info_enforce_const(ri, enforce_consts);
scheme_enable_expression_resolve_lifts(ri); 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); result = scheme_make_vector(len - 1, NULL);
for (i = 0; i < len - 1; i++) { for (i = 0; i < len - 1; i++) {
s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], scheme_make_integer(shift), orig, modidx, s = SCHEME_VEC_ELS(expr)[i];
env->module_registry->exports, NULL, NULL); s = scheme_stx_shift(s,
scheme_make_integer(shift),
orig, modidx,
env->module_registry->exports,
NULL, NULL);
SCHEME_VEC_ELS(result)[i] = s; SCHEME_VEC_ELS(result)[i] = s;
} }
@ -4483,7 +4501,7 @@ static void *expand_k(void)
if (rename > 0) { if (rename > 0) {
/* Renamings for requires: */ /* Renamings for requires: */
obj = add_renames_unless_module(obj, env->genv); obj = scheme_top_introduce(obj, env->genv);
} }
observer = scheme_get_expand_observe(); observer = scheme_get_expand_observe();
@ -4493,7 +4511,7 @@ static void *expand_k(void)
if (as_local < 0) { if (as_local < 0) {
/* Insert a dummy frame so that `pair_lifted' can add more. */ /* 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 = MALLOC_N(Scheme_Comp_Env *, 1);
*ip = env; *ip = env;
} else } else
@ -4504,12 +4522,13 @@ static void *expand_k(void)
/* Loop for lifted expressions: */ /* Loop for lifted expressions: */
while (1) { while (1) {
erec1.comp = 0; erec1.comp = 0;
erec1.depth = depth; erec1.depth = ((depth == -3) ? -2 : depth);
erec1.value_name = scheme_false; erec1.value_name = scheme_false;
erec1.observer = observer; erec1.observer = observer;
erec1.pre_unwrapped = 0; erec1.pre_unwrapped = 0;
erec1.env_already = 0; erec1.env_already = 0;
erec1.comp_flags = comp_flags; erec1.comp_flags = comp_flags;
erec1.substitute_bindings = (depth != -3);
if (catch_lifts_key) { if (catch_lifts_key) {
Scheme_Object *data; Scheme_Object *data;
@ -4524,7 +4543,7 @@ static void *expand_k(void)
if (just_to_top) { if (just_to_top) {
Scheme_Object *gval; 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 } else
obj = scheme_expand_expr(obj, env, &erec1, 0); 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, int depth, int rename, int just_to_top,
Scheme_Object *catch_lifts_key, int eb, Scheme_Object *catch_lifts_key, int eb,
int as_local) 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; 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) 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); -1, 1, 0, scheme_false, -1, 0);
} }
@ -4629,7 +4651,7 @@ eval(int argc, Scheme_Object *argv[])
genv = (Scheme_Env *)argv[1]; genv = (Scheme_Env *)argv[1];
} else } else
genv = scheme_get_env(NULL); genv = scheme_get_env(NULL);
form = add_renames_unless_module(form, genv); form = scheme_top_introduce(form, genv);
} }
a[0] = form; 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)) { if (!SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) {
Scheme_Env *genv; Scheme_Env *genv;
genv = (Scheme_Env *)scheme_get_param(scheme_current_config(), MZCONFIG_ENV); 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; return form;
@ -4727,7 +4749,7 @@ compile(int argc, Scheme_Object *argv[])
form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0);
genv = scheme_get_env(NULL); genv = scheme_get_env(NULL);
form = add_renames_unless_module(form, genv); form = scheme_top_introduce(form, genv);
return call_compile_handler(form, 0); return call_compile_handler(form, 0);
} }
@ -4755,7 +4777,9 @@ static Scheme_Object *expand(int argc, Scheme_Object **argv)
env = scheme_get_env(NULL); 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); -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); 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); -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; Scheme_Object *l, *ids, *id;
/* Registers marked ids: */ /* Registers scoped ids: */
for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) {
id = SCHEME_CAR(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), 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); 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; Scheme_Object *rl = renaming;
if (SCHEME_PAIRP(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)) { 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); rl = SCHEME_CDR(rl);
} }
if (need_delim)
l = scheme_add_rib_delimiter(l, renaming);
} else { } else {
l = scheme_add_rename(l, renaming); l = scheme_stx_add_scope(l, renaming, phase);
} }
return l; 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) 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_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 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; Scheme_Object *observer, *catch_lifts_key = NULL;
env = scheme_current_thread->current_local_env; 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) { if (for_stx) {
scheme_prepare_exp_env(env->genv); 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_propagate_require_lift_capture(orig_env, env);
} }
scheme_prepare_compile_env(env->genv); 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) if (for_expr)
kind = 0; /* expression */ kind = 0; /* expression */
else if (!for_stx && SAME_OBJ(argv[1], module_symbol)) 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)) 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)) { else if (SAME_OBJ(argv[1], top_level_symbol)) {
kind = SCHEME_TOPLEVEL_FRAME; kind = SCHEME_TOPLEVEL_FRAME;
if (catch_lifts < 0) catch_lifts = 0; if (catch_lifts < 0) catch_lifts = 0;
} else if (SAME_OBJ(argv[1], expression_symbol)) } else if (SAME_OBJ(argv[1], expression_symbol))
kind = 0; kind = 0;
else if (scheme_proper_list_length(argv[1]) > 0) else if (scheme_proper_list_length(argv[1]) > 0)
kind = SCHEME_INTDEF_FRAME; kind = SCHEME_INTDEF_FRAME | SCHEME_USE_SCOPES_TO_NEXT;
else { else {
scheme_wrong_contract(name, scheme_wrong_contract(name,
(for_stx (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]); update_intdef_chain(argv[3]);
stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[3]))[0]; stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[3]))[0];
renaming = SCHEME_PTR2_VAL(argv[3]); 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)) if (!scheme_is_sub_env(stx_env, env))
bad_sub_env = 1; bad_sub_env = 1;
env = stx_env; 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]; rl = argv[3];
update_intdef_chain(SCHEME_CAR(rl)); update_intdef_chain(SCHEME_CAR(rl));
env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0]; 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)); renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl));
else { if (SCHEME_BOXP(renaming))
renaming = NULL;
} else {
/* reverse and extract: */ /* reverse and extract: */
renaming = scheme_null; renaming = scheme_null;
while (!SCHEME_NULLP(rl)) { 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); rl = SCHEME_CDR(rl);
} }
} }
@ -4961,7 +4987,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
env = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME env = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME
| SCHEME_FOR_STOPS | SCHEME_FOR_STOPS
| kind), | kind),
env); NULL,
env);
if (catch_lifts < 0) { if (catch_lifts < 0) {
/* Note: extra frames can get inserted after env by pair_lifted */ /* Note: extra frames can get inserted after env by pair_lifted */
ip = MALLOC_N(Scheme_Comp_Env *, 1); 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 } else
ip = NULL; ip = NULL;
if (kind == SCHEME_INTDEF_FRAME) if (kind & SCHEME_INTDEF_FRAME)
env->intdef_name = argv[1]; env->intdef_name = argv[1];
env->in_modidx = scheme_current_thread->current_local_modidx; 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) { if (for_expr) {
} else if (SCHEME_TRUEP(argv[2])) { } 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]); cnt = scheme_stx_proper_list_length(argv[2]);
if (cnt == 1) 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 else
is_modstar = 0; 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) 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)) { if (!SCHEME_NULLP(l)) {
scheme_wrong_contract(name, "(or/c #f (listof identifier?))", 2, argc, argv); 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("#%variable-reference"), env);
scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%expression"), env); scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%expression"), env);
scheme_add_core_stop_form(pos++, quote_symbol, 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, /* Since we have an expression from local context,
we need to remove the temporary mark... */ we need to remove the temporary scope... */
l = scheme_add_remove_mark(l, local_mark); l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv));
} }
if (renaming) 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); 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; 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) { if (SAME_OBJ(xl, l) && !for_expr) {
SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, xl); 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; l = xl;
} else { } else {
/* Expand the expression. depth = -2 means expand all the way, but /* Expand the expression. depth = -2 means expand all the way, but
preserve letrec-syntax. */ preserve letrec-syntax, while -3 is -2 but also avoid replacing reference ids
l = r_expand(l, env, -2, 0, 0, catch_lifts_key, 0, catch_lifts ? catch_lifts : 1); with binding ids. */
l = r_expand(l, env, (keep_ref_ids ? -3 : -2), 0, 0, catch_lifts_key, 0,
catch_lifts ? catch_lifts : 1);
} }
SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l); SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
if (renaming) if (renaming)
l = add_intdef_renamings(l, renaming); l = add_intdef_renamings(l, renaming, scheme_env_phase(env->genv));
if (for_expr) { if (for_expr) {
/* Package up expanded expr with the environment. */ /* 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_PTR1_VAL(exp_expr) = l;
SCHEME_PTR2_VAL(exp_expr) = orig_env; SCHEME_PTR2_VAL(exp_expr) = orig_env;
exp_expr = scheme_datum_to_syntax(exp_expr, l, scheme_false, 0, 0); exp_expr = scheme_datum_to_syntax(exp_expr, l, scheme_false, 0, 0);
if (local_mark) if (local_scope)
exp_expr = scheme_add_remove_mark(exp_expr, local_mark); exp_expr = scheme_stx_flip_scope(exp_expr, local_scope, scheme_env_phase(env->genv));
} }
if (local_mark) { if (local_scope) {
/* Put the temporary mark back: */ /* Put the temporary scope back: */
l = scheme_add_remove_mark(l, local_mark); l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv));
} }
if (for_expr) { 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); return scheme_values(2, a);
} else { } else {
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l); SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
if (kind == SCHEME_MODULE_FRAME)
l = scheme_annotate_existing_submodules(l, 0);
return l; return l;
} }
} }
@ -5199,7 +5227,9 @@ expand_once(int argc, Scheme_Object **argv)
env = scheme_get_env(NULL); 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); 1, 1, 0, scheme_false, 0, 0);
} }
@ -5213,7 +5243,9 @@ expand_stx_once(int argc, Scheme_Object **argv)
env = scheme_get_env(NULL); 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); 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); 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); 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); 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); 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 * static Scheme_Object *
local_eval(int argc, Scheme_Object **argv) 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; Scheme_Object *l, *a, *rib, *expr, *names, *rn_names, *observer;
int cnt = 0, pos; int cnt = 0, pos;
@ -5539,13 +5594,9 @@ local_eval(int argc, Scheme_Object **argv)
update_intdef_chain(argv[2]); update_intdef_chain(argv[2]);
stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0]; 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]); 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)) { if (!scheme_is_sub_env(stx_env, env)) {
scheme_contract_error("syntax-local-bind-syntaxes", scheme_contract_error("syntax-local-bind-syntaxes",
@ -5553,26 +5604,25 @@ local_eval(int argc, Scheme_Object **argv)
NULL); NULL);
} }
old_stx_env = stx_env; stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF | SCHEME_USE_SCOPES_TO_NEXT, rib, stx_env);
stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, stx_env);
scheme_add_local_syntax(cnt, stx_env); scheme_add_local_syntax(cnt, stx_env);
/* Mark names */ /* Scope names */
if (scheme_current_thread->current_local_mark) if (scheme_current_thread->current_local_scope)
names = scheme_named_map_1(NULL, scheme_add_remove_mark, names, names = scheme_named_map_1(NULL, flip_scope_at_phase_and_revert_expr, names,
scheme_current_thread->current_local_mark); scheme_make_raw_pair(scheme_current_thread->current_local_scope,
(Scheme_Object *)stx_env));
SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer,names); SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer,names);
/* Initialize environment slots to #f, which means "not syntax". */ /* Initialize environment slots to #f, which means "not syntax". */
cnt = 0; cnt = 0;
for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { 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; stx_env->in_modidx = scheme_current_thread->current_local_modidx;
if (!SCHEME_FALSEP(expr)) { if (!SCHEME_FALSEP(expr)) {
Scheme_Compile_Expand_Info rec; Scheme_Compile_Expand_Info rec;
@ -5582,21 +5632,25 @@ local_eval(int argc, Scheme_Object **argv)
rec.observer = observer; rec.observer = observer;
rec.pre_unwrapped = 0; rec.pre_unwrapped = 0;
rec.env_already = 0; rec.env_already = 0;
rec.substitute_bindings = 1;
rec.comp_flags = get_comp_flags(NULL); rec.comp_flags = get_comp_flags(NULL);
/* Evaluate and bind syntaxes */ /* Evaluate and bind syntaxes */
if (scheme_current_thread->current_local_mark) if (scheme_current_thread->current_local_scope)
expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark); expr = scheme_stx_flip_scope(expr, scheme_current_thread->current_local_scope,
scheme_env_phase(env->genv));
scheme_prepare_exp_env(stx_env->genv); scheme_prepare_exp_env(stx_env->genv);
scheme_prepare_compile_env(stx_env->genv->exp_env); scheme_prepare_compile_env(stx_env->genv->exp_env);
pos = 0; pos = 0;
expr = scheme_add_rename_rib(expr, rib); expr = scheme_stx_add_scope(expr, rib, scheme_env_phase(stx_env->genv));
rn_names = scheme_named_map_1(NULL, scheme_add_rename_rib, names, rib); rn_names = scheme_named_map_1(NULL, add_scope_at_phase, names,
scheme_make_pair(rib, scheme_env_phase(stx_env->genv)));
rn_names = scheme_named_map_1(NULL, revert_expr_scopes, rn_names, (Scheme_Object *)init_env);
scheme_bind_syntaxes("local syntax definition", rn_names, expr, scheme_bind_syntaxes("local syntax definition", rn_names, expr,
stx_env->genv->exp_env, stx_env->insp, &rec, 0, stx_env->genv->exp_env, stx_env->insp, &rec, 0,
stx_env, stx_env, stx_env, stx_env,
&pos, rib); &pos, rib, 1);
} }
/* Remember extended environment */ /* 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 **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
Scheme_Object *src_modidx, Scheme_Object *now_modidx, Scheme_Object *src_modidx, Scheme_Object *now_modidx,
int src_phase, int now_phase, int src_phase, int now_phase,
Scheme_Env *dummy_env, Scheme_Env *dummy_env, Scheme_Object *insp)
Scheme_Object *insp)
{ {
Scheme_Object **rs_save, **rs, *v; Scheme_Object **rs_save, **rs, *v;
Scheme_Prefix *pf; Scheme_Prefix *pf;
@ -5706,10 +5759,10 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
if (insp && SCHEME_FALSEP(insp)) if (insp && SCHEME_FALSEP(insp))
insp = scheme_get_current_inspector(); insp = scheme_get_current_inspector();
i = rp->num_toplevels; i = rp->num_toplevels;
v = scheme_stx_phase_shift_as_rename(scheme_make_integer(now_phase - src_phase), v = scheme_make_shift(scheme_make_integer(now_phase - src_phase),
src_modidx, now_modidx, src_modidx, now_modidx,
genv ? genv->module_registry->exports : NULL, genv ? genv->module_registry->exports : NULL,
insp, NULL); rp->src_insp_desc, insp);
if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) { if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) {
/* Put lazy-shift info in pf->a[i]: */ /* Put lazy-shift info in pf->a[i]: */
Scheme_Object **ls; Scheme_Object **ls;
@ -5719,7 +5772,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
pf->a[i] = (Scheme_Object *)ls; pf->a[i] = (Scheme_Object *)ls;
/* Rest of a left zeroed, to be filled in lazily by quote-syntax evaluation */ /* Rest of a left zeroed, to be filled in lazily by quote-syntax evaluation */
} else { } else {
/* No shift, so fill in stxes immediately */ /* No shift, so fill in stxes immediately */
i++; i++;
for (j = 0; j < rp->num_stxes; j++) { for (j = 0; j < rp->num_stxes; j++) {
pf->a[i + j] = rp->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 #ifdef MZ_GC_BACKTRACE
GC_set_backpointer_object(pf->backpointer); GC_set_backpointer_object(pf->backpointer);
#endif #endif
GC_mark_no_recur(gc, 1);
gcMARK(pf); gcMARK(pf);
pf = (Scheme_Prefix *)GC_resolve2(pf, gc); pf = (Scheme_Prefix *)GC_resolve2(pf, gc);
GC_retract_only_mark_stack_entry(pf, gc); GC_retract_only_mark_stack_entry(pf, gc);
GC_mark_no_recur(gc, 0);
} else } else
pf = (Scheme_Prefix *)GC_resolve2(pf, gc); pf = (Scheme_Prefix *)GC_resolve2(pf, gc);

48
racket/src/racket/src/fun.c
View File

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

166
racket/src/racket/src/hamt_subset.inc Normal file
View File

@ -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

1459
racket/src/racket/src/hash.c
View File

File diff suppressed because it is too large Load Diff

4
racket/src/racket/src/jit_ts.c
View File

@ -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_multi, FSRC_MARKS)
define_ts_s_s(call_with_values_from_multiple_result, 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_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_b_v(scheme_unbound_global, FSRC_MARKS)
define_ts_ss_v(scheme_set_box, FSRC_MARKS) define_ts_ss_v(scheme_set_box, FSRC_MARKS)
define_ts_iS_s(scheme_checked_car, 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_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity
# define ts_call_wrong_return_arity call_wrong_return_arity # define ts_call_wrong_return_arity call_wrong_return_arity
# define ts_scheme_unbound_global scheme_unbound_global # 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_car scheme_checked_car
# define ts_scheme_checked_cdr scheme_checked_cdr # define ts_scheme_checked_cdr scheme_checked_cdr
# define ts_scheme_checked_caar scheme_checked_caar # define ts_scheme_checked_caar scheme_checked_caar

8
racket/src/racket/src/jitcommon.c
View File

@ -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_subi_p(JIT_R1, JIT_R1, WORDS_TO_BYTES(1));
jit_rshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE); jit_rshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE);
CHECK_LIMIT(); CHECK_LIMIT();
/* Call scheme_delayed_rename: */ /* Call scheme_delayed_shift: */
JIT_UPDATE_THREAD_RSPTR(); JIT_UPDATE_THREAD_RSPTR();
CHECK_LIMIT(); CHECK_LIMIT();
mz_prepare(2); mz_prepare(2);
jit_pusharg_l(JIT_R1); jit_pusharg_l(JIT_R1);
jit_pusharg_p(JIT_R0); 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(); CHECK_LIMIT();
jit_retval(JIT_R0); jit_retval(JIT_R0);
/* Restore global array into JIT_R1, and put computed element at i+p+1: */ /* 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); (void)mz_bnei_t(reffail, JIT_R0, scheme_stx_type, JIT_R2);
/* It's a syntax object... needs to propagate? */ /* It's a syntax object... needs to propagate? */
jit_ldxi_l(JIT_R2, JIT_R0, &((Scheme_Stx *)0x0)->u.lazy_prefix); jit_ldxi_l(JIT_R2, JIT_R0, &((Scheme_Stx *)0x0)->u.to_propagate);
ref = jit_beqi_l(jit_forward(), JIT_R2, 0x0); ref = jit_beqi_p(jit_forward(), JIT_R2, 0x0);
CHECK_LIMIT(); CHECK_LIMIT();
/* Maybe needs to propagate; check STX_SUBSTX_FLAG flag */ /* Maybe needs to propagate; check STX_SUBSTX_FLAG flag */

96
racket/src/racket/src/list.c
View File

@ -2030,15 +2030,27 @@ Scheme_Hash_Table *scheme_make_hash_table_equal()
return t; 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 *scheme_make_hash_table_eqv()
{ {
Scheme_Hash_Table *t; Scheme_Hash_Table *t;
Scheme_Object *sema;
t = scheme_make_hash_table(SCHEME_hash_ptr); t = scheme_make_hash_table(SCHEME_hash_ptr);
sema = scheme_make_sema(1);
t->mutex = sema;
t->compare = compare_eqv; t->compare = compare_eqv;
t->make_hash_indices = make_hash_indices_for_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); if (t->mutex) scheme_post_sema(t->mutex);
return o; return o;
} else if (SCHEME_HASHTRP(v)) { } else if (SCHEME_HASHTRP(v)) {
Scheme_Hash_Tree *t; return scheme_hash_tree_copy(v);
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;
} else { } else {
scheme_wrong_contract("hash-copy", "hash?", 0, argc, argv); scheme_wrong_contract("hash-copy", "hash?", 0, argc, argv);
return NULL; 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[]) static Scheme_Object *hash_p(int argc, Scheme_Object *argv[])
{ {
Scheme_Object *o = argv[0]; 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)) && (((Scheme_Hash_Table *)o)->compare != compare_eqv))
return scheme_true; return scheme_true;
} else if (SCHEME_HASHTRP(o)) { } 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; return scheme_true;
} else if (SCHEME_BUCKTP(o)) { } else if (SCHEME_BUCKTP(o)) {
if ((((Scheme_Bucket_Table *)o)->compare != scheme_compare_equal) 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) if (((Scheme_Hash_Table *)o)->compare == compare_eqv)
return scheme_true; return scheme_true;
} else if (SCHEME_HASHTRP(o)) { } 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; return scheme_true;
} else if (SCHEME_BUCKTP(o)) { } else if (SCHEME_BUCKTP(o)) {
if (((Scheme_Bucket_Table *)o)->compare == compare_eqv) 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) if (((Scheme_Hash_Table *)o)->compare == scheme_compare_equal)
return scheme_true; return scheme_true;
} else if (SCHEME_HASHTRP(o)) { } 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; return scheme_true;
} else if (SCHEME_BUCKTP(o)) { } else if (SCHEME_BUCKTP(o)) {
if (((Scheme_Bucket_Table *)o)->compare == scheme_compare_equal) 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)) else if (SCHEME_HASHTP(o) || SCHEME_HASHTRP(o))
return scheme_false; return scheme_false;
scheme_wrong_contract("hash-eq?", "hash?", 0, argc, argv); scheme_wrong_contract("hash-weak?", "hash?", 0, argc, argv);
return NULL; return NULL;
} }
@ -2260,12 +2277,12 @@ int scheme_is_hash_table_eqv(Scheme_Object *o)
int scheme_is_hash_tree_equal(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) 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[]) 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); return hash_failed(argc, argv);
} }
} else if (SCHEME_HASHTRP(v)) { } 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]); v = scheme_eq_hash_tree_get((Scheme_Hash_Tree *)v, argv[1]);
if (v) if (v)
return 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); v = hash_table_remove_bang(2, a);
} }
} }
} else } else {
return (Scheme_Object *)scheme_make_hash_tree(SCHEME_HASHTR_FLAGS((Scheme_Hash_Tree *)v) & 0x3); return (Scheme_Object *)scheme_make_hash_tree_of_type(SCHEME_HASHTR_TYPE(v));
}
} }
static void no_post_key(const char *name, Scheme_Object *key, int chap) 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 { else {
/* mode == 4, hash-clear */ /* mode == 4, hash-clear */
if (SCHEME_HASHTRP(o)) { 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) { while (wraps) {
o = transfer_chaperone(SCHEME_CAR(wraps), o); o = transfer_chaperone(SCHEME_CAR(wraps), o);
wraps = SCHEME_CDR(wraps); wraps = SCHEME_CDR(wraps);

226
racket/src/racket/src/marshal.c
View File

@ -768,57 +768,62 @@ static Scheme_Object *write_compiled_closure(Scheme_Object *obj)
if (!ds) { if (!ds) {
mt = scheme_current_thread->current_mt; mt = scheme_current_thread->current_mt;
if (!mt->pass) { if (mt->pass < 0) {
int key; /* nothing to do, yet */
ds = scheme_false;
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 { } else {
pos = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0xFF00) >> 8; if (!mt->pass) {
int key;
while (pos < mt->cdata_counter) { pos = mt->cdata_counter;
ds = mt->cdata_map[pos]; if ((!mt->cdata_map || (pos >= 32))
if (ds) { && !(pos & (pos - 1))) {
ds = SCHEME_PTR_VAL(ds); /* Need to grow the array */
if (SAME_OBJ(data->code, ds)) Scheme_Object **a;
break; a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32));
if (SAME_TYPE(scheme_quote_compilation_type, SCHEME_TYPE(ds))) memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *));
if (SAME_OBJ(data->code, SCHEME_PTR_VAL(ds))) mt->cdata_map = a;
break; }
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 */ /* 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); 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) static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
{ {
Resolve_Prefix *rp = (Resolve_Prefix *)obj; Resolve_Prefix *rp = (Resolve_Prefix *)obj;
@ -1092,15 +1113,13 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
while (i--) { while (i--) {
if (rp->stxes[i]) { if (rp->stxes[i]) {
if (SCHEME_INTP(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 This should only happen if we're writing back
code loaded from bytecode. */ code loaded from bytecode. */
scheme_load_delayed_syntax(rp, i); scheme_load_delayed_syntax(rp, i);
} }
ds = scheme_alloc_small_object(); ds = make_delayed_syntax(rp->stxes[i]);
ds->type = scheme_delay_syntax_type;
SCHEME_PTR_VAL(ds) = rp->stxes[i];
} else } else
ds = scheme_false; ds = scheme_false;
SCHEME_VEC_ELS(sv)[i] = ds; SCHEME_VEC_ELS(sv)[i] = ds;
@ -1109,15 +1128,23 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
tv = scheme_make_pair(scheme_make_integer(rp->num_lifts), tv = scheme_make_pair(scheme_make_integer(rp->num_lifts),
scheme_make_pair(tv, sv)); scheme_make_pair(tv, sv));
tv = scheme_make_pair(rp->src_insp_desc, tv);
return tv; return tv;
} }
static Scheme_Object *read_resolve_prefix(Scheme_Object *obj) static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
{ {
Resolve_Prefix *rp; Resolve_Prefix *rp;
Scheme_Object *tv, *sv, **a, *stx, *tl; Scheme_Object *tv, *sv, **a, *stx, *tl, *insp_desc;
intptr_t i; 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_PAIRP(obj)) return NULL;
if (!SCHEME_INTP(SCHEME_CAR(obj))) { if (!SCHEME_INTP(SCHEME_CAR(obj))) {
@ -1181,9 +1208,70 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
} }
rp->stxes = a; rp->stxes = a;
rp->src_insp_desc = insp_desc;
return (Scheme_Object *)rp; 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) static Scheme_Object *write_module(Scheme_Object *obj)
{ {
Scheme_Module *m = (Scheme_Module *)obj; Scheme_Module *m = (Scheme_Module *)obj;
@ -1332,8 +1420,12 @@ static Scheme_Object *write_module(Scheme_Object *obj)
v = m->rn_stx; v = m->rn_stx;
if (!v) if (!v)
v = scheme_false; v = scheme_false;
else if (SCHEME_PAIRP(v)) else if (!SAME_OBJ(v, scheme_true)) {
v = scheme_list_to_vector(v); v = scheme_stx_force_delayed(v);
if (!SAME_OBJ(v, m->rn_stx))
m->rn_stx = v;
v = make_delayed_syntax(v);
}
l = cons(v, l); l = cons(v, l);
/* previously recorded "functional?" info: */ /* 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((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(m->me->src_modidx, l);
l = cons(scheme_resolved_module_path_value(m->modsrc), l); l = cons(scheme_resolved_module_path_value(m->modsrc), l);
l = cons(scheme_resolved_module_path_value(m->modname), 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) static Scheme_Object *read_module(Scheme_Object *obj)
{ {
Scheme_Module *m; 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_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
Scheme_Module_Exports *me; Scheme_Module_Exports *me;
Scheme_Module_Phase_Exports *pt; 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; ((Scheme_Modidx *)me->src_modidx)->resolved = m->modname;
m->self_modidx = me->src_modidx; 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(); if (!SCHEME_PAIRP(obj)) return_NULL();
m->phaseless = (SCHEME_TRUEP(SCHEME_CAR(obj)) ? scheme_true : NULL); m->phaseless = (SCHEME_TRUEP(SCHEME_CAR(obj)) ? scheme_true : NULL);
obj = SCHEME_CDR(obj); obj = SCHEME_CDR(obj);

2804
racket/src/racket/src/module.c
View File

File diff suppressed because it is too large Load Diff

76
racket/src/racket/src/mzmark_compenv.inc
View File

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

Some files were not shown because too many files have changed in this diff Show More