From 201d3760b79b313d8334c0c9d208734c0ddf3f70 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 21 Nov 2016 20:39:05 -0700 Subject: [PATCH] fix `syntax-source-module` repair Try again on 3a782d01db, which broke contract tests by mangling the module path index attached to a module. --- 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 | 118 ++++++++++++++++++-------------- 6 files changed, 82 insertions(+), 82 deletions(-) diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index 0c679ef521..ba0c34a7e4 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -1791,8 +1791,7 @@ 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, - 1); + env->module->prefix->src_insp_desc, env->access_insp); binding_names->vals[i] = id; } } diff --git a/racket/src/racket/src/env.c b/racket/src/racket/src/env.c index 9e2f1464bc..78df15e9a7 100644 --- a/racket/src/racket/src/env.c +++ b/racket/src/racket/src/env.c @@ -905,8 +905,7 @@ void scheme_prepare_env_stx_context(Scheme_Env *env) (env->module->prefix ? env->module->prefix->src_insp_desc : env->module->insp), - insp, - 1); + insp); mc = scheme_make_module_context(insp, shift, env->module->modname); } else @@ -1608,8 +1607,7 @@ 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, - 1); + env->module->prefix->src_insp_desc, env->access_insp); } 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 aaaa3dc799..c704dd809d 100644 --- a/racket/src/racket/src/eval.c +++ b/racket/src/racket/src/eval.c @@ -4620,8 +4620,7 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env * scheme_make_integer(shift), orig, modidx, env->module_registry->exports, - NULL, NULL, - 1); + NULL, NULL); SCHEME_VEC_ELS(result)[i] = s; } @@ -6052,8 +6051,7 @@ 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, - 1); + rp->src_insp_desc, insp); 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 997d400829..17d3e7dac8 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -3246,10 +3246,9 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) midx = SCHEME_CDR(m->rn_stx); 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, - 0); + NULL, m->prefix->src_insp_desc, menv->access_insp); m->rn_stx = rn_stx; } else { @@ -6849,15 +6848,6 @@ 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)) { @@ -6885,7 +6875,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)); */ @@ -7477,8 +7467,7 @@ 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, - 1); + m->insp, m->insp); super_bxs_info = MALLOC_N(void*, 6); super_bxs_info[0] = super_bxs; @@ -7611,11 +7600,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, 1); + m->insp, m->insp); 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, 1); + m->insp, m->insp); m->ii_src = ii; } @@ -7707,7 +7696,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, 1); + ps = scheme_make_shift(NULL, self_modidx, this_empty_self_modidx, NULL, NULL, NULL); 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 f78b5dd575..62d39bde2e 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -1319,16 +1319,14 @@ 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, - int counts_as_source); + Scheme_Object *src_insp_desc, Scheme_Object *insp); 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, - int counts_as_source); + Scheme_Object *src_insp_desc, Scheme_Object *insp); 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 a4bf08b854..172a6c2e6d 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -1691,8 +1691,7 @@ 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, - int count_as_source) + Scheme_Object *src_insp_desc, Scheme_Object *insp) { Scheme_Object *exr; @@ -1718,8 +1717,7 @@ Scheme_Object *scheme_make_shift(Scheme_Object *phase_delta, vec = last_phase_shift; if (vec - && (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)[0] == old_midx) && (SCHEME_VEC_ELS(vec)[1] == new_midx) && (SCHEME_VEC_ELS(vec)[2] == src_insp_desc) && (SCHEME_VEC_ELS(vec)[3] == insp) @@ -1728,8 +1726,6 @@ 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; @@ -1768,28 +1764,64 @@ 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, - int counts_as_source) + Scheme_Object *src_insp_desc, Scheme_Object *insp) /* 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, counts_as_source); + s = scheme_make_shift(phase_delta, old_midx, new_midx, export_registry, src_insp_desc, insp); if (s) stx = scheme_stx_add_shift(stx, s); return stx; } +static Scheme_Object *shifts_to_non_source(Scheme_Object *shifts) { + Scheme_Object *l, *p, *last, *first, *vec, *vec2; + int i; + + for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + if (!non_source_shift(SCHEME_CAR(l))) + break; + } + + if (SCHEME_NULLP(l)) + return shifts; + + last = NULL; + first = NULL; + + for (l = shifts; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + vec = SCHEME_CAR(l); + if (!non_source_shift(vec)) { + i = SCHEME_VEC_SIZE(vec); + vec2 = scheme_make_vector(i, NULL); + while (i--) { + SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i]; + } + vec = vec2; + vec2 = scheme_box(SCHEME_VEC_ELS(vec)[0]); + SCHEME_VEC_ELS(vec)[0] = vec2; + } + + p = scheme_make_pair(vec, scheme_null); + if (!first) + first = p; + else + SCHEME_CDR(last) = p; + last = p; + } + + return first; +} + static Scheme_Object *apply_modidx_shifts(Scheme_Object *shifts, Scheme_Object *modidx, - Scheme_Object **_insp, Scheme_Hash_Table **_export_registry, - int *_any_non_source) + Scheme_Object **_insp, Scheme_Hash_Table **_export_registry) { #define QUICK_SHIFT_LEN 5 - Scheme_Object *vec, *dest, *src, *insp_desc, *new_modidx; + Scheme_Object *vec, *dest, *src, *insp_desc; 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)) @@ -1808,9 +1840,6 @@ 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); @@ -1826,18 +1855,10 @@ static Scheme_Object *apply_modidx_shifts(Scheme_Object *shifts, Scheme_Object * src = SCHEME_VEC_ELS(vec)[0]; dest = SCHEME_VEC_ELS(vec)[1]; - if (SCHEME_BOXP(src)) { + 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; + + modidx = scheme_modidx_shift(modidx, src, dest); if (SCHEME_VEC_SIZE(vec) > 2) { if (SCHEME_SYMBOLP(insp_desc) @@ -3192,7 +3213,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, NULL); + val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); } @@ -3321,7 +3342,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, NULL); + val = apply_modidx_shifts(stx->shifts, val, NULL, NULL); bind_desc = scheme_hash_tree_set(bind_desc, module_symbol, val); if (PES_UNMARSHAL_DESCP(pes)) { @@ -3876,10 +3897,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, NULL); + o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), SCHEME_VEC_ELS(result)[0], _insp, NULL); SCHEME_VEC_ELS(result)[0] = o; if (nominal_modidx) { - o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), *nominal_modidx, NULL, NULL, NULL); + o = apply_modidx_shifts(SCHEME_CAR(prev_shifts), *nominal_modidx, NULL, NULL); *nominal_modidx = o; } } @@ -4171,11 +4192,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, NULL); + l = apply_modidx_shifts(stx->shifts, SCHEME_VEC_ELS(result)[0], &insp_desc, NULL); SCHEME_VEC_ELS(result)[0] = l; if (nominal_modidx) { - l = apply_modidx_shifts(stx->shifts, *nominal_modidx, NULL, NULL, NULL); + l = apply_modidx_shifts(stx->shifts, *nominal_modidx, NULL, NULL); *nominal_modidx = l; } } else @@ -4847,9 +4868,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, NULL); + modidx = apply_modidx_shifts(stx->shifts, req_modidx, &insp, &export_registry); else - modidx = apply_modidx_shifts(shifts, req_modidx, &insp, &export_registry, NULL); + modidx = apply_modidx_shifts(shifts, req_modidx, &insp, &export_registry); src_phase = SCHEME_VEC_ELS(vec)[1]; unmarshal_info = SCHEME_VEC_ELS(vec)[2]; @@ -4909,6 +4930,7 @@ Scheme_Object *scheme_stx_to_module_context(Scheme_Object *_stx) shifts = stx->shifts; if (SCHEME_VECTORP(shifts)) shifts = SCHEME_VEC_ELS(shifts)[0]; + shifts = shifts_to_non_source(shifts); phase = scheme_make_integer(0); @@ -5159,7 +5181,6 @@ 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]; @@ -5174,22 +5195,19 @@ Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int sou if (SCHEME_MODIDXP(src)) { if (SCHEME_FALSEP(((Scheme_Modidx *)src)->path)) { src = apply_modidx_shifts(((Scheme_Stx *)stx)->shifts, src, - 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); + 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; } - return src; + src = SCHEME_PTR_VAL(src); } + return src; } } }