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

fix problem with free-id= cycles

Browse Source 
svn: r14524
This commit is contained in:
Matthew Flatt 2009-04-15 17:18:02 +00:00
parent b7063fc563
commit daf779d230
4 changed files with 104 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2003,7 +2003,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
existing rename. */ existing rename. */
if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) { if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) {
Scheme_Object *mod, *nm = id; Scheme_Object *mod, *nm = id;
mod = scheme_stx_module_name(0, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL); NULL, NULL, NULL, NULL);
if (mod /* must refer to env->module, otherwise there would if (mod /* must refer to env->module, otherwise there would
have been an error before getting here */ have been an error before getting here */
@ -2679,7 +2679,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
} }
src_find_id = find_id; src_find_id = find_id;
modidx = scheme_stx_module_name(0, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase,
NULL, NULL, NULL, NULL); NULL, NULL, NULL, NULL);
/* Used out of context? */ /* Used out of context? */
@ -2957,7 +2957,7 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok
if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) { if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) {
return 1; return 1;
} else { } else {
mod = scheme_stx_module_name(0, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, mod = scheme_stx_module_name(NULL, &id, scheme_make_integer(env->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL); NULL, NULL, NULL, NULL);
if (SAME_OBJ(mod, scheme_undefined)) if (SAME_OBJ(mod, scheme_undefined))
return 1; return 1;

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

@ -7304,7 +7304,7 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name,
name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2)); name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2));
id = name2; id = name2;
mod = scheme_stx_module_name(0, &id, phase, mod = scheme_stx_module_name(NULL, &id, phase,
_implicit_nominal_mod, _implicit_nominal_name, _implicit_nominal_mod, _implicit_nominal_name,
_implicit_mod_phase, _implicit_mod_phase,
NULL, NULL, NULL, NULL); NULL, NULL, NULL, NULL);

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

@ -809,7 +809,7 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist);
int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase); int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase);
int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym); int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym);
Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase); Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase);
Scheme_Object *scheme_stx_module_name(int recur, Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *recur,
Scheme_Object **name, Scheme_Object *phase, Scheme_Object **name, Scheme_Object *phase,
Scheme_Object **nominal_modidx, Scheme_Object **nominal_modidx,
Scheme_Object **nominal_name, Scheme_Object **nominal_name,

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

@ -88,6 +88,7 @@ static Scheme_Stx_Srcloc *empty_srcloc;
static Scheme_Object *empty_simplified; static Scheme_Object *empty_simplified;
static Scheme_Hash_Table *empty_hash_table; static Scheme_Hash_Table *empty_hash_table;
static THREAD_LOCAL Scheme_Hash_Table *quick_hash_table;
static THREAD_LOCAL Scheme_Object *last_phase_shift; static THREAD_LOCAL Scheme_Object *last_phase_shift;
@ -570,6 +571,8 @@ void scheme_init_stx(Scheme_Env *env)
REGISTER_SO(nominal_ipair_cache); REGISTER_SO(nominal_ipair_cache);
REGISTER_SO(quick_hash_table);
REGISTER_SO(last_phase_shift); REGISTER_SO(last_phase_shift);
REGISTER_SO(empty_hash_table); REGISTER_SO(empty_hash_table);
@ -1930,10 +1933,29 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib)
return scheme_add_rename(o, rib); return scheme_add_rename(o, rib);
} }
static Scheme_Hash_Table *make_recur_table()
{
if (quick_hash_table) {
GC_CAN_IGNORE Scheme_Hash_Table *t;
t = quick_hash_table;
quick_hash_table = NULL;
return t;
} else
return scheme_make_hash_table(SCHEME_hash_ptr);
}
static void release_recur_table(Scheme_Hash_Table *free_id_recur)
{
if (!free_id_recur->size && !quick_hash_table) {
quick_hash_table = free_id_recur;
}
}
static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn,
Scheme_Object *id, Scheme_Object *id,
Scheme_Object *orig_id, Scheme_Object *orig_id,
int *_sealed) int *_sealed,
Scheme_Hash_Table *free_id_recur)
{ {
Scheme_Object *result; Scheme_Object *result;
Scheme_Object *modname; Scheme_Object *modname;
@ -1943,10 +1965,15 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn,
Scheme_Object *src_phase_index; Scheme_Object *src_phase_index;
Scheme_Object *nominal_src_phase; Scheme_Object *nominal_src_phase;
Scheme_Object *lex_env; Scheme_Object *lex_env;
if (scheme_hash_get(free_id_recur, id)) {
return id;
}
scheme_hash_set(free_id_recur, id, id);
nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL);
modname = scheme_stx_module_name(1, modname = scheme_stx_module_name(free_id_recur,
&orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx,
&nominal_name, &nominal_name,
&mod_phase, &mod_phase,
@ -3939,7 +3966,8 @@ 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, int *_binding_marks_skipped, Scheme_Object *skip_ribs, int *_binding_marks_skipped,
int *_depends_on_unsealed_rib, int depth, int get_free_id_info) int *_depends_on_unsealed_rib, int depth,
Scheme_Hash_Table *free_id_recur)
/* 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
@ -4024,7 +4052,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (mresult_depends_unsealed) if (mresult_depends_unsealed)
depends_on_unsealed_rib = 1; depends_on_unsealed_rib = 1;
} else { } else {
if (get_free_id_info && !SCHEME_VOIDP(result_free_rename)) { if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) {
Scheme_Object *orig; Scheme_Object *orig;
int rib_dep = 0; int rib_dep = 0;
orig = result_free_rename; orig = result_free_rename;
@ -4038,7 +4066,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
result = resolve_env(NULL, SCHEME_CAR(result_free_rename), phase, result = resolve_env(NULL, SCHEME_CAR(result_free_rename), phase,
w_mod, get_names, w_mod, get_names,
NULL, _binding_marks_skipped, NULL, _binding_marks_skipped,
&rib_dep, depth + 1, 1); &rib_dep, depth + 1, free_id_recur);
if (get_names && !get_names[1]) if (get_names && !get_names[1])
if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0])) if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0]))
get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename)); get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename));
@ -4123,7 +4151,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth));
if (!bdg) { if (!bdg) {
EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); EXPLAIN(fprintf(stderr, "%d get bdg\n", depth));
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, 0); bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, 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);
@ -4153,14 +4181,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0)));
if (get_free_id_info && mrn->free_id_renames) { if (free_id_recur && mrn->free_id_renames) {
rename = scheme_hash_get(mrn->free_id_renames, glob_id); rename = scheme_hash_get(mrn->free_id_renames, glob_id);
if (rename && SCHEME_STXP(rename)) { if (rename && SCHEME_STXP(rename)) {
int sealed; int sealed;
rename = extract_module_free_id_binding((Scheme_Object *)mrn, rename = extract_module_free_id_binding((Scheme_Object *)mrn,
glob_id, glob_id,
rename, rename,
&sealed); &sealed,
free_id_recur);
if (!sealed) if (!sealed)
mresult_depends_unsealed = 1; mresult_depends_unsealed = 1;
} }
@ -4416,7 +4445,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
if (SCHEME_VOIDP(other_env)) { if (SCHEME_VOIDP(other_env)) {
int rib_dep = 0; int rib_dep = 0;
SCHEME_USE_FUEL(1); SCHEME_USE_FUEL(1);
other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, 0); other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL);
{ {
Scheme_Object *e; Scheme_Object *e;
e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs,
@ -4449,7 +4478,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
top element of the stack and combine the two top element of the stack and combine the two
mappings, but the intermediate name may be needed mappings, but the intermediate name may be needed
(for other_env values that don't come from this stack). */ (for other_env values that don't come from this stack). */
if (get_free_id_info && !SCHEME_VOIDP(free_id_rename)) { if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) {
/* Need to remember phase ad shifts for free-id=? rename: */ /* Need to remember phase ad shifts for free-id=? rename: */
Scheme_Object *vec; Scheme_Object *vec;
vec = scheme_make_vector(4, NULL); vec = scheme_make_vector(4, NULL);
@ -4535,7 +4564,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
} }
} }
static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, int use_free_id_renames) static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase,
Scheme_Hash_Table *free_id_recur)
/* Gets a module source name under the assumption that the identifier /* Gets a module source name under the assumption that the identifier
is not lexically renamed. This is used as a quick pre-test for is not lexically renamed. This is used as a quick pre-test for
free-identifier=?. We do have to look at lexical renames to check for free-identifier=?. We do have to look at lexical renames to check for
@ -4545,11 +4575,11 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
WRAP_POS wraps; WRAP_POS wraps;
Scheme_Object *result, *result_from; Scheme_Object *result, *result_from;
int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0; int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0;
int no_lexical = !use_free_id_renames; int no_lexical = !free_id_recur;
Scheme_Object *phase = orig_phase; Scheme_Object *phase = orig_phase;
Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Object *bdg = NULL, *floating = NULL;
if (!use_free_id_renames if (!free_id_recur
&& SAME_OBJ(phase, scheme_make_integer(0)) && SAME_OBJ(phase, scheme_make_integer(0))
&& ((Scheme_Stx *)a)->u.modinfo_cache) && ((Scheme_Stx *)a)->u.modinfo_cache)
return ((Scheme_Stx *)a)->u.modinfo_cache; return ((Scheme_Stx *)a)->u.modinfo_cache;
@ -4568,7 +4598,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
if (!result) if (!result)
result = SCHEME_STX_VAL(a); result = SCHEME_STX_VAL(a);
if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !use_free_id_renames) if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur)
((Scheme_Stx *)a)->u.modinfo_cache = result; ((Scheme_Stx *)a)->u.modinfo_cache = result;
return result; return result;
@ -4609,13 +4639,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, NULL, NULL, 0, 0); resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, 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, NULL, NULL, 0, 0); bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, 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);
@ -4634,14 +4664,15 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
} else } else
glob_id = SCHEME_STX_VAL(a); glob_id = SCHEME_STX_VAL(a);
if (use_free_id_renames && mrn->free_id_renames) { if (free_id_recur && mrn->free_id_renames) {
rename = scheme_hash_get(mrn->free_id_renames, glob_id); rename = scheme_hash_get(mrn->free_id_renames, glob_id);
if (rename && SCHEME_STXP(rename)) { if (rename && SCHEME_STXP(rename)) {
int sealed; int sealed;
rename = extract_module_free_id_binding((Scheme_Object *)mrn, rename = extract_module_free_id_binding((Scheme_Object *)mrn,
glob_id, glob_id,
rename, rename,
&sealed); &sealed,
free_id_recur);
if (!sealed) if (!sealed)
sealed = 0; sealed = 0;
} }
@ -4754,7 +4785,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
names[4] = NULL; names[4] = NULL;
names[5] = NULL; names[5] = NULL;
modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, 1); modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur);
if (rib_dep) if (rib_dep)
sealed = 0; sealed = 0;
@ -4784,18 +4815,27 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym) int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym)
{ {
Scheme_Object *bsym; Scheme_Object *bsym;
Scheme_Hash_Table *free_id_recur;
if (!a || !b) if (!a || !b)
return (a == b); return (a == b);
if (SCHEME_STXP(b)) if (SCHEME_STXP(b)) {
bsym = get_module_src_name(b, phase, !asym); if (!asym)
else free_id_recur = make_recur_table();
else
free_id_recur = NULL;
bsym = get_module_src_name(b, phase, free_id_recur);
if (!asym)
release_recur_table(free_id_recur);
} else
bsym = b; bsym = b;
if (!asym) { if (!asym) {
if (SCHEME_STXP(a)) if (SCHEME_STXP(a)) {
asym = get_module_src_name(a, phase, 1); free_id_recur = make_recur_table();
else asym = get_module_src_name(a, phase, free_id_recur);
release_recur_table(free_id_recur);
} else
asym = a; asym = a;
} }
@ -4805,9 +4845,14 @@ 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, NULL, NULL, 0, 1); free_id_recur = make_recur_table();
b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, 1); a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
release_recur_table(free_id_recur);
free_id_recur = make_recur_table();
b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
release_recur_table(free_id_recur);
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);
@ -4826,12 +4871,12 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase)
Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase) Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase)
{ {
if (SCHEME_STXP(a)) if (SCHEME_STXP(a))
return get_module_src_name(a, phase, 0); return get_module_src_name(a, phase, NULL);
else else
return a; return a;
} }
Scheme_Object *scheme_stx_module_name(int recur, Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur,
Scheme_Object **a, Scheme_Object *phase, Scheme_Object **a, Scheme_Object *phase,
Scheme_Object **nominal_modidx, /* how it was imported */ Scheme_Object **nominal_modidx, /* how it was imported */
Scheme_Object **nominal_name, /* imported as name */ Scheme_Object **nominal_name, /* imported as name */
@ -4856,7 +4901,7 @@ Scheme_Object *scheme_stx_module_name(int recur,
names[4] = NULL; names[4] = NULL;
names[5] = NULL; names[5] = NULL;
modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, recur); modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, free_id_recur);
if (_sealed) *_sealed = !rib_dep; if (_sealed) *_sealed = !rib_dep;
@ -4902,8 +4947,8 @@ int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs)
skip_ribs = SCHEME_CDR(skip_ribs); skip_ribs = SCHEME_CDR(skip_ribs);
} }
m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, 0); m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, NULL);
m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, 0); m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, NULL);
return !SAME_OBJ(m1, m2); return !SAME_OBJ(m1, m2);
} }
@ -4914,7 +4959,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, NULL, NULL, 0, 0); r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, NULL);
if (SCHEME_FALSEP(r)) if (SCHEME_FALSEP(r))
r = check_floating_id(a); r = check_floating_id(a);
@ -4946,13 +4991,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, NULL, NULL, 0, 0); ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, 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, NULL, NULL, 0, 0); be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
/* No need to module_resolve be, because we ignored module renamings. */ /* No need to module_resolve be, because we ignored module renamings. */
} }
@ -4982,7 +5027,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)
{ {
scheme_explain_resolves++; scheme_explain_resolves++;
a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, 1); a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, NULL);
--scheme_explain_resolves; --scheme_explain_resolves;
return a; return a;
} }
@ -5379,16 +5424,19 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id)
Scheme_Object *nominal_src_phase; Scheme_Object *nominal_src_phase;
Scheme_Object *lex_env = NULL; Scheme_Object *lex_env = NULL;
Scheme_Object *vec, *phase; Scheme_Object *vec, *phase;
Scheme_Hash_Table *free_id_recur;
phase = SCHEME_CDR(id); phase = SCHEME_CDR(id);
id = SCHEME_CAR(id); id = SCHEME_CAR(id);
nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); nom2 = scheme_stx_property(id, nominal_id_symbol, NULL);
bind = scheme_stx_module_name(1, free_id_recur = make_recur_table();
bind = scheme_stx_module_name(free_id_recur,
&id, phase, &nominal_modidx, &nominal_name, &id, phase, &nominal_modidx, &nominal_name,
&mod_phase, &src_phase_index, &nominal_src_phase, &mod_phase, &src_phase_index, &nominal_src_phase,
&lex_env, NULL); &lex_env, NULL);
release_recur_table(free_id_recur);
if (SCHEME_SYMBOLP(nom2)) if (SCHEME_SYMBOLP(nom2))
nominal_name = nom2; nominal_name = nom2;
@ -5534,7 +5582,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
other_env = filter_cached_env(other_env, prec_ribs); other_env = filter_cached_env(other_env, prec_ribs);
if (SCHEME_VOIDP(other_env)) { if (SCHEME_VOIDP(other_env)) {
int rib_dep; int rib_dep;
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL);
if (rib_dep) { if (rib_dep) {
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
return NULL; return NULL;
@ -5707,7 +5755,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
other_env = filter_cached_env(other_env, prec_ribs); other_env = filter_cached_env(other_env, prec_ribs);
if (SCHEME_VOIDP(other_env)) { if (SCHEME_VOIDP(other_env)) {
int rib_dep; int rib_dep;
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL);
if (rib_dep) { if (rib_dep) {
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
return NULL; return NULL;
@ -6119,15 +6167,16 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
if (mrn->free_id_renames->vals[i]) { if (mrn->free_id_renames->vals[i]) {
if (SCHEME_STXP(mrn->free_id_renames->vals[i])) { if (SCHEME_STXP(mrn->free_id_renames->vals[i])) {
int sealed; int sealed;
Scheme_Hash_Table *free_id_recur;
free_id_recur = make_recur_table();
b = extract_module_free_id_binding((Scheme_Object *)mrn, b = extract_module_free_id_binding((Scheme_Object *)mrn,
mrn->free_id_renames->keys[i], mrn->free_id_renames->keys[i],
mrn->free_id_renames->vals[i], mrn->free_id_renames->vals[i],
&sealed); &sealed,
free_id_recur);
release_recur_table(free_id_recur);
if (!sealed) { if (!sealed) {
extract_module_free_id_binding((Scheme_Object *)mrn,
mrn->free_id_renames->keys[i],
mrn->free_id_renames->vals[i],
&sealed);
scheme_signal_error("write: unsealed local-definition or module context" scheme_signal_error("write: unsealed local-definition or module context"
" found in syntax object"); " found in syntax object");
} }
@ -7800,7 +7849,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache)
if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) { if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) {
fprintf(stderr, fprintf(stderr,
"simplifying... %s\n", "simplifying... %s\n",
scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL),
NULL)); NULL));
explain_simp = 1; explain_simp = 1;
} }
@ -7818,7 +7867,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache)
if (explain_simp) { if (explain_simp) {
explain_simp = 0; explain_simp = 0;
fprintf(stderr, "simplified: %s\n", fprintf(stderr, "simplified: %s\n",
scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL),
NULL)); NULL));
} }
#endif #endif
@ -8310,7 +8359,8 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv)
int skipped = -1; int skipped = -1;
Scheme_Object *mod; Scheme_Object *mod;
mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, 1); mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0,
scheme_make_hash_table(SCHEME_hash_ptr));
if ((skipped == -1) && SCHEME_FALSEP(mod)) { if ((skipped == -1) && SCHEME_FALSEP(mod)) {
/* For top-level bindings, need to check the current environment's table, /* For top-level bindings, need to check the current environment's table,
@ -8436,7 +8486,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar
phase = scheme_bin_plus(dphase, phase); phase = scheme_bin_plus(dphase, phase);
} }
m = scheme_stx_module_name(1, m = scheme_stx_module_name(scheme_make_hash_table(SCHEME_hash_ptr),
&a, &a,
phase, phase,
&nom_mod, &nom_a, &nom_mod, &nom_a,