diff --git a/collects/scribblings/reference/read.scrbl b/collects/scribblings/reference/read.scrbl index ed8ef1c56e..0a8ae5e68c 100644 --- a/collects/scribblings/reference/read.scrbl +++ b/collects/scribblings/reference/read.scrbl @@ -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 diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 103a8fc957..65e8d3de09 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -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 diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 8b56bb7d0d..dcc449f04e 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -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, diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index a43193c912..2e865e81e3 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -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[]) { diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index b7a98fc4fc..b411c45983 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 0ca83d304e..680aede755 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -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) { diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 67e2bbd240..526b7f346f 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -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 diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 041c98381d..4ab47f9545 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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, diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 4d86f0c583..8de35328ca 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -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)