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

bitwise ops accept 0 arguments; module and local binding expansion more consistent, because a module-level binding can have let-binding context; load/cd fixed; X non-Xft font problem fixed; added openbsd support and chage README in libffi; JIT inlines string-ref and bytes-ref

Browse Source 
svn: r2689
This commit is contained in:
Matthew Flatt 2006-04-17 16:58:43 +00:00
parent 0c25abb469
commit a07b22f1f1
30 changed files with 1274 additions and 1000 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/foreign/README Normal file
View File

@ -0,0 +1,12 @@
The copy of libffi for PLT Scheme has been changed in a few small
ways:
* Added i386 Mac OS X support from the PyObjC project:
gcc/libffi/src/x86/ffi_darwin.c
gcc/libffi/src/x86/darwin.S
and changed ffi.c and sysv.S to #include these when __APPLE__
is defined.
* Added line to "configure" for i*86-*-darwin*
* Added line to "configure" for i*86-*-openbsd*

1
src/foreign/gcc/libffi/configure vendored
View File

@ -5383,6 +5383,7 @@ i*86-*-solaris2.1[0-9]*) TARGET=X86_64; TARGETDIR=x86;;
i*86-*-solaris*) TARGET=X86; TARGETDIR=x86;; i*86-*-solaris*) TARGET=X86; TARGETDIR=x86;;
i*86-*-beos*) TARGET=X86; TARGETDIR=x86;; i*86-*-beos*) TARGET=X86; TARGETDIR=x86;;
i*86-*-freebsd* | i*86-*-kfreebsd*-gnu) TARGET=X86; TARGETDIR=x86;; i*86-*-freebsd* | i*86-*-kfreebsd*-gnu) TARGET=X86; TARGETDIR=x86;;
i*86-*-openbsd* | i*86-*-kopenbsd*-gnu) TARGET=X86; TARGETDIR=x86;;
i*86-*-netbsdelf* | i*86-*-knetbsd*-gnu) TARGET=X86; TARGETDIR=x86;; i*86-*-netbsdelf* | i*86-*-knetbsd*-gnu) TARGET=X86; TARGETDIR=x86;;
i*86-*-rtems*) TARGET=X86; TARGETDIR=x86;; i*86-*-rtems*) TARGET=X86; TARGETDIR=x86;;
i*86-*-darwin*) TARGET=X86; TARGETDIR=x86;; i*86-*-darwin*) TARGET=X86; TARGETDIR=x86;;

4
src/mzscheme/include/mzscheme.exp
View File

@ -418,10 +418,6 @@ scheme_lookup_global
scheme_global_bucket scheme_global_bucket
scheme_global_keyword_bucket scheme_global_keyword_bucket
scheme_module_bucket scheme_module_bucket
scheme_exptime_global_bucket
scheme_exptime_expdef_global_bucket
scheme_exptime_module_bucket
scheme_exptime_expdef_module_bucket
scheme_builtin_value scheme_builtin_value
scheme_set_global_bucket scheme_set_global_bucket
scheme_install_macro scheme_install_macro

4
src/mzscheme/include/mzscheme3m.exp
View File

@ -425,10 +425,6 @@ scheme_lookup_global
scheme_global_bucket scheme_global_bucket
scheme_global_keyword_bucket scheme_global_keyword_bucket
scheme_module_bucket scheme_module_bucket
scheme_exptime_global_bucket
scheme_exptime_expdef_global_bucket
scheme_exptime_module_bucket
scheme_exptime_expdef_module_bucket
scheme_builtin_value scheme_builtin_value
scheme_set_global_bucket scheme_set_global_bucket
scheme_install_macro scheme_install_macro

4
src/mzscheme/include/mzwin.def
View File

@ -410,10 +410,6 @@ EXPORTS
scheme_global_bucket scheme_global_bucket
scheme_global_keyword_bucket scheme_global_keyword_bucket
scheme_module_bucket scheme_module_bucket
scheme_exptime_global_bucket
scheme_exptime_expdef_global_bucket
scheme_exptime_module_bucket
scheme_exptime_expdef_module_bucket
scheme_builtin_value scheme_builtin_value
scheme_set_global_bucket scheme_set_global_bucket
scheme_install_macro scheme_install_macro

2
src/mzscheme/include/scheme.h
View File

@ -734,7 +734,7 @@ typedef struct Scheme_Hash_Table
void (*make_hash_indices)(void *v, long *h1, long *h2); void (*make_hash_indices)(void *v, long *h1, long *h2);
int (*compare)(void *v1, void *v2); int (*compare)(void *v1, void *v2);
Scheme_Object *mutex; Scheme_Object *mutex;
int mcount; /* number of non-null keys, <= count */ int mcount; /* number of non-NULL keys, >= count (which is non-NULL vals) */
} Scheme_Hash_Table; } Scheme_Hash_Table;

1409
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

138
src/mzscheme/src/env.c
View File

@ -615,9 +615,30 @@ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client
/* namespace constructors */ /* namespace constructors */
/*========================================================================*/ /*========================================================================*/
static void create_env_marked_names(Scheme_Env *e)
{
Scheme_Hash_Table *mn;
Scheme_Object *rn;
/* Set up a rename table, in case an identifier with a let-binding
renaming ends up in a definition position: */
mn = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(mn, scheme_false, scheme_null);
e->marked_names = mn;
rn = scheme_make_module_rename(e->phase, mzMOD_RENAME_TOPLEVEL, mn);
e->rename = rn;
}
Scheme_Env *scheme_make_empty_env(void) Scheme_Env *scheme_make_empty_env(void)
{ {
return make_env(NULL, 0, 7); Scheme_Env *e;
e = make_env(NULL, 0, 7);
create_env_marked_names(e);
return e;
} }
static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size) static Scheme_Env *make_env(Scheme_Env *base, int semi, int toplevel_size)
@ -720,6 +741,9 @@ void scheme_prepare_exp_env(Scheme_Env *env)
env->exp_env = eenv; env->exp_env = eenv;
eenv->template_env = env; eenv->template_env = env;
if (!env->module && !env->phase)
create_env_marked_names(eenv);
} }
} }
@ -902,21 +926,6 @@ scheme_global_keyword_bucket(Scheme_Object *symbol, Scheme_Env *env)
return b; return b;
} }
Scheme_Bucket *
scheme_exptime_global_bucket(Scheme_Object *symbol, Scheme_Env *env)
{
/* This is for mzc, but it can't be right. */
scheme_prepare_exp_env(env);
return scheme_global_bucket(symbol, env->exp_env);
}
Scheme_Bucket *
scheme_exptime_expdef_global_bucket(Scheme_Object *symbol, Scheme_Env *env)
{
scheme_prepare_exp_env(env);
return scheme_global_bucket(symbol, env->exp_env);
}
/********** Set **********/ /********** Set **********/
void void
@ -1577,11 +1586,11 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
return val; return val;
} }
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def) Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def)
/* The `env' argument can actually be a hash table. */ /* The `env' argument can actually be a hash table. */
{ {
Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm; Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg;
int best_match_skipped, ms; int best_match_skipped, ms, one_mark;
Scheme_Hash_Table *marked_names; Scheme_Hash_Table *marked_names;
sym = SCHEME_STX_SYM(id); sym = SCHEME_STX_SYM(id);
@ -1599,8 +1608,10 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
/* If we're defining, see if we need to create a table. Getting /* If we're defining, see if we need to create a table. Getting
marks is relatively expensive, but we only do this once per marks is relatively expensive, but we only do this once per
definition. */ definition. */
if (!bdg)
bdg = scheme_stx_moduleless_env(id, 0 /* renames currently don't depend on phase */);
marks = scheme_stx_extract_marks(id); marks = scheme_stx_extract_marks(id);
if (SCHEME_NULLP(marks)) if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg))
return sym; return sym;
} }
@ -1608,7 +1619,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
marked_names = scheme_make_hash_table(SCHEME_hash_ptr); marked_names = scheme_make_hash_table(SCHEME_hash_ptr);
env->marked_names = marked_names; env->marked_names = marked_names;
} }
map = scheme_hash_get(marked_names, sym); map = scheme_hash_get(marked_names, sym);
if (!map) { if (!map) {
@ -1619,10 +1630,15 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
map = scheme_null; map = scheme_null;
} }
if (!bdg) {
/* We need lexical binding, if any, too: */
bdg = scheme_stx_moduleless_env(id, 0 /* renames currently don't depend on phase */);
}
if (!marks) { if (!marks) {
/* We really do need the marks. Get them. */ /* We really do need the marks. Get them. */
marks = scheme_stx_extract_marks(id); marks = scheme_stx_extract_marks(id);
if (SCHEME_NULLP(marks)) if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg))
return sym; return sym;
} }
@ -1633,43 +1649,57 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
Since the list is otherwise marshaled into .zo, etc., Since the list is otherwise marshaled into .zo, etc.,
simplify by extracting just the mark: */ simplify by extracting just the mark: */
marks = SCHEME_CAR(marks); marks = SCHEME_CAR(marks);
} one_mark = 1;
} else
one_mark = 0;
if (!SCHEME_TRUEP(bdg))
bdg = NULL;
/* Find a mapping that matches the longest tail of marks */ /* Find a mapping that matches the longest tail of marks */
for (l = map; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { for (l = map; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l); a = SCHEME_CAR(l);
amarks = SCHEME_CAR(a); amarks = SCHEME_CAR(a);
if (is_def) {
if (scheme_equal(amarks, marks)) { if (SCHEME_VECTORP(amarks)) {
best_match = SCHEME_CDR(a); abdg = SCHEME_VEC_ELS(amarks)[1];
break; amarks = SCHEME_VEC_ELS(amarks)[0];
} } else
} else { abdg = NULL;
if (!SCHEME_PAIRP(marks)) {
/* To be better than nothing, could only match exactly: */ if (SAME_OBJ(abdg, bdg)) {
if (SAME_OBJ(amarks, marks)) { if (is_def) {
if (scheme_equal(amarks, marks)) {
best_match = SCHEME_CDR(a); best_match = SCHEME_CDR(a);
best_match_skipped = 0; break;
} }
} else { } else {
/* amarks can match a tail of marks: */ if (!SCHEME_PAIRP(marks)) {
for (m = marks, ms = 0; /* To be better than nothing, could only match exactly: */
SCHEME_PAIRP(m) && (ms < best_match_skipped); if (scheme_equal(amarks, marks)) {
m = SCHEME_CDR(m), ms++) {
cm = m;
if (!SCHEME_PAIRP(amarks)) {
/* If we're down to the last element
of marks, then extract it to try to
match the symbol amarks. */
if (SCHEME_NULLP(SCHEME_CDR(m)))
cm = SCHEME_CAR(m);
}
if (scheme_equal(amarks, cm)) {
best_match = SCHEME_CDR(a); best_match = SCHEME_CDR(a);
best_match_skipped = ms; best_match_skipped = 0;
break; }
} else {
/* amarks can match a tail of marks: */
for (m = marks, ms = 0;
SCHEME_PAIRP(m) && (ms < best_match_skipped);
m = SCHEME_CDR(m), ms++) {
cm = m;
if (!SCHEME_PAIRP(amarks)) {
/* If we're down to the last element
of marks, then extract it to try to
match the symbol amarks. */
if (SCHEME_NULLP(SCHEME_CDR(m)))
cm = SCHEME_CAR(m);
}
if (scheme_equal(amarks, cm)) {
best_match = SCHEME_CDR(a);
best_match_skipped = ms;
break;
}
} }
} }
} }
@ -1742,6 +1772,12 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
/* Otherwise, increment counter and try again... */ /* Otherwise, increment counter and try again... */
} }
} }
if (bdg) {
a = scheme_make_vector(2, NULL);
SCHEME_VEC_ELS(a)[0] = marks;
SCHEME_VEC_ELS(a)[1] = bdg;
marks = a;
}
a = scheme_make_pair(marks, best_match); a = scheme_make_pair(marks, best_match);
map = scheme_make_pair(a, map); map = scheme_make_pair(a, map);
@ -2336,7 +2372,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
*_menv = genv; *_menv = genv;
if (!modname && SCHEME_STXP(find_id)) if (!modname && SCHEME_STXP(find_id))
find_global_id = scheme_tl_id_sym(env->genv, find_id, 0); find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0);
else else
find_global_id = find_id; find_global_id = find_id;

8
src/mzscheme/src/eval.c
View File

@ -3596,7 +3596,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
/* If form is a marked name, then force #%top binding. /* If form is a marked name, then force #%top binding.
This is so temporaries can be used as defined ids. */ This is so temporaries can be used as defined ids. */
Scheme_Object *nm; Scheme_Object *nm;
nm = scheme_tl_id_sym(env->genv, form, 0); nm = scheme_tl_id_sym(env->genv, form, NULL, 0);
if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) { if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) {
stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0);
@ -3861,7 +3861,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co
Scheme_Object *modidx, *symbol = c, *tl_id; Scheme_Object *modidx, *symbol = c, *tl_id;
int bad; int bad;
tl_id = scheme_tl_id_sym(env->genv, symbol, 0); tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0);
if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
/* Since the module has a rename for this id, it's certainly defined. */ /* Since the module has a rename for this id, it's certainly defined. */
} else { } else {
@ -3897,7 +3897,7 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
c = check_top(scheme_compile_stx_string, form, env); c = check_top(scheme_compile_stx_string, form, env);
c = scheme_tl_id_sym(env->genv, c, 0); c = scheme_tl_id_sym(env->genv, c, NULL, 0);
if (env->genv->module && !rec[drec].resolve_module_ids) { if (env->genv->module && !rec[drec].resolve_module_ids) {
/* Self-reference in a module; need to remember the modidx. Don't /* Self-reference in a module; need to remember the modidx. Don't
@ -6355,7 +6355,7 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob
Scheme_Object *l; Scheme_Object *l;
/* Registers marked id: */ /* Registers marked id: */
scheme_tl_id_sym(env->genv, *_id, 2); scheme_tl_id_sym(env->genv, *_id, scheme_false, 2);
l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0), l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0),
icons(scheme_make_immutable_pair(*_id, scheme_null), icons(scheme_make_immutable_pair(*_id, scheme_null),

19
src/mzscheme/src/fun.c
View File

@ -3119,8 +3119,13 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
saved->type = scheme_rt_saved_stack; saved->type = scheme_rt_saved_stack;
#endif #endif
if (share_from && (share_from->ss.runstack_start == runstack_start)) { if (share_from && (share_from->ss.runstack_start == runstack_start)) {
/* Copy just the difference between share_from's runstack and current runstack */ /* Copy just the difference between share_from's runstack and current runstack... */
size = (share_from->ss.runstack XFORM_OK_MINUS runstack); size = (share_from->ss.runstack XFORM_OK_MINUS runstack);
/* But add one, because call/cc takes one argument. If there's not one
move value on the stack, then call/cc must have received its argument
from elsewhere. */
if ((share_from->ss.runstack XFORM_OK_MINUS runstack_start) < p->runstack_size)
size++;
} else { } else {
size = p->runstack_size - (runstack XFORM_OK_MINUS runstack_start); size = p->runstack_size - (runstack XFORM_OK_MINUS runstack_start);
} }
@ -3563,10 +3568,14 @@ internal_call_cc (int argc, Scheme_Object *argv[])
/* Copy shared part in: */ /* Copy shared part in: */
sub_cont = sub_cont->buf.cont; sub_cont = sub_cont->buf.cont;
size = sub_cont->runstack_copied->runstack_size; size = sub_cont->runstack_copied->runstack_size;
memcpy(MZ_RUNSTACK XFORM_OK_PLUS done, if (size) {
sub_cont->runstack_copied->runstack_start, /* Skip the first item, since that's the call/cc argument,
size * sizeof(Scheme_Object *)); which we don't want from the outer continuation. */
done += size; memcpy(MZ_RUNSTACK XFORM_OK_PLUS done,
sub_cont->runstack_copied->runstack_start + 1,
(size - 1) * sizeof(Scheme_Object *));
done += (size - 1);
}
} else } else
break; break;
} }

227
src/mzscheme/src/jit.c
View File

@ -78,6 +78,9 @@ END_XFORM_ARITH;
#define WORDS_TO_BYTES(x) ((x) << JIT_LOG_WORD_SIZE) #define WORDS_TO_BYTES(x) ((x) << JIT_LOG_WORD_SIZE)
#define MAX_TRY_SHIFT 30 #define MAX_TRY_SHIFT 30
/* a mzchar is an int: */
#define LOG_MZCHAR_SIZE 2
#if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_X86_64) #if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_X86_64)
# define NEED_LONG_JUMPS # define NEED_LONG_JUMPS
#endif #endif
@ -105,6 +108,8 @@ static void *call_original_binary_arith_for_branch_code;
static void *call_original_binary_rev_arith_for_branch_code; static void *call_original_binary_rev_arith_for_branch_code;
static void *bad_car_code, *bad_cdr_code; static void *bad_car_code, *bad_cdr_code;
static void *vector_ref_code, *vector_ref_check_index_code; static void *vector_ref_code, *vector_ref_check_index_code;
static void *string_ref_code, *string_ref_check_index_code;
static void *bytes_ref_code, *bytes_ref_check_index_code;
static void *syntax_e_code; static void *syntax_e_code;
static void *on_demand_jit_code; static void *on_demand_jit_code;
static void *on_demand_jit_arity_code; static void *on_demand_jit_arity_code;
@ -2557,8 +2562,18 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} else if (IS_NAMED_PRIM(rator, "arithmetic-shift")) { } else if (IS_NAMED_PRIM(rator, "arithmetic-shift")) {
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1); generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1);
return 1; return 1;
} else if (IS_NAMED_PRIM(rator, "vector-ref")) { } else if (IS_NAMED_PRIM(rator, "vector-ref")
|| IS_NAMED_PRIM(rator, "string-ref")
|| IS_NAMED_PRIM(rator, "bytes-ref")) {
int simple; int simple;
int which;
if (IS_NAMED_PRIM(rator, "vector-ref"))
which = 0;
else if (IS_NAMED_PRIM(rator, "string-ref"))
which = 1;
else
which = 2;
LOG_IT(("inlined vector-ref?\n")); LOG_IT(("inlined vector-ref?\n"));
@ -2590,14 +2605,31 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
mz_runstack_popped(jitter, 1); mz_runstack_popped(jitter, 1);
(void)jit_calli(vector_ref_check_index_code); if (!which) {
(void)jit_calli(vector_ref_check_index_code);
} else if (which == 1) {
(void)jit_calli(string_ref_check_index_code);
} else {
(void)jit_calli(bytes_ref_check_index_code);
}
} else { } else {
long offset; long offset;
offset = SCHEME_INT_VAL(app->rand2); offset = SCHEME_INT_VAL(app->rand2);
(void)jit_movi_p(JIT_R1, offset); (void)jit_movi_p(JIT_R1, offset);
offset = ((int)&SCHEME_VEC_ELS(0x0)) + WORDS_TO_BYTES(SCHEME_INT_VAL(app->rand2)); if (!which)
offset = ((int)&SCHEME_VEC_ELS(0x0)) + WORDS_TO_BYTES(SCHEME_INT_VAL(app->rand2));
else if (which == 1)
offset = SCHEME_INT_VAL(app->rand2) << LOG_MZCHAR_SIZE;
else
offset = SCHEME_INT_VAL(app->rand2);
jit_movi_l(JIT_V1, offset); jit_movi_l(JIT_V1, offset);
(void)jit_calli(vector_ref_code); if (!which) {
(void)jit_calli(vector_ref_code);
} else if (which == 1) {
(void)jit_calli(string_ref_code);
} else {
(void)jit_calli(bytes_ref_code);
}
} }
if (simple) if (simple)
@ -3006,8 +3038,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
jit_ldi_p(JIT_R0, &scheme_current_thread); jit_ldi_p(JIT_R0, &scheme_current_thread);
CHECK_LIMIT(); CHECK_LIMIT();
jit_ldxi_i(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.count); jit_ldxi_i(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.count);
jit_lshi_i(JIT_V1, JIT_V1, 0x1); jit_lshi_l(JIT_V1, JIT_V1, 0x1);
jit_ori_i(JIT_V1, JIT_V1, 0x1); jit_ori_l(JIT_V1, JIT_V1, 0x1);
mz_pushr_p(JIT_V1); mz_pushr_p(JIT_V1);
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.array); jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.array);
mz_pushr_p(JIT_V1); /* !!!!!!!! */ mz_pushr_p(JIT_V1); /* !!!!!!!! */
@ -3743,7 +3775,7 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
static int do_generate_common(mz_jit_state *jitter, void *_data) static int do_generate_common(mz_jit_state *jitter, void *_data)
{ {
int in, i; int in, i, ii;
GC_CAN_IGNORE jit_insn *ref, *ref2; GC_CAN_IGNORE jit_insn *ref, *ref2;
/* *** check_arity_code *** */ /* *** check_arity_code *** */
@ -4043,8 +4075,8 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
jit_sti_p(&stack_cache_stack_pos, JIT_R2); jit_sti_p(&stack_cache_stack_pos, JIT_R2);
CHECK_LIMIT(); CHECK_LIMIT();
/* Extract old return address and jump to it */ /* Extract old return address and jump to it */
jit_lshi_i(JIT_R1, JIT_R1, (JIT_LOG_WORD_SIZE + 2)); jit_lshi_l(JIT_R1, JIT_R1, (JIT_LOG_WORD_SIZE + 2));
jit_addi_i(JIT_R1, JIT_R1, (int)&((Stack_Cache_Elem *)0x0)->orig_return_address); jit_addi_l(JIT_R1, JIT_R1, (int)&((Stack_Cache_Elem *)0x0)->orig_return_address);
(void)jit_movi_p(JIT_R2, &stack_cache_stack); (void)jit_movi_p(JIT_R2, &stack_cache_stack);
jit_ldxr_p(JIT_R2, JIT_R2, JIT_R1); jit_ldxr_p(JIT_R2, JIT_R2, JIT_R1);
jit_movr_p(JIT_RET, JIT_R0); jit_movr_p(JIT_RET, JIT_R0);
@ -4054,63 +4086,140 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
jit_jmpr(JIT_R2); jit_jmpr(JIT_R2);
CHECK_LIMIT(); CHECK_LIMIT();
/* *** vector_ref_[check_index_]code *** */ /* *** {vector,string,bytes}_ref_[check_index_]code *** */
/* R0 is vector, R1 is index (Scheme number in check-index mode), /* R0 is vector/string/bytes, R1 is index (Scheme number in check-index mode),
V1 is vector offset in non-check-index mode */ V1 is vector/string/bytes offset in non-check-index mode (and for
for (i = 0; i < 2; i++) { vector, it includes the offset to the start of the elements array. */
jit_insn *ref, *reffail; for (ii = 0; ii < 3; ii++) {
for (i = 0; i < 2; i++) {
jit_insn *ref, *reffail;
Scheme_Type ty;
int offset, count_offset, log_elem_size;
if (!i) { switch (ii) {
vector_ref_code = jit_get_ip().ptr; case 0:
} else { ty = scheme_vector_type;
vector_ref_check_index_code = jit_get_ip().ptr; offset = (int)&SCHEME_VEC_ELS(0x0);
} count_offset = (int)&SCHEME_VEC_SIZE(0x0);
log_elem_size = JIT_LOG_WORD_SIZE;
if (!i) {
vector_ref_code = jit_get_ip().ptr;
} else {
vector_ref_check_index_code = jit_get_ip().ptr;
}
break;
case 1:
ty = scheme_char_string_type;
offset = (int)&SCHEME_CHAR_STR_VAL(0x0);
count_offset = (int)&SCHEME_CHAR_STRLEN_VAL(0x0);
log_elem_size = LOG_MZCHAR_SIZE;
if (!i) {
string_ref_code = jit_get_ip().ptr;
} else {
string_ref_check_index_code = jit_get_ip().ptr;
}
break;
default:
case 2:
ty = scheme_byte_string_type;
offset = (int)&SCHEME_BYTE_STR_VAL(0x0);
count_offset = (int)&SCHEME_BYTE_STRLEN_VAL(0x0);
log_elem_size = 0;
if (!i) {
bytes_ref_code = jit_get_ip().ptr;
} else {
bytes_ref_check_index_code = jit_get_ip().ptr;
}
break;
}
__START_SHORT_JUMPS__(1); __START_SHORT_JUMPS__(1);
mz_prolog(JIT_R2); mz_prolog(JIT_R2);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
CHECK_LIMIT(); CHECK_LIMIT();
reffail = _jit.x.pc; reffail = _jit.x.pc;
if (!i) { if (!i) {
jit_lshi_ul(JIT_R1, JIT_R1, 1); jit_lshi_ul(JIT_R1, JIT_R1, 1);
jit_ori_ul(JIT_R1, JIT_R1, 0x1); jit_ori_ul(JIT_R1, JIT_R1, 0x1);
} }
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
jit_str_p(JIT_RUNSTACK, JIT_R0); jit_str_p(JIT_RUNSTACK, JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1); jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
jit_movi_i(JIT_R1, 2); jit_movi_i(JIT_R1, 2);
JIT_UPDATE_THREAD_RSPTR(); JIT_UPDATE_THREAD_RSPTR();
jit_prepare(2); jit_prepare(2);
jit_pusharg_p(JIT_RUNSTACK); jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R1); jit_pusharg_i(JIT_R1);
(void)mz_finish(scheme_checked_vector_ref); switch (ii) {
/* doesn't return */ case 0:
CHECK_LIMIT(); (void)mz_finish(scheme_checked_vector_ref);
break;
case 1:
(void)mz_finish(scheme_checked_string_ref);
/* might return, if char was outside Latin-1 */
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
jit_retval(JIT_R0);
mz_epilog(JIT_R2);
break;
case 2:
(void)mz_finish(scheme_checked_byte_string_ref);
break;
}
/* doesn't return */
CHECK_LIMIT();
mz_patch_branch(ref); mz_patch_branch(ref);
if (i) { if (i) {
(void)jit_bmci_ul(reffail, JIT_R1, 0x1); (void)jit_bmci_ul(reffail, JIT_R1, 0x1);
(void)jit_blei_l(reffail, JIT_R1, 0x0); (void)jit_blei_l(reffail, JIT_R1, 0x0);
} }
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type); (void)jit_bnei_i(reffail, JIT_R2, ty);
jit_ldxi_i(JIT_R2, JIT_R0, &SCHEME_VEC_SIZE(0x0)); jit_ldxi_i(JIT_R2, JIT_R0, count_offset);
if (i) { if (i) {
jit_rshi_ul(JIT_V1, JIT_R1, 1); /* index from expression: */
(void)jit_bler_ul(reffail, JIT_R2, JIT_V1); jit_rshi_ul(JIT_V1, JIT_R1, 1);
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); (void)jit_bler_ul(reffail, JIT_R2, JIT_V1);
jit_addi_p(JIT_V1, JIT_V1, ((int)&SCHEME_VEC_ELS(0x0))); if (log_elem_size)
} else { jit_lshi_ul(JIT_V1, JIT_V1, log_elem_size);
(void)jit_bler_ul(reffail, JIT_R2, JIT_R1); if (!ii) /* vector */
} jit_addi_p(JIT_V1, JIT_V1, offset);
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1); } else {
mz_epilog(JIT_R2); /* constant index supplied: */
CHECK_LIMIT(); (void)jit_bler_ul(reffail, JIT_R2, JIT_R1);
}
switch (ii) {
case 0:
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
break;
case 1:
jit_ldxi_p(JIT_R2, JIT_R0, offset);
jit_ldxr_i(JIT_R2, JIT_R2, JIT_V1);
/* Non-Latin-1 char: use slow path: */
jit_extr_i_l(JIT_R2, JIT_R2);
(void)jit_bgti_l(reffail, JIT_R2, 255);
/* Latin-1: extract from scheme_char_constants: */
jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE);
(void)jit_movi_p(JIT_R0, scheme_char_constants);
jit_ldxr_p(JIT_R0, JIT_R0, JIT_R2);
break;
case 2:
jit_ldxi_p(JIT_R0, JIT_R0, offset);
jit_ldxr_c(JIT_R0, JIT_R0, JIT_V1);
jit_extr_uc_ul(JIT_R0, JIT_R0);
jit_lshi_l(JIT_R0, JIT_R0, 0x1);
jit_ori_l(JIT_R0, JIT_R0, 0x1);
break;
}
mz_epilog(JIT_R2);
CHECK_LIMIT();
__END_SHORT_JUMPS__(1); __END_SHORT_JUMPS__(1);
}
} }
/* *** syntax_ecode *** */ /* *** syntax_ecode *** */

2
src/mzscheme/src/list.c
View File

@ -1941,7 +1941,7 @@ void scheme_clear_ephemerons()
done_ephemerons = NULL; done_ephemerons = NULL;
} }
extern MZ_DLLIMPORT void (*GC_custom_finalize)(void); extern MZ_DLLIMPORT void (*GC_custom_finalize)();
void scheme_init_ephemerons(void) void scheme_init_ephemerons(void)
{ {

87
src/mzscheme/src/module.c
View File

@ -664,6 +664,21 @@ void scheme_install_initial_module_set(Scheme_Env *env)
} }
} }
static void annote_marked_names_nonempty(Scheme_Hash_Table *mn_ht)
{
/* Prevents a module-renaming record for macro-introduced bindings
from being dropped in syntax objects until the module is fully
compiled/expanded. */
scheme_hash_set(mn_ht, scheme_false, scheme_null);
}
static void clear_marked_names_nonempty(Scheme_Hash_Table *mn_ht)
{
/* Clears the annotation, since the module is fully
compiled/expanded. */
scheme_hash_set(mn_ht, scheme_false, NULL);
}
/**********************************************************************/ /**********************************************************************/
/* parameters */ /* parameters */
/**********************************************************************/ /**********************************************************************/
@ -2006,7 +2021,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
supplied (not both). For unprotected access, both prot_insp supplied (not both). For unprotected access, both prot_insp
and stx+certs should be supplied. */ and stx+certs should be supplied. */
{ {
symbol = scheme_tl_id_sym(env, symbol, 0); symbol = scheme_tl_id_sym(env, symbol, NULL, 0);
if ((env == scheme_initial_env) if ((env == scheme_initial_env)
|| (env->module->primitive) || (env->module->primitive)
@ -2163,7 +2178,7 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Sch
finish_expstart_module_in_namespace(menv, env); finish_expstart_module_in_namespace(menv, env);
} }
name = scheme_tl_id_sym(menv, name, 0); name = scheme_tl_id_sym(menv, name, NULL, 0);
val = scheme_lookup_in_table(menv->syntax, (char *)name); val = scheme_lookup_in_table(menv->syntax, (char *)name);
@ -2699,26 +2714,6 @@ Scheme_Bucket *scheme_module_bucket(Scheme_Object *modname, Scheme_Object *var,
return (Scheme_Bucket *)_dynamic_require(2, a, env, 1, 0, 0, 1, 1, pos); return (Scheme_Bucket *)_dynamic_require(2, a, env, 1, 0, 0, 1, 1, pos);
} }
Scheme_Bucket *scheme_exptime_module_bucket(Scheme_Object *modname, Scheme_Object *var, int pos, Scheme_Env *env)
{
Scheme_Object *a[2];
a[0] = modname;
a[1] = var;
return (Scheme_Bucket *)_dynamic_require(2, a, env, 1, 1, 0, 1, 1, pos);
}
Scheme_Bucket *scheme_exptime_expdef_module_bucket(Scheme_Object *modname, Scheme_Object *var, int pos, Scheme_Env *env)
{
Scheme_Object *a[2];
a[0] = modname;
a[1] = var;
return (Scheme_Bucket *)_dynamic_require(2, a, env, 1, 1, 1, 1, 1, pos);
}
Scheme_Object *scheme_builtin_value(const char *name) Scheme_Object *scheme_builtin_value(const char *name)
{ {
Scheme_Object *a[2], *v; Scheme_Object *a[2], *v;
@ -3328,6 +3323,10 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
et_mn_ht = scheme_make_hash_table(SCHEME_hash_ptr); et_mn_ht = scheme_make_hash_table(SCHEME_hash_ptr);
tt_mn_ht = scheme_make_hash_table(SCHEME_hash_ptr); tt_mn_ht = scheme_make_hash_table(SCHEME_hash_ptr);
annote_marked_names_nonempty(mn_ht);
annote_marked_names_nonempty(et_mn_ht);
annote_marked_names_nonempty(tt_mn_ht);
rn = scheme_make_module_rename(0, mzMOD_RENAME_NORMAL, mn_ht); rn = scheme_make_module_rename(0, mzMOD_RENAME_NORMAL, mn_ht);
et_rn = scheme_make_module_rename(1, mzMOD_RENAME_NORMAL, et_mn_ht); et_rn = scheme_make_module_rename(1, mzMOD_RENAME_NORMAL, et_mn_ht);
tt_rn = scheme_make_module_rename(-1, mzMOD_RENAME_NORMAL, tt_mn_ht); tt_rn = scheme_make_module_rename(-1, mzMOD_RENAME_NORMAL, tt_mn_ht);
@ -3410,7 +3409,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_wrong_syntax(NULL, NULL, form, scheme_wrong_syntax(NULL, NULL, form,
"no #%%module-begin binding in the module's language"); "no #%%module-begin binding in the module's language");
} }
if (rec[drec].comp) { if (rec[drec].comp) {
Scheme_Object *dummy; Scheme_Object *dummy;
@ -3428,7 +3427,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
if (restore_confusing_name) if (restore_confusing_name)
m->modname = kernel_symbol; m->modname = kernel_symbol;
return scheme_make_syntax_compiled(MODULE_EXPD, (Scheme_Object *)m); fm = scheme_make_syntax_compiled(MODULE_EXPD, (Scheme_Object *)m);
} else { } else {
Scheme_Object *hints, *formname; Scheme_Object *hints, *formname;
@ -3484,9 +3483,13 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
/* make self_modidx like the empty modidx */ /* make self_modidx like the empty modidx */
((Scheme_Modidx *)self_modidx)->resolved = empty_self_symbol; ((Scheme_Modidx *)self_modidx)->resolved = empty_self_symbol;
return fm;
} }
clear_marked_names_nonempty(mn_ht);
clear_marked_names_nonempty(et_mn_ht);
clear_marked_names_nonempty(tt_mn_ht);
return fm;
} }
static Scheme_Object * static Scheme_Object *
@ -3732,7 +3735,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, Sc
static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv) static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv)
{ {
return scheme_tl_id_sym((Scheme_Env *)_genv, name, 2); return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2);
} }
static Scheme_Object *add_req(Scheme_Object *imods, Scheme_Object *requires) static Scheme_Object *add_req(Scheme_Object *imods, Scheme_Object *requires)
@ -3768,7 +3771,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
self_modidx = SCHEME_VEC_ELS(data)[1]; self_modidx = SCHEME_VEC_ELS(data)[1];
rn = SCHEME_VEC_ELS(data)[2]; rn = SCHEME_VEC_ELS(data)[2];
name = scheme_tl_id_sym(env->genv, *_id, 2); name = scheme_tl_id_sym(env->genv, *_id, scheme_false, 2);
/* Create the bucket, indicating that the name will be defined: */ /* Create the bucket, indicating that the name will be defined: */
scheme_add_global_symbol(name, scheme_undefined, env->genv); scheme_add_global_symbol(name, scheme_undefined, env->genv);
@ -3946,7 +3949,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
post_ex_rn = scheme_make_module_rename(0, mzMOD_RENAME_MARKED, env->genv->marked_names); post_ex_rn = scheme_make_module_rename(0, mzMOD_RENAME_MARKED, env->genv->marked_names);
post_ex_et_rn = scheme_make_module_rename(1, mzMOD_RENAME_MARKED, env->genv->exp_env->marked_names); post_ex_et_rn = scheme_make_module_rename(1, mzMOD_RENAME_MARKED, env->genv->exp_env->marked_names);
post_ex_tt_rn = scheme_make_module_rename(-1, mzMOD_RENAME_MARKED, env->genv->exp_env->marked_names); post_ex_tt_rn = scheme_make_module_rename(-1, mzMOD_RENAME_MARKED, env->genv->template_env->marked_names);
/* For syntax-local-context, etc., in a d-s RHS: */ /* For syntax-local-context, etc., in a d-s RHS: */
rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME);
@ -4041,7 +4044,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Remember the original: */ /* Remember the original: */
all_defs = scheme_make_pair(name, all_defs); all_defs = scheme_make_pair(name, all_defs);
name = scheme_tl_id_sym(env->genv, name, 2); name = scheme_tl_id_sym(env->genv, name, NULL, 2);
/* Check that it's not yet defined: */ /* Check that it's not yet defined: */
if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) { if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) {
@ -4111,7 +4114,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (!for_stx) if (!for_stx)
all_defs = scheme_make_pair(name, all_defs); all_defs = scheme_make_pair(name, all_defs);
name = scheme_tl_id_sym(oenv->genv, name, 2); name = scheme_tl_id_sym(oenv->genv, name, NULL, 2);
if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) { if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) {
scheme_wrong_syntax("module", orig_name, e, scheme_wrong_syntax("module", orig_name, e,
@ -4737,7 +4740,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Make sure each excluded name was defined: */ /* Make sure each excluded name was defined: */
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
a = SCHEME_STX_CAR(exns); a = SCHEME_STX_CAR(exns);
name = scheme_tl_id_sym(env->genv, a, 0); name = scheme_tl_id_sym(env->genv, a, NULL, 0);
if (!scheme_lookup_in_table(env->genv->toplevel, (const char *)name) if (!scheme_lookup_in_table(env->genv->toplevel, (const char *)name)
&& !scheme_lookup_in_table(env->genv->syntax, (const char *)name)) { && !scheme_lookup_in_table(env->genv->syntax, (const char *)name)) {
scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined"); scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined");
@ -4747,12 +4750,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) {
name = SCHEME_CAR(adl); name = SCHEME_CAR(adl);
exname = SCHEME_STX_SYM(name); exname = SCHEME_STX_SYM(name);
name = scheme_tl_id_sym(env->genv, name, 0); name = scheme_tl_id_sym(env->genv, name, NULL, 0);
/* Was this one excluded? */ /* Was this one excluded? */
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
a = SCHEME_STX_CAR(exns); a = SCHEME_STX_CAR(exns);
a = scheme_tl_id_sym(env->genv, a, 0); a = scheme_tl_id_sym(env->genv, a, NULL, 0);
if (SAME_OBJ(a, name)) if (SAME_OBJ(a, name))
break; break;
} }
@ -4768,7 +4771,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
as if it had ree_kw's context, then comparing that result as if it had ree_kw's context, then comparing that result
to the actual tl_id. */ to the actual tl_id. */
a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0); a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0);
a = scheme_tl_id_sym(env->genv, a, 0); a = scheme_tl_id_sym(env->genv, a, NULL, 0);
if (SAME_OBJ(a, name)) { if (SAME_OBJ(a, name)) {
/* Add prefix, if any */ /* Add prefix, if any */
@ -4809,7 +4812,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... */ /* may be a single shadowed exclusion, now bound to exclude_hint... */
n = SCHEME_CAR(n); n = SCHEME_CAR(n);
if (SCHEME_STXP(n)) if (SCHEME_STXP(n))
n = scheme_tl_id_sym(env->genv, n, 0); n = scheme_tl_id_sym(env->genv, n, NULL, 0);
n = scheme_hash_get(required, n); n = scheme_hash_get(required, n);
if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_symbol)) { if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_symbol)) {
/* there is a single shadowed exclusion. */ /* there is a single shadowed exclusion. */
@ -4854,7 +4857,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (SCHEME_STXP(name)) { if (SCHEME_STXP(name)) {
prnt_name = SCHEME_STX_VAL(name); prnt_name = SCHEME_STX_VAL(name);
name = scheme_tl_id_sym(env->genv, name, 0); name = scheme_tl_id_sym(env->genv, name, NULL, 0);
} else } else
prnt_name = name; prnt_name = name;
@ -4906,7 +4909,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
protected = SCHEME_TRUEP(SCHEME_CDR(v)); protected = SCHEME_TRUEP(SCHEME_CDR(v));
if (SCHEME_STXP(name)) if (SCHEME_STXP(name))
name = scheme_tl_id_sym(env->genv, name, 0); name = scheme_tl_id_sym(env->genv, name, NULL, 0);
if (scheme_lookup_in_table(env->genv->syntax, (const char *)name)) { if (scheme_lookup_in_table(env->genv->syntax, (const char *)name)) {
/* Defined locally */ /* Defined locally */
@ -5095,10 +5098,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->comp_prefix = cenv->prefix; env->genv->module->comp_prefix = cenv->prefix;
if (all_simple_renames && (env->genv->marked_names->count == 0)) { if (all_simple_renames
&& (env->genv->marked_names->count == 1 /* just the false mapping */)) {
env->genv->module->rn_stx = scheme_true; env->genv->module->rn_stx = scheme_true;
} }
if (et_all_simple_renames && (et_mn->count == 0)) { if (et_all_simple_renames
&& (et_mn->count == 1 /* just the false mapping */)) {
env->genv->module->et_rn_stx = scheme_true; env->genv->module->et_rn_stx = scheme_true;
} }
if (tt_all_simple_renames) { if (tt_all_simple_renames) {
@ -5344,7 +5349,7 @@ void add_single_require(Scheme_Module *m, /* from module */
/* The `require' expression has a set of marks in its /* The `require' expression has a set of marks in its
context, which means that we need to generate a name. */ context, which means that we need to generate a name. */
iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0);
iname = scheme_tl_id_sym(env, iname, 2); iname = scheme_tl_id_sym(env, iname, scheme_false, 2);
} }
if (ck) if (ck)

4
src/mzscheme/src/numarith.c
View File

@ -240,8 +240,8 @@ GEN_BIN_OP(scheme_bin_minus, "-", SUBTRACT, F_SUBTRACT, FS_SUBTRACT, scheme_bign
GEN_BIN_OP(scheme_bin_mult, "*", MULTIPLY, F_MULTIPLY, FS_MULTIPLY, scheme_bignum_multiply, scheme_rational_multiply, scheme_complex_multiply, GEN_RETURN_0, GEN_RETURN_0, NO_NAN_CHECK, NO_NAN_CHECK) GEN_BIN_OP(scheme_bin_mult, "*", MULTIPLY, F_MULTIPLY, FS_MULTIPLY, scheme_bignum_multiply, scheme_rational_multiply, scheme_complex_multiply, GEN_RETURN_0, GEN_RETURN_0, NO_NAN_CHECK, NO_NAN_CHECK)
GEN_BIN_DIV_OP(scheme_bin_div, "/", DIVIDE, F_DIVIDE, FS_DIVIDE, scheme_make_rational, scheme_rational_divide, scheme_complex_divide) GEN_BIN_DIV_OP(scheme_bin_div, "/", DIVIDE, F_DIVIDE, FS_DIVIDE, scheme_make_rational, scheme_rational_divide, scheme_complex_divide)
GEN_NARY_OP(plus, "+", scheme_bin_plus, 0, SCHEME_NUMBERP, "number") GEN_NARY_OP(static, plus, "+", scheme_bin_plus, 0, SCHEME_NUMBERP, "number")
GEN_NARY_OP(mult, "*", scheme_bin_mult, 1, SCHEME_NUMBERP, "number") GEN_NARY_OP(static, mult, "*", scheme_bin_mult, 1, SCHEME_NUMBERP, "number")
static Scheme_Object * static Scheme_Object *
minus (int argc, Scheme_Object *argv[]) minus (int argc, Scheme_Object *argv[])

16
src/mzscheme/src/number.c
View File

@ -264,15 +264,15 @@ scheme_init_number (Scheme_Env *env)
1, 1, 1), 1, 1, 1),
env); env);
p = scheme_make_folding_prim(scheme_bitwise_and, "bitwise-and", 1, -1, 1); p = scheme_make_folding_prim(scheme_bitwise_and, "bitwise-and", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("bitwise-and", p, env); scheme_add_global_constant("bitwise-and", p, env);
p = scheme_make_folding_prim(bitwise_or, "bitwise-ior", 1, -1, 1); p = scheme_make_folding_prim(bitwise_or, "bitwise-ior", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("bitwise-ior", p, env); scheme_add_global_constant("bitwise-ior", p, env);
p = scheme_make_folding_prim(bitwise_xor, "bitwise-xor", 1, -1, 1); p = scheme_make_folding_prim(bitwise_xor, "bitwise-xor", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("bitwise-xor", p, env); scheme_add_global_constant("bitwise-xor", p, env);
@ -869,8 +869,8 @@ even_p (int argc, Scheme_Object *argv[])
static Scheme_Object *bin_lcm (Scheme_Object *n1, Scheme_Object *n2); static Scheme_Object *bin_lcm (Scheme_Object *n1, Scheme_Object *n2);
GEN_NARY_OP(gcd, "gcd", scheme_bin_gcd, 0, scheme_is_integer, "integer") GEN_NARY_OP(static, gcd, "gcd", scheme_bin_gcd, 0, scheme_is_integer, "integer")
GEN_NARY_OP(lcm, "lcm", bin_lcm, 1, scheme_is_integer, "integer") GEN_NARY_OP(static, lcm, "lcm", bin_lcm, 1, scheme_is_integer, "integer")
Scheme_Object * Scheme_Object *
scheme_bin_gcd (const Scheme_Object *n1, const Scheme_Object *n2) scheme_bin_gcd (const Scheme_Object *n1, const Scheme_Object *n2)
@ -2324,9 +2324,9 @@ GEN_BIN_INT_OP(bin_bitwise_xor, "bitwise-xor", ^, scheme_bignum_xor)
#define MZ_PUBLIC /**/ #define MZ_PUBLIC /**/
GEN_TWOARY_OP(MZ_PUBLIC, scheme_bitwise_and, "bitwise-and", bin_bitwise_and, SCHEME_EXACT_INTEGERP, "exact integer") GEN_NARY_OP(MZ_PUBLIC, scheme_bitwise_and, "bitwise-and", bin_bitwise_and, -1, SCHEME_EXACT_INTEGERP, "exact integer")
GEN_TWOARY_OP(static, bitwise_or, "bitwise-ior", bin_bitwise_or, SCHEME_EXACT_INTEGERP, "exact integer") GEN_NARY_OP(static, bitwise_or, "bitwise-ior", bin_bitwise_or, 0, SCHEME_EXACT_INTEGERP, "exact integer")
GEN_TWOARY_OP(static, bitwise_xor, "bitwise-xor", bin_bitwise_xor, SCHEME_EXACT_INTEGERP, "exact integer") GEN_NARY_OP(static, bitwise_xor, "bitwise-xor", bin_bitwise_xor, 0, SCHEME_EXACT_INTEGERP, "exact integer")
static Scheme_Object * static Scheme_Object *
bitwise_not(int argc, Scheme_Object *argv[]) bitwise_not(int argc, Scheme_Object *argv[])

4
src/mzscheme/src/nummacs.h
View File

@ -456,8 +456,8 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \
return scheme_void; \ return scheme_void; \
} }
#define GEN_NARY_OP(name, scheme_name, bin_name, ident, TYPEP, type) \ #define GEN_NARY_OP(stat, name, scheme_name, bin_name, ident, TYPEP, type) \
static Scheme_Object * \ stat Scheme_Object * \
name (int argc, Scheme_Object *argv[]) \ name (int argc, Scheme_Object *argv[]) \
{ \ { \
Scheme_Object *ret; \ Scheme_Object *ret; \

5
src/mzscheme/src/schemef.h
View File

@ -836,11 +836,6 @@ MZ_EXTERN Scheme_Bucket *scheme_global_bucket(Scheme_Object *symbol, Scheme_Env
MZ_EXTERN Scheme_Bucket *scheme_global_keyword_bucket(Scheme_Object *symbol, Scheme_Env *env); MZ_EXTERN Scheme_Bucket *scheme_global_keyword_bucket(Scheme_Object *symbol, Scheme_Env *env);
MZ_EXTERN Scheme_Bucket *scheme_module_bucket(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env); MZ_EXTERN Scheme_Bucket *scheme_module_bucket(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env);
MZ_EXTERN Scheme_Bucket *scheme_exptime_global_bucket(Scheme_Object *symbol, Scheme_Env *env);
MZ_EXTERN Scheme_Bucket *scheme_exptime_expdef_global_bucket(Scheme_Object *symbol, Scheme_Env *env);
MZ_EXTERN Scheme_Bucket *scheme_exptime_module_bucket(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env);
MZ_EXTERN Scheme_Bucket *scheme_exptime_expdef_module_bucket(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_builtin_value(const char *name); /* convenience */ MZ_EXTERN Scheme_Object *scheme_builtin_value(const char *name); /* convenience */
MZ_EXTERN void scheme_set_global_bucket(char *proc, Scheme_Bucket *var, Scheme_Object *val, MZ_EXTERN void scheme_set_global_bucket(char *proc, Scheme_Bucket *var, Scheme_Object *val,

4
src/mzscheme/src/schemex.h
View File

@ -692,10 +692,6 @@ Scheme_Object *(*scheme_lookup_global)(Scheme_Object *symbol, Scheme_Env *env);
Scheme_Bucket *(*scheme_global_bucket)(Scheme_Object *symbol, Scheme_Env *env); Scheme_Bucket *(*scheme_global_bucket)(Scheme_Object *symbol, Scheme_Env *env);
Scheme_Bucket *(*scheme_global_keyword_bucket)(Scheme_Object *symbol, Scheme_Env *env); Scheme_Bucket *(*scheme_global_keyword_bucket)(Scheme_Object *symbol, Scheme_Env *env);
Scheme_Bucket *(*scheme_module_bucket)(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env); Scheme_Bucket *(*scheme_module_bucket)(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env);
Scheme_Bucket *(*scheme_exptime_global_bucket)(Scheme_Object *symbol, Scheme_Env *env);
Scheme_Bucket *(*scheme_exptime_expdef_global_bucket)(Scheme_Object *symbol, Scheme_Env *env);
Scheme_Bucket *(*scheme_exptime_module_bucket)(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env);
Scheme_Bucket *(*scheme_exptime_expdef_module_bucket)(Scheme_Object *mod, Scheme_Object *var, int pos, Scheme_Env *env);
Scheme_Object *(*scheme_builtin_value)(const char *name); /* convenience */ Scheme_Object *(*scheme_builtin_value)(const char *name); /* convenience */
void (*scheme_set_global_bucket)(char *proc, Scheme_Bucket *var, Scheme_Object *val, void (*scheme_set_global_bucket)(char *proc, Scheme_Bucket *var, Scheme_Object *val,
int set_undef); int set_undef);

4
src/mzscheme/src/schemex.inc
View File

@ -467,10 +467,6 @@
scheme_extension_table->scheme_global_bucket = scheme_global_bucket; scheme_extension_table->scheme_global_bucket = scheme_global_bucket;
scheme_extension_table->scheme_global_keyword_bucket = scheme_global_keyword_bucket; scheme_extension_table->scheme_global_keyword_bucket = scheme_global_keyword_bucket;
scheme_extension_table->scheme_module_bucket = scheme_module_bucket; scheme_extension_table->scheme_module_bucket = scheme_module_bucket;
scheme_extension_table->scheme_exptime_global_bucket = scheme_exptime_global_bucket;
scheme_extension_table->scheme_exptime_expdef_global_bucket = scheme_exptime_expdef_global_bucket;
scheme_extension_table->scheme_exptime_module_bucket = scheme_exptime_module_bucket;
scheme_extension_table->scheme_exptime_expdef_module_bucket = scheme_exptime_expdef_module_bucket;
scheme_extension_table->scheme_builtin_value = scheme_builtin_value; scheme_extension_table->scheme_builtin_value = scheme_builtin_value;
scheme_extension_table->scheme_set_global_bucket = scheme_set_global_bucket; scheme_extension_table->scheme_set_global_bucket = scheme_set_global_bucket;
scheme_extension_table->scheme_install_macro = scheme_install_macro; scheme_extension_table->scheme_install_macro = scheme_install_macro;

4
src/mzscheme/src/schemexm.h
View File

@ -467,10 +467,6 @@
#define scheme_global_bucket (scheme_extension_table->scheme_global_bucket) #define scheme_global_bucket (scheme_extension_table->scheme_global_bucket)
#define scheme_global_keyword_bucket (scheme_extension_table->scheme_global_keyword_bucket) #define scheme_global_keyword_bucket (scheme_extension_table->scheme_global_keyword_bucket)
#define scheme_module_bucket (scheme_extension_table->scheme_module_bucket) #define scheme_module_bucket (scheme_extension_table->scheme_module_bucket)
#define scheme_exptime_global_bucket (scheme_extension_table->scheme_exptime_global_bucket)
#define scheme_exptime_expdef_global_bucket (scheme_extension_table->scheme_exptime_expdef_global_bucket)
#define scheme_exptime_module_bucket (scheme_extension_table->scheme_exptime_module_bucket)
#define scheme_exptime_expdef_module_bucket (scheme_extension_table->scheme_exptime_expdef_module_bucket)
#define scheme_builtin_value (scheme_extension_table->scheme_builtin_value) #define scheme_builtin_value (scheme_extension_table->scheme_builtin_value)
#define scheme_set_global_bucket (scheme_extension_table->scheme_set_global_bucket) #define scheme_set_global_bucket (scheme_extension_table->scheme_set_global_bucket)
#define scheme_install_macro (scheme_extension_table->scheme_install_macro) #define scheme_install_macro (scheme_extension_table->scheme_install_macro)

7
src/mzscheme/src/schpriv.h
View File

@ -611,6 +611,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **name, long phase,
Scheme_Object **nominal_modidx, Scheme_Object **nominal_modidx,
Scheme_Object **nominal_name, Scheme_Object **nominal_name,
int *mod_phase); int *mod_phase);
Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a, long phase);
int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx); int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx);
int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, long phase); int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, long phase);
@ -1973,7 +1974,7 @@ void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port,
void scheme_validate_boxenv(int pos, Mz_CPort *port, void scheme_validate_boxenv(int pos, Mz_CPort *port,
char *stack, int depth, int delta); char *stack, int depth, int delta);
#define TRACK_ILL_FORMED_CATCH_LINES 0 #define TRACK_ILL_FORMED_CATCH_LINES 1
#if TRACK_ILL_FORMED_CATCH_LINES #if TRACK_ILL_FORMED_CATCH_LINES
void scheme_ill_formed(Mz_CPort *port, const char *file, int line); void scheme_ill_formed(Mz_CPort *port, const char *file, int line);
# define scheme_ill_formed_code(port) scheme_ill_formed(port, __FILE__, __LINE__) # define scheme_ill_formed_code(port) scheme_ill_formed(port, __FILE__, __LINE__)
@ -2114,7 +2115,7 @@ void scheme_add_global_keyword_symbol(Scheme_Object *name, Scheme_Object *v, Sch
void scheme_add_global_constant(const char *name, Scheme_Object *v, Scheme_Env *env); void scheme_add_global_constant(const char *name, Scheme_Object *v, Scheme_Env *env);
void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env); void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Scheme_Env *env);
Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def); Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def);
int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym); int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym);
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env); Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env);
@ -2445,6 +2446,8 @@ void scheme_count_generic(Scheme_Object *o, long *s, long *e, Scheme_Hash_Table
Scheme_Object *scheme_checked_car(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_car(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_cdr(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_cdr(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_string_ref (int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_checked_byte_string_ref (int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv);
void scheme_set_root_param(int p, Scheme_Object *v); void scheme_set_root_param(int p, Scheme_Object *v);

2
src/mzscheme/src/startup.inc
View File

@ -2596,7 +2596,7 @@
"(string->immutable-string" "(string->immutable-string"
" (format \"load/cd: cannot open a directory: ~s\" n))" " (format \"load/cd: cannot open a directory: ~s\" n))"
"(current-continuation-marks)))" "(current-continuation-marks)))"
"(if(not(bytes? base))" "(if(not(path? base))"
"(load n)" "(load n)"
"(begin" "(begin"
"(if(not(directory-exists? base))" "(if(not(directory-exists? base))"

2
src/mzscheme/src/startup.ss
View File

@ -3010,7 +3010,7 @@
(string->immutable-string (string->immutable-string
(format "load/cd: cannot open a directory: ~s" n)) (format "load/cd: cannot open a directory: ~s" n))
(current-continuation-marks))) (current-continuation-marks)))
(if (not (bytes? base)) (if (not (path? base))
(load n) (load n)
(begin (begin
(if (not (directory-exists? base)) (if (not (directory-exists? base))

22
src/mzscheme/src/string.c
View File

@ -162,7 +162,6 @@ static Scheme_Object *make_string (int argc, Scheme_Object *argv[]);
static Scheme_Object *string (int argc, Scheme_Object *argv[]); static Scheme_Object *string (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_p (int argc, Scheme_Object *argv[]); static Scheme_Object *string_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_length (int argc, Scheme_Object *argv[]); static Scheme_Object *string_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_set (int argc, Scheme_Object *argv[]); static Scheme_Object *string_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_eq (int argc, Scheme_Object *argv[]); static Scheme_Object *string_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_locale_eq (int argc, Scheme_Object *argv[]); static Scheme_Object *string_locale_eq (int argc, Scheme_Object *argv[]);
@ -204,7 +203,6 @@ static Scheme_Object *byte_string (int argc, Scheme_Object *argv[]);
static Scheme_Object *byte_p (int argc, Scheme_Object *argv[]); static Scheme_Object *byte_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *byte_string_p (int argc, Scheme_Object *argv[]); static Scheme_Object *byte_string_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *byte_string_length (int argc, Scheme_Object *argv[]); static Scheme_Object *byte_string_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *byte_string_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *byte_string_set (int argc, Scheme_Object *argv[]); static Scheme_Object *byte_string_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *byte_string_eq (int argc, Scheme_Object *argv[]); static Scheme_Object *byte_string_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *byte_string_lt (int argc, Scheme_Object *argv[]); static Scheme_Object *byte_string_lt (int argc, Scheme_Object *argv[]);
@ -350,11 +348,11 @@ scheme_init_string (Scheme_Env *env)
"string-length", "string-length",
1, 1, 1), 1, 1, 1),
env); env);
scheme_add_global_constant("string-ref",
scheme_make_noncm_prim(string_ref, p = scheme_make_noncm_prim(scheme_checked_string_ref, "string-ref", 2, 2);
"string-ref", SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
2, 2), scheme_add_global_constant("string-ref", p, env);
env);
scheme_add_global_constant("string-set!", scheme_add_global_constant("string-set!",
scheme_make_noncm_prim(string_set, scheme_make_noncm_prim(string_set,
"string-set!", "string-set!",
@ -619,11 +617,11 @@ scheme_init_string (Scheme_Env *env)
"bytes-length", "bytes-length",
1, 1, 1), 1, 1, 1),
env); env);
scheme_add_global_constant("bytes-ref",
scheme_make_noncm_prim(byte_string_ref, p = scheme_make_noncm_prim(scheme_checked_byte_string_ref, "bytes-ref", 2, 2);
"bytes-ref", SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
2, 2), scheme_add_global_constant("bytes-ref", p, env);
env);
scheme_add_global_constant("bytes-set!", scheme_add_global_constant("bytes-set!",
scheme_make_noncm_prim(byte_string_set, scheme_make_noncm_prim(byte_string_set,
"bytes-set!", "bytes-set!",

4
src/mzscheme/src/strops.inc
View File

@ -145,8 +145,8 @@ X__(string_length) (int argc, Scheme_Object *argv[])
return scheme_make_integer(SCHEME_X_STRTAG_VAL(argv[0])); return scheme_make_integer(SCHEME_X_STRTAG_VAL(argv[0]));
} }
static Scheme_Object * Scheme_Object *
X__(string_ref) (int argc, Scheme_Object *argv[]) X_(scheme_checked, string_ref) (int argc, Scheme_Object *argv[])
{ {
long i, len; long i, len;
int c; int c;

245
src/mzscheme/src/stxobj.c
View File

@ -21,7 +21,20 @@
#include "schpriv.h" #include "schpriv.h"
#include "schmach.h" #include "schmach.h"
/* FIXME: syntax->list and resolve_env need stack checks. */ /* The implementation of syntax objects is extremely complex due to
two levels of optimization:
1. Different kinds of binding are handled in different ways,
because they'll have different usage patterns. For example,
module-level bindings are handled differently than local
bindings, because modules can't be nested.
2. To save time and space, the data structures involved have lots
of caches, and syntax objects to be marshaled undergo a
simplification pass.
In addition, the need to marshal syntax objects to bytecode
introduces some other complications. */
#define STX_DEBUG 0 #define STX_DEBUG 0
@ -70,6 +83,7 @@ static Scheme_Object *protected_symbol;
static Scheme_Object *nominal_ipair_cache; static Scheme_Object *nominal_ipair_cache;
static Scheme_Object *mark_id = scheme_make_integer(0); static Scheme_Object *mark_id = scheme_make_integer(0);
static Scheme_Object *current_rib_timestamp = scheme_make_integer(0);
static Scheme_Stx_Srcloc *empty_srcloc; static Scheme_Stx_Srcloc *empty_srcloc;
@ -153,6 +167,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
typedef struct Scheme_Lexical_Rib { typedef struct Scheme_Lexical_Rib {
Scheme_Object so; Scheme_Object so;
Scheme_Object *rename; /* a vector for a lexical rename */ Scheme_Object *rename; /* a vector for a lexical rename */
Scheme_Object *timestamp;
struct Scheme_Lexical_Rib *next; struct Scheme_Lexical_Rib *next;
} Scheme_Lexical_Rib; } Scheme_Lexical_Rib;
@ -285,7 +300,7 @@ void DO_WRAP_POS_INC(Wrap_Pos *w)
#define WRAP_POS_INC(w) DO_WRAP_POS_INC(&w) #define WRAP_POS_INC(w) DO_WRAP_POS_INC(&w)
#define WRAP_POS_INIT_END(w) w.l = scheme_null #define WRAP_POS_INIT_END(w) (w.l = scheme_null, w.a = NULL, w.is_limb = 0, w.pos = 0)
#define WRAP_POS_END_P(w) SCHEME_NULLP(w.l) #define WRAP_POS_END_P(w) SCHEME_NULLP(w.l)
#define WRAP_POS_FIRST(w) w.a #define WRAP_POS_FIRST(w) w.a
#define WRAP_POS_COPY(w, w2) w.l = (w2).l; w.a = (w2).a; w.is_limb= (w2).is_limb; w.pos = (w2).pos #define WRAP_POS_COPY(w, w2) w.l = (w2).l; w.a = (w2).a; w.is_limb= (w2).is_limb; w.pos = (w2).pos
@ -1026,6 +1041,9 @@ Scheme_Object *scheme_make_rename_rib()
rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib);
rib->so.type = scheme_lexical_rib_type; rib->so.type = scheme_lexical_rib_type;
rib->timestamp = current_rib_timestamp;
current_rib_timestamp = scheme_add1(1, &current_rib_timestamp);
return (Scheme_Object *)rib; return (Scheme_Object *)rib;
} }
@ -1041,6 +1059,8 @@ void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename)
rib = (Scheme_Lexical_Rib *)ro; rib = (Scheme_Lexical_Rib *)ro;
naya->next = rib->next; naya->next = rib->next;
rib->next = naya; rib->next = naya;
naya->timestamp = rib->timestamp;
} }
void scheme_drop_first_rib_rename(Scheme_Object *ro) void scheme_drop_first_rib_rename(Scheme_Object *ro)
@ -1216,21 +1236,10 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
} }
} }
/* Copy over marked names */ /* Need to share marked names: */
if (((Module_Renames *)src)->marked_names) { if (((Module_Renames *)src)->marked_names) {
if (!((Module_Renames *)dest)->marked_names) { ((Module_Renames *)dest)->marked_names = ((Module_Renames *)src)->marked_names;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
((Module_Renames *)dest)->marked_names = ht;
} else
ht = ((Module_Renames *)dest)->marked_names;
hts = ((Module_Renames *)src)->marked_names;
for (i = hts->size; i--; ) {
if (hts->vals[i]) {
scheme_hash_set(ht, hts->keys[i], hts->vals[i]);
}
}
} }
} }
@ -2630,7 +2639,12 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
#define QUICK_STACK_SIZE 10 #define QUICK_STACK_SIZE 10
static Scheme_Object *resolve_env(Scheme_Object *a, long phase, /* Although resolve_env may call itself recursively, the recursion
depth is bounded (by the fact that modules can't be nested,
etc.). */
static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *a, long phase,
int w_mod, Scheme_Object **get_names, int w_mod, Scheme_Object **get_names,
Scheme_Object *skip_ribs) Scheme_Object *skip_ribs)
/* Module binding ignored if w_mod is 0. /* Module binding ignored if w_mod is 0.
@ -2646,29 +2660,48 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
Scheme_Object *mresult = scheme_false; Scheme_Object *mresult = scheme_false;
Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL;
Scheme_Object *rename_stack[QUICK_STACK_SIZE]; Scheme_Object *rename_stack[QUICK_STACK_SIZE];
int stack_pos = 0; int stack_pos = 0, no_lexical = 0;
int is_in_module = 0, skip_other_mods = 0; int is_in_module = 0, skip_other_mods = 0;
Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL; Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL;
long orig_phase = phase;
Scheme_Object *bdg = NULL;
WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); if (_wraps) {
WRAP_POS_COPY(wraps, *_wraps);
WRAP_POS_INC(wraps);
} else
WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps);
while (1) { while (1) {
if (WRAP_POS_END_P(wraps)) { if (WRAP_POS_END_P(wraps)) {
/* See rename case for info on rename_stack: */ /* See rename case for info on rename_stack: */
Scheme_Object *result; Scheme_Object *result, *key;
int did_lexical = 0;
result = scheme_false; result = scheme_false;
while (!SCHEME_NULLP(o_rename_stack)) { while (!SCHEME_NULLP(o_rename_stack)) {
if (SAME_OBJ(SCHEME_CAAR(o_rename_stack), result)) key = SCHEME_CAAR(o_rename_stack);
if (SAME_OBJ(key, result)) {
did_lexical = 1;
result = SCHEME_CDR(SCHEME_CAR(o_rename_stack)); result = SCHEME_CDR(SCHEME_CAR(o_rename_stack));
} else if (SAME_OBJ(key, scheme_true)) {
/* marks a module-level renaming that overrides lexical renaming */
did_lexical = 0;
}
o_rename_stack = SCHEME_CDR(o_rename_stack); o_rename_stack = SCHEME_CDR(o_rename_stack);
} }
while (stack_pos) { while (stack_pos) {
if (SAME_OBJ(rename_stack[stack_pos - 1], result)) key = rename_stack[stack_pos - 1];
if (SAME_OBJ(key, result)) {
result = rename_stack[stack_pos - 2]; result = rename_stack[stack_pos - 2];
did_lexical = 1;
} else if (SAME_OBJ(key, scheme_true)) {
/* marks a module-level renaming that overrides lexical renaming */
did_lexical = 0;
}
stack_pos -= 2; stack_pos -= 2;
} }
if (SCHEME_FALSEP(result)) if (!did_lexical)
result = mresult; result = mresult;
else if (get_names) else if (get_names)
get_names[0] = scheme_undefined; get_names[0] = scheme_undefined;
@ -2687,9 +2720,24 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
if (mrn->needs_unmarshal) if (mrn->needs_unmarshal)
unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to); unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to);
if (mrn->marked_names) if (mrn->marked_names) {
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, 0); /* Resolve based on rest of wraps: */
else if (!bdg)
bdg = resolve_env(NULL, a, orig_phase, 0, NULL, skip_ribs);
/* Remap id based on marks and rest-of-wraps resolution: */
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0);
if (SCHEME_TRUEP(bdg)
&& !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) {
/* Even if this module doesn't match, the lex-renamed id
has been top-level bound in its scope, so ignore all
lexical renamings. (If the id was further renamed, then
the further renaming would show up in bdg, and bdg wouldn't
have matched in marked_names.) */
no_lexical = 1;
stack_pos = 0;
o_rename_stack = scheme_null;
}
} else
glob_id = SCHEME_STX_VAL(a); glob_id = SCHEME_STX_VAL(a);
rename = scheme_hash_get(mrn->ht, glob_id); rename = scheme_hash_get(mrn->ht, glob_id);
@ -2782,16 +2830,21 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
modidx_shift_from = src; modidx_shift_from = src;
} }
} else if (rib || SCHEME_VECTORP(WRAP_POS_FIRST(wraps))) { } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
&& !no_lexical)) {
/* Lexical rename: */ /* Lexical rename: */
Scheme_Object *rename, *renamed; Scheme_Object *rename, *renamed, *recur_skip_ribs;
int ri, c, istart, iend; int ri, c, istart, iend, is_rib;
if (rib) { if (rib) {
rename = rib->rename; rename = rib->rename;
recur_skip_ribs = rib->timestamp;
rib = rib->next; rib = rib->next;
is_rib = 1;
} else { } else {
rename = WRAP_POS_FIRST(wraps); rename = WRAP_POS_FIRST(wraps);
recur_skip_ribs = skip_ribs;
is_rib = 0;
} }
c = SCHEME_RENAME_LEN(rename); c = SCHEME_RENAME_LEN(rename);
@ -2836,10 +2889,9 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
if (SCHEME_VOIDP(other_env)) { if (SCHEME_VOIDP(other_env)) {
SCHEME_USE_FUEL(1); SCHEME_USE_FUEL(1);
other_env = resolve_env(renamed, 0, 0, NULL, other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs);
scheme_make_pair(WRAP_POS_FIRST(wraps), if (!is_rib)
skip_ribs)); SCHEME_VEC_ELS(rename)[2+c+ri] = other_env;
SCHEME_VEC_ELS(rename)[2+c+ri] = other_env;
SCHEME_USE_FUEL(1); SCHEME_USE_FUEL(1);
} }
@ -2856,7 +2908,7 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
It's tempting to try to compare envname to the It's tempting to try to compare envname to the
top element of the stack and combine the two top element of the stack and combine the two
mappings, but the intermediate name may be needed mappings, but the intermediate name may be needed
(for other_env values that don't come from this stack. */ (for other_env values that don't come from this stack). */
if (stack_pos < QUICK_STACK_SIZE) { if (stack_pos < QUICK_STACK_SIZE) {
rename_stack[stack_pos++] = envname; rename_stack[stack_pos++] = envname;
rename_stack[stack_pos++] = other_env; rename_stack[stack_pos++] = other_env;
@ -2871,21 +2923,20 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
} }
} }
} }
} else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps))) { } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) {
/* Lexical-rename rib. Splice in the names. */ /* Lexical-rename rib. Splice in the names. */
Scheme_Object *srs;
rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps);
for (srs = skip_ribs; SCHEME_PAIRP(srs); srs = SCHEME_CDR(srs)) { if (skip_ribs) {
if (SAME_OBJ(SCHEME_CAR(srs), (Scheme_Object *)rib)) if (scheme_bin_gt_eq(rib->timestamp, skip_ribs))
break; rib = NULL;
} }
if (SCHEME_PAIRP(srs)) if (rib) {
rib = NULL; if (SAME_OBJ(did_rib, rib))
else if (SAME_OBJ(did_rib, rib)) rib = NULL;
rib = NULL; else {
else { did_rib = rib;
did_rib = rib; rib = rib->next; /* First rib record has no rename */
rib = rib->next; /* First rib record has no rename */ }
} }
} else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps)) } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))
|| SAME_OBJ(WRAP_POS_FIRST(wraps), barrier_symbol)) { || SAME_OBJ(WRAP_POS_FIRST(wraps), barrier_symbol)) {
@ -2922,6 +2973,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, long phase)
Scheme_Object *result; Scheme_Object *result;
int is_in_module = 0, skip_other_mods = 0; int is_in_module = 0, skip_other_mods = 0;
long orig_phase = phase; long orig_phase = phase;
Scheme_Object *bdg = NULL;
if (((Scheme_Stx *)a)->u.modinfo_cache) if (((Scheme_Stx *)a)->u.modinfo_cache)
return ((Scheme_Stx *)a)->u.modinfo_cache; return ((Scheme_Stx *)a)->u.modinfo_cache;
@ -2952,12 +3004,16 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, long phase)
if (mrn->needs_unmarshal) { if (mrn->needs_unmarshal) {
/* Use resolve_env to trigger unmarshal, so that we /* Use resolve_env to trigger unmarshal, so that we
don't have to implement top/from shifts here: */ don't have to implement top/from shifts here: */
resolve_env(a, orig_phase, 1, NULL, scheme_null); resolve_env(NULL, a, orig_phase, 1, NULL, NULL);
} }
if (mrn->marked_names) if (mrn->marked_names) {
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, 0); /* Resolve based on rest of wraps: */
else if (!bdg)
bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL);
/* Remap id based on marks and rest-of-wraps resolution: */
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0);
} else
glob_id = SCHEME_STX_VAL(a); glob_id = SCHEME_STX_VAL(a);
rename = scheme_hash_get(mrn->ht, glob_id); rename = scheme_hash_get(mrn->ht, glob_id);
@ -2967,9 +3023,9 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, long phase)
rename = scheme_hash_get(krn->ht, glob_id); rename = scheme_hash_get(krn->ht, glob_id);
if (rename) { if (rename) {
/* match; set result: */
if (mrn->kind == mzMOD_RENAME_MARKED) if (mrn->kind == mzMOD_RENAME_MARKED)
skip_other_mods = 1; skip_other_mods = 1;
/* match; set result: */
if (SCHEME_PAIRP(rename)) { if (SCHEME_PAIRP(rename)) {
if (SCHEME_IMMUTABLEP(rename)) { if (SCHEME_IMMUTABLEP(rename)) {
result = glob_id; result = glob_id;
@ -3020,8 +3076,8 @@ int scheme_stx_free_eq(Scheme_Object *a, Scheme_Object *b, long phase)
if ((a == asym) || (b == bsym)) if ((a == asym) || (b == bsym))
return 1; return 1;
a = resolve_env(a, phase, 1, NULL, scheme_null); a = resolve_env(NULL, a, phase, 1, NULL, NULL);
b = resolve_env(b, phase, 1, NULL, scheme_null); b = resolve_env(NULL, b, phase, 1, NULL, NULL);
a = scheme_module_resolve(a); a = scheme_module_resolve(a);
b = scheme_module_resolve(b); b = scheme_module_resolve(b);
@ -3053,8 +3109,8 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase)
if ((a == asym) || (b == bsym)) if ((a == asym) || (b == bsym))
return 1; return 1;
a = resolve_env(a, phase, 1, NULL, scheme_null); a = resolve_env(NULL, a, phase, 1, NULL, NULL);
b = resolve_env(b, phase, 1, NULL, scheme_null); b = resolve_env(NULL, b, phase, 1, NULL, NULL);
a = scheme_module_resolve(a); a = scheme_module_resolve(a);
b = scheme_module_resolve(b); b = scheme_module_resolve(b);
@ -3077,7 +3133,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, long phase,
names[0] = NULL; names[0] = NULL;
names[3] = scheme_make_integer(0); names[3] = scheme_make_integer(0);
modname = resolve_env(*a, phase, 1, names, scheme_null); modname = resolve_env(NULL, *a, phase, 1, names, NULL);
if (names[0]) { if (names[0]) {
if (SAME_OBJ(names[0], scheme_undefined)) { if (SAME_OBJ(names[0], scheme_undefined)) {
@ -3098,6 +3154,20 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, long phase,
return NULL; return NULL;
} }
Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a, long phase)
/* Returns either NULL or a lexical-rename symbol */
{
if (SCHEME_STXP(a)) {
Scheme_Object *r;
r = resolve_env(NULL, a, phase, 0, NULL, NULL);
if (r)
return r;
}
return NULL;
}
int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, long phase) int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, long phase)
/* If uid is given, it's the environment for b. */ /* If uid is given, it's the environment for b. */
{ {
@ -3119,13 +3189,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
if (!SAME_OBJ(asym, bsym)) if (!SAME_OBJ(asym, bsym))
return 0; return 0;
ae = resolve_env(a, phase, 0, NULL, scheme_null); ae = resolve_env(NULL, a, phase, 0, NULL, NULL);
/* No need to module_resolve ae, because we ignored module renamings. */ /* No need to module_resolve ae, because we ignored module renamings. */
if (uid) if (uid)
be = uid; be = uid;
else { else {
be = resolve_env(b, phase, 0, NULL, scheme_null); be = resolve_env(NULL, b, phase, 0, NULL, NULL);
/* No need to module_resolve be, because we ignored module renamings. */ /* No need to module_resolve be, because we ignored module renamings. */
} }
@ -3352,6 +3422,20 @@ int scheme_stx_proper_list_length(Scheme_Object *list)
return -1; return -1;
} }
#ifdef DO_STACK_CHECK
static Scheme_Object *flatten_syntax_list_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *l = (Scheme_Object *)p->ku.k.p1;
int *r = (int *)p->ku.k.p2;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
return scheme_flatten_syntax_list(l, r);
}
#endif
Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist) Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist)
{ {
Scheme_Object *l = lst, *lflat, *first, *last; Scheme_Object *l = lst, *lflat, *first, *last;
@ -3379,7 +3463,30 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist)
if (SCHEME_NULLP(l) || SCHEME_PAIRP(l)) { if (SCHEME_NULLP(l) || SCHEME_PAIRP(l)) {
int lislist; int lislist;
lflat = scheme_flatten_syntax_list(l, &lislist); lflat = NULL;
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
int *r;
r = (int *)scheme_malloc_atomic(sizeof(int));
p->ku.k.p1 = (void *)l;
p->ku.k.p2 = (void *)r;
lflat = scheme_handle_stack_overflow(flatten_syntax_list_k);
lislist = *r;
}
}
#endif
if (!lflat)
lflat = scheme_flatten_syntax_list(l, &lislist);
if (!lislist) { if (!lislist) {
/* Not a list. Can't flatten this one. */ /* Not a list. Can't flatten this one. */
return lst; return lst;
@ -3515,12 +3622,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
&& !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2]))) { && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2]))) {
/* This is the place to simplify: */ /* This is the place to simplify: */
Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL; Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL;
Scheme_Object *skip_ribs = scheme_null; Scheme_Object *skip_ribs = NULL;
int ii, vvsize; int ii, vvsize;
if (SCHEME_RIBP(v)) { if (SCHEME_RIBP(v)) {
skip_ribs = scheme_make_pair(v, scheme_null);
init_rib = (Scheme_Lexical_Rib *)v; init_rib = (Scheme_Lexical_Rib *)v;
skip_ribs = init_rib->timestamp;
rib = init_rib->next; rib = init_rib->next;
vsize = 0; vsize = 0;
while (rib) { while (rib) {
@ -3570,7 +3677,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii];
if (SCHEME_VOIDP(other_env)) { if (SCHEME_VOIDP(other_env)) {
other_env = resolve_env(stx, 0, 0, NULL, skip_ribs); other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs);
SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env;
} }
@ -3750,13 +3857,15 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
/* Not useful if there's no marked names. */ /* Not useful if there's no marked names. */
redundant = !mrn->marked_names->count; redundant = !mrn->marked_names->count;
if (!redundant) { if (!redundant) {
/* Otherwise, watch out for multiple instances of the same rename. */ /* Otherwise, watch out for multiple instances of the same rename: */
WRAP_POS l; WRAP_POS l;
Scheme_Object *la;
WRAP_POS_COPY(l,w); WRAP_POS_COPY(l,w);
for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) {
if (SAME_OBJ(a, WRAP_POS_FIRST(l))) { la = WRAP_POS_FIRST(l);
if (SAME_OBJ(a, la)) {
redundant = 1; redundant = 1;
break; break;
} }
@ -3766,11 +3875,13 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
/* Check for later [non]module rename at the same phase: */ /* Check for later [non]module rename at the same phase: */
long shift = 0; long shift = 0;
WRAP_POS l; WRAP_POS l;
Scheme_Object *la;
WRAP_POS_COPY(l,w); WRAP_POS_COPY(l,w);
for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) {
if (SCHEME_RENAMESP(WRAP_POS_FIRST(l))) { la = WRAP_POS_FIRST(l);
if (SCHEME_RENAMESP(la)) {
Module_Renames *lrn = (Module_Renames *)WRAP_POS_FIRST(l); Module_Renames *lrn = (Module_Renames *)WRAP_POS_FIRST(l);
if ((lrn->kind == mrn->kind) if ((lrn->kind == mrn->kind)
&& ((lrn->phase + shift) == mrn->phase)) { && ((lrn->phase + shift) == mrn->phase)) {
@ -3778,7 +3889,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
redundant = 1; redundant = 1;
break; break;
} }
} else if (SCHEME_BOXP(WRAP_POS_FIRST(l))) { } else if (SCHEME_BOXP(la)) {
shift += SCHEME_INT_VAL(SCHEME_VEC_ELS(SCHEME_PTR_VAL(WRAP_POS_FIRST(l)))[0]); shift += SCHEME_INT_VAL(SCHEME_VEC_ELS(SCHEME_PTR_VAL(WRAP_POS_FIRST(l)))[0]);
} }
} }
@ -3804,7 +3915,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
int i, j, count = 0; int i, j, count = 0;
Scheme_Object *l, *idi; Scheme_Object *l, *idi;
count = mrn->ht->mcount; count = mrn->ht->count;
l = scheme_make_vector(count * 2, NULL); l = scheme_make_vector(count * 2, NULL);

4
src/mzscheme/src/syntax.c
View File

@ -898,7 +898,7 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In
Scheme_Object *name, *pr, *bucket; Scheme_Object *name, *pr, *bucket;
name = SCHEME_STX_CAR(var); name = SCHEME_STX_CAR(var);
name = scheme_tl_id_sym(env->genv, name, 2); name = scheme_tl_id_sym(env->genv, name, NULL, 2);
if (rec[drec].resolve_module_ids || !env->genv->module) { if (rec[drec].resolve_module_ids || !env->genv->module) {
bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv); bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv);
@ -4077,7 +4077,7 @@ static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env)
{ {
Scheme_Env *env = (Scheme_Env *)_env; Scheme_Env *env = (Scheme_Env *)_env;
return scheme_tl_id_sym(env, name, 2); return scheme_tl_id_sym(env, name, NULL, 2);
} }
static Scheme_Object * static Scheme_Object *

16
src/mzscheme/src/thread.c
View File

@ -220,7 +220,7 @@ extern MZ_DLLIMPORT long GC_get_memory_use();
typedef struct Thread_Cell { typedef struct Thread_Cell {
Scheme_Object so; Scheme_Object so;
char inherited; char inherited, assigned;
Scheme_Object *def_val; Scheme_Object *def_val;
/* A thread's thread_cell table maps cells to keys weakly. /* A thread's thread_cell table maps cells to keys weakly.
This table maps keys to values weakly. The two weak This table maps keys to values weakly. The two weak
@ -5391,15 +5391,19 @@ Scheme_Object *scheme_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Ta
{ {
Scheme_Object *v; Scheme_Object *v;
v = scheme_lookup_in_table(cells, (const char *)cell); if (((Thread_Cell *)cell)->assigned) {
if (v) v = scheme_lookup_in_table(cells, (const char *)cell);
return scheme_ephemeron_value(v); if (v)
else return scheme_ephemeron_value(v);
return ((Thread_Cell *)cell)->def_val; }
return ((Thread_Cell *)cell)->def_val;
} }
void scheme_thread_cell_set(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v) void scheme_thread_cell_set(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v)
{ {
if (!((Thread_Cell *)cell)->assigned)
((Thread_Cell *)cell)->assigned = 1;
v = scheme_make_ephemeron(cell, v); v = scheme_make_ephemeron(cell, v);
scheme_add_to_table(cells, (const char *)cell, (void *)v, 0); scheme_add_to_table(cells, (const char *)cell, (void *)v, 0);
} }

12
src/wxxt/src/DeviceContexts/WindowDC.cc
View File

@ -157,6 +157,8 @@ wxWindowDC::wxWindowDC(void) : wxDC()
current_pen = wxBLACK_PEN; current_pen = wxBLACK_PEN;
current_pen->Lock(1); current_pen->Lock(1);
current_font = wxNORMAL_FONT; current_font = wxNORMAL_FONT;
need_x_set_font = 1;
} }
wxWindowDC::~wxWindowDC(void) wxWindowDC::~wxWindowDC(void)
@ -2428,6 +2430,10 @@ void wxWindowDC::DrawText(char *orig_text, double x, double y,
#endif #endif
{ {
if ((angle == 0.0) && (current_text_bgmode == wxSOLID)) { if ((angle == 0.0) && (current_text_bgmode == wxSOLID)) {
if (need_x_set_font) {
XSetFont(DPY, TEXT_GC, fontinfo->fid);
need_x_set_font = 0;
}
XDrawImageString16(DPY, DRAWABLE, TEXT_GC, dev_x, dev_y+ascent, (XChar2b *)text + dt, textlen); XDrawImageString16(DPY, DRAWABLE, TEXT_GC, dev_x, dev_y+ascent, (XChar2b *)text + dt, textlen);
} else { } else {
if (angle != 0.0) { if (angle != 0.0) {
@ -2471,6 +2477,10 @@ void wxWindowDC::DrawText(char *orig_text, double x, double y,
XSetFont(DPY, TEXT_GC, zfontinfo->fid); XSetFont(DPY, TEXT_GC, zfontinfo->fid);
} else { } else {
if (need_x_set_font) {
XSetFont(DPY, TEXT_GC, fontinfo->fid);
need_x_set_font = 0;
}
XDrawString16(DPY, DRAWABLE, TEXT_GC, dev_x, dev_y+ascent, ((XChar2b *)text) + dt, textlen); XDrawString16(DPY, DRAWABLE, TEXT_GC, dev_x, dev_y+ascent, ((XChar2b *)text) + dt, textlen);
} }
} }
@ -2673,6 +2683,8 @@ void wxWindowDC::SetFont(wxFont *font)
if (!(current_font = font)) // nothing to do without a font if (!(current_font = font)) // nothing to do without a font
return; return;
need_x_set_font = 1;
} }
void wxWindowDC::SetTextForeground(wxColour *col) void wxWindowDC::SetTextForeground(wxColour *col)

2
src/wxxt/src/DeviceContexts/WindowDC.h
View File

@ -222,6 +222,8 @@ protected:
friend class wxWindow; friend class wxWindow;
friend class wxPostScriptDC; friend class wxPostScriptDC;
char need_x_set_font;
void Initialize(wxWindowDC_Xinit* init); void Initialize(wxWindowDC_Xinit* init);
void Destroy(void); void Destroy(void);