diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index 4e8728c243..9648455c33 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -533,7 +533,7 @@ profile todo: ;; a member of stacktrace-imports^ ;; guarantees that the continuation marks associated with errortrace-key are ;; 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 [(path? (syntax-source src-stx)) (syntax-source src-stx)] @@ -557,11 +557,13 @@ profile todo: (if source (with-syntax ([expr expr] [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 - (with-continuation-mark 'errortrace-key - 'mark - expr))) + (wcm (qte errortrace-key) + (qte mark) + expr))) expr))) ;; current-backtrace-window : (union #f (instanceof frame:basic<%>)) diff --git a/collects/errortrace/errortrace-key-syntax.rkt b/collects/errortrace/errortrace-key-syntax.rkt deleted file mode 100644 index ee59a3969e..0000000000 --- a/collects/errortrace/errortrace-key-syntax.rkt +++ /dev/null @@ -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)) diff --git a/collects/errortrace/errortrace-lib.rkt b/collects/errortrace/errortrace-lib.rkt index 4cbd43803a..7a7efd7b5a 100644 --- a/collects/errortrace/errortrace-lib.rkt +++ b/collects/errortrace/errortrace-lib.rkt @@ -5,6 +5,7 @@ (require "stacktrace.rkt" "errortrace-key.rkt" + "private/utils.rkt" racket/contract racket/unit racket/runtime-path @@ -198,25 +199,23 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Stacktrace instrumenter -(define-runtime-path key-syntax - '(lib "errortrace-key-syntax.rkt" "errortrace")) - -(define dynamic-errortrace-key - (dynamic-require key-syntax 'errortrace-key-syntax)) +(define base-phase + (variable-reference->module-base-phase (#%variable-reference))) ;; with-mark : stx stx -> stx -(define (with-mark mark expr) - (let ([loc (make-st-mark mark)]) +(define (with-mark mark expr phase) + (let ([loc (make-st-mark mark phase)]) (if loc (with-syntax ([expr expr] [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 mark (syntax - (with-continuation-mark et-key - loc - expr)))) + (wcm et-key + loc + expr)))) expr))) (define-values/invoke-unit/infer stacktrace@) @@ -415,21 +414,17 @@ [(mod name init-import mb) (syntax-case (disarm #'mb) (#%plain-module-begin) [(#%plain-module-begin body ...) - (add-test-coverage-init-code - (normal - (copy-props - top-e - #`(#,(namespace-module-identifier) name init-import - #,(syntax-rearm - #`(#%plain-module-begin - #,((make-syntax-introducer) - (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 ...) - #'mb)))))])])))] + (let ([meta-depth ((count-meta-levels 0) #'(begin body ...))]) + (add-test-coverage-init-code + (normal + (copy-props + top-e + #`(#,(namespace-module-identifier) name init-import + #,(syntax-rearm + #`(#%plain-module-begin + #,(generate-key-imports meta-depth) + body ...) + #'mb))))))])])))] [_else (normal top-e)]))) diff --git a/collects/errortrace/lang/body.rkt b/collects/errortrace/lang/body.rkt index a794663681..b610ef9b00 100644 --- a/collects/errortrace/lang/body.rkt +++ b/collects/errortrace/lang/body.rkt @@ -1,7 +1,9 @@ #lang racket/base (require (for-syntax racket/base syntax/strip-context - "../errortrace-lib.rkt")) + racket/pretty + "../errortrace-lib.rkt" + "../private/utils.rkt")) (provide (rename-out [module-begin #%module-begin])) @@ -9,13 +11,15 @@ (syntax-case stx () [(_ lang . body) (let ([e (annotate-top - (syntax-local-introduce + (values ; syntax-local-introduce (local-expand #`(module . #,(strip-context #`(n lang . body))) 'top-level null)) 0)]) + (collect-garbage) (syntax-case e () [(mod nm lang (mb . body)) #`(#%plain-module-begin - (require (only-in lang) errortrace/errortrace-key) + (require (only-in lang)) + #,(generate-key-imports ((count-meta-levels 0) #'(begin . body))) . body)]))])) diff --git a/collects/errortrace/private/utils.rkt b/collects/errortrace/private/utils.rkt new file mode 100644 index 0000000000..dbd6a80846 --- /dev/null +++ b/collects/errortrace/private/utils.rkt @@ -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))) diff --git a/collects/errortrace/scribblings/errortrace.scrbl b/collects/errortrace/scribblings/errortrace.scrbl index a09da34c80..4efde7d5eb 100644 --- a/collects/errortrace/scribblings/errortrace.scrbl +++ b/collects/errortrace/scribblings/errortrace.scrbl @@ -45,7 +45,7 @@ Then, ] 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. 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 source. Using the @racketmodname[errortrace] meta-language is one way 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^ ()]{ @deftogether[( - @defproc[(annotate (stx syntax?) (phase-level exact-integer?)) syntax?] - @defproc[(annotate-top (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-nonnegative-integer?)) syntax?])]{ Annotate expressions with errortrace information. The @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.} @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-bindings (st-mark st-mark?)) list?])]{ @@ -406,12 +406,15 @@ hardwired to return @racket[null]. } @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 expressions with @racket[with-continuation-mark]. The first argument -is the source expression and the second argument is the expression to -be wrapped.} +is the source expression, the second argument is the expression to +be wrapped, and the last is the phase level of the expression.} @defboolparam[test-coverage-enabled on?]{ diff --git a/collects/errortrace/stacktrace.rkt b/collects/errortrace/stacktrace.rkt index 3db268756b..17dc627564 100644 --- a/collects/errortrace/stacktrace.rkt +++ b/collects/errortrace/stacktrace.rkt @@ -52,19 +52,21 @@ [(syntax? v) (short-version (syntax-e v) depth)] [else v])) - (define (make-st-mark stx) + (define (make-st-mark stx phase) (unless (syntax? stx) (error 'make-st-mark "expected syntax object as argument, got ~e" stx)) (cond [(syntax-source stx) - #`(quote (#,(short-version stx 10) - #,(syntax-source stx) - #,(syntax-line stx) - #,(syntax-column stx) - #,(syntax-position stx) - #,(syntax-span stx)))] + (with-syntax ([quote (syntax-shift-phase-level #'quote phase)]) + #`(quote (#,(short-version stx 10) + #,(syntax-source stx) + #,(syntax-line stx) + #,(syntax-column stx) + #,(syntax-position stx) + #,(syntax-span stx))))] [else #f])) + (define (st-mark-source src) (and src (datum->syntax #f (car src) (cdr src) #f))) @@ -309,6 +311,8 @@ (define (make-annotate top? name) (lambda (expr phase) (define disarmed-expr (disarm expr)) + (define (with-mrk* mark expr) + (with-mark mark expr phase)) (test-coverage-point (kernel-syntax-case/phase disarmed-expr phase [_ @@ -324,11 +328,11 @@ expr] [else ;; might be undefined/uninitialized - (with-mark expr expr)]))] + (with-mrk* expr expr)]))] [(#%top . id) ;; might be undefined/uninitialized - (with-mark expr expr)] + (with-mrk* expr expr)] [(#%variable-reference . _) ;; no error possible expr] @@ -337,7 +341,7 @@ top? ;; Can't put annotation on the outside (let* ([marked - (with-mark expr + (with-mrk* expr (annotate-named (one-name #'names) (syntax rhs) @@ -372,7 +376,8 @@ (annotate-named (one-name #'(name ...)) (syntax rhs) - (add1 phase)))]) + (add1 phase)) + (add1 phase))]) (rearm expr (rebuild disarmed-expr (list (cons #'rhs marked)))))] @@ -446,7 +451,7 @@ ;; Wrap RHSs and body [(let-values ([vars rhs] ...) . body) - (with-mark expr + (with-mrk* expr (rearm expr (annotate-let disarmed-expr phase @@ -466,7 +471,7 @@ (free-identifier=? #'var1 #'var2)) fm] [_ - (with-mark expr fm)]))] + (with-mrk* expr fm)]))] ;; This case is needed for `#lang errortrace ...', which uses ;; `local-expand' on the module body. [(letrec-syntaxes+values sbindings ([vars rhs] ...) . body) @@ -476,7 +481,7 @@ (syntax (vars ...)) (syntax (rhs ...)) (syntax body)))]) - (with-mark expr fm))] + (with-mrk* expr fm))] ;; Wrap RHS [(set! var rhs) @@ -485,7 +490,7 @@ (syntax rhs) phase)]) ;; set! might fail on undefined variable, or too many values: - (with-mark expr + (with-mrk* expr (rearm expr (rebuild disarmed-expr (list (cons #'rhs new-rhs))))))] @@ -497,12 +502,12 @@ expr #`(begin #,(annotate (syntax e) phase)))] [(begin . body) - (with-mark expr + (with-mrk* expr (rearm expr (annotate-seq disarmed-expr #'body annotate phase)))] [(begin0 . body) - (with-mark expr + (with-mrk* expr (rearm expr (annotate-seq disarmed-expr #'body annotate phase)))] @@ -510,7 +515,7 @@ (let ([w-tst (annotate (syntax tst) phase)] [w-thn (annotate (syntax thn) phase)] [w-els (annotate (syntax els) phase)]) - (with-mark expr + (with-mrk* expr (rearm expr (rebuild disarmed-expr (list (cons #'tst w-tst) @@ -519,13 +524,13 @@ [(if tst thn) (let ([w-tst (annotate (syntax tst) phase)] [w-thn (annotate (syntax thn) phase)]) - (with-mark expr + (with-mrk* expr (rearm expr (rebuild disarmed-expr (list (cons #'tst w-tst) (cons #'thn w-thn))))))] [(with-continuation-mark . body) - (with-mark expr + (with-mrk* expr (rearm expr (annotate-seq disarmed-expr (syntax body) @@ -546,7 +551,7 @@ ;; It's (void): expr] [else - (with-mark expr (rearm + (with-mrk* expr (rearm expr (annotate-seq disarmed-expr (syntax body) annotate phase)))])] diff --git a/collects/racket/private/sandbox-coverage.rkt b/collects/racket/private/sandbox-coverage.rkt index 9c121ecd25..57aa2f5d77 100644 --- a/collects/racket/private/sandbox-coverage.rkt +++ b/collects/racket/private/sandbox-coverage.rkt @@ -50,7 +50,7 @@ (define register-profile-start void) (define register-profile-done void) ;; no marks -(define (with-mark mark expr) expr) +(define (with-mark mark expr phase) expr) (define-values/invoke-unit/infer stacktrace@) diff --git a/collects/scribblings/reference/stx-ops.scrbl b/collects/scribblings/reference/stx-ops.scrbl index d3431d3ddb..11fdb79f78 100644 --- a/collects/scribblings/reference/stx-ops.scrbl +++ b/collects/scribblings/reference/stx-ops.scrbl @@ -3,11 +3,19 @@ @title[#:tag "stxops"]{Syntax Object Content} + @defproc[(syntax? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is a @tech{syntax object}, @racket[#f] 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]{ 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.} -@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 -@racket[(syntax-e stx)] produces a symbol.} +Returns a syntax object that is like @racket[stx], but with all of its +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?)]) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 9f1649fb30..fa3803336e 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -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 Generalized begin-with-syntax to allow phase-N definitions, both variable and syntax, within a module for all N >= 0; diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index ce55af4112..e532f1caec 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -3600,7 +3600,7 @@ static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env if (genv->rename_set) { form = scheme_add_rename(form, genv->rename_set); /* this "phase shift" just attaches the namespace's module registry: */ - form = scheme_stx_phase_shift(form, 0, NULL, NULL, genv->module_registry->exports, NULL); + form = scheme_stx_phase_shift(form, NULL, NULL, NULL, genv->module_registry->exports, NULL); } return form; @@ -3674,7 +3674,7 @@ static void *compile_k(void) if (rename) { form = add_renames_unless_module(form, genv); if (genv->module) { - form = scheme_stx_phase_shift(form, 0, + form = scheme_stx_phase_shift(form, NULL, genv->module->me->src_modidx, genv->module->self_modidx, 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); 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); 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)) insp = scheme_get_current_inspector(); 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, insp); if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) { diff --git a/src/racket/src/module.c b/src/racket/src/module.c index a90271aab6..f49af35900 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -4535,10 +4535,15 @@ static void should_run_for_compile(Scheme_Env *menv, int phase) { if (menv->running[phase]) return; - while (phase > 1) { - scheme_prepare_exp_env(menv); - menv = menv->exp_env; - phase--; + if (!phase) { + scheme_prepare_template_env(menv); + menv = menv->template_env; + } else { + while (phase > 1) { + scheme_prepare_exp_env(menv); + menv = menv->exp_env; + phase--; + } } #if 0 @@ -4546,15 +4551,10 @@ static void should_run_for_compile(Scheme_Env *menv, int phase) scheme_signal_error("internal error: inconsistent instance_env"); #endif - if (!menv->available_next[0]) { menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0); 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, @@ -4704,13 +4704,6 @@ void scheme_prepare_compile_env(Scheme_Env *env) that env->phase is visited. */ { 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) @@ -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)); /* 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); @@ -5852,7 +5845,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, } /* 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 */ ((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) { 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; e = scheme_expand_expr(e, nenv, &erec1, 0); 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, int phase) /* 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' are matched up by order. */ { @@ -7325,11 +7318,12 @@ static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l, e = SCHEME_CAR(p); if (SCHEME_STX_PAIRP(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); 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_copy_list(l); expanded_provides = fixup_expanded_provides(SCHEME_CDR(l), expanded_provides, phase + 1); e = scheme_datum_to_syntax(l, e, e, 0, 2); SCHEME_CAR(p) = e; diff --git a/src/racket/src/number.c b/src/racket/src/number.c index e973ca60e4..ce387bc2d5 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -1110,6 +1110,11 @@ int scheme_get_unsigned_long_long_val(Scheme_Object *o, umzlonglong *v) return 0; } +int scheme_exact_p(Scheme_Object *n) +{ + return (SCHEME_INTP(n) || SCHEME_BIGNUMP(n)); +} + int scheme_nonneg_exact_p(Scheme_Object *n) { return ((SCHEME_INTP(n) && (SCHEME_INT_VAL(n) >= 0)) diff --git a/src/racket/src/schminc.h b/src/racket/src/schminc.h index 34684a62a3..886075060c 100644 --- a/src/racket/src/schminc.h +++ b/src/racket/src/schminc.h @@ -11,9 +11,9 @@ EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP 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_FLFXNUM_COUNT 68 #define EXPECTED_FUTURES_COUNT 11 diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 23af9c5760..c865073aa7 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -1038,11 +1038,11 @@ Scheme_Object *scheme_stx_property(Scheme_Object *_stx, Scheme_Object *key, 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_Hash_Table *export_registry, 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_Hash_Table *export_registry, 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_and(int argc, Scheme_Object *argv[]); +int scheme_exact_p(Scheme_Object *n); int scheme_nonneg_exact_p(Scheme_Object *n); #ifdef TIME_TYPE_IS_UNSIGNED diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index 9b48cd9733..ee71c04ebb 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.1.3.8" +#define MZSCHEME_VERSION "5.1.3.9" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 1 #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_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index f43998f8b6..0da57dde64 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -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_track_origin(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv); + static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); static Scheme_Object *module_eq(int argc, Scheme_Object **argv); static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv); @@ -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("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("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-to-source-module", identifier_prune_to_module, 1, 1, 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); @@ -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) { - 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; if (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)[2] == (new_midx ? new_midx : 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 */ } else { 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)[2] = (new_midx ? new_midx : 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; } -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_Hash_Table *export_registry, Scheme_Object *insp) @@ -2183,6 +2188,19 @@ Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift, 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) { last_phase_shift = NULL;