switch to set-of-scopes expander

The development history for set-of-scopes is preserved in a "scope"
branch in the main Racket repository, which is commit
 ae88c96f50
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

View File

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

View File

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

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
quoted syntax that need to be instantiated (and put into an array on
the stack) before evaluating expressions that might use them.}
@defproc[(decode-module-binding [binding module-binding?]
[name symbol?])
decoded-module-binding?]{
Given a compact-form representation of a module binding and the name
from which the binding is mapped, returns a normalized form of the
binding.}

View File

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

View File

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

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.}]}
@defproc[(log-max-level [logger logger?]
[topic (or/c symbol? #f) #f])
(or/c #f 'fatal 'error 'warning 'info 'debug)]{

View File

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

View File

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

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. */
GC2_EXTERN void GC_mark_no_recur(struct NewGC *gc, int enable);
GC2_EXTERN void GC_retract_only_mark_stack_entry(void *pf, struct NewGC *gc);
/*
Used for very special collaboration with GC. */

View File

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

View File

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

File diff suppressed because it is too large Load Diff

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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

View File

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

View File

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

View File

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

View File

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

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

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

View File

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

View File

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

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

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

File diff suppressed because it is too large Load Diff

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, FSRC_MARKS)
define_ts_S_s(apply_checked_fail, FSRC_MARKS)
define_ts_Sl_s(scheme_delayed_rename, FSRC_OTHER)
define_ts_Sl_s(scheme_delayed_shift, FSRC_OTHER)
define_ts_b_v(scheme_unbound_global, FSRC_MARKS)
define_ts_ss_v(scheme_set_box, FSRC_MARKS)
define_ts_iS_s(scheme_checked_car, FSRC_MARKS)
@ -177,7 +177,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
# define ts_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity
# define ts_call_wrong_return_arity call_wrong_return_arity
# define ts_scheme_unbound_global scheme_unbound_global
# define ts_scheme_delayed_rename scheme_delayed_rename
# define ts_scheme_delayed_shift scheme_delayed_shift
# define ts_scheme_checked_car scheme_checked_car
# define ts_scheme_checked_cdr scheme_checked_cdr
# define ts_scheme_checked_caar scheme_checked_caar

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

View File

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

View File

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

File diff suppressed because it is too large Load Diff

View File

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

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