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

fix interaction of module->namespace and syntax-source-module

Browse Source 
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
This commit is contained in:
Matthew Flatt 2016-11-21 13:01:27 -07:00
parent 87161fc5f3
commit 3a782d01db
7 changed files with 141 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -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)

3
racket/src/racket/src/compenv.c
View File

@ -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;
}
}

6
racket/src/racket/src/env.c
View File

@ -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),

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

@ -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;

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

@ -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) {

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

@ -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);

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

@ -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;
}
}
}