diff --git a/collects/scribblings/reference/namespaces.scrbl b/collects/scribblings/reference/namespaces.scrbl index 2c76cfdcff..3bd573d30a 100644 --- a/collects/scribblings/reference/namespaces.scrbl +++ b/collects/scribblings/reference/namespaces.scrbl @@ -246,18 +246,28 @@ undefined.} Attaches the instantiated module named by @racket[modname] in @racket[src-namespace] (at its @tech{base phase}) to the @tech{module -registry} of @racket[dest-namespace]. If @racket[modname] is not a -symbol, the current module name resolver is called to resolve the -path, but no module is loaded; the resolved form of @racket[modname] -is used as the module name in @racket[dest-namespace]. In addition to -@racket[modname], every module that it imports (directly or -indirectly) is also recorded in the current namespace's @tech{module -registry}, and instances at the same @tech{phase} or lower are also -attached to @racket[dest-namespace] (while @tech{visits} at the -module's phase and instances at higher phases are not attached, nor -even made @tech{available} for on-demand @tech{visits}). The inspector -of the module invocation in @racket[dest-namespace] is the same as -inspector of the invocation in @racket[src-namespace]. +registry} of @racket[dest-namespace]. + +In addition to @racket[modname], every module that it imports +(directly or indirectly) is also recorded in the current namespace's +@tech{module registry}, and instances at the same @tech{phase} or +lower are also attached to @racket[dest-namespace] (while +@tech{visits} at the module's phase and instances at higher phases are +not attached, nor even made @tech{available} for on-demand +@tech{visits}). The inspector of the module invocation in +@racket[dest-namespace] is the same as inspector of the invocation in +@racket[src-namespace]. + +If @racket[modname] is not a symbol, the current module name resolver +is called to resolve the path, but no module is loaded; the resolved +form of @racket[modname] is used as the module name in +@racket[dest-namespace]. + +If @racket[modname] refers to a submodule or a module with submodules, +unless the module was loaded from bytecode (i.e., a @filepath{.zo} +file) independently from submodules within the same top-level module, +then declarations for all submodules within the module's top-level +module are also attached to @racket[dest-namespace]. If @racket[modname] does not refer to an @tech{instantiate}d module in @racket[src-namespace], or if the name of any module to be attached diff --git a/collects/tests/racket/submodule.rktl b/collects/tests/racket/submodule.rktl index 89f80f54bd..6818e84b96 100644 --- a/collects/tests/racket/submodule.rktl +++ b/collects/tests/racket/submodule.rktl @@ -671,6 +671,39 @@ (for-each loop (directory-list))) (delete-directory x)])) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Module attach + +(let () + (define (test-attach decl-only? pre-check?) + (let ([ns1 (make-base-namespace)] + [ns2 (make-base-namespace)] + [ns3 (make-base-namespace)]) + (parameterize ([current-namespace ns1]) + (eval '(module m racket/base + (provide root) (define root 'm) + (module+ n (provide x) (define x 'x)))) + (unless decl-only? + (dynamic-require ''m #f) + (when pre-check? + (test 'x dynamic-require '(submod 'm n) 'x)))) + (parameterize ([current-namespace ns2]) + ((if decl-only? namespace-attach-module-declaration namespace-attach-module) + ns1 + ''m) + (test 'x dynamic-require '(submod 'm n) 'x)) + (unless decl-only? + (parameterize ([current-namespace ns1]) + (test 'x dynamic-require '(submod 'm n) 'x))) + (parameterize ([current-namespace ns3]) + ((if decl-only? namespace-attach-module-declaration namespace-attach-module) + ns1 + '(submod 'm n)) + (test 'm dynamic-require ''m 'root)))) + (test-attach #f #f) + (test-attach #f #t) + (test-attach #t #f)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/module.c b/src/racket/src/module.c index a0139bdefa..c88f73c745 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -1418,6 +1418,60 @@ static void check_phase(Scheme_Env *menv, Scheme_Env *env, int phase) { } static void check_modchain_consistency(Scheme_Hash_Table *ht, int phase) { } #endif +void ensure_instantiate_for_label(const char *who, Scheme_Env *from_env, Scheme_Object *name, Scheme_Object *modidx) +{ + Scheme_Module *m2; + + m2 = registry_get_loaded(from_env, name); + if (!m2) + scheme_contract_error(who, + "module not declared (in the source namespace)", + "name", 1, name, + NULL); + else { + /* instantiate for-label: */ + Scheme_Cont_Frame_Data cframe; + Scheme_Config *config; + + /* make sure `from_env' is the current namespace, because + start_module() may need to resolve module paths: */ + config = scheme_extend_config(scheme_current_config(), + MZCONFIG_ENV, + (Scheme_Object *)from_env); + scheme_push_continuation_frame(&cframe); + scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); + + start_module(m2, + from_env->label_env, 0, + modidx, + 0, 0, -1, + scheme_null, + 0); + + scheme_pop_continuation_frame(&cframe); + } +} + +static Scheme_Object *make_sub_modidx(Scheme_Env *menv, Scheme_Object *name, int i) +{ + if (i) { + name = scheme_resolved_module_path_value(name); + while (SCHEME_PAIRP(SCHEME_CDR(name))) { + name = SCHEME_CDR(name); + } + name = SCHEME_CAR(name); + } else { + name = scheme_make_utf8_string(".."); + } + + return scheme_make_modidx(scheme_make_pair(submod_symbol, + scheme_make_pair(scheme_make_utf8_string("."), + scheme_make_pair(name, + scheme_null))), + menv->link_midx, + scheme_false); +} + #if 0 # define LOG_ATTACH(x) (x, fflush(stdout)) #else @@ -1705,6 +1759,41 @@ static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Sche } } } + + if (!same_namespace) { + /* attached submodules: like for-label imports: */ + int i; + for (i = 0; i < 3; i++) { + switch (i) { + case 0: + if (menv->module->supermodule) + l = scheme_make_pair(menv->module->supermodule, scheme_null); + else + l = scheme_null; + break; + case 1: + l = menv->module->post_submodules; + break; + case 2: + default: + l = menv->module->pre_submodules; + break; + } + if (l) { + while (!SCHEME_NULLP(l)) { + name = ((Scheme_Module *)SCHEME_CAR(l))->modname; + + if (!scheme_hash_get(nophase_checked, name)) { + LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(name, NULL))); + nophase_todo = scheme_make_pair(scheme_make_pair(name, make_sub_modidx(menv, name, i)), + nophase_todo); + scheme_hash_set(nophase_checked, name, just_declare ? scheme_false : scheme_true); + } + l = SCHEME_CDR(l); + } + } + } + } } } } @@ -1777,7 +1866,15 @@ static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Sche /* Recursively process phase-#f modules: */ while (!SCHEME_NULLP(nophase_todo)) { + int is_submod; + name = SCHEME_CAR(nophase_todo); + if (SCHEME_PAIRP(name)) { + is_submod = 1; + main_modidx = SCHEME_CDR(name); + name = SCHEME_CAR(name); + } else + is_submod = 0; nophase_todo = SCHEME_CDR(nophase_todo); if (!is_builtin_modname(name)) { @@ -1788,40 +1885,12 @@ static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Sche LOG_ATTACH(printf("Check #f %s\n", scheme_write_to_string(name, 0))); if (!menv) { - if (only_declare && main_modidx) { - m2 = registry_get_loaded(from_env, name); - if (!m2) - scheme_contract_error(who, - "module not declared (in the source namespace)", - "name", 1, name, - NULL); - else { - /* instantiate for-label: */ - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - - /* make sure `from_env' is the current namespace, because - start_module() may need to resolve module paths: */ - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)from_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - start_module(m2, - from_env->label_env, 0, - main_modidx, - 0, 0, -1, - scheme_null, - 0); - - scheme_pop_continuation_frame(&cframe); - - /* try again: */ - menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name); - } - } - + if ((only_declare || is_submod) && main_modidx) { + ensure_instantiate_for_label(who, from_env, name, main_modidx); + /* try again: */ + menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name); + } + if (!menv) scheme_arg_mismatch(who, "internal error; unknown module (for label): ", @@ -1877,6 +1946,38 @@ static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Sche } } } + + for (i = 0; i < 3; i++) { + switch (i) { + case 0: + if (menv->module->supermodule) + l = scheme_make_pair(menv->module->supermodule, scheme_null); + else + l = scheme_null; + break; + case 1: + l = menv->module->post_submodules; + break; + case 2: + default: + l = menv->module->pre_submodules; + break; + } + + if (l) { + while (!SCHEME_NULLP(l)) { + name = ((Scheme_Module *)SCHEME_CAR(l))->modname; + + if (!scheme_hash_get(nophase_checked, name)) { + LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(name, NULL))); + nophase_todo = scheme_make_pair(scheme_make_pair(name, make_sub_modidx(menv, name, i)), + nophase_todo); + scheme_hash_set(nophase_checked, name, just_declare ? scheme_false : scheme_true); + } + l = SCHEME_CDR(l); + } + } + } } } @@ -5943,7 +6044,8 @@ static void eval_exptime(Scheme_Object *names, int count, static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, int set_cache, int set_in_pre, - Scheme_Object *prefix); + Scheme_Object *prefix, + Scheme_Object *supermodule); static Scheme_Object *do_module_execute_k() { @@ -5951,17 +6053,20 @@ static Scheme_Object *do_module_execute_k() Scheme_Object *data = (Scheme_Object *)p->ku.k.p1; Scheme_Env *genv = (Scheme_Env *)p->ku.k.p2; Scheme_Object *prefix = (Scheme_Object *)p->ku.k.p3; + Scheme_Object *supermodule = (Scheme_Object *)p->ku.k.p4; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; + p->ku.k.p4 = NULL; - return do_module_execute(data, genv, p->ku.k.i1, p->ku.k.i2, prefix); + return do_module_execute(data, genv, p->ku.k.i1, p->ku.k.i2, prefix, supermodule); } static Scheme_Object *do_module_execute_recur(Scheme_Object *data, Scheme_Env *genv, int set_cache, int set_in_pre, - Scheme_Object *prefix) + Scheme_Object *prefix, + Scheme_Object *supermodule) { # include "mzstkchk.h" { @@ -5971,9 +6076,10 @@ static Scheme_Object *do_module_execute_recur(Scheme_Object *data, Scheme_Env *g p->ku.k.i1 = set_cache; p->ku.k.i2 = set_in_pre; p->ku.k.p3 = (void *)prefix; + p->ku.k.p4 = (void *)supermodule; return scheme_handle_stack_overflow(do_module_execute_k); } else { - return do_module_execute(data, genv, set_cache, set_in_pre, prefix); + return do_module_execute(data, genv, set_cache, set_in_pre, prefix, supermodule); } } @@ -5992,7 +6098,8 @@ static void execute_submodules(Scheme_Module *m, int pre, Scheme_Env *genv, } while (!SCHEME_NULLP(p)) { - do_module_execute_recur(SCHEME_CAR(p), genv, set_cache, set_in_pre, prefix); + do_module_execute_recur(SCHEME_CAR(p), genv, set_cache, set_in_pre, prefix, + (Scheme_Object *)m); p = SCHEME_CDR(p); } } @@ -6000,7 +6107,8 @@ static void execute_submodules(Scheme_Module *m, int pre, Scheme_Env *genv, static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, int set_cache, int set_in_pre, - Scheme_Object *prefix) + Scheme_Object *prefix, + Scheme_Object *supermodule) { Scheme_Module *m; Scheme_Env *env; @@ -6076,6 +6184,9 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, m->modsrc = src; } + if (supermodule) + m->supermodule = supermodule; + if (genv) env = genv; else @@ -6152,7 +6263,7 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, Scheme_Object *scheme_module_execute(Scheme_Object *data, Scheme_Env *genv) { - return do_module_execute(data, genv, 1, 0, NULL); + return do_module_execute(data, genv, 1, 0, NULL, NULL); } static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec, Resolve_Prefix *rp) @@ -7854,7 +7965,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env else o = scheme_eval_clone(o); - (void)do_module_execute(o, env->genv, 0, 1, root_module_name); + (void)do_module_execute(o, env->genv, 0, 1, root_module_name, NULL); } if (!rec[drec].comp && (is_modulestar_stop(env))) { diff --git a/src/racket/src/mzmark_type.inc b/src/racket/src/mzmark_type.inc index ceae929b24..9ddfa83a9d 100644 --- a/src/racket/src/mzmark_type.inc +++ b/src/racket/src/mzmark_type.inc @@ -2574,6 +2574,7 @@ static int module_val_MARK(void *p, struct NewGC *gc) { gcMARK2(m->submodule_path, gc); gcMARK2(m->pre_submodules, gc); gcMARK2(m->post_submodules, gc); + gcMARK2(m->supermodule, gc); gcMARK2(m->submodule_ancestry, gc); gcMARK2(m->primitive, gc); @@ -2620,6 +2621,7 @@ static int module_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(m->submodule_path, gc); gcFIXUP2(m->pre_submodules, gc); gcFIXUP2(m->post_submodules, gc); + gcFIXUP2(m->supermodule, gc); gcFIXUP2(m->submodule_ancestry, gc); gcFIXUP2(m->primitive, gc); diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index df23bf2f97..f50292c75e 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -1051,6 +1051,7 @@ module_val { gcMARK2(m->submodule_path, gc); gcMARK2(m->pre_submodules, gc); gcMARK2(m->post_submodules, gc); + gcMARK2(m->supermodule, gc); gcMARK2(m->submodule_ancestry, gc); gcMARK2(m->primitive, gc); diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 1aa4183832..a9945f6125 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -3125,6 +3125,7 @@ typedef struct Scheme_Module 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) */ + Scheme_Object *supermodule; /* supermodule for which this is in {pre,post}_submodules */ Scheme_Object *submodule_ancestry; /* se by compile/expand, temporary */ } Scheme_Module;