From 17ad24945b9d7d0e4ce650df6da2873fe70a0076 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Jan 2009 21:46:40 +0000 Subject: [PATCH] syntax-local-lift-require svn: r13075 --- .../scribblings/reference/stx-trans.scrbl | 18 +++ collects/scribblings/reference/syntax.scrbl | 2 +- collects/sirmail/readr.ss | 2 +- doc/release-notes/mzscheme/HISTORY.txt | 6 +- src/mred/wxme/wx_mline.cxx | 10 +- src/mzscheme/src/env.c | 99 ++++++++++++- src/mzscheme/src/error.c | 2 +- src/mzscheme/src/eval.c | 40 ++++-- src/mzscheme/src/module.c | 133 ++++++++++++++++-- src/mzscheme/src/schminc.h | 4 +- src/mzscheme/src/schpriv.h | 13 +- src/mzscheme/src/schvers.h | 4 +- 12 files changed, 293 insertions(+), 40 deletions(-) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index a7183c2278..9ca81d5210 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -340,6 +340,24 @@ eventually expanded in an expression context. @transform-time[]} +@defproc[(syntax-local-lift-require [quoted-raw-require-spec any/c][stx syntax?]) + syntax?]{ + +Lifts a @scheme[#%require] form corresponding to +@scheme[quoted-raw-require-spec] to the top-level or to the top of the +module currently being expanded, wrapping it with @scheme[for-meta] if +the current expansion context is not @tech{phase level} 0. + +The resulting syntax object is the same as @scheme[stx], except that a +fresh @tech{syntax mark} is added. The same @tech{syntax mark} is +added to the lifted @scheme[#%require] form, so that the +@scheme[#%require] form can bind uses of imported identifiers in the +resulting syntax object (assuming that the lexical information of +@scheme[stx] includes the binding environment into which the +@scheme[#%require] is lifted). + +@transform-time[]} + @defproc[(syntax-local-name) (or/c symbol? #f)]{ Returns an inferred name for the expression position being diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 77ed5e2701..59b70b3eaa 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -606,7 +606,7 @@ export name, though the same binding can be specified with the multiple symbolic names.} -@defform[(for-meta require-spec ...)]{See @scheme[require] and @scheme[provide].} +@defform[(for-meta phase-level require-spec ...)]{See @scheme[require] and @scheme[provide].} @defform[(for-syntax require-spec ...)]{See @scheme[require] and @scheme[provide].} @defform[(for-template require-spec ...)]{See @scheme[require] and @scheme[provide].} @defform[(for-label require-spec ...)]{See @scheme[require] and @scheme[provide].} diff --git a/collects/sirmail/readr.ss b/collects/sirmail/readr.ss index 08553388dd..8ede4cd3e5 100644 --- a/collects/sirmail/readr.ss +++ b/collects/sirmail/readr.ss @@ -1018,7 +1018,7 @@ (lambda (w e) (purge-marked/update-headers))) (send global-keymap add-function "gc" - (lambda (w e) (collect-garbage) (collect-garbage))) + (lambda (w e) (collect-garbage) (collect-garbage) (dump-memory-stats))) (send global-keymap add-function "show-memory-graph" (lambda (w e) (show-memory-graph))) diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index ebfcfd7801..28df148eb8 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,6 +1,5 @@ -Somewhere in there: - function contracts now preserve tail recursion in many cases; the - 'any' contract is no longer special. +Version 4.1.3.10 +Added syntax-local-lift-require Version 4.1.3.8 Added procedure-rename @@ -15,6 +14,7 @@ Version 4.1.3.6 Memory accounting changed to bias charges to parent instead of children Version 4.1.3.3 +Function contracts preserve tail recursion in many cases Added compile-context-preservation-enabled Added exception-backtrace support for x86_84+JIT Added scheme/package, scheme/splicing diff --git a/src/mred/wxme/wx_mline.cxx b/src/mred/wxme/wx_mline.cxx index afaa853190..60b7ac05cf 100644 --- a/src/mred/wxme/wx_mline.cxx +++ b/src/mred/wxme/wx_mline.cxx @@ -321,7 +321,7 @@ void wxMediaLine::Delete(wxMediaLine **root) else x = v->right; - x->parent = v->parent; + x->parent = v->parent; /* x could be NIL; fixup at end */ if (PTREQ(v->parent, NIL)) *root = x; @@ -448,6 +448,11 @@ void wxMediaLine::Delete(wxMediaLine **root) SET_BLACK(x); } + if (PTRNE(NIL->parent, NIL)) { + /* fixup: we set NIL's parent above */ + NIL->parent = NIL; + } + right = left = NIL; DELETE_OBJ this; } @@ -594,7 +599,8 @@ wxMediaParagraph *wxMediaLine::GetParagraphStyle(Bool *first) } else { \ node = node->parent; \ } \ - } \ + } + void wxMediaLine::SetLength(long len) { diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 2cd890ec5c..90aff15d8e 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -110,6 +110,7 @@ static Scheme_Object *local_module_expanding_provides(int argc, Scheme_Object *a static Scheme_Object *local_lift_expr(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 *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[]); @@ -550,6 +551,7 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env); 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); { Scheme_Object *sym; @@ -1366,7 +1368,7 @@ 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 *end_stmts, Scheme_Object *context_key, Scheme_Object *requires) { Scheme_Lift_Capture_Proc *pp; Scheme_Object *vec; @@ -1374,16 +1376,45 @@ 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(5, NULL); + vec = scheme_make_vector(7, NULL); SCHEME_VEC_ELS(vec)[0] = scheme_null; SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp; SCHEME_VEC_ELS(vec)[2] = data; SCHEME_VEC_ELS(vec)[3] = end_stmts; 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 */ COMPILE_DATA(env)->lifts = vec; } +void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env) +{ + while (orig_env) { + if ((COMPILE_DATA(orig_env)->lifts) + && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(orig_env)->lifts)[5])) + break; + orig_env = orig_env->next; + } + + if (orig_env) { + Scheme_Object *vec, *p; + + p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env); + + vec = scheme_make_vector(7, NULL); + SCHEME_VEC_ELS(vec)[0] = scheme_false; + SCHEME_VEC_ELS(vec)[1] = scheme_void; + SCHEME_VEC_ELS(vec)[2] = scheme_void; + SCHEME_VEC_ELS(vec)[3] = scheme_false; + 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; + + COMPILE_DATA(env)->lifts = vec; + } +} + Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env) { return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]; @@ -1394,6 +1425,11 @@ Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env) return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]; } +Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env) +{ + return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]; +} + void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env) { Scheme_Object **ns, **vs; @@ -4748,6 +4784,10 @@ local_lift_expr(int argc, Scheme_Object *argv[]) env = env->next; } + if (env) + if (SCHEME_FALSEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0])) + env = NULL; + if (!env) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-lift-expression: no lift target"); @@ -4851,6 +4891,61 @@ local_lift_end_statement(int argc, Scheme_Object *argv[]) return scheme_void; } +static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]) +{ + Scheme_Comp_Env *env; + Scheme_Object *local_mark, *mark, *data, *pr, *form; + long phase; + + if (!SCHEME_STXP(argv[1])) + scheme_wrong_type("syntax-local-lift-require", "syntax", 1, argc, argv); + + env = scheme_current_thread->current_local_env; + local_mark = scheme_current_thread->current_local_mark; + phase = env->genv->phase; + + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "syntax-local-lift-require: not currently transforming"); + + data = NULL; + + while (env) { + if (COMPILE_DATA(env)->lifts + && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5])) { + data = SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5]; + if (SCHEME_RPAIRP(data) + && !SCHEME_CAR(data)) { + env = (Scheme_Comp_Env *)SCHEME_CDR(data); + } else + break; + } else + env = env->next; + } + + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "syntax-local-lift-requires: could not find target context"); + + + mark = scheme_new_mark(); + + if (SCHEME_RPAIRP(data)) + form = scheme_parse_lifted_require(argv[0], phase, mark, SCHEME_CAR(data)); + else + form = scheme_toplevel_require_for_expand(argv[0], phase, env, mark); + + pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]); + SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6] = pr; + + form = argv[1]; + form = scheme_add_remove_mark(form, local_mark); + form = scheme_add_remove_mark(form, mark); + form = scheme_add_remove_mark(form, local_mark); + + return form; +} + static Scheme_Object * make_set_transformer(int argc, Scheme_Object *argv[]) { diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 4422763fbb..446d809fe4 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -1218,7 +1218,7 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc, name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1); #endif } else if (SCHEME_STRUCTP(proc)) { - name = proc; + name = (const char *)proc; mina = -1; maxa = 0; } else { diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index e93bcc8f90..2fc414ca14 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -4911,7 +4911,7 @@ static void *compile_k(void) int writeable, for_eval, rename, enforce_consts, comp_flags; Scheme_Env *genv; Scheme_Compile_Info rec, rec2; - Scheme_Object *o, *tl_queue; + Scheme_Object *o, *rl, *tl_queue; Scheme_Compilation_Top *top; Resolve_Prefix *rp; Resolve_Info *ri; @@ -4973,7 +4973,8 @@ static void *compile_k(void) find one, break it up to eval first expression before the rest. */ while (1) { - scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_false); + scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), + scheme_false, scheme_false, scheme_null); form = scheme_check_immediate_macro(form, cenv, &rec, 0, 0, &gval, NULL, NULL); @@ -4989,10 +4990,13 @@ static void *compile_k(void) } else break; } else { + rl = scheme_frame_get_require_lifts(cenv); o = scheme_frame_get_lifts(cenv); - if (!SCHEME_NULLP(o)) { + if (!SCHEME_NULLP(o) + || !SCHEME_NULLP(rl)) { tl_queue = scheme_make_pair(form, tl_queue); tl_queue = scheme_append(o, tl_queue); + tl_queue = scheme_append(rl, tl_queue); form = SCHEME_CAR(tl_queue); tl_queue = SCHEME_CDR(tl_queue); } @@ -5010,7 +5014,8 @@ static void *compile_k(void) Scheme_Object *l, *prev_o = NULL; while (1) { - scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_false); + scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), + scheme_false, scheme_false, scheme_null); scheme_init_compile_recs(&rec, 0, &rec2, 1); @@ -5031,10 +5036,13 @@ static void *compile_k(void) /* If any definitions were lifted in the process of compiling o, we need to fold them in. */ l = scheme_frame_get_lifts(cenv); - if (!SCHEME_NULLP(l)) { - l = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0), - l); - form = scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0); + rl = scheme_frame_get_require_lifts(cenv); + if (!SCHEME_NULLP(l) + || !SCHEME_NULLP(rl)) { + l = scheme_append(rl, l); + rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0), + rl); + form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0); prev_o = o; } else break; @@ -6213,7 +6221,7 @@ 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); + scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, context_key, NULL); if (rec[drec].comp) { scheme_init_compile_recs(rec, drec, recs, 2); @@ -8877,7 +8885,9 @@ static void *expand_k(void) erec1.comp_flags = comp_flags; if (catch_lifts_key) - scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key); + scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), + scheme_false, catch_lifts_key, + (!as_local && catch_lifts_key) ? scheme_null : NULL); if (just_to_top) { Scheme_Object *gval; @@ -8886,9 +8896,12 @@ static void *expand_k(void) obj = scheme_expand_expr(obj, env, &erec1, 0); if (catch_lifts_key) { - Scheme_Object *l; + Scheme_Object *l, *rl; l = scheme_frame_get_lifts(env); - if (SCHEME_PAIRP(l)) { + rl = scheme_frame_get_require_lifts(env); + if (SCHEME_PAIRP(l) + || SCHEME_PAIRP(rl)) { + l = scheme_append(rl, l); obj = add_lifts_as_begin(obj, l, env); SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj); if ((depth >= 0) || as_local) @@ -9189,6 +9202,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in if (for_stx) { scheme_prepare_exp_env(env->genv); env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); + scheme_propagate_require_lift_capture(orig_env, env); } if (for_expr) @@ -9322,7 +9336,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in if (catch_lifts_key) scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, - catch_lifts_key); + catch_lifts_key, NULL); memset(drec, 0, sizeof(drec)); drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */ diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 98efadf023..2398ea2ba4 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -5749,6 +5749,76 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id, return scheme_make_lifted_defn(scheme_sys_wraps(env), _id, expr, _env); } +static Scheme_Object *make_require_form(Scheme_Object *module_path, long phase, Scheme_Object *mark) +{ + Scheme_Object *e = module_path; + + if (phase != 0) { + e = scheme_make_pair(for_meta_symbol, + scheme_make_pair(scheme_make_integer(phase), + scheme_make_pair(e, + scheme_null))); + } + e = scheme_make_pair(require_stx, scheme_make_pair(e, scheme_null)); + e = scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0); + + e = scheme_add_remove_mark(e, mark); + + return e; +} + +Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, + long phase, + Scheme_Object *mark, + void *data) +{ + Scheme_Object *e; + Scheme_Object *base_modidx = (Scheme_Object *)((void **)data)[1]; + Scheme_Env *env = (Scheme_Env *)((void **)data)[2]; + Scheme_Module *for_m = (Scheme_Module *)((void **)data)[3]; + Scheme_Object *rns = (Scheme_Object *)((void **)data)[4]; + Scheme_Object *post_ex_rns = (Scheme_Object *)((void **)data)[5]; + void *tables = ((void **)data)[6]; + Scheme_Object *redef_modname = (Scheme_Object *)((void **)data)[7]; + int *all_simple = (int *)((void **)data)[8]; + + e = make_require_form(module_path, phase, mark); + + parse_requires(e, base_modidx, env, for_m, + rns, post_ex_rns, + check_require_name, tables, + redef_modname, + 0, 0, 1, 0, + all_simple); + + return e; +} + +static Scheme_Object *package_require_data(Scheme_Object *base_modidx, + Scheme_Env *env, + Scheme_Module *for_m, + Scheme_Object *rns, Scheme_Object *post_ex_rns, + void *data, + Scheme_Object *redef_modname, + int *all_simple) +{ + void **vals; + + vals = MALLOC_N(void*, 9); + vals[0] = NULL; /* this slot is available */ + vals[1] = base_modidx; + vals[2] = env; + vals[3] = for_m; + vals[4] = rns; + vals[5] = post_ex_rns; + vals[6] = data; + vals[7] = redef_modname; + vals[8] = all_simple; + + return scheme_make_raw_pair((Scheme_Object *)vals, NULL); +} + + static void flush_definitions(Scheme_Env *genv) { if (genv->syntax) { @@ -5786,9 +5856,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *exclude_hint = scheme_false, *lift_data; Scheme_Object **exis, **et_exis, **exsis; Scheme_Object *lift_ctx; + Scheme_Object *lifted_reqs = scheme_null, *req_data; int exicount, et_exicount, exsicount; char *exps, *et_exps; - int all_simple_renames = 1; + int *all_simple_renames; int maybe_has_lifts = 0; int reprovide_kernel; Scheme_Object *redef_modname; @@ -5931,6 +6002,15 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, maybe_has_lifts = 0; lift_ctx = scheme_generate_lifts_key(); + all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int)); + *all_simple_renames = 1; + + req_data = package_require_data(self_modidx, env->genv, env->genv->module, + rn_set, post_ex_rn_set, + tables, + redef_modname, + all_simple_renames); + /* Pass 1 */ /* Partially expand all expressions, and process definitions, requires, @@ -5949,7 +6029,8 @@ 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); - scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p, lift_ctx); + scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), + p, lift_ctx, req_data); maybe_has_lifts = 1; { @@ -5966,11 +6047,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, e = scheme_expand_expr(e, xenv, &erec1, 0); } + lifted_reqs = scheme_append(scheme_frame_get_require_lifts(xenv), lifted_reqs); + fst = scheme_frame_get_lifts(xenv); if (!SCHEME_NULLP(fst)) { /* Expansion lifted expressions, so add them to the front and try again. */ - all_simple_renames = 0; + *all_simple_renames = 0; fm = SCHEME_STX_CDR(fm); e = scheme_add_rename(e, post_ex_rn_set); fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn_set); @@ -6066,7 +6149,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, /* Add a renaming: */ if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); - all_simple_renames = 0; + *all_simple_renames = 0; } else scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); @@ -6102,6 +6185,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, scheme_prepare_exp_env(env->genv); 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); oenv = (for_stx ? eenv : env); @@ -6148,7 +6232,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name, for_stx ? 1 : 0, NULL, NULL, 0); - all_simple_renames = 0; + *all_simple_renames = 0; } else scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name, for_stx ? 1 : 0, NULL, NULL, 0); @@ -6186,6 +6270,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, } m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0); + lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs); + oi = scheme_optimize_info_create(); oi->context = (Scheme_Object *)env->genv->module; if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) @@ -6243,7 +6329,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, check_require_name, tables, redef_modname, 0, 0, 1, 0, - &all_simple_renames); + all_simple_renames); if (rec[drec].comp) e = NULL; @@ -6361,7 +6447,7 @@ 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); + scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data); maybe_has_lifts = 1; if (kind == 2) @@ -6380,6 +6466,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, erec1.value_name = scheme_false; e = scheme_expand_expr(e, nenv, &erec1, 0); } + + lifted_reqs = scheme_append(scheme_frame_get_require_lifts(xenv), lifted_reqs); l = scheme_frame_get_lifts(cenv); if (SCHEME_NULLP(l)) { @@ -6389,7 +6477,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, p = SCHEME_CDR(p); } else { /* Lifts - insert them and try again */ - all_simple_renames = 0; + *all_simple_renames = 0; SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l)); e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */ SCHEME_CAR(p) = e; @@ -6632,7 +6720,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, env->genv->module->indirect_provides = exis; env->genv->module->num_indirect_provides = exicount; - if (all_simple_renames) { + if (*all_simple_renames) { env->genv->module->indirect_syntax_provides = exsis; env->genv->module->num_indirect_syntax_provides = exsicount; } else { @@ -6645,7 +6733,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, env->genv->module->comp_prefix = cenv->prefix; - if (all_simple_renames) { + if (*all_simple_renames) { env->genv->module->rn_stx = scheme_true; } @@ -6659,6 +6747,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, } p = SCHEME_STX_CAR(form); + + /* Add lifted requires */ + if (!SCHEME_NULLP(lifted_reqs)) { + lifted_reqs = scheme_reverse(lifted_reqs); + first = scheme_append(lifted_reqs, first); + } + return scheme_datum_to_syntax(cons(p, first), form, form, 0, 2); } } @@ -9045,10 +9140,10 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env, 0, 0, 0, 0, NULL); - if (rec[drec].comp) { + if (rec && rec[drec].comp) { /* Dummy lets us access a top-level environment: */ dummy = scheme_make_environment_dummy(env); - + scheme_compile_rec_done_local(rec, drec); scheme_default_compile_rec(rec, drec); return scheme_make_syntax_compiled(REQUIRE_EXPD, @@ -9071,6 +9166,20 @@ require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er return do_require(form, env, erec, drec); } +Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, + long phase, + Scheme_Comp_Env *cenv, + Scheme_Object *mark) +{ + Scheme_Object *form; + + form = make_require_form(module_path, phase, mark); + + do_require(form, cenv, NULL, 0); + + return form; +} + /**********************************************************************/ /* dummy forms */ /**********************************************************************/ diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 5f08fc194b..33581e2922 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -11,9 +11,9 @@ EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP can be set to 1 again. */ -#define USE_COMPILED_STARTUP 1 +#define USE_COMPILED_STARTUP 0 -#define EXPECTED_PRIM_COUNT 945 +#define EXPECTED_PRIM_COUNT 946 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 301079be72..ccd049a4ca 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2065,11 +2065,22 @@ 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 *end_stmts, Scheme_Object *context_key, Scheme_Object *require_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_generate_lifts_key(void); +Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, + long phase, + Scheme_Comp_Env *cenv, + Scheme_Object *mark); +Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, + long phase, + Scheme_Object *mark, + void *data); + void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env); void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val, Scheme_Comp_Env *env); diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 0583c45695..cd5cfe3196 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.3.9" +#define MZSCHEME_VERSION "4.1.3.10" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 9 +#define MZSCHEME_VERSION_W 10 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)