301.8
svn: r2336
This commit is contained in:
Matthew Flatt
parent
0e1e6b18e4
commit
6aa901de18
|
|
@ -298,7 +298,7 @@ EXTRA_OBJS_L = ../src/gmp.@LTO@ @FOREIGN_OBJSLIB_IF_USED@
|
|||
$(RANLIB) ../libmzscheme3m.@LIBSFX@
|
||||
|
||||
../mzscheme3m@NOT_OSX@: main.@LTO@ ../libmzscheme3m.@LIBSFX@
|
||||
@MZLINKER@ -o ../mzscheme3m main.@LTO@ ../libmzscheme3m.@LIBSFX@ $(LIBS)
|
||||
@MZLINKER@ -o ../mzscheme3m @PROFFLAGS@ main.@LTO@ ../libmzscheme3m.@LIBSFX@ $(LIBS)
|
||||
|
||||
MZFWMMM = PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme
|
||||
|
||||
|
|
@ -311,7 +311,7 @@ $(MZFWMMM): $(OBJS) $(EXTRA_OBJS_T)
|
|||
ln -s Versions/$(FWVERSION)_3m/PLT_MzScheme PLT_MzScheme.framework/PLT_MzScheme
|
||||
|
||||
../mzscheme3m@OSX@: $(MZFWMMM) main.@LTO@
|
||||
$(CC) -o ../mzscheme3m main.@LTO@ -Wl,-headerpad_max_install_names -F. -framework PLT_MzScheme
|
||||
$(CC) -o ../mzscheme3m @PROFFLAGS@ main.@LTO@ -Wl,-headerpad_max_install_names -F. -framework PLT_MzScheme
|
||||
if [ ! -d ../PLT_MzScheme.framework/Versions/$(FWVERSION)_3m ] ; then mkdir ../PLT_MzScheme.framework/Versions/$(FWVERSION)_3m ; fi
|
||||
cp PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme ../PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme
|
||||
|
||||
|
|
|
|||
|
|
@ -102,6 +102,7 @@ scheme_uchar_ups
|
|||
scheme_uchar_downs
|
||||
scheme_uchar_titles
|
||||
scheme_uchar_folds
|
||||
scheme_uchar_combining_classes
|
||||
scheme_eval
|
||||
scheme_eval_multi
|
||||
scheme_eval_compiled
|
||||
|
|
|
|||
|
|
@ -102,6 +102,7 @@ scheme_uchar_ups
|
|||
scheme_uchar_downs
|
||||
scheme_uchar_titles
|
||||
scheme_uchar_folds
|
||||
scheme_uchar_combining_classes
|
||||
scheme_eval
|
||||
scheme_eval_multi
|
||||
scheme_eval_compiled
|
||||
|
|
|
|||
|
|
@ -104,6 +104,7 @@ EXPORTS
|
|||
scheme_uchar_downs
|
||||
scheme_uchar_titles
|
||||
scheme_uchar_folds
|
||||
scheme_uchar_combining_classes
|
||||
scheme_eval
|
||||
scheme_eval_multi
|
||||
scheme_eval_compiled
|
||||
|
|
|
|||
|
|
@ -547,6 +547,8 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
|
|||
#define scheme_isgraphic(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x800)
|
||||
#define scheme_iscaseignorable(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1000)
|
||||
#define scheme_isspecialcasing(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2000)
|
||||
#define scheme_needs_decompose(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4000)
|
||||
#define scheme_needs_maybe_compose(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8000)
|
||||
|
||||
#define scheme_iscased(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x700)
|
||||
|
||||
|
|
@ -554,6 +556,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
|
|||
#define scheme_tolower(x) (x + scheme_uchar_downs[scheme_uchar_find(scheme_uchar_cases_table, x)])
|
||||
#define scheme_totitle(x) (x + scheme_uchar_titles[scheme_uchar_find(scheme_uchar_cases_table, x)])
|
||||
#define scheme_tofold(x) (x + scheme_uchar_folds[scheme_uchar_find(scheme_uchar_cases_table, x)])
|
||||
#define scheme_combining_class(x) (scheme_uchar_combining_classes[scheme_uchar_find(scheme_uchar_cases_table, x)])
|
||||
|
||||
/*========================================================================*/
|
||||
/* procedure values */
|
||||
|
|
@ -563,12 +566,11 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
|
|||
Do not use them directly. */
|
||||
#define SCHEME_PRIM_IS_FOLDING 1
|
||||
#define SCHEME_PRIM_IS_PRIMITIVE 2
|
||||
#define SCHEME_PRIM_IS_STRUCT_PROC 4
|
||||
#define SCHEME_PRIM_IS_STRUCT_SETTER 8
|
||||
#define SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER 4
|
||||
#define SCHEME_PRIM_IS_STRUCT_PRED 8
|
||||
#define SCHEME_PRIM_IS_PARAMETER 16
|
||||
#define SCHEME_PRIM_IS_STRUCT_GETTER 32
|
||||
#define SCHEME_PRIM_IS_STRUCT_PRED 64
|
||||
#define SCHEME_PRIM_IS_STRUCT_CONSTR 128
|
||||
#define SCHEME_PRIM_IS_STRUCT_OTHER 32
|
||||
#define SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK (64 | 128)
|
||||
#define SCHEME_PRIM_IS_MULTI_RESULT 256
|
||||
#define SCHEME_PRIM_IS_BINARY_INLINED 512
|
||||
#define SCHEME_PRIM_IS_USER_PARAMETER 1024
|
||||
|
|
@ -577,6 +579,13 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
|
|||
#define SCHEME_PRIM_IS_NONCM 8192
|
||||
#define SCHEME_PRIM_IS_UNARY_INLINED 16384
|
||||
|
||||
#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER 0
|
||||
#define SCHEME_PRIM_STRUCT_TYPE_CONSTR 64
|
||||
#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER 128
|
||||
#define SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER (64 | 128)
|
||||
|
||||
#define SCHEME_PRIM_IS_STRUCT_PROC (SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER | SCHEME_PRIM_IS_STRUCT_PRED | SCHEME_PRIM_IS_STRUCT_OTHER)
|
||||
|
||||
#define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
|
||||
|
||||
typedef struct Scheme_Object *(Scheme_Prim)(int argc, Scheme_Object *argv[]);
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -3372,8 +3372,12 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
|
|||
result = SCHEME_STX_CDR(result);
|
||||
result = scheme_flatten_begin(first, result);
|
||||
goto define_try_again;
|
||||
} else
|
||||
} else {
|
||||
/* Keep partially expanded `first': */
|
||||
result = SCHEME_STX_CDR(result);
|
||||
result = scheme_make_pair(first, result);
|
||||
break;
|
||||
}
|
||||
}
|
||||
} else
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -793,6 +793,9 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info)
|
|||
/* Then the pointer to globals, if any: */
|
||||
offset = cl->base_closure_size;
|
||||
if (cl->has_tl) {
|
||||
/* GLOBAL ASSUMPTION: jit.c assumes that the array
|
||||
of globals is the last item in the closure; grep
|
||||
for "GLOBAL ASSUMPTION" in jit.c */
|
||||
int li;
|
||||
li = scheme_resolve_toplevel_pos(info);
|
||||
closure_map[offset] = li;
|
||||
|
|
|
|||
|
|
@ -74,6 +74,9 @@ static void *on_demand_jit_code;
|
|||
static void *on_demand_jit_arity_code;
|
||||
static void *get_stack_pointer_code;
|
||||
static void *stack_cache_pop_code;
|
||||
static void *struct_pred_code;
|
||||
static void *struct_pred_branch_code;
|
||||
static void *struct_get_code;
|
||||
|
||||
typedef struct {
|
||||
MZTAG_IF_REQUIRED
|
||||
|
|
@ -94,6 +97,7 @@ typedef struct {
|
|||
int need_set_rs;
|
||||
void **retain_start;
|
||||
int log_depth;
|
||||
Scheme_Native_Closure *nc;
|
||||
} mz_jit_state;
|
||||
|
||||
typedef int (*Native_Check_Arity_Proc)(Scheme_Object *o, int argc);
|
||||
|
|
@ -670,12 +674,12 @@ static int mz_is_closure(mz_jit_state *jitter, int i, int arity)
|
|||
# define mz_patch_ucbranch(a) mz_patch_ucbranch_at(a, (_jit.x.pc))
|
||||
# define mz_prolog(x) (MFLRr(x), mz_set_local_p(x, JIT_LOCAL2))
|
||||
# define mz_epilog(x) (mz_get_local_p(x, JIT_LOCAL2), jit_jmpr(x))
|
||||
# define mz_epilog_without_jmp() /* empty */
|
||||
# define mz_push_locals() /* empty */
|
||||
# define mz_pop_locals() /* empty */
|
||||
#else
|
||||
# define JIT_LOCAL1 -16
|
||||
# define JIT_LOCAL2 -20
|
||||
# define JIT_LOCAL3 JIT_LOCAL2
|
||||
# define mz_set_local_p(x, l) jit_stxi_p((l), JIT_FP, (x))
|
||||
# define mz_get_local_p(x, l) jit_ldxi_p((x), JIT_FP, (l))
|
||||
# define mz_patch_branch_at(a, v) jit_patch_at(a, v)
|
||||
|
|
@ -686,12 +690,16 @@ static int mz_is_closure(mz_jit_state *jitter, int i, int arity)
|
|||
/* Maintain 4-byte stack alignment.
|
||||
Built-in prolog pushes 3 words in local frame already. */
|
||||
# define mz_prolog(x) (SUBLir(3 * JIT_WORD_SIZE, JIT_SP))
|
||||
# define mz_epilog(x) (ADDLir(3 * JIT_WORD_SIZE, JIT_SP), RET_())
|
||||
# define mz_epilog_without_jmp() ADDLir(3 * JIT_WORD_SIZE, JIT_SP)
|
||||
# define mz_epilog(x) (mz_epilog_without_jmp(), RET_())
|
||||
# define LOCAL_FRAME_SIZE 3
|
||||
# define JIT_LOCAL3 -24
|
||||
# else
|
||||
# define mz_prolog(x) /* empty */
|
||||
# define mz_epilog(x) RET_()
|
||||
# define mz_epilog_without_jmp() ADDLir(JIT_WORD_SIZE, JIT_SP)
|
||||
# define LOCAL_FRAME_SIZE 2
|
||||
# define JIT_LOCAL3 JIT_LOCAL2
|
||||
# endif
|
||||
# define mz_push_locals() SUBLir((LOCAL_FRAME_SIZE << JIT_LOG_WORD_SIZE), JIT_SP)
|
||||
# define mz_pop_locals() ADDLir((LOCAL_FRAME_SIZE << JIT_LOG_WORD_SIZE), JIT_SP)
|
||||
|
|
@ -802,10 +810,43 @@ static int is_short(Scheme_Object *obj, int fuel)
|
|||
}
|
||||
#endif
|
||||
|
||||
static int inlined_unary_prim(Scheme_Object *o, Scheme_Object *_app)
|
||||
Scheme_Object *extract_global(Scheme_Object *o, Scheme_Native_Closure *nc)
|
||||
{
|
||||
return (SCHEME_PRIMP(o)
|
||||
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_UNARY_INLINED));
|
||||
/* GLOBAL ASSUMPTION: we assume that globals are the last thing
|
||||
in the closure; grep for "GLOBAL ASSUMPTION" in fun.c. */
|
||||
Scheme_Object **globs;
|
||||
|
||||
globs = (Scheme_Object **)nc->vals[nc->code->u2.orig_code->closure_size - 1];
|
||||
return globs[SCHEME_TOPLEVEL_POS(o)];
|
||||
}
|
||||
|
||||
static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter)
|
||||
{
|
||||
if (jitter->nc
|
||||
&& SAME_TYPE(SCHEME_TYPE(o), scheme_toplevel_type)) {
|
||||
Scheme_Object *p;
|
||||
p = extract_global(o, jitter->nc);
|
||||
p = ((Scheme_Bucket *)p)->val;
|
||||
if (p && SCHEME_PRIMP(p)) {
|
||||
if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED)
|
||||
return 1;
|
||||
else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
|
||||
return 2;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int inlined_unary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_state *jitter)
|
||||
{
|
||||
if (SCHEME_PRIMP(o)
|
||||
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_UNARY_INLINED))
|
||||
return 1;
|
||||
|
||||
if (inlineable_struct_prim(o, jitter))
|
||||
return 1;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app)
|
||||
|
|
@ -825,7 +866,7 @@ static int is_noncm(Scheme_Object *a)
|
|||
|
||||
#define INIT_SIMPLE_DEPTH 10
|
||||
|
||||
static int is_simple(Scheme_Object *obj, int depth, int just_markless)
|
||||
static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_state *jitter)
|
||||
{
|
||||
/* Return 1 if evaluating `obj' doesn't change the runstack or cont-mark stack ---
|
||||
or, if just_markless is 1, doesn't use the cont-mark stack.
|
||||
|
|
@ -849,29 +890,29 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless)
|
|||
case scheme_branch_type:
|
||||
if (depth) {
|
||||
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)obj;
|
||||
return (is_simple(b->tbranch, depth - 1, just_markless)
|
||||
&& is_simple(b->fbranch, depth - 1, just_markless));
|
||||
return (is_simple(b->tbranch, depth - 1, just_markless, jitter)
|
||||
&& is_simple(b->fbranch, depth - 1, just_markless, jitter));
|
||||
}
|
||||
break;
|
||||
|
||||
case scheme_let_value_type:
|
||||
if (depth) {
|
||||
return is_simple(((Scheme_Let_Value *)obj)->body, depth - 1, just_markless);
|
||||
return is_simple(((Scheme_Let_Value *)obj)->body, depth - 1, just_markless, jitter);
|
||||
}
|
||||
break;
|
||||
case scheme_let_one_type:
|
||||
if (just_markless && depth) {
|
||||
return is_simple(((Scheme_Let_One *)obj)->body, depth - 1, just_markless);
|
||||
return is_simple(((Scheme_Let_One *)obj)->body, depth - 1, just_markless, jitter);
|
||||
}
|
||||
break;
|
||||
case scheme_let_void_type:
|
||||
if (just_markless && depth) {
|
||||
return is_simple(((Scheme_Let_Void *)obj)->body, depth - 1, just_markless);
|
||||
return is_simple(((Scheme_Let_Void *)obj)->body, depth - 1, just_markless, jitter);
|
||||
}
|
||||
break;
|
||||
case scheme_letrec_type:
|
||||
if (just_markless && depth) {
|
||||
return is_simple(((Scheme_Letrec *)obj)->body, depth - 1, just_markless);
|
||||
return is_simple(((Scheme_Letrec *)obj)->body, depth - 1, just_markless, jitter);
|
||||
}
|
||||
break;
|
||||
|
||||
|
|
@ -881,7 +922,7 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless)
|
|||
}
|
||||
break;
|
||||
case scheme_application2_type:
|
||||
if (inlined_unary_prim(((Scheme_App2_Rec *)obj)->rator, obj))
|
||||
if (inlined_unary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter))
|
||||
return 1;
|
||||
else if (just_markless) {
|
||||
return is_noncm(((Scheme_App2_Rec *)obj)->rator);
|
||||
|
|
@ -1283,7 +1324,8 @@ static void *generate_shared_call(int num_rands, mz_jit_state *old_jitter, int m
|
|||
static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands,
|
||||
mz_jit_state *jitter, int is_tail, int multi_ok)
|
||||
{
|
||||
int i, direct_prim = 0, need_non_tail = 0, direct_native = 0, offset;
|
||||
int i, offset;
|
||||
int direct_prim = 0, need_non_tail = 0, direct_native = 0, proc_already_in_place = 0;
|
||||
Scheme_Object *rator, *v;
|
||||
int reorder_ok = 0;
|
||||
START_JIT_DATA();
|
||||
|
|
@ -1316,7 +1358,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
|
|||
|
||||
for (i = 0; i <= num_rands; i++) {
|
||||
v = (alt_rands ? alt_rands[i] : app->args[i]);
|
||||
if (!is_simple(v, INIT_SIMPLE_DEPTH, 1)) {
|
||||
if (!is_simple(v, INIT_SIMPLE_DEPTH, 1, jitter)) {
|
||||
need_non_tail = 1;
|
||||
break;
|
||||
}
|
||||
|
|
@ -1334,7 +1376,16 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
|
|||
|
||||
if (num_rands) {
|
||||
/* Save rator where GC can see it */
|
||||
jit_stxi_p(WORDS_TO_BYTES(num_rands - 1 + offset), JIT_RUNSTACK, JIT_R0);
|
||||
Scheme_Type t;
|
||||
t = SCHEME_TYPE(alt_rands ? alt_rands[1] : app->args[1]);
|
||||
if ((num_rands == 1) && (SAME_TYPE(scheme_local_type, t)
|
||||
|| (t >= _scheme_values_types_))) {
|
||||
/* App of something complex to a local variable. We
|
||||
can move the proc directly to V1. */
|
||||
jit_movr_p(JIT_V1, JIT_R0);
|
||||
proc_already_in_place = 1;
|
||||
} else
|
||||
jit_stxi_p(WORDS_TO_BYTES(num_rands - 1 + offset), JIT_RUNSTACK, JIT_R0);
|
||||
} else {
|
||||
jit_movr_p(JIT_V1, JIT_R0);
|
||||
}
|
||||
|
|
@ -1345,7 +1396,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
|
|||
generate_non_tail(alt_rands ? alt_rands[i+1] : app->args[i+1], jitter, 0, !need_non_tail);
|
||||
RESUME_JIT_DATA();
|
||||
CHECK_LIMIT();
|
||||
if ((i == num_rands - 1) && !direct_prim && !reorder_ok) {
|
||||
if ((i == num_rands - 1) && !direct_prim && !reorder_ok && !proc_already_in_place) {
|
||||
/* Move rator back to register: */
|
||||
jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(i + offset));
|
||||
}
|
||||
|
|
@ -1907,11 +1958,66 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
|
|||
return 1;
|
||||
}
|
||||
|
||||
static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
|
||||
Scheme_Object *rator, Scheme_Object *rand,
|
||||
jit_insn **for_branch, int branch_short)
|
||||
{
|
||||
mz_runstack_skipped(jitter, 1);
|
||||
|
||||
generate(rator, jitter, 0, 0);
|
||||
CHECK_LIMIT();
|
||||
|
||||
if (SAME_TYPE(scheme_local_type, SCHEME_TYPE(rand))) {
|
||||
jit_movr_p(JIT_R1, JIT_R0);
|
||||
generate(rand, jitter, 0, 0);
|
||||
mz_runstack_unskipped(jitter, 1);
|
||||
} else {
|
||||
mz_runstack_unskipped(jitter, 1);
|
||||
|
||||
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
|
||||
mz_runstack_pushed(jitter, 1);
|
||||
jit_str_p(JIT_RUNSTACK, JIT_R0);
|
||||
CHECK_LIMIT();
|
||||
|
||||
generate_non_tail(rand, jitter, 0, 1);
|
||||
CHECK_LIMIT();
|
||||
|
||||
jit_ldr_p(JIT_R1, JIT_RUNSTACK);
|
||||
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
|
||||
mz_runstack_popped(jitter, 1);
|
||||
}
|
||||
|
||||
/* R1 is [potential] predicate/getter, R0 is value */
|
||||
|
||||
if (for_branch) {
|
||||
for_branch[2] = jit_movi_p(JIT_V1, jit_forward());
|
||||
(void)jit_calli(struct_pred_branch_code);
|
||||
} else if (kind == 1) {
|
||||
(void)jit_calli(struct_pred_code);
|
||||
} else {
|
||||
(void)jit_calli(struct_get_code);
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, int is_tail, int multi_ok,
|
||||
jit_insn **for_branch, int branch_short)
|
||||
{
|
||||
Scheme_Object *rator = app->rator;
|
||||
|
||||
{
|
||||
int k;
|
||||
k = inlineable_struct_prim(rator, jitter);
|
||||
if (k == 1) {
|
||||
generate_inlined_struct_op(1, jitter, rator, app->rand, for_branch, branch_short);
|
||||
return 1;
|
||||
} else if ((k == 2) && !for_branch) {
|
||||
generate_inlined_struct_op(2, jitter, rator, app->rand, for_branch, branch_short);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
if (!SCHEME_PRIMP(rator))
|
||||
return 0;
|
||||
|
||||
|
|
@ -2421,7 +2527,7 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter)
|
|||
|
||||
static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int mark_pos_ends)
|
||||
{
|
||||
if (is_simple(obj, INIT_SIMPLE_DEPTH, 0)) {
|
||||
if (is_simple(obj, INIT_SIMPLE_DEPTH, 0, jitter)) {
|
||||
/* Simple; doesn't change the stack or set marks: */
|
||||
int v;
|
||||
FOR_LOG(jitter->log_depth++);
|
||||
|
|
@ -2435,7 +2541,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi
|
|||
START_JIT_DATA();
|
||||
|
||||
/* Might change the stack or marks: */
|
||||
if (is_simple(obj, INIT_SIMPLE_DEPTH, 1)) {
|
||||
if (is_simple(obj, INIT_SIMPLE_DEPTH, 1, jitter)) {
|
||||
need_ends = 0;
|
||||
} else {
|
||||
if (mark_pos_ends)
|
||||
|
|
@ -2547,6 +2653,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
|
|||
}
|
||||
case scheme_local_type:
|
||||
{
|
||||
/* Other parts of thie JIT rely on this code modifying R0, only */
|
||||
int pos;
|
||||
START_JIT_DATA();
|
||||
LOG_IT(("local\n"));
|
||||
|
|
@ -2896,7 +3003,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
|
|||
case scheme_branch_type:
|
||||
{
|
||||
Scheme_Branch_Rec *branch = (Scheme_Branch_Rec *)obj;
|
||||
jit_insn *refs[4], *ref2;
|
||||
jit_insn *refs[5], *ref2;
|
||||
int nsrs, nsrs1, g1, g2, amt;
|
||||
#ifdef MZ_USE_JIT_PPC
|
||||
int then_short_ok, else_short_ok;
|
||||
|
|
@ -2920,6 +3027,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
|
|||
refs[1] = NULL;
|
||||
refs[2] = NULL;
|
||||
refs[3] = NULL;
|
||||
refs[4] = NULL;
|
||||
|
||||
if (!generate_inlined_test(jitter, branch->test, then_short_ok, refs)) {
|
||||
CHECK_LIMIT();
|
||||
|
|
@ -2969,6 +3077,9 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
|
|||
if (refs[3]) {
|
||||
mz_patch_branch(refs[3]);
|
||||
}
|
||||
if (refs[4]) {
|
||||
mz_patch_branch(refs[4]);
|
||||
}
|
||||
__END_SHORT_JUMPS__(then_short_ok);
|
||||
PAUSE_JIT_DATA();
|
||||
LOG_IT(("...else\n"));
|
||||
|
|
@ -3232,6 +3343,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
|
|||
Scheme_Type type = SCHEME_TYPE(obj);
|
||||
START_JIT_DATA();
|
||||
|
||||
/* Other parts of thie JIT rely on this code modifying R0, only */
|
||||
|
||||
LOG_IT(("const\n"));
|
||||
|
||||
/* Avoid compiling closures multiple times: */
|
||||
|
|
@ -3734,12 +3847,12 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
(void)jit_bnei_p(reffail, JIT_R2, scheme_vector_type);
|
||||
jit_ldxi_i(JIT_R2, JIT_R0, &SCHEME_VEC_SIZE(0x0));
|
||||
if (i) {
|
||||
jit_rshi_ul(JIT_R1, JIT_R1, 1);
|
||||
}
|
||||
(void)jit_bler_ul(reffail, JIT_R2, JIT_R1);
|
||||
if (i) {
|
||||
jit_lshi_ul(JIT_V1, JIT_R1, JIT_LOG_WORD_SIZE);
|
||||
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)));
|
||||
} else {
|
||||
(void)jit_bler_ul(reffail, JIT_R2, JIT_R1);
|
||||
}
|
||||
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
|
||||
mz_epilog(JIT_R2);
|
||||
|
|
@ -3796,6 +3909,192 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
__END_SHORT_JUMPS__(1);
|
||||
}
|
||||
|
||||
/* *** struct_{pred,get}[_branch]_code *** */
|
||||
/* R1 is (potential) struct proc, R0 is (potential) struct */
|
||||
/* In branch mode, V1 is target address for false branch */
|
||||
{
|
||||
for (i = 0; i < 3; i++) {
|
||||
void *code, *code_end;
|
||||
int kind, for_branch;
|
||||
jit_insn *ref, *ref2, *refslow, *bref1, *bref2, *bref3, *bref4, *bref5, *bref6;
|
||||
|
||||
code = jit_get_ip().ptr;
|
||||
|
||||
if (!i) {
|
||||
kind = 1;
|
||||
for_branch = 0;
|
||||
struct_pred_code = jit_get_ip().ptr;
|
||||
} else if (i == 1) {
|
||||
kind = 1;
|
||||
for_branch = 1;
|
||||
struct_pred_branch_code = jit_get_ip().ptr;
|
||||
/* Save target address for false branch: */
|
||||
#ifdef MZ_USE_JIT_PPC
|
||||
jit_movr_p(JIT_V(3), JIT_V1);
|
||||
#endif
|
||||
#ifdef MZ_USE_JIT_I386
|
||||
# ifdef _CALL_DARWIN
|
||||
mz_set_local(JIT_V1, JIT_LOCAL3);
|
||||
# else
|
||||
jit_pushr_p(JIT_V1);
|
||||
# endif
|
||||
#endif
|
||||
} else {
|
||||
kind = 2;
|
||||
for_branch = 0;
|
||||
struct_get_code = jit_get_ip().ptr;
|
||||
}
|
||||
|
||||
mz_prolog(JIT_V1);
|
||||
|
||||
__START_SHORT_JUMPS__(1);
|
||||
|
||||
ref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1);
|
||||
CHECK_LIMIT();
|
||||
|
||||
/* Slow path: non-struct proc, or argument type is
|
||||
bad for a getter. */
|
||||
refslow = _jit.x.pc;
|
||||
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
|
||||
JIT_UPDATE_THREAD_RSPTR();
|
||||
jit_str_p(JIT_RUNSTACK, JIT_R0);
|
||||
jit_movi_i(JIT_V1, 1);
|
||||
jit_prepare(3);
|
||||
jit_pusharg_p(JIT_RUNSTACK);
|
||||
jit_pusharg_p(JIT_V1);
|
||||
jit_pusharg_p(JIT_R1);
|
||||
(void)jit_finish(_scheme_apply_from_native);
|
||||
jit_retval(JIT_R0);
|
||||
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
|
||||
JIT_UPDATE_THREAD_RSPTR();
|
||||
if (!for_branch) {
|
||||
mz_epilog(JIT_V1);
|
||||
bref5 = NULL;
|
||||
bref6 = NULL;
|
||||
} else {
|
||||
/* Need to check for true or false. */
|
||||
bref5 = jit_beqi_p(jit_forward(), JIT_R0, scheme_false);
|
||||
bref6 = jit_jmpi(jit_forward());
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
|
||||
/* Continue trying fast path: check proc */
|
||||
mz_patch_branch(ref);
|
||||
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
|
||||
(void)jit_bnei_i(refslow, JIT_R2, scheme_prim_type);
|
||||
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Primitive_Proc *)0x0)->pp.flags);
|
||||
(void)jit_bmci_i(refslow, JIT_R2, ((kind == 1)
|
||||
? SCHEME_PRIM_IS_STRUCT_PRED
|
||||
: SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER));
|
||||
CHECK_LIMIT();
|
||||
/* Check argument: */
|
||||
if (kind == 1) {
|
||||
bref1 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
|
||||
ref2 = jit_beqi_p(jit_forward(), JIT_R2, scheme_structure_type);
|
||||
bref2 = jit_bnei_p(jit_forward(), JIT_R2, scheme_proc_struct_type);
|
||||
} else {
|
||||
(void)jit_bmsi_ul(refslow, JIT_R0, 0x1);
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
|
||||
ref2 = jit_beqi_p(jit_forward(), JIT_R2, scheme_structure_type);
|
||||
(void)jit_bnei_p(refslow, JIT_R2, scheme_structure_type);
|
||||
bref1 = bref2 = NULL;
|
||||
}
|
||||
mz_patch_branch(ref2);
|
||||
CHECK_LIMIT();
|
||||
|
||||
/* Put argument struct type in R2, target struct type in V1 */
|
||||
jit_ldxi_p(JIT_R2, JIT_R0, &((Scheme_Structure *)0x0)->stype);
|
||||
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
if (kind == 2) {
|
||||
jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type);
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
|
||||
jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->name_pos);
|
||||
jit_ldxi_i(JIT_V1, JIT_V1, &((Scheme_Struct_Type *)0x0)->name_pos);
|
||||
/* Now R2 is argument depth, V1 is target depth */
|
||||
if (kind == 1) {
|
||||
bref3 = jit_bltr_i(jit_forward(), JIT_R2, JIT_V1);
|
||||
} else {
|
||||
(void)jit_bltr_i(refslow, JIT_R2, JIT_V1);
|
||||
bref3 = NULL;
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
/* Lookup argument type at target type depth, put it in R2: */
|
||||
jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE);
|
||||
jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types);
|
||||
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Structure *)0x0)->stype);
|
||||
jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2);
|
||||
CHECK_LIMIT();
|
||||
|
||||
/* Re-load target type into V1: */
|
||||
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
if (kind == 2) {
|
||||
jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type);
|
||||
}
|
||||
|
||||
if (kind == 1) {
|
||||
bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1);
|
||||
|
||||
/* True branch: */
|
||||
if (!for_branch) {
|
||||
(void)jit_movi_p(JIT_R0, scheme_true);
|
||||
} else {
|
||||
mz_patch_ucbranch(bref6);
|
||||
#ifdef MZ_USE_JIT_I386
|
||||
# ifndef _CALL_DARWIN
|
||||
jit_popr_p(JIT_V1);
|
||||
# endif
|
||||
#endif
|
||||
}
|
||||
mz_epilog(JIT_V1);
|
||||
|
||||
/* False branch: */
|
||||
mz_patch_branch(bref1);
|
||||
mz_patch_branch(bref2);
|
||||
mz_patch_branch(bref3);
|
||||
mz_patch_branch(bref4);
|
||||
if (for_branch) {
|
||||
mz_patch_branch(bref5);
|
||||
#ifdef MZ_USE_JIT_PPC
|
||||
jit_movr_p(JIT_V1, JIT_V(3));
|
||||
#endif
|
||||
#ifdef MZ_USE_JIT_I386
|
||||
# ifdef _CALL_DARWIN
|
||||
mz_get_local(JIT_V1, JIT_LOCAL3);
|
||||
# else
|
||||
jit_popr_p(JIT_V1);
|
||||
# endif
|
||||
#endif
|
||||
mz_epilog_without_jmp();
|
||||
jit_jmpr(JIT_V1);
|
||||
} else {
|
||||
(void)jit_movi_p(JIT_R0, scheme_false);
|
||||
mz_epilog(JIT_V1);
|
||||
}
|
||||
} else {
|
||||
(void)jit_bner_p(refslow, JIT_R2, JIT_V1);
|
||||
bref4 = NULL;
|
||||
/* Extract field */
|
||||
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field);
|
||||
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
|
||||
jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots);
|
||||
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
|
||||
mz_epilog(JIT_V1);
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
|
||||
__END_SHORT_JUMPS__(1);
|
||||
|
||||
if (jitter->retain_start) {
|
||||
code_end = jit_get_ip().ptr;
|
||||
add_symbol((unsigned long)code, (unsigned long)code_end - 1, scheme_false, 0);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
|
@ -3803,6 +4102,7 @@ typedef struct {
|
|||
Scheme_Closure_Data *data;
|
||||
void *code, *tail_code, *code_end;
|
||||
int max_extra, max_depth;
|
||||
Scheme_Native_Closure *nc;
|
||||
} Generate_Closure_Data;
|
||||
|
||||
static int do_generate_closure(mz_jit_state *jitter, void *_data)
|
||||
|
|
@ -3814,6 +4114,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
|
|||
|
||||
code = jit_get_ip().ptr;
|
||||
|
||||
jitter->nc = gdata->nc;
|
||||
|
||||
generate_function_prolog(jitter, code,
|
||||
/* max_extra_pushed may be wrong the first time around,
|
||||
but it will be right the last time around */
|
||||
|
|
@ -3859,7 +4161,9 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
|
|||
/* Build a list for extra arguments: */
|
||||
mz_patch_branch(ref);
|
||||
mz_patch_branch(ref3);
|
||||
#ifndef JIT_PRECISE_GC
|
||||
if (data->closure_size)
|
||||
#endif
|
||||
mz_pushr_p(JIT_R0);
|
||||
JIT_UPDATE_THREAD_RSPTR();
|
||||
CHECK_LIMIT();
|
||||
|
|
@ -3871,7 +4175,9 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
|
|||
CHECK_LIMIT();
|
||||
(void)mz_finish(scheme_build_list_offset);
|
||||
jit_retval(JIT_V1);
|
||||
#ifndef JIT_PRECISE_GC
|
||||
if (data->closure_size)
|
||||
#endif
|
||||
mz_popr_p(JIT_R0);
|
||||
jit_stxi_p(WORDS_TO_BYTES(cnt), JIT_RUNSTACK, JIT_V1);
|
||||
mz_patch_ucbranch(ref2); /* jump here if we copied and produced null */
|
||||
|
|
@ -3950,8 +4256,9 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static void on_demand_generate_lambda(Scheme_Native_Closure_Data *ndata)
|
||||
static void on_demand_generate_lambda(Scheme_Native_Closure *nc)
|
||||
{
|
||||
Scheme_Native_Closure_Data *ndata = nc->code;
|
||||
Scheme_Closure_Data *data;
|
||||
Generate_Closure_Data gdata;
|
||||
void *code, *tail_code, *arity_code;
|
||||
|
|
@ -3960,6 +4267,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure_Data *ndata)
|
|||
data = ndata->u2.orig_code;
|
||||
|
||||
gdata.data = data;
|
||||
gdata.nc = nc;
|
||||
|
||||
generate_one(NULL, do_generate_closure, &gdata, 1, data->name, ndata);
|
||||
|
||||
|
|
@ -3990,7 +4298,9 @@ static void on_demand_generate_lambda(Scheme_Native_Closure_Data *ndata)
|
|||
} else
|
||||
arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 0);
|
||||
|
||||
max_depth = WORDS_TO_BYTES(data->max_let_depth + gdata.max_extra);
|
||||
/* Add a couple of extra slots to computed let-depth, in case
|
||||
we haven't quite computed right for inlined uses, etc. */
|
||||
max_depth = WORDS_TO_BYTES(data->max_let_depth + gdata.max_extra + 2);
|
||||
|
||||
/* max_let_depth is used for flags by generate_lambda: */
|
||||
if (ndata->max_let_depth & 0x1) {
|
||||
|
|
@ -4016,14 +4326,12 @@ static void on_demand()
|
|||
{
|
||||
/* On runstack: closure (nearest), argc, argv (deepest) */
|
||||
Scheme_Object *c, *argc, **argv;
|
||||
Scheme_Native_Closure_Data *ndata;
|
||||
|
||||
c = MZ_RUNSTACK[0];
|
||||
argc = MZ_RUNSTACK[1];
|
||||
argv = (Scheme_Object **)MZ_RUNSTACK[2];
|
||||
|
||||
ndata = ((Scheme_Native_Closure *)c)->code;
|
||||
on_demand_generate_lambda(ndata);
|
||||
on_demand_generate_lambda((Scheme_Native_Closure *)c);
|
||||
}
|
||||
|
||||
Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, int clear_code_after_jit,
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@
|
|||
;; overwritten.
|
||||
|
||||
(require (lib "list.ss"))
|
||||
(require mzscheme)
|
||||
|
||||
(define mark-cats '("Mn" "Mc" "Me"))
|
||||
(define letter-cats '("Lu" "Ll" "Lt" "Lm" "Lo"))
|
||||
|
|
@ -27,13 +28,13 @@
|
|||
|
||||
(define cases (cons (make-hash-table 'equal) (box 0)))
|
||||
|
||||
(define (indirect t v)
|
||||
(define (indirect t v limit)
|
||||
(let ([r (hash-table-get (car t) v (lambda () #f))])
|
||||
(or r
|
||||
(let ([r (unbox (cdr t))])
|
||||
(set-box! (cdr t) (add1 r))
|
||||
(hash-table-put! (car t) v r)
|
||||
(when (r . > . 255)
|
||||
(when (r . > . limit)
|
||||
(error "too many indirects"))
|
||||
r))))
|
||||
|
||||
|
|
@ -48,11 +49,13 @@
|
|||
1
|
||||
0))))))
|
||||
|
||||
(define (combine-case up down title fold)
|
||||
(indirect cases (list up down title fold)))
|
||||
(define (combine-case up down title fold combining)
|
||||
(indirect cases (list up down title fold combining) 256))
|
||||
|
||||
(define hexes (map char->integer (string->list "0123456789abcdefABCDEF")))
|
||||
|
||||
(define combining-class-ht (make-hash-table))
|
||||
|
||||
;; In principle, adjust this number to tune the result, but
|
||||
;; the macros for accessing the table (in scheme.h) need to
|
||||
;; be updated accordingly.
|
||||
|
|
@ -75,7 +78,8 @@
|
|||
|
||||
(define ccount 0)
|
||||
|
||||
(define (map1 c v v2)
|
||||
(define (map1 c v v2 cc)
|
||||
(hash-table-put! combining-class-ht c cc)
|
||||
(set! ccount (add1 ccount))
|
||||
(if (= c (add1 range-top))
|
||||
(begin
|
||||
|
|
@ -113,12 +117,18 @@
|
|||
(vector-set! vec (bitwise-and c low) v)
|
||||
(vector-set! vec2 (bitwise-and c low) v2)))))
|
||||
|
||||
(define (mapn c from v v2)
|
||||
(define (mapn c from v v2 cc)
|
||||
(if (= c from)
|
||||
(map1 c v v2)
|
||||
(map1 c v v2 cc)
|
||||
(begin
|
||||
(map1 from v v2)
|
||||
(mapn c (add1 from) v v2))))
|
||||
(map1 from v v2 cc)
|
||||
(mapn c (add1 from) v v2 cc))))
|
||||
|
||||
(define (set-compose-initial! c)
|
||||
(let ([top-index (arithmetic-shift c (- low-bits))])
|
||||
(let ([vec (vector-ref top top-index)]
|
||||
[i (bitwise-and c low) ])
|
||||
(vector-set! vec i (bitwise-ior #x8000 (vector-ref vec i))))))
|
||||
|
||||
(define midletters
|
||||
(call-with-input-file "WordBreakProperty.txt"
|
||||
|
|
@ -197,28 +207,81 @@
|
|||
(loop (add1 i)))))))
|
||||
(loop))))))
|
||||
|
||||
(define decomp-ht (make-hash-table))
|
||||
(define k-decomp-ht (make-hash-table))
|
||||
(define compose-initial-ht (make-hash-table))
|
||||
(define compose-map (make-hash-table 'equal))
|
||||
(define do-not-compose-ht (make-hash-table 'equal))
|
||||
|
||||
(with-input-from-file "CompositionExclusions.txt"
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ([l (read-line)])
|
||||
(unless (eof-object? l)
|
||||
(let ([m (regexp-match #rx"^([0-9A-F.]+)" l)])
|
||||
(when m
|
||||
(let ([code (string->number (car m) 16)])
|
||||
(hash-table-put! do-not-compose-ht code #t))))
|
||||
(loop))))))
|
||||
|
||||
(define (extract-decomp decomp code)
|
||||
(if (string=? decomp "")
|
||||
#f
|
||||
(let ([m (regexp-match #rx"^([0-9A-F]+) ?([0-9A-F]*)$" decomp)])
|
||||
(if m
|
||||
;; Canonical decomp
|
||||
(let ([a (string->number (cadr m) 16)]
|
||||
[b (if (string=? "" (caddr m))
|
||||
0
|
||||
(string->number (caddr m) 16))])
|
||||
;; Canonical composition?
|
||||
(when (and (positive? b)
|
||||
(not (hash-table-get do-not-compose-ht
|
||||
code
|
||||
(lambda () #f))))
|
||||
(hash-table-put! compose-initial-ht a #t)
|
||||
(let ([key (bitwise-ior (arithmetic-shift a 16) b)])
|
||||
(when (hash-table-get compose-map key (lambda () #f))
|
||||
(error 'decomp "composition already mapped: ~e" key))
|
||||
(hash-table-put! compose-map key code)))
|
||||
(hash-table-put! decomp-ht code (cons a b))
|
||||
#t)
|
||||
;; Compatibility decomp
|
||||
(let ([seq
|
||||
(let loop ([str (cadr (regexp-match #rx"^<[^>]*> *(.*)$" decomp))])
|
||||
(let ([m (regexp-match #rx"^([0-9A-F]+) *(.*)$" str)])
|
||||
(if m
|
||||
(cons (string->number (cadr m) 16)
|
||||
(loop (caddr m)))
|
||||
null)))])
|
||||
(hash-table-put! k-decomp-ht code seq)
|
||||
#t)))))
|
||||
|
||||
(call-with-input-file "UnicodeData.txt"
|
||||
(lambda (i)
|
||||
(let loop ([prev-code 0])
|
||||
(let ([l (read-line i)])
|
||||
(unless (eof-object? l)
|
||||
(let ([m (regexp-match #rx"^([0-9A-F]+);([^;]*);([^;]*);[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;([^;]*);([^;]*);([^;]*)"
|
||||
(let ([m (regexp-match #rx"^([0-9A-F]+);([^;]*);([^;]*);([^;]*);[^;]*;([^;]*);[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;([^;]*);([^;]*);([^;]*)"
|
||||
l)])
|
||||
(unless m
|
||||
(printf "no match: ~a~n" l))
|
||||
(let ([code (string->number (cadr m) 16)]
|
||||
[name (caddr m)]
|
||||
[cat (cadddr m)]
|
||||
[up (string->number (cadddr (cdr m)) 16)]
|
||||
[down (string->number (cadddr (cddr m)) 16)]
|
||||
[title (string->number (cadddr (cdddr m)) 16)])
|
||||
[combining (string->number (cadddr (cdr m)))]
|
||||
[decomp (cadddr (cddr m))]
|
||||
[up (string->number (cadddr (cdddr m)) 16)]
|
||||
[down (string->number (cadddr (cddddr m)) 16)]
|
||||
[title (string->number (cadddr (cddddr (cdr m))) 16)])
|
||||
(mapn code
|
||||
(if (regexp-match #rx", Last>" name)
|
||||
(add1 prev-code)
|
||||
code)
|
||||
;; The booleans below are in most-siginficant-bit-first order
|
||||
(combine
|
||||
;; Decomposition
|
||||
(extract-decomp decomp code)
|
||||
;; special-casing
|
||||
(or (hash-table-get special-casings code (lambda () #f))
|
||||
(hash-table-get special-case-foldings code (lambda () #f)))
|
||||
|
|
@ -270,14 +333,80 @@
|
|||
(if down (- down code) 0)
|
||||
(if title (- title code) 0)
|
||||
(let ([case-fold (hash-table-get case-foldings code (lambda () #f))])
|
||||
(if case-fold (- case-fold code) 0))))
|
||||
(if case-fold (- case-fold code) 0))
|
||||
combining)
|
||||
;; Combining class - used again to filter initial composes
|
||||
combining)
|
||||
(loop code))))))))
|
||||
|
||||
(hash-table-for-each compose-initial-ht
|
||||
(lambda (k v)
|
||||
;; A canonical decomposition that starts with a non-0 combining
|
||||
;; class is not re-created in a canonical composition. There
|
||||
;; are only two such leading character as of Unicode 4.0:
|
||||
;; U+0308 and U+0F71.
|
||||
(when (zero? (hash-table-get combining-class-ht k))
|
||||
(set-compose-initial! k))))
|
||||
|
||||
;; Remove compositions from compose map that start with
|
||||
;; a character whose combining class is not 0. As of Unicode
|
||||
;; 4.0, there are only four of these: U+0344, U+0F73,
|
||||
;; U+0F75, and U+0F81.
|
||||
(for-each (lambda (k)
|
||||
(let ([a (arithmetic-shift k -16)])
|
||||
(unless (zero? (hash-table-get combining-class-ht a))
|
||||
(hash-table-remove! compose-map k))))
|
||||
(hash-table-map compose-map (lambda (k v) k)))
|
||||
|
||||
(define k-decomp-map-ht (make-hash-table))
|
||||
(define k-decomp-strs-ht (make-hash-table 'equal))
|
||||
(define k-decomp-strs-len 0)
|
||||
(define k-decomp-strs null)
|
||||
|
||||
(define (fold-decomp s)
|
||||
(cond
|
||||
[(empty? s) empty]
|
||||
[(empty? (cdr s))
|
||||
(let ([code (car s)])
|
||||
(let ([v (hash-table-get decomp-ht code (lambda () #f))])
|
||||
(if v
|
||||
(if (zero? (cdr v))
|
||||
(fold-decomp (list (car v)))
|
||||
(fold-decomp (list (car v) (cdr v))))
|
||||
(let ([v (hash-table-get k-decomp-ht code (lambda () #f))])
|
||||
(if v
|
||||
(fold-decomp v)
|
||||
(list code))))))]
|
||||
[else (append (fold-decomp (list (car s)))
|
||||
(fold-decomp (cdr s)))]))
|
||||
|
||||
(for-each
|
||||
(lambda (p)
|
||||
(let* ([code (car p)]
|
||||
[seq (fold-decomp (cdr p))]
|
||||
[pos (hash-table-get k-decomp-strs-ht seq
|
||||
(lambda ()
|
||||
(begin0
|
||||
k-decomp-strs-len
|
||||
(hash-table-put! k-decomp-strs-ht seq
|
||||
k-decomp-strs-len)
|
||||
(set! k-decomp-strs
|
||||
(append (reverse seq) k-decomp-strs))
|
||||
(set! k-decomp-strs-len (+ k-decomp-strs-len
|
||||
(length seq))))))])
|
||||
(hash-table-put! k-decomp-map-ht code (cons pos (length seq)))))
|
||||
;; Sort to keep it deterministic:
|
||||
(quicksort (hash-table-map k-decomp-ht cons)
|
||||
(lambda (a b) (< (car a) (car b)))))
|
||||
|
||||
|
||||
(define vectors (make-hash-table 'equal))
|
||||
(define vectors2 (make-hash-table 'equal))
|
||||
|
||||
(define pos 0)
|
||||
(define pos2 0)
|
||||
(define pos3 0)
|
||||
(define pos4 0)
|
||||
|
||||
(current-output-port (open-output-file "schuchar.inc" 'truncate/replace))
|
||||
|
||||
|
|
@ -313,16 +442,31 @@
|
|||
(printf "/* Generated by mk-uchar.ss */~n~n")
|
||||
|
||||
(printf "/* Character count: ~a */~n" ccount)
|
||||
(printf "/* Table size: ~a */~n~n"
|
||||
(printf "/* Total bytes for all tables: ~a */~n~n"
|
||||
(+ (* (add1 low)
|
||||
(* 2 (add1 (length (hash-table-map vectors cons)))))
|
||||
(* (add1 low)
|
||||
(* 1 (add1 (length (hash-table-map vectors2 cons)))))
|
||||
(* (hash-table-count decomp-ht)
|
||||
8)
|
||||
(* (hash-table-count compose-map)
|
||||
2)
|
||||
(* (hash-table-count k-decomp-map-ht) (+ 4 1 2))
|
||||
(* 2 k-decomp-strs-len)
|
||||
(* 4 4 (unbox (cdr cases)))
|
||||
(* 4 (* 2 hi-count))))
|
||||
|
||||
(printf (string-append
|
||||
"/* Each of the following maps a character to a value\n"
|
||||
" via the scheme_uchar_find() macro in scheme.h. */\n\n"))
|
||||
|
||||
(printf "/* Character properties: */\n")
|
||||
(printf "unsigned short *scheme_uchar_table[~a];~n" hi-count)
|
||||
(printf "unsigned char *scheme_uchar_cases_table[~a];~n~n" hi-count)
|
||||
|
||||
(printf "\n/* Character case mapping as index into scheme_uchar_ups, etc.: */\n")
|
||||
(printf "unsigned char *scheme_uchar_cases_table[~a];~n" hi-count)
|
||||
|
||||
(printf "\n/* The udata... arrays are used by init_uchar_table to fill the above mappings.*/\n\n")
|
||||
|
||||
(define print-row
|
||||
(lambda (vec name pos hex?)
|
||||
|
|
@ -351,10 +495,14 @@
|
|||
(printf "\n")
|
||||
(print-table "char" "_cases" vectors2 pos2 #f)
|
||||
|
||||
(printf "~n/* Case mapping size: ~a */~n" (hash-table-count (car cases)))
|
||||
(printf "~n/* Case mapping size: ~a */\n" (hash-table-count (car cases)))
|
||||
(printf "/* Find an index into the ups, downs, etc. table for a character\n")
|
||||
(printf " by using scheme_uchar_cases_table; then, the value at the index\n")
|
||||
(printf " is relative to the original character (except for combining class,\n")
|
||||
(printf " of course). */\n")
|
||||
|
||||
(define (print-shift t end select name)
|
||||
(printf "~nint scheme_uchar_~a[] = {~n" name)
|
||||
(define (print-shift t end select type name)
|
||||
(printf "~n~a scheme_uchar_~a[] = {~n" type name)
|
||||
(for-each (lambda (p)
|
||||
(printf " ~a~a"
|
||||
(select (car p))
|
||||
|
|
@ -367,10 +515,11 @@
|
|||
(lambda (a b) (< (cdr a) (cdr b)))))
|
||||
(printf " };~n"))
|
||||
|
||||
(print-shift (car cases) (unbox (cdr cases)) car "ups")
|
||||
(print-shift (car cases) (unbox (cdr cases)) cadr "downs")
|
||||
(print-shift (car cases) (unbox (cdr cases)) caddr "titles")
|
||||
(print-shift (car cases) (unbox (cdr cases)) cadddr "folds")
|
||||
(print-shift (car cases) (unbox (cdr cases)) car "int" "ups")
|
||||
(print-shift (car cases) (unbox (cdr cases)) cadr "int" "downs")
|
||||
(print-shift (car cases) (unbox (cdr cases)) caddr "int" "titles")
|
||||
(print-shift (car cases) (unbox (cdr cases)) cadddr "int" "folds")
|
||||
(print-shift (car cases) (unbox (cdr cases)) (lambda (x) (cadddr (cdr x))) "unsigned char" "combining_classes")
|
||||
|
||||
(set! ranges (cons (list range-bottom range-top (range-v . > . -1))
|
||||
ranges))
|
||||
|
|
@ -492,3 +641,117 @@
|
|||
(length (special-casing-folding v))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(let ()
|
||||
(define canon-composes (list->vector
|
||||
(quicksort
|
||||
(hash-table-map compose-map cons)
|
||||
(lambda (a b) (< (car a) (car b))))))
|
||||
(define count (hash-table-count compose-map))
|
||||
|
||||
(define-values (all-composes decomp-vector long-composes)
|
||||
(let ([decomp-pos-ht (make-hash-table)]
|
||||
[counter count]
|
||||
[extra null]
|
||||
[long-counter 0]
|
||||
[longs null])
|
||||
(hash-table-for-each decomp-ht
|
||||
(lambda (k v)
|
||||
;; Use table of composed shorts:
|
||||
(let ([key (+ (arithmetic-shift (car v) 16) (cdr v))])
|
||||
(let ([pos
|
||||
(if (and ((car v) . <= . #xFFFF)
|
||||
((cdr v) . <= . #xFFFF))
|
||||
(if (hash-table-get compose-map key (lambda () #f))
|
||||
;; Find index in comp vector:
|
||||
(let loop ([i 0])
|
||||
(if (= key (car (vector-ref canon-composes i)))
|
||||
i
|
||||
(loop (add1 i))))
|
||||
;; Add to compose table:
|
||||
(begin0
|
||||
counter
|
||||
(set! extra (cons (cons key #f) extra))
|
||||
(set! counter (add1 counter))))
|
||||
;; Use table of long+long sequences:
|
||||
(begin
|
||||
(set! long-counter (add1 long-counter))
|
||||
(set! longs (cons (cdr v) (cons (car v) longs)))
|
||||
(- long-counter)))])
|
||||
(hash-table-put! decomp-pos-ht k pos)))))
|
||||
(values
|
||||
(list->vector (append (vector->list canon-composes)
|
||||
(reverse extra)))
|
||||
(list->vector
|
||||
(quicksort (hash-table-map decomp-pos-ht cons)
|
||||
(lambda (a b) (< (car a) (car b)))))
|
||||
(list->vector (reverse longs)))))
|
||||
|
||||
(printf "\n/* Subset of ~a decompositions used for canonical composition: */\n"
|
||||
(vector-length all-composes))
|
||||
(printf "#define COMPOSE_TABLE_SIZE ~a\n\n" count)
|
||||
|
||||
(let ([print-compose-data
|
||||
(lambda (type suffix which composes count hex? row-len)
|
||||
(printf "static ~a utable_~a[] = {\n"
|
||||
type suffix)
|
||||
(let loop ([i 0])
|
||||
(let ([v (which (vector-ref composes i))])
|
||||
(if (= i (sub1 count))
|
||||
(printf (format " ~a\n};\n" (if hex? "0x~x" "~a")) v)
|
||||
(begin
|
||||
(printf (format " ~a," (if hex? "0x~x" "~a")) v)
|
||||
(when (zero? (modulo (add1 i) row-len))
|
||||
(newline))
|
||||
(loop (add1 i)))))))])
|
||||
(printf "/* utable_compose_pairs contains BMP pairs that form a canonical decomposition.\n")
|
||||
(printf " The first COMPOSE_TABLE_SIZE are also canonical compositions, and they are\n")
|
||||
(printf " sorted, so that a binary search can find the pair; the utable_compose_result\n")
|
||||
(printf " table is in parallel for those COMPOSE_TABLE_SIZE to indicate the composed\n")
|
||||
(printf " characters. Use scheme_needs_maybe_compose() from scheme.h to check whether\n")
|
||||
(printf " a character might start a canonical decomposition. A zero as the second element\n")
|
||||
(printf " of a composition means that it is a singleton decomposition.\n")
|
||||
(printf " The entire utable_compose_pairs table is referenced by utable_decomp_indices\n")
|
||||
(printf " to map characters to canonical decompositions.\n")
|
||||
(printf " None of the [de]composition tables includes Hangol. */\n")
|
||||
(print-compose-data "unsigned int" "compose_pairs" car all-composes (vector-length all-composes) #t 8)
|
||||
(print-compose-data "unsigned int" "compose_result" cdr canon-composes count #t 8)
|
||||
(printf "\n")
|
||||
(printf "/* utable_compose_long_pairs contains a sequence of character pairs where at\n")
|
||||
(printf " least one is outside the BMP, so it doesn't fit in utable_compose_pairs.\n")
|
||||
(printf " Negative values in utable_decomp_indices map to this table; add one to\n")
|
||||
(printf " the mapped index, negate, then multiply by 2 to find the pair. */\n")
|
||||
(print-compose-data "unsigned int" "compose_long_pairs" values long-composes (vector-length long-composes) #t 8)
|
||||
(printf "\n")
|
||||
(printf "/* utable_decomp_keys identifies characters that have a canonical decomposition;\n")
|
||||
(printf " it is sorted, so binary search can be used, but use scheme_needs_decompose()\n")
|
||||
(printf " from scheme.h to first determine whether a character may have a mapping in this table.\n")
|
||||
(printf " (If scheme_needs_decompose(), may instead have a mapping in the kompat table.).\n")
|
||||
(printf " The parallel utable_decomp_indices maps the corresponding character in this table\n")
|
||||
(printf " to a composition pair in either utable_compose_pairs (when the index is positive) or\n")
|
||||
(printf " utable_long_compose_pairs (when the index is negative). */\n")
|
||||
(printf "#define DECOMPOSE_TABLE_SIZE ~a\n\n" (vector-length decomp-vector))
|
||||
(print-compose-data "unsigned int" "decomp_keys" car decomp-vector (vector-length decomp-vector) #t 8)
|
||||
(print-compose-data "short" "decomp_indices" cdr decomp-vector (vector-length decomp-vector) #f 8)
|
||||
|
||||
(let ([k-decomp-vector
|
||||
(list->vector
|
||||
(quicksort (hash-table-map k-decomp-map-ht cons)
|
||||
(lambda (a b) (< (car a) (car b)))))])
|
||||
(printf "\n")
|
||||
(printf "/* utable_kompat_decomp_keys identifies characters that have a compatability decomposition;\n")
|
||||
(printf " it is sorted, and scheme_needs_decompose() is true for every key (but a character\n")
|
||||
(printf " with scheme_needs_decompose(), may instead have a mapping in the canonical table.).\n")
|
||||
(printf " The parallel utable_kompat_decomp_indices maps the corresponding character in this table\n")
|
||||
(printf " to a composition string in kompat_decomp_strs with a length determined by the\n")
|
||||
(printf " utable_kompat_decomp_lens table. The decomposition never contains characters that need\n")
|
||||
(printf " further decomposition. */\n")
|
||||
(printf "\n#define KOMPAT_DECOMPOSE_TABLE_SIZE ~a\n\n" (vector-length k-decomp-vector))
|
||||
(print-compose-data "unsigned int" "kompat_decomp_keys" car k-decomp-vector (vector-length k-decomp-vector) #t 8)
|
||||
(print-compose-data "char" "kompat_decomp_lens" cddr
|
||||
k-decomp-vector (vector-length k-decomp-vector) #f 24)
|
||||
(print-compose-data "short" "kompat_decomp_indices" cadr
|
||||
k-decomp-vector (vector-length k-decomp-vector) #f 16)
|
||||
(let ([l (list->vector (reverse k-decomp-strs))])
|
||||
(print-compose-data "unsigned short" "kompat_decomp_strs" values l (vector-length l) #t 8)))))
|
||||
|
|
|
|||
|
|
@ -231,6 +231,7 @@ MZ_EXTERN int scheme_uchar_ups[];
|
|||
MZ_EXTERN int scheme_uchar_downs[];
|
||||
MZ_EXTERN int scheme_uchar_titles[];
|
||||
MZ_EXTERN int scheme_uchar_folds[];
|
||||
MZ_EXTERN unsigned char scheme_uchar_combining_classes[];
|
||||
|
||||
/*========================================================================*/
|
||||
/* evaluation */
|
||||
|
|
|
|||
|
|
@ -186,6 +186,7 @@ int *scheme_uchar_ups;
|
|||
int *scheme_uchar_downs;
|
||||
int *scheme_uchar_titles;
|
||||
int *scheme_uchar_folds;
|
||||
unsigned char *scheme_uchar_combining_classes;
|
||||
/*========================================================================*/
|
||||
/* evaluation */
|
||||
/*========================================================================*/
|
||||
|
|
|
|||
|
|
@ -110,6 +110,7 @@
|
|||
scheme_extension_table->scheme_uchar_downs = scheme_uchar_downs;
|
||||
scheme_extension_table->scheme_uchar_titles = scheme_uchar_titles;
|
||||
scheme_extension_table->scheme_uchar_folds = scheme_uchar_folds;
|
||||
scheme_extension_table->scheme_uchar_combining_classes = scheme_uchar_combining_classes;
|
||||
scheme_extension_table->scheme_eval = scheme_eval;
|
||||
scheme_extension_table->scheme_eval_multi = scheme_eval_multi;
|
||||
scheme_extension_table->scheme_eval_compiled = scheme_eval_compiled;
|
||||
|
|
|
|||
|
|
@ -110,6 +110,7 @@
|
|||
#define scheme_uchar_downs (scheme_extension_table->scheme_uchar_downs)
|
||||
#define scheme_uchar_titles (scheme_extension_table->scheme_uchar_titles)
|
||||
#define scheme_uchar_folds (scheme_extension_table->scheme_uchar_folds)
|
||||
#define scheme_uchar_combining_classes (scheme_extension_table->scheme_uchar_combining_classes)
|
||||
#define scheme_eval (scheme_extension_table->scheme_eval)
|
||||
#define scheme_eval_multi (scheme_extension_table->scheme_eval_multi)
|
||||
#define scheme_eval_compiled (scheme_extension_table->scheme_eval_compiled)
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
|
||||
#define USE_COMPILED_STARTUP 1
|
||||
|
||||
#define EXPECTED_PRIM_COUNT 855
|
||||
#define EXPECTED_PRIM_COUNT 859
|
||||
|
||||
#ifdef MZSCHEME_SOMETHING_OMITTED
|
||||
# undef USE_COMPILED_STARTUP
|
||||
|
|
|
|||
|
|
@ -469,6 +469,13 @@ typedef struct Scheme_Structure
|
|||
Scheme_Object *slots[1];
|
||||
} Scheme_Structure;
|
||||
|
||||
typedef struct Struct_Proc_Info {
|
||||
MZTAG_IF_REQUIRED
|
||||
Scheme_Struct_Type *struct_type;
|
||||
char *func_name;
|
||||
mzshort field;
|
||||
} Struct_Proc_Info;
|
||||
|
||||
#define SCHEME_STRUCT_TYPE(o) (((Scheme_Structure *)o)->stype)
|
||||
|
||||
#define SCHEME_STRUCT_NUM_SLOTS(o) (SCHEME_STRUCT_TYPE(o)->num_slots)
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -9,6 +9,6 @@
|
|||
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR 301
|
||||
#define MZSCHEME_VERSION_MINOR 7
|
||||
#define MZSCHEME_VERSION_MINOR 8
|
||||
|
||||
#define MZSCHEME_VERSION "301.7" _MZ_SPECIAL_TAG
|
||||
#define MZSCHEME_VERSION "301.8" _MZ_SPECIAL_TAG
|
||||
|
|
|
|||
|
|
@ -192,6 +192,10 @@ static Scheme_Object *string_copy (int argc, Scheme_Object *argv[]);
|
|||
static Scheme_Object *string_copy_bang (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *string_fill (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *string_to_immutable (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *string_normalize_c (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *string_normalize_kc (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *string_normalize_d (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *string_normalize_kd (int argc, Scheme_Object *argv[]);
|
||||
|
||||
static Scheme_Object *make_byte_string (int argc, Scheme_Object *argv[]);
|
||||
static Scheme_Object *byte_string (int argc, Scheme_Object *argv[]);
|
||||
|
|
@ -474,7 +478,26 @@ scheme_init_string (Scheme_Env *env)
|
|||
"string->immutable-string",
|
||||
1, 1),
|
||||
env);
|
||||
|
||||
scheme_add_global_constant("string-normalize-nfc",
|
||||
scheme_make_noncm_prim(string_normalize_c,
|
||||
"string-normalize-nfc",
|
||||
1, 1),
|
||||
env);
|
||||
scheme_add_global_constant("string-normalize-nfkc",
|
||||
scheme_make_noncm_prim(string_normalize_kc,
|
||||
"string-normalize-nfkc",
|
||||
1, 1),
|
||||
env);
|
||||
scheme_add_global_constant("string-normalize-nfd",
|
||||
scheme_make_noncm_prim(string_normalize_d,
|
||||
"string-normalize-nfd",
|
||||
1, 1),
|
||||
env);
|
||||
scheme_add_global_constant("string-normalize-nfkd",
|
||||
scheme_make_noncm_prim(string_normalize_kd,
|
||||
"string-normalize-nfkd",
|
||||
1, 1),
|
||||
env);
|
||||
|
||||
scheme_add_global_constant("string-upcase",
|
||||
scheme_make_noncm_prim(string_upcase,
|
||||
|
|
@ -3350,6 +3373,465 @@ static Scheme_Object *string_foldcase (int argc, Scheme_Object *argv[])
|
|||
return string_recase("string-foldcase", argc, argv, 3);
|
||||
}
|
||||
|
||||
/**********************************************************************/
|
||||
/* normalization */
|
||||
/**********************************************************************/
|
||||
|
||||
#define MZ_JAMO_INITIAL_CONSONANT_START 0x1100
|
||||
#define MZ_JAMO_INITIAL_CONSONANT_COUNT 19
|
||||
#define MZ_JAMO_INITIAL_CONSONANT_END (MZ_JAMO_INITIAL_CONSONANT_START + MZ_JAMO_INITIAL_CONSONANT_COUNT - 1)
|
||||
|
||||
#define MZ_JAMO_VOWEL_START 0x1161
|
||||
#define MZ_JAMO_VOWEL_COUNT 21
|
||||
#define MZ_JAMO_VOWEL_END (MZ_JAMO_VOWEL_START + MZ_JAMO_VOWEL_COUNT - 1)
|
||||
|
||||
/* First in this range is not actually a consonant, but a placeholder for "no consonant" */
|
||||
#define MZ_JAMO_TRAILING_CONSONANT_START 0x11A7
|
||||
#define MZ_JAMO_TRAILING_CONSONANT_COUNT 28
|
||||
#define MZ_JAMO_TRAILING_CONSONANT_END (MZ_JAMO_TRAILING_CONSONANT_START + MZ_JAMO_TRAILING_CONSONANT_COUNT - 1)
|
||||
|
||||
#define MZ_JAMO_SYLLABLE_START 0xAC00
|
||||
#define MZ_JAMO_SYLLABLE_END (MZ_JAMO_SYLLABLE_START + 11171)
|
||||
|
||||
static mzchar get_composition(mzchar a, mzchar b)
|
||||
{
|
||||
unsigned long key = (a << 16) | b;
|
||||
int pos = (COMPOSE_TABLE_SIZE >> 1), new_pos;
|
||||
int below_len = pos;
|
||||
int above_len = (COMPOSE_TABLE_SIZE - pos - 1);
|
||||
|
||||
if (a > 0xFFFF) return 0;
|
||||
|
||||
/* Binary search: */
|
||||
while (key != utable_compose_pairs[pos]) {
|
||||
if (key > utable_compose_pairs[pos]) {
|
||||
if (!above_len)
|
||||
return 0;
|
||||
new_pos = pos + (above_len >> 1) + 1;
|
||||
below_len = (new_pos - pos - 1);
|
||||
above_len = (above_len - below_len - 1);
|
||||
pos = new_pos;
|
||||
} else if (key < utable_compose_pairs[pos]) {
|
||||
if (!below_len)
|
||||
return 0;
|
||||
new_pos = pos - ((below_len >> 1) + 1);
|
||||
above_len = (pos - new_pos - 1);
|
||||
below_len = (below_len - above_len - 1);
|
||||
pos = new_pos;
|
||||
}
|
||||
}
|
||||
|
||||
return utable_compose_result[pos];
|
||||
}
|
||||
|
||||
mzchar get_canon_decomposition(mzchar key, mzchar *b)
|
||||
{
|
||||
int pos = (DECOMPOSE_TABLE_SIZE >> 1), new_pos;
|
||||
int below_len = pos;
|
||||
int above_len = (DECOMPOSE_TABLE_SIZE - pos - 1);
|
||||
|
||||
/* Binary search: */
|
||||
while (key != utable_decomp_keys[pos]) {
|
||||
if (key > utable_decomp_keys[pos]) {
|
||||
if (!above_len)
|
||||
return 0;
|
||||
new_pos = pos + (above_len >> 1) + 1;
|
||||
below_len = (new_pos - pos - 1);
|
||||
above_len = (above_len - below_len - 1);
|
||||
pos = new_pos;
|
||||
} else if (key < utable_decomp_keys[pos]) {
|
||||
if (!below_len)
|
||||
return 0;
|
||||
new_pos = pos - ((below_len >> 1) + 1);
|
||||
above_len = (pos - new_pos - 1);
|
||||
below_len = (below_len - above_len - 1);
|
||||
pos = new_pos;
|
||||
}
|
||||
}
|
||||
|
||||
pos = utable_decomp_indices[pos];
|
||||
if (pos < 0) {
|
||||
pos = -(pos + 1);
|
||||
pos <<= 1;
|
||||
*b = utable_compose_long_pairs[pos + 1];
|
||||
return utable_compose_long_pairs[pos];
|
||||
} else {
|
||||
key = utable_compose_pairs[pos];
|
||||
*b = (key & 0xFFFF);
|
||||
return (key >> 16);
|
||||
}
|
||||
}
|
||||
|
||||
int get_kompat_decomposition(mzchar key, unsigned short **chars)
|
||||
{
|
||||
int pos = (KOMPAT_DECOMPOSE_TABLE_SIZE >> 1), new_pos;
|
||||
int below_len = pos;
|
||||
int above_len = (KOMPAT_DECOMPOSE_TABLE_SIZE - pos - 1);
|
||||
|
||||
/* Binary search: */
|
||||
while (key != utable_kompat_decomp_keys[pos]) {
|
||||
if (key > utable_kompat_decomp_keys[pos]) {
|
||||
if (!above_len)
|
||||
return 0;
|
||||
new_pos = pos + (above_len >> 1) + 1;
|
||||
below_len = (new_pos - pos - 1);
|
||||
above_len = (above_len - below_len - 1);
|
||||
pos = new_pos;
|
||||
} else if (key < utable_kompat_decomp_keys[pos]) {
|
||||
if (!below_len)
|
||||
return 0;
|
||||
new_pos = pos - ((below_len >> 1) + 1);
|
||||
above_len = (pos - new_pos - 1);
|
||||
below_len = (below_len - above_len - 1);
|
||||
pos = new_pos;
|
||||
}
|
||||
}
|
||||
|
||||
*chars = utable_kompat_decomp_strs XFORM_OK_PLUS utable_kompat_decomp_indices[pos];
|
||||
return utable_kompat_decomp_lens[pos];
|
||||
}
|
||||
|
||||
static Scheme_Object *normalize_c(Scheme_Object *o)
|
||||
/* Assumes then given string is in normal form D */
|
||||
{
|
||||
mzchar *s, *s2, tmp, last_c0 = 0;
|
||||
int len, i, j = 0, last_c0_pos = 0, last_cc = 0;
|
||||
|
||||
s = SCHEME_CHAR_STR_VAL(o);
|
||||
len = SCHEME_CHAR_STRLEN_VAL(o);
|
||||
|
||||
s2 = (mzchar *)scheme_malloc_atomic((len + 1) * sizeof(mzchar));
|
||||
memcpy(s2, s, len * sizeof(mzchar));
|
||||
|
||||
for (i = 0; i < len; i++) {
|
||||
if ((i + 1 < len)
|
||||
&& (s2[i] >= MZ_JAMO_INITIAL_CONSONANT_START)
|
||||
&& (s2[i] <= MZ_JAMO_INITIAL_CONSONANT_END)
|
||||
&& (s2[i+1] >= MZ_JAMO_VOWEL_START)
|
||||
&& (s2[i+1] <= MZ_JAMO_VOWEL_END)) {
|
||||
/* Need Hangul composition */
|
||||
if ((i + 2 < len)
|
||||
&& (s2[i+2] > MZ_JAMO_TRAILING_CONSONANT_START)
|
||||
&& (s2[i+2] <= MZ_JAMO_TRAILING_CONSONANT_END)) {
|
||||
/* 3-char composition */
|
||||
tmp = (MZ_JAMO_SYLLABLE_START
|
||||
+ ((s2[i] - MZ_JAMO_INITIAL_CONSONANT_START)
|
||||
* MZ_JAMO_VOWEL_COUNT * MZ_JAMO_TRAILING_CONSONANT_COUNT)
|
||||
+ ((s2[i+1] - MZ_JAMO_VOWEL_START)
|
||||
* MZ_JAMO_TRAILING_CONSONANT_COUNT)
|
||||
+ (s2[i+2] - MZ_JAMO_TRAILING_CONSONANT_START));
|
||||
i += 2;
|
||||
} else {
|
||||
/* 2-char composition */
|
||||
tmp = (MZ_JAMO_SYLLABLE_START
|
||||
+ ((s2[i] - MZ_JAMO_INITIAL_CONSONANT_START)
|
||||
* MZ_JAMO_VOWEL_COUNT * MZ_JAMO_TRAILING_CONSONANT_COUNT)
|
||||
+ ((s2[i+1] - MZ_JAMO_VOWEL_START)
|
||||
* MZ_JAMO_TRAILING_CONSONANT_COUNT));
|
||||
i++;
|
||||
}
|
||||
last_c0 = tmp;
|
||||
last_c0_pos = j;
|
||||
last_cc = 0;
|
||||
s2[j++] = tmp;
|
||||
} else {
|
||||
int cc;
|
||||
|
||||
cc = scheme_combining_class(s2[i]);
|
||||
if (last_c0 && (cc > last_cc))
|
||||
tmp = get_composition(last_c0, s2[i]);
|
||||
else
|
||||
tmp = 0;
|
||||
|
||||
if (tmp) {
|
||||
/* Need to compose */
|
||||
s2[last_c0_pos] = tmp;
|
||||
last_c0 = tmp;
|
||||
} else if (!cc) {
|
||||
/* Reset last_c0... */
|
||||
tmp = s2[i];
|
||||
if (scheme_needs_maybe_compose(tmp)) {
|
||||
last_c0 = tmp;
|
||||
last_c0_pos = j;
|
||||
} else {
|
||||
last_c0 = 0;
|
||||
}
|
||||
last_cc = -1;
|
||||
s2[j++] = tmp;
|
||||
} else {
|
||||
s2[j++] = s2[i];
|
||||
last_cc = cc;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
s2[j] = 0;
|
||||
if (len - j > 16) {
|
||||
s2 = (mzchar *)scheme_malloc_atomic((j + 1) * sizeof(mzchar));
|
||||
memcpy(s2, s, (j + 1) * sizeof(mzchar));
|
||||
s2 = s;
|
||||
}
|
||||
|
||||
return scheme_make_sized_char_string(s2, j, 0);
|
||||
}
|
||||
|
||||
static Scheme_Object *normalize_d(Scheme_Object *o, int kompat)
|
||||
{
|
||||
mzchar *s, tmp, *s2;
|
||||
int len, i, delta, j, swapped;
|
||||
|
||||
s = SCHEME_CHAR_STR_VAL(o);
|
||||
len = SCHEME_CHAR_STRLEN_VAL(o);
|
||||
|
||||
/* Run through string list to predict expansion: */
|
||||
delta = 0;
|
||||
for (i = 0; i < len; i++) {
|
||||
if (scheme_needs_decompose(s[i])) {
|
||||
int klen;
|
||||
mzchar snd;
|
||||
GC_CAN_IGNORE unsigned short *start;
|
||||
|
||||
tmp = s[i];
|
||||
while (scheme_needs_decompose(tmp)) {
|
||||
if (kompat)
|
||||
klen = get_kompat_decomposition(tmp, &start);
|
||||
else
|
||||
klen = 0;
|
||||
if (klen) {
|
||||
delta += (klen - 1);
|
||||
break;
|
||||
} else {
|
||||
tmp = get_canon_decomposition(tmp, &snd);
|
||||
if (tmp) {
|
||||
if (snd) {
|
||||
delta++;
|
||||
if (kompat) {
|
||||
klen = get_kompat_decomposition(snd, &start);
|
||||
if (klen)
|
||||
delta += (klen - 1);
|
||||
}
|
||||
}
|
||||
} else
|
||||
break;
|
||||
}
|
||||
}
|
||||
} else if ((s[i] >= MZ_JAMO_SYLLABLE_START)
|
||||
&& (s[i] <= MZ_JAMO_SYLLABLE_END)) {
|
||||
tmp = s[i];
|
||||
tmp -= MZ_JAMO_SYLLABLE_START;
|
||||
if (tmp % MZ_JAMO_TRAILING_CONSONANT_COUNT)
|
||||
delta += 2;
|
||||
else
|
||||
delta += 1;
|
||||
}
|
||||
}
|
||||
|
||||
s2 = (mzchar *)scheme_malloc_atomic((len + delta + 1) * sizeof(mzchar));
|
||||
|
||||
j = 0;
|
||||
for (i = 0; i < len; i++) {
|
||||
if (scheme_needs_decompose(s[i])) {
|
||||
mzchar snd, tmp2;
|
||||
int snds = 0, klen = 0, k;
|
||||
GC_CAN_IGNORE unsigned short*start;
|
||||
|
||||
tmp = s[i];
|
||||
while (scheme_needs_decompose(tmp)) {
|
||||
if (kompat)
|
||||
klen = get_kompat_decomposition(tmp, &start);
|
||||
else
|
||||
klen = 0;
|
||||
if (klen) {
|
||||
for (k = 0; k < klen; k++) {
|
||||
s2[j++] = start[k];
|
||||
}
|
||||
break;
|
||||
} else {
|
||||
tmp2 = get_canon_decomposition(tmp, &snd);
|
||||
if (tmp2) {
|
||||
tmp = tmp2;
|
||||
if (snd) {
|
||||
if (kompat)
|
||||
klen = get_kompat_decomposition(snd, &start);
|
||||
else
|
||||
klen = 0;
|
||||
if (klen) {
|
||||
snds += klen;
|
||||
for (k = 0; k < klen; k++) {
|
||||
s2[len + delta - snds + k] = start[k];
|
||||
}
|
||||
klen = 0;
|
||||
} else {
|
||||
snds++;
|
||||
s2[len + delta - snds] = snd;
|
||||
}
|
||||
}
|
||||
} else
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (!klen)
|
||||
s2[j++] = tmp;
|
||||
memcpy(s2 + j, s2 + len + delta - snds, snds * sizeof(mzchar));
|
||||
j += snds;
|
||||
} else if ((s[i] >= MZ_JAMO_SYLLABLE_START)
|
||||
&& (s[i] <= MZ_JAMO_SYLLABLE_END)) {
|
||||
int l, v, t;
|
||||
tmp = s[i];
|
||||
tmp -= MZ_JAMO_SYLLABLE_START;
|
||||
l = tmp / (MZ_JAMO_VOWEL_COUNT * MZ_JAMO_TRAILING_CONSONANT_COUNT);
|
||||
v = (tmp % (MZ_JAMO_VOWEL_COUNT * MZ_JAMO_TRAILING_CONSONANT_COUNT)) / MZ_JAMO_TRAILING_CONSONANT_COUNT;
|
||||
t = tmp % MZ_JAMO_TRAILING_CONSONANT_COUNT;
|
||||
s2[j++] = MZ_JAMO_INITIAL_CONSONANT_START + l;
|
||||
s2[j++] = MZ_JAMO_VOWEL_START + v;
|
||||
if (t) {
|
||||
s2[j++] = MZ_JAMO_TRAILING_CONSONANT_START + t;
|
||||
}
|
||||
} else {
|
||||
s2[j++] = s[i];
|
||||
}
|
||||
}
|
||||
s2[j] = 0;
|
||||
len += delta;
|
||||
|
||||
/* Reorder pass: */
|
||||
do {
|
||||
swapped = 0;
|
||||
for (i = 0; i < len; i++) {
|
||||
if ((i + 1 < len)
|
||||
&& scheme_combining_class(s2[i])
|
||||
&& scheme_combining_class(s2[i+1])
|
||||
&& (scheme_combining_class(s2[i+1]) < scheme_combining_class(s2[i]))) {
|
||||
/* Reorder and try again: */
|
||||
tmp = s2[i + 1];
|
||||
s2[i + 1] = s2[i];
|
||||
s2[i] = tmp;
|
||||
i--;
|
||||
swapped = 1;
|
||||
}
|
||||
}
|
||||
} while (swapped);
|
||||
|
||||
return scheme_make_sized_char_string(s2, len, 0);
|
||||
}
|
||||
|
||||
static Scheme_Object *do_string_normalize_c (const char *who, int argc, Scheme_Object *argv[], int kompat)
|
||||
{
|
||||
Scheme_Object *o;
|
||||
mzchar *s, last_c0 = 0, snd;
|
||||
int len, i, last_cc = 0;
|
||||
|
||||
o = argv[0];
|
||||
if (!SCHEME_CHAR_STRINGP(o))
|
||||
scheme_wrong_type(who, "string", 0, argc, argv);
|
||||
|
||||
s = SCHEME_CHAR_STR_VAL(o);
|
||||
len = SCHEME_CHAR_STRLEN_VAL(o);
|
||||
|
||||
for (i = 0; i < len; i++) {
|
||||
if (scheme_needs_decompose(s[i])
|
||||
&& (kompat || get_canon_decomposition(s[i], &snd))) {
|
||||
/* Decomposition may expose a different composition */
|
||||
break;
|
||||
} else if ((i + 1 < len)
|
||||
&& scheme_combining_class(s[i])
|
||||
&& scheme_combining_class(s[i+1])
|
||||
&& (scheme_combining_class(s[i+1]) < scheme_combining_class(s[i]))) {
|
||||
/* Need to reorder */
|
||||
break;
|
||||
} else if ((s[i] >= MZ_JAMO_INITIAL_CONSONANT_START)
|
||||
&& (s[i] <= MZ_JAMO_INITIAL_CONSONANT_END)
|
||||
&& (s[i+1] >= MZ_JAMO_VOWEL_START)
|
||||
&& (s[i+1] <= MZ_JAMO_VOWEL_END)) {
|
||||
/* Need Hangul composition */
|
||||
break;
|
||||
} else if (last_c0
|
||||
&& get_composition(last_c0, s[i])
|
||||
&& (scheme_combining_class(s[i]) > last_cc)) {
|
||||
/* Need to compose */
|
||||
break;
|
||||
} else {
|
||||
int cc;
|
||||
|
||||
cc = scheme_combining_class(s[i]);
|
||||
|
||||
if (!cc) {
|
||||
if (scheme_needs_maybe_compose(s[i]))
|
||||
last_c0 = s[i];
|
||||
else
|
||||
last_c0 = 0;
|
||||
last_cc = -1;
|
||||
} else
|
||||
last_cc = cc;
|
||||
}
|
||||
}
|
||||
|
||||
if (i < len) {
|
||||
o = normalize_c(normalize_d(o, kompat));
|
||||
}
|
||||
|
||||
return o;
|
||||
}
|
||||
|
||||
static Scheme_Object *string_normalize_c (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return do_string_normalize_c("string-normalize-nfc", argc, argv, 0);
|
||||
}
|
||||
|
||||
static Scheme_Object *string_normalize_kc (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return do_string_normalize_c("string-normalize-nfkc", argc, argv, 1);
|
||||
}
|
||||
|
||||
static Scheme_Object *do_string_normalize_d (const char *who, int argc, Scheme_Object *argv[], int kompat)
|
||||
{
|
||||
Scheme_Object *o;
|
||||
mzchar *s;
|
||||
int len, i;
|
||||
|
||||
o = argv[0];
|
||||
if (!SCHEME_CHAR_STRINGP(o))
|
||||
scheme_wrong_type(who, "string", 0, argc, argv);
|
||||
|
||||
s = SCHEME_CHAR_STR_VAL(o);
|
||||
len = SCHEME_CHAR_STRLEN_VAL(o);
|
||||
|
||||
for (i = len; i--; ) {
|
||||
if (scheme_needs_decompose(s[i])) {
|
||||
/* Need to decompose */
|
||||
mzchar snd;
|
||||
if (kompat || get_canon_decomposition(s[i], &snd))
|
||||
break;
|
||||
} else if ((i + 1 < len)
|
||||
&& scheme_combining_class(s[i])
|
||||
&& scheme_combining_class(s[i+1])
|
||||
&& (scheme_combining_class(s[i+1]) < scheme_combining_class(s[i]))) {
|
||||
/* Need to reorder */
|
||||
break;
|
||||
} else if ((s[i] >= MZ_JAMO_SYLLABLE_START)
|
||||
&& (s[i] <= MZ_JAMO_SYLLABLE_END)) {
|
||||
/* Need Hangul decomposition */
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (i >= 0) {
|
||||
o = normalize_d(o, kompat);
|
||||
}
|
||||
|
||||
return o;
|
||||
}
|
||||
|
||||
static Scheme_Object *string_normalize_d (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return do_string_normalize_d("string-normalize-nfd", argc, argv, 0);
|
||||
}
|
||||
|
||||
static Scheme_Object *string_normalize_kd (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return do_string_normalize_d("string-normalize-nfkd", argc, argv, 1);
|
||||
}
|
||||
|
||||
/**********************************************************************/
|
||||
/* strcmps */
|
||||
/**********************************************************************/
|
||||
|
|
|
|||
|
|
@ -39,13 +39,6 @@ typedef enum {
|
|||
SCHEME_GEN_SETTER
|
||||
} Scheme_ProcT;
|
||||
|
||||
typedef struct Struct_Proc_Info {
|
||||
MZTAG_IF_REQUIRED
|
||||
Scheme_Struct_Type *struct_type;
|
||||
char *func_name;
|
||||
mzshort field;
|
||||
} Struct_Proc_Info;
|
||||
|
||||
typedef struct {
|
||||
Scheme_Object so;
|
||||
Scheme_Object *evt;
|
||||
|
|
@ -990,6 +983,46 @@ make_struct_instance(int argc, Scheme_Object **args, Scheme_Object *prim)
|
|||
return scheme_make_struct_instance(SCHEME_PRIM_CLOSURE_ELS(prim)[0], argc, args);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
make_simple_struct_instance(int argc, Scheme_Object **args, Scheme_Object *prim)
|
||||
/* No guards, uninitialized slots, or proc type */
|
||||
{
|
||||
Scheme_Structure *inst;
|
||||
Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
|
||||
int i, c;
|
||||
|
||||
c = stype->num_slots;
|
||||
inst = (Scheme_Structure *)
|
||||
scheme_malloc_tagged(sizeof(Scheme_Structure)
|
||||
+ ((c - 1) * sizeof(Scheme_Object *)));
|
||||
|
||||
inst->so.type = scheme_structure_type;
|
||||
inst->stype = stype;
|
||||
|
||||
for (i = 0; i < argc; i++) {
|
||||
inst->slots[i] = args[i];
|
||||
}
|
||||
|
||||
return (Scheme_Object *)inst;
|
||||
}
|
||||
|
||||
static int is_simple_struct_type(Scheme_Struct_Type *stype)
|
||||
{
|
||||
int p;
|
||||
|
||||
if (stype->proc_attr)
|
||||
return 0;
|
||||
|
||||
for (p = stype->name_pos; p >= 0; p--) {
|
||||
if (stype->parent_types[p]->guard)
|
||||
return 0;
|
||||
if (stype->parent_types[p]->num_slots != stype->parent_types[p]->num_islots)
|
||||
return 0;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
static Scheme_Object *struct_pred(int argc, Scheme_Object **args, Scheme_Object *prim)
|
||||
{
|
||||
if (SCHEME_STRUCTP(args[0])) {
|
||||
|
|
@ -1440,20 +1473,30 @@ int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos)
|
|||
}
|
||||
|
||||
|
||||
#define STRUCT_PROCP(o, t) \
|
||||
(SCHEME_STRUCT_PROCP(o) && (((Scheme_Primitive_Proc *)o)->pp.flags & t))
|
||||
#define STRUCT_mPROCP(o, t, v) \
|
||||
(SCHEME_PRIMP(o) && ((((Scheme_Primitive_Proc *)o)->pp.flags & (t)) == (v)))
|
||||
|
||||
#define STRUCT_PROCP(o, t) STRUCT_mPROCP(o, t, t)
|
||||
|
||||
static Scheme_Object *
|
||||
struct_setter_p(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return (STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_SETTER)
|
||||
return ((STRUCT_mPROCP(argv[0],
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)
|
||||
|| STRUCT_mPROCP(argv[0],
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))
|
||||
? scheme_true : scheme_false);
|
||||
}
|
||||
|
||||
static Scheme_Object *
|
||||
struct_getter_p(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return (STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_GETTER)
|
||||
return ((STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
|
||||
|| STRUCT_mPROCP(argv[0],
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER))
|
||||
? scheme_true : scheme_false);
|
||||
}
|
||||
|
||||
|
|
@ -1467,7 +1510,9 @@ struct_pred_p(int argc, Scheme_Object *argv[])
|
|||
static Scheme_Object *
|
||||
struct_constr_p(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
return (STRUCT_PROCP(argv[0], SCHEME_PRIM_IS_STRUCT_CONSTR)
|
||||
return (STRUCT_mPROCP(argv[0],
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_TYPE_CONSTR)
|
||||
? scheme_true : scheme_false);
|
||||
}
|
||||
|
||||
|
|
@ -1481,10 +1526,11 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
|
|||
char digitbuf[20];
|
||||
int fieldstrlen;
|
||||
|
||||
if (!STRUCT_PROCP(argv[0], (getter
|
||||
? SCHEME_PRIM_IS_STRUCT_GETTER
|
||||
: SCHEME_PRIM_IS_STRUCT_SETTER))
|
||||
|| (((Scheme_Primitive_Proc *)argv[0])->mina == (getter ? 1 : 2))) {
|
||||
if (!STRUCT_mPROCP(argv[0],
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
|
||||
SCHEME_PRIM_IS_STRUCT_OTHER | (getter
|
||||
? SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER
|
||||
: SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))) {
|
||||
scheme_wrong_type(who, (getter
|
||||
? "accessor procedure that requires a field index"
|
||||
: "mutator procedure that requires a field index"),
|
||||
|
|
@ -1946,17 +1992,21 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
|
|||
Scheme_ProcT proc_type, int field_num)
|
||||
{
|
||||
Scheme_Object *p, *a[1];
|
||||
short flags = SCHEME_PRIM_IS_STRUCT_PROC;
|
||||
short flags = 0;
|
||||
|
||||
if (proc_type == SCHEME_CONSTR) {
|
||||
int simple;
|
||||
simple = is_simple_struct_type(struct_type);
|
||||
a[0] = (Scheme_Object *)struct_type;
|
||||
p = scheme_make_folding_prim_closure(make_struct_instance,
|
||||
p = scheme_make_folding_prim_closure((simple
|
||||
? make_simple_struct_instance
|
||||
: make_struct_instance),
|
||||
1, a,
|
||||
func_name,
|
||||
struct_type->num_islots,
|
||||
struct_type->num_islots,
|
||||
0);
|
||||
flags |= SCHEME_PRIM_IS_STRUCT_CONSTR;
|
||||
flags |= SCHEME_PRIM_STRUCT_TYPE_CONSTR | SCHEME_PRIM_IS_STRUCT_OTHER;
|
||||
} else if (proc_type == SCHEME_PRED) {
|
||||
a[0] = (Scheme_Object *)struct_type;
|
||||
p = scheme_make_folding_prim_closure(struct_pred,
|
||||
|
|
@ -1989,7 +2039,10 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
|
|||
1, a,
|
||||
func_name,
|
||||
1 + need_pos, 1 + need_pos, 1);
|
||||
flags |= SCHEME_PRIM_IS_STRUCT_GETTER;
|
||||
if (need_pos)
|
||||
flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER | SCHEME_PRIM_IS_STRUCT_OTHER;
|
||||
else
|
||||
flags |= SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER;
|
||||
/* Cache the accessor only if `struct_info' is used.
|
||||
This avoids keep lots of useless accessors.
|
||||
if (need_pos) struct_type->accessor = p; */
|
||||
|
|
@ -1998,7 +2051,10 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
|
|||
1, a,
|
||||
func_name,
|
||||
2 + need_pos, 2 + need_pos, 0);
|
||||
flags |= SCHEME_PRIM_IS_STRUCT_SETTER;
|
||||
if (need_pos)
|
||||
flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER | SCHEME_PRIM_IS_STRUCT_OTHER;
|
||||
else
|
||||
flags |= SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER | SCHEME_PRIM_IS_STRUCT_OTHER;
|
||||
/* See note above:
|
||||
if (need_pos) struct_type->mutator = p; */
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user