fix problem with transferring marks when some marks contirbuted to the generation of a module-level binding
svn: r12071
This commit is contained in:
parent
79b0487270
commit
9d0f9f7a05
|
@ -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;
|
||||
|
||||
|
|
|
@ -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),
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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--;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
@ -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 *
|
||||
|
|
Loading…
Reference in New Issue
Block a user