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

call SCHEME_EXPAND_OBSERVE_* only when in expand mode, not compile

Browse Source 
Merge to 6.3.
This commit is contained in:
Ryan Culpepper 2015-10-23 16:13:57 -04:00
parent 2e3ff0332d
commit a41c63be09
2 changed files with 248 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

191
racket/src/racket/src/compile.c
View File

@ -2824,7 +2824,9 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
body = scheme_datum_to_syntax(body, form, form, 0, 0);
if (scope) body = scheme_stx_add_scope(body, scope, scheme_env_phase(env->genv));
SCHEME_EXPAND_OBSERVE_LET_RENAMES(env->observer, vars, body);
if (!erec[drec].comp) {
SCHEME_EXPAND_OBSERVE_LET_RENAMES(env->observer, vars, body);
}
/* Pass 2: Expand */
@ -2833,7 +2835,9 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
while (SCHEME_STX_PAIRP(vars)) {
Scheme_Object *rhs, *rhs_name;
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
if (!erec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
}
v = SCHEME_STX_CAR(vars);
@ -2897,7 +2901,9 @@ do_let_expand(Scheme_Object *orig_form, Scheme_Comp_Env *origenv, Scheme_Expand_
first = scheme_datum_to_syntax(first, vs, vs, 0, 1);
}
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(env->observer);
if (!erec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(env->observer);
}
scheme_init_expand_recs(erec, drec, &erec1, 1);
env->value_name = boundname;
if (!body_block)
@ -3217,8 +3223,10 @@ do_begin_expand(char *name,
if (SCHEME_STX_NULLP(rest)) {
if (!zero && scheme_is_toplevel(env)) {
SCHEME_EXPAND_OBSERVE_ENTER_LIST(env->observer, form);
SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, form);
if (!erec[drec].comp) {
SCHEME_EXPAND_OBSERVE_ENTER_LIST(env->observer, form);
SCHEME_EXPAND_OBSERVE_EXIT_LIST(env->observer, form);
}
return orig_form;
}
scheme_wrong_syntax(NULL, NULL, form, "empty form not allowed");
@ -3238,12 +3246,16 @@ do_begin_expand(char *name,
fst = SCHEME_STX_CAR(rest);
rest = SCHEME_STX_CDR(rest);
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
if (!erec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
}
env->value_name = boundname;
fst = scheme_expand_expr(fst, env, &erec1, 0);
env->value_name = NULL;
rest = scheme_datum_to_syntax(rest, form, form, 0, 0);
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
if (!erec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
}
rest = expand_list(rest, env, erec, drec);
form = cons(fst, rest);
@ -3589,7 +3601,9 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem
Scheme_Object *form, *l, *fn, *vec, *dummy;
Scheme_Comp_Env *env;
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(in_env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(in_env->observer);
}
form = orig_form;
@ -3598,7 +3612,9 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem
(void)check_form(form, form);
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(in_env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(in_env->observer);
}
scheme_prepare_exp_env(in_env->genv);
scheme_prepare_compile_env(in_env->genv->exp_env);
@ -3836,7 +3852,9 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
but it's not likely that a let-syntax-bound macro is going
to run lots of times, so JITting is probably not worth it. */
SCHEME_EXPAND_OBSERVE_NEXT(eenv->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT(eenv->observer);
}
a_expr = a;
a = eval_letmacro_rhs(a_expr, rhs_env,
@ -3903,7 +3921,9 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
scheme_merge_undefineds(eenv, rhs_env);
SCHEME_EXPAND_OBSERVE_EXIT_BIND(observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_EXIT_BIND(observer);
}
}
static Scheme_Object *
@ -4086,9 +4106,10 @@ do_letrec_syntaxes(const char *where,
}
}
SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(stx_env->observer, bindings, var_bindings, body);
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(stx_env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(stx_env->observer, bindings, var_bindings, body);
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(stx_env->observer);
}
scheme_prepare_exp_env(stx_env->genv);
scheme_prepare_compile_env(stx_env->genv->exp_env);
@ -4098,7 +4119,9 @@ do_letrec_syntaxes(const char *where,
for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
Scheme_Object *a, *names;
SCHEME_EXPAND_OBSERVE_NEXT(stx_env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT(stx_env->observer);
}
a = SCHEME_STX_CAR(v);
names = SCHEME_STX_CAR(a);
@ -4114,7 +4137,9 @@ do_letrec_syntaxes(const char *where,
}
}
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(stx_env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(stx_env->observer);
}
if (!env_already && names_to_disappear) {
/* Need to add renaming for disappeared bindings. If they
@ -4177,7 +4202,7 @@ do_letrec_syntaxes(const char *where,
v = scheme_stx_taint_rearm(v, orig_forms);
if (!restore) {
SCHEME_EXPAND_OBSERVE_TAG(stx_env->observer,v);
SCHEME_EXPAND_OBSERVE_TAG(stx_env->observer,v); /* in "expand" branch */
}
}
var_env->value_name = NULL;
@ -4201,7 +4226,7 @@ do_letrec_syntaxes(const char *where,
rec[drec].env_already = 1;
}
SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(stx_env->observer);
SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(stx_env->observer); /* in "expand" branch */
v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, var_env);
if (restore) {
@ -4213,7 +4238,7 @@ do_letrec_syntaxes(const char *where,
v = cons(formname, cons(bindings, v));
v = scheme_datum_to_syntax(v, orig_forms, scheme_sys_wraps(origenv), 0, 2);
} else {
SCHEME_EXPAND_OBSERVE_TAG(stx_env->observer,v);
SCHEME_EXPAND_OBSERVE_TAG(stx_env->observer,v); /* in "expand" branch */
}
}
}
@ -4586,7 +4611,9 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
Scheme_Expand_Info erec1;
Scheme_Env *menv = NULL;
SCHEME_EXPAND_OBSERVE_ENTER_CHECK(env->observer, first);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_ENTER_CHECK(env->observer, first);
}
while (1) {
*current_val = NULL;
@ -4599,7 +4626,9 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
}
if (!SCHEME_STX_SYMBOLP(name)) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first);
}
return first;
}
@ -4627,7 +4656,9 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
if (!val) {
first = install_alt_from_rename(first, alt_first);
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first);
}
return first;
} else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(val),
@ -4661,7 +4692,9 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
}
} else {
first = install_alt_from_rename(first, alt_first);
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_EXIT_CHECK(env->observer, first);
}
return first;
}
}
@ -4775,7 +4808,7 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp) {
scheme_default_compile_rec(rec, drec);
} else {
SCHEME_EXPAND_OBSERVE_VISIT(env->observer,form);
SCHEME_EXPAND_OBSERVE_VISIT(env->observer,form); /* in "expand" branch */
}
if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) {
@ -4832,7 +4865,9 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
&bind_id, &need_macro_scope,
&inline_variant);
SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer,find_name);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer,find_name);
}
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
@ -4867,10 +4902,12 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
} else {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
if (var == stop_expander) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer,form);
SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer,form);
SCHEME_EXPAND_OBSERVE_RETURN(env->observer,form);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer,form);
SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer,form);
SCHEME_EXPAND_OBSERVE_RETURN(env->observer,form);
}
return form;
} else {
scheme_wrong_syntax(NULL, NULL, form, "bad syntax");
@ -4904,14 +4941,14 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
else
return var;
} else {
SCHEME_EXPAND_OBSERVE_VARIABLE(env->observer, form, find_name);
SCHEME_EXPAND_OBSERVE_VARIABLE(env->observer, form, find_name); /* in "expand" branch */
if (bind_id && rec[drec].substitute_bindings)
find_name = bind_id;
if (protected) {
/* Add a property to indicate that the name is protected */
find_name = scheme_stx_property(find_name, protected_symbol, scheme_true);
}
SCHEME_EXPAND_OBSERVE_RETURN(env->observer, find_name);
SCHEME_EXPAND_OBSERVE_RETURN(env->observer, find_name); /* in "expand" branch */
return find_name; /* which is usually == form */
}
}
@ -4960,7 +4997,9 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
NULL, &need_macro_scope,
NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name);
}
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var),
@ -5057,7 +5096,9 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
NULL, &need_macro_scope,
NULL);
SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_RESOLVE(env->observer, find_name);
}
if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)
&& scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) {
@ -5088,10 +5129,12 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
|| SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type))) {
if (SAME_OBJ(var, stop_expander)) {
/* Return original: */
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form);
SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form);
SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form);
SCHEME_EXPAND_OBSERVE_PRIM_STOP(env->observer);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form);
SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form);
}
return form;
} else if (rec[drec].comp && SAME_OBJ(var, normal) && !env->observer) {
/* Skip creation of intermediate form */
@ -5112,7 +5155,9 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
} else {
name = scheme_stx_taint_disarm(form, NULL);
form = scheme_datum_to_syntax(scheme_make_pair(stx, name), form, form, 0, 2);
SCHEME_EXPAND_OBSERVE_TAG(env->observer, form);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_TAG(env->observer, form);
}
}
if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) {
@ -5123,7 +5168,7 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
} else {
Scheme_Syntax_Expander *f;
f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, form); /* in "expand" branch */
form = f(form, env, rec, drec);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer, form);
SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form);
@ -5175,7 +5220,9 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
return form; /* We've gone as deep as requested */
}
SCHEME_EXPAND_OBSERVE_ENTER_MACRO(env->observer, form);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_ENTER_MACRO(env->observer, form);
}
if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var),
scheme_frame_to_expansion_context_symbol(env->flags))) {
form = compile_expand_macro_app(name, menv, var, form, env, rec, drec, need_macro_scope);
@ -5187,7 +5234,9 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
}
} else
form = adjust_for_other_context(form, var, env);
SCHEME_EXPAND_OBSERVE_EXIT_MACRO(env->observer, form);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_EXIT_MACRO(env->observer, form);
}
if (rec[drec].comp)
goto top;
@ -5197,7 +5246,7 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].depth)
goto top;
else {
SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form);
SCHEME_EXPAND_OBSERVE_RETURN(env->observer, form); /* in "expand" branch */
return form;
}
}
@ -5826,7 +5875,9 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
} else
o = form;
form = scheme_add_lifts_as_let(o, l, env, orig_form, rec[drec].comp);
SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(env->observer, form);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(env->observer, form);
}
form = compile_expand_expr_lift_to_let(form, env, recs, 1);
if (rec[drec].comp)
scheme_merge_compile_recs(rec, drec, recs, 2);
@ -5927,11 +5978,15 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
old = forms;
forms = add_scope_at_arbitrary_phase(forms, rib);
SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(env->observer, forms, old);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(env->observer, forms, old);
}
try_again:
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
}
if (!SCHEME_STX_PAIRP(forms)) {
scheme_wrong_syntax(scheme_begin_stx_string, NULL, beginify(env, forms), "bad syntax");
@ -5961,7 +6016,9 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
/* Inline content */
Scheme_Object *orig_forms = forms;
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer);
}
/* FIXME: Redundant with check done by scheme_flatten_begin below? */
if (scheme_stx_proper_list_length(first) < 0)
@ -5981,7 +6038,9 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
forms = scheme_flatten_begin(first, forms);
SCHEME_EXPAND_OBSERVE_SPLICE(env->observer, forms);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_SPLICE(env->observer, forms);
}
if (SCHEME_STX_NULLP(forms)) {
if (!SCHEME_PAIRP(pre_exprs)) {
@ -6047,10 +6106,12 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
v = SCHEME_STX_CDR(first);
if (is_val) {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(env->observer);
} else {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(env->observer);
if (!rec[drec].comp) {
if (is_val) {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(env->observer);
} else {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(env->observer);
}
}
if (!SCHEME_STX_PAIRP(v))
@ -6080,7 +6141,9 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
var = SCHEME_STX_CAR(first);
v = scheme_stx_track(v, first, var);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer,v);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer,v);
}
link = scheme_make_pair(v, scheme_null);
if (is_val) {
@ -6146,7 +6209,9 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (!is_val) {
/* Evaluate and bind syntaxes */
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer);
}
scheme_prepare_exp_env(new_env->genv);
scheme_prepare_compile_env(new_env->genv->exp_env);
pos = 0;
@ -6169,7 +6234,9 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (!SCHEME_STX_NULLP(result)) {
first = SCHEME_STX_CAR(result);
first = scheme_datum_to_syntax(first, forms, forms, 0, 0);
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT(env->observer);
}
is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(result));
if (is_last)
env->value_name = orig_vname;
@ -6182,9 +6249,13 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (SAME_OBJ(gval, scheme_begin_syntax)) {
/* Inline content */
result = SCHEME_STX_CDR(result);
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(env->observer);
}
result = scheme_flatten_begin(first, result);
SCHEME_EXPAND_OBSERVE_SPLICE(env->observer,result);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_SPLICE(env->observer,result);
}
goto define_try_again;
} else if (mixed) {
/* accumulate expr for either sequence after definitions
@ -6263,8 +6334,10 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
if (rec[drec].depth > 0)
--rec[drec].depth;
if (rec[drec].depth) {
SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(env->observer,
scheme_make_pair(result, scheme_null));
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(env->observer,
scheme_make_pair(result, scheme_null));
}
env = scheme_no_defines(env);
env->value_name = orig_vname;
result = scheme_expand_expr(result, env, rec, drec);
@ -6330,7 +6403,7 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
env->value_name = orig_vname;
SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(env->observer, forms);
SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(env->observer, forms); /* in "expand" branch */
forms = expand_list(forms, env, recs, 0);
return forms;
}

157
racket/src/racket/src/module.c
View File

@ -7205,7 +7205,9 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
m->super_bxs_info = super_bxs_info;
}
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer);
}
/* load the module for the initial require */
if (iidx) {
@ -7308,8 +7310,10 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_datum_to_syntax(fm, form, mb_ctx, 0, 2);
if (check_mb) {
SCHEME_EXPAND_OBSERVE_TAG(env->observer, fm);
if (!rec[drec].comp) {
if (check_mb) {
SCHEME_EXPAND_OBSERVE_TAG(env->observer, fm);
}
}
fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp));
@ -7322,7 +7326,9 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_stx_add_module_frame_context(fm, rn_set);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer, fm);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer, fm);
}
if (!check_mb) {
fm = scheme_check_immediate_macro(fm, benv, rec, drec, &mbval, 1);
@ -7335,7 +7341,9 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_datum_to_syntax(fm, form, mb_ctx, 0, 2);
fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(rmp));
SCHEME_EXPAND_OBSERVE_TAG(env->observer, fm);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_TAG(env->observer, fm);
}
check_mb = 1;
}
@ -7452,7 +7460,9 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
LOG_END_EXPAND(m);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer, fm);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_RENAME_ONE(env->observer, fm);
}
return fm;
}
@ -8182,7 +8192,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env
form = introduce_to_module_context(form, rn_set);
observer = env->observer;
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form);
}
_num_phases = MALLOC_ONE_ATOMIC(int);
*_num_phases = 0;
@ -8434,7 +8446,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env
env->genv->module->dummy = dummy;
}
SCHEME_EXPAND_OBSERVE_NEXT(observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_NEXT(observer);
}
/* Submodules */
if (has_submodules) {
@ -8582,11 +8596,13 @@ static Scheme_Object *handle_submodule_form(const char *who,
e = revert_use_site_scopes_via_context(e, rn_set, phase);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
if (is_star) {
SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer);
} else {
SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
if (is_star) {
SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer);
} else {
SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer);
}
}
if (SCHEME_STX_PAIRP(e)) {
@ -8632,7 +8648,9 @@ static Scheme_Object *handle_submodule_form(const char *who,
*_kind = MODULE_MODFORM_KIND;
}
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e);
if (erec) {
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e);
}
return e;
}
@ -8838,7 +8856,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
while (1) {
Scheme_Object *fst;
SCHEME_EXPAND_OBSERVE_NEXT(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_NEXT(observer);
}
e = SCHEME_STX_CAR(fm);
@ -8882,9 +8902,13 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
e = introduce_to_module_context(e, rn_set);
fm = scheme_named_map_1(NULL, introduce_to_module_context, fm, rn_set);
fm = scheme_make_pair(e, fm);
SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm);
if (erec) {
SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm);
}
fm = scheme_append(fst, fm);
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, fst);
if (erec) {
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, fst);
}
} else {
/* No definition lifts added... */
if (SCHEME_STX_PAIRP(e))
@ -8895,9 +8919,13 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_free_eq_x(scheme_begin_stx, fst, phase)) {
fm = SCHEME_STX_CDR(fm);
e = introduce_to_module_context(e, rn_set);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
if (erec) {
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
}
fm = scheme_flatten_begin(e, fm);
SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm);
if (erec) {
SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm);
}
if (SCHEME_STX_NULLP(fm)) {
e = scheme_frame_get_provide_lifts(xenv);
e = scheme_reverse(e);
@ -8911,7 +8939,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
fm = e;
if (SCHEME_NULLP(fm) && expand_ends)
fm = get_higher_phase_lifts(bxs, begin_for_syntax_stx);
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
if (erec) {
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
}
if (SCHEME_NULLP(fm)) {
e = NULL;
break;
@ -8925,7 +8955,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
e = introduce_to_module_context(e, rn_set);
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
if (erec) {
SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
}
if (SCHEME_STX_PAIRP(e)) {
Scheme_Object *fst;
@ -8938,8 +8970,10 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
Scheme_Object *vars, *val;
int var_count = 0;
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer);
}
/* Create top-level vars; uses revert_use_site_scopes() on the vars */
scheme_define_parse(e, &vars, &val, 0, xenv, 1);
@ -8995,7 +9029,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
e, e, 0, 2);
}
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
if (erec) {
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
}
kind = DEFN_MODFORM_KIND;
} else if (scheme_stx_free_eq_x(scheme_define_syntaxes_stx, fst, phase)
|| scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase)) {
@ -9013,15 +9049,21 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
for_stx = scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
if (erec) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
}
if (for_stx) {
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer);
}
if (scheme_stx_proper_list_length(e) < 0)
scheme_wrong_syntax(NULL, NULL, e, NULL);
code = e;
} else {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer);
}
scheme_define_parse(e, &names, &code, 1, env, 1);
}
@ -9030,7 +9072,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
else
boundname = scheme_false;
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(observer);
}
scheme_prepare_exp_env(env->genv);
scheme_prepare_compile_env(env->genv->exp_env);
@ -9040,6 +9084,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
eenv = scheme_new_comp_env(env->genv->exp_env, env->insp,
frame_scopes,
SCHEME_KEEP_SCOPES_FRAME);
eenv->observer = observer;
if (!for_stx)
scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false,
req_data, scheme_false, scheme_false);
@ -9213,7 +9258,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
} else
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
if (erec) {
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
}
kind = DONE_MODFORM_KIND;
@ -9222,8 +9269,10 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
non_phaseless_form = e;
} else if (scheme_stx_free_eq_x(require_stx, fst, phase)) {
/************ require *************/
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer);
}
e = revert_use_site_scopes_via_context(e, rn_set, phase);
@ -9241,7 +9290,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
if (!erec)
e = NULL;
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
if (erec) {
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
}
kind = DONE_MODFORM_KIND;
} else if (scheme_stx_free_eq_x(provide_stx, fst, phase)) {
/************ provide *************/
@ -9334,7 +9385,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
fm = get_higher_phase_lifts(bxs, begin_for_syntax_stx);
} else
fm = e;
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
if (erec) {
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
}
}
}
/* first = a list of (cons semi-expanded-expression kind) */
@ -9351,7 +9404,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
}
/* Pass 2 */
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
}
{
/* Module and each `begin-for-syntax' group manages its own prefix: */
@ -9379,7 +9434,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
kind = SCHEME_INT_VAL(SCHEME_CDR(e));
e = SCHEME_CAR(e);
SCHEME_EXPAND_OBSERVE_NEXT(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_NEXT(observer);
}
if (kind == SAVED_MODFORM_KIND) {
expanded_l = scheme_make_pair(SCHEME_CDR(e), expanded_l);
@ -9453,7 +9510,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
/* Lifts - insert them and try again */
Scheme_Object *fst;
*bxs->all_simple_bindings = 0;
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
if (erec) {
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
}
if (erec) {
e = scheme_make_pair(scheme_make_pair(e, SCHEME_CAR(expanded_l)),
scheme_make_integer(SAVED_MODFORM_KIND)); /* kept both expanded & maybe compiled */
@ -9519,7 +9578,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
p = e;
expr_cnt = 0;
}
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p);
if (erec) {
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p);
}
for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
e = SCHEME_CAR(ll);
if (expr_cnt <= 0) {
@ -9558,7 +9619,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
/* Pass 3 */
/* if at phase 0, expand provides for all phases */
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
if (erec) {
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
}
if (phase == 0) {
Scheme_Object *expanded_provides;
@ -9660,8 +9723,10 @@ static Scheme_Object *expand_all_provides(Scheme_Object *form,
/* Expand and add provides to table: */
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer);
}
ex = e;
@ -9692,7 +9757,9 @@ static Scheme_Object *expand_all_provides(Scheme_Object *form,
if (keep_expanded)
expanded_provides = scheme_make_pair(ex, expanded_provides);
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
}
saved_provides = SCHEME_CDR(saved_provides);
}
@ -9720,10 +9787,14 @@ static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int dre
while (!SCHEME_NULLP(l)) {
mod = SCHEME_CAR(l);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, SCHEME_CAR(mod));
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(env->observer, SCHEME_CAR(mod));
}
mod = do_module(SCHEME_CAR(mod), env, rec, drec, ancestry, env->genv->module->submodule_path, post,
bxs, SCHEME_CDR(mod));
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer,mod);
if (!rec[drec].comp) {
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(env->observer,mod);
}
mods = scheme_make_pair(mod, mods);