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

fix two macro-expansion bugs: local-expand with internal syntax definitions, and simplifying rename records that involve internal-definition ribs

Browse Source 
svn: r5053
This commit is contained in:
Matthew Flatt 2006-12-07 02:08:37 +00:00
parent 6335ee3c03
commit 4bfa93feac
4 changed files with 1518 additions and 1493 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2898
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -2219,7 +2219,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
/* Need to know the phase being compiled */ /* Need to know the phase being compiled */
phase = env->genv->phase; phase = env->genv->phase;
/* Walk through the compilation frames */ /* Walk through the compilation frames */
for (frame = env; frame->next != NULL; frame = frame->next) { for (frame = env; frame->next != NULL; frame = frame->next) {
int i; int i;

8
src/mzscheme/src/eval.c
View File

@ -5128,8 +5128,12 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (SCHEME_STX_PAIRP(result)) { if (SCHEME_STX_PAIRP(result)) {
if (!start) if (!start)
start = scheme_null; start = scheme_null;
if (stx_start && !(rec[drec].comp || (rec[drec].depth == -1)))
stx_start = scheme_null; /* I think the following was intended as an optimization for `expand',
since the syntax definition will be dropped. But it breaks
`local-expand':
if (stx_start && !(rec[drec].comp || (rec[drec].depth == -1)))
stx_start = scheme_null; */
if (stx_start) { if (stx_start) {
result = scheme_make_immutable_pair(letrec_syntaxes_symbol, result = scheme_make_immutable_pair(letrec_syntaxes_symbol,
scheme_make_immutable_pair(stx_start, scheme_make_immutable_pair(stx_start,

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

@ -3667,7 +3667,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
WRAP_POS prev; WRAP_POS prev;
WRAP_POS w2; WRAP_POS w2;
Scheme_Object *stack = scheme_null, *key, *old_key; Scheme_Object *stack = scheme_null, *key, *old_key;
Scheme_Object *v, *v2, *v2l, *stx, *name; Scheme_Object *v, *v2, *v2l, *stx, *name, *svl;
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,
@ -3765,7 +3765,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
} else } else
vsize = SCHEME_RENAME_LEN(v); vsize = SCHEME_RENAME_LEN(v);
/* Initial size; may shrink: */ /* Initial size; may shrink: */
size = vsize; size = vsize;
v2 = scheme_make_vector(2 + (2 * size), NULL); v2 = scheme_make_vector(2 + (2 * size), NULL);
@ -3790,14 +3790,16 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
stx = SCHEME_VEC_ELS(v)[2+ii]; stx = SCHEME_VEC_ELS(v)[2+ii];
name = SCHEME_STX_VAL(stx); name = SCHEME_STX_VAL(stx);
SCHEME_VEC_ELS(v2)[2+pos] = name; SCHEME_VEC_ELS(v2)[2+pos] = name;
{ {
/* Either this name is in prev, in which case the answer /* Either this name is in prev, in which case the answer
must match this rename's target, or this rename's must match this rename's target, or this rename's
answer applies. */ answer applies. */
Scheme_Object *ok = NULL; Scheme_Object *ok = NULL, *ok_replace = NULL;
int ok_replace_index = 0;
if (!WRAP_POS_END_P(prev)) { if (!WRAP_POS_END_P(prev)
|| SCHEME_PAIRP(v2l)) {
WRAP_POS w3; WRAP_POS w3;
Scheme_Object *vp; Scheme_Object *vp;
Scheme_Object *other_env; Scheme_Object *other_env;
@ -3807,51 +3809,74 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs); other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs);
SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env;
} }
/* Check marks (now that we have the correct barriers). */ /* Check marks (now that we have the correct barriers). */
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
if (!same_marks(&w2, &w, other_env, (Scheme_Object *)init_rib)) { if (!same_marks(&w2, &w, other_env, (Scheme_Object *)init_rib)) {
other_env = NULL; other_env = NULL;
} }
if (other_env) { if (other_env) {
WRAP_POS_COPY(w3, prev); /* First, check simplications in v2l.
for (; !WRAP_POS_END_P(w3); WRAP_POS_INC(w3)) { If not in v2l, try prev. */
vp = WRAP_POS_FIRST(w3); if (!ok) {
if (SCHEME_VECTORP(vp)) { WRAP_POS_COPY(w3, prev);
psize = SCHEME_RENAME_LEN(vp); svl = v2l;
for (j = 0; j < psize; j++) { for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) {
if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+j], name)) { if (SCHEME_PAIRP(svl))
if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+psize+j], other_env)) { vp = SCHEME_CAR(svl);
ok = SCHEME_VEC_ELS(v)[0]; else
} else { vp = WRAP_POS_FIRST(w3);
ok = NULL; if (SCHEME_VECTORP(vp)) {
/* Alternate time/space tradeoff: could be psize = SCHEME_RENAME_LEN(vp);
SCHEME_VEC_ELS(vp)[2+psize+j], for (j = 0; j < psize; j++) {
which is the value from prev */ if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+j], name)) {
} if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+psize+j], other_env)) {
break; ok = SCHEME_VEC_ELS(v)[0];
} } else {
} ok = NULL;
if (j < psize) /* Alternate time/space tradeoff: could be
break; SCHEME_VEC_ELS(vp)[2+psize+j],
} which is the value from prev */
} }
if (WRAP_POS_END_P(w3) && SCHEME_FALSEP(other_env)) if (ok && SCHEME_PAIRP(svl)) {
ok = SCHEME_VEC_ELS(v)[0]; /* Need to overwrite old map, instead
} else of adding a new one. */
ok = NULL; ok_replace = vp;
ok_replace_index = 2 + psize + j;
}
break;
}
}
if (j < psize)
break;
}
if (SCHEME_PAIRP(svl))
svl = SCHEME_CDR(svl);
else {
WRAP_POS_INC(w3);
}
}
if (WRAP_POS_END_P(w3) && SCHEME_NULLP(svl) && SCHEME_FALSEP(other_env))
ok = SCHEME_VEC_ELS(v)[0];
} else
ok = NULL;
}
} else { } else {
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
if (same_marks(&w2, &w, scheme_false, (Scheme_Object *)init_rib)) if (same_marks(&w2, &w, scheme_false, (Scheme_Object *)init_rib))
ok = SCHEME_VEC_ELS(v)[0]; ok = SCHEME_VEC_ELS(v)[0];
else else
ok = NULL; ok = NULL;
} }
if (ok) { if (ok) {
SCHEME_VEC_ELS(v2)[2+size+pos] = ok; if (ok_replace) {
pos++; SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok;
} else {
SCHEME_VEC_ELS(v2)[2+size+pos] = ok;
pos++;
}
} }
} }
ii++; ii++;
@ -3875,8 +3900,6 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
SCHEME_VEC_ELS(v2)[1] = scheme_false; SCHEME_VEC_ELS(v2)[1] = scheme_false;
v2l = CONS(v2, v2l); v2l = CONS(v2, v2l);
WRAP_POS_COPY(prev, w);
} }
WRAP_POS_DEC(w); WRAP_POS_DEC(w);