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

safe-for-space fixes for the interepreter; syntax-local-lift-provide

Browse Source 
svn: r15154
This commit is contained in:
Matthew Flatt 2009-06-12 17:46:25 +00:00
parent 50e9a86dbc
commit 3ce6cbb737
9 changed files with 165 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/scribblings/reference/read.scrbl
View File

@ -155,7 +155,7 @@ If @scheme[in] does not specify a @tech{reader language}, then
A parameter that controls parsing and printing of symbols. When this
parameter's value is @scheme[#f], the reader case-folds symbols (e.g.,
producing @scheme['hi] when the input is any one of \litchar{hi},
producing @scheme['hi] when the input is any one of @litchar{hi},
@litchar{Hi}, @litchar{HI}, or @litchar{hI}). The parameter also
affects the way that @scheme[write] prints symbols containing
uppercase characters; if the parameter's value is @scheme[#f], then

19
collects/scribblings/reference/stx-trans.scrbl
View File

@ -453,13 +453,13 @@ for caching lift information to avoid redundant lifts.
Cooperates with the @scheme[module] form to insert @scheme[stx] as
a top-level declaration at the end of the module currently being
expanded. If the current expression being transformed is not within a
@scheme[module] form, or if it is not a run-time expression, then the
@exnraise[exn:fail:contract]. If the current expression being
expanded. If the current expression being
transformed is not in the module top-level, then @scheme[stx] is
eventually expanded in an expression context.
@transform-time[]}
@transform-time[] If the current expression being transformed is not
within a @scheme[module] form, or if it is not a run-time expression,
then the @exnraise[exn:fail:contract].}
@defproc[(syntax-local-lift-require [raw-require-spec any/c][stx syntax?])
@ -481,6 +481,17 @@ resulting syntax object (assuming that the lexical information of
@transform-time[]}
@defproc[(syntax-local-lift-provide [raw-provide-spec-stx syntax?])
void?]{
Lifts a @scheme[#%provide] form corresponding to
@scheme[raw-provide-spec-stx] to the top of the module currently being
expanded.
@transform-time[] If the current expression being transformed is not
within a @scheme[module] form, or if it is not a run-time expression,
then the @exnraise[exn:fail:contract]. }
@defproc[(syntax-local-name) (or/c symbol? #f)]{
Returns an inferred name for the expression position being

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

@ -1,5 +1,5 @@
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,48,46,51,50,0,0,0,1,0,0,3,0,12,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,48,46,52,50,0,0,0,1,0,0,3,0,12,0,
17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78,
0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
177,0,179,0,193,0,1,1,27,1,35,1,43,1,53,1,89,1,128,1,167,
@ -100,7 +100,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 2048);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,48,46,51,59,0,0,0,1,0,0,13,0,18,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,48,46,52,59,0,0,0,1,0,0,13,0,18,0,
35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226,
0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1,
199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100,
@ -342,7 +342,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 5016);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,48,46,51,8,0,0,0,1,0,0,6,0,19,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,48,46,52,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,115,0,0,0,6,1,0,0,65,113,117,111,116,
101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
@ -360,7 +360,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 299);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,48,46,51,52,0,0,0,1,0,0,11,0,38,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,48,46,52,52,0,0,0,1,0,0,11,0,38,0,
44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220,
0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1,
89,1,192,1,237,1,1,2,30,2,61,2,117,2,127,2,174,2,184,2,191,

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

@ -113,6 +113,7 @@ static Scheme_Object *local_lift_exprs(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);
@ -560,6 +561,7 @@ static void make_kernel_env(void)
GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env);
{
Scheme_Object *sym;
@ -1419,7 +1421,8 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
}
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data,
Scheme_Object *end_stmts, Scheme_Object *context_key, Scheme_Object *requires)
Scheme_Object *end_stmts, Scheme_Object *context_key,
Scheme_Object *requires, Scheme_Object *provides)
{
Scheme_Lift_Capture_Proc *pp;
Scheme_Object *vec;
@ -1427,7 +1430,7 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
*pp = cp;
vec = scheme_make_vector(7, NULL);
vec = scheme_make_vector(8, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_null;
SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
SCHEME_VEC_ELS(vec)[2] = data;
@ -1435,6 +1438,7 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
SCHEME_VEC_ELS(vec)[4] = context_key;
SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false);
SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */
SCHEME_VEC_ELS(vec)[7] = provides;
COMPILE_DATA(env)->lifts = vec;
}
@ -1453,7 +1457,7 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com
p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env);
vec = scheme_make_vector(7, NULL);
vec = scheme_make_vector(8, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_false;
SCHEME_VEC_ELS(vec)[1] = scheme_void;
SCHEME_VEC_ELS(vec)[2] = scheme_void;
@ -1461,6 +1465,7 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com
SCHEME_VEC_ELS(vec)[4] = scheme_false;
SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */
SCHEME_VEC_ELS(vec)[6] = scheme_null;
SCHEME_VEC_ELS(vec)[7] = scheme_false;
COMPILE_DATA(env)->lifts = vec;
}
@ -1468,7 +1473,7 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com
Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env)
{
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0];
return scheme_reverse(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]);
}
Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env)
@ -1481,6 +1486,11 @@ Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env)
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6];
}
Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env)
{
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7];
}
void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env)
{
Scheme_Object **ns, **vs;
@ -5125,6 +5135,47 @@ static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[])
return form;
}
static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env;
Scheme_Object *pr, *form, *local_mark;
form = argv[0];
if (!SCHEME_STXP(form))
scheme_wrong_type("syntax-local-lift-provide", "syntax", 1, argc, argv);
env = scheme_current_thread->current_local_env;
local_mark = scheme_current_thread->current_local_mark;
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-provide: not currently transforming");
while (env) {
if (COMPILE_DATA(env)->lifts
&& SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7])) {
break;
} else
env = env->next;
}
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-provide: not expanding in a module run-time body");
form = scheme_add_remove_mark(form, local_mark);
form = scheme_datum_to_syntax(scheme_make_pair(scheme_datum_to_syntax(scheme_intern_symbol("#%provide"),
scheme_false, scheme_sys_wraps(env),
0, 0),
scheme_make_pair(form, scheme_null)),
form, scheme_false, 0, 0);
pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7]);
SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7] = pr;
return scheme_void;
}
static Scheme_Object *
make_set_transformer(int argc, Scheme_Object *argv[])
{

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

@ -5081,7 +5081,7 @@ static void *compile_k(void)
before the rest. */
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv),
scheme_false, scheme_false, scheme_null);
scheme_false, scheme_false, scheme_null, scheme_false);
form = scheme_check_immediate_macro(form,
cenv, &rec, 0,
0, &gval, NULL, NULL);
@ -5122,7 +5122,7 @@ static void *compile_k(void)
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv),
scheme_false, scheme_false, scheme_null);
scheme_false, scheme_false, scheme_null, scheme_false);
scheme_init_compile_recs(&rec, 0, &rec2, 1);
@ -6258,28 +6258,45 @@ static Scheme_Object *pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Sche
{
Scheme_Comp_Env **ip = (Scheme_Comp_Env **)_ip, *naya;
Scheme_Object *ids, *id;
int pos;
naya = scheme_new_compilation_frame(1, SCHEME_CAPTURE_LIFTED, (*ip)->next, NULL);
pos = scheme_list_length(*_ids);
naya = scheme_new_compilation_frame(pos, SCHEME_CAPTURE_LIFTED, (*ip)->next, NULL);
(*ip)->next = naya;
*ip = naya;
for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) {
id = SCHEME_CAR(ids);
scheme_add_compilation_binding(0, id, naya);
scheme_add_compilation_binding(--pos, id, naya);
}
return icons(*_ids, icons(expr, scheme_null));
}
static Scheme_Object *add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env,
Scheme_Object *orig_form)
Scheme_Object *orig_form, int comp_rev)
{
Scheme_Object *revl = scheme_null, *a;
Scheme_Object *revl, *a;
if (SCHEME_NULLP(l)) return obj;
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
revl = icons(SCHEME_CAR(l), revl);
revl = scheme_reverse(l);
if (comp_rev) {
/* We've already compiled the body of this let
with the bindings in reverse order. So insert a series of `lets'
to match that order: */
if (!SCHEME_NULLP(SCHEME_CDR(l))) {
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = scheme_reverse(SCHEME_CAR(SCHEME_CAR(l)));
for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) {
obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
icons(icons(icons(icons(SCHEME_CAR(a), scheme_null), icons(SCHEME_CAR(a), scheme_null)),
scheme_null),
icons(obj, scheme_null)));
}
}
}
}
for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) {
@ -6289,7 +6306,9 @@ static Scheme_Object *add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Sch
icons(obj, scheme_null)));
}
return scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0);
obj = scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0);
return obj;
}
static Scheme_Object *compile_expand_expr_lift_to_let_k(void);
@ -6355,7 +6374,8 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
context_key = scheme_generate_lifts_key();
scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, context_key, NULL);
scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false,
context_key, NULL, scheme_false);
if (rec[drec].comp) {
scheme_init_compile_recs(rec, drec, recs, 2);
@ -6381,7 +6401,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
SCHEME_IPTR_VAL(o) = form;
} else
o = form;
form = add_lifts_as_let(o, l, env, orig_form);
form = add_lifts_as_let(o, l, env, orig_form, rec[drec].comp);
SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(rec[drec].observer, form);
form = compile_expand_expr_lift_to_let(form, env, recs, 1);
if (rec[drec].comp)
@ -7718,8 +7738,12 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { \
runstack[SCHEME_LOCAL_POS(obj)] = NULL; \
}
# define SFS_CLEAR_RUNSTACK_ONE(runstack, pos) runstack[pos] = NULL
# define SFS_CLEAR_RUNSTACK(runstack, i, n) for (i = n; i--; ) { SFS_CLEAR_RUNSTACK_ONE(runstack, i); }
#else
# define EVAL_SFS_CLEAR(rs, obj) /* empty */
# define SFS_CLEAR_RUNSTACK_ONE(runstack, pos) /* empty */
# define SFS_CLEAR_RUNSTACK(runstack, i, n) /* empty */
#endif
#define RUNSTACK_START MZ_RUNSTACK_START
@ -7911,16 +7935,16 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
return NULL; /* Doesn't get here */
}
stack = RUNSTACK = old_runstack - num_params;
CHECK_RUNSTACK(p, RUNSTACK);
RUNSTACK_CHANGED();
if (rands != stack) {
int n = num_params;
while (n--) {
stack[n] = rands[n];
}
}
stack = RUNSTACK = old_runstack - num_params;
CHECK_RUNSTACK(p, RUNSTACK);
RUNSTACK_CHANGED();
if (rands != stack) {
int n = num_params;
while (n--) {
stack[n] = rands[n];
}
}
}
} else {
if (num_rands) {
@ -8241,6 +8265,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
stack = PUSH_RUNSTACK(p, RUNSTACK, num_rands);
RUNSTACK_CHANGED();
UPDATE_THREAD_RSPTR();
SFS_CLEAR_RUNSTACK(RUNSTACK, k, num_rands);
/* Inline local & global variable lookups for speed */
switch (GET_FIRST_EVAL) {
@ -8334,6 +8359,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
rands = PUSH_RUNSTACK(p, RUNSTACK, 1);
RUNSTACK_CHANGED();
UPDATE_THREAD_RSPTR();
SFS_CLEAR_RUNSTACK_ONE(RUNSTACK, 0);
/* Inline local & global variable lookups for speed */
switch (flags & 0x7) {
@ -8412,7 +8438,9 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
rands = PUSH_RUNSTACK(p, RUNSTACK, 2);
RUNSTACK_CHANGED();
UPDATE_THREAD_RSPTR();
SFS_CLEAR_RUNSTACK_ONE(RUNSTACK, 0);
SFS_CLEAR_RUNSTACK_ONE(RUNSTACK, 1);
/* Inline local & global variable lookups for speed */
switch (flags & 0x7) {
case SCHEME_EVAL_CONSTANT:
@ -8693,6 +8721,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
UPDATE_THREAD_RSPTR();
{
GC_CAN_IGNORE Scheme_Object *val;
SFS_CLEAR_RUNSTACK_ONE(RUNSTACK, 0);
val = _scheme_eval_linked_expr_wp(lo->value, p);
RUNSTACK[0] = val;
}
@ -9112,7 +9141,8 @@ static void *expand_k(void)
scheme_frame_captures_lifts(env,
(as_local < 0) ? pair_lifted : scheme_make_lifted_defn, data,
scheme_false, catch_lifts_key,
(!as_local && catch_lifts_key) ? scheme_null : NULL);
(!as_local && catch_lifts_key) ? scheme_null : NULL,
scheme_false);
}
if (just_to_top) {
@ -9129,7 +9159,7 @@ static void *expand_k(void)
|| SCHEME_PAIRP(rl)) {
l = scheme_append(rl, l);
if (as_local < 0)
obj = add_lifts_as_let(obj, l, env, scheme_false);
obj = add_lifts_as_let(obj, l, env, scheme_false, 0);
else
obj = add_lifts_as_begin(obj, l, env);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
@ -9654,7 +9684,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
scheme_frame_captures_lifts(env,
(catch_lifts < 0) ? pair_lifted : scheme_make_lifted_defn, data,
scheme_false,
catch_lifts_key, NULL);
catch_lifts_key, NULL,
scheme_false);
}
memset(drec, 0, sizeof(drec));
@ -9678,7 +9709,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
if (catch_lifts_key) {
if (catch_lifts < 0)
xl = add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l);
xl = add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l, 0);
else
xl = add_lifts_as_begin(xl, scheme_frame_get_lifts(env), env);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl);

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

@ -6070,8 +6070,11 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
p = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(xenv)
: scheme_null);
prev_p = (maybe_has_lifts
? scheme_frame_get_provide_lifts(xenv)
: scheme_null);
scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv),
p, lift_ctx, req_data);
p, lift_ctx, req_data, prev_p);
maybe_has_lifts = 1;
{
@ -6116,8 +6119,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_flatten_begin(e, fm);
SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm);
if (SCHEME_STX_NULLP(fm)) {
e = scheme_frame_get_provide_lifts(xenv);
e = scheme_reverse(e);
fm = scheme_frame_get_end_statement_lifts(xenv);
fm = scheme_reverse(fm);
if (!SCHEME_NULLP(e))
fm = scheme_append(fm, e);
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
maybe_has_lifts = 0;
if (SCHEME_NULLP(fm)) {
@ -6228,7 +6235,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_prepare_exp_env(env->genv);
scheme_prepare_compile_env(env->genv->exp_env);
eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, req_data);
scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false,
req_data, scheme_false);
oenv = (for_stx ? eenv : env);
@ -6407,8 +6415,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* If we're out of declarations, check for lifted-to-end: */
if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) {
e = scheme_frame_get_provide_lifts(xenv);
e = scheme_reverse(e);
fm = scheme_frame_get_end_statement_lifts(xenv);
fm = scheme_reverse(fm);
if (!SCHEME_NULLP(e))
fm = scheme_append(fm, e);
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
maybe_has_lifts = 0;
}
@ -6493,7 +6505,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
l = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(cenv)
: scheme_null);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data);
ll = (maybe_has_lifts
? scheme_frame_get_provide_lifts(cenv)
: scheme_null);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll);
maybe_has_lifts = 1;
if (kind == 2)
@ -6546,12 +6561,19 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* If we're out of declarations, check for lifted-to-end: */
if (SCHEME_NULLP(p) && maybe_has_lifts) {
int expr_cnt;
e = scheme_frame_get_provide_lifts(cenv);
e = scheme_reverse(e);
p = scheme_frame_get_end_statement_lifts(cenv);
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, scheme_reverse(p));
p = scheme_reverse(p);
expr_cnt = scheme_list_length(p);
if (!SCHEME_NULLP(e))
p = scheme_append(p, e);
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p);
for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(1));
e = scheme_make_pair(SCHEME_CAR(ll), (expr_cnt > 0) ? scheme_make_integer(1) : scheme_make_integer(3));
SCHEME_CAR(ll) = e;
expr_cnt--;
}
maybe_has_lifts = 0;
if (prev_p) {

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 952
#define EXPECTED_PRIM_COUNT 953
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -2088,11 +2088,13 @@ Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env);
typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *);
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data,
Scheme_Object *end_stmts, Scheme_Object *context_key, Scheme_Object *require_lifts);
Scheme_Object *end_stmts, Scheme_Object *context_key,
Scheme_Object *require_lifts, Scheme_Object *provide_lifts);
void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_generate_lifts_key(void);
Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path,

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.0.3"
#define MZSCHEME_VERSION "4.2.0.4"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)