From ba09bf3541c25c5ed9d752ff3dd0fa35bb8b8f72 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Jul 2012 11:32:21 -0500 Subject: [PATCH] fixes for submodules and `variable-reference->namespace' Closes PR 12925 Merge to 5.3 (cherry picked from commit d95ec4d454efc8a98bfbe2ad055c020ee7af880e) --- collects/compiler/zo-structs.rkt | 2 +- collects/scribblings/raco/zo-struct.scrbl | 2 +- collects/tests/racket/submodule.rktl | 51 +++++++++++++ src/racket/src/compenv.c | 2 +- src/racket/src/module.c | 92 ++++++++++++++++++----- src/racket/src/schpriv.h | 4 +- src/racket/src/syntax.c | 38 ++++++++++ 7 files changed, 168 insertions(+), 23 deletions(-) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index a6c9749db9..d16b9fbd66 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -124,7 +124,7 @@ [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx?)] + [internal-context (or/c #f #t stx? (listof stx?))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])) diff --git a/collects/scribblings/raco/zo-struct.scrbl b/collects/scribblings/raco/zo-struct.scrbl index 3c9e06e95f..330fdd7438 100644 --- a/collects/scribblings/raco/zo-struct.scrbl +++ b/collects/scribblings/raco/zo-struct.scrbl @@ -173,7 +173,7 @@ structures that are produced by @racket[zo-parse] and consumed by [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] - [internal-context (or/c #f #t stx?)] + [internal-context (or/c #f #t stx? (listof stx?))] [pre-submodules (listof mod?)] [post-submodules (listof mod?)])]{ Represents a @racket[module] declaration. diff --git a/collects/tests/racket/submodule.rktl b/collects/tests/racket/submodule.rktl index 662fb8a68a..bce629630c 100644 --- a/collects/tests/racket/submodule.rktl +++ b/collects/tests/racket/submodule.rktl @@ -711,6 +711,57 @@ (attach-tests #f) (attach-tests #t)) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; module->namespace + +(module check-to-namespace-1 racket/base + (module* main #f + (define x 10) + (define v + (eval 'x (variable-reference->namespace (#%variable-reference)))) + (provide v))) + +(test 10 dynamic-require `(submod 'check-to-namespace-1 main) 'v) + +(module check-to-namespace-2 racket/base + (require racket/math) + (module* main #f + (define v + (eval 'pi (variable-reference->namespace (#%variable-reference)))) + (provide v))) + +(require racket/math) +(test pi dynamic-require `(submod 'check-to-namespace-2 main) 'v) + +(module check-to-namespace-3.0 racket/base + (define x 13) + (define v + (eval 'x (variable-reference->namespace (#%variable-reference)))) + (provide v)) + +(test 13 dynamic-require ''check-to-namespace-3.0 'v) + +(module check-to-namespace-3 racket/base + (define x 13) + (module* main #f + (define v + (eval 'x (variable-reference->namespace (#%variable-reference)))) + (provide v))) + +(test 13 dynamic-require `(submod 'check-to-namespace-3 main) 'v) + +(let ([path (build-path (current-directory) "ctn-no-such-file.rkt")]) + (parameterize ([current-module-declare-name (make-resolved-module-path path)]) + (eval + '(module check-to-namespace-3 racket/base + (define x 130) + (module* main #f + (define v + (eval 'x (variable-reference->namespace (#%variable-reference)))) + (provide v))))) + (test 130 dynamic-require `(submod ,path main) 'v)) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index d0585ee63d..1fc21e42bb 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -1951,7 +1951,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, pos = 0; else pos = scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, NULL, NULL, rename_insp, -1, 1, + find_id, src_find_id, NULL, env->insp, rename_insp, -1, 1, _protected, NULL, env->genv, NULL, &mod_constant); modpos = (int)SCHEME_INT_VAL(pos); } else diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 2ec54d5787..8f02fd1873 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -122,6 +122,7 @@ typedef struct Module_Begin_Expand_State { Scheme_Hash_Table *modidx_cache; Scheme_Object *redef_modname; Scheme_Object *end_statementss; /* list of lists */ + Scheme_Object *rn_stx; } Module_Begin_Expand_State; static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, @@ -2912,17 +2913,45 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) m->rn_stx = rns; } else if (SCHEME_PAIRP(m->rn_stx)) { /* Delayed shift: */ - Scheme_Object *rn_stx, *midx; - rn_stx = SCHEME_CAR(m->rn_stx); + Scheme_Object *vec, *vec2, *rn_stx, *midx; + int i; + + vec = SCHEME_CAR(m->rn_stx); midx = SCHEME_CDR(m->rn_stx); - rns = scheme_stx_to_rename(rn_stx); - rns = scheme_stx_shift_rename_set(rns, midx, m->self_modidx, m->insp); - rn_stx = scheme_rename_to_stx(rns); - m->rn_stx = rn_stx; + + if (!SCHEME_VECTORP(vec)) + vec = scheme_make_vector(1, vec); + vec2 = scheme_make_vector(SCHEME_VEC_SIZE(vec), NULL); + + for (i = SCHEME_VEC_SIZE(vec); i--; ) { + rn_stx = SCHEME_VEC_ELS(vec)[i]; + rns = scheme_stx_to_rename(rn_stx); + rns = scheme_stx_shift_rename_set(rns, midx, m->self_modidx, m->insp); + rn_stx = scheme_rename_to_stx(rns); + SCHEME_VEC_ELS(vec2)[i] = rn_stx; + } + + m->rn_stx = vec2; + } + + /* add rename(s) to the environment's rename: */ + { + int i; + Scheme_Object *vec = m->rn_stx, *prior = NULL; + + if (!SCHEME_VECTORP(vec)) { + vec = scheme_make_vector(1, vec); + m->rn_stx = vec; + } + + for (i = SCHEME_VEC_SIZE(vec); i--; ) { + rns = scheme_stx_to_rename(SCHEME_VEC_ELS(vec)[i]); + scheme_append_rename_set_to_env(rns, menv); + prior = scheme_accum_prior_contexts(rns, prior); + } + scheme_install_prior_contexts_to_env(prior, menv); } - rns = scheme_stx_to_rename(m->rn_stx); - scheme_append_rename_set_to_env(rns, menv); menv->rename_set_ready = 1; } } @@ -6898,7 +6927,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, scheme_false); } else { void **super_bxs_info; - Scheme_Object *rn; + Scheme_Object *rn, *rnss, *rnss2, *rn2; iidx = scheme_make_modidx(scheme_make_pair(submod_symbol, scheme_make_pair(scheme_make_utf8_string(".."), @@ -6912,14 +6941,25 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, top_env->module->self_modidx, iidx, menv->module_registry->exports, env->insp, NULL); + + rnss2 = scheme_null; + for (rnss = super_bxs->rn_stx; SCHEME_PAIRP(rnss); rnss = SCHEME_CDR(rnss)) { + rn2 = scheme_stx_to_rename(SCHEME_CAR(rnss)); + rn2 = scheme_stx_shift_rename_set(rn2, + top_env->module->self_modidx, iidx, + env->insp); + rnss2 = scheme_make_pair(scheme_rename_to_stx(rn2), rnss2); + } + rnss2 = scheme_reverse(rnss2); - super_bxs_info = MALLOC_N(void*, 6); + super_bxs_info = MALLOC_N(void*, 7); super_bxs_info[0] = super_bxs; super_bxs_info[1] = rn; super_bxs_info[2] = top_env->module->self_modidx; super_bxs_info[3] = iidx; super_bxs_info[4] = top_env; super_bxs_info[5] = super_phase_shift; + super_bxs_info[6] = rnss2; m->super_bxs_info = super_bxs_info; } @@ -7639,7 +7679,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env Scheme_Module_Export_Info **exp_infos, *exp_info; Scheme_Module_Phase_Exports *pt; Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */ - Scheme_Object *form, *redef_modname, *rn_set, *observer, **exis, *body_lists, *expanded_l; + Scheme_Object *form, *redef_modname, *rn_set, *observer, **exis, *body_lists, *expanded_l, *rn_stx; Scheme_Env *genv; Module_Begin_Expand_State *bxs; Scheme_Expand_Info crec; @@ -7664,18 +7704,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env modidx_cache = scheme_make_hash_table_equal(); - rn_set = env->genv->rename_set; - { - Scheme_Object *v; - v = scheme_rename_to_stx(rn_set); - env->genv->module->rn_stx = v; - } - all_provided = scheme_make_hash_table_equal(); all_reprovided = scheme_make_hash_table_equal(); all_defs = scheme_make_hash_tree(1); all_defs_out = scheme_make_hash_table_equal(); + rn_set = env->genv->rename_set; post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set, env->genv->module->insp); /* It's possible that #%module-begin expansion introduces @@ -7691,6 +7725,22 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int)); *all_simple_renames = 1; + if (env->genv->module->super_bxs_info) { + rn_stx = scheme_rename_to_stx(post_ex_rn_set); + *all_simple_renames = 0; + } else + rn_stx = scheme_rename_to_stx(rn_set); + if (env->genv->module->super_bxs_info && env->genv->module->super_bxs_info[6]) + rn_stx = scheme_make_pair(rn_stx, env->genv->module->super_bxs_info[6]); + { + Scheme_Object *v; + if (SCHEME_PAIRP(rn_stx)) + v = scheme_list_to_vector(rn_stx); + else + v = rn_stx; + env->genv->module->rn_stx = v; + } + bxs = scheme_malloc(sizeof(Module_Begin_Expand_State)); bxs->post_ex_rn_set = post_ex_rn_set; bxs->tables = tables; @@ -7974,6 +8024,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env (void)do_module_execute(o, env->genv, 0, 1, root_module_name, NULL); } + if (!SCHEME_PAIRP(rn_stx)) + rn_stx = scheme_make_pair(rn_stx, scheme_null); + bxs->rn_stx = rn_stx; + if (!rec[drec].comp && (is_modulestar_stop(env))) { Scheme_Object *l = bxs->saved_submodules; expanded_modules = NULL; @@ -9059,7 +9113,7 @@ static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int dre Scheme_Comp_Env *env, Scheme_Object *l, int post, Module_Begin_Expand_State *bxs, - int keep_expanded) + int keep_expanded) { Scheme_Object *mods = scheme_null, *mod, *ancestry; diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 12524ae011..22f8932ca6 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -1007,6 +1007,8 @@ Scheme_Object *scheme_get_module_rename_from_set(Scheme_Object *set, Scheme_Obje Scheme_Hash_Table *scheme_get_module_rename_marked_names(Scheme_Object *set, Scheme_Object *phase, int create); void scheme_append_rename_set_to_env(Scheme_Object *rns, Scheme_Env *env); +void scheme_install_prior_contexts_to_env(Scheme_Object *prior, Scheme_Env *env); +Scheme_Object *scheme_accum_prior_contexts(Scheme_Object *rns, Scheme_Object *prior); void scheme_seal_module_rename(Scheme_Object *rn, int level); void scheme_seal_module_rename_set(Scheme_Object *rns, int level); @@ -3122,7 +3124,7 @@ typedef struct Scheme_Module Scheme_Env *primitive; - Scheme_Object *rn_stx; + Scheme_Object *rn_stx; /* NULL, #t, a stx for a rename, a vector of stxes, or a pair to delay shifts */ Scheme_Object *submodule_path; /* path to this module relative to enclosing top-level module */ Scheme_Object *pre_submodules, *post_submodules; /* list of modules (when compiled or loaded as a group) */ diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 67a1b55d84..955ad50723 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -170,6 +170,7 @@ typedef struct Module_Renames_Set { Scheme_Object so; /* scheme_rename_table_set_type */ char kind, sealed; Scheme_Object *set_identity; + Scheme_Object *prior_contexts; /* for module->namespace */ Module_Renames *rt, *et; Scheme_Hash_Table *other_phases; Scheme_Object *share_marked_names; /* a Module_Renames_Set */ @@ -1634,6 +1635,23 @@ void scheme_append_rename_set_to_env(Scheme_Object *_mrns, Scheme_Env *env) } } +void scheme_install_prior_contexts_to_env(Scheme_Object *prior, Scheme_Env *env) +{ + if (prior) { + prior = SCHEME_CDR(prior); + if (!SCHEME_NULLP(prior)) { + ((Module_Renames_Set *)env->rename_set)->prior_contexts = prior; + } + } +} + +Scheme_Object *scheme_accum_prior_contexts(Scheme_Object *rns, Scheme_Object *prior) +{ + if (!prior) + prior = scheme_null; + return scheme_make_pair(((Module_Renames_Set *)rns)->set_identity, prior); +} + void scheme_remove_module_rename(Scheme_Object *mrn, Scheme_Object *localname) { @@ -1715,6 +1733,9 @@ Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx) if (!rns) { rns = scheme_make_module_rename_set(((Module_Renames *)v)->kind, NULL, NULL); ((Module_Renames_Set *)rns)->set_identity = ((Module_Renames *)v)->set_identity; + } else if (!SAME_OBJ(((Module_Renames_Set *)rns)->set_identity, + ((Module_Renames *)v)->set_identity)) { + scheme_signal_error("can't convert syntax to rename (identity mismatch)"); } scheme_add_module_rename_to_set(rns, v); } else { @@ -1798,6 +1819,8 @@ Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *_mrns, mrns2 = scheme_make_module_rename_set(mrns->kind, NULL, new_insp); ((Module_Renames_Set *)mrns2)->sealed = mrns->sealed; + ((Module_Renames_Set *)mrns2)->set_identity = mrns->set_identity; + if (mrns->rt) { mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->rt, old_midx, new_midx, new_insp); scheme_add_module_rename_to_set(mrns2, mrn); @@ -3084,6 +3107,21 @@ static Scheme_Object *get_old_module_env(Scheme_Object *stx) kind = mrns->kind; set_identity = mrns->set_identity; + + if (mrns->prior_contexts) { + /* A rename-set with a prior context should be last */ + if (SCHEME_FALSEP(result_id)) { + result_id = mrns->prior_contexts; + if (SCHEME_NULLP(SCHEME_CDR(result_id))) + result_id = SCHEME_CAR(result_id); + } else { + if (!SCHEME_PAIRP(result_id)) { + result_id = scheme_make_pair(result_id, scheme_null); + last_pr = result_id; + } + SCHEME_CDR(last_pr) = mrns->prior_contexts; + } + } } if ((kind != mzMOD_RENAME_TOPLEVEL)