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

change quote-syntax to include a certificate for the enclosing module, enable certificate checking of phase-1 bindings, and fix some other problems with certificates

Browse Source 
svn: r12714
This commit is contained in:
Matthew Flatt 2008-12-05 22:45:04 +00:00
parent 15ee54b301
commit 89d0801d7a
12 changed files with 615 additions and 410 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/scheme/private/class-internal.ss
View File

@ -1654,8 +1654,7 @@
;; Need to attach srcloc to this definition:
(syntax/loc stx
(define-syntaxes (id ...)
(values (make-private-name (quote-syntax id)
((syntax-local-certifier) (quote-syntax gen-id)))
(values (make-private-name (quote-syntax id) (quote-syntax gen-id))
...)))])
(syntax/loc stx
(begin

67
collects/scheme/private/define-struct.ss
View File

@ -424,47 +424,46 @@
(let ([protect (lambda (sel)
(and sel
(if (syntax-e sel)
#`(c (quote-syntax #,sel))
#`(quote-syntax #,sel)
sel)))]
[mk-info (if super-info-checked?
#'make-checked-struct-info
#'make-struct-info)])
(quasisyntax/loc stx
(define-syntaxes (#,id)
(let ([c (syntax-local-certifier)])
(#,mk-info
(lambda ()
(list
(c (quote-syntax #,struct:))
(c (quote-syntax #,make-))
(c (quote-syntax #,?))
(list
#,@(map protect (reverse sels))
#,@(if super-info
(map protect (list-ref super-info 3))
(if super-expr
'(#f)
null)))
(list
#,@(reverse
(let loop ([fields fields][sets sets])
(cond
[(null? fields) null]
[(not (or mutable? (field-mutable? (car fields))))
(cons #f (loop (cdr fields) sets))]
[else
(cons (protect (car sets))
(loop (cdr fields) (cdr sets)))])))
#,@(if super-info
(map protect (list-ref super-info 4))
(if super-expr
'(#f)
null)))
#,(if super-id
(protect super-id)
(#,mk-info
(lambda ()
(list
(quote-syntax #,struct:)
(quote-syntax #,make-)
(quote-syntax #,?)
(list
#,@(map protect (reverse sels))
#,@(if super-info
(map protect (list-ref super-info 3))
(if super-expr
#f
#t))))))))))])
'(#f)
null)))
(list
#,@(reverse
(let loop ([fields fields][sets sets])
(cond
[(null? fields) null]
[(not (or mutable? (field-mutable? (car fields))))
(cons #f (loop (cdr fields) sets))]
[else
(cons (protect (car sets))
(loop (cdr fields) (cdr sets)))])))
#,@(if super-info
(map protect (list-ref super-info 4))
(if super-expr
'(#f)
null)))
#,(if super-id
(protect super-id)
(if super-expr
#f
#t)))))))))])
(let ([result
(cond
[(and (not omit-define-values?) (not omit-define-syntaxes?))

3
collects/scheme/private/for.ss
View File

@ -100,8 +100,7 @@
;; down to all the relevant identifiers and expressions:
(define (recert s) (syntax-recertify s src-stx (current-inspector) cert-key))
(define (cert s) (certifier (recert s) cert-key introducer))
(define (map-cert s) (map (lambda (s) (certifier (recert s) cert-key #;introducer))
(syntax->list s)))
(define (map-cert s) (map cert (syntax->list s)))
(syntax-case clause (:do-in)
[[(id ...) (:do-in ([(outer-id ...) outer-expr] ...)

2
collects/scribblings/guide/certificates.scrbl
View File

@ -170,7 +170,7 @@ be transferred from one syntax object to another. Such transfers are
allowed because a macro transformer with access to the syntax object
could already wrap it with an arbitrary context before activating the
certificates. In practice, transferring inactive certificates is
useful mainly to macros that implement to new template forms, such as
useful mainly to macros that implement new template forms, such as
@scheme[syntax/loc].
@;------------------------------------------------------------------------

21
collects/scribblings/reference/exns.scrbl
View File

@ -15,7 +15,7 @@ handler} for a primitive error is always an instance of the
@scheme[message] field that is a string, the primitive error message.
The default exception handler recognizes exception values with the
@scheme[exn?] predicate and passes the error message to the current
error display handler (see @scheme[error-display-handler]).
@tech{error display handler} (see @scheme[error-display-handler]).
Primitive procedures that accept a procedure argument with a
particular required arity (e.g., @scheme[call-with-input-file],
@ -80,7 +80,7 @@ In all cases, the constructed message string is passed to
Like @scheme[error], but constructs an exception with
@scheme[make-exn:fail:user] instead of @scheme[make-exn:fail]. The
default error display handler does not show a ``stack trace'' for
default @tech{error display handler} does not show a ``stack trace'' for
@scheme[exn:fail:user] exceptions (see @secref["contmarks"]), so
@scheme[raise-user-error] should be used for errors that are intended
for end users.}
@ -221,16 +221,16 @@ it returns, an exception is raised (to be handled by an exception
handler that reports both the original and newly raised exception).
The default uncaught-exception handler prints an error message using
the current error display handler (see @scheme[error-display-handler])
the current @tech{error display handler} (see @scheme[error-display-handler])
and then escapes by calling the current error escape handler (see
@scheme[error-escape-handler]). The call to each handler is
@scheme[parameterize]d to set @scheme[error-display-handler] to the
default error display handler, and it is @scheme[parameterize-break]ed
default @tech{error display handler}, and it is @scheme[parameterize-break]ed
to disable breaks. The call to the error escape handler is further
parameterized to set @scheme[error-escape-handler] to the default
error escape handler.
When the current error display handler is the default handler, then the
When the current @tech{error display handler} is the default handler, then the
error-display call is parameterized to install an emergency error
display handler that attempts to print directly to a console and never
fails.}
@ -322,7 +322,7 @@ argument if it is an @scheme[exn] value but not an
the second argument to highlight source locations.}
To report a run-time error, use @scheme[raise] or procedures like
@scheme[error], instead of calling the error display procedure
@scheme[error], instead of calling the error display handler
directly.}
@defparam[error-print-width width (and exact-integer? (>=/c 3))]{
@ -333,7 +333,7 @@ message.}
@defparam[error-print-context-length cnt exact-nonnegative-integer?]{
A parameter whose value is used by the default error display handler
A parameter whose value is used by the default @tech{error display handler}
as the maximum number of lines of context (or ``stack trace'') to
print; a single ``...'' line is printed if more lines are available
after the first @scheme[cnt] lines. A @scheme[0] value for
@ -504,13 +504,14 @@ interrupted computation.}
@defthing[prop:exn:srclocs struct-type-property?]{
A property that identifiers structure types that provide a list of
A property that identifies structure types that provide a list of
@scheme[srcloc] values. The property is normally attached to structure
types used to represent exception information.
The property value must be a procedure that accepts a single
value---the structure type instance from which to extract source
locations---and returns a list of @scheme[srcloc]s.}
locations---and returns a list of @scheme[srcloc]s. Some @tech{error
display handlers} use only the first returned location.}
@defproc[(exn:srclocs? [v any/c]) boolean?]{
@ -520,7 +521,7 @@ property, @scheme[#f] otherwise.}
@defproc[(exn:srclocs-accessor [v exn:srclocs?])
(exn:srclocs?. -> . (listof srcloc))]{
(exn:srclocs? . -> . (listof srcloc))]{
Returns the @scheme[srcloc]-getting procedure associated with @scheme[v].}

10
collects/scribblings/reference/stx-certs.scrbl
View File

@ -3,6 +3,8 @@
@title[#:tag "stxcerts"]{Syntax Certificates}
@guideintro["stx-certs"]{syntax certificates}
A @deftech{syntax certificate} combines a @tech{syntax mark} (see
@secref["transformer-model"]), a @tech{module path index} or symbol
module name (see @secref["modpathidx"]), an @tech{inspector} (see
@ -112,8 +114,12 @@ expansion context:
@item{When the expander encounters a @scheme[quote-syntax] form, it
attaches all accumulated @tech{active certificates} from the
expressions's context to the quoted syntax objects. The
certificates are attached as @tech{inactive certificates}.}
expressions's context to the quoted syntax objects. A certificate
for the enclosing module (if any) is also included. The
certificates are attached as @tech{inactive certificates} to the
immediate syntax object (i.e., not to any nested syntax
objects). In addition, any inactive certificates within the quoted
syntax object are lifted to the immediate syntax object.}
}

325
src/mzscheme/src/cstartup.inc
View File

@ -1,111 +1,115 @@
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,50,0,0,0,1,0,0,6,0,9,0,
13,0,26,0,29,0,34,0,41,0,46,0,51,0,58,0,65,0,69,0,78,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,50,0,0,0,1,0,0,6,0,9,0,
18,0,22,0,35,0,38,0,43,0,50,0,55,0,60,0,67,0,74,0,78,
0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,68,1,107,1,146,
1,215,1,4,2,92,2,137,2,142,2,162,2,51,3,71,3,121,3,187,3,
72,4,230,4,17,5,28,5,107,5,0,0,106,7,0,0,65,98,101,103,105,
110,29,11,11,63,108,101,116,72,112,97,114,97,109,101,116,101,114,105,122,101,
62,111,114,64,108,101,116,42,66,117,110,108,101,115,115,64,99,111,110,100,64,
119,104,101,110,66,108,101,116,114,101,99,66,100,101,102,105,110,101,63,97,110,
100,68,104,101,114,101,45,115,116,120,65,113,117,111,116,101,29,94,2,14,68,
177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165,
1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3,
132,4,34,5,84,5,107,5,186,5,0,0,201,7,0,0,65,98,101,103,105,
110,29,11,11,68,104,101,114,101,45,115,116,120,63,108,101,116,72,112,97,114,
97,109,101,116,101,114,105,122,101,62,111,114,64,108,101,116,42,66,117,110,108,
101,115,115,64,99,111,110,100,64,119,104,101,110,66,108,101,116,114,101,99,66,
100,101,102,105,110,101,63,97,110,100,65,113,117,111,116,101,29,94,2,14,68,
35,37,107,101,114,110,101,108,11,29,94,2,14,68,35,37,112,97,114,97,109,
122,11,62,105,102,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,
115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,
98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98,
10,35,11,8,133,229,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3,
2,2,2,4,2,2,2,10,2,2,2,5,2,2,2,6,2,2,2,7,2,
2,2,8,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97,36,11,8,
133,229,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2,
13,97,10,11,11,8,133,229,16,0,97,10,37,11,8,133,229,16,0,13,16,
4,35,29,11,11,2,2,11,18,98,64,104,101,114,101,8,31,8,30,8,29,
8,28,8,27,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,
22,74,2,17,248,22,89,23,200,2,12,249,22,64,2,1,248,22,91,23,202,
1,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,2,
17,248,22,89,23,200,2,249,22,64,2,1,248,22,91,23,202,1,12,27,248,
22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,
36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,
38,35,251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,12,248,22,66,
23,202,1,11,18,100,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
2,18,3,1,7,101,110,118,57,55,57,56,16,4,11,11,2,19,3,1,7,
101,110,118,57,55,57,57,27,248,22,66,248,22,133,4,23,197,1,28,248,22,
72,23,194,2,20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,
22,65,193,249,22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,
74,248,22,74,2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21,
249,22,64,2,5,248,22,66,23,205,1,18,100,11,8,31,8,30,8,29,8,
28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,48,49,16,4,
11,11,2,19,3,1,7,101,110,118,57,56,48,50,248,22,133,4,193,27,248,
22,133,4,194,249,22,64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,
66,248,22,133,4,23,197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,
22,191,3,248,22,65,23,198,2,27,249,22,2,32,0,89,162,43,36,42,9,
222,33,39,248,22,133,4,248,22,89,23,200,2,250,22,74,2,22,248,22,74,
249,22,74,248,22,74,248,22,65,23,204,2,250,22,75,2,23,249,22,2,22,
65,23,204,2,248,22,91,23,206,2,249,22,64,248,22,65,23,202,1,249,22,
2,22,89,23,200,1,250,22,75,2,20,249,22,2,32,0,89,162,43,36,46,
9,222,33,40,248,22,133,4,248,22,65,201,248,22,66,198,27,248,22,133,4,
194,249,22,64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,
133,4,23,197,1,249,22,190,3,80,158,38,35,250,22,75,2,22,249,22,2,
32,0,89,162,43,36,46,9,222,33,42,248,22,133,4,248,22,65,201,248,22,
66,198,27,248,22,66,248,22,133,4,196,27,248,22,133,4,248,22,65,195,249,
22,190,3,80,158,39,35,28,248,22,72,195,250,22,75,2,20,9,248,22,66,
199,250,22,74,2,3,248,22,74,248,22,65,199,250,22,75,2,6,248,22,66,
201,248,22,66,202,27,248,22,66,248,22,133,4,23,197,1,27,249,22,1,22,
78,249,22,2,22,133,4,248,22,133,4,248,22,65,199,249,22,190,3,80,158,
39,35,251,22,74,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,
105,111,110,45,109,97,114,107,2,24,250,22,75,1,23,101,120,116,101,110,100,
45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,
99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,
45,102,105,114,115,116,11,2,24,201,250,22,75,2,20,9,248,22,66,203,27,
248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,
35,36,249,22,190,3,80,158,38,35,27,248,22,133,4,248,22,65,23,198,2,
28,249,22,162,8,62,61,62,248,22,191,3,248,22,89,23,197,2,250,22,74,
2,20,248,22,74,249,22,74,21,93,2,25,248,22,65,199,250,22,75,2,8,
249,22,74,2,25,249,22,74,248,22,98,203,2,25,248,22,66,202,251,22,74,
2,17,28,249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,
101,10,248,22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,
22,64,2,8,248,22,66,23,203,1,99,8,31,8,30,8,29,8,28,8,27,
16,4,11,11,2,18,3,1,7,101,110,118,57,56,50,52,16,4,11,11,2,
19,3,1,7,101,110,118,57,56,50,53,18,158,94,10,64,118,111,105,100,8,
47,27,248,22,66,248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,
52,248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,
248,22,89,198,27,248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,
248,22,65,197,250,22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,
159,35,16,1,2,1,16,0,83,158,41,20,100,138,69,35,37,109,105,110,45,
115,116,120,2,2,11,10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,
0,11,11,16,0,35,11,38,35,11,11,16,10,2,3,2,4,2,5,2,6,
2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11,11,11,11,
11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,
2,11,2,12,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,
0,16,0,16,0,35,35,16,11,16,5,93,2,13,20,15,159,35,35,35,35,
20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,7,89,162,43,36,52,
9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,
0,11,16,5,93,2,9,89,162,43,36,52,9,223,0,33,34,35,20,103,159,
35,16,1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,12,89,162,
43,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25,159,36,2,2,
2,13,16,1,33,36,11,16,5,93,2,5,89,162,43,36,55,9,223,0,33,
37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,1,33,38,11,
16,5,93,2,3,89,162,43,36,57,9,223,0,33,41,35,20,103,159,35,16,
1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,10,89,162,43,36,
52,9,223,0,33,43,35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,
16,0,11,16,5,93,2,6,89,162,43,36,53,9,223,0,33,44,35,20,103,
159,35,16,1,20,25,159,36,2,2,2,13,16,0,11,16,5,93,2,4,89,
162,43,36,54,9,223,0,33,45,35,20,103,159,35,16,1,20,25,159,36,2,
2,2,13,16,0,11,16,5,93,2,8,89,162,43,36,57,9,223,0,33,46,
35,20,103,159,35,16,1,20,25,159,36,2,2,2,13,16,1,33,48,11,16,
5,93,2,11,89,162,43,36,53,9,223,0,33,49,35,20,103,159,35,16,1,
20,25,159,36,2,2,2,13,16,0,11,16,0,94,2,15,2,16,93,2,15,
9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2019);
10,35,11,8,180,243,94,159,2,16,35,35,159,2,15,35,35,16,20,2,4,
2,2,2,5,2,2,2,11,2,2,2,6,2,2,2,7,2,2,2,8,2,
2,2,9,2,2,2,10,2,2,2,12,2,2,2,13,2,2,97,36,11,8,
180,243,93,159,2,15,35,36,16,2,2,3,161,2,2,36,2,3,2,2,2,
3,97,10,11,11,8,180,243,16,0,97,10,37,11,8,180,243,16,0,13,16,
4,35,29,11,11,2,2,11,18,16,2,99,64,104,101,114,101,8,31,8,30,
8,29,8,28,8,27,93,8,224,251,60,0,0,95,9,8,224,251,60,0,0,
2,2,27,248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,
2,17,248,22,89,23,200,2,12,249,22,64,2,1,248,22,91,23,202,1,27,
248,22,133,4,23,196,1,249,22,190,3,80,158,38,35,251,22,74,2,17,248,
22,89,23,200,2,249,22,64,2,1,248,22,91,23,202,1,12,27,248,22,66,
248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,28,
248,22,72,248,22,66,23,195,2,248,22,65,193,249,22,190,3,80,158,38,35,
251,22,74,2,17,248,22,65,23,200,2,249,22,64,2,13,248,22,66,23,202,
1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11,
2,18,3,1,7,101,110,118,57,55,57,52,16,4,11,11,2,19,3,1,7,
101,110,118,57,55,57,53,93,8,224,252,60,0,0,95,9,8,224,252,60,0,
0,2,2,27,248,22,66,248,22,133,4,23,197,1,28,248,22,72,23,194,2,
20,15,159,36,35,36,28,248,22,72,248,22,66,23,195,2,248,22,65,193,249,
22,190,3,80,158,38,35,250,22,74,2,20,248,22,74,249,22,74,248,22,74,
2,21,248,22,65,23,202,2,251,22,74,2,17,2,21,2,21,249,22,64,2,
6,248,22,66,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8,
27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,55,16,4,11,11,
2,19,3,1,7,101,110,118,57,55,57,56,93,8,224,253,60,0,0,95,9,
8,224,253,60,0,0,2,2,248,22,133,4,193,27,248,22,133,4,194,249,22,
64,248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,
197,1,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,248,22,65,
23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39,248,22,
133,4,248,22,89,23,200,2,250,22,74,2,22,248,22,74,249,22,74,248,22,
74,248,22,65,23,204,2,250,22,75,2,23,249,22,2,22,65,23,204,2,248,
22,91,23,206,2,249,22,64,248,22,65,23,202,1,249,22,2,22,89,23,200,
1,250,22,75,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40,
248,22,133,4,248,22,65,201,248,22,66,198,27,248,22,133,4,194,249,22,64,
248,22,74,248,22,65,196,248,22,66,195,27,248,22,66,248,22,133,4,23,197,
1,249,22,190,3,80,158,38,35,250,22,75,2,22,249,22,2,32,0,89,162,
8,44,36,46,9,222,33,42,248,22,133,4,248,22,65,201,248,22,66,198,27,
248,22,66,248,22,133,4,196,27,248,22,133,4,248,22,65,195,249,22,190,3,
80,158,39,35,28,248,22,72,195,250,22,75,2,20,9,248,22,66,199,250,22,
74,2,4,248,22,74,248,22,65,199,250,22,75,2,7,248,22,66,201,248,22,
66,202,27,248,22,66,248,22,133,4,23,197,1,27,249,22,1,22,78,249,22,
2,22,133,4,248,22,133,4,248,22,65,199,249,22,190,3,80,158,39,35,251,
22,74,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,
45,109,97,114,107,2,24,250,22,75,1,23,101,120,116,101,110,100,45,112,97,
114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99,111,110,
116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102,105,
114,115,116,11,2,24,201,250,22,75,2,20,9,248,22,66,203,27,248,22,66,
248,22,133,4,23,197,1,28,248,22,72,23,194,2,20,15,159,36,35,36,249,
22,190,3,80,158,38,35,27,248,22,133,4,248,22,65,23,198,2,28,249,22,
162,8,62,61,62,248,22,191,3,248,22,89,23,197,2,250,22,74,2,20,248,
22,74,249,22,74,21,93,2,25,248,22,65,199,250,22,75,2,9,249,22,74,
2,25,249,22,74,248,22,98,203,2,25,248,22,66,202,251,22,74,2,17,28,
249,22,162,8,248,22,191,3,248,22,65,23,201,2,64,101,108,115,101,10,248,
22,65,23,198,2,250,22,75,2,20,9,248,22,66,23,201,1,249,22,64,2,
9,248,22,66,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,7,101,110,118,57,56,50,48,16,4,11,11,2,19,3,1,
7,101,110,118,57,56,50,49,93,8,224,254,60,0,0,18,16,2,158,94,10,
64,118,111,105,100,8,47,95,9,8,224,254,60,0,0,2,2,27,248,22,66,
248,22,133,4,196,249,22,190,3,80,158,38,35,28,248,22,52,248,22,191,3,
248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,199,248,22,89,198,27,
248,22,191,3,248,22,65,197,250,22,74,2,26,248,22,74,248,22,65,197,250,
22,75,2,23,248,22,66,199,248,22,66,202,159,35,20,103,159,35,16,1,2,
1,16,0,83,158,41,20,100,141,69,35,37,109,105,110,45,115,116,120,2,2,
11,10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1,
2,3,36,16,0,35,11,11,38,35,11,11,16,10,2,4,2,5,2,6,2,
7,2,8,2,9,2,10,2,11,2,12,2,13,16,10,11,11,11,11,11,11,
11,11,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,
11,2,12,2,13,35,45,36,11,11,16,0,16,0,16,0,35,35,11,11,11,
16,0,16,0,16,0,35,35,16,11,16,5,93,2,3,20,15,159,35,35,35,
35,20,103,159,35,16,0,16,1,33,32,10,16,5,93,2,8,89,162,8,44,
36,52,9,223,0,33,33,35,20,103,159,35,16,1,20,25,159,36,2,2,2,
3,16,0,11,16,5,93,2,10,89,162,8,44,36,52,9,223,0,33,34,35,
20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,
13,89,162,8,44,36,52,9,223,0,33,35,35,20,103,159,35,16,1,20,25,
159,36,2,2,2,3,16,1,33,36,11,16,5,93,2,6,89,162,8,44,36,
55,9,223,0,33,37,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,
16,1,33,38,11,16,5,93,2,4,89,162,8,44,36,57,9,223,0,33,41,
35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,
2,11,89,162,8,44,36,52,9,223,0,33,43,35,20,103,159,35,16,1,20,
25,159,36,2,2,2,3,16,0,11,16,5,93,2,7,89,162,8,44,36,53,
9,223,0,33,44,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,
0,11,16,5,93,2,5,89,162,8,44,36,54,9,223,0,33,45,35,20,103,
159,35,16,1,20,25,159,36,2,2,2,3,16,0,11,16,5,93,2,9,89,
162,8,44,36,57,9,223,0,33,46,35,20,103,159,35,16,1,20,25,159,36,
2,2,2,3,16,1,33,48,11,16,5,93,2,12,89,162,8,44,36,53,9,
223,0,33,49,35,20,103,159,35,16,1,20,25,159,36,2,2,2,3,16,0,
11,16,0,94,2,15,2,16,93,2,15,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2114);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,60,0,0,0,1,0,0,3,0,16,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,60,0,0,0,1,0,0,3,0,16,0,
21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200,
0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1,
157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241,
5,102,6,116,6,150,6,166,6,16,8,30,8,193,8,194,9,194,10,201,10,
208,10,215,10,90,11,103,11,58,12,160,12,173,12,195,12,147,13,51,14,122,
15,130,15,138,15,164,15,18,16,0,0,63,19,0,0,29,11,11,72,112,97,
15,130,15,138,15,164,15,18,16,0,0,67,19,0,0,29,11,11,72,112,97,
116,104,45,115,116,114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,
108,45,99,97,115,101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,
108,112,97,116,104,77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,
@ -302,7 +306,7 @@
173,3,23,202,1,28,192,192,35,249,22,151,5,23,197,1,83,158,39,20,97,
95,89,162,8,44,35,47,9,224,3,2,33,58,23,195,1,23,196,1,27,248,
22,136,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1,
65,98,101,103,105,110,16,0,83,158,41,20,100,138,67,35,37,117,116,105,108,
65,98,101,103,105,110,16,0,83,158,41,20,100,141,67,35,37,117,116,105,108,
115,2,1,11,11,10,10,42,80,158,35,35,20,103,159,37,16,17,30,2,1,
2,2,193,30,2,1,2,3,193,30,2,1,2,4,193,30,2,1,2,5,193,
30,2,1,2,6,193,30,2,1,2,7,193,30,2,1,2,8,193,30,2,1,
@ -311,62 +315,63 @@
2,16,193,30,2,18,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,
105,111,110,45,107,101,121,4,30,2,18,1,23,101,120,116,101,110,100,45,112,
97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,
4,2,6,2,5,2,3,2,9,39,11,38,35,11,11,16,11,2,8,2,7,
2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,16,11,11,
11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,16,2,15,2,
13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11,11,16,0,16,
0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,17,83,
158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159,35,53,36,83,
158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80,159,35,52,36,
83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31,80,159,35,35,
36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,36,36,83,158,
35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35,37,36,83,158,
35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80,159,35,38,36,
83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33,35,80,159,35,
39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0,33,37,80,159,
35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8,222,33,40,80,
159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,9,222,33,41,
80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,2,10,222,33,
42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,53,2,11,222,
33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,36,43,2,12,
222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20,96,96,2,13,
89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223,0,33,46,89,
162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35,16,2,27,248,
22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,2,21,6,1,
1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,97,93,42,41,
126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,47,2,14,223,
0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20,96,96,2,15,
89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9,223,0,33,56,
89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158,35,16,2,89,
162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29,94,2,17,68,
35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109,105,110,45,115,
116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5068);
0,35,16,4,2,6,2,5,2,3,2,9,39,11,11,38,35,11,11,16,11,
2,8,2,7,2,16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,
2,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,8,2,7,2,
16,2,15,2,13,2,12,2,4,2,11,2,14,2,10,2,2,46,46,36,11,
11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,
0,16,17,83,158,35,16,2,89,162,43,36,48,2,19,223,0,33,29,80,159,
35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,19,223,0,33,30,80,
159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,2,222,33,31,
80,159,35,35,36,83,158,35,16,2,249,22,159,6,7,92,7,92,80,159,35,
36,36,83,158,35,16,2,89,162,43,36,53,2,4,223,0,33,32,80,159,35,
37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,5,222,33,33,80,
159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,6,222,33,
35,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,7,223,0,
33,37,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51,2,8,
222,33,40,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38,49,2,
9,222,33,41,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43,37,52,
2,10,222,33,42,80,159,35,43,36,83,158,35,16,2,32,0,89,162,43,37,
53,2,11,222,33,43,80,159,35,44,36,83,158,35,16,2,32,0,89,162,43,
36,43,2,12,222,33,44,80,159,35,45,36,83,158,35,16,2,83,158,38,20,
96,96,2,13,89,162,43,35,43,9,223,0,33,45,89,162,43,36,44,9,223,
0,33,46,89,162,43,37,54,9,223,0,33,47,80,159,35,46,36,83,158,35,
16,2,27,248,22,182,13,248,22,168,7,27,28,249,22,162,8,247,22,176,7,
2,21,6,1,1,59,6,1,1,58,250,22,141,7,6,14,14,40,91,94,126,
97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,
47,2,14,223,0,33,50,80,159,35,47,36,83,158,35,16,2,83,158,38,20,
96,96,2,15,89,162,8,44,38,53,9,223,0,33,55,89,162,43,37,46,9,
223,0,33,56,89,162,43,36,45,9,223,0,33,57,80,159,35,48,36,83,158,
35,16,2,89,162,43,38,51,2,16,223,0,33,59,80,159,35,49,36,94,29,
94,2,17,68,35,37,107,101,114,110,101,108,11,29,94,2,17,69,35,37,109,
105,110,45,115,116,120,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 5072);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,111,0,0,0,255,0,0,0,65,113,117,111,116,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,111,0,0,0,3,1,0,0,65,113,117,111,116,
101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,
37,107,101,114,110,101,108,11,98,10,35,11,8,135,231,97,159,2,2,35,35,
37,107,101,114,110,101,108,11,98,10,35,11,8,186,245,97,159,2,2,35,35,
159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16,
0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,
100,138,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,
100,141,69,35,37,98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,
42,42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,0,35,
11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,0,16,0,16,
0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,0,99,2,6,
2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,2,4,2,3,
2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 292);
16,0,35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,
0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,
0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,
2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,
9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 296);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,51,53,0,0,0,1,0,0,3,0,14,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,51,46,52,53,0,0,0,1,0,0,3,0,14,0,
41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200,
0,223,0,3,1,8,1,13,1,18,1,27,1,32,1,63,1,67,1,75,1,
83,1,91,1,194,1,239,1,3,2,31,2,62,2,117,2,127,2,174,2,184,
2,191,2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,15,6,21,6,
35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,164,15,0,
35,6,62,6,147,6,149,6,214,6,149,12,208,12,240,12,0,0,168,15,0,
0,29,11,11,70,100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,
117,108,116,45,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,
65,113,117,111,116,101,29,94,2,4,67,35,37,117,116,105,108,115,11,29,94,
@ -525,7 +530,7 @@
33,43,89,162,43,38,48,9,223,1,33,44,89,162,43,39,8,30,9,225,2,
3,0,33,50,208,87,95,248,22,150,4,248,80,158,37,49,247,22,183,11,248,
22,188,4,80,158,36,36,248,22,174,12,80,159,36,41,36,159,35,20,103,159,
35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,138,66,35,37,98,
35,16,1,65,98,101,103,105,110,16,0,83,158,41,20,100,141,66,35,37,98,
111,111,116,2,1,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,30,
2,1,2,2,193,30,2,1,2,3,193,30,2,5,72,112,97,116,104,45,115,
116,114,105,110,103,63,10,30,2,5,75,112,97,116,104,45,97,100,100,45,115,
@ -537,26 +542,26 @@
1,2,14,193,30,2,1,2,15,193,30,2,5,69,45,102,105,110,100,45,99,
111,108,0,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,
116,104,6,30,2,5,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,
117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,11,2,10,2,
11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,14,46,11,
38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,36,11,11,16,
0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,
16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,57,36,
83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,35,56,36,83,
158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,26,
80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45,
100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,248,22,176,7,
69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89,
162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,35,16,2,32,
0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,158,35,16,2,
247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,159,35,43,36,
83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,2,248,22,18,
74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83,
158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158,
35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,35,48,36,83,
158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,159,35,49,36,
83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,159,35,53,36,
95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,2,4,69,35,
37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4131);
117,102,102,105,120,9,30,2,1,2,16,193,16,0,11,11,16,0,35,16,11,
2,10,2,11,2,8,2,9,2,12,2,13,2,3,2,7,2,2,2,15,2,
14,46,11,11,38,35,11,11,16,1,2,16,16,1,11,16,1,2,16,36,36,
36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,
35,16,0,16,16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,
159,35,57,36,83,158,35,16,2,89,162,43,36,44,9,223,0,33,25,80,159,
35,56,36,83,158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,
223,0,33,26,80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,
105,116,104,45,100,105,114,223,0,33,27,80,159,35,54,36,83,158,35,16,2,
248,22,176,7,69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,
35,16,2,89,162,43,37,59,2,3,223,0,33,36,80,159,35,36,36,83,158,
35,16,2,32,0,89,162,8,44,36,41,2,7,222,192,80,159,35,41,36,83,
158,35,16,2,247,22,125,80,159,35,42,36,83,158,35,16,2,247,22,124,80,
159,35,43,36,83,158,35,16,2,247,22,60,80,159,35,44,36,83,158,35,16,
2,248,22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,
35,45,36,83,158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,
35,47,83,158,35,16,2,32,0,89,162,43,37,44,2,14,222,33,42,80,159,
35,48,36,83,158,35,16,2,89,162,8,44,36,44,2,15,223,0,33,51,80,
159,35,49,36,83,158,35,16,2,89,162,43,35,43,2,16,223,0,33,52,80,
159,35,53,36,95,29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,
2,4,69,35,37,109,105,110,45,115,116,120,11,2,5,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 4135);
}

492
src/mzscheme/src/module.c
View File

@ -244,7 +244,11 @@ static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash
Scheme_Module_Exports *me,
Scheme_Env *genv,
int reprovide_kernel,
Scheme_Object *form);
Scheme_Object *form,
char **_phase1_protects);
static Scheme_Object **compute_indirects(Scheme_Env *genv,
Scheme_Module_Phase_Exports *pt,
int *_count);
static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx,
int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list);
static void finish_expstart_module(Scheme_Env *menv);
@ -3100,28 +3104,51 @@ static Scheme_Module *module_load(Scheme_Object *name, Scheme_Env *env, const ch
static void setup_accessible_table(Scheme_Module *m)
{
if (!m->accessible) {
Scheme_Hash_Table *ht;
int i, count, nvp;
Scheme_Module_Phase_Exports *pt;
int j;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
nvp = m->me->rt->num_var_provides;
for (i = 0; i < nvp; i++) {
if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) {
scheme_hash_set(ht, m->me->rt->provide_src_names[i], scheme_make_integer(i));
}
}
for (j = 0; j < 2; j++) {
if (!j)
pt = m->me->rt;
else
pt = m->me->et;
if (pt) {
Scheme_Hash_Table *ht;
int i, count, nvp;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
nvp = pt->num_var_provides;
for (i = 0; i < nvp; i++) {
if (SCHEME_FALSEP(pt->provide_srcs[i])) {
scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(i));
}
}
if (j == 0) {
count = m->num_indirect_provides;
for (i = 0; i < count; i++) {
scheme_hash_set(ht, m->indirect_provides[i], scheme_make_integer(i + nvp));
}
} else {
count = m->num_indirect_et_provides;
for (i = 0; i < count; i++) {
scheme_hash_set(ht, m->et_indirect_provides[i], scheme_make_integer(i + nvp));
}
}
/* Add syntax as negative ids: */
count = pt->num_provides;
for (i = nvp; i < count; i++) {
if (SCHEME_FALSEP(pt->provide_srcs[i])) {
scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(-(i+1)));
}
}
count = m->num_indirect_provides;
for (i = 0; i < count; i++) {
scheme_hash_set(ht, m->indirect_provides[i], scheme_make_integer(i + nvp));
}
m->accessible = ht;
/* Add syntax as negative ids: */
count = m->me->rt->num_provides;
for (i = nvp; i < count; i++) {
if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) {
scheme_hash_set(ht, m->me->rt->provide_src_names[i], scheme_make_integer(-(i+1)));
if (!j)
m->accessible = ht;
else
m->et_accessible = ht;
}
}
}
@ -3212,111 +3239,163 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
supplied (not both). For unprotected access, both prot_insp
and stx+certs should be supplied. */
{
Scheme_Module_Phase_Exports *pt;
if (!SCHEME_SYMBOLP(symbol))
symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL);
if (scheme_is_kernel_env(env)
|| ((env->module->primitive && !env->module->provide_protects))
/* For now[?], we're pretending that all definitions exists for
non-0 local phase. */
|| env->mod_phase) {
|| ((env->module->primitive && !env->module->provide_protects))) {
if (want_pos)
return scheme_make_integer(-1);
else
return symbol;
}
if (position >= 0) {
/* Check whether the symbol at `pos' matches the string part of
the expected symbol. */
Scheme_Object *isym;
int need_cert = 0;
switch (env->mod_phase) {
case 0:
pt = env->module->me->rt;
break;
case 1:
pt = env->module->me->et;
break;
default:
pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->module->me->other_phases,
scheme_make_integer(env->mod_phase));
break;
}
if (position < env->module->me->rt->num_var_provides) {
if (!env->module->me->rt->provide_srcs
|| SCHEME_FALSEP(env->module->me->rt->provide_srcs[position]))
isym = env->module->me->rt->provide_src_names[position];
else
isym = NULL;
} else {
int ipos = position - env->module->me->rt->num_var_provides;
if (ipos < env->module->num_indirect_provides) {
isym = env->module->indirect_provides[ipos];
need_cert = 1;
if (_protected)
*_protected = 1;
} else
isym = NULL;
}
if (pt) {
if (position >= 0) {
/* Check whether the symbol at `pos' matches the string part of
the expected symbol. */
Scheme_Object *isym;
int need_cert = 0;
if (isym) {
if (SAME_OBJ(isym, symbol)
|| (SCHEME_SYM_LEN(isym) == SCHEME_SYM_LEN(symbol)
&& !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) {
if ((position < env->module->me->rt->num_var_provides)
&& scheme_module_protected_wrt(env->insp, prot_insp)
&& env->module->provide_protects
&& env->module->provide_protects[position]) {
if (_protected)
*_protected = 1;
check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
}
if (need_cert)
check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
if (want_pos)
return scheme_make_integer(position);
else
return isym;
}
}
/* failure */
} else {
Scheme_Object *pos;
pos = scheme_hash_get(env->module->accessible, symbol);
if (pos) {
if (position < -1) {
if (SCHEME_INT_VAL(pos) < 0)
pos = scheme_make_integer(-SCHEME_INT_VAL(pos) - 1);
else
pos = NULL;
if (position < pt->num_var_provides) {
if (!pt->provide_srcs
|| SCHEME_FALSEP(pt->provide_srcs[position]))
isym = pt->provide_src_names[position];
else
isym = NULL;
} else {
if (SCHEME_INT_VAL(pos) < 0)
pos = NULL;
}
}
int ipos = position - pt->num_var_provides;
int num_indirect_provides;
Scheme_Object **indirect_provides;
if (pos) {
if (env->module->provide_protects
&& (SCHEME_INT_VAL(pos) < env->module->me->rt->num_provides)
&& env->module->provide_protects[SCHEME_INT_VAL(pos)]) {
if (_protected)
*_protected = 1;
check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
if (env->mod_phase == 0) {
num_indirect_provides = env->module->num_indirect_provides;
indirect_provides = env->module->indirect_provides;
} else if (env->mod_phase == 1) {
num_indirect_provides = env->module->num_indirect_et_provides;
indirect_provides = env->module->et_indirect_provides;
} else {
num_indirect_provides = 0;
indirect_provides = NULL;
}
if (ipos < num_indirect_provides) {
isym = indirect_provides[ipos];
need_cert = 1;
if (_protected)
*_protected = 1;
} else
isym = NULL;
}
if ((position >= -1)
&& (SCHEME_INT_VAL(pos) >= env->module->me->rt->num_var_provides)) {
/* unexported var -- need cert */
if (_protected)
*_protected = 1;
check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
}
if (isym) {
if (SAME_OBJ(isym, symbol)
|| (SCHEME_SYM_LEN(isym) == SCHEME_SYM_LEN(symbol)
&& !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) {
if ((position < pt->num_var_provides)
&& scheme_module_protected_wrt(env->insp, prot_insp)) {
char *provide_protects;
if (env->mod_phase == 0)
provide_protects = env->module->provide_protects;
else if (env->mod_phase == 0)
provide_protects = env->module->et_provide_protects;
else
provide_protects = NULL;
if (provide_protects
&& provide_protects[position]) {
if (_protected)
*_protected = 1;
check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
}
}
if (want_pos)
return pos;
if (need_cert)
check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
if (want_pos)
return scheme_make_integer(position);
else
return isym;
}
}
/* failure */
} else {
Scheme_Object *pos;
if (!env->mod_phase)
pos = scheme_hash_get(env->module->accessible, symbol);
else if (env->mod_phase == 1)
pos = scheme_hash_get(env->module->et_accessible, symbol);
else
return symbol;
}
pos = NULL;
if (position < -1) {
/* unexported syntax -- need cert */
check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 0, 0);
return NULL;
if (pos) {
if (position < -1) {
if (SCHEME_INT_VAL(pos) < 0)
pos = scheme_make_integer(-SCHEME_INT_VAL(pos) - 1);
else
pos = NULL;
} else {
if (SCHEME_INT_VAL(pos) < 0)
pos = NULL;
}
}
if (pos) {
char *provide_protects;
if (env->mod_phase == 0)
provide_protects = env->module->provide_protects;
else if (env->mod_phase == 1)
provide_protects = env->module->et_provide_protects;
else
provide_protects = NULL;
if (provide_protects
&& (SCHEME_INT_VAL(pos) < pt->num_provides)
&& provide_protects[SCHEME_INT_VAL(pos)]) {
if (_protected)
*_protected = 1;
check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1);
}
if ((position >= -1)
&& (SCHEME_INT_VAL(pos) >= pt->num_var_provides)) {
/* unexported var -- need cert */
if (_protected)
*_protected = 1;
check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0);
}
if (want_pos)
return pos;
else
return symbol;
}
if (position < -1) {
/* unexported syntax -- need cert */
check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 0, 0);
return NULL;
}
}
}
@ -3336,14 +3415,15 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
srcstr = "";
srclen = 0;
}
scheme_wrong_syntax("link", stx, symbol,
"module mismatch, probably from old bytecode whose dependencies have changed: "
"variable not provided (directly or indirectly%s) from module: %D %s%t",
"variable not provided (directly or indirectly%s) from module: %D%s%t at source phase level: %d",
(position >= 0) ? " and at the expected position" : "",
env->module->modname,
srclen ? "accessed from module: " : "",
srcstr, srclen);
srclen ? " accessed from module: " : "",
srcstr, srclen,
env->mod_phase);
}
return NULL;
@ -5598,10 +5678,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */
Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */
Scheme_Object *exclude_hint = scheme_false, *lift_data;
Scheme_Object **exis;
Scheme_Object **exis, **et_exis;
Scheme_Object *lift_ctx;
int exicount;
char *exps;
int exicount, et_exicount;
char *exps, *et_exps;
int all_simple_renames = 1;
int maybe_has_lifts = 0;
int reprovide_kernel;
@ -5980,13 +6060,14 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
mrec.pre_unwrapped = 0;
mrec.env_already = 0;
mrec.comp_flags = rec[drec].comp_flags;
scheme_rec_add_certs(&mrec, 0, e);
if (!rec[drec].comp) {
Scheme_Expand_Info erec1;
erec1.comp = 0;
erec1.depth = -1;
erec1.value_name = boundname;
erec1.certs = rec[drec].certs;
erec1.certs = mrec.certs;
erec1.observer = rec[drec].observer;
erec1.pre_unwrapped = 0;
erec1.env_already = 0;
@ -6311,51 +6392,16 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->me,
env->genv,
reprovide_kernel,
form);
form, &et_exps);
/* Compute indirect provides (which is everything at the top-level): */
exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount);
et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount);
if (rec[drec].comp || (rec[drec].depth != -2)) {
scheme_clean_dead_env(env->genv);
}
/* Compute indirect provides (which is everything at the top-level): */
{
int i, count, j;
Scheme_Bucket **bs, *b;
Scheme_Object **exsns = env->genv->module->me->rt->provide_src_names;
int exvcount = env->genv->module->me->rt->num_var_provides;
bs = env->genv->toplevel->buckets;
for (count = 0, i = env->genv->toplevel->size; i--; ) {
b = bs[i];
if (b && b->val)
count++;
}
exis = MALLOC_N(Scheme_Object *, count);
for (count = 0, i = env->genv->toplevel->size; i--; ) {
b = bs[i];
if (b && b->val) {
Scheme_Object *name;
name = (Scheme_Object *)b->key;
/* If the name is directly provided, no need for indirect... */
for (j = 0; j < exvcount; j++) {
if (SAME_OBJ(name, exsns[j]))
break;
}
if (j == exvcount)
exis[count++] = name;
}
}
exicount = count;
qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);
}
if (!rec[drec].comp) {
Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt;
int excount = rt->num_provides;
@ -6465,6 +6511,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->et_body = exp_body_r;
env->genv->module->provide_protects = exps;
env->genv->module->et_provide_protects = et_exps;
env->genv->module->me->rt->reprovide_kernel = reprovide_kernel;
env->genv->module->me->rt->kernel_exclusion = exclude_hint;
@ -6472,6 +6519,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->indirect_provides = exis;
env->genv->module->num_indirect_provides = exicount;
env->genv->module->et_indirect_provides = et_exis;
env->genv->module->num_indirect_et_provides = et_exicount;
env->genv->module->comp_prefix = cenv->prefix;
if (all_simple_renames) {
@ -6878,6 +6928,64 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
return reprovide_kernel;
}
static Scheme_Object **compute_indirects(Scheme_Env *genv,
Scheme_Module_Phase_Exports *pt,
int *_count)
{
int i, count, j;
Scheme_Bucket **bs, *b;
Scheme_Object **exsns = pt->provide_src_names, **exis;
int exvcount = pt->num_var_provides, exicount;
if (!genv->toplevel)
count = 0;
else {
bs = genv->toplevel->buckets;
for (count = 0, i = genv->toplevel->size; i--; ) {
b = bs[i];
if (b && b->val)
count++;
}
}
if (!count) {
*_count = 0;
return NULL;
}
exis = MALLOC_N(Scheme_Object *, count);
for (count = 0, i = genv->toplevel->size; i--; ) {
b = bs[i];
if (b && b->val) {
Scheme_Object *name;
name = (Scheme_Object *)b->key;
/* If the name is directly provided, no need for indirect... */
for (j = 0; j < exvcount; j++) {
if (SAME_OBJ(name, exsns[j]))
break;
}
if (j == exvcount)
exis[count++] = name;
}
}
if (!count) {
*_count = 0;
return NULL;
}
exicount = count;
qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);
*_count = exicount;
return exis;
}
Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath,
Scheme_Object *mode)
{
@ -6979,12 +7087,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
Scheme_Module_Exports *me,
Scheme_Env *genv,
int reprovide_kernel,
Scheme_Object *form)
Scheme_Object *form,
char **_phase1_protects)
{
int i, count, z;
Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase;
Scheme_Hash_Table *provided, *required;
char *exps, *exets, *phase0_exps = NULL;
char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL;
int excount, exvcount;
Scheme_Module_Phase_Exports *pt;
@ -7190,8 +7299,12 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
if (SAME_OBJ(phase, scheme_make_integer(0)))
phase0_exps = exps;
else if (SAME_OBJ(phase, scheme_make_integer(1)))
phase1_exps = exps;
}
}
*_phase1_protects = phase1_exps;
return phase0_exps;
}
@ -8945,7 +9058,6 @@ static Scheme_Object *write_module(Scheme_Object *obj)
l = cons(scheme_make_integer(cnt), l);
count = m->me->rt->num_provides;
if (m->provide_protects) {
for (i = 0; i < count; i++) {
if (m->provide_protects[i])
@ -8962,16 +9074,39 @@ static Scheme_Object *write_module(Scheme_Object *obj)
} else
l = cons(scheme_false, l);
l = cons(scheme_make_integer(m->num_indirect_provides), l);
count = m->me->et->num_provides;
if (m->et_provide_protects) {
for (i = 0; i < count; i++) {
if (m->et_provide_protects[i])
break;
}
if (i < count) {
v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) {
SCHEME_VEC_ELS(v)[i] = (m->et_provide_protects[i] ? scheme_true : scheme_false);
}
} else
v = scheme_false;
l = cons(v, l);
} else
l = cons(scheme_false, l);
count = m->num_indirect_provides;
l = cons(scheme_make_integer(count), l);
v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) {
SCHEME_VEC_ELS(v)[i] = m->indirect_provides[i];
}
l = cons(v, l);
count = m->num_indirect_et_provides;
l = cons(scheme_make_integer(count), l);
v = scheme_make_vector(count, NULL);
for (i = 0; i < count; i++) {
SCHEME_VEC_ELS(v)[i] = m->et_indirect_provides[i];
}
l = cons(v, l);
l = cons(m->me->rt->reprovide_kernel ? scheme_true : scheme_false, l);
l = cons(m->me->rt->kernel_exclusion, l);
@ -9018,7 +9153,7 @@ static Scheme_Object *read_module(Scheme_Object *obj)
{
Scheme_Module *m;
Scheme_Object *ie, *nie;
Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v;
Scheme_Module_Exports *me;
Scheme_Module_Phase_Exports *pt;
char *ps, *sps;
@ -9096,6 +9231,24 @@ static Scheme_Object *read_module(Scheme_Object *obj)
count = SCHEME_INT_VAL(nie);
if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
v = MALLOC_N(Scheme_Object *, count);
for (i = 0; i < count; i++) {
v[i] = SCHEME_VEC_ELS(ie)[i];
}
m->et_indirect_provides = v;
m->num_indirect_et_provides = count;
if (!SCHEME_PAIRP(obj)) return_NULL();
ie = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return_NULL();
nie = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
count = SCHEME_INT_VAL(nie);
if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL();
v = MALLOC_N(Scheme_Object *, count);
for (i = 0; i < count; i++) {
@ -9104,6 +9257,10 @@ static Scheme_Object *read_module(Scheme_Object *obj)
m->indirect_provides = v;
m->num_indirect_provides = count;
if (!SCHEME_PAIRP(obj)) return_NULL();
eesp = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return_NULL();
esp = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
@ -9231,6 +9388,17 @@ static Scheme_Object *read_module(Scheme_Object *obj)
m->provide_protects = ps;
}
if (SCHEME_FALSEP(eesp)) {
m->et_provide_protects = NULL;
} else {
if (!SCHEME_VECTORP(eesp) || (SCHEME_VEC_SIZE(eesp) != count)) return_NULL();
ps = MALLOC_N_ATOMIC(char, count);
for (i = 0; i < count; i++) {
ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(eesp)[i]);
}
m->et_provide_protects = ps;
}
if (!SCHEME_PAIRP(obj)) return_NULL();
e = SCHEME_CAR(obj);
if (!SCHEME_VECTORP(e)) return_NULL();

4
src/mzscheme/src/schpriv.h
View File

@ -2563,8 +2563,8 @@ typedef struct Scheme_Module
Scheme_Object *self_modidx;
Scheme_Hash_Table *accessible;
Scheme_Hash_Table *et_accessible;
Scheme_Hash_Table *accessible; /* (symbol -> ...) */
Scheme_Hash_Table *et_accessible; /* phase -> (symbol -> ...) */
Scheme_Object *insp; /* declaration-time inspector, for creating certificates
and for module instantiation */

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.1.3.3"
#define MZSCHEME_VERSION "4.1.3.4"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

90
src/mzscheme/src/stxobj.c
View File

@ -185,8 +185,10 @@ typedef struct Scheme_Cert {
/* Certs encoding:
- NULL: no inactive or active certs;
maybe inactive certs in nested parts
- cons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL);
no inactive certs in nested parts */
- rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL);
maybe inactive certs in nested parts
- immutable-rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL);
no inactive certs in nested parts (using the immutable flag as a hack!) */
#define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))
#define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))
static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp);
@ -557,6 +559,7 @@ void scheme_init_stx(Scheme_Env *env)
REGISTER_SO(no_nested_inactive_certs);
no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL);
SCHEME_SET_IMMUTABLE(no_nested_inactive_certs);
}
/*========================================================================*/
@ -1983,15 +1986,20 @@ static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int
icerts = first;
}
/* Even if icerts is NULL, preserve the pair in ->certs,
to indicate no nested inactive certs. */
if (icerts || SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)) {
nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
} else
nc = (Scheme_Object *)acerts;
((Scheme_Stx *)o)->certs = nc;
/* Even if icerts is NULL, may preserve the pair in ->certs,
to indicate no nested inactive certs: */
{
int no_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)
&& SCHEME_IMMUTABLEP(((Scheme_Stx *)o)->certs));
if (icerts || no_sub) {
nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
if (no_sub)
SCHEME_SET_IMMUTABLE(nc);
} else
nc = (Scheme_Object *)acerts;
((Scheme_Stx *)o)->certs = nc;
}
}
}
@ -2396,7 +2404,6 @@ static Scheme_Cert *append_certs(Scheme_Cert *a, Scheme_Cert *b)
}
static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active)
/* If !active, then inactive certs must have been lifted already. */
{
Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs;
Scheme_Stx *stx = (Scheme_Stx *)o, *res;
@ -2469,9 +2476,13 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
if (!active) {
pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs);
res->certs = pr;
if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
SCHEME_SET_IMMUTABLE(pr);
} else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs));
res->certs = pr;
if (SCHEME_IMMUTABLEP(stx->certs))
SCHEME_SET_IMMUTABLE(pr);
} else
res->certs = (Scheme_Object *)orig_certs;
stx = res;
@ -2529,7 +2540,8 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
int active)
/* If `name' is module-bound, add the module's certification.
Also copy any certifications from plus_stx.
If active and mark is non-NULL, make inactive certificates active. */
If active and mark is non-NULL, make inactive certificates active.
Existing inactive are lifted when adding from plus_stx_or_certs. */
{
if (mark && active) {
o = scheme_stx_activate_certs(o);
@ -2574,21 +2586,25 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
cert = ACTIVE_CERTS(stx);
else
cert = INACTIVE_CERTS(stx);
cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->me->src_modidx,
menv->module->insp, key, cert);
menv->module->insp, key, cert);
if (active) {
if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
Scheme_Object *pr;
pr = scheme_make_raw_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs));
res->certs = pr;
if (SCHEME_IMMUTABLEP(stx->certs))
SCHEME_SET_IMMUTABLE(pr);
} else
res->certs = (Scheme_Object *)cert;
} else {
Scheme_Object *pr;
pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert);
res->certs = pr;
if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
SCHEME_SET_IMMUTABLE(pr);
}
o = (Scheme_Object *)res;
@ -2871,28 +2887,38 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
Scheme_Stx *stx = (Scheme_Stx *)o;
if (INACTIVE_CERTS(stx)) {
/* Change inactive certs to active certs. (No
sub-object has inactive certs, because they
are always lifted when inactive certs are added.) */
Scheme_Object *np;
/* Change inactive certs to active certs. */
Scheme_Object *np, *v;
Scheme_Stx *res;
Scheme_Cert *certs;
res = (Scheme_Stx *)scheme_make_stx(stx->val,
if (SCHEME_IMMUTABLEP(stx->certs)) {
/* No sub-object has other inactive certs */
v = stx->val;
} else {
v = stx_activate_certs(stx->val, cp);
}
res = (Scheme_Stx *)scheme_make_stx(v,
stx->srcloc,
stx->props);
res->wraps = stx->wraps;
res->u.lazy_prefix = stx->u.lazy_prefix;
np = scheme_make_raw_pair(SCHEME_CAR(stx->certs), NULL);
if (!ACTIVE_CERTS(stx))
np = no_nested_inactive_certs;
else {
np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
SCHEME_SET_IMMUTABLE(np);
}
res->certs = np;
certs = append_certs(INACTIVE_CERTS(stx), *cp);
*cp = certs;
return (Scheme_Object *)res;
} else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
/* Explicit pair but NULL for inactive certs means no
inactive certs anywhere in this object. */
} else if (stx->certs && SCHEME_RPAIRP(stx->certs)
&& SCHEME_IMMUTABLEP(stx->certs)) {
/* Explicit pair, but no inactive certs anywhere in this object. */
return (Scheme_Object *)stx;
} else {
o = stx_activate_certs(stx->val, cp);
@ -2904,14 +2930,11 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
stx->props);
res->wraps = stx->wraps;
res->u.lazy_prefix = stx->u.lazy_prefix;
/* stx->certs must not be a pair, otherwise we
would have taken an earlier branch; allocate
a pair with an explicitl NULL now to inidicate
that there are no nested certs here */
if (stx->certs) {
if (ACTIVE_CERTS(stx)) {
Scheme_Object *np;
np = scheme_make_raw_pair(stx->certs, NULL);
np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
res->certs = np;
SCHEME_SET_IMMUTABLE(np);
} else
res->certs = no_nested_inactive_certs;
@ -2922,6 +2945,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
Scheme_Object *np;
np = scheme_make_raw_pair(stx->certs, NULL);
stx->certs = np;
SCHEME_SET_IMMUTABLE(np);
} else
stx->certs = no_nested_inactive_certs;
@ -2937,6 +2961,8 @@ static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active)
Scheme_Cert *certs = NULL;
o = stx_activate_certs(o, &certs);
/* the inactive certs collected into `certs'
have been stripped from `o' at this point */
if (certs)
o = add_certs(o, certs, NULL, as_active);
@ -6925,10 +6951,8 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
((Scheme_Stx *)src)->props = properties;
}
if (certs) {
src = lift_inactive_certs(src, 0);
if (certs)
src = add_certs(src, (Scheme_Cert *)certs, NULL, 0);
}
return src;
}

4
src/mzscheme/src/syntax.c
View File

@ -5184,6 +5184,10 @@ quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_In
/* Push all certificates in the environment down to the syntax object. */
stx = scheme_stx_add_inactive_certs(stx, rec[drec].certs);
if (env->genv->module) {
/* Also certify access to the enclosing module: */
stx = scheme_stx_cert(stx, scheme_false, env->genv, NULL, NULL, 0);
}
if (rec[drec].comp) {
return scheme_register_stx_in_prefix(stx, env, rec, drec);