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

syntax-local-lift-require

Browse Source 
svn: r13075
This commit is contained in:
Matthew Flatt 2009-01-12 21:46:40 +00:00
parent 0e8cf2e160
commit 17ad24945b
12 changed files with 293 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

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

@ -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].}

2
collects/sirmail/readr.ss
View File

@ -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)))

6
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -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

10
src/mred/wxme/wx_mline.cxx
View File

@ -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)
{

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

@ -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[])
{

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

@ -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 {

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

@ -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 ? */

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

@ -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 */
/**********************************************************************/

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

@ -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

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

@ -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);

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

@ -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)