From 3a782d01db5c0a536d0c0e2e7e0e0421b3d40ccc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 21 Nov 2016 13:01:27 -0700 Subject: [PATCH] fix interaction of `module->namespace` and `syntax-source-module` An identifier that gets a module context via `module->namespace` plus `namespace-syntax-introduce` should not count as having the module as its source as reported by `syntax-source-module`. The correct behavior happened for the wrong reason prior to commit cb6af9664c. Closes #1515 --- .../racket-test-core/tests/racket/module.rktl | 51 +++++++++++ racket/src/racket/src/compenv.c | 3 +- racket/src/racket/src/env.c | 6 +- racket/src/racket/src/eval.c | 6 +- racket/src/racket/src/module.c | 25 ++++-- racket/src/racket/src/schpriv.h | 6 +- racket/src/racket/src/syntax.c | 86 +++++++++++++------ 7 files changed, 141 insertions(+), 42 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index eab7c529b6..28ffe625c7 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -1854,6 +1854,57 @@ case of module-leve bindings; it doesn't cover local bindings. (and (memq 'p:force (namespace-mapped-symbols)) #t))))) +;; ---------------------------------------- +;; Check that `syntax-source-module` is #f for a top-level evaluation +;; that starts outside of a module: + +(define my-very-own-x 'x) + +(define (make-module-that-has-a-complex-renaming v) + `(module module-that-has-a-complex-renaming racket + ;; this line is necessary, but you can require anything + (require (rename-in racket/base [car prefix:car])) + (module+ sub) + + (define my-very-own-x ,v))) + +(eval (make-module-that-has-a-complex-renaming 10)) +(parameterize ([current-module-declare-name + (make-resolved-module-path 'module-that-has-a-complex-renaming2)]) + (eval (make-module-that-has-a-complex-renaming 11))) + +(require 'module-that-has-a-complex-renaming) +(require 'module-that-has-a-complex-renaming2) +(require (submod 'module-that-has-a-complex-renaming sub)) +(require (submod 'module-that-has-a-complex-renaming2 sub)) + +(parameterize ([current-namespace (module->namespace ''module-that-has-a-complex-renaming)]) + (test #f syntax-source-module (namespace-syntax-introduce #'my-very-own-x)) + (test 10 eval #'my-very-own-x)) + +(parameterize ([current-namespace (module->namespace ''module-that-has-a-complex-renaming2)]) + (test #f syntax-source-module (namespace-syntax-introduce #'my-very-own-x)) + (test 11 eval #'my-very-own-x)) + +(parameterize ([current-namespace (module->namespace '(submod 'module-that-has-a-complex-renaming sub))]) + (test #f syntax-source-module (namespace-syntax-introduce #'my-very-own-x)) + (test 10 eval 'my-very-own-x)) + +(parameterize ([current-namespace (module->namespace '(submod 'module-that-has-a-complex-renaming2 sub))]) + (test #f syntax-source-module (namespace-syntax-introduce #'my-very-own-x)) + (test 11 eval 'my-very-own-x)) + +(module provide-the-x-identifier racket/base + (define x-id #'my-very-own-x) + (provide x-id)) + +(parameterize ([current-namespace (module->namespace ''module-that-has-a-complex-renaming)]) + (test 'provide-the-x-identifier + resolved-module-path-name + (module-path-index-resolve (syntax-source-module + (namespace-syntax-introduce + (dynamic-require ''provide-the-x-identifier 'x-id)))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index ba0c34a7e4..0c679ef521 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -1791,7 +1791,8 @@ Scheme_Hash_Table *scheme_get_binding_names_table(Scheme_Env *env) id = scheme_stx_shift(id, scheme_make_integer(env->phase - env->mod_phase), env->module->self_modidx, env->link_midx, env->module_registry->exports, - env->module->prefix->src_insp_desc, env->access_insp); + env->module->prefix->src_insp_desc, env->access_insp, + 1); binding_names->vals[i] = id; } } diff --git a/racket/src/racket/src/env.c b/racket/src/racket/src/env.c index 78df15e9a7..9e2f1464bc 100644 --- a/racket/src/racket/src/env.c +++ b/racket/src/racket/src/env.c @@ -905,7 +905,8 @@ void scheme_prepare_env_stx_context(Scheme_Env *env) (env->module->prefix ? env->module->prefix->src_insp_desc : env->module->insp), - insp); + insp, + 1); mc = scheme_make_module_context(insp, shift, env->module->modname); } else @@ -1607,7 +1608,8 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, Scheme_Object *val, int as id = scheme_stx_shift(id, scheme_make_integer(env->phase - env->mod_phase), env->module->self_modidx, env->link_midx, env->module_registry->exports, - env->module->prefix->src_insp_desc, env->access_insp); + env->module->prefix->src_insp_desc, env->access_insp, + 1); } scheme_add_module_binding(id, scheme_env_phase(env), diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c index c704dd809d..aaaa3dc799 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -4620,7 +4620,8 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env * scheme_make_integer(shift), orig, modidx, env->module_registry->exports, - NULL, NULL); + NULL, NULL, + 1); SCHEME_VEC_ELS(result)[i] = s; } @@ -6051,7 +6052,8 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, int already_linked, Resolve v = scheme_make_shift(scheme_make_integer(now_phase - src_phase), src_modidx, now_modidx, !already_linked ? genv->module_registry->exports : NULL, - rp->src_insp_desc, insp); + rp->src_insp_desc, insp, + 1); if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) { /* Put lazy-shift info in pf->a[i]: */ Scheme_Object **ls; diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 31b3696db6..997d400829 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -3248,7 +3248,8 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) rn_stx = scheme_stx_force_delayed(rn_stx); rn_stx = scheme_stx_shift(rn_stx, scheme_make_integer(0), midx, m->self_modidx, - NULL, m->prefix->src_insp_desc, menv->access_insp); + NULL, m->prefix->src_insp_desc, menv->access_insp, + 0); m->rn_stx = rn_stx; } else { @@ -6848,6 +6849,15 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, if (!prefix) prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME); + + if (!SCHEME_MODNAMEP(prefix) + && m->rn_stx + && !SAME_OBJ(scheme_true, m->rn_stx) + && (!m->submodule_path || SCHEME_NULLP(m->submodule_path))) { + /* Need a shift to indicate top-levelness in rn_stx (i.e., not a + module source) */ + prefix = m->modname; + } if (SCHEME_MODNAMEP(prefix)) { if (m->submodule_path && !SCHEME_NULLP(m->submodule_path)) { @@ -6857,7 +6867,7 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, } m->modname = prefix; - + if (m->self_modidx) { if (!SCHEME_SYMBOLP(m->self_modidx)) { Scheme_Modidx *midx = (Scheme_Modidx *)m->self_modidx; @@ -6875,7 +6885,7 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, } } } - } else + } else prefix = m->modname; /* used for submodules */ /* printf("declare %s\n", scheme_write_to_string(m->modname, NULL)); */ @@ -7467,7 +7477,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, shift = scheme_make_shift(super_phase_shift, top_env->module->self_modidx, iidx, menv->module_registry->exports, - m->insp, m->insp); + m->insp, m->insp, + 1); super_bxs_info = MALLOC_N(void*, 6); super_bxs_info[0] = super_bxs; @@ -7600,11 +7611,11 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, /* phase shift to replace self_modidx of previous expansion: */ fm = scheme_stx_shift(fm, NULL, this_empty_self_modidx, self_modidx, NULL, - m->insp, m->insp); + m->insp, m->insp, 1); if (m->ii_src) { /* shift the initial import to record the chain for rn_stx */ ii = scheme_stx_shift(m->ii_src, NULL, this_empty_self_modidx, self_modidx, NULL, - m->insp, m->insp); + m->insp, m->insp, 1); m->ii_src = ii; } @@ -7696,7 +7707,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, fm = scheme_datum_to_syntax(fm, form, ctx_form, 0, 2); /* for future expansion, shift away from self_modidx: */ - ps = scheme_make_shift(NULL, self_modidx, this_empty_self_modidx, NULL, NULL, NULL); + ps = scheme_make_shift(NULL, self_modidx, this_empty_self_modidx, NULL, NULL, NULL, 1); fm = scheme_stx_add_shift(fm, ps); if (hints) { diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 62d39bde2e..f78b5dd575 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1319,14 +1319,16 @@ Scheme_Object *scheme_add_frame_intdef_scope(Scheme_Object *frame_scopes, Scheme Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp); + Scheme_Object *src_insp_desc, Scheme_Object *insp, + int counts_as_source); Scheme_Object *scheme_stx_add_shift(Scheme_Object *o, Scheme_Object *shift); Scheme_Object *scheme_stx_add_shifts(Scheme_Object *o, Scheme_Object *shift); Scheme_Object *scheme_stx_shift(Scheme_Object *stx, Scheme_Object *phase_delta, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp); + Scheme_Object *src_insp_desc, Scheme_Object *insp, + int counts_as_source); Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv); int scheme_get_introducer_mode(const char *who, int which, int argc, Scheme_Object **argv); diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index 4711e6a4a8..a4bf08b854 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -1691,7 +1691,8 @@ Scheme_Object *scheme_stx_add_shifts(Scheme_Object *o, Scheme_Object *l) Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp) + Scheme_Object *src_insp_desc, Scheme_Object *insp, + int count_as_source) { Scheme_Object *exr; @@ -1717,7 +1718,8 @@ Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, vec = last_phase_shift; if (vec - && (SCHEME_VEC_ELS(vec)[0] == old_midx) + && (SCHEME_BOXP(SCHEME_VEC_ELS(vec)[0]) == !count_as_source) + && ((count_as_source ? SCHEME_VEC_ELS(vec)[0] : SCHEME_BOX_VAL(SCHEME_VEC_ELS(vec)[0])) == old_midx) && (SCHEME_VEC_ELS(vec)[1] == new_midx) && (SCHEME_VEC_ELS(vec)[2] == src_insp_desc) && (SCHEME_VEC_ELS(vec)[3] == insp) @@ -1726,6 +1728,8 @@ Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, /* use the old one */ } else { vec = scheme_make_vector(6, NULL); + if (!count_as_source) + old_midx = scheme_box(old_midx); SCHEME_VEC_ELS(vec)[0] = old_midx; SCHEME_VEC_ELS(vec)[1] = new_midx; SCHEME_VEC_ELS(vec)[2] = src_insp_desc; @@ -1741,6 +1745,11 @@ Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, return NULL; } +static int non_source_shift(Scheme_Object *vec) +{ + return SCHEME_BOXP(SCHEME_VEC_ELS(vec)[0]); +} + void scheme_clear_shift_cache(void) { int i; @@ -1759,12 +1768,13 @@ Scheme_Object *scheme_stx_shift(Scheme_Object *stx, Scheme_Object *phase_delta, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Hash_Table *export_registry, - Scheme_Object *src_insp_desc, Scheme_Object *insp) + Scheme_Object *src_insp_desc, Scheme_Object *insp, + int counts_as_source) /* Shifts the modidx on a syntax object in a module as well as the phase of scopes. */ { Scheme_Object *s; - s = scheme_make_shift(phase_delta, old_midx, new_midx, export_registry, src_insp_desc, insp); + s = scheme_make_shift(phase_delta, old_midx, new_midx, export_registry, src_insp_desc, insp, counts_as_source); if (s) stx = scheme_stx_add_shift(stx, s); @@ -1772,12 +1782,14 @@ Scheme_Object *scheme_stx_shift(Scheme_Object *stx, } static Scheme_Object *apply_modidx_shifts(Scheme_Object *shifts, Scheme_Object *modidx, - Scheme_Object **_insp, Scheme_Hash_Table **_export_registry) + Scheme_Object **_insp, Scheme_Hash_Table **_export_registry, + int *_any_non_source) { #define QUICK_SHIFT_LEN 5 - Scheme_Object *vec, *dest, *src, *insp_desc; + Scheme_Object *vec, *dest, *src, *insp_desc, *new_modidx; Scheme_Object *quick_a[QUICK_SHIFT_LEN], **a; intptr_t i, len; + int was_boxed; /* Strip away propagation layer, if any: */ if (SCHEME_VECTORP(shifts)) @@ -1796,6 +1808,9 @@ static Scheme_Object *apply_modidx_shifts(Scheme_Object *shifts, Scheme_Object * else a = MALLOC_N(Scheme_Object *, len); + if (_any_non_source) + *_any_non_source = 0; + i = len; while (!SCHEME_NULLP(shifts)) { a[--i] = SCHEME_CAR(shifts); @@ -1811,7 +1826,18 @@ static Scheme_Object *apply_modidx_shifts(Scheme_Object *shifts, Scheme_Object * src = SCHEME_VEC_ELS(vec)[0]; dest = SCHEME_VEC_ELS(vec)[1]; - modidx = scheme_modidx_shift(modidx, src, dest); + if (SCHEME_BOXP(src)) { + src = SCHEME_BOX_VAL(src); + was_boxed = 1; + } else + was_boxed = 0; + + new_modidx = scheme_modidx_shift(modidx, src, dest); + if (_any_non_source + && !SAME_OBJ(new_modidx, modidx) + && was_boxed) + *_any_non_source = 1; + modidx = new_modidx; if (SCHEME_VEC_SIZE(vec) > 2) { if (SCHEME_SYMBOLP(insp_desc) @@ -3166,7 +3192,7 @@ Scheme_Object *add_bindings_info(Scheme_Object *bindings, Scheme_Object *key, Sc val = SCHEME_CAR(val); } if (SCHEME_MODIDXP(val)) - val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); + val = apply_modidx_shifts(stx->shifts, val, NULL, NULL, NULL); bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); } @@ -3295,7 +3321,7 @@ static Scheme_Object *stx_debug_info(Scheme_Stx *stx, Scheme_Object *phase, Sche pes = SCHEME_BINDING_VAL(SCHEME_CAR(l)); val = SCHEME_VEC_ELS(pes)[0]; if (SCHEME_MODIDXP(val)) - val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); + val = apply_modidx_shifts(stx->shifts, val, NULL, NULL, NULL); bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); if (PES_UNMARSHAL_DESCP(pes)) { @@ -3850,10 +3876,10 @@ static Scheme_Object *apply_accumulated_shifts(Scheme_Object *result, Scheme_Obj SCHEME_VEC_ELS(result)[1] = stx->val; for (; !SCHEME_NULLP(prev_shifts); prev_shifts = SCHEME_CDR(prev_shifts)) { - o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), SCHEME_VEC_ELS(result)[0], _insp, NULL); + o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), SCHEME_VEC_ELS(result)[0], _insp, NULL, NULL); SCHEME_VEC_ELS(result)[0] = o; if (nominal_modidx) { - o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), *nominal_modidx, NULL, NULL); + o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), *nominal_modidx, NULL, NULL, NULL); *nominal_modidx = o; } } @@ -4145,11 +4171,11 @@ Scheme_Object *scheme_stx_lookup_w_nominal(Scheme_Object *o, Scheme_Object *phas if (nominal_src_phase && !*nominal_src_phase) *nominal_src_phase = SCHEME_VEC_ELS(result)[2]; - l = apply_modidx_shifts(stx->shifts, SCHEME_VEC_ELS(result)[0], &insp_desc, NULL); + l = apply_modidx_shifts(stx->shifts, SCHEME_VEC_ELS(result)[0], &insp_desc, NULL, NULL); SCHEME_VEC_ELS(result)[0] = l; if (nominal_modidx) { - l = apply_modidx_shifts(stx->shifts, *nominal_modidx, NULL, NULL); + l = apply_modidx_shifts(stx->shifts, *nominal_modidx, NULL, NULL, NULL); *nominal_modidx = l; } } else @@ -4821,9 +4847,9 @@ static void unmarshal_module_context_additions(Scheme_Stx *stx, Scheme_Object *s req_insp = insp; if (stx) - modidx = apply_modidx_shifts(stx->shifts, req_modidx, &insp, &export_registry); + modidx = apply_modidx_shifts(stx->shifts, req_modidx, &insp, &export_registry, NULL); else - modidx = apply_modidx_shifts(shifts, req_modidx, &insp, &export_registry); + modidx = apply_modidx_shifts(shifts, req_modidx, &insp, &export_registry, NULL); src_phase = SCHEME_VEC_ELS(vec)[1]; unmarshal_info = SCHEME_VEC_ELS(vec)[2]; @@ -5133,33 +5159,37 @@ Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int sou /* Look for the oldest "self" modidx that has a resolution: */ Scheme_Object *l = ((Scheme_Stx *)stx)->shifts, *a, *src; Scheme_Hash_Table *export_registry; + int any_non_source; if (SCHEME_VECTORP(l)) l = SCHEME_VEC_ELS(l)[0]; l = scheme_reverse(l); - + while (!SCHEME_NULLP(l)) { a = SCHEME_CAR(l); - if (SCHEME_VECTORP(a)) { + if (SCHEME_VECTORP(a) && !non_source_shift(a)) { src = SCHEME_VEC_ELS(a)[1]; if (SCHEME_MODIDXP(src)) { if (SCHEME_FALSEP(((Scheme_Modidx *)src)->path)) { src = apply_modidx_shifts(((Scheme_Stx *)stx)->shifts, src, - NULL, &export_registry); - if (!SCHEME_FALSEP(((Scheme_Modidx *)src)->path) - || !SCHEME_FALSEP(((Scheme_Modidx *)src)->resolved)) { - if (resolve) { - src = scheme_module_resolve(src, 0); - if (export_registry && source) { - a = scheme_hash_get(export_registry, src); - if (a) - src = ((Scheme_Module_Exports *)a)->modsrc; + NULL, &export_registry, + &any_non_source); + if (!any_non_source) { + if (!SCHEME_FALSEP(((Scheme_Modidx *)src)->path) + || !SCHEME_FALSEP(((Scheme_Modidx *)src)->resolved)) { + if (resolve) { + src = scheme_module_resolve(src, 0); + if (export_registry && source) { + a = scheme_hash_get(export_registry, src); + if (a) + src = ((Scheme_Module_Exports *)a)->modsrc; + } + src = SCHEME_PTR_VAL(src); } - src = SCHEME_PTR_VAL(src); + return src; } - return src; } } }