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

fixes for submodules and `variable-reference->namespace'

Browse Source 
Closes PR 12925

Merge to 5.3
(cherry picked from commit d95ec4d454)
This commit is contained in:
Matthew Flatt 2012-07-22 11:32:21 -05:00 committed by Ryan Culpepper
parent f9131630ce
commit ba09bf3541
7 changed files with 168 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/zo-structs.rkt
View File

@ -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?)]))

2
collects/scribblings/raco/zo-struct.scrbl
View File

@ -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.

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

@ -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)

2
src/racket/src/compenv.c
View File

@ -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

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

@ -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(".."),
@ -6913,13 +6942,24 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
menv->module_registry->exports,
env->insp, NULL);
super_bxs_info = MALLOC_N(void*, 6);
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*, 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;

4
src/racket/src/schpriv.h
View File

@ -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) */

38
src/racket/src/syntax.c
View File

@ -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)