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
svn: r2689
This commit is contained in:
Matthew Flatt
parent
0c25abb469
commit
a07b22f1f1
12
src/foreign/README
Normal file
12
src/foreign/README
Normal 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
1
src/foreign/gcc/libffi/configure
vendored
|
|
@ -5383,6 +5383,7 @@ i*86-*-solaris2.1[0-9]*) TARGET=X86_64; TARGETDIR=x86;;
|
|||
i*86-*-solaris*) TARGET=X86; TARGETDIR=x86;;
|
||||
i*86-*-beos*) 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-*-rtems*) TARGET=X86; TARGETDIR=x86;;
|
||||
i*86-*-darwin*) TARGET=X86; TARGETDIR=x86;;
|
||||
|
|
|
|||
|
|
@ -418,10 +418,6 @@ scheme_lookup_global
|
|||
scheme_global_bucket
|
||||
scheme_global_keyword_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_set_global_bucket
|
||||
scheme_install_macro
|
||||
|
|
|
|||
|
|
@ -425,10 +425,6 @@ scheme_lookup_global
|
|||
scheme_global_bucket
|
||||
scheme_global_keyword_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_set_global_bucket
|
||||
scheme_install_macro
|
||||
|
|
|
|||
|
|
@ -410,10 +410,6 @@ EXPORTS
|
|||
scheme_global_bucket
|
||||
scheme_global_keyword_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_set_global_bucket
|
||||
scheme_install_macro
|
||||
|
|
|
|||
|
|
@ -734,7 +734,7 @@ typedef struct Scheme_Hash_Table
|
|||
void (*make_hash_indices)(void *v, long *h1, long *h2);
|
||||
int (*compare)(void *v1, void *v2);
|
||||
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;
|
||||
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -615,9 +615,30 @@ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client
|
|||
/* 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)
|
||||
{
|
||||
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)
|
||||
|
|
@ -720,6 +741,9 @@ void scheme_prepare_exp_env(Scheme_Env *env)
|
|||
|
||||
env->exp_env = eenv;
|
||||
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;
|
||||
}
|
||||
|
||||
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 **********/
|
||||
|
||||
void
|
||||
|
|
@ -1577,11 +1586,11 @@ 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, 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. */
|
||||
{
|
||||
Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm;
|
||||
int best_match_skipped, ms;
|
||||
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;
|
||||
|
||||
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
|
||||
marks is relatively expensive, but we only do this once per
|
||||
definition. */
|
||||
if (!bdg)
|
||||
bdg = scheme_stx_moduleless_env(id, 0 /* renames currently don't depend on phase */);
|
||||
marks = scheme_stx_extract_marks(id);
|
||||
if (SCHEME_NULLP(marks))
|
||||
if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg))
|
||||
return sym;
|
||||
}
|
||||
|
||||
|
|
@ -1619,10 +1630,15 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
|
|||
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) {
|
||||
/* We really do need the marks. Get them. */
|
||||
marks = scheme_stx_extract_marks(id);
|
||||
if (SCHEME_NULLP(marks))
|
||||
if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg))
|
||||
return sym;
|
||||
}
|
||||
|
||||
|
|
@ -1633,12 +1649,25 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
|
|||
Since the list is otherwise marshaled into .zo, etc.,
|
||||
simplify by extracting just the mark: */
|
||||
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 */
|
||||
for (l = map; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
|
||||
a = SCHEME_CAR(l);
|
||||
amarks = SCHEME_CAR(a);
|
||||
|
||||
if (SCHEME_VECTORP(amarks)) {
|
||||
abdg = SCHEME_VEC_ELS(amarks)[1];
|
||||
amarks = SCHEME_VEC_ELS(amarks)[0];
|
||||
} else
|
||||
abdg = NULL;
|
||||
|
||||
if (SAME_OBJ(abdg, bdg)) {
|
||||
if (is_def) {
|
||||
if (scheme_equal(amarks, marks)) {
|
||||
best_match = SCHEME_CDR(a);
|
||||
|
|
@ -1647,7 +1676,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
|
|||
} else {
|
||||
if (!SCHEME_PAIRP(marks)) {
|
||||
/* To be better than nothing, could only match exactly: */
|
||||
if (SAME_OBJ(amarks, marks)) {
|
||||
if (scheme_equal(amarks, marks)) {
|
||||
best_match = SCHEME_CDR(a);
|
||||
best_match_skipped = 0;
|
||||
}
|
||||
|
|
@ -1675,6 +1704,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, int is_def)
|
|||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (!best_match) {
|
||||
if (!is_def) {
|
||||
|
|
@ -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... */
|
||||
}
|
||||
}
|
||||
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);
|
||||
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;
|
||||
|
||||
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
|
||||
find_global_id = find_id;
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
This is so temporaries can be used as defined ids. */
|
||||
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))) {
|
||||
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;
|
||||
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))) {
|
||||
/* Since the module has a rename for this id, it's certainly defined. */
|
||||
} 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 = 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) {
|
||||
/* 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;
|
||||
|
||||
/* 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),
|
||||
icons(scheme_make_immutable_pair(*_id, scheme_null),
|
||||
|
|
|
|||
|
|
@ -3119,8 +3119,13 @@ static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
|
|||
saved->type = scheme_rt_saved_stack;
|
||||
#endif
|
||||
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);
|
||||
/* 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 {
|
||||
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: */
|
||||
sub_cont = sub_cont->buf.cont;
|
||||
size = sub_cont->runstack_copied->runstack_size;
|
||||
if (size) {
|
||||
/* Skip the first item, since that's the call/cc argument,
|
||||
which we don't want from the outer continuation. */
|
||||
memcpy(MZ_RUNSTACK XFORM_OK_PLUS done,
|
||||
sub_cont->runstack_copied->runstack_start,
|
||||
size * sizeof(Scheme_Object *));
|
||||
done += size;
|
||||
sub_cont->runstack_copied->runstack_start + 1,
|
||||
(size - 1) * sizeof(Scheme_Object *));
|
||||
done += (size - 1);
|
||||
}
|
||||
} else
|
||||
break;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -78,6 +78,9 @@ END_XFORM_ARITH;
|
|||
#define WORDS_TO_BYTES(x) ((x) << JIT_LOG_WORD_SIZE)
|
||||
#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)
|
||||
# define NEED_LONG_JUMPS
|
||||
#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 *bad_car_code, *bad_cdr_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 *on_demand_jit_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")) {
|
||||
generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 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 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"));
|
||||
|
||||
|
|
@ -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));
|
||||
mz_runstack_popped(jitter, 1);
|
||||
|
||||
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 {
|
||||
long offset;
|
||||
offset = SCHEME_INT_VAL(app->rand2);
|
||||
(void)jit_movi_p(JIT_R1, offset);
|
||||
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);
|
||||
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)
|
||||
|
|
@ -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);
|
||||
CHECK_LIMIT();
|
||||
jit_ldxi_i(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.count);
|
||||
jit_lshi_i(JIT_V1, JIT_V1, 0x1);
|
||||
jit_ori_i(JIT_V1, JIT_V1, 0x1);
|
||||
jit_lshi_l(JIT_V1, JIT_V1, 0x1);
|
||||
jit_ori_l(JIT_V1, JIT_V1, 0x1);
|
||||
mz_pushr_p(JIT_V1);
|
||||
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.array);
|
||||
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)
|
||||
{
|
||||
int in, i;
|
||||
int in, i, ii;
|
||||
GC_CAN_IGNORE jit_insn *ref, *ref2;
|
||||
|
||||
/* *** 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);
|
||||
CHECK_LIMIT();
|
||||
/* Extract old return address and jump to it */
|
||||
jit_lshi_i(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_lshi_l(JIT_R1, JIT_R1, (JIT_LOG_WORD_SIZE + 2));
|
||||
jit_addi_l(JIT_R1, JIT_R1, (int)&((Stack_Cache_Elem *)0x0)->orig_return_address);
|
||||
(void)jit_movi_p(JIT_R2, &stack_cache_stack);
|
||||
jit_ldxr_p(JIT_R2, JIT_R2, JIT_R1);
|
||||
jit_movr_p(JIT_RET, JIT_R0);
|
||||
|
|
@ -4054,17 +4086,52 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
jit_jmpr(JIT_R2);
|
||||
CHECK_LIMIT();
|
||||
|
||||
/* *** vector_ref_[check_index_]code *** */
|
||||
/* R0 is vector, R1 is index (Scheme number in check-index mode),
|
||||
V1 is vector offset in non-check-index mode */
|
||||
/* *** {vector,string,bytes}_ref_[check_index_]code *** */
|
||||
/* R0 is vector/string/bytes, R1 is index (Scheme number in check-index mode),
|
||||
V1 is vector/string/bytes offset in non-check-index mode (and for
|
||||
vector, it includes the offset to the start of the elements array. */
|
||||
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;
|
||||
|
||||
switch (ii) {
|
||||
case 0:
|
||||
ty = scheme_vector_type;
|
||||
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);
|
||||
|
||||
|
|
@ -4086,7 +4153,22 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
jit_prepare(2);
|
||||
jit_pusharg_p(JIT_RUNSTACK);
|
||||
jit_pusharg_i(JIT_R1);
|
||||
switch (ii) {
|
||||
case 0:
|
||||
(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();
|
||||
|
||||
|
|
@ -4096,22 +4178,49 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
(void)jit_blei_l(reffail, JIT_R1, 0x0);
|
||||
}
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
|
||||
(void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type);
|
||||
jit_ldxi_i(JIT_R2, JIT_R0, &SCHEME_VEC_SIZE(0x0));
|
||||
(void)jit_bnei_i(reffail, JIT_R2, ty);
|
||||
jit_ldxi_i(JIT_R2, JIT_R0, count_offset);
|
||||
if (i) {
|
||||
/* index from expression: */
|
||||
jit_rshi_ul(JIT_V1, JIT_R1, 1);
|
||||
(void)jit_bler_ul(reffail, JIT_R2, JIT_V1);
|
||||
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
|
||||
jit_addi_p(JIT_V1, JIT_V1, ((int)&SCHEME_VEC_ELS(0x0)));
|
||||
if (log_elem_size)
|
||||
jit_lshi_ul(JIT_V1, JIT_V1, log_elem_size);
|
||||
if (!ii) /* vector */
|
||||
jit_addi_p(JIT_V1, JIT_V1, offset);
|
||||
} else {
|
||||
/* constant index supplied: */
|
||||
(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);
|
||||
}
|
||||
}
|
||||
|
||||
/* *** syntax_ecode *** */
|
||||
/* R0 is (potential) syntax object */
|
||||
|
|
|
|||
|
|
@ -1941,7 +1941,7 @@ void scheme_clear_ephemerons()
|
|||
done_ephemerons = NULL;
|
||||
}
|
||||
|
||||
extern MZ_DLLIMPORT void (*GC_custom_finalize)(void);
|
||||
extern MZ_DLLIMPORT void (*GC_custom_finalize)();
|
||||
|
||||
void scheme_init_ephemerons(void)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
/**********************************************************************/
|
||||
|
|
@ -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
|
||||
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)
|
||||
|| (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);
|
||||
}
|
||||
|
||||
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);
|
||||
|
||||
|
|
@ -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);
|
||||
}
|
||||
|
||||
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 *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);
|
||||
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);
|
||||
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);
|
||||
|
|
@ -3428,7 +3427,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
if (restore_confusing_name)
|
||||
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 {
|
||||
Scheme_Object *hints, *formname;
|
||||
|
||||
|
|
@ -3484,10 +3483,14 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
|
|||
|
||||
/* make self_modidx like the empty modidx */
|
||||
((Scheme_Modidx *)self_modidx)->resolved = empty_self_symbol;
|
||||
}
|
||||
|
||||
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 *
|
||||
module_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
|
||||
|
|
@ -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)
|
||||
{
|
||||
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)
|
||||
|
|
@ -3768,7 +3771,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id,
|
|||
self_modidx = SCHEME_VEC_ELS(data)[1];
|
||||
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: */
|
||||
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_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: */
|
||||
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: */
|
||||
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: */
|
||||
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)
|
||||
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)) {
|
||||
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: */
|
||||
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(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)
|
||||
&& !scheme_lookup_in_table(env->genv->syntax, (const char *)name)) {
|
||||
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)) {
|
||||
name = SCHEME_CAR(adl);
|
||||
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? */
|
||||
for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(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))
|
||||
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
|
||||
to the actual tl_id. */
|
||||
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)) {
|
||||
/* 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... */
|
||||
n = SCHEME_CAR(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);
|
||||
if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_symbol)) {
|
||||
/* 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)) {
|
||||
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
|
||||
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));
|
||||
|
||||
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)) {
|
||||
/* 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;
|
||||
|
||||
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;
|
||||
}
|
||||
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;
|
||||
}
|
||||
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
|
||||
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(env, iname, 2);
|
||||
iname = scheme_tl_id_sym(env, iname, scheme_false, 2);
|
||||
}
|
||||
|
||||
if (ck)
|
||||
|
|
|
|||
|
|
@ -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_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(mult, "*", scheme_bin_mult, 1, SCHEME_NUMBERP, "number")
|
||||
GEN_NARY_OP(static, plus, "+", scheme_bin_plus, 0, SCHEME_NUMBERP, "number")
|
||||
GEN_NARY_OP(static, mult, "*", scheme_bin_mult, 1, SCHEME_NUMBERP, "number")
|
||||
|
||||
static Scheme_Object *
|
||||
minus (int argc, Scheme_Object *argv[])
|
||||
|
|
|
|||
|
|
@ -264,15 +264,15 @@ scheme_init_number (Scheme_Env *env)
|
|||
1, 1, 1),
|
||||
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_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_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_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);
|
||||
|
||||
GEN_NARY_OP(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, gcd, "gcd", scheme_bin_gcd, 0, scheme_is_integer, "integer")
|
||||
GEN_NARY_OP(static, lcm, "lcm", bin_lcm, 1, scheme_is_integer, "integer")
|
||||
|
||||
Scheme_Object *
|
||||
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 /**/
|
||||
|
||||
GEN_TWOARY_OP(MZ_PUBLIC, scheme_bitwise_and, "bitwise-and", bin_bitwise_and, SCHEME_EXACT_INTEGERP, "exact integer")
|
||||
GEN_TWOARY_OP(static, bitwise_or, "bitwise-ior", bin_bitwise_or, SCHEME_EXACT_INTEGERP, "exact integer")
|
||||
GEN_TWOARY_OP(static, bitwise_xor, "bitwise-xor", bin_bitwise_xor, 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_NARY_OP(static, bitwise_or, "bitwise-ior", bin_bitwise_or, 0, 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 *
|
||||
bitwise_not(int argc, Scheme_Object *argv[])
|
||||
|
|
|
|||
|
|
@ -456,8 +456,8 @@ name (const Scheme_Object *n1, const Scheme_Object *n2) \
|
|||
return scheme_void; \
|
||||
}
|
||||
|
||||
#define GEN_NARY_OP(name, scheme_name, bin_name, ident, TYPEP, type) \
|
||||
static Scheme_Object * \
|
||||
#define GEN_NARY_OP(stat, name, scheme_name, bin_name, ident, TYPEP, type) \
|
||||
stat Scheme_Object * \
|
||||
name (int argc, Scheme_Object *argv[]) \
|
||||
{ \
|
||||
Scheme_Object *ret; \
|
||||
|
|
|
|||
|
|
@ -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_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 void scheme_set_global_bucket(char *proc, Scheme_Bucket *var, Scheme_Object *val,
|
||||
|
|
|
|||
|
|
@ -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_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_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 */
|
||||
void (*scheme_set_global_bucket)(char *proc, Scheme_Bucket *var, Scheme_Object *val,
|
||||
int set_undef);
|
||||
|
|
|
|||
|
|
@ -467,10 +467,6 @@
|
|||
scheme_extension_table->scheme_global_bucket = scheme_global_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_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_set_global_bucket = scheme_set_global_bucket;
|
||||
scheme_extension_table->scheme_install_macro = scheme_install_macro;
|
||||
|
|
|
|||
|
|
@ -467,10 +467,6 @@
|
|||
#define scheme_global_bucket (scheme_extension_table->scheme_global_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_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_set_global_bucket (scheme_extension_table->scheme_set_global_bucket)
|
||||
#define scheme_install_macro (scheme_extension_table->scheme_install_macro)
|
||||
|
|
|
|||
|
|
@ -611,6 +611,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **name, long phase,
|
|||
Scheme_Object **nominal_modidx,
|
||||
Scheme_Object **nominal_name,
|
||||
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_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,
|
||||
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
|
||||
void scheme_ill_formed(Mz_CPort *port, const char *file, int 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_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);
|
||||
|
||||
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_cdr(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);
|
||||
|
||||
void scheme_set_root_param(int p, Scheme_Object *v);
|
||||
|
|
|
|||
|
|
@ -2596,7 +2596,7 @@
|
|||
"(string->immutable-string"
|
||||
" (format \"load/cd: cannot open a directory: ~s\" n))"
|
||||
"(current-continuation-marks)))"
|
||||
"(if(not(bytes? base))"
|
||||
"(if(not(path? base))"
|
||||
"(load n)"
|
||||
"(begin"
|
||||
"(if(not(directory-exists? base))"
|
||||
|
|
|
|||
|
|
@ -3010,7 +3010,7 @@
|
|||
(string->immutable-string
|
||||
(format "load/cd: cannot open a directory: ~s" n))
|
||||
(current-continuation-marks)))
|
||||
(if (not (bytes? base))
|
||||
(if (not (path? base))
|
||||
(load n)
|
||||
(begin
|
||||
(if (not (directory-exists? base))
|
||||
|
|
|
|||
|
|
@ -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_p (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_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_string_p (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_eq (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",
|
||||
1, 1, 1),
|
||||
env);
|
||||
scheme_add_global_constant("string-ref",
|
||||
scheme_make_noncm_prim(string_ref,
|
||||
"string-ref",
|
||||
2, 2),
|
||||
env);
|
||||
|
||||
p = scheme_make_noncm_prim(scheme_checked_string_ref, "string-ref", 2, 2);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
|
||||
scheme_add_global_constant("string-ref", p, env);
|
||||
|
||||
scheme_add_global_constant("string-set!",
|
||||
scheme_make_noncm_prim(string_set,
|
||||
"string-set!",
|
||||
|
|
@ -619,11 +617,11 @@ scheme_init_string (Scheme_Env *env)
|
|||
"bytes-length",
|
||||
1, 1, 1),
|
||||
env);
|
||||
scheme_add_global_constant("bytes-ref",
|
||||
scheme_make_noncm_prim(byte_string_ref,
|
||||
"bytes-ref",
|
||||
2, 2),
|
||||
env);
|
||||
|
||||
p = scheme_make_noncm_prim(scheme_checked_byte_string_ref, "bytes-ref", 2, 2);
|
||||
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
|
||||
scheme_add_global_constant("bytes-ref", p, env);
|
||||
|
||||
scheme_add_global_constant("bytes-set!",
|
||||
scheme_make_noncm_prim(byte_string_set,
|
||||
"bytes-set!",
|
||||
|
|
|
|||
|
|
@ -145,8 +145,8 @@ X__(string_length) (int argc, Scheme_Object *argv[])
|
|||
return scheme_make_integer(SCHEME_X_STRTAG_VAL(argv[0]));
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
X__(string_ref) (int argc, Scheme_Object *argv[])
|
||||
Scheme_Object *
|
||||
X_(scheme_checked, string_ref) (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
long i, len;
|
||||
int c;
|
||||
|
|
|
|||
|
|
@ -21,7 +21,20 @@
|
|||
#include "schpriv.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
|
||||
|
||||
|
|
@ -70,6 +83,7 @@ static Scheme_Object *protected_symbol;
|
|||
static Scheme_Object *nominal_ipair_cache;
|
||||
|
||||
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;
|
||||
|
||||
|
|
@ -153,6 +167,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
|
|||
typedef struct Scheme_Lexical_Rib {
|
||||
Scheme_Object so;
|
||||
Scheme_Object *rename; /* a vector for a lexical rename */
|
||||
Scheme_Object *timestamp;
|
||||
struct Scheme_Lexical_Rib *next;
|
||||
} 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_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_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
|
||||
|
|
@ -1026,6 +1041,9 @@ Scheme_Object *scheme_make_rename_rib()
|
|||
|
||||
rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib);
|
||||
rib->so.type = scheme_lexical_rib_type;
|
||||
rib->timestamp = current_rib_timestamp;
|
||||
|
||||
current_rib_timestamp = scheme_add1(1, ¤t_rib_timestamp);
|
||||
|
||||
return (Scheme_Object *)rib;
|
||||
}
|
||||
|
|
@ -1041,6 +1059,8 @@ void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename)
|
|||
rib = (Scheme_Lexical_Rib *)ro;
|
||||
naya->next = rib->next;
|
||||
rib->next = naya;
|
||||
|
||||
naya->timestamp = rib->timestamp;
|
||||
}
|
||||
|
||||
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 *)dest)->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]);
|
||||
}
|
||||
}
|
||||
((Module_Renames *)dest)->marked_names = ((Module_Renames *)src)->marked_names;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -2630,7 +2639,12 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
|
|||
|
||||
#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,
|
||||
Scheme_Object *skip_ribs)
|
||||
/* 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 *modidx_shift_to = NULL, *modidx_shift_from = NULL;
|
||||
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;
|
||||
Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL;
|
||||
long orig_phase = phase;
|
||||
Scheme_Object *bdg = NULL;
|
||||
|
||||
if (_wraps) {
|
||||
WRAP_POS_COPY(wraps, *_wraps);
|
||||
WRAP_POS_INC(wraps);
|
||||
} else
|
||||
WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps);
|
||||
|
||||
while (1) {
|
||||
if (WRAP_POS_END_P(wraps)) {
|
||||
/* See rename case for info on rename_stack: */
|
||||
Scheme_Object *result;
|
||||
Scheme_Object *result, *key;
|
||||
int did_lexical = 0;
|
||||
|
||||
result = scheme_false;
|
||||
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));
|
||||
} 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);
|
||||
}
|
||||
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];
|
||||
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;
|
||||
}
|
||||
if (SCHEME_FALSEP(result))
|
||||
if (!did_lexical)
|
||||
result = mresult;
|
||||
else if (get_names)
|
||||
get_names[0] = scheme_undefined;
|
||||
|
|
@ -2687,9 +2720,24 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
|
|||
if (mrn->needs_unmarshal)
|
||||
unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to);
|
||||
|
||||
if (mrn->marked_names)
|
||||
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, 0);
|
||||
else
|
||||
if (mrn->marked_names) {
|
||||
/* Resolve based on rest of wraps: */
|
||||
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);
|
||||
|
||||
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;
|
||||
}
|
||||
} else if (rib || SCHEME_VECTORP(WRAP_POS_FIRST(wraps))) {
|
||||
} else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
|
||||
&& !no_lexical)) {
|
||||
/* Lexical rename: */
|
||||
Scheme_Object *rename, *renamed;
|
||||
int ri, c, istart, iend;
|
||||
Scheme_Object *rename, *renamed, *recur_skip_ribs;
|
||||
int ri, c, istart, iend, is_rib;
|
||||
|
||||
if (rib) {
|
||||
rename = rib->rename;
|
||||
recur_skip_ribs = rib->timestamp;
|
||||
rib = rib->next;
|
||||
is_rib = 1;
|
||||
} else {
|
||||
rename = WRAP_POS_FIRST(wraps);
|
||||
recur_skip_ribs = skip_ribs;
|
||||
is_rib = 0;
|
||||
}
|
||||
|
||||
c = SCHEME_RENAME_LEN(rename);
|
||||
|
|
@ -2836,9 +2889,8 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
|
|||
|
||||
if (SCHEME_VOIDP(other_env)) {
|
||||
SCHEME_USE_FUEL(1);
|
||||
other_env = resolve_env(renamed, 0, 0, NULL,
|
||||
scheme_make_pair(WRAP_POS_FIRST(wraps),
|
||||
skip_ribs));
|
||||
other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs);
|
||||
if (!is_rib)
|
||||
SCHEME_VEC_ELS(rename)[2+c+ri] = other_env;
|
||||
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
|
||||
top element of the stack and combine the two
|
||||
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) {
|
||||
rename_stack[stack_pos++] = envname;
|
||||
rename_stack[stack_pos++] = other_env;
|
||||
|
|
@ -2871,22 +2923,21 @@ 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. */
|
||||
Scheme_Object *srs;
|
||||
rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps);
|
||||
for (srs = skip_ribs; SCHEME_PAIRP(srs); srs = SCHEME_CDR(srs)) {
|
||||
if (SAME_OBJ(SCHEME_CAR(srs), (Scheme_Object *)rib))
|
||||
break;
|
||||
}
|
||||
if (SCHEME_PAIRP(srs))
|
||||
if (skip_ribs) {
|
||||
if (scheme_bin_gt_eq(rib->timestamp, skip_ribs))
|
||||
rib = NULL;
|
||||
else if (SAME_OBJ(did_rib, rib))
|
||||
}
|
||||
if (rib) {
|
||||
if (SAME_OBJ(did_rib, rib))
|
||||
rib = NULL;
|
||||
else {
|
||||
did_rib = rib;
|
||||
rib = rib->next; /* First rib record has no rename */
|
||||
}
|
||||
}
|
||||
} else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))
|
||||
|| SAME_OBJ(WRAP_POS_FIRST(wraps), barrier_symbol)) {
|
||||
did_rib = NULL;
|
||||
|
|
@ -2922,6 +2973,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, long phase)
|
|||
Scheme_Object *result;
|
||||
int is_in_module = 0, skip_other_mods = 0;
|
||||
long orig_phase = phase;
|
||||
Scheme_Object *bdg = NULL;
|
||||
|
||||
if (((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) {
|
||||
/* Use resolve_env to trigger unmarshal, so that we
|
||||
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)
|
||||
glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, 0);
|
||||
else
|
||||
if (mrn->marked_names) {
|
||||
/* Resolve based on rest of wraps: */
|
||||
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);
|
||||
|
||||
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);
|
||||
|
||||
if (rename) {
|
||||
/* match; set result: */
|
||||
if (mrn->kind == mzMOD_RENAME_MARKED)
|
||||
skip_other_mods = 1;
|
||||
/* match; set result: */
|
||||
if (SCHEME_PAIRP(rename)) {
|
||||
if (SCHEME_IMMUTABLEP(rename)) {
|
||||
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))
|
||||
return 1;
|
||||
|
||||
a = resolve_env(a, phase, 1, NULL, scheme_null);
|
||||
b = resolve_env(b, phase, 1, NULL, scheme_null);
|
||||
a = resolve_env(NULL, a, phase, 1, NULL, NULL);
|
||||
b = resolve_env(NULL, b, phase, 1, NULL, NULL);
|
||||
|
||||
a = scheme_module_resolve(a);
|
||||
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))
|
||||
return 1;
|
||||
|
||||
a = resolve_env(a, phase, 1, NULL, scheme_null);
|
||||
b = resolve_env(b, phase, 1, NULL, scheme_null);
|
||||
a = resolve_env(NULL, a, phase, 1, NULL, NULL);
|
||||
b = resolve_env(NULL, b, phase, 1, NULL, NULL);
|
||||
|
||||
a = scheme_module_resolve(a);
|
||||
b = scheme_module_resolve(b);
|
||||
|
|
@ -3077,7 +3133,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, long phase,
|
|||
names[0] = NULL;
|
||||
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 (SAME_OBJ(names[0], scheme_undefined)) {
|
||||
|
|
@ -3098,6 +3154,20 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, long phase,
|
|||
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)
|
||||
/* 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))
|
||||
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. */
|
||||
|
||||
if (uid)
|
||||
be = uid;
|
||||
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. */
|
||||
}
|
||||
|
||||
|
|
@ -3352,6 +3422,20 @@ int scheme_stx_proper_list_length(Scheme_Object *list)
|
|||
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 *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)) {
|
||||
int 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) {
|
||||
/* Not a list. Can't flatten this one. */
|
||||
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]))) {
|
||||
/* This is the place to simplify: */
|
||||
Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL;
|
||||
Scheme_Object *skip_ribs = scheme_null;
|
||||
Scheme_Object *skip_ribs = NULL;
|
||||
int ii, vvsize;
|
||||
|
||||
if (SCHEME_RIBP(v)) {
|
||||
skip_ribs = scheme_make_pair(v, scheme_null);
|
||||
init_rib = (Scheme_Lexical_Rib *)v;
|
||||
skip_ribs = init_rib->timestamp;
|
||||
rib = init_rib->next;
|
||||
vsize = 0;
|
||||
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];
|
||||
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;
|
||||
}
|
||||
|
||||
|
|
@ -3750,13 +3857,15 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
|
|||
/* Not useful if there's no marked names. */
|
||||
redundant = !mrn->marked_names->count;
|
||||
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;
|
||||
Scheme_Object *la;
|
||||
|
||||
WRAP_POS_COPY(l,w);
|
||||
|
||||
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;
|
||||
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: */
|
||||
long shift = 0;
|
||||
WRAP_POS l;
|
||||
Scheme_Object *la;
|
||||
|
||||
WRAP_POS_COPY(l,w);
|
||||
|
||||
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);
|
||||
if ((lrn->kind == mrn->kind)
|
||||
&& ((lrn->phase + shift) == mrn->phase)) {
|
||||
|
|
@ -3778,7 +3889,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
|
|||
redundant = 1;
|
||||
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]);
|
||||
}
|
||||
}
|
||||
|
|
@ -3804,7 +3915,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
|
|||
int i, j, count = 0;
|
||||
Scheme_Object *l, *idi;
|
||||
|
||||
count = mrn->ht->mcount;
|
||||
count = mrn->ht->count;
|
||||
|
||||
l = scheme_make_vector(count * 2, NULL);
|
||||
|
||||
|
|
|
|||
|
|
@ -898,7 +898,7 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In
|
|||
Scheme_Object *name, *pr, *bucket;
|
||||
|
||||
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) {
|
||||
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;
|
||||
|
||||
return scheme_tl_id_sym(env, name, 2);
|
||||
return scheme_tl_id_sym(env, name, NULL, 2);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
|
|
|
|||
|
|
@ -220,7 +220,7 @@ extern MZ_DLLIMPORT long GC_get_memory_use();
|
|||
|
||||
typedef struct Thread_Cell {
|
||||
Scheme_Object so;
|
||||
char inherited;
|
||||
char inherited, assigned;
|
||||
Scheme_Object *def_val;
|
||||
/* A thread's thread_cell table maps cells to keys weakly.
|
||||
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;
|
||||
|
||||
if (((Thread_Cell *)cell)->assigned) {
|
||||
v = scheme_lookup_in_table(cells, (const char *)cell);
|
||||
if (v)
|
||||
return scheme_ephemeron_value(v);
|
||||
else
|
||||
}
|
||||
|
||||
return ((Thread_Cell *)cell)->def_val;
|
||||
}
|
||||
|
||||
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);
|
||||
scheme_add_to_table(cells, (const char *)cell, (void *)v, 0);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -157,6 +157,8 @@ wxWindowDC::wxWindowDC(void) : wxDC()
|
|||
current_pen = wxBLACK_PEN;
|
||||
current_pen->Lock(1);
|
||||
current_font = wxNORMAL_FONT;
|
||||
|
||||
need_x_set_font = 1;
|
||||
}
|
||||
|
||||
wxWindowDC::~wxWindowDC(void)
|
||||
|
|
@ -2428,6 +2430,10 @@ void wxWindowDC::DrawText(char *orig_text, double x, double y,
|
|||
#endif
|
||||
{
|
||||
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);
|
||||
} else {
|
||||
if (angle != 0.0) {
|
||||
|
|
@ -2471,6 +2477,10 @@ void wxWindowDC::DrawText(char *orig_text, double x, double y,
|
|||
|
||||
XSetFont(DPY, TEXT_GC, zfontinfo->fid);
|
||||
} 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);
|
||||
}
|
||||
}
|
||||
|
|
@ -2673,6 +2683,8 @@ void wxWindowDC::SetFont(wxFont *font)
|
|||
|
||||
if (!(current_font = font)) // nothing to do without a font
|
||||
return;
|
||||
|
||||
need_x_set_font = 1;
|
||||
}
|
||||
|
||||
void wxWindowDC::SetTextForeground(wxColour *col)
|
||||
|
|
|
|||
|
|
@ -222,6 +222,8 @@ protected:
|
|||
friend class wxWindow;
|
||||
friend class wxPostScriptDC;
|
||||
|
||||
char need_x_set_font;
|
||||
|
||||
void Initialize(wxWindowDC_Xinit* init);
|
||||
void Destroy(void);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user