change representation of marked imports in syntax context (which finally fixes the 13MB-of-redundant-bytecode problem with the framework and tools docs)
svn: r12156
This commit is contained in:
Matthew Flatt
parent
8b666c1710
commit
981a491c45
|
|
@ -1743,31 +1743,36 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
|
|||
return val;
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def,
|
||||
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg,
|
||||
int mode, /* -1, 0 => lookup; 2, 3 => define
|
||||
-1 and 3 => use temp table
|
||||
1 would mean define if no match; not currently used */
|
||||
Scheme_Object *phase, int *_skipped)
|
||||
/* The `env' argument can actually be a hash table. */
|
||||
{
|
||||
Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg;
|
||||
int best_match_skipped, ms, one_mark;
|
||||
Scheme_Hash_Table *marked_names;
|
||||
Scheme_Hash_Table *marked_names, *temp_marked_names, *dest_marked_names;
|
||||
|
||||
sym = SCHEME_STX_SYM(id);
|
||||
|
||||
if (_skipped)
|
||||
*_skipped = 0;
|
||||
|
||||
if (SCHEME_HASHTP((Scheme_Object *)env))
|
||||
if (SCHEME_HASHTP((Scheme_Object *)env)) {
|
||||
marked_names = (Scheme_Hash_Table *)env;
|
||||
else {
|
||||
temp_marked_names = NULL;
|
||||
} else {
|
||||
/* If there's no table and we're not defining, bail out fast */
|
||||
if (!is_def && !env->rename_set)
|
||||
if ((mode <= 0) && !env->rename_set)
|
||||
return sym;
|
||||
marked_names = scheme_get_module_rename_marked_names(env->rename_set,
|
||||
phase ? phase : scheme_make_integer(env->phase),
|
||||
0);
|
||||
temp_marked_names = env->temp_marked_names;
|
||||
}
|
||||
|
||||
if (is_def) {
|
||||
if (mode > 0) {
|
||||
/* If we're defining, see if we need to create a table. Getting
|
||||
marks is relatively expensive, but we only do this once per
|
||||
definition. */
|
||||
|
|
@ -1784,12 +1789,23 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
|
|||
phase ? phase : scheme_make_integer(env->phase),
|
||||
1);
|
||||
}
|
||||
if (!temp_marked_names && (mode > 2)) {
|
||||
/* The "temp" marked name table is used to correlate marked module
|
||||
requires with similarly marked provides. We don't go through
|
||||
the normal rename table because (for efficiency) the marks in
|
||||
this case are handled more directly in the shared_pes module
|
||||
renamings. */
|
||||
temp_marked_names = scheme_make_hash_table(SCHEME_hash_ptr);
|
||||
env->temp_marked_names = temp_marked_names;
|
||||
}
|
||||
|
||||
map = scheme_hash_get(marked_names, sym);
|
||||
if (!map && ((mode < 0) || (mode > 2)) && temp_marked_names)
|
||||
map = scheme_hash_get(temp_marked_names, sym);
|
||||
|
||||
if (!map) {
|
||||
/* If we're not defining, we can bail out before extracting marks. */
|
||||
if (!is_def)
|
||||
if (mode <= 0)
|
||||
return sym;
|
||||
else
|
||||
map = scheme_null;
|
||||
|
|
@ -1833,7 +1849,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
|
|||
abdg = NULL;
|
||||
|
||||
if (SAME_OBJ(abdg, bdg)) {
|
||||
if (is_def) {
|
||||
if (mode > 0) {
|
||||
if (scheme_equal(amarks, marks)) {
|
||||
best_match = SCHEME_CDR(a);
|
||||
break;
|
||||
|
|
@ -1873,7 +1889,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
|
|||
}
|
||||
|
||||
if (!best_match) {
|
||||
if (!is_def) {
|
||||
if (mode <= 0) {
|
||||
return sym;
|
||||
}
|
||||
|
||||
|
|
@ -1883,7 +1899,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
|
|||
"redundant" module renamings wouldn't be redundant. (See
|
||||
simpify in stxobj.c.) So check for a context-determined
|
||||
existing rename. */
|
||||
if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (is_def != 2)) {
|
||||
if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) {
|
||||
Scheme_Object *mod, *nm = id;
|
||||
mod = scheme_stx_module_name(&nm, scheme_make_integer(env->phase), NULL, NULL, NULL, NULL, NULL);
|
||||
if (mod /* must refer to env->module, otherwise there would
|
||||
|
|
@ -1925,11 +1941,14 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
|
|||
best_match = scheme_intern_exact_parallel_symbol(buf, strlen(buf));
|
||||
|
||||
if (!scheme_stx_parallel_is_used(best_match, id)) {
|
||||
/* Also check environment's rename tables. This
|
||||
last check turns out to matter for compiling in
|
||||
`module->namespace' contexts, because no renaming
|
||||
is added after expansion to record the rename table. */
|
||||
if (!scheme_tl_id_is_sym_used(marked_names, best_match)) {
|
||||
/* Also check environment's rename tables. This last check
|
||||
includes the temp table. It also turns out to matter for
|
||||
compiling in `module->namespace' contexts, because no
|
||||
renaming is added after expansion to record the rename
|
||||
table. */
|
||||
if (!scheme_tl_id_is_sym_used(marked_names, best_match)
|
||||
&& (!temp_marked_names
|
||||
|| !scheme_tl_id_is_sym_used(temp_marked_names, best_match))) {
|
||||
/* Ok, no matches, so this name is fine. */
|
||||
break;
|
||||
}
|
||||
|
|
@ -1947,10 +1966,11 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
|
|||
a = scheme_make_pair(marks, best_match);
|
||||
map = scheme_make_pair(a, map);
|
||||
|
||||
scheme_hash_set(marked_names, sym, map);
|
||||
dest_marked_names = ((mode < 0) || (mode > 2)) ? temp_marked_names : marked_names;
|
||||
scheme_hash_set(dest_marked_names, sym, map);
|
||||
{
|
||||
Scheme_Hash_Table *rev_ht;
|
||||
rev_ht = (Scheme_Hash_Table *)scheme_hash_get(marked_names, scheme_false);
|
||||
rev_ht = (Scheme_Hash_Table *)scheme_hash_get(dest_marked_names, scheme_false);
|
||||
if (rev_ht) {
|
||||
scheme_hash_set(rev_ht, best_match, scheme_true);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -2156,7 +2156,9 @@ static int do_add_simple_require_renames(Scheme_Object *rn,
|
|||
pt->src_modidx = im->me->src_modidx;
|
||||
scheme_extend_module_rename_with_shared(rn, idx, pt,
|
||||
marshal_phase_index,
|
||||
scheme_make_integer(0), 1);
|
||||
scheme_make_integer(0),
|
||||
scheme_null,
|
||||
1);
|
||||
}
|
||||
|
||||
mark_src = scheme_rename_to_stx(rn);
|
||||
|
|
@ -6278,7 +6280,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
/* may be a single shadowed exclusion, now bound to exclude_hint... */
|
||||
n = SCHEME_CAR(n);
|
||||
if (SCHEME_STXP(n))
|
||||
n = scheme_tl_id_sym(env->genv, n, NULL, 0, NULL, NULL);
|
||||
n = scheme_tl_id_sym(env->genv, n, NULL, -1, NULL, NULL);
|
||||
n = scheme_hash_get(required, n);
|
||||
if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) {
|
||||
/* there is a single shadowed exclusion. */
|
||||
|
|
@ -7033,7 +7035,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
|
|||
prnt_name = name;
|
||||
if (SCHEME_STXP(name)) {
|
||||
if (genv)
|
||||
name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL);
|
||||
name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL);
|
||||
else
|
||||
name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
|
||||
}
|
||||
|
|
@ -7106,7 +7108,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table
|
|||
if (genv
|
||||
&& (SAME_OBJ(phase, scheme_make_integer(0))
|
||||
|| SAME_OBJ(phase, scheme_make_integer(1))))
|
||||
name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL);
|
||||
name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL);
|
||||
else {
|
||||
name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
|
||||
}
|
||||
|
|
@ -7869,7 +7871,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
|
|||
{
|
||||
int j, var_count;
|
||||
Scheme_Object *orig_idx = idx, *to_phase;
|
||||
Scheme_Object **exs, **exsns, **exss;
|
||||
Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null;
|
||||
char *exets;
|
||||
int is_kern, has_context, save_marshal_info = 0;
|
||||
Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename;
|
||||
|
|
@ -7879,9 +7881,8 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
|
|||
if (mark_src) {
|
||||
/* Check whether there's context for this import (which
|
||||
leads to generated local names). */
|
||||
Scheme_Object *l;
|
||||
l = scheme_stx_extract_marks(mark_src);
|
||||
has_context = !SCHEME_NULLP(l);
|
||||
context_marks = scheme_stx_extract_marks(mark_src);
|
||||
has_context = !SCHEME_NULLP(context_marks);
|
||||
if (has_context) {
|
||||
if (all_simple)
|
||||
*all_simple = 0;
|
||||
|
|
@ -7889,7 +7890,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
|
|||
} else
|
||||
has_context = 0; /* computed later */
|
||||
|
||||
if (iname || ename || onlys || for_unmarshal || unpack_kern || has_context)
|
||||
if (iname || ename || onlys || for_unmarshal || unpack_kern)
|
||||
can_save_marshal = 0;
|
||||
|
||||
if (onlys)
|
||||
|
|
@ -7964,7 +7965,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
|
|||
/* Simple "import everything" whose mappings can be shared via the exporting module: */
|
||||
if (!pt->src_modidx)
|
||||
pt->src_modidx = me->src_modidx;
|
||||
scheme_extend_module_rename_with_shared(rn, idx, pt, pt->phase_index, src_phase_index, 1);
|
||||
scheme_extend_module_rename_with_shared(rn, idx, pt, pt->phase_index, src_phase_index, context_marks, 1);
|
||||
skip_rename = 1;
|
||||
} else
|
||||
skip_rename = 0;
|
||||
|
|
@ -8040,7 +8041,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
|
|||
/* The `require' expression has a set of marks in its
|
||||
context, which means that we need to generate a name. */
|
||||
iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0);
|
||||
iname = scheme_tl_id_sym(orig_env, iname, scheme_false, 2, to_phase, NULL);
|
||||
iname = scheme_tl_id_sym(orig_env, iname, scheme_false, skip_rename ? 3 : 2, to_phase, NULL);
|
||||
if (all_simple)
|
||||
*all_simple = 0;
|
||||
}
|
||||
|
|
@ -8154,7 +8155,7 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
|
|||
Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to,
|
||||
Scheme_Hash_Table *export_registry)
|
||||
{
|
||||
Scheme_Object *orig_idx, *exns, *prefix, *idx, *name, *pt_phase, *src_phase_index;
|
||||
Scheme_Object *orig_idx, *exns, *prefix, *idx, *name, *pt_phase, *src_phase_index, *marks;
|
||||
Scheme_Module_Exports *me;
|
||||
Scheme_Env *env;
|
||||
int share_all;
|
||||
|
|
@ -8164,6 +8165,13 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
|
|||
info = SCHEME_CDR(info);
|
||||
pt_phase = SCHEME_CAR(info);
|
||||
info = SCHEME_CDR(info);
|
||||
|
||||
if (SCHEME_PAIRP(info) && SCHEME_PAIRP(SCHEME_CAR(info))) {
|
||||
marks = SCHEME_CAR(info);
|
||||
info = SCHEME_CDR(info);
|
||||
} else
|
||||
marks = scheme_null;
|
||||
|
||||
if (SCHEME_INTP(info)
|
||||
|| SCHEME_FALSEP(info)) {
|
||||
share_all = 1;
|
||||
|
|
@ -8224,9 +8232,12 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
|
|||
if (pt) {
|
||||
if (!pt->src_modidx)
|
||||
pt->src_modidx = me->src_modidx;
|
||||
scheme_extend_module_rename_with_shared(rn, orig_idx, pt, pt->phase_index, src_phase_index, 0);
|
||||
scheme_extend_module_rename_with_shared(rn, orig_idx, pt, pt->phase_index, src_phase_index, marks, 0);
|
||||
}
|
||||
} else {
|
||||
if (!SCHEME_NULLP(marks))
|
||||
scheme_signal_error("internal error: unexpected marks");
|
||||
|
||||
add_single_require(me, pt_phase, src_phase_index, orig_idx, NULL,
|
||||
NULL, NULL, rn,
|
||||
exns, NULL, prefix, NULL, NULL,
|
||||
|
|
|
|||
|
|
@ -2071,6 +2071,7 @@ static int namespace_val_MARK(void *p) {
|
|||
gcMARK(e->insp);
|
||||
|
||||
gcMARK(e->rename_set);
|
||||
gcMARK(e->temp_marked_names);
|
||||
|
||||
gcMARK(e->syntax);
|
||||
gcMARK(e->exp_env);
|
||||
|
|
@ -2105,6 +2106,7 @@ static int namespace_val_FIXUP(void *p) {
|
|||
gcFIXUP(e->insp);
|
||||
|
||||
gcFIXUP(e->rename_set);
|
||||
gcFIXUP(e->temp_marked_names);
|
||||
|
||||
gcFIXUP(e->syntax);
|
||||
gcFIXUP(e->exp_env);
|
||||
|
|
|
|||
|
|
@ -823,6 +823,7 @@ namespace_val {
|
|||
gcMARK(e->insp);
|
||||
|
||||
gcMARK(e->rename_set);
|
||||
gcMARK(e->temp_marked_names);
|
||||
|
||||
gcMARK(e->syntax);
|
||||
gcMARK(e->exp_env);
|
||||
|
|
|
|||
|
|
@ -749,6 +749,7 @@ void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *m
|
|||
struct Scheme_Module_Phase_Exports *pt,
|
||||
Scheme_Object *unmarshal_phase_index,
|
||||
Scheme_Object *src_phase_index,
|
||||
Scheme_Object *marks,
|
||||
int save_unmarshal);
|
||||
void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src);
|
||||
void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info);
|
||||
|
|
@ -2475,6 +2476,7 @@ struct Scheme_Env {
|
|||
protected access and certificates */
|
||||
|
||||
Scheme_Object *rename_set;
|
||||
Scheme_Hash_Table *temp_marked_names; /* used to correlate imports with re-exports */
|
||||
|
||||
Scheme_Bucket_Table *syntax;
|
||||
struct Scheme_Env *exp_env;
|
||||
|
|
@ -2633,7 +2635,7 @@ void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Sc
|
|||
|
||||
|
||||
|
||||
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def,
|
||||
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int mode,
|
||||
Scheme_Object *phase, int *_skipped);
|
||||
int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym);
|
||||
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "4.1.2.1"
|
||||
#define MZSCHEME_VERSION "4.1.2.2"
|
||||
|
||||
#define MZSCHEME_VERSION_X 4
|
||||
#define MZSCHEME_VERSION_Y 1
|
||||
#define MZSCHEME_VERSION_Z 2
|
||||
#define MZSCHEME_VERSION_W 1
|
||||
#define MZSCHEME_VERSION_W 2
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
|
|
@ -141,7 +141,10 @@ typedef struct Module_Renames {
|
|||
nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase)
|
||||
import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */
|
||||
Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */
|
||||
Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase-index-int)) like nomarshal ht, but shared from provider */
|
||||
Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase_and_marks))
|
||||
phase_and_marks -> phase-index-int OR
|
||||
(cons (nonempty-listof mark) phase-index-int)
|
||||
like nomarshal ht, but shared from provider */
|
||||
Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module;
|
||||
this table maps a top-level-bound identifier with a non-empty mark
|
||||
set to a gensym created for the binding */
|
||||
|
|
@ -1320,23 +1323,29 @@ void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *m
|
|||
Scheme_Module_Phase_Exports *pt,
|
||||
Scheme_Object *unmarshal_phase_index,
|
||||
Scheme_Object *src_phase_index,
|
||||
Scheme_Object *marks,
|
||||
int save_unmarshal)
|
||||
{
|
||||
Module_Renames *mrn = (Module_Renames *)rn;
|
||||
Scheme_Object *pr;
|
||||
Scheme_Object *pr, *index_plus_marks;
|
||||
|
||||
check_not_sealed(mrn);
|
||||
|
||||
if (SCHEME_PAIRP(marks))
|
||||
index_plus_marks = scheme_make_pair(marks, src_phase_index);
|
||||
else
|
||||
index_plus_marks = src_phase_index;
|
||||
|
||||
pr = scheme_make_pair(scheme_make_pair(modidx,
|
||||
scheme_make_pair((Scheme_Object *)pt,
|
||||
src_phase_index)),
|
||||
index_plus_marks)),
|
||||
mrn->shared_pes);
|
||||
mrn->shared_pes = pr;
|
||||
|
||||
if (save_unmarshal) {
|
||||
pr = scheme_make_pair(scheme_make_pair(modidx,
|
||||
scheme_make_pair(unmarshal_phase_index,
|
||||
src_phase_index)),
|
||||
index_plus_marks)),
|
||||
mrn->unmarshal_info);
|
||||
mrn->unmarshal_info = pr;
|
||||
}
|
||||
|
|
@ -3155,13 +3164,51 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
|
|||
}
|
||||
}
|
||||
|
||||
static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, Scheme_Object *glob_id,
|
||||
static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache)
|
||||
{
|
||||
int l1, l2;
|
||||
Scheme_Object *m1, *m2;
|
||||
|
||||
p = SCHEME_CDR(p); /* skip modidx */
|
||||
p = SCHEME_CDR(p); /* skip phase_export */
|
||||
if (SCHEME_PAIRP(p)) {
|
||||
/* has marks */
|
||||
|
||||
m1 = SCHEME_CAR(p);
|
||||
if (*marks_cache)
|
||||
m2 = *marks_cache;
|
||||
else {
|
||||
m2 = scheme_stx_extract_marks(orig_id);
|
||||
*marks_cache = m2;
|
||||
}
|
||||
|
||||
l1 = scheme_list_length(m1);
|
||||
l2 = scheme_list_length(m2);
|
||||
|
||||
if (l2 < l1) return -1; /* no match */
|
||||
|
||||
while (l2 > l1) {
|
||||
m2 = SCHEME_CDR(m2);
|
||||
l2--;
|
||||
}
|
||||
|
||||
if (scheme_equal(m1, m2))
|
||||
return l1; /* matches */
|
||||
else
|
||||
return -1; /* no match */
|
||||
} else
|
||||
return 0; /* match empty mark set */
|
||||
}
|
||||
|
||||
static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes,
|
||||
Scheme_Object *glob_id, Scheme_Object *orig_id,
|
||||
Scheme_Object **get_names, int get_orig_name)
|
||||
{
|
||||
Scheme_Object *pr, *idx, *pos, *src;
|
||||
Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL;
|
||||
Scheme_Module_Phase_Exports *pt;
|
||||
Scheme_Hash_Table *ht;
|
||||
int i, phase;
|
||||
int i, phase, best_match_len = -1;
|
||||
Scheme_Object *marks_cache = NULL;
|
||||
|
||||
for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) {
|
||||
pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr));
|
||||
|
|
@ -3177,69 +3224,87 @@ static Scheme_Object *scheme_search_shared_pes(Scheme_Object *shared_pes, Scheme
|
|||
|
||||
pos = scheme_hash_get(pt->ht, glob_id);
|
||||
if (pos) {
|
||||
/* found it; return suitable rename: */
|
||||
idx = SCHEME_CAR(SCHEME_CAR(pr));
|
||||
/* Found it, maybe. Check marks. */
|
||||
int mark_len;
|
||||
mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache);
|
||||
if (mark_len > best_match_len) {
|
||||
/* Marks match and improve on previously found match. Build suitable rename: */
|
||||
best_match_len = mark_len;
|
||||
|
||||
idx = SCHEME_CAR(SCHEME_CAR(pr));
|
||||
|
||||
i = SCHEME_INT_VAL(pos);
|
||||
i = SCHEME_INT_VAL(pos);
|
||||
|
||||
if (get_orig_name)
|
||||
return pt->provide_src_names[i];
|
||||
if (get_orig_name)
|
||||
best_match = pt->provide_src_names[i];
|
||||
else {
|
||||
if (pt->provide_srcs)
|
||||
src = pt->provide_srcs[i];
|
||||
else
|
||||
src = scheme_false;
|
||||
|
||||
if (pt->provide_srcs)
|
||||
src = pt->provide_srcs[i];
|
||||
else
|
||||
src = scheme_false;
|
||||
if (get_names) {
|
||||
/* If module bound, result is module idx, and get_names[0] is set to source name,
|
||||
get_names[1] is set to the nominal source module, get_names[2] is set to
|
||||
the nominal source module's export, get_names[3] is set to the phase of
|
||||
the source definition, get_names[4] is set to the module import phase index,
|
||||
and get_names[5] is set to the nominal export phase */
|
||||
|
||||
if (get_names) {
|
||||
/* If module bound, result is module idx, and get_names[0] is set to source name,
|
||||
get_names[1] is set to the nominal source module, get_names[2] is set to
|
||||
the nominal source module's export, get_names[3] is set to the phase of
|
||||
the source definition, get_names[4] is set to the module import phase index,
|
||||
and get_names[5] is set to the nominal export phase */
|
||||
if (pt->provide_src_phases)
|
||||
phase = pt->provide_src_phases[i];
|
||||
else
|
||||
phase = 0;
|
||||
|
||||
if (pt->provide_src_phases)
|
||||
phase = pt->provide_src_phases[i];
|
||||
else
|
||||
phase = 0;
|
||||
get_names[0] = pt->provide_src_names[i];
|
||||
get_names[1] = idx;
|
||||
get_names[2] = glob_id;
|
||||
get_names[3] = scheme_make_integer(phase);
|
||||
get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr)));
|
||||
if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */
|
||||
get_names[4] = SCHEME_CDR(get_names[4]);
|
||||
get_names[5] = pt->phase_index;
|
||||
}
|
||||
|
||||
get_names[0] = pt->provide_src_names[i];
|
||||
get_names[1] = idx;
|
||||
get_names[2] = glob_id;
|
||||
get_names[3] = scheme_make_integer(phase);
|
||||
get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr)));
|
||||
get_names[5] = pt->phase_index;
|
||||
if (SCHEME_FALSEP(src)) {
|
||||
src = idx;
|
||||
} else {
|
||||
src = scheme_modidx_shift(src, pt->src_modidx, idx);
|
||||
}
|
||||
|
||||
best_match = src;
|
||||
}
|
||||
}
|
||||
|
||||
if (SCHEME_FALSEP(src)) {
|
||||
src = idx;
|
||||
} else {
|
||||
src = scheme_modidx_shift(src, pt->src_modidx, idx);
|
||||
}
|
||||
|
||||
return src;
|
||||
}
|
||||
|
||||
if (pt->reprovide_kernel) {
|
||||
} else if (pt->reprovide_kernel) {
|
||||
Scheme_Object *kpr;
|
||||
kpr = scheme_hash_get(krn->ht, glob_id);
|
||||
if (kpr) {
|
||||
if (get_orig_name)
|
||||
return glob_id;
|
||||
if (get_names) {
|
||||
idx = SCHEME_CAR(SCHEME_CAR(kpr));
|
||||
get_names[0] = glob_id;
|
||||
get_names[1] = idx;
|
||||
get_names[2] = glob_id;
|
||||
get_names[3] = scheme_make_integer(0);
|
||||
get_names[4] = pt->phase_index;
|
||||
get_names[5] = scheme_make_integer(0);
|
||||
/* Found it, maybe. Check marks. */
|
||||
int mark_len;
|
||||
mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache);
|
||||
if (mark_len > best_match_len) {
|
||||
/* Marks match and improve on previously found match. Build suitable rename: */
|
||||
best_match_len = mark_len;
|
||||
|
||||
if (get_orig_name)
|
||||
best_match = glob_id;
|
||||
else {
|
||||
if (get_names) {
|
||||
idx = SCHEME_CAR(SCHEME_CAR(kpr));
|
||||
get_names[0] = glob_id;
|
||||
get_names[1] = idx;
|
||||
get_names[2] = glob_id;
|
||||
get_names[3] = scheme_make_integer(0);
|
||||
get_names[4] = pt->phase_index;
|
||||
get_names[5] = scheme_make_integer(0);
|
||||
}
|
||||
best_match = scheme_get_kernel_modidx();
|
||||
}
|
||||
}
|
||||
return scheme_get_kernel_modidx();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return NULL;
|
||||
return best_match;
|
||||
}
|
||||
|
||||
static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object *phase)
|
||||
|
|
@ -3457,7 +3522,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
}
|
||||
get_names_done = 0;
|
||||
if (!rename) {
|
||||
rename = scheme_search_shared_pes(mrn->shared_pes, glob_id, get_names, 0);
|
||||
rename = scheme_search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0);
|
||||
if (rename)
|
||||
get_names_done = 1;
|
||||
}
|
||||
|
|
@ -3841,7 +3906,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
|
|||
rename = scheme_hash_get(krn->ht, glob_id);
|
||||
|
||||
if (!rename)
|
||||
result = scheme_search_shared_pes(mrn->shared_pes, glob_id, NULL, 1);
|
||||
result = scheme_search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1);
|
||||
else if (rename) {
|
||||
/* match; set result: */
|
||||
if (mrn->kind == mzMOD_RENAME_MARKED)
|
||||
|
|
@ -5405,6 +5470,8 @@ static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Unmarshal_Tables
|
|||
|
||||
if (SCHEME_INTP(a) && IS_POSMARK(a))
|
||||
a = scheme_make_integer(-SCHEME_INT_VAL(a));
|
||||
else if (!SCHEME_NUMBERP(a))
|
||||
return NULL;
|
||||
else
|
||||
a = scheme_intern_symbol(scheme_number_to_string(10, a));
|
||||
|
||||
|
|
@ -5554,6 +5621,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
|
|||
|
||||
if (!SCHEME_PAIRP(a)) return_NULL;
|
||||
set_identity = unmarshal_mark(SCHEME_CAR(a), ut);
|
||||
if (!set_identity) return_NULL;
|
||||
a = SCHEME_CDR(a);
|
||||
|
||||
mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL);
|
||||
|
|
@ -5566,9 +5634,10 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
|
|||
|
||||
if (!SCHEME_VECTORP(a)) {
|
||||
/* Unmarshall info: */
|
||||
Scheme_Object *ml = a, *mli;
|
||||
Scheme_Object *ml = a, *mli, *first = scheme_null, *last = NULL, *ai;
|
||||
while (SCHEME_PAIRP(ml)) {
|
||||
mli = SCHEME_CAR(ml);
|
||||
ai = SCHEME_CAR(ml);
|
||||
mli = ai;
|
||||
if (!SCHEME_PAIRP(mli)) return_NULL;
|
||||
|
||||
/* A module path index: */
|
||||
|
|
@ -5580,24 +5649,57 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
|
|||
|
||||
if (!SCHEME_PAIRP(mli)) return_NULL;
|
||||
|
||||
/* A phase/dimension index */
|
||||
/* A phase/dimension index k */
|
||||
p = SCHEME_CAR(mli);
|
||||
if (!ok_phase_index(p))
|
||||
return_NULL;
|
||||
|
||||
p = SCHEME_CDR(mli);
|
||||
if (SCHEME_PAIRP(p) && SCHEME_PAIRP(SCHEME_CAR(p))) {
|
||||
/* list of marks: */
|
||||
Scheme_Object *m_first = scheme_null, *m_last = NULL, *mp, *after_marks;
|
||||
|
||||
after_marks = SCHEME_CDR(p);
|
||||
mli = SCHEME_CAR(p);
|
||||
|
||||
while (SCHEME_PAIRP(mli)) {
|
||||
p = SCHEME_CAR(mli);
|
||||
p = unmarshal_mark(p, ut);
|
||||
if (!p) return_NULL;
|
||||
|
||||
mp = scheme_make_pair(p, scheme_null);
|
||||
if (m_last)
|
||||
SCHEME_CDR(m_last) = mp;
|
||||
else
|
||||
m_first = mp;
|
||||
m_last = mp;
|
||||
|
||||
mli = SCHEME_CDR(mli);
|
||||
}
|
||||
|
||||
/* Rebuild for unmarshaled marks: */
|
||||
ai = scheme_make_pair(SCHEME_CAR(ai),
|
||||
scheme_make_pair(SCHEME_CADR(ai),
|
||||
scheme_make_pair(m_first, after_marks)));
|
||||
|
||||
if (!SCHEME_NULLP(mli)) return_NULL;
|
||||
p = after_marks;
|
||||
}
|
||||
|
||||
if (ok_phase_index(p)) {
|
||||
/* For a shared table: (cons k src-phase-index) */
|
||||
/* For a shared table: src-phase-index */
|
||||
} else {
|
||||
/* For a non-shared table: (list* src-phase-index exceptions prefix), after k */
|
||||
mli = p;
|
||||
if (!SCHEME_PAIRP(mli)) return_NULL;
|
||||
|
||||
/* For a shared table: (cons k src-phase-index) */
|
||||
p = SCHEME_CAR(mli);
|
||||
if (!ok_phase_index(p))
|
||||
return_NULL;
|
||||
mli = SCHEME_CDR(mli);
|
||||
|
||||
if (!SCHEME_PAIRP(mli)) return_NULL;
|
||||
|
||||
/* A list of symbols: */
|
||||
p = SCHEME_CAR(mli);
|
||||
while (SCHEME_PAIRP(p)) {
|
||||
|
|
@ -5612,11 +5714,19 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
|
|||
}
|
||||
|
||||
ml = SCHEME_CDR(ml);
|
||||
|
||||
/* rebuild, in case we converted marks */
|
||||
p = scheme_make_pair(ai, scheme_null);
|
||||
if (last)
|
||||
SCHEME_CDR(last) = p;
|
||||
else
|
||||
first = p;
|
||||
last = p;
|
||||
}
|
||||
if (!SCHEME_NULLP(ml)) return_NULL;
|
||||
|
||||
mrn->unmarshal_info = a;
|
||||
if (SCHEME_PAIRP(a))
|
||||
mrn->unmarshal_info = first;
|
||||
if (SCHEME_PAIRP(first))
|
||||
mrn->needs_unmarshal = 1;
|
||||
|
||||
if (!SCHEME_PAIRP(mns)) return_NULL;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user