From 307ce653ed8949fe60adf44822e1b1362a017f75 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 31 Aug 2006 10:54:16 +0000 Subject: [PATCH] fix problems with local-expand on a module-begin svn: r4199 --- src/mzscheme/src/module.c | 48 +++++++++++++++++++++++++++++++------- src/mzscheme/src/schpriv.h | 3 ++- src/mzscheme/src/syntax.c | 13 ++++++----- 3 files changed, 48 insertions(+), 16 deletions(-) diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 6eb2b21e5f..72fda4aae3 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -2011,12 +2011,17 @@ Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, int rev_m Scheme_Env *menv; chain = env->modchain; - if (rev_mod_phase) { + if (rev_mod_phase && chain) { chain = (SCHEME_VEC_ELS(chain))[2]; if (SCHEME_FALSEP(chain)) return NULL; } + if (!chain) { + scheme_signal_error("internal error: missing chain for module instances"); + return NULL; + } + menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(chain), name); if (rev_mod_phase && menv) @@ -3791,6 +3796,20 @@ 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 void flush_definitions(Scheme_Env *genv) +{ + if (genv->syntax) { + Scheme_Bucket_Table *t; + t = scheme_make_bucket_table(7, SCHEME_hash_ptr); + genv->syntax = t; + } + if (genv->toplevel) { + Scheme_Bucket_Table *t; + t = scheme_make_bucket_table(7, SCHEME_hash_ptr); + genv->toplevel = t; + } +} + static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec) { @@ -3916,10 +3935,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, et_rn = env->genv->et_rename; tt_rn = env->genv->tt_rename; - /* rename tables no longer needed; NULL them out */ - env->genv->rename = NULL; - env->genv->et_rename = NULL; - env->genv->tt_rename = NULL; + if (rec[drec].comp || (rec[drec].depth != -2)) { + /* rename tables no longer needed; NULL them out */ + env->genv->rename = NULL; + env->genv->et_rename = NULL; + env->genv->tt_rename = NULL; + } { Scheme_Object *v; @@ -4069,7 +4090,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer); /* Create top-level vars */ - scheme_define_parse(e, &vars, &val, 0, env); + scheme_define_parse(e, &vars, &val, 0, env, 1); while (SCHEME_STX_PAIRP(vars)) { Scheme_Object *name, *orig_name; @@ -4133,7 +4154,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer); - scheme_define_parse(e, &names, &code, 1, env); + scheme_define_parse(e, &names, &code, 1, env, 1); if (SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) boundname = SCHEME_STX_CAR(names); @@ -4708,11 +4729,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, } } } - /* first = a list of expanded/compiled expressions */ + /* first = a list of expanded/compiled expressions */ et_mn = env->genv->exp_env->marked_names; - scheme_clean_dead_env(env->genv); + if (rec[drec].comp || (rec[drec].depth != -2)) { + scheme_clean_dead_env(env->genv); + } /* If compiling, drop expressions that are constants: */ if (rec[drec].comp) { @@ -5221,6 +5244,13 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, return (Scheme_Object *)env->genv->module; } else { + if (rec[drec].depth == -2) { + /* This was a local expand. Flush definitions, because the body expand may start over. */ + flush_definitions(env->genv); + if (env->genv->exp_env) + flush_definitions(env->genv->exp_env); + } + p = SCHEME_STX_CAR(form); return scheme_datum_to_syntax(cons(p, first), form, form, 0, 2); } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index c04ce4ed1d..5cfbaaffe0 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2004,7 +2004,8 @@ Scheme_Object *scheme_get_stop_expander(void); void scheme_define_parse(Scheme_Object *form, Scheme_Object **vars, Scheme_Object **val, int defmacro, - Scheme_Comp_Env *env); + Scheme_Comp_Env *env, + int no_toplevel_check); void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo); diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 62385a5a8d..935eb94798 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -921,13 +921,14 @@ void scheme_resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Sche void scheme_define_parse(Scheme_Object *form, Scheme_Object **var, Scheme_Object **_stk_val, int defmacro, - Scheme_Comp_Env *env) + Scheme_Comp_Env *env, + int no_toplevel_check) { Scheme_Object *vars, *rest; int len; DupCheckRecord r; - if (!scheme_is_toplevel(env)) + if (!no_toplevel_check && !scheme_is_toplevel(env)) scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); len = check_form(form, form); @@ -998,7 +999,7 @@ define_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_ { Scheme_Object *var, *val, *targets, *variables; - scheme_define_parse(form, &var, &val, 0, env); + scheme_define_parse(form, &var, &val, 0, env, 0); variables = var; targets = defn_targets_syntax(var, env, rec, drec); @@ -1027,7 +1028,7 @@ define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_In SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(erec[drec].observer); - scheme_define_parse(form, &var, &val, 0, env); + scheme_define_parse(form, &var, &val, 0, env, 0); env = scheme_no_defines(env); @@ -4629,7 +4630,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, scheme_default_compile_rec(rec, drec); scheme_rec_add_certs(rec, drec, form); - scheme_define_parse(form, &names, &code, 1, env); + scheme_define_parse(form, &names, &code, 1, env, 0); scheme_prepare_exp_env(env->genv); @@ -4684,7 +4685,7 @@ define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_ scheme_prepare_exp_env(env->genv); - scheme_define_parse(form, &names, &code, 1, env); + scheme_define_parse(form, &names, &code, 1, env, 0); env = scheme_new_expand_env(env->genv->exp_env, env->insp, 0);