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

360.1

Browse Source 
svn: r4897
This commit is contained in:
Matthew Flatt 2006-11-20 21:32:57 +00:00
parent fa348fffdf
commit c537bfb8ac
7 changed files with 4479 additions and 4341 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

File diff suppressed because it is too large Load Diff

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

@ -2207,7 +2207,8 @@ void create_skip_table(Scheme_Comp_Env *start_frame)
Scheme_Object *
scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
Scheme_Object *certs, Scheme_Object *in_modidx,
Scheme_Env **_menv, int *_protected)
Scheme_Env **_menv, int *_protected,
Scheme_Object **_lexical_binding_id)
{
Scheme_Comp_Env *frame;
int j = 0, p = 0, modpos, skip_stops = 0, mod_defn_phase, module_self_reference = 0;
@ -2261,7 +2262,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
&& scheme_stx_module_eq(find_id, frame->values[i], phase))
|| ((frame->flags & SCHEME_CAPTURE_LIFTED)
&& scheme_stx_bound_eq(find_id, frame->values[i], phase)))) {
/* Found a lambda- or let-bound variable: */
/* Found a lambda-, let-, etc. bound variable: */
/* First, check certs (don't bind with fewer certs): */
if (!(flags & SCHEME_NO_CERT_CHECKS)
&& !(frame->flags & (SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) {
@ -2272,6 +2273,10 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
}
}
/* Looks ok; return a lexical reference */
if (_lexical_binding_id) {
val = scheme_stx_remove_extra_marks(find_id, frame->values[i]);
*_lexical_binding_id = val;
}
if (flags & SCHEME_DONT_MARK_USE)
return scheme_make_local(scheme_local_type, 0);
else
@ -3365,7 +3370,7 @@ namespace_variable_value(int argc, Scheme_Object *argv[])
init_compile_data((Scheme_Comp_Env *)&inlined_e);
inlined_e.base.prefix = NULL;
v = scheme_lookup_binding(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, NULL, NULL, NULL, NULL);
v = scheme_lookup_binding(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, NULL, NULL, NULL, NULL, NULL);
if (v) {
if (!SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) {
use_map = -1;
@ -3558,7 +3563,7 @@ local_exp_time_value(int argc, Scheme_Object *argv[])
+ SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST),
scheme_current_thread->current_local_certs,
scheme_current_thread->current_local_modidx,
&menv, NULL);
&menv, NULL, NULL);
/* Deref globals */
if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type))

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

@ -3898,7 +3898,7 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
? SCHEME_RESOLVE_MODIDS
: 0),
certs, env->in_modidx,
&menv, NULL);
&menv, NULL, NULL);
if (SCHEME_STX_PAIRP(first))
*current_val = val;
@ -4046,10 +4046,11 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
normal = app_expander;
} else if (!SCHEME_STX_PAIRP(form)) {
if (SCHEME_STX_SYMBOLP(form)) {
Scheme_Object *find_name = form;
Scheme_Object *find_name = form, *lexical_binding_id;
int protected = 0;
while (1) {
lexical_binding_id = NULL;
var = scheme_lookup_binding(find_name, env,
SCHEME_NULL_FOR_UNBOUND
+ SCHEME_ENV_CONSTANTS_OK
@ -4066,7 +4067,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
? SCHEME_RESOLVE_MODIDS
: 0),
rec[drec].certs, env->in_modidx,
&menv, &protected);
&menv, &protected, &lexical_binding_id);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name);
@ -4119,11 +4120,14 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
else
return var;
} else {
SCHEME_EXPAND_OBSERVE_VARIABLE(rec[drec].observer, form, find_name);
if (lexical_binding_id) {
find_name = lexical_binding_id;
}
if (protected) {
/* Add a property to indicate that the name is protected */
find_name = scheme_stx_property(find_name, protected_symbol, scheme_true);
}
SCHEME_EXPAND_OBSERVE_VARIABLE(rec[drec].observer, form, find_name);
SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, find_name);
return find_name; /* which is usually == form */
}
@ -4165,7 +4169,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
? SCHEME_RESOLVE_MODIDS
: 0),
erec1.certs, env->in_modidx,
&menv, NULL);
&menv, NULL, NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
@ -4243,7 +4247,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_DONT_MARK_USE,
rec[drec].certs, env->in_modidx,
&menv, NULL);
&menv, NULL, NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name);
@ -4286,7 +4290,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_DONT_MARK_USE,
rec[drec].certs, env->in_modidx,
&menv, NULL);
&menv, NULL, NULL);
}
}
@ -7170,8 +7174,6 @@ static void *expand_k(void)
Scheme_Object *l;
l = scheme_frame_get_lifts(env);
if (SCHEME_PAIRP(l)) {
if (rename && !just_to_top)
obj = scheme_add_mark_barrier(obj);
obj = scheme_append(l, scheme_make_immutable_pair(obj, scheme_null));
obj = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
obj);
@ -7186,7 +7188,6 @@ static void *expand_k(void)
}
if (rename && !just_to_top) {
obj = scheme_add_mark_barrier(obj);
/* scheme_simplify_stx(obj, scheme_new_stx_simplify_cache()); */ /* too expensive */
}

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

@ -595,6 +595,8 @@ Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename);
Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib);
Scheme_Object *scheme_add_mark_barrier(Scheme_Object *o);
Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to);
#define mzMOD_RENAME_TOPLEVEL 0
#define mzMOD_RENAME_NORMAL 1
#define mzMOD_RENAME_MARKED 2
@ -1788,7 +1790,8 @@ Scheme_Comp_Env *scheme_require_renames(Scheme_Comp_Env *env);
Scheme_Object *scheme_lookup_binding(Scheme_Object *symbol, Scheme_Comp_Env *env, int flags,
Scheme_Object *certs, Scheme_Object *in_modidx,
Scheme_Env **_menv, int *_protected);
Scheme_Env **_menv, int *_protected,
Scheme_Object **_lexical_binding_id);
Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
Scheme_Comp_Env *upto);

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 360
#define MZSCHEME_VERSION_MINOR 0
#define MZSCHEME_VERSION_MINOR 1
#define MZSCHEME_VERSION "360" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "360.1" _MZ_SPECIAL_TAG

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

@ -327,6 +327,8 @@ XFORM_NONGCING static void DO_WRAP_POS_REVINIT(Wrap_Pos *w, Scheme_Object *k)
#define WRAP_POS_REVEND_P(w) (w.pos < 0)
#define WRAP_POS_DEC(w) --w.pos; if (w.pos >= 0) w.a = ((Wrap_Chunk *)SCHEME_CAR(w.l))->a[w.pos]
#define WRAP_POS_PLAIN_TAIL(w) (w.is_limb ? (w.pos ? NULL : w.l) : w.l)
/*========================================================================*/
/* initialization */
/*========================================================================*/
@ -2641,6 +2643,111 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
}
}
static Scheme_Object *prune_marks(Scheme_Stx *stx, Scheme_Object *keep_list)
/* Returns a new wrap */
{
WRAP_POS awl, acur_mark_l, shared_tail_l;
Scheme_Object *acur_mark, *w, *save_wraps = scheme_null, *acur_save_wraps = NULL, *shared_tail_save_wraps = NULL;
int wrap_c = 0, shared_tail_wrap_c = 0, acur_wrap_c = 0;
WRAP_POS_INIT(awl, stx->wraps);
/* Just so they're initialized: */
WRAP_POS_COPY(acur_mark_l, awl);
WRAP_POS_COPY(shared_tail_l, awl);
while (1) {
/* Skip over renames and cancelled marks: */
acur_mark = NULL;
while (1) {
if (WRAP_POS_END_P(awl))
break;
w = WRAP_POS_FIRST(awl);
if (SCHEME_NUMBERP(w) && IS_POSMARK(WRAP_POS_FIRST(awl))) {
if (acur_mark) {
if (SAME_OBJ(acur_mark, w)) {
acur_mark = NULL;
WRAP_POS_INC(awl);
} else
break;
} else {
acur_mark = WRAP_POS_FIRST(awl);
WRAP_POS_INC(awl);
WRAP_POS_COPY(acur_mark_l, awl);
acur_wrap_c = wrap_c;
acur_save_wraps = save_wraps;
}
} else {
save_wraps = scheme_make_pair(w, save_wraps);
wrap_c++;
WRAP_POS_INC(awl);
}
}
if (!acur_mark)
break;
/* Same mark? */
if (SCHEME_PAIRP(keep_list) && SAME_OBJ(acur_mark, SCHEME_CAR(keep_list))) {
save_wraps = scheme_make_pair(acur_mark, save_wraps);
wrap_c++;
keep_list = SCHEME_CDR(keep_list);
} else {
/* We need to drop the mark, so shift the shared tail */
WRAP_POS_COPY(shared_tail_l, acur_mark_l);
shared_tail_save_wraps = acur_save_wraps;
shared_tail_wrap_c = acur_wrap_c;
}
}
if (!shared_tail_save_wraps) {
w = scheme_null;
shared_tail_save_wraps = save_wraps;
shared_tail_wrap_c = wrap_c;
} else {
/* save_wraps is the set of wraps (in reverse order) that we want to
keep, but there could be a shared tail; build on shared_tail_l
with shared_tail_save_wraps: */
while (1) {
w = WRAP_POS_PLAIN_TAIL(shared_tail_l);
if (w)
break;
shared_tail_save_wraps = scheme_make_pair(WRAP_POS_FIRST(shared_tail_l),
shared_tail_save_wraps);
shared_tail_wrap_c++;
WRAP_POS_INC(shared_tail_l);
}
}
if (shared_tail_wrap_c) {
Wrap_Chunk *wc;
int i;
wc = MALLOC_WRAP_CHUNK(shared_tail_wrap_c);
wc->type = scheme_wrap_chunk_type;
wc->len = shared_tail_wrap_c;
for (i = shared_tail_wrap_c - 1;
!SCHEME_NULLP(shared_tail_save_wraps);
shared_tail_save_wraps = SCHEME_CDR(shared_tail_save_wraps), --i) {
wc->a[i] = SCHEME_CAR(shared_tail_save_wraps);
}
w = scheme_make_pair((Scheme_Object *)wc, w);
}
/* Construct the new id: */
{
Scheme_Object *certs;
certs = stx->certs;
stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
stx->wraps = w;
stx->certs = certs;
}
return (Scheme_Object *)stx;
}
#define QUICK_STACK_SIZE 10
/* Although resolve_env may call itself recursively, the recursion
@ -3367,6 +3474,22 @@ int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *id_certs,
return 0;
}
Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to)
{
WRAP_POS aw;
WRAP_POS bw;
WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
if (!same_marks(&aw, &bw, 0, NULL, NULL)) {
return prune_marks((Scheme_Stx *)a,
scheme_stx_extract_marks(relative_to));
}
return a;
}
/*========================================================================*/
/* stx and lists */
/*========================================================================*/

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

@ -1524,7 +1524,7 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
? SCHEME_RESOLVE_MODIDS
: 0),
rec[drec].certs, env->in_modidx,
&menv, NULL);
&menv, NULL, NULL);
if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) {
/* Redirect to a macro? */
@ -1587,7 +1587,7 @@ static Scheme_Object *
set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
Scheme_Env *menv = NULL;
Scheme_Object *name, *var, *fn, *rhs, *find_name;
Scheme_Object *name, *var, *fn, *rhs, *find_name, *lexical_binding_id;
int l;
SCHEME_EXPAND_OBSERVE_PRIM_SET(erec[drec].observer);
@ -1609,9 +1609,10 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
while (1) {
/* Make sure it's mutable, and check for redirects: */
lexical_binding_id = NULL;
var = scheme_lookup_binding(find_name, env, SCHEME_SETTING,
erec[drec].certs, env->in_modidx,
&menv, NULL);
&menv, NULL, &lexical_binding_id);
SCHEME_EXPAND_OBSERVE_RESOLVE(erec[drec].observer, find_name);
@ -1639,9 +1640,13 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec,
find_name = new_name;
menv = NULL;
} else
break;
} else
break;
} else {
if (lexical_binding_id) {
find_name = lexical_binding_id;
}
break;
}
}
if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
@ -1775,7 +1780,7 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
? SCHEME_RESOLVE_MODIDS
: 0),
rec[drec].certs, env->in_modidx,
&menv, NULL);
&menv, NULL, NULL);
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {