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

another `namespace-attach-module' repair for submodules

Browse Source 
Merge to v5.3
This commit is contained in:
Matthew Flatt 2012-07-19 16:49:54 -05:00
parent 99dbc321f5
commit a45d13b52a
2 changed files with 54 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/tests/racket/submodule.rktl
View File

@ -675,34 +675,41 @@
;; Module attach ;; Module attach
(let () (let ()
(define (attach-tests use-path?)
(define (test-attach decl-only? pre-check?) (define (test-attach decl-only? pre-check?)
(define path (and use-path?
(build-path (find-system-path 'temp-dir) "mod.rkt")))
(let ([ns1 (make-base-namespace)] (let ([ns1 (make-base-namespace)]
[ns2 (make-base-namespace)] [ns2 (make-base-namespace)]
[ns3 (make-base-namespace)]) [ns3 (make-base-namespace)])
(parameterize ([current-namespace ns1]) (parameterize ([current-namespace ns1])
(parameterize ([current-module-declare-name (and use-path?
(make-resolved-module-path path))])
(eval '(module m racket/base (eval '(module m racket/base
(provide root) (define root 'm) (provide root) (define root 'm)
(module+ n (provide x) (define x 'x)))) (module+ n (provide x) (define x 'x)))))
(unless decl-only? (unless decl-only?
(dynamic-require ''m #f) (dynamic-require (or path ''m) #f)
(when pre-check? (when pre-check?
(test 'x dynamic-require '(submod 'm n) 'x)))) (test 'x dynamic-require `(submod ,(or path ''m) n) 'x))))
(parameterize ([current-namespace ns2]) (parameterize ([current-namespace ns2])
((if decl-only? namespace-attach-module-declaration namespace-attach-module) ((if decl-only? namespace-attach-module-declaration namespace-attach-module)
ns1 ns1
''m) (or path ''m))
(test 'x dynamic-require '(submod 'm n) 'x)) (test 'x dynamic-require `(submod ,(or path ''m) n) 'x))
(unless decl-only? (unless decl-only?
(parameterize ([current-namespace ns1]) (parameterize ([current-namespace ns1])
(test 'x dynamic-require '(submod 'm n) 'x))) (test 'x dynamic-require `(submod ,(or path ''m) n) 'x)))
(parameterize ([current-namespace ns3]) (parameterize ([current-namespace ns3])
((if decl-only? namespace-attach-module-declaration namespace-attach-module) ((if decl-only? namespace-attach-module-declaration namespace-attach-module)
ns1 ns1
'(submod 'm n)) `(submod ,(or path ''m) n))
(test 'm dynamic-require ''m 'root)))) (test 'm dynamic-require (or path ''m) 'root))))
(test-attach #f #f) (test-attach #f #f)
(test-attach #f #t) (test-attach #f #t)
(test-attach #t #f)) (test-attach #t #f))
(attach-tests #f)
(attach-tests #t))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -1453,8 +1453,10 @@ void ensure_instantiate_for_label(const char *who, Scheme_Env *from_env, Scheme_
} }
} }
static Scheme_Object *make_sub_modidx(Scheme_Env *menv, Scheme_Object *name, int i) static Scheme_Object *make_sub_modidx_pair(Scheme_Env *menv, Scheme_Object *name, int i)
{ {
Scheme_Object *modidx;
if (i) { if (i) {
name = scheme_resolved_module_path_value(name); name = scheme_resolved_module_path_value(name);
while (SCHEME_PAIRP(SCHEME_CDR(name))) { while (SCHEME_PAIRP(SCHEME_CDR(name))) {
@ -1465,12 +1467,15 @@ static Scheme_Object *make_sub_modidx(Scheme_Env *menv, Scheme_Object *name, int
name = scheme_make_utf8_string(".."); name = scheme_make_utf8_string("..");
} }
return scheme_make_modidx(scheme_make_pair(submod_symbol, modidx = scheme_make_modidx(scheme_make_pair(submod_symbol,
scheme_make_pair(scheme_make_utf8_string("."), scheme_make_pair(scheme_make_utf8_string("."),
scheme_make_pair(name, scheme_make_pair(name,
scheme_null))), scheme_null))),
menv->link_midx, menv->link_midx,
scheme_false); scheme_false);
name = scheme_module_resolve(modidx, 0);
return scheme_make_pair(name, modidx);
} }
#if 0 #if 0
@ -1785,10 +1790,10 @@ static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Sche
name = ((Scheme_Module *)SCHEME_CAR(l))->modname; name = ((Scheme_Module *)SCHEME_CAR(l))->modname;
if (!scheme_hash_get(nophase_checked, name)) { if (!scheme_hash_get(nophase_checked, name)) {
LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(name, NULL))); name = make_sub_modidx_pair(menv, name, i);
nophase_todo = scheme_make_pair(scheme_make_pair(name, make_sub_modidx(menv, name, i)), LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(SCHEME_CAR(name), NULL)));
nophase_todo); nophase_todo = scheme_make_pair(name, nophase_todo);
scheme_hash_set(nophase_checked, name, just_declare ? scheme_false : scheme_true); scheme_hash_set(nophase_checked, SCHEME_CAR(name), just_declare ? scheme_false : scheme_true);
} }
l = SCHEME_CDR(l); l = SCHEME_CDR(l);
} }
@ -1970,10 +1975,10 @@ static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Sche
name = ((Scheme_Module *)SCHEME_CAR(l))->modname; name = ((Scheme_Module *)SCHEME_CAR(l))->modname;
if (!scheme_hash_get(nophase_checked, name)) { if (!scheme_hash_get(nophase_checked, name)) {
LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(name, NULL))); name = make_sub_modidx_pair(menv, name, i);
nophase_todo = scheme_make_pair(scheme_make_pair(name, make_sub_modidx(menv, name, i)), LOG_ATTACH(printf("Add s %s\n", scheme_write_to_string(SCHEME_CAR(name), NULL)));
nophase_todo); nophase_todo = scheme_make_pair(name, nophase_todo);
scheme_hash_set(nophase_checked, name, just_declare ? scheme_false : scheme_true); scheme_hash_set(nophase_checked, SCHEME_CAR(name), just_declare ? scheme_false : scheme_true);
} }
l = SCHEME_CDR(l); l = SCHEME_CDR(l);
} }