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

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

View File

@ -1743,7 +1743,8 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
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. */
{
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);
if (_skipped)
*_skipped = 0;
if (SCHEME_HASHTP((Scheme_Object *)env))
marked_names = (Scheme_Hash_Table *)env;
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);
}
}
} else {
if (_skipped)
*_skipped = best_match_skipped;
}
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 (!env->genv->module && SCHEME_STXP(find_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)))
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;
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
find_global_id = find_id;

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.
This is so temporaries can be used as defined ids. */
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))) {
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;
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))) {
/* Since the module has a rename for this id, it's certainly defined. */
} 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 = 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) {
/* 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;
/* 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),
icons(scheme_make_pair(*_id, scheme_null),

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
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)
|| ((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)
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);
@ -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)
{
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)
@ -5546,7 +5546,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
self_modidx = SCHEME_VEC_ELS(data)[1];
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: */
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: */
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: */
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
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)) {
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... */
n = SCHEME_CAR(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);
if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) {
/* 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: */
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(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)
&& !scheme_lookup_in_table(genv->syntax, (const char *)name)) {
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)) {
name = SCHEME_CAR(adl);
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? */
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(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))
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
to the actual tl_id. */
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)) {
/* Add prefix, if any */
@ -7033,7 +7033,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
prnt_name = name;
if (SCHEME_STXP(name)) {
if (genv)
name = scheme_tl_id_sym(genv, name, NULL, 0, phase);
name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL);
else
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
&& (SAME_OBJ(phase, scheme_make_integer(0))
|| 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 {
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
context, which means that we need to generate a name. */
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)
*all_simple = 0;
}

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);
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env);

View File

@ -3300,7 +3300,7 @@ static int explain_resolves = 0;
static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *a, Scheme_Object *orig_phase,
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.
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
@ -3321,6 +3321,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *phase = orig_phase;
Scheme_Object *bdg = NULL, *floating = 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)),
scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL)));
@ -3370,10 +3371,12 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
stack_pos -= 2;
}
if (!did_lexical)
if (!did_lexical) {
result = mresult;
else if (get_names)
get_names[0] = scheme_undefined;
if (_binding_marks_skipped)
*_binding_marks_skipped = mresult_skipped;
} else if (get_names)
get_names[0] = scheme_undefined;
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) {
/* Module rename: */
Module_Renames *mrn;
int skipped;
EXPLAIN(printf("Rename/set\n"));
@ -3415,7 +3419,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (mrn->marked_names) {
/* Resolve based on rest of wraps: */
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 (!floating_checked) {
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: */
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)
&& !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) {
/* 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;
o_rename_stack = scheme_null;
}
} else
} else {
skipped = 0;
glob_id = SCHEME_STX_VAL(a);
}
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_to);
mresult_skipped = skipped;
if (get_names) {
int no_shift = 0;
@ -3551,6 +3559,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
} else {
mresult = scheme_false;
mresult_skipped = 0;
if (get_names)
get_names[0] = NULL;
}
@ -3647,7 +3656,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (SCHEME_VOIDP(other_env)) {
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)
SCHEME_VEC_ELS(rename)[2+c+ri] = other_env;
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) {
/* Use resolve_env to trigger unmarshal, so that we
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) {
/* Resolve based on rest of wraps: */
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 (!floating_checked) {
floating = check_floating_id(a);
@ -3821,7 +3830,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
bdg = floating;
}
/* 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
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))
return 1;
a = resolve_env(NULL, a, phase, 1, NULL, NULL);
b = resolve_env(NULL, b, phase, 1, NULL, NULL);
a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL);
b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
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[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 (SAME_OBJ(names[0], scheme_undefined)) {
@ -3966,7 +3975,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a)
if (SCHEME_STXP(a)) {
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))
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))
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. */
if (uid)
be = uid;
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. */
}
@ -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)
{
explain_resolves++;
a = resolve_env(NULL, a, 0, 0, NULL, NULL);
a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL);
--explain_resolves;
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];
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;
}
@ -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)
{
Scheme_Object *m1, *m2, *delta, *a[1];
Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1];
int l1, l2;
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);
m1 = scheme_stx_extract_marks(argv[0]);
orig_m1 = m1;
m2 = scheme_stx_extract_marks(argv[1]);
l1 = scheme_list_length(m1);
@ -6810,11 +6820,32 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv)
}
if (!scheme_equal(m1, m2)) {
/* tails don't match, so keep all marks */
while (l1) {
delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1);
l1--;
/* 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) {
delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1);
l1--;
}
}
}

View File

@ -1102,7 +1102,7 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In
Scheme_Object *name, *pr, *bucket;
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) {
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;
return scheme_tl_id_sym(env, name, NULL, 2, NULL);
return scheme_tl_id_sym(env, name, NULL, 2, NULL, NULL);
}
static Scheme_Object *