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

fix problem with transferring marks when some marks contirbuted to the generation of a module-level binding

Browse Source 
svn: r12071
This commit is contained in:
Matthew Flatt 2008-10-20 13:13:42 +00:00
parent 79b0487270
commit 9d0f9f7a05
6 changed files with 88 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/mzscheme/src/env.c
View File

@ -1743,7 +1743,8 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
return val; return val;
} }
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, Scheme_Object *phase) Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def,
Scheme_Object *phase, int *_skipped)
/* The `env' argument can actually be a hash table. */ /* The `env' argument can actually be a hash table. */
{ {
Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg; Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg;
@ -1752,6 +1753,9 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
sym = SCHEME_STX_SYM(id); sym = SCHEME_STX_SYM(id);
if (_skipped)
*_skipped = 0;
if (SCHEME_HASHTP((Scheme_Object *)env)) if (SCHEME_HASHTP((Scheme_Object *)env))
marked_names = (Scheme_Hash_Table *)env; marked_names = (Scheme_Hash_Table *)env;
else { else {
@ -1951,6 +1955,9 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
scheme_hash_set(rev_ht, best_match, scheme_true); scheme_hash_set(rev_ht, best_match, scheme_true);
} }
} }
} else {
if (_skipped)
*_skipped = best_match_skipped;
} }
return best_match; return best_match;
@ -2515,7 +2522,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if (SAME_OBJ(modidx, scheme_undefined)) { if (SAME_OBJ(modidx, scheme_undefined)) {
if (!env->genv->module && SCHEME_STXP(find_id)) { if (!env->genv->module && SCHEME_STXP(find_id)) {
/* Looks like lexically bound, but double-check that it's not bound via a tl_id: */ /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */
find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL); find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL);
if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id))) if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id)))
modidx = NULL; /* yes, it is bound */ modidx = NULL; /* yes, it is bound */
} }
@ -2582,7 +2589,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
*_menv = genv; *_menv = genv;
if (!modname && SCHEME_STXP(find_id)) if (!modname && SCHEME_STXP(find_id))
find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL); find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL);
else else
find_global_id = find_id; find_global_id = find_id;

8
src/mzscheme/src/eval.c
View File

@ -5435,7 +5435,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
/* If form is a marked name, then force #%top binding. /* If form is a marked name, then force #%top binding.
This is so temporaries can be used as defined ids. */ This is so temporaries can be used as defined ids. */
Scheme_Object *nm; Scheme_Object *nm;
nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL); nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL, NULL);
if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) { if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) {
stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0);
@ -5870,7 +5870,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co
Scheme_Object *modidx, *symbol = c, *tl_id; Scheme_Object *modidx, *symbol = c, *tl_id;
int bad; int bad;
tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL); tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL, NULL);
if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
/* Since the module has a rename for this id, it's certainly defined. */ /* Since the module has a rename for this id, it's certainly defined. */
} else { } else {
@ -5917,7 +5917,7 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
c = check_top(scheme_compile_stx_string, form, env, rec, drec); c = check_top(scheme_compile_stx_string, form, env, rec, drec);
c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL); c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL, NULL);
if (env->genv->module && !rec[drec].resolve_module_ids) { if (env->genv->module && !rec[drec].resolve_module_ids) {
/* Self-reference in a module; need to remember the modidx. Don't /* Self-reference in a module; need to remember the modidx. Don't
@ -8954,7 +8954,7 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob
Scheme_Object *l; Scheme_Object *l;
/* Registers marked id: */ /* Registers marked id: */
scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL); scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL, NULL);
l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0), l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0),
icons(scheme_make_pair(*_id, scheme_null), icons(scheme_make_pair(*_id, scheme_null),

28
src/mzscheme/src/module.c
View File

@ -3210,7 +3210,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
supplied (not both). For unprotected access, both prot_insp supplied (not both). For unprotected access, both prot_insp
and stx+certs should be supplied. */ and stx+certs should be supplied. */
{ {
symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL); symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL);
if (scheme_is_kernel_env(env) if (scheme_is_kernel_env(env)
|| ((env->module->primitive && !env->module->provide_protects)) || ((env->module->primitive && !env->module->provide_protects))
@ -3389,7 +3389,7 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Sch
if (!menv->et_ran) if (!menv->et_ran)
scheme_run_module_exptime(menv, 1); scheme_run_module_exptime(menv, 1);
name = scheme_tl_id_sym(menv, name, NULL, 0, NULL); name = scheme_tl_id_sym(menv, name, NULL, 0, NULL, NULL);
val = scheme_lookup_in_table(menv->syntax, (char *)name); val = scheme_lookup_in_table(menv->syntax, (char *)name);
@ -5505,7 +5505,7 @@ static int check_already_required(Scheme_Hash_Table *required, Scheme_Object *na
static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv) static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv)
{ {
return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2, NULL); return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2, NULL, NULL);
} }
static Scheme_Object *add_a_rename(Scheme_Object *fm, Scheme_Object *post_ex_rn) static Scheme_Object *add_a_rename(Scheme_Object *fm, Scheme_Object *post_ex_rn)
@ -5546,7 +5546,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
self_modidx = SCHEME_VEC_ELS(data)[1]; self_modidx = SCHEME_VEC_ELS(data)[1];
rn = SCHEME_VEC_ELS(data)[2]; rn = SCHEME_VEC_ELS(data)[2];
name = scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL); name = scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL, NULL);
/* Create the bucket, indicating that the name will be defined: */ /* Create the bucket, indicating that the name will be defined: */
scheme_add_global_symbol(name, scheme_undefined, env->genv); scheme_add_global_symbol(name, scheme_undefined, env->genv);
@ -5848,7 +5848,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Remember the original: */ /* Remember the original: */
all_defs = scheme_make_pair(name, all_defs); all_defs = scheme_make_pair(name, all_defs);
name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL); name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL);
/* Check that it's not yet defined: */ /* Check that it's not yet defined: */
if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) { if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) {
@ -5925,7 +5925,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
else else
all_et_defs = scheme_make_pair(name, all_et_defs); all_et_defs = scheme_make_pair(name, all_et_defs);
name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL); name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL);
if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) { if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) {
scheme_wrong_syntax("module", orig_name, e, scheme_wrong_syntax("module", orig_name, e,
@ -6278,7 +6278,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* may be a single shadowed exclusion, now bound to exclude_hint... */ /* may be a single shadowed exclusion, now bound to exclude_hint... */
n = SCHEME_CAR(n); n = SCHEME_CAR(n);
if (SCHEME_STXP(n)) if (SCHEME_STXP(n))
n = scheme_tl_id_sym(env->genv, n, NULL, 0, NULL); n = scheme_tl_id_sym(env->genv, n, NULL, 0, NULL, NULL);
n = scheme_hash_get(required, n); n = scheme_hash_get(required, n);
if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) { if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) {
/* there is a single shadowed exclusion. */ /* there is a single shadowed exclusion. */
@ -6814,7 +6814,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
/* Make sure each excluded name was defined: */ /* Make sure each excluded name was defined: */
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
a = SCHEME_STX_CAR(exns); a = SCHEME_STX_CAR(exns);
name = scheme_tl_id_sym(genv, a, NULL, 0, NULL); name = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
if (!scheme_lookup_in_table(genv->toplevel, (const char *)name) if (!scheme_lookup_in_table(genv->toplevel, (const char *)name)
&& !scheme_lookup_in_table(genv->syntax, (const char *)name)) { && !scheme_lookup_in_table(genv->syntax, (const char *)name)) {
scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined"); scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined");
@ -6824,12 +6824,12 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) {
name = SCHEME_CAR(adl); name = SCHEME_CAR(adl);
exname = SCHEME_STX_SYM(name); exname = SCHEME_STX_SYM(name);
name = scheme_tl_id_sym(genv, name, NULL, 0, NULL); name = scheme_tl_id_sym(genv, name, NULL, 0, NULL, NULL);
/* Was this one excluded? */ /* Was this one excluded? */
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
a = SCHEME_STX_CAR(exns); a = SCHEME_STX_CAR(exns);
a = scheme_tl_id_sym(genv, a, NULL, 0, NULL); a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
if (SAME_OBJ(a, name)) if (SAME_OBJ(a, name))
break; break;
} }
@ -6845,7 +6845,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided,
as if it had ree_kw's context, then comparing that result as if it had ree_kw's context, then comparing that result
to the actual tl_id. */ to the actual tl_id. */
a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0); a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0);
a = scheme_tl_id_sym(genv, a, NULL, 0, NULL); a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
if (SAME_OBJ(a, name)) { if (SAME_OBJ(a, name)) {
/* Add prefix, if any */ /* Add prefix, if any */
@ -7033,7 +7033,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
prnt_name = name; prnt_name = name;
if (SCHEME_STXP(name)) { if (SCHEME_STXP(name)) {
if (genv) if (genv)
name = scheme_tl_id_sym(genv, name, NULL, 0, phase); name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL);
else else
name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
} }
@ -7106,7 +7106,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
if (genv if (genv
&& (SAME_OBJ(phase, scheme_make_integer(0)) && (SAME_OBJ(phase, scheme_make_integer(0))
|| SAME_OBJ(phase, scheme_make_integer(1)))) || SAME_OBJ(phase, scheme_make_integer(1))))
name = scheme_tl_id_sym(genv, name, NULL, 0, phase); name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL);
else { else {
name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
} }
@ -8040,7 +8040,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
/* The `require' expression has a set of marks in its /* The `require' expression has a set of marks in its
context, which means that we need to generate a name. */ context, which means that we need to generate a name. */
iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0);
iname = scheme_tl_id_sym(orig_env, iname, scheme_false, 2, to_phase); iname = scheme_tl_id_sym(orig_env, iname, scheme_false, 2, to_phase, NULL);
if (all_simple) if (all_simple)
*all_simple = 0; *all_simple = 0;
} }

3
src/mzscheme/src/schpriv.h
View File

@ -2634,7 +2634,8 @@ void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Sc
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, Scheme_Object *phase); Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def,
Scheme_Object *phase, int *_skipped);
int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym); int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym);
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env); Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env);

71
src/mzscheme/src/stxobj.c
View File

@ -3300,7 +3300,7 @@ static int explain_resolves = 0;
static Scheme_Object *resolve_env(WRAP_POS *_wraps, static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *a, Scheme_Object *orig_phase, Scheme_Object *a, Scheme_Object *orig_phase,
int w_mod, Scheme_Object **get_names, int w_mod, Scheme_Object **get_names,
Scheme_Object *skip_ribs) Scheme_Object *skip_ribs, int *_binding_marks_skipped)
/* Module binding ignored if w_mod is 0. /* Module binding ignored if w_mod is 0.
If module bound, result is module idx, and get_names[0] is set to source name, If module bound, result is module idx, and get_names[0] is set to source name,
get_names[1] is set to the nominal source module, get_names[2] is set to get_names[1] is set to the nominal source module, get_names[2] is set to
@ -3321,6 +3321,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *phase = orig_phase; Scheme_Object *phase = orig_phase;
Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Object *bdg = NULL, *floating = NULL;
Scheme_Hash_Table *export_registry = NULL; Scheme_Hash_Table *export_registry = NULL;
int mresult_skipped = 0;
EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)),
scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL)));
@ -3370,9 +3371,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
} }
stack_pos -= 2; stack_pos -= 2;
} }
if (!did_lexical) if (!did_lexical) {
result = mresult; result = mresult;
else if (get_names) if (_binding_marks_skipped)
*_binding_marks_skipped = mresult_skipped;
} else if (get_names)
get_names[0] = scheme_undefined; get_names[0] = scheme_undefined;
EXPLAIN(printf("Result: %s\n", scheme_write_to_string(result, 0))); EXPLAIN(printf("Result: %s\n", scheme_write_to_string(result, 0)));
@ -3383,6 +3386,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
&& w_mod) { && w_mod) {
/* Module rename: */ /* Module rename: */
Module_Renames *mrn; Module_Renames *mrn;
int skipped;
EXPLAIN(printf("Rename/set\n")); EXPLAIN(printf("Rename/set\n"));
@ -3415,7 +3419,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (mrn->marked_names) { if (mrn->marked_names) {
/* Resolve based on rest of wraps: */ /* Resolve based on rest of wraps: */
if (!bdg) { if (!bdg) {
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs); bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL);
if (SCHEME_FALSEP(bdg)) { if (SCHEME_FALSEP(bdg)) {
if (!floating_checked) { if (!floating_checked) {
floating = check_floating_id(a); floating = check_floating_id(a);
@ -3425,7 +3429,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
} }
} }
/* Remap id based on marks and rest-of-wraps resolution: */ /* Remap id based on marks and rest-of-wraps resolution: */
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL); glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, &skipped);
if (SCHEME_TRUEP(bdg) if (SCHEME_TRUEP(bdg)
&& !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) {
/* Even if this module doesn't match, the lex-renamed id /* Even if this module doesn't match, the lex-renamed id
@ -3437,8 +3441,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
stack_pos = 0; stack_pos = 0;
o_rename_stack = scheme_null; o_rename_stack = scheme_null;
} }
} else } else {
skipped = 0;
glob_id = SCHEME_STX_VAL(a); glob_id = SCHEME_STX_VAL(a);
}
EXPLAIN(printf(" search %s\n", scheme_write_to_string(glob_id, 0))); EXPLAIN(printf(" search %s\n", scheme_write_to_string(glob_id, 0)));
@ -3478,6 +3484,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
modidx_shift_from, modidx_shift_from,
modidx_shift_to); modidx_shift_to);
mresult_skipped = skipped;
if (get_names) { if (get_names) {
int no_shift = 0; int no_shift = 0;
@ -3551,6 +3559,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
} }
} else { } else {
mresult = scheme_false; mresult = scheme_false;
mresult_skipped = 0;
if (get_names) if (get_names)
get_names[0] = NULL; get_names[0] = NULL;
} }
@ -3647,7 +3656,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (SCHEME_VOIDP(other_env)) { if (SCHEME_VOIDP(other_env)) {
SCHEME_USE_FUEL(1); SCHEME_USE_FUEL(1);
other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs); other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL);
if (!is_rib) if (!is_rib)
SCHEME_VEC_ELS(rename)[2+c+ri] = other_env; SCHEME_VEC_ELS(rename)[2+c+ri] = other_env;
SCHEME_USE_FUEL(1); SCHEME_USE_FUEL(1);
@ -3806,13 +3815,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
if (mrn->needs_unmarshal) { if (mrn->needs_unmarshal) {
/* Use resolve_env to trigger unmarshal, so that we /* Use resolve_env to trigger unmarshal, so that we
don't have to implement top/from shifts here: */ don't have to implement top/from shifts here: */
resolve_env(NULL, a, orig_phase, 1, NULL, NULL); resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL);
} }
if (mrn->marked_names) { if (mrn->marked_names) {
/* Resolve based on rest of wraps: */ /* Resolve based on rest of wraps: */
if (!bdg) if (!bdg)
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL); bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL);
if (SCHEME_FALSEP(bdg)) { if (SCHEME_FALSEP(bdg)) {
if (!floating_checked) { if (!floating_checked) {
floating = check_floating_id(a); floating = check_floating_id(a);
@ -3821,7 +3830,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
bdg = floating; bdg = floating;
} }
/* Remap id based on marks and rest-of-wraps resolution: */ /* Remap id based on marks and rest-of-wraps resolution: */
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL); glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL);
} else } else
glob_id = SCHEME_STX_VAL(a); glob_id = SCHEME_STX_VAL(a);
@ -3892,8 +3901,8 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
if ((a == asym) || (b == bsym)) if ((a == asym) || (b == bsym))
return 1; return 1;
a = resolve_env(NULL, a, phase, 1, NULL, NULL); a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL);
b = resolve_env(NULL, b, phase, 1, NULL, NULL); b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
a = scheme_module_resolve(a, 0); a = scheme_module_resolve(a, 0);
@ -3935,7 +3944,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase,
names[4] = NULL; names[4] = NULL;
names[5] = NULL; names[5] = NULL;
modname = resolve_env(NULL, *a, phase, 1, names, NULL); modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL);
if (names[0]) { if (names[0]) {
if (SAME_OBJ(names[0], scheme_undefined)) { if (SAME_OBJ(names[0], scheme_undefined)) {
@ -3966,7 +3975,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a)
if (SCHEME_STXP(a)) { if (SCHEME_STXP(a)) {
Scheme_Object *r; Scheme_Object *r;
r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL); r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL);
if (SCHEME_FALSEP(r)) if (SCHEME_FALSEP(r))
r = check_floating_id(a); r = check_floating_id(a);
@ -3998,13 +4007,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
if (!SAME_OBJ(asym, bsym)) if (!SAME_OBJ(asym, bsym))
return 0; return 0;
ae = resolve_env(NULL, a, phase, 0, NULL, NULL); ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL);
/* No need to module_resolve ae, because we ignored module renamings. */ /* No need to module_resolve ae, because we ignored module renamings. */
if (uid) if (uid)
be = uid; be = uid;
else { else {
be = resolve_env(NULL, b, phase, 0, NULL, NULL); be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL);
/* No need to module_resolve be, because we ignored module renamings. */ /* No need to module_resolve be, because we ignored module renamings. */
} }
@ -4034,7 +4043,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase
Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a)
{ {
explain_resolves++; explain_resolves++;
a = resolve_env(NULL, a, 0, 0, NULL, NULL); a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL);
--explain_resolves; --explain_resolves;
return a; return a;
} }
@ -4567,7 +4576,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii];
if (SCHEME_VOIDP(other_env)) { if (SCHEME_VOIDP(other_env)) {
other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs); other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs, NULL);
SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env;
} }
@ -6788,7 +6797,7 @@ static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], S
static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv) static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv)
{ {
Scheme_Object *m1, *m2, *delta, *a[1]; Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1];
int l1, l2; int l1, l2;
if (!SCHEME_STXP(argv[0])) if (!SCHEME_STXP(argv[0]))
@ -6797,6 +6806,7 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv)
scheme_wrong_type("make-syntax-delta-introducer", "syntax", 1, argc, argv); scheme_wrong_type("make-syntax-delta-introducer", "syntax", 1, argc, argv);
m1 = scheme_stx_extract_marks(argv[0]); m1 = scheme_stx_extract_marks(argv[0]);
orig_m1 = m1;
m2 = scheme_stx_extract_marks(argv[1]); m2 = scheme_stx_extract_marks(argv[1]);
l1 = scheme_list_length(m1); l1 = scheme_list_length(m1);
@ -6810,13 +6820,34 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv)
} }
if (!scheme_equal(m1, m2)) { if (!scheme_equal(m1, m2)) {
/* tails don't match, so keep all marks */ /* tails don't match, so keep all marks --- except those that determine a module binding */
int skipped = 0;
Scheme_Object *phase;
Scheme_Thread *p = scheme_current_thread;
phase = scheme_make_integer(p->current_local_env
? p->current_local_env->genv->phase
: 0);
resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped);
if (skipped) {
/* Just keep the first `skipped' marks. */
delta = scheme_null;
m1 = orig_m1;
while (skipped) {
delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1);
skipped--;
}
} else {
/* Keep them all */
while (l1) { while (l1) {
delta = CONS(SCHEME_CAR(m1), delta); delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1); m1 = SCHEME_CDR(m1);
l1--; l1--;
} }
} }
}
a[0] = delta; a[0] = delta;

4
src/mzscheme/src/syntax.c
View File

@ -1102,7 +1102,7 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In
Scheme_Object *name, *pr, *bucket; Scheme_Object *name, *pr, *bucket;
name = SCHEME_STX_CAR(var); name = SCHEME_STX_CAR(var);
name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL); name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL);
if (rec[drec].resolve_module_ids || !env->genv->module) { if (rec[drec].resolve_module_ids || !env->genv->module) {
bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv); bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv);
@ -5373,7 +5373,7 @@ static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env)
{ {
Scheme_Env *env = (Scheme_Env *)_env; Scheme_Env *env = (Scheme_Env *)_env;
return scheme_tl_id_sym(env, name, NULL, 2, NULL); return scheme_tl_id_sym(env, name, NULL, 2, NULL, NULL);
} }
static Scheme_Object * static Scheme_Object *