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

fix bug in stxobj simplication

Browse Source 
svn: r14081
This commit is contained in:
Matthew Flatt 2009-03-12 20:53:18 +00:00
parent edd69e5c50
commit 5826654a4e
1 changed files with 40 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3163,8 +3163,8 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
#define EXPLAIN_RESOLVE 0 #define EXPLAIN_RESOLVE 0
#if EXPLAIN_RESOLVE #if EXPLAIN_RESOLVE
static int explain_resolves = 1; int scheme_explain_resolves = 0;
# define EXPLAIN(x) if (explain_resolves) { x; } # define EXPLAIN(x) if (scheme_explain_resolves) { x; }
#else #else
# define EXPLAIN(x) /* empty */ # define EXPLAIN(x) /* empty */
#endif #endif
@ -3754,7 +3754,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, skip_ribs, NULL, NULL, depth+1); bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1);
if (SCHEME_FALSEP(bdg)) { if (SCHEME_FALSEP(bdg)) {
if (!floating_checked) { if (!floating_checked) {
floating = check_floating_id(a); floating = check_floating_id(a);
@ -4418,9 +4418,9 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase
#if EXPLAIN_RESOLVE #if EXPLAIN_RESOLVE
Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a)
{ {
explain_resolves++; scheme_explain_resolves++;
a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0); a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0);
--explain_resolves; --scheme_explain_resolves;
return a; return a;
} }
#endif #endif
@ -4814,7 +4814,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL; Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL;
Scheme_Lexical_Rib *did_rib = NULL; Scheme_Lexical_Rib *did_rib = NULL;
Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht;
int copy_on_write; int copy_on_write, no_rib_mutation = 1;
long size, vsize, psize, i, j, pos; long size, vsize, psize, i, j, pos;
/* Although it makes no sense to simplify the rename table itself, /* Although it makes no sense to simplify the rename table itself,
@ -4886,7 +4886,12 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
if (SCHEME_RIBP(v)) { if (SCHEME_RIBP(v)) {
/* A rib certainly isn't simplified yet. */ /* A rib certainly isn't simplified yet. */
Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v; Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v;
no_rib_mutation = 0;
add = 1; add = 1;
if (!*rib->sealed) {
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
return NULL;
}
if (SAME_OBJ(did_rib, rib) if (SAME_OBJ(did_rib, rib)
|| !nonempty_rib(rib)) { || !nonempty_rib(rib)) {
skip_this = 1; skip_this = 1;
@ -4894,10 +4899,6 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
scheme_write_to_string(rib->timestamp, NULL))); scheme_write_to_string(rib->timestamp, NULL)));
} else { } else {
did_rib = rib; did_rib = rib;
if (!*rib->sealed) {
scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
return NULL;
}
prec_ribs = add_skip_set(rib->timestamp, prec_ribs); prec_ribs = add_skip_set(rib->timestamp, prec_ribs);
EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib,
@ -5226,36 +5227,36 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
ii++; ii++;
} }
if (pos != size) { if (!pos)
/* Shrink simplified vector */ v2 = empty_simplified;
if (!pos) else {
v2 = empty_simplified; if (pos != size) {
else { /* Shrink simplified vector */
v = v2; v = v2;
v2 = scheme_make_vector(2 + (2 * pos), NULL); v2 = scheme_make_vector(2 + (2 * pos), NULL);
for (i = 0; i < pos; i++) { for (i = 0; i < pos; i++) {
SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i]; SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i];
SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i]; SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i];
} }
} }
}
SCHEME_VEC_ELS(v2)[0] = scheme_false;
SCHEME_VEC_ELS(v2)[0] = scheme_false; SCHEME_VEC_ELS(v2)[1] = scheme_false;
SCHEME_VEC_ELS(v2)[1] = scheme_false;
if (no_rib_mutation) {
{ /* Sometimes we generate the same simplified lex table, so
/* Sometimes we generate the same simplified lex table, so look for an equivalent one in the cache. */
look for an equivalent one in the cache. */ v = scheme_hash_get(lex_cache, scheme_true);
v = scheme_hash_get(lex_cache, scheme_true); if (!v) {
if (!v) { v = (Scheme_Object *)scheme_make_hash_table_equal();
v = (Scheme_Object *)scheme_make_hash_table_equal(); scheme_hash_set(lex_cache, scheme_true, v);
scheme_hash_set(lex_cache, scheme_true, v); }
svl = scheme_hash_get((Scheme_Hash_Table *)v, v2);
if (svl)
v2 = svl;
else
scheme_hash_set((Scheme_Hash_Table *)v, v2, v2);
} }
svl = scheme_hash_get((Scheme_Hash_Table *)v, v2);
if (svl)
v2 = svl;
else
scheme_hash_set((Scheme_Hash_Table *)v, v2, v2);
} }
v2l = CONS(v2, v2l); v2l = CONS(v2, v2l);