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

change internal definition expansion, simplifying, fixing douplicate-id checking, and fixing binding resolution through extensible ribs

Browse Source 
svn: r12563
This commit is contained in:
Matthew Flatt 2008-11-21 13:49:10 +00:00
parent 344ef56604
commit 937fd18b2a
7 changed files with 152 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2123,7 +2123,8 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
}
while (env != upto) {
if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) {
if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME
| SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) {
int i, count;
/* How many slots filled in the frame so far? This can change
@ -2311,6 +2312,26 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
stx = scheme_add_rename(stx, l);
}
}
} else if (env->flags & SCHEME_INTDEF_SHADOW) {
/* Just extract existing uids from identifiers, and don't need to
add renames to syntax objects. */
if (!env->uids) {
Scheme_Object **uids, *uid;
int i;
uids = MALLOC_N(Scheme_Object *, env->num_bindings);
env->uids = uids;
for (i = env->num_bindings; i--; ) {
uid = scheme_stx_moduleless_env(env->values[i]);
if (SCHEME_FALSEP(uid))
scheme_signal_error("intdef shadow binding is #f for %d/%s",
SCHEME_TYPE(env->values[i]),
scheme_write_to_string(SCHEME_STX_VAL(env->values[i]),
NULL));
env->uids[i] = uid;
}
}
}
env = env->next;

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

@ -778,7 +778,7 @@ scheme_signal_error (const char *msg, ...)
if (scheme_current_thread->current_local_env) {
char *s2 = " [during expansion]";
strcpy(buffer + len, s2);
len = strlen(s2);
len += strlen(s2);
}
buffer[len] = 0;

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

@ -4563,6 +4563,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
/* should be always NULL */
dest[i].observer = src[drec].observer;
dest[i].pre_unwrapped = 0;
dest[i].env_already = 0;
}
}
@ -4581,6 +4582,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec,
dest[i].certs = src[drec].certs;
dest[i].observer = src[drec].observer;
dest[i].pre_unwrapped = 0;
dest[i].env_already = 0;
}
}
@ -4603,6 +4605,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec,
lam[dlrec].certs = src[drec].certs;
lam[dlrec].observer = src[drec].observer;
lam[dlrec].pre_unwrapped = 0;
lam[dlrec].env_already = 0;
}
void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec,
@ -4850,6 +4853,7 @@ static void *compile_k(void)
rec.certs = NULL;
rec.observer = NULL;
rec.pre_unwrapped = 0;
rec.env_already = 0;
cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);
@ -6289,7 +6293,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (!SCHEME_STX_SYMBOLP(var))
scheme_wrong_syntax(NULL, var, first,
"name must be an identifier");
scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
// scheme_dup_symbol_check(&r, "internal definition", var, "binding", first);
vars = SCHEME_STX_CDR(vars);
cnt++;
}
@ -6359,6 +6363,16 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
scheme_set_local_syntax(cnt++, a, scheme_false, new_env);
}
/* Extend shared rib with renamings */
scheme_add_env_renames(rib, new_env, env);
/* Check for duplicates after extending the rib with renamings,
since the renamings properly track marks. */
for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
a = SCHEME_STX_CAR(l);
scheme_dup_symbol_check(&r, "internal definition", a, "binding", first);
}
if (!is_val) {
/* Evaluate and bind syntaxes */
scheme_prepare_exp_env(new_env->genv);
@ -6371,9 +6385,6 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
&pos);
}
/* Extend shared rib with renamings */
scheme_add_env_renames(rib, new_env, env);
/* Remember extended environment */
SCHEME_PTR1_VAL(ctx) = new_env;
env = new_env;
@ -6441,6 +6452,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
}
if (!more) {
/* We've converted to a letrec or letrec-values+syntaxes */
rec[drec].env_already = 1;
if (rec[drec].comp) {
result = scheme_compile_expr(result, env, rec, drec);
return scheme_make_pair(result, scheme_null);
@ -8720,6 +8734,7 @@ static void *expand_k(void)
erec1.certs = certs;
erec1.observer = observer;
erec1.pre_unwrapped = 0;
erec1.env_already = 0;
if (catch_lifts_key)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
@ -9201,7 +9216,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
l = scheme_add_rename(l, renaming);
if (for_expr) {
/* Package up expanded expr with the enviornment. */
/* Package up expanded expr with the environment. */
while (1) {
if (orig_env->flags & SCHEME_FOR_STOPS)
orig_env = orig_env->next;
@ -9552,6 +9567,7 @@ local_eval(int argc, Scheme_Object **argv)
rec.certs = certs;
rec.observer = observer;
rec.pre_unwrapped = 0;
rec.env_already = 0;
/* Evaluate and bind syntaxes */
expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);

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

@ -5773,6 +5773,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
erec1.certs = rec[drec].certs;
erec1.observer = rec[drec].observer;
erec1.pre_unwrapped = 0;
erec1.env_already = 0;
e = scheme_expand_expr(e, xenv, &erec1, 0);
}
@ -5975,6 +5976,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
mrec.certs = rec[drec].certs;
mrec.observer = NULL;
mrec.pre_unwrapped = 0;
mrec.env_already = 0;
if (!rec[drec].comp) {
Scheme_Expand_Info erec1;
@ -5984,6 +5986,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
erec1.certs = rec[drec].certs;
erec1.observer = rec[drec].observer;
erec1.pre_unwrapped = 0;
erec1.env_already = 0;
SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
}

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

@ -1837,6 +1837,7 @@ typedef struct Scheme_Compile_Expand_Info
char resolve_module_ids;
char pre_unwrapped;
int depth;
int env_already;
} Scheme_Compile_Expand_Info;
typedef Scheme_Compile_Expand_Info Scheme_Compile_Info;
@ -2301,6 +2302,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
#define SCHEME_FOR_STOPS 128
#define SCHEME_FOR_INTDEF 256
#define SCHEME_CAPTURE_LIFTED 512
#define SCHEME_INTDEF_SHADOW 1024
/* Flags used with scheme_static_distance */
#define SCHEME_ELIM_CONST 1

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

@ -2982,12 +2982,14 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
return scheme_false;
}
XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
Scheme_Object *barrier_env, Scheme_Object *ignore_rib)
XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
/* Compares the marks in two wraps lists. A result of 2 means that the
result depended on a barrier env. Use #f for barrier_env
to treat no rib envs as barriers; we check for barrier_env only in ribs
because simpliciation eliminates the need for these checks(?). */
result depended on a barrier env. For a rib-based renaming, we need
to check only up to the rib, and the barrier effect important for
when a rib-based renaming is layered with another renaming (such as
when an internal-definition-base local-expand is used to form a new
set of bindings, as in the unit form); simplification cleans up the
layers, so that we only need to check in ribs. */
{
WRAP_POS awl;
WRAP_POS bwl;
@ -3015,9 +3017,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
WRAP_POS_INC(awl);
}
} else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) {
if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(awl))) {
WRAP_POS_INC(awl);
} else if (SCHEME_FALSEP(barrier_env)) {
if (SCHEME_FALSEP(barrier_env)) {
WRAP_POS_INC(awl);
} else {
/* See if the barrier environment is in this rib. */
@ -3054,9 +3054,7 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
WRAP_POS_INC(bwl);
}
} else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) {
if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(bwl))) {
WRAP_POS_INC(bwl);
} else if (SCHEME_FALSEP(barrier_env)) {
if (SCHEME_FALSEP(barrier_env)) {
WRAP_POS_INC(bwl);
} else {
/* See if the barrier environment is in this rib. */
@ -3665,15 +3663,16 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
&& !no_lexical)) {
/* Lexical rename: */
Scheme_Object *rename, *renamed;
int ri, c, istart, iend, is_rib;
int ri, c, istart, iend;
Scheme_Lexical_Rib *is_rib;
if (rib) {
rename = rib->rename;
is_rib = rib;
rib = rib->next;
is_rib = 1;
} else {
rename = WRAP_POS_FIRST(wraps);
is_rib = 0;
is_rib = NULL;
}
c = SCHEME_RENAME_LEN(rename);
@ -3735,7 +3734,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
{
WRAP_POS w2;
WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
same = same_marks(&w2, &wraps, other_env, WRAP_POS_FIRST(wraps));
same = same_marks(&w2, &wraps, other_env);
if (!same)
EXPLAIN(printf("Different marks\n"));
}
@ -3755,7 +3754,11 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
o_rename_stack = CONS(CONS(other_env, envname),
o_rename_stack);
}
rib = NULL; /* skip rest of rib (if any) */
if (is_rib) {
/* skip rest of rib (if any) and future instances of the same rib */
rib = NULL;
skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs);
}
}
break;
@ -4092,7 +4095,7 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
WRAP_POS bw;
WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps);
if (!same_marks(&aw, &bw, ae, NULL))
if (!same_marks(&aw, &bw, ae))
return 0;
}
@ -4277,7 +4280,7 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *re
WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
if (!same_marks(&aw, &bw, NULL, NULL)) {
if (!same_marks(&aw, &bw, scheme_false)) {
Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps;
if (uid) {
/* Add a rename record: */
@ -4647,7 +4650,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
/* Check marks (now that we have the correct barriers). */
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)) {
other_env = NULL;
}
@ -4699,7 +4702,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
}
} else {
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))
ok = SCHEME_VEC_ELS(v)[0];
else
ok = NULL;
@ -6759,7 +6762,7 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv)
WRAP_POS_INIT(awl, stx->wraps);
WRAP_POS_INIT_END(ewl);
if (same_marks(&awl, &ewl, scheme_false, NULL))
if (same_marks(&awl, &ewl, scheme_false))
return scheme_true;
else
return scheme_false;

58
src/mzscheme/src/syntax.c
View File

@ -4092,6 +4092,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
Scheme_Object *first = NULL;
Scheme_Compiled_Let_Value *last = NULL, *lv;
DupCheckRecord r;
int rec_env_already = rec[drec].env_already;
i = scheme_stx_proper_list_length(form);
if (i < 3)
@ -4160,8 +4161,14 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
names = MALLOC_N(Scheme_Object *, num_bindings);
if (frame_already)
frame = frame_already;
else
frame = scheme_new_compilation_frame(num_bindings, 0, origenv, rec[drec].certs);
else {
frame = scheme_new_compilation_frame(num_bindings,
(rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
origenv,
rec[drec].certs);
if (rec_env_already)
frame_already = frame;
}
env = frame;
recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1));
@ -4172,7 +4179,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
defname = scheme_check_name_property(form, defname);
if (!star) {
if (!star && !frame_already) {
scheme_begin_dup_symbol_check(&r, env);
}
@ -4216,7 +4223,7 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
names[k++] = name;
}
if (!star) {
if (!star && !frame_already) {
for (m = pre_k; m < k; m++) {
scheme_dup_symbol_check(&r, NULL, names[m], "binding", form);
}
@ -4319,6 +4326,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
Scheme_Comp_Env *use_env, *env;
Scheme_Expand_Info erec1;
DupCheckRecord r;
int rec_env_already = erec[drec].env_already;
vars = SCHEME_STX_CDR(form);
@ -4385,7 +4393,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
}
/* Note: no more letstar handling needed after this point */
if (!env_already && !rec_env_already)
scheme_begin_dup_symbol_check(&r, origenv);
vlist = scheme_null;
@ -4405,6 +4413,7 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
{
DupCheckRecord r2;
Scheme_Object *names = name;
if (!env_already && !rec_env_already)
scheme_begin_dup_symbol_check(&r2, origenv);
while (SCHEME_STX_PAIRP(names)) {
name = SCHEME_STX_CAR(names);
@ -4412,8 +4421,10 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
scheme_check_identifier(NULL, name, NULL, origenv, form);
vlist = cons(name, vlist);
if (!env_already && !rec_env_already) {
scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
scheme_dup_symbol_check(&r, NULL, name, "binding", form);
}
names = SCHEME_STX_CDR(names);
}
@ -4430,7 +4441,10 @@ do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info
if (env_already)
env = env_already;
else
env = scheme_add_compilation_frame(vlist, origenv, 0, erec[drec].certs);
env = scheme_add_compilation_frame(vlist,
origenv,
(rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
erec[drec].certs);
if (letrec)
use_env = env;
@ -5526,6 +5540,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
rec1.certs = rec[drec].certs;
rec1.observer = NULL;
rec1.pre_unwrapped = 0;
rec1.env_already = 0;
if (for_stx) {
names = defn_targets_syntax(names, exp_env, &rec1, 0);
@ -5717,6 +5732,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
mrec.certs = certs;
mrec.observer = NULL;
mrec.pre_unwrapped = 0;
mrec.env_already = 0;
a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
@ -5805,9 +5821,11 @@ do_letrec_syntaxes(const char *where,
Scheme_Object *form, *bindings, *var_bindings, *body, *v;
Scheme_Object *names_to_disappear;
Scheme_Comp_Env *stx_env, *var_env, *rhs_env;
int cnt, stx_cnt, var_cnt, i, j, depth, saw_var;
int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already;
DupCheckRecord r;
env_already = rec[drec].env_already;
form = SCHEME_STX_CDR(forms);
if (!SCHEME_STX_PAIRP(form))
scheme_wrong_syntax(NULL, NULL, forms, NULL);
@ -5823,6 +5841,9 @@ do_letrec_syntaxes(const char *where,
scheme_rec_add_certs(rec, drec, forms);
if (env_already)
stx_env = origenv;
else
stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);
rhs_env = stx_env;
@ -5846,7 +5867,7 @@ do_letrec_syntaxes(const char *where,
else
names_to_disappear = NULL;
if (!env_already)
scheme_begin_dup_symbol_check(&r, stx_env);
/* Pass 1: Check and Rename */
@ -5881,8 +5902,10 @@ do_letrec_syntaxes(const char *where,
for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
a = SCHEME_STX_CAR(l);
if (!env_already) {
scheme_check_identifier(where, a, NULL, stx_env, forms);
scheme_dup_symbol_check(&r, where, a, "binding", forms);
}
cnt++;
}
if (i)
@ -5895,16 +5918,21 @@ do_letrec_syntaxes(const char *where,
var_cnt = cnt - stx_cnt;
}
if (!env_already)
scheme_add_local_syntax(stx_cnt, stx_env);
if (saw_var)
var_env = scheme_new_compilation_frame(var_cnt, 0, stx_env, rec[drec].certs);
else
if (saw_var) {
var_env = scheme_new_compilation_frame(var_cnt,
(env_already ? SCHEME_INTDEF_SHADOW : 0),
stx_env,
rec[drec].certs);
} else
var_env = NULL;
for (i = 0; i < (var_env ? 2 : 1) ; i++) {
for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) {
cnt = (i ? var_cnt : stx_cnt);
if (cnt > 0) {
/* Add new syntax names to the environment: */
/* Add new syntax/variable names to the environment: */
j = 0;
for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *l;
@ -5949,6 +5977,7 @@ do_letrec_syntaxes(const char *where,
scheme_prepare_exp_env(stx_env->genv);
if (!env_already) {
i = 0;
for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
@ -5968,10 +5997,11 @@ do_letrec_syntaxes(const char *where,
stx_env, rhs_env,
&i);
}
}
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer);
if (names_to_disappear) {
if (!env_already && names_to_disappear) {
/* Need to add renaming for disappeared bindings. If they
originated for internal definitions, then we need both
pre-renamed and renamed, since some might have been