diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index f434d05209..5cce96d9e6 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -2057,6 +2057,7 @@ ;; In `ns1`, `cons` refers to `add1` ;; In `ns2`, `cons` refers to `cons` (define cons-id/ns1 (eval '(quote-syntax cons) ns1)) + (test add1 eval cons-id/ns1 ns1) (test add1 eval cons-id/ns1 ns2) (eval `(define ,cons-id/ns1 1) ns2) (test 1 eval cons-id/ns1 ns2) @@ -2190,4 +2191,19 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(parameterize ([current-namespace (make-base-namespace)]) + (eval '(require (for-syntax racket/base))) + (eval + '(define-syntax (m stx) + (define x (car (generate-temporaries '(1)))) + (syntax-case stx () + [(_ lib name) + #`(begin (require (only-in lib [name #,x])) + (define-syntax name + (make-rename-transformer (quote-syntax #,x))) + name)]))) + (eval '(m racket/base values))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (report-errs) diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 40ab74d22c..c0a2ee8718 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -12513,7 +12513,7 @@ do_require_execute(Scheme_Env *env, Scheme_Object *form) Scheme_Object *modidx; /* Use the current top-level context: */ - form = scheme_stx_add_module_context(form, env->stx_context); + form = scheme_stx_from_generic_to_module_context(form, env->stx_context); /* Check for collisions again, in case there's a difference between compile and run times: */ @@ -12559,7 +12559,7 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env, if (rec && rec[drec].comp) { /* Remove all context specific to the compile-time environment: */ - form = scheme_stx_remove_module_context(form, env->genv->stx_context); + form = scheme_stx_from_module_context_to_generic(form, env->genv->stx_context); /* Dummy lets us access a top-level environment: */ dummy = scheme_make_environment_dummy(env); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index cfbd1fa113..3298dc2041 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1223,6 +1223,9 @@ Scheme_Object *scheme_stx_unintroduce_from_module_context(Scheme_Object *stx, Sc Scheme_Object *scheme_stx_push_module_context(Scheme_Object *stx, Scheme_Object *mc); Scheme_Object *scheme_stx_push_introduce_module_context(Scheme_Object *stx, Scheme_Object *mc); +Scheme_Object *scheme_stx_from_module_context_to_generic(Scheme_Object *stx, Scheme_Object *mc); +Scheme_Object *scheme_stx_from_generic_to_module_context(Scheme_Object *stx, Scheme_Object *mc); + Scheme_Object *scheme_module_context_to_stx(Scheme_Object *mc, Scheme_Object *orig_src); Scheme_Object *scheme_stx_to_module_context(Scheme_Object *stx); diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index 495c9c8a49..dc318d5a4d 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -1199,6 +1199,9 @@ static Scheme_Object *stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scop Scheme_Object *key, *val; intptr_t i; + STX_ASSERT(SCHEME_STXP(o)); + STX_ASSERT(SCHEME_SCOPE_SETP(scopes)); + i = scope_set_next(scopes, -1); while (i != -1) { scope_set_index(scopes, i, &key, &val); @@ -4335,6 +4338,108 @@ Scheme_Object *scheme_stx_adjust_module_use_site_context(Scheme_Object *stx, Sch return scheme_stx_adjust_scopes(stx, scopes, SCHEME_VEC_ELS(mc)[1], mode); } +#ifdef DO_STACK_CHECK +static Scheme_Object *replace_scopes(Scheme_Object *stx, Scheme_Object *remove_scopes, + Scheme_Object *add_scopes, Scheme_Object *phase); + +static Scheme_Object *replace_scopes_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *stx = (Scheme_Object *)p->ku.k.p1; + Scheme_Object *remove_scopes = (Scheme_Object *)p->ku.k.p2; + Scheme_Object *add_scopes = (Scheme_Object *)p->ku.k.p3; + Scheme_Object *phase = (Scheme_Object *)p->ku.k.p4; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + p->ku.k.p4 = NULL; + + return replace_scopes(stx, remove_scopes, add_scopes, phase); +} +#endif + +static Scheme_Object *replace_scopes(Scheme_Object *stx, Scheme_Object *remove_scopes, + Scheme_Object *add_scopes, Scheme_Object *phase) +{ + Scheme_Object *sym, *sym2, *content; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + + p->ku.k.p1 = (void *)stx; + p->ku.k.p2 = (void *)remove_scopes; + p->ku.k.p3 = (void *)add_scopes; + p->ku.k.p4 = (void *)phase; + + return scheme_handle_stack_overflow(replace_scopes_k); + } + } +#endif + + if (SCHEME_STXP(stx)) { + int mutate = 0; + + scheme_stx_content(stx); + if (HAS_SUBSTX(SCHEME_STX_VAL(stx))) { + content = replace_scopes(SCHEME_STX_VAL(stx), remove_scopes, add_scopes, phase); + sym = scheme_datum_to_syntax(scheme_false, scheme_false, stx, 0, 0); + } else { + sym = stx; + content = SCHEME_STX_VAL(stx); + } + + if (SCHEME_SCOPEP(remove_scopes) || SCHEME_MULTI_SCOPEP(remove_scopes)) + sym2 = stx_adjust_scope(sym, remove_scopes, phase, SCHEME_STX_REMOVE, &mutate); + else + sym2 = stx_adjust_scopes(sym, (Scheme_Scope_Set *)remove_scopes, phase, SCHEME_STX_REMOVE, &mutate); + + if (!SAME_OBJ(sym, sym2) || !SAME_OBJ(content, SCHEME_STX_VAL(stx))) { + if (SCHEME_SCOPEP(add_scopes) || SCHEME_MULTI_SCOPEP(add_scopes)) + sym2 = stx_adjust_scope(sym2, add_scopes, phase, SCHEME_STX_ADD, &mutate); + else + sym2 = stx_adjust_scopes(sym2, (Scheme_Scope_Set *)add_scopes, phase, SCHEME_STX_ADD, &mutate); + return scheme_datum_to_syntax(content, stx, sym2, 0, 2); + } else + return stx; + } else if (SCHEME_NULLP(stx)) { + return stx; + } else if (SCHEME_PAIRP(stx)) { + sym = replace_scopes(SCHEME_CAR(stx), remove_scopes, add_scopes, phase); + sym2 = replace_scopes(SCHEME_CDR(stx), remove_scopes, add_scopes, phase); + if (SAME_OBJ(sym, SCHEME_CAR(stx)) && SAME_OBJ(sym2, SCHEME_CDR(stx))) + return stx; + else + return scheme_make_pair(sym, sym2); + } else { + scheme_signal_error("internal error: unsupported form for replace_scopes()"); + return NULL; + } +} + +Scheme_Object *scheme_stx_from_module_context_to_generic(Scheme_Object *stx, Scheme_Object *mc) +{ + /* remove the introduction scope, which should be everywhere, and + map the other scopes to the root scope */ + Scheme_Object *scopes; + stx = scheme_stx_remove_scope(stx, SCHEME_VEC_ELS(mc)[4], SCHEME_VEC_ELS(mc)[1]); + scopes = (Scheme_Object *)scheme_module_context_scopes(mc); + return replace_scopes(stx, scopes, root_scope, SCHEME_VEC_ELS(mc)[1]); +} + +Scheme_Object *scheme_stx_from_generic_to_module_context(Scheme_Object *stx, Scheme_Object *mc) +{ + /* map the root scope to the body scope, and add the introduction + scope everywhere */ + Scheme_Object *scopes; + scopes = (Scheme_Object *)scheme_module_context_scopes(mc); + stx = replace_scopes(stx, root_scope, scopes, SCHEME_VEC_ELS(mc)[1]); + return scheme_stx_introduce_to_module_context(stx, mc); +} + void scheme_extend_module_context(Scheme_Object *mc, /* (vector ...) */ Scheme_Object *ctx, /* binding context (as stx) or NULL */ Scheme_Object *modidx, /* actual source module */