diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl index d5b5e33507..2ebaa5a9cb 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl @@ -1034,14 +1034,15 @@ (with-syntax ([id (syntax-local-lift-expression #'(set! lifted-output "lifted!"))]) #'(list lifted-output id))])) -(test (list #f 2) '@@foo (@@foo 2)) -(test (list #f 2) eval-syntax #'(@@foo 2)) -(test (list #f 2) eval (expand-once #'(@@foo 2))) -(test (list #f 2) eval (expand-syntax-once #'(@@foo 2))) -(test (list #f 2) eval (expand #'(@@foo 2))) -(test (list #f 2) eval (expand-syntax #'(@@foo 2))) -(test (list #f 2) eval (expand-to-top-form #'(@@foo 2))) -(test (list #f 2) eval (expand-syntax-to-top-form #'(@@foo 2))) +(let ([res (@@foo 2)]) + (test res '@@foo (@@foo 2)) + (test res eval-syntax #'(@@foo 2)) + (test res eval (expand-once #'(@@foo 2))) + (test res eval (expand-syntax-once #'(@@foo 2))) + (test res eval (expand #'(@@foo 2))) + (test res eval (expand-syntax #'(@@foo 2))) + (test res eval (expand-to-top-form #'(@@foo 2))) + (test res eval (expand-syntax-to-top-form #'(@@foo 2)))) (test (list "lifted!" (void)) '@@goo (@@goo)) (set! lifted-output #f) (test (list "lifted!" (void)) eval (expand-once #'(@@goo))) @@ -1148,14 +1149,43 @@ (mk null) (mk #f)))) -(test '(#f 1) 'let-foo (let ([x 5]) (@@foo 1))) -(test '(#f 1) eval (expand #'(let ([x 5]) (@@foo 1)))) +(let ([res (let ([x 5]) (@@foo 1))]) + (test res 'let-foo (let ([x 5]) (@@foo 1))) + (test res eval (expand #'(let ([x 5]) (@@foo 1))))) (test '(the-key 1) 'local-foo (let ([x 5]) (@@local-top (@@foo 1)))) (test '(the-key 1) eval (expand #'(let ([x 5]) (@@local-top (@@foo 1))))) (test '(the-key 1) eval (expand #'(@@local-top (@@foo 1)))) (test '(the-key 1) eval (expand #'(@@local-top2 (@@foo 1)))) (test '(the-key 1) eval (expand #'(@@local-top3 (@@foo 1)))) +;; Check for distinct top-level contexts for different namespaces: +(module example-that-uses-the-lift-context racket/base + (require (for-syntax racket/base)) + (provide m) + (define-for-syntax ht (make-hash)) + (define-syntax (m stx) + (or (hash-ref ht (syntax-local-lift-context) #f) + (let ([id (syntax-local-lift-expression #`(quote #,(current-inexact-milliseconds)))]) + (hash-set! ht (syntax-local-lift-context) id) + id)))) +(dynamic-require ''example-that-uses-the-lift-context 0) +(let ([go + (lambda () + (define orig-ns (current-namespace)) + (parameterize ([current-namespace (make-base-namespace)]) + (namespace-attach-module orig-ns ''example-that-uses-the-lift-context) + (namespace-require ''example-that-uses-the-lift-context) + (test (eval 'm) eval 'm) + (eval '(module extra-module racket/base + (require 'example-that-uses-the-lift-context))) + (dynamic-require ''extra-module 0) + (let ([ns (module->namespace ''extra-module)]) + (test (eval 'm ns) eval 'm ns) + (test #f = (eval 'm) (eval 'm ns)))))]) + (go) + (go) + (go)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check interaction of macro-introduced/lifted names and ;; module->namespace diff --git a/racket/src/racket/src/compile.c b/racket/src/racket/src/compile.c index e0a263a158..50c41548b4 100644 --- a/racket/src/racket/src/compile.c +++ b/racket/src/racket/src/compile.c @@ -3394,7 +3394,7 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem while (1) { scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), - scheme_false, scheme_false, scheme_null, scheme_false); + scheme_false, scheme_top_level_lifts_key(env), scheme_null, scheme_false); if (rec[drec].comp) { scheme_init_compile_recs(rec, drec, recs, 1); diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index 653d601f30..7aea71dcec 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -3967,7 +3967,7 @@ static void *compile_k(void) before the rest. */ while (1) { scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), - scheme_false, scheme_false, scheme_null, scheme_false); + scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false); form = scheme_check_immediate_macro(form, cenv, &rec, 0, 0, &gval, NULL, NULL); @@ -4009,7 +4009,7 @@ static void *compile_k(void) while (1) { scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), - scheme_false, scheme_false, scheme_null, scheme_false); + scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false); scheme_init_compile_recs(&rec, 0, &rec2, 1); @@ -4406,6 +4406,9 @@ static void *expand_k(void) p->ku.k.p3 = NULL; p->ku.k.p4 = NULL; + if (SCHEME_FALSEP(catch_lifts_key)) + catch_lifts_key = scheme_top_level_lifts_key(env); + if (!SCHEME_STXP(obj)) obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0); @@ -4510,7 +4513,7 @@ static Scheme_Object *r_expand(Scheme_Object *obj, Scheme_Comp_Env *env, Scheme_Object *scheme_expand(Scheme_Object *obj, Scheme_Env *env) { return r_expand(obj, scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), - -1, 1, 0, scheme_true, -1, 0); + -1, 1, 0, scheme_false, -1, 0); } Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj) @@ -4707,6 +4710,16 @@ Scheme_Object *scheme_generate_lifts_key(void) return scheme_make_symbol(buf); /* uninterned */ } +Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env) +{ + if (!env->genv->lift_key) { + Scheme_Object *o; + o = scheme_generate_lifts_key(); + env->genv->lift_key = o; + } + return env->genv->lift_key; +} + Scheme_Object * scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env) { @@ -4996,7 +5009,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in scheme_frame_captures_lifts(env, (catch_lifts < 0) ? scheme_pair_lifted : scheme_make_lifted_defn, data, - scheme_false, + scheme_top_level_lifts_key(env), catch_lifts_key, NULL, scheme_false); } diff --git a/racket/src/racket/src/mzmark_type.inc b/racket/src/racket/src/mzmark_type.inc index 14651c05e7..a77a5115ae 100644 --- a/racket/src/racket/src/mzmark_type.inc +++ b/racket/src/racket/src/mzmark_type.inc @@ -2286,6 +2286,8 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) { gcMARK2(e->shadowed_syntax, gc); + gcMARK2(e->lift_key, gc); + gcMARK2(e->link_midx, gc); gcMARK2(e->require_names, gc); gcMARK2(e->et_require_names, gc); @@ -2329,6 +2331,8 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(e->shadowed_syntax, gc); + gcFIXUP2(e->lift_key, gc); + gcFIXUP2(e->link_midx, gc); gcFIXUP2(e->require_names, gc); gcFIXUP2(e->et_require_names, gc); diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 3c0740912e..ba7a1f0bcb 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -925,6 +925,8 @@ namespace_val { gcMARK2(e->shadowed_syntax, gc); + gcMARK2(e->lift_key, gc); + gcMARK2(e->link_midx, gc); gcMARK2(e->require_names, gc); gcMARK2(e->et_require_names, gc); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 39058ac5d3..28937647ca 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -2744,6 +2744,7 @@ Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env); Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env); Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env); Scheme_Object *scheme_generate_lifts_key(void); +Scheme_Object *scheme_top_level_lifts_key(Scheme_Comp_Env *env); Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, intptr_t phase, @@ -3248,6 +3249,8 @@ struct Scheme_Env { Scheme_Hash_Table *shadowed_syntax; /* top level only */ + Scheme_Object *lift_key; /* for `syntax-local-lift-context' */ + /* Per-instance: */ intptr_t phase, mod_phase; Scheme_Object *link_midx;