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

fix errortrace (required API changes), add `syntax-shift-phase-level'

Browse Source 
Also fix a bug in the `module' expander and streamline lazy
visits.
This commit is contained in:
Matthew Flatt 2011-09-13 10:15:34 -06:00
parent 437d654cc1
commit a233697f08
17 changed files with 184 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/drracket/private/debug.rkt
View File

@ -533,7 +533,7 @@ profile todo:
;; a member of stacktrace-imports^ ;; a member of stacktrace-imports^
;; guarantees that the continuation marks associated with errortrace-key are ;; guarantees that the continuation marks associated with errortrace-key are
;; members of the debug-source type, after unwrapped with st-mark-source ;; members of the debug-source type, after unwrapped with st-mark-source
(define (with-mark src-stx expr) (define (with-mark src-stx expr phase)
(let ([source (cond (let ([source (cond
[(path? (syntax-source src-stx)) [(path? (syntax-source src-stx))
(syntax-source src-stx)] (syntax-source src-stx)]
@ -557,10 +557,12 @@ profile todo:
(if source (if source
(with-syntax ([expr expr] (with-syntax ([expr expr]
[mark (list 'dummy-thing source line column position span)] [mark (list 'dummy-thing source line column position span)]
[errortrace-key errortrace-key]) [wcm (syntax-shift-phase-level #'with-continuation-mark phase)]
[errortrace-key (syntax-shift-phase-level errortrace-key phase)]
[qte (syntax-shift-phase-level #'quote phase)])
(syntax (syntax
(with-continuation-mark 'errortrace-key (wcm (qte errortrace-key)
'mark (qte mark)
expr))) expr)))
expr))) expr)))

5
collects/errortrace/errortrace-key-syntax.rkt
View File

@ -1,5 +0,0 @@
(module errortrace-key-syntax mzscheme
(require errortrace/errortrace-key)
(require-for-syntax errortrace/errortrace-key)
(define errortrace-key-syntax #'errortrace-key)
(provide errortrace-key-syntax))

27
collects/errortrace/errortrace-lib.rkt
View File

@ -5,6 +5,7 @@
(require "stacktrace.rkt" (require "stacktrace.rkt"
"errortrace-key.rkt" "errortrace-key.rkt"
"private/utils.rkt"
racket/contract racket/contract
racket/unit racket/unit
racket/runtime-path racket/runtime-path
@ -198,23 +199,21 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stacktrace instrumenter ;; Stacktrace instrumenter
(define-runtime-path key-syntax (define base-phase
'(lib "errortrace-key-syntax.rkt" "errortrace")) (variable-reference->module-base-phase (#%variable-reference)))
(define dynamic-errortrace-key
(dynamic-require key-syntax 'errortrace-key-syntax))
;; with-mark : stx stx -> stx ;; with-mark : stx stx -> stx
(define (with-mark mark expr) (define (with-mark mark expr phase)
(let ([loc (make-st-mark mark)]) (let ([loc (make-st-mark mark phase)])
(if loc (if loc
(with-syntax ([expr expr] (with-syntax ([expr expr]
[loc loc] [loc loc]
[et-key dynamic-errortrace-key]) [et-key (syntax-shift-phase-level #'errortrace-key (- phase base-phase))]
[wcm (syntax-shift-phase-level #'with-continuation-mark (- phase base-phase))])
(execute-point (execute-point
mark mark
(syntax (syntax
(with-continuation-mark et-key (wcm et-key
loc loc
expr)))) expr))))
expr))) expr)))
@ -415,6 +414,7 @@
[(mod name init-import mb) [(mod name init-import mb)
(syntax-case (disarm #'mb) (#%plain-module-begin) (syntax-case (disarm #'mb) (#%plain-module-begin)
[(#%plain-module-begin body ...) [(#%plain-module-begin body ...)
(let ([meta-depth ((count-meta-levels 0) #'(begin body ...))])
(add-test-coverage-init-code (add-test-coverage-init-code
(normal (normal
(copy-props (copy-props
@ -422,14 +422,9 @@
#`(#,(namespace-module-identifier) name init-import #`(#,(namespace-module-identifier) name init-import
#,(syntax-rearm #,(syntax-rearm
#`(#%plain-module-begin #`(#%plain-module-begin
#,((make-syntax-introducer) #,(generate-key-imports meta-depth)
(syntax/loc (datum->syntax #f 'x #f)
(#%require errortrace/errortrace-key)))
#,((make-syntax-introducer)
(syntax/loc (datum->syntax #f 'x #f)
(#%require (for-syntax errortrace/errortrace-key))))
body ...) body ...)
#'mb)))))])])))] #'mb))))))])])))]
[_else [_else
(normal top-e)]))) (normal top-e)])))

10
collects/errortrace/lang/body.rkt
View File

@ -1,7 +1,9 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base (require (for-syntax racket/base
syntax/strip-context syntax/strip-context
"../errortrace-lib.rkt")) racket/pretty
"../errortrace-lib.rkt"
"../private/utils.rkt"))
(provide (rename-out [module-begin #%module-begin])) (provide (rename-out [module-begin #%module-begin]))
@ -9,13 +11,15 @@
(syntax-case stx () (syntax-case stx ()
[(_ lang . body) [(_ lang . body)
(let ([e (annotate-top (let ([e (annotate-top
(syntax-local-introduce (values ; syntax-local-introduce
(local-expand #`(module . #,(strip-context #`(n lang . body))) (local-expand #`(module . #,(strip-context #`(n lang . body)))
'top-level 'top-level
null)) null))
0)]) 0)])
(collect-garbage)
(syntax-case e () (syntax-case e ()
[(mod nm lang (mb . body)) [(mod nm lang (mb . body))
#`(#%plain-module-begin #`(#%plain-module-begin
(require (only-in lang) errortrace/errortrace-key) (require (only-in lang))
#,(generate-key-imports ((count-meta-levels 0) #'(begin . body)))
. body)]))])) . body)]))]))

31
collects/errortrace/private/utils.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang racket/base
(provide count-meta-levels
generate-key-imports)
(define base (variable-reference->module-base-phase (#%variable-reference)))
(define ((count-meta-levels phase) expr)
(syntax-case expr ()
[(bfs . exprs)
(free-identifier=? #'bfs #'begin-for-syntax phase base)
(add1 (apply max 0 (map (count-meta-levels (add1 phase)) (syntax->list #'exprs))))]
[(ds . _)
(free-identifier=? #'ds #'define-syntaxes phase base)
1]
[(b . exprs)
(free-identifier=? #'b #'begin phase base)
(apply max 0 (map (count-meta-levels phase) (syntax->list #'exprs)))]
[_ 0]))
(define (generate-key-imports meta-depth)
(syntax-shift-phase-level
(let loop ([meta-depth meta-depth])
(let ([e ((make-syntax-introducer)
#`(#%require (for-meta #,meta-depth
errortrace/errortrace-key)))])
(if (zero? meta-depth)
e
#`(begin #,e #,(loop (sub1 meta-depth))))))
(- (syntax-local-phase-level) base)))

19
collects/errortrace/scribblings/errortrace.scrbl
View File

@ -45,7 +45,7 @@ Then,
] ]
After starting @racketmodname[errortrace] in one of these ways, when an After starting @racketmodname[errortrace] in one of these ways, when an
exception occurs, the exception handler something like a stack trace exception occurs, the exception handler prints something like a stack trace
with most recent contexts first. with most recent contexts first.
The @racketmodname[errortrace] module is strange: Don't import it The @racketmodname[errortrace] module is strange: Don't import it
@ -105,7 +105,7 @@ but instruments the module for debugging in the same way as if
@racketmodname[errortrace] is required before loading the module from @racketmodname[errortrace] is required before loading the module from
source. Using the @racketmodname[errortrace] meta-language is one way source. Using the @racketmodname[errortrace] meta-language is one way
to ensure that debugging instrumentation is present when the module is to ensure that debugging instrumentation is present when the module is
compiled.} compiled.
@; --------------------------------------------- @; ---------------------------------------------
@ -374,8 +374,8 @@ Imports @racket[stacktrace-imports^] and exports @racket[stacktrace^].}
@defsignature[stacktrace^ ()]{ @defsignature[stacktrace^ ()]{
@deftogether[( @deftogether[(
@defproc[(annotate (stx syntax?) (phase-level exact-integer?)) syntax?] @defproc[(annotate (stx syntax?) (phase-level exact-nonnegative-integer?)) syntax?]
@defproc[(annotate-top (stx syntax?) (phase-level exact-integer?)) syntax?])]{ @defproc[(annotate-top (stx syntax?) (phase-level exact-nonnegative-integer?)) syntax?])]{
Annotate expressions with errortrace information. The Annotate expressions with errortrace information. The
@racketout[annotate-top] function should be called with a top-level @racketout[annotate-top] function should be called with a top-level
@ -386,7 +386,7 @@ expression, typically @racket[(namespace-base-phase)] for a top-level
expression.} expression.}
@deftogether[( @deftogether[(
@defproc[(make-st-mark (syntax syntax?)) (or/c #f st-mark?)] @defproc[(make-st-mark [stx syntax?] [phase-level exact-nonnegative-integer?]) (or/c #f st-mark?)]
@defproc[(st-mark-source (st-mark st-mark?)) syntax?] @defproc[(st-mark-source (st-mark st-mark?)) syntax?]
@defproc[(st-mark-bindings (st-mark st-mark?)) list?])]{ @defproc[(st-mark-bindings (st-mark st-mark?)) list?])]{
@ -406,12 +406,15 @@ hardwired to return @racket[null]. }
@defsignature[stacktrace-imports^ ()]{ @defsignature[stacktrace-imports^ ()]{
@defproc[(with-mark (source-stx any/c) (dest-stx any/c)) any/c]{ @defproc[(with-mark [source-stx any/c]
[dest-stx any/c]
[phase nonnegative-exact-integer?])
any/c]{
Called by @racketout[annotate] and @racketout[annotate-top] to wrap Called by @racketout[annotate] and @racketout[annotate-top] to wrap
expressions with @racket[with-continuation-mark]. The first argument expressions with @racket[with-continuation-mark]. The first argument
is the source expression and the second argument is the expression to is the source expression, the second argument is the expression to
be wrapped.} be wrapped, and the last is the phase level of the expression.}
@defboolparam[test-coverage-enabled on?]{ @defboolparam[test-coverage-enabled on?]{

37
collects/errortrace/stacktrace.rkt
View File

@ -52,19 +52,21 @@
[(syntax? v) (short-version (syntax-e v) depth)] [(syntax? v) (short-version (syntax-e v) depth)]
[else v])) [else v]))
(define (make-st-mark stx) (define (make-st-mark stx phase)
(unless (syntax? stx) (unless (syntax? stx)
(error 'make-st-mark (error 'make-st-mark
"expected syntax object as argument, got ~e" stx)) "expected syntax object as argument, got ~e" stx))
(cond (cond
[(syntax-source stx) [(syntax-source stx)
(with-syntax ([quote (syntax-shift-phase-level #'quote phase)])
#`(quote (#,(short-version stx 10) #`(quote (#,(short-version stx 10)
#,(syntax-source stx) #,(syntax-source stx)
#,(syntax-line stx) #,(syntax-line stx)
#,(syntax-column stx) #,(syntax-column stx)
#,(syntax-position stx) #,(syntax-position stx)
#,(syntax-span stx)))] #,(syntax-span stx))))]
[else #f])) [else #f]))
(define (st-mark-source src) (define (st-mark-source src)
(and src (and src
(datum->syntax #f (car src) (cdr src) #f))) (datum->syntax #f (car src) (cdr src) #f)))
@ -309,6 +311,8 @@
(define (make-annotate top? name) (define (make-annotate top? name)
(lambda (expr phase) (lambda (expr phase)
(define disarmed-expr (disarm expr)) (define disarmed-expr (disarm expr))
(define (with-mrk* mark expr)
(with-mark mark expr phase))
(test-coverage-point (test-coverage-point
(kernel-syntax-case/phase disarmed-expr phase (kernel-syntax-case/phase disarmed-expr phase
[_ [_
@ -324,11 +328,11 @@
expr] expr]
[else [else
;; might be undefined/uninitialized ;; might be undefined/uninitialized
(with-mark expr expr)]))] (with-mrk* expr expr)]))]
[(#%top . id) [(#%top . id)
;; might be undefined/uninitialized ;; might be undefined/uninitialized
(with-mark expr expr)] (with-mrk* expr expr)]
[(#%variable-reference . _) [(#%variable-reference . _)
;; no error possible ;; no error possible
expr] expr]
@ -337,7 +341,7 @@
top? top?
;; Can't put annotation on the outside ;; Can't put annotation on the outside
(let* ([marked (let* ([marked
(with-mark expr (with-mrk* expr
(annotate-named (annotate-named
(one-name #'names) (one-name #'names)
(syntax rhs) (syntax rhs)
@ -372,7 +376,8 @@
(annotate-named (annotate-named
(one-name #'(name ...)) (one-name #'(name ...))
(syntax rhs) (syntax rhs)
(add1 phase)))]) (add1 phase))
(add1 phase))])
(rearm (rearm
expr expr
(rebuild disarmed-expr (list (cons #'rhs marked)))))] (rebuild disarmed-expr (list (cons #'rhs marked)))))]
@ -446,7 +451,7 @@
;; Wrap RHSs and body ;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body) [(let-values ([vars rhs] ...) . body)
(with-mark expr (with-mrk* expr
(rearm (rearm
expr expr
(annotate-let disarmed-expr phase (annotate-let disarmed-expr phase
@ -466,7 +471,7 @@
(free-identifier=? #'var1 #'var2)) (free-identifier=? #'var1 #'var2))
fm] fm]
[_ [_
(with-mark expr fm)]))] (with-mrk* expr fm)]))]
;; This case is needed for `#lang errortrace ...', which uses ;; This case is needed for `#lang errortrace ...', which uses
;; `local-expand' on the module body. ;; `local-expand' on the module body.
[(letrec-syntaxes+values sbindings ([vars rhs] ...) . body) [(letrec-syntaxes+values sbindings ([vars rhs] ...) . body)
@ -476,7 +481,7 @@
(syntax (vars ...)) (syntax (vars ...))
(syntax (rhs ...)) (syntax (rhs ...))
(syntax body)))]) (syntax body)))])
(with-mark expr fm))] (with-mrk* expr fm))]
;; Wrap RHS ;; Wrap RHS
[(set! var rhs) [(set! var rhs)
@ -485,7 +490,7 @@
(syntax rhs) (syntax rhs)
phase)]) phase)])
;; set! might fail on undefined variable, or too many values: ;; set! might fail on undefined variable, or too many values:
(with-mark expr (with-mrk* expr
(rearm (rearm
expr expr
(rebuild disarmed-expr (list (cons #'rhs new-rhs))))))] (rebuild disarmed-expr (list (cons #'rhs new-rhs))))))]
@ -497,12 +502,12 @@
expr expr
#`(begin #,(annotate (syntax e) phase)))] #`(begin #,(annotate (syntax e) phase)))]
[(begin . body) [(begin . body)
(with-mark expr (with-mrk* expr
(rearm (rearm
expr expr
(annotate-seq disarmed-expr #'body annotate phase)))] (annotate-seq disarmed-expr #'body annotate phase)))]
[(begin0 . body) [(begin0 . body)
(with-mark expr (with-mrk* expr
(rearm (rearm
expr expr
(annotate-seq disarmed-expr #'body annotate phase)))] (annotate-seq disarmed-expr #'body annotate phase)))]
@ -510,7 +515,7 @@
(let ([w-tst (annotate (syntax tst) phase)] (let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)] [w-thn (annotate (syntax thn) phase)]
[w-els (annotate (syntax els) phase)]) [w-els (annotate (syntax els) phase)])
(with-mark expr (with-mrk* expr
(rearm (rearm
expr expr
(rebuild disarmed-expr (list (cons #'tst w-tst) (rebuild disarmed-expr (list (cons #'tst w-tst)
@ -519,13 +524,13 @@
[(if tst thn) [(if tst thn)
(let ([w-tst (annotate (syntax tst) phase)] (let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)]) [w-thn (annotate (syntax thn) phase)])
(with-mark expr (with-mrk* expr
(rearm (rearm
expr expr
(rebuild disarmed-expr (list (cons #'tst w-tst) (rebuild disarmed-expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))] (cons #'thn w-thn))))))]
[(with-continuation-mark . body) [(with-continuation-mark . body)
(with-mark expr (with-mrk* expr
(rearm (rearm
expr expr
(annotate-seq disarmed-expr (syntax body) (annotate-seq disarmed-expr (syntax body)
@ -546,7 +551,7 @@
;; It's (void): ;; It's (void):
expr] expr]
[else [else
(with-mark expr (rearm (with-mrk* expr (rearm
expr expr
(annotate-seq disarmed-expr (syntax body) (annotate-seq disarmed-expr (syntax body)
annotate phase)))])] annotate phase)))])]

2
collects/racket/private/sandbox-coverage.rkt
View File

@ -50,7 +50,7 @@
(define register-profile-start void) (define register-profile-start void)
(define register-profile-done void) (define register-profile-done void)
;; no marks ;; no marks
(define (with-mark mark expr) expr) (define (with-mark mark expr phase) expr)
(define-values/invoke-unit/infer stacktrace@) (define-values/invoke-unit/infer stacktrace@)

18
collects/scribblings/reference/stx-ops.scrbl
View File

@ -3,11 +3,19 @@
@title[#:tag "stxops"]{Syntax Object Content} @title[#:tag "stxops"]{Syntax Object Content}
@defproc[(syntax? [v any/c]) boolean?]{ @defproc[(syntax? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{syntax object}, @racket[#f] Returns @racket[#t] if @racket[v] is a @tech{syntax object}, @racket[#f]
otherwise. See also @secref["stxobj-model"].} otherwise. See also @secref["stxobj-model"].}
@defproc[(identifier? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{syntax object} and
@racket[(syntax-e stx)] produces a symbol.}
@defproc[(syntax-source [stx syntax?]) any]{ @defproc[(syntax-source [stx syntax?]) any]{
Returns the source for the @tech{syntax object} @racket[stx], or @racket[#f] Returns the source for the @tech{syntax object} @racket[stx], or @racket[#f]
@ -221,10 +229,14 @@ The @racket[ignored] argument is allowed for backward compatibility
and has no effect on the returned syntax object.} and has no effect on the returned syntax object.}
@defproc[(identifier? [v any/c]) boolean?]{ @defproc[(syntax-shift-phase-level [stx syntax?]
[shift exact-integer?])
syntax?]{
Returns @racket[#t] if @racket[v] is a @tech{syntax object} and Returns a syntax object that is like @racket[stx], but with all of its
@racket[(syntax-e stx)] produces a symbol.} top-level and module binding shifted by @racket[shift] @tech{phase
levels}. If @racket[shift] is @racket[0], then the result is
@racket[stx].}
@defproc[(generate-temporaries [stx-pair (or syntax? list?)]) @defproc[(generate-temporaries [stx-pair (or syntax? list?)])

8
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,11 @@
Version 5.1.3.9
Add syntax-shift-phase-level
errortrace: with-mark and make-st-mark now take a phase level
Version 5.1.3.8
Add syntax-transforming-module-expression? and
variable-reference->module-base-phase
Version 5.1.3.7 Version 5.1.3.7
Generalized begin-with-syntax to allow phase-N definitions, Generalized begin-with-syntax to allow phase-N definitions,
both variable and syntax, within a module for all N >= 0; both variable and syntax, within a module for all N >= 0;

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

@ -3600,7 +3600,7 @@ static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env
if (genv->rename_set) { if (genv->rename_set) {
form = scheme_add_rename(form, genv->rename_set); form = scheme_add_rename(form, genv->rename_set);
/* this "phase shift" just attaches the namespace's module registry: */ /* this "phase shift" just attaches the namespace's module registry: */
form = scheme_stx_phase_shift(form, 0, NULL, NULL, genv->module_registry->exports, NULL); form = scheme_stx_phase_shift(form, NULL, NULL, NULL, genv->module_registry->exports, NULL);
} }
return form; return form;
@ -3674,7 +3674,7 @@ static void *compile_k(void)
if (rename) { if (rename) {
form = add_renames_unless_module(form, genv); form = add_renames_unless_module(form, genv);
if (genv->module) { if (genv->module) {
form = scheme_stx_phase_shift(form, 0, form = scheme_stx_phase_shift(form, NULL,
genv->module->me->src_modidx, genv->module->me->src_modidx,
genv->module->self_modidx, genv->module->self_modidx,
genv->module_registry->exports, genv->module_registry->exports,
@ -4110,7 +4110,7 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *
result = scheme_make_vector(len - 1, NULL); result = scheme_make_vector(len - 1, NULL);
for (i = 0; i < len - 1; i++) { for (i = 0; i < len - 1; i++) {
s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], shift, orig, modidx, s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], scheme_make_integer(shift), orig, modidx,
env->module_registry->exports, NULL); env->module_registry->exports, NULL);
SCHEME_VEC_ELS(result)[i] = s; SCHEME_VEC_ELS(result)[i] = s;
} }
@ -5278,7 +5278,8 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
if (insp && SCHEME_FALSEP(insp)) if (insp && SCHEME_FALSEP(insp))
insp = scheme_get_current_inspector(); insp = scheme_get_current_inspector();
i = rp->num_toplevels; i = rp->num_toplevels;
v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx, v = scheme_stx_phase_shift_as_rename(scheme_make_integer(now_phase - src_phase),
src_modidx, now_modidx,
genv ? genv->module_registry->exports : NULL, genv ? genv->module_registry->exports : NULL,
insp); insp);
if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) { if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) {

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

@ -4535,26 +4535,26 @@ static void should_run_for_compile(Scheme_Env *menv, int phase)
{ {
if (menv->running[phase]) return; if (menv->running[phase]) return;
if (!phase) {
scheme_prepare_template_env(menv);
menv = menv->template_env;
} else {
while (phase > 1) { while (phase > 1) {
scheme_prepare_exp_env(menv); scheme_prepare_exp_env(menv);
menv = menv->exp_env; menv = menv->exp_env;
phase--; phase--;
} }
}
#if 0 #if 0
if (!scheme_hash_get(MODCHAIN_TABLE(menv->instance_env->modchain), menv->module->modname)) if (!scheme_hash_get(MODCHAIN_TABLE(menv->instance_env->modchain), menv->module->modname))
scheme_signal_error("internal error: inconsistent instance_env"); scheme_signal_error("internal error: inconsistent instance_env");
#endif #endif
if (!menv->available_next[0]) { if (!menv->available_next[0]) {
menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0); menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0);
MODCHAIN_AVAIL(menv->modchain, 0) = (Scheme_Object *)menv; MODCHAIN_AVAIL(menv->modchain, 0) = (Scheme_Object *)menv;
} }
if (!menv->available_next[1]) {
menv->available_next[1] = MODCHAIN_AVAIL(menv->modchain, 1);
MODCHAIN_AVAIL(menv->modchain, 1) = (Scheme_Object *)menv;
}
} }
static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, static void start_module(Scheme_Module *m, Scheme_Env *env, int restart,
@ -4704,13 +4704,6 @@ void scheme_prepare_compile_env(Scheme_Env *env)
that env->phase is visited. */ that env->phase is visited. */
{ {
do_prepare_compile_env(env, env->phase, 0); do_prepare_compile_env(env, env->phase, 0);
/* A top-level `require' can introduce in any phase with a
`for-syntax' import whose visit triggers an instantiation.
So, also check for instances at the next phase. */
if (env->exp_env) {
do_prepare_compile_env(env->exp_env, env->phase, 1);
}
} }
static void *eval_module_body_k(void) static void *eval_module_body_k(void)
@ -5743,7 +5736,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(m->modname)); fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(m->modname));
/* phase shift to replace self_modidx of previous expansion (if any): */ /* phase shift to replace self_modidx of previous expansion (if any): */
fm = scheme_stx_phase_shift(fm, 0, empty_self_modidx, self_modidx, NULL, m->insp); fm = scheme_stx_phase_shift(fm, NULL, empty_self_modidx, self_modidx, NULL, m->insp);
fm = scheme_add_rename(fm, rn_set); fm = scheme_add_rename(fm, rn_set);
@ -5852,7 +5845,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
} }
/* for future expansion, shift away from self_modidx: */ /* for future expansion, shift away from self_modidx: */
fm = scheme_stx_phase_shift(fm, 0, self_modidx, empty_self_modidx, NULL, NULL); fm = scheme_stx_phase_shift(fm, NULL, self_modidx, empty_self_modidx, NULL, NULL);
/* make self_modidx like the empty modidx */ /* make self_modidx like the empty modidx */
((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname; ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname;
@ -7069,7 +7062,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
if (erec) { if (erec) {
Scheme_Expand_Info erec1; Scheme_Expand_Info erec1;
scheme_init_expand_recs(rec, drec, &erec1, 1); scheme_init_expand_recs(erec, derec, &erec1, 1);
erec1.value_name = scheme_false; erec1.value_name = scheme_false;
e = scheme_expand_expr(e, nenv, &erec1, 0); e = scheme_expand_expr(e, nenv, &erec1, 0);
expanded_l = scheme_make_pair(e, expanded_l); expanded_l = scheme_make_pair(e, expanded_l);
@ -7306,7 +7299,7 @@ static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l,
Scheme_Object *expanded_provides, Scheme_Object *expanded_provides,
int phase) int phase)
/* mutates `expanded_l' to find `#%provide's (possibly nested in /* mutates `expanded_l' to find `#%provide's (possibly nested in
`begin-for-syntax') and elace them with the ones in `begin-for-syntax') and replace them with the ones in
`expanded_provides'. The provides in `expanded_l' and `expanded_provides'. The provides in `expanded_l' and
`expanded_provides' are matched up by order. */ `expanded_provides' are matched up by order. */
{ {
@ -7325,11 +7318,12 @@ static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l,
e = SCHEME_CAR(p); e = SCHEME_CAR(p);
if (SCHEME_STX_PAIRP(e)) { if (SCHEME_STX_PAIRP(e)) {
fst = SCHEME_STX_CAR(e); fst = SCHEME_STX_CAR(e);
if (scheme_stx_module_eq(prov_stx, fst, 0)) { if (scheme_stx_module_eq(prov_stx, fst, phase)) {
SCHEME_CAR(p) = SCHEME_CAR(expanded_provides); SCHEME_CAR(p) = SCHEME_CAR(expanded_provides);
expanded_provides = SCHEME_CDR(expanded_provides); expanded_provides = SCHEME_CDR(expanded_provides);
} else if (scheme_stx_module_eq(begin_for_syntax_stx, fst, 0)) { } else if (scheme_stx_module_eq(begin_for_syntax_stx, fst, phase)) {
l = scheme_flatten_syntax_list(e, NULL); l = scheme_flatten_syntax_list(e, NULL);
l = scheme_copy_list(l);
expanded_provides = fixup_expanded_provides(SCHEME_CDR(l), expanded_provides, phase + 1); expanded_provides = fixup_expanded_provides(SCHEME_CDR(l), expanded_provides, phase + 1);
e = scheme_datum_to_syntax(l, e, e, 0, 2); e = scheme_datum_to_syntax(l, e, e, 0, 2);
SCHEME_CAR(p) = e; SCHEME_CAR(p) = e;

5
src/racket/src/number.c
View File

@ -1110,6 +1110,11 @@ int scheme_get_unsigned_long_long_val(Scheme_Object *o, umzlonglong *v)
return 0; return 0;
} }
int scheme_exact_p(Scheme_Object *n)
{
return (SCHEME_INTP(n) || SCHEME_BIGNUMP(n));
}
int scheme_nonneg_exact_p(Scheme_Object *n) int scheme_nonneg_exact_p(Scheme_Object *n)
{ {
return ((SCHEME_INTP(n) && (SCHEME_INT_VAL(n) >= 0)) return ((SCHEME_INTP(n) && (SCHEME_INT_VAL(n) >= 0))

4
src/racket/src/schminc.h
View File

@ -11,9 +11,9 @@
EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP
can be set to 1 again. */ can be set to 1 again. */
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 0
#define EXPECTED_PRIM_COUNT 1033 #define EXPECTED_PRIM_COUNT 1034
#define EXPECTED_UNSAFE_COUNT 78 #define EXPECTED_UNSAFE_COUNT 78
#define EXPECTED_FLFXNUM_COUNT 68 #define EXPECTED_FLFXNUM_COUNT 68
#define EXPECTED_FUTURES_COUNT 11 #define EXPECTED_FUTURES_COUNT 11

5
src/racket/src/schpriv.h
View File

@ -1038,11 +1038,11 @@ Scheme_Object *scheme_stx_property(Scheme_Object *_stx,
Scheme_Object *key, Scheme_Object *key,
Scheme_Object *val); Scheme_Object *val);
Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift, Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, Scheme_Object *shift,
Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry, Scheme_Hash_Table *export_registry,
Scheme_Object *insp); Scheme_Object *insp);
Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *scheme_stx_phase_shift_as_rename(Scheme_Object *shift,
Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry, Scheme_Hash_Table *export_registry,
Scheme_Object *insp); Scheme_Object *insp);
@ -1990,6 +1990,7 @@ Scheme_Object *scheme_make_polar(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_bitwise_shift(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_bitwise_shift(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_bitwise_and(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_bitwise_and(int argc, Scheme_Object *argv[]);
int scheme_exact_p(Scheme_Object *n);
int scheme_nonneg_exact_p(Scheme_Object *n); int scheme_nonneg_exact_p(Scheme_Object *n);
#ifdef TIME_TYPE_IS_UNSIGNED #ifdef TIME_TYPE_IS_UNSIGNED

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.1.3.8" #define MZSCHEME_VERSION "5.1.3.9"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 3 #define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 8 #define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

30
src/racket/src/syntax.c
View File

@ -77,6 +77,8 @@ static Scheme_Object *syntax_property(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv); static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv); static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv);
static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); static Scheme_Object *bound_eq(int argc, Scheme_Object **argv);
static Scheme_Object *module_eq(int argc, Scheme_Object **argv); static Scheme_Object *module_eq(int argc, Scheme_Object **argv);
static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv); static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv);
@ -424,6 +426,7 @@ void scheme_init_stx(Scheme_Env *env)
GLOBAL_IMMED_PRIM("syntax-track-origin" , syntax_track_origin , 3, 3, env); GLOBAL_IMMED_PRIM("syntax-track-origin" , syntax_track_origin , 3, 3, env);
GLOBAL_IMMED_PRIM("make-syntax-delta-introducer" , scheme_syntax_make_transfer_intro, 2, 3, env); GLOBAL_IMMED_PRIM("make-syntax-delta-introducer" , scheme_syntax_make_transfer_intro, 2, 3, env);
GLOBAL_IMMED_PRIM("syntax-shift-phase-level" , syntax_shift_phase , 2, 2, env);
GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 4, env); GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 4, env);
GLOBAL_IMMED_PRIM("free-identifier=?" , module_eq , 2, 4, env); GLOBAL_IMMED_PRIM("free-identifier=?" , module_eq , 2, 4, env);
@ -438,7 +441,6 @@ void scheme_init_stx(Scheme_Env *env)
GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env); GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env);
GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env); GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env);
GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env); GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env);
GLOBAL_FOLDING_PRIM("syntax-tainted?", syntax_tainted_p, 1, 1, 1, env); GLOBAL_FOLDING_PRIM("syntax-tainted?", syntax_tainted_p, 1, 1, 1, env);
@ -2136,15 +2138,18 @@ void scheme_install_free_id_rename(Scheme_Object *id,
} }
} }
Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Object *scheme_stx_phase_shift_as_rename(Scheme_Object *shift, Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry, Scheme_Object *insp) Scheme_Hash_Table *export_registry, Scheme_Object *insp)
{ {
if (shift || new_midx || export_registry || insp) { if (!shift)
shift = scheme_make_integer(0);
if (!SCHEME_INTP(shift) || SCHEME_INT_VAL(shift) || new_midx || export_registry || insp) {
Scheme_Object *vec; Scheme_Object *vec;
if (last_phase_shift if (last_phase_shift
&& ((vec = SCHEME_BOX_VAL(last_phase_shift))) && ((vec = SCHEME_BOX_VAL(last_phase_shift)))
&& (SCHEME_VEC_ELS(vec)[0] == scheme_make_integer(shift)) && (SCHEME_VEC_ELS(vec)[0] == shift)
&& (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false)) && (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false))
&& (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false)) && (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false))
&& (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false)) && (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false))
@ -2152,7 +2157,7 @@ Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *o
/* use the old one */ /* use the old one */
} else { } else {
vec = scheme_make_vector(5, NULL); vec = scheme_make_vector(5, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(shift); SCHEME_VEC_ELS(vec)[0] = shift;
SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false); SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false);
SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false); SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false);
SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false); SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false);
@ -2166,7 +2171,7 @@ Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *o
return NULL; return NULL;
} }
Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift, Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, Scheme_Object *shift,
Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry, Scheme_Hash_Table *export_registry,
Scheme_Object *insp) Scheme_Object *insp)
@ -2183,6 +2188,19 @@ Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift,
return stx; return stx;
} }
static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv)
{
if (!SCHEME_STXP(argv[0]))
scheme_wrong_type("syntax-shift-phase-level", "syntax", 0, argc, argv);
if (!scheme_exact_p(argv[1]))
scheme_wrong_type("syntax-shift-phase-level", "exact integer", 0, argc, argv);
if (SCHEME_INTP(argv[1]) && !SCHEME_INT_VAL(argv[1]))
return argv[0];
return scheme_stx_phase_shift(argv[0], argv[1], NULL, NULL, NULL, NULL);
}
void scheme_clear_shift_cache(void) void scheme_clear_shift_cache(void)
{ {
last_phase_shift = NULL; last_phase_shift = NULL;