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

fix algorithmic problems in syntax-object resolution with nested intdef contexts

Browse Source 
svn: r14093
This commit is contained in:
Matthew Flatt 2009-03-14 09:38:05 +00:00
parent d9b543ae6f
commit dc8c06381a
1 changed files with 117 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -77,10 +77,10 @@ static Scheme_Object *origin_symbol;
static Scheme_Object *lexical_symbol;
static Scheme_Object *protected_symbol;
static Scheme_Object *nominal_ipair_cache;
static THREAD_LOCAL Scheme_Object *nominal_ipair_cache;
static Scheme_Object *mark_id = scheme_make_integer(0);
static Scheme_Object *current_rib_timestamp = scheme_make_integer(0);
static THREAD_LOCAL Scheme_Object *mark_id = scheme_make_integer(0);
static THREAD_LOCAL Scheme_Object *current_rib_timestamp = scheme_make_integer(0);
static Scheme_Stx_Srcloc *empty_srcloc;
@ -88,11 +88,12 @@ static Scheme_Object *empty_simplified;
static Scheme_Hash_Table *empty_hash_table;
static Scheme_Object *last_phase_shift;
static THREAD_LOCAL Scheme_Object *last_phase_shift;
/* caches */
static THREAD_LOCAL Scheme_Hash_Table *id_marks_ht;
static THREAD_LOCAL Scheme_Hash_Table *than_id_marks_ht;
static THREAD_LOCAL Scheme_Object *unsealed_dependencies;
static THREAD_LOCAL Scheme_Hash_Table *id_marks_ht; /* a cache */
static THREAD_LOCAL Scheme_Hash_Table *than_id_marks_ht; /* a cache */
static Scheme_Object *no_nested_inactive_certs;
@ -225,6 +226,9 @@ static Module_Renames *krn;
->pos) void => not yet computed
or #f sym => mark check done,
var-resolved is answer to replace #f
for nozero skipped ribs
(rlistof (rcons skipped sym)) => generalization of sym
(mcons var-resolved next) => depends on unsealed rib
- A wrap-elem (vector <any> <ht> <sym> ... <sym> ...) is also a lexical rename
var resolved
where the variables have already been resolved and filtered (no mark
@ -560,6 +564,8 @@ void scheme_init_stx(Scheme_Env *env)
REGISTER_SO(no_nested_inactive_certs);
no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL);
SCHEME_SET_IMMUTABLE(no_nested_inactive_certs);
REGISTER_SO(unsealed_dependencies);
}
/*========================================================================*/
@ -1059,6 +1065,7 @@ Scheme_Object *scheme_make_rename_rib()
void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename)
{
Scheme_Lexical_Rib *rib, *naya;
Scheme_Object *next;
naya = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib);
naya->so.type = scheme_lexical_rib_type;
@ -1070,6 +1077,13 @@ void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename)
naya->timestamp = rib->timestamp;
naya->sealed = rib->sealed;
while (unsealed_dependencies) {
next = SCHEME_CDR(unsealed_dependencies);
SCHEME_CAR(unsealed_dependencies) = NULL;
SCHEME_CDR(unsealed_dependencies) = NULL;
unsealed_dependencies = next;
}
}
void scheme_drop_first_rib_rename(Scheme_Object *ro)
@ -3614,7 +3628,89 @@ static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs)
static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs)
{
return scheme_make_raw_pair(timestamp, skip_ribs);
if (in_skip_set(timestamp, skip_ribs))
return skip_ribs;
else
return scheme_make_raw_pair(timestamp, skip_ribs);
}
XFORM_NONGCING static int same_skipped_ribs(Scheme_Object *a, Scheme_Object *b)
{
while (a) {
if (!b) return 0;
if (!SAME_OBJ(SCHEME_CAR(a), SCHEME_CAR(b)))
return 0;
a = SCHEME_CDR(a);
b = SCHEME_CDR(b);
}
return !b;
}
XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, Scheme_Object *skip_ribs)
{
Scheme_Object *p;
if (SCHEME_MPAIRP(other_env)) {
other_env = SCHEME_CAR(other_env);
if (!other_env)
return scheme_void;
}
if (SCHEME_RPAIRP(other_env)) {
while (other_env) {
p = SCHEME_CAR(other_env);
if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs))
return SCHEME_CDR(p);
other_env = SCHEME_CDR(other_env);
}
return scheme_void;
} else if (!skip_ribs)
return other_env;
else
return scheme_void;
}
static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *other_env, Scheme_Object *skip_ribs,
int depends_on_unsealed_rib)
{
Scheme_Object *in_mpair = NULL;
if (SCHEME_MPAIRP(orig)) {
in_mpair = orig;
orig = SCHEME_CAR(orig);
if (!depends_on_unsealed_rib && !orig) {
/* no longer depends on unsealed rib: */
in_mpair = NULL;
orig = scheme_void;
} else {
/* (some) still depends on unsealed rib: */
if (!orig) {
/* re-register in list of dependencies */
SCHEME_CDR(in_mpair) = unsealed_dependencies;
unsealed_dependencies = in_mpair;
orig = scheme_void;
}
}
} else if (depends_on_unsealed_rib) {
/* register dependency: */
in_mpair = scheme_make_mutable_pair(NULL, unsealed_dependencies);
unsealed_dependencies = in_mpair;
}
if (SCHEME_VOIDP(orig) && !skip_ribs) {
orig = other_env;
} else {
if (!SCHEME_RPAIRP(orig))
orig = scheme_make_raw_pair(scheme_make_raw_pair(NULL, orig), NULL);
orig = scheme_make_raw_pair(scheme_make_raw_pair(skip_ribs, other_env), orig);
}
if (in_mpair) {
SCHEME_CAR(in_mpair) = orig;
return in_mpair;
} else
return orig;
}
#define QUICK_STACK_SIZE 8
@ -4000,13 +4096,18 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
} else {
envname = SCHEME_VEC_ELS(rename)[0];
other_env = SCHEME_VEC_ELS(rename)[2+c+ri];
other_env = filter_cached_env(other_env, recur_skip_ribs);
if (SCHEME_VOIDP(other_env)) {
int rib_dep = 0;
SCHEME_USE_FUEL(1);
other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1);
if (!is_rib && !rib_dep)
SCHEME_VEC_ELS(rename)[2+c+ri] = other_env;
{
Scheme_Object *e;
e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs,
(is_rib && !(*is_rib->sealed)) || rib_dep);
SCHEME_VEC_ELS(rename)[2+c+ri] = e;
}
if (rib_dep)
depends_on_unsealed_rib = 1;
SCHEME_USE_FUEL(1);
@ -4065,6 +4166,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
}
if (rib) {
if (!*rib->sealed)
depends_on_unsealed_rib = 1;
if (nonempty_rib(rib)) {
if (SAME_OBJ(did_rib, rib)) {
EXPLAIN(fprintf(stderr, "%d Did rib\n", depth));
@ -4925,6 +5028,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
/* No. Should we skip? */
Scheme_Object *other_env;
other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i];
other_env = filter_cached_env(other_env, prec_ribs);
if (SCHEME_VOIDP(other_env)) {
int rib_dep;
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0);
@ -5093,6 +5197,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
}
other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii];
other_env = filter_cached_env(other_env, prec_ribs);
if (SCHEME_VOIDP(other_env)) {
int rib_dep;
other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0);
@ -5100,7 +5205,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
return NULL;
}
if (!rib)
if (!prec_ribs)
SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env;
}