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

301.8

Browse Source 
svn: r2336
This commit is contained in:
Matthew Flatt 2006-03-01 01:10:47 +00:00
parent 0e1e6b18e4
commit 6aa901de18
21 changed files with 6429 additions and 2656 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/mzscheme/gc2/Makefile.in
View File

@ -298,7 +298,7 @@ EXTRA_OBJS_L = ../src/gmp.@LTO@ @FOREIGN_OBJSLIB_IF_USED@
$(RANLIB) ../libmzscheme3m.@LIBSFX@ $(RANLIB) ../libmzscheme3m.@LIBSFX@
../mzscheme3m@NOT_OSX@: main.@LTO@ ../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 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 ln -s Versions/$(FWVERSION)_3m/PLT_MzScheme PLT_MzScheme.framework/PLT_MzScheme
../mzscheme3m@OSX@: $(MZFWMMM) main.@LTO@ ../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 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 cp PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme ../PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme

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

@ -102,6 +102,7 @@ scheme_uchar_ups
scheme_uchar_downs scheme_uchar_downs
scheme_uchar_titles scheme_uchar_titles
scheme_uchar_folds scheme_uchar_folds
scheme_uchar_combining_classes
scheme_eval scheme_eval
scheme_eval_multi scheme_eval_multi
scheme_eval_compiled scheme_eval_compiled

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

@ -102,6 +102,7 @@ scheme_uchar_ups
scheme_uchar_downs scheme_uchar_downs
scheme_uchar_titles scheme_uchar_titles
scheme_uchar_folds scheme_uchar_folds
scheme_uchar_combining_classes
scheme_eval scheme_eval
scheme_eval_multi scheme_eval_multi
scheme_eval_compiled scheme_eval_compiled

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

@ -104,6 +104,7 @@ EXPORTS
scheme_uchar_downs scheme_uchar_downs
scheme_uchar_titles scheme_uchar_titles
scheme_uchar_folds scheme_uchar_folds
scheme_uchar_combining_classes
scheme_eval scheme_eval
scheme_eval_multi scheme_eval_multi
scheme_eval_compiled scheme_eval_compiled

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

@ -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_isgraphic(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x800)
#define scheme_iscaseignorable(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1000) #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_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) #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_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_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_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 */ /* procedure values */
@ -563,12 +566,11 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
Do not use them directly. */ Do not use them directly. */
#define SCHEME_PRIM_IS_FOLDING 1 #define SCHEME_PRIM_IS_FOLDING 1
#define SCHEME_PRIM_IS_PRIMITIVE 2 #define SCHEME_PRIM_IS_PRIMITIVE 2
#define SCHEME_PRIM_IS_STRUCT_PROC 4 #define SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER 4
#define SCHEME_PRIM_IS_STRUCT_SETTER 8 #define SCHEME_PRIM_IS_STRUCT_PRED 8
#define SCHEME_PRIM_IS_PARAMETER 16 #define SCHEME_PRIM_IS_PARAMETER 16
#define SCHEME_PRIM_IS_STRUCT_GETTER 32 #define SCHEME_PRIM_IS_STRUCT_OTHER 32
#define SCHEME_PRIM_IS_STRUCT_PRED 64 #define SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK (64 | 128)
#define SCHEME_PRIM_IS_STRUCT_CONSTR 128
#define SCHEME_PRIM_IS_MULTI_RESULT 256 #define SCHEME_PRIM_IS_MULTI_RESULT 256
#define SCHEME_PRIM_IS_BINARY_INLINED 512 #define SCHEME_PRIM_IS_BINARY_INLINED 512
#define SCHEME_PRIM_IS_USER_PARAMETER 1024 #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_NONCM 8192
#define SCHEME_PRIM_IS_UNARY_INLINED 16384 #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) #define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
typedef struct Scheme_Object *(Scheme_Prim)(int argc, Scheme_Object *argv[]); typedef struct Scheme_Object *(Scheme_Prim)(int argc, Scheme_Object *argv[]);

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

File diff suppressed because it is too large Load Diff

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

@ -3372,8 +3372,12 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
result = SCHEME_STX_CDR(result); result = SCHEME_STX_CDR(result);
result = scheme_flatten_begin(first, result); result = scheme_flatten_begin(first, result);
goto define_try_again; goto define_try_again;
} else } else {
/* Keep partially expanded `first': */
result = SCHEME_STX_CDR(result);
result = scheme_make_pair(first, result);
break; break;
}
} }
} else } else
break; break;

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

@ -793,6 +793,9 @@ scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info)
/* Then the pointer to globals, if any: */ /* Then the pointer to globals, if any: */
offset = cl->base_closure_size; offset = cl->base_closure_size;
if (cl->has_tl) { 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; int li;
li = scheme_resolve_toplevel_pos(info); li = scheme_resolve_toplevel_pos(info);
closure_map[offset] = li; closure_map[offset] = li;

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

@ -74,6 +74,9 @@ static void *on_demand_jit_code;
static void *on_demand_jit_arity_code; static void *on_demand_jit_arity_code;
static void *get_stack_pointer_code; static void *get_stack_pointer_code;
static void *stack_cache_pop_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 { typedef struct {
MZTAG_IF_REQUIRED MZTAG_IF_REQUIRED
@ -94,6 +97,7 @@ typedef struct {
int need_set_rs; int need_set_rs;
void **retain_start; void **retain_start;
int log_depth; int log_depth;
Scheme_Native_Closure *nc;
} mz_jit_state; } mz_jit_state;
typedef int (*Native_Check_Arity_Proc)(Scheme_Object *o, int argc); 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_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_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(x) (mz_get_local_p(x, JIT_LOCAL2), jit_jmpr(x))
# define mz_epilog_without_jmp() /* empty */
# define mz_push_locals() /* empty */ # define mz_push_locals() /* empty */
# define mz_pop_locals() /* empty */ # define mz_pop_locals() /* empty */
#else #else
# define JIT_LOCAL1 -16 # define JIT_LOCAL1 -16
# define JIT_LOCAL2 -20 # 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_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_get_local_p(x, l) jit_ldxi_p((x), JIT_FP, (l))
# define mz_patch_branch_at(a, v) jit_patch_at(a, v) # 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. /* Maintain 4-byte stack alignment.
Built-in prolog pushes 3 words in local frame already. */ Built-in prolog pushes 3 words in local frame already. */
# define mz_prolog(x) (SUBLir(3 * JIT_WORD_SIZE, JIT_SP)) # 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 LOCAL_FRAME_SIZE 3
# define JIT_LOCAL3 -24
# else # else
# define mz_prolog(x) /* empty */ # define mz_prolog(x) /* empty */
# define mz_epilog(x) RET_() # define mz_epilog(x) RET_()
# define mz_epilog_without_jmp() ADDLir(JIT_WORD_SIZE, JIT_SP)
# define LOCAL_FRAME_SIZE 2 # define LOCAL_FRAME_SIZE 2
# define JIT_LOCAL3 JIT_LOCAL2
# endif # endif
# define mz_push_locals() SUBLir((LOCAL_FRAME_SIZE << JIT_LOG_WORD_SIZE), JIT_SP) # 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) # 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 #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) /* GLOBAL ASSUMPTION: we assume that globals are the last thing
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_UNARY_INLINED)); 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) 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 #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 --- /* 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. 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: case scheme_branch_type:
if (depth) { if (depth) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)obj; Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)obj;
return (is_simple(b->tbranch, depth - 1, just_markless) return (is_simple(b->tbranch, depth - 1, just_markless, jitter)
&& is_simple(b->fbranch, depth - 1, just_markless)); && is_simple(b->fbranch, depth - 1, just_markless, jitter));
} }
break; break;
case scheme_let_value_type: case scheme_let_value_type:
if (depth) { 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; break;
case scheme_let_one_type: case scheme_let_one_type:
if (just_markless && depth) { 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; break;
case scheme_let_void_type: case scheme_let_void_type:
if (just_markless && depth) { 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; break;
case scheme_letrec_type: case scheme_letrec_type:
if (just_markless && depth) { 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; break;
@ -881,7 +922,7 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless)
} }
break; break;
case scheme_application2_type: 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; return 1;
else if (just_markless) { else if (just_markless) {
return is_noncm(((Scheme_App2_Rec *)obj)->rator); 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, 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) 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; Scheme_Object *rator, *v;
int reorder_ok = 0; int reorder_ok = 0;
START_JIT_DATA(); 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++) { for (i = 0; i <= num_rands; i++) {
v = (alt_rands ? alt_rands[i] : app->args[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; need_non_tail = 1;
break; break;
} }
@ -1334,7 +1376,16 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
if (num_rands) { if (num_rands) {
/* Save rator where GC can see it */ /* 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 { } else {
jit_movr_p(JIT_V1, JIT_R0); 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); generate_non_tail(alt_rands ? alt_rands[i+1] : app->args[i+1], jitter, 0, !need_non_tail);
RESUME_JIT_DATA(); RESUME_JIT_DATA();
CHECK_LIMIT(); 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: */ /* Move rator back to register: */
jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(i + offset)); 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; 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, 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) jit_insn **for_branch, int branch_short)
{ {
Scheme_Object *rator = app->rator; 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)) if (!SCHEME_PRIMP(rator))
return 0; 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) 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: */ /* Simple; doesn't change the stack or set marks: */
int v; int v;
FOR_LOG(jitter->log_depth++); 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(); START_JIT_DATA();
/* Might change the stack or marks: */ /* 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; need_ends = 0;
} else { } else {
if (mark_pos_ends) 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: case scheme_local_type:
{ {
/* Other parts of thie JIT rely on this code modifying R0, only */
int pos; int pos;
START_JIT_DATA(); START_JIT_DATA();
LOG_IT(("local\n")); 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: case scheme_branch_type:
{ {
Scheme_Branch_Rec *branch = (Scheme_Branch_Rec *)obj; Scheme_Branch_Rec *branch = (Scheme_Branch_Rec *)obj;
jit_insn *refs[4], *ref2; jit_insn *refs[5], *ref2;
int nsrs, nsrs1, g1, g2, amt; int nsrs, nsrs1, g1, g2, amt;
#ifdef MZ_USE_JIT_PPC #ifdef MZ_USE_JIT_PPC
int then_short_ok, else_short_ok; 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[1] = NULL;
refs[2] = NULL; refs[2] = NULL;
refs[3] = NULL; refs[3] = NULL;
refs[4] = NULL;
if (!generate_inlined_test(jitter, branch->test, then_short_ok, refs)) { if (!generate_inlined_test(jitter, branch->test, then_short_ok, refs)) {
CHECK_LIMIT(); CHECK_LIMIT();
@ -2969,6 +3077,9 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
if (refs[3]) { if (refs[3]) {
mz_patch_branch(refs[3]); mz_patch_branch(refs[3]);
} }
if (refs[4]) {
mz_patch_branch(refs[4]);
}
__END_SHORT_JUMPS__(then_short_ok); __END_SHORT_JUMPS__(then_short_ok);
PAUSE_JIT_DATA(); PAUSE_JIT_DATA();
LOG_IT(("...else\n")); 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); Scheme_Type type = SCHEME_TYPE(obj);
START_JIT_DATA(); START_JIT_DATA();
/* Other parts of thie JIT rely on this code modifying R0, only */
LOG_IT(("const\n")); LOG_IT(("const\n"));
/* Avoid compiling closures multiple times: */ /* 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); (void)jit_bnei_p(reffail, JIT_R2, scheme_vector_type);
jit_ldxi_i(JIT_R2, JIT_R0, &SCHEME_VEC_SIZE(0x0)); jit_ldxi_i(JIT_R2, JIT_R0, &SCHEME_VEC_SIZE(0x0));
if (i) { if (i) {
jit_rshi_ul(JIT_R1, JIT_R1, 1); jit_rshi_ul(JIT_V1, JIT_R1, 1);
} (void)jit_bler_ul(reffail, JIT_R2, JIT_V1);
(void)jit_bler_ul(reffail, JIT_R2, JIT_R1); jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
if (i) {
jit_lshi_ul(JIT_V1, JIT_R1, JIT_LOG_WORD_SIZE);
jit_addi_p(JIT_V1, JIT_V1, ((int)&SCHEME_VEC_ELS(0x0))); 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); jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
mz_epilog(JIT_R2); mz_epilog(JIT_R2);
@ -3796,6 +3909,192 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
__END_SHORT_JUMPS__(1); __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; return 1;
} }
@ -3803,6 +4102,7 @@ typedef struct {
Scheme_Closure_Data *data; Scheme_Closure_Data *data;
void *code, *tail_code, *code_end; void *code, *tail_code, *code_end;
int max_extra, max_depth; int max_extra, max_depth;
Scheme_Native_Closure *nc;
} Generate_Closure_Data; } Generate_Closure_Data;
static int do_generate_closure(mz_jit_state *jitter, void *_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; code = jit_get_ip().ptr;
jitter->nc = gdata->nc;
generate_function_prolog(jitter, code, generate_function_prolog(jitter, code,
/* max_extra_pushed may be wrong the first time around, /* max_extra_pushed may be wrong the first time around,
but it will be right the last 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: */ /* Build a list for extra arguments: */
mz_patch_branch(ref); mz_patch_branch(ref);
mz_patch_branch(ref3); mz_patch_branch(ref3);
#ifndef JIT_PRECISE_GC
if (data->closure_size) if (data->closure_size)
#endif
mz_pushr_p(JIT_R0); mz_pushr_p(JIT_R0);
JIT_UPDATE_THREAD_RSPTR(); JIT_UPDATE_THREAD_RSPTR();
CHECK_LIMIT(); CHECK_LIMIT();
@ -3871,7 +4175,9 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
CHECK_LIMIT(); CHECK_LIMIT();
(void)mz_finish(scheme_build_list_offset); (void)mz_finish(scheme_build_list_offset);
jit_retval(JIT_V1); jit_retval(JIT_V1);
#ifndef JIT_PRECISE_GC
if (data->closure_size) if (data->closure_size)
#endif
mz_popr_p(JIT_R0); mz_popr_p(JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(cnt), JIT_RUNSTACK, JIT_V1); jit_stxi_p(WORDS_TO_BYTES(cnt), JIT_RUNSTACK, JIT_V1);
mz_patch_ucbranch(ref2); /* jump here if we copied and produced null */ 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; 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; Scheme_Closure_Data *data;
Generate_Closure_Data gdata; Generate_Closure_Data gdata;
void *code, *tail_code, *arity_code; 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; data = ndata->u2.orig_code;
gdata.data = data; gdata.data = data;
gdata.nc = nc;
generate_one(NULL, do_generate_closure, &gdata, 1, data->name, ndata); 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 } else
arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 0); 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: */ /* max_let_depth is used for flags by generate_lambda: */
if (ndata->max_let_depth & 0x1) { if (ndata->max_let_depth & 0x1) {
@ -4016,14 +4326,12 @@ static void on_demand()
{ {
/* On runstack: closure (nearest), argc, argv (deepest) */ /* On runstack: closure (nearest), argc, argv (deepest) */
Scheme_Object *c, *argc, **argv; Scheme_Object *c, *argc, **argv;
Scheme_Native_Closure_Data *ndata;
c = MZ_RUNSTACK[0]; c = MZ_RUNSTACK[0];
argc = MZ_RUNSTACK[1]; argc = MZ_RUNSTACK[1];
argv = (Scheme_Object **)MZ_RUNSTACK[2]; argv = (Scheme_Object **)MZ_RUNSTACK[2];
ndata = ((Scheme_Native_Closure *)c)->code; on_demand_generate_lambda((Scheme_Native_Closure *)c);
on_demand_generate_lambda(ndata);
} }
Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, int clear_code_after_jit, Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, int clear_code_after_jit,

309
src/mzscheme/src/mk-uchar.ss
View File

@ -12,6 +12,7 @@
;; overwritten. ;; overwritten.
(require (lib "list.ss")) (require (lib "list.ss"))
(require mzscheme)
(define mark-cats '("Mn" "Mc" "Me")) (define mark-cats '("Mn" "Mc" "Me"))
(define letter-cats '("Lu" "Ll" "Lt" "Lm" "Lo")) (define letter-cats '("Lu" "Ll" "Lt" "Lm" "Lo"))
@ -27,13 +28,13 @@
(define cases (cons (make-hash-table 'equal) (box 0))) (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))]) (let ([r (hash-table-get (car t) v (lambda () #f))])
(or r (or r
(let ([r (unbox (cdr t))]) (let ([r (unbox (cdr t))])
(set-box! (cdr t) (add1 r)) (set-box! (cdr t) (add1 r))
(hash-table-put! (car t) v r) (hash-table-put! (car t) v r)
(when (r . > . 255) (when (r . > . limit)
(error "too many indirects")) (error "too many indirects"))
r)))) r))))
@ -48,11 +49,13 @@
1 1
0)))))) 0))))))
(define (combine-case up down title fold) (define (combine-case up down title fold combining)
(indirect cases (list up down title fold))) (indirect cases (list up down title fold combining) 256))
(define hexes (map char->integer (string->list "0123456789abcdefABCDEF"))) (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 ;; In principle, adjust this number to tune the result, but
;; the macros for accessing the table (in scheme.h) need to ;; the macros for accessing the table (in scheme.h) need to
;; be updated accordingly. ;; be updated accordingly.
@ -75,7 +78,8 @@
(define ccount 0) (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)) (set! ccount (add1 ccount))
(if (= c (add1 range-top)) (if (= c (add1 range-top))
(begin (begin
@ -113,12 +117,18 @@
(vector-set! vec (bitwise-and c low) v) (vector-set! vec (bitwise-and c low) v)
(vector-set! vec2 (bitwise-and c low) v2))))) (vector-set! vec2 (bitwise-and c low) v2)))))
(define (mapn c from v v2) (define (mapn c from v v2 cc)
(if (= c from) (if (= c from)
(map1 c v v2) (map1 c v v2 cc)
(begin (begin
(map1 from v v2) (map1 from v v2 cc)
(mapn c (add1 from) v v2)))) (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 (define midletters
(call-with-input-file "WordBreakProperty.txt" (call-with-input-file "WordBreakProperty.txt"
@ -197,28 +207,81 @@
(loop (add1 i))))))) (loop (add1 i)))))))
(loop)))))) (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" (call-with-input-file "UnicodeData.txt"
(lambda (i) (lambda (i)
(let loop ([prev-code 0]) (let loop ([prev-code 0])
(let ([l (read-line i)]) (let ([l (read-line i)])
(unless (eof-object? l) (unless (eof-object? l)
(let ([m (regexp-match #rx"^([0-9A-F]+);([^;]*);([^;]*);[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;([^;]*);([^;]*);([^;]*)" (let ([m (regexp-match #rx"^([0-9A-F]+);([^;]*);([^;]*);([^;]*);[^;]*;([^;]*);[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;[^;]*;([^;]*);([^;]*);([^;]*)"
l)]) l)])
(unless m (unless m
(printf "no match: ~a~n" l)) (printf "no match: ~a~n" l))
(let ([code (string->number (cadr m) 16)] (let ([code (string->number (cadr m) 16)]
[name (caddr m)] [name (caddr m)]
[cat (cadddr m)] [cat (cadddr m)]
[up (string->number (cadddr (cdr m)) 16)] [combining (string->number (cadddr (cdr m)))]
[down (string->number (cadddr (cddr m)) 16)] [decomp (cadddr (cddr m))]
[title (string->number (cadddr (cdddr m)) 16)]) [up (string->number (cadddr (cdddr m)) 16)]
[down (string->number (cadddr (cddddr m)) 16)]
[title (string->number (cadddr (cddddr (cdr m))) 16)])
(mapn code (mapn code
(if (regexp-match #rx", Last>" name) (if (regexp-match #rx", Last>" name)
(add1 prev-code) (add1 prev-code)
code) code)
;; The booleans below are in most-siginficant-bit-first order ;; The booleans below are in most-siginficant-bit-first order
(combine (combine
;; Decomposition
(extract-decomp decomp code)
;; special-casing ;; special-casing
(or (hash-table-get special-casings code (lambda () #f)) (or (hash-table-get special-casings code (lambda () #f))
(hash-table-get special-case-foldings code (lambda () #f))) (hash-table-get special-case-foldings code (lambda () #f)))
@ -270,14 +333,80 @@
(if down (- down code) 0) (if down (- down code) 0)
(if title (- title code) 0) (if title (- title code) 0)
(let ([case-fold (hash-table-get case-foldings code (lambda () #f))]) (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)))))))) (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 vectors (make-hash-table 'equal))
(define vectors2 (make-hash-table 'equal)) (define vectors2 (make-hash-table 'equal))
(define pos 0) (define pos 0)
(define pos2 0) (define pos2 0)
(define pos3 0)
(define pos4 0)
(current-output-port (open-output-file "schuchar.inc" 'truncate/replace)) (current-output-port (open-output-file "schuchar.inc" 'truncate/replace))
@ -313,16 +442,31 @@
(printf "/* Generated by mk-uchar.ss */~n~n") (printf "/* Generated by mk-uchar.ss */~n~n")
(printf "/* Character count: ~a */~n" ccount) (printf "/* Character count: ~a */~n" ccount)
(printf "/* Table size: ~a */~n~n" (printf "/* Total bytes for all tables: ~a */~n~n"
(+ (* (add1 low) (+ (* (add1 low)
(* 2 (add1 (length (hash-table-map vectors cons))))) (* 2 (add1 (length (hash-table-map vectors cons)))))
(* (add1 low) (* (add1 low)
(* 1 (add1 (length (hash-table-map vectors2 cons))))) (* 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 4 (unbox (cdr cases)))
(* 4 (* 2 hi-count)))) (* 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 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 (define print-row
(lambda (vec name pos hex?) (lambda (vec name pos hex?)
@ -351,10 +495,14 @@
(printf "\n") (printf "\n")
(print-table "char" "_cases" vectors2 pos2 #f) (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) (define (print-shift t end select type name)
(printf "~nint scheme_uchar_~a[] = {~n" name) (printf "~n~a scheme_uchar_~a[] = {~n" type name)
(for-each (lambda (p) (for-each (lambda (p)
(printf " ~a~a" (printf " ~a~a"
(select (car p)) (select (car p))
@ -367,10 +515,11 @@
(lambda (a b) (< (cdr a) (cdr b))))) (lambda (a b) (< (cdr a) (cdr b)))))
(printf " };~n")) (printf " };~n"))
(print-shift (car cases) (unbox (cdr cases)) car "ups") (print-shift (car cases) (unbox (cdr cases)) car "int" "ups")
(print-shift (car cases) (unbox (cdr cases)) cadr "downs") (print-shift (car cases) (unbox (cdr cases)) cadr "int" "downs")
(print-shift (car cases) (unbox (cdr cases)) caddr "titles") (print-shift (car cases) (unbox (cdr cases)) caddr "int" "titles")
(print-shift (car cases) (unbox (cdr cases)) cadddr "folds") (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)) (set! ranges (cons (list range-bottom range-top (range-v . > . -1))
ranges)) ranges))
@ -492,3 +641,117 @@
(length (special-casing-folding v)))))) (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)))))

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

@ -231,6 +231,7 @@ MZ_EXTERN int scheme_uchar_ups[];
MZ_EXTERN int scheme_uchar_downs[]; MZ_EXTERN int scheme_uchar_downs[];
MZ_EXTERN int scheme_uchar_titles[]; MZ_EXTERN int scheme_uchar_titles[];
MZ_EXTERN int scheme_uchar_folds[]; MZ_EXTERN int scheme_uchar_folds[];
MZ_EXTERN unsigned char scheme_uchar_combining_classes[];
/*========================================================================*/ /*========================================================================*/
/* evaluation */ /* evaluation */

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

@ -186,6 +186,7 @@ int *scheme_uchar_ups;
int *scheme_uchar_downs; int *scheme_uchar_downs;
int *scheme_uchar_titles; int *scheme_uchar_titles;
int *scheme_uchar_folds; int *scheme_uchar_folds;
unsigned char *scheme_uchar_combining_classes;
/*========================================================================*/ /*========================================================================*/
/* evaluation */ /* evaluation */
/*========================================================================*/ /*========================================================================*/

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

@ -110,6 +110,7 @@
scheme_extension_table->scheme_uchar_downs = scheme_uchar_downs; scheme_extension_table->scheme_uchar_downs = scheme_uchar_downs;
scheme_extension_table->scheme_uchar_titles = scheme_uchar_titles; scheme_extension_table->scheme_uchar_titles = scheme_uchar_titles;
scheme_extension_table->scheme_uchar_folds = scheme_uchar_folds; 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 = scheme_eval;
scheme_extension_table->scheme_eval_multi = scheme_eval_multi; scheme_extension_table->scheme_eval_multi = scheme_eval_multi;
scheme_extension_table->scheme_eval_compiled = scheme_eval_compiled; scheme_extension_table->scheme_eval_compiled = scheme_eval_compiled;

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

@ -110,6 +110,7 @@
#define scheme_uchar_downs (scheme_extension_table->scheme_uchar_downs) #define scheme_uchar_downs (scheme_extension_table->scheme_uchar_downs)
#define scheme_uchar_titles (scheme_extension_table->scheme_uchar_titles) #define scheme_uchar_titles (scheme_extension_table->scheme_uchar_titles)
#define scheme_uchar_folds (scheme_extension_table->scheme_uchar_folds) #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 (scheme_extension_table->scheme_eval)
#define scheme_eval_multi (scheme_extension_table->scheme_eval_multi) #define scheme_eval_multi (scheme_extension_table->scheme_eval_multi)
#define scheme_eval_compiled (scheme_extension_table->scheme_eval_compiled) #define scheme_eval_compiled (scheme_extension_table->scheme_eval_compiled)

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 855 #define EXPECTED_PRIM_COUNT 859
#ifdef MZSCHEME_SOMETHING_OMITTED #ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP # undef USE_COMPILED_STARTUP

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

@ -469,6 +469,13 @@ typedef struct Scheme_Structure
Scheme_Object *slots[1]; Scheme_Object *slots[1];
} Scheme_Structure; } 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_TYPE(o) (((Scheme_Structure *)o)->stype)
#define SCHEME_STRUCT_NUM_SLOTS(o) (SCHEME_STRUCT_TYPE(o)->num_slots) #define SCHEME_STRUCT_NUM_SLOTS(o) (SCHEME_STRUCT_TYPE(o)->num_slots)

1834
src/mzscheme/src/schuchar.inc
View File

File diff suppressed because it is too large Load Diff

2116
src/mzscheme/src/schustr.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 301 #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

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

@ -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_copy_bang (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_fill (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_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 *make_byte_string (int argc, Scheme_Object *argv[]);
static Scheme_Object *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", "string->immutable-string",
1, 1), 1, 1),
env); 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_add_global_constant("string-upcase",
scheme_make_noncm_prim(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); 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 */ /* strcmps */
/**********************************************************************/ /**********************************************************************/

98
src/mzscheme/src/struct.c
View File

@ -39,13 +39,6 @@ typedef enum {
SCHEME_GEN_SETTER SCHEME_GEN_SETTER
} Scheme_ProcT; } 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 { typedef struct {
Scheme_Object so; Scheme_Object so;
Scheme_Object *evt; 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); 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) static Scheme_Object *struct_pred(int argc, Scheme_Object **args, Scheme_Object *prim)
{ {
if (SCHEME_STRUCTP(args[0])) { 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) \ #define STRUCT_mPROCP(o, t, v) \
(SCHEME_STRUCT_PROCP(o) && (((Scheme_Primitive_Proc *)o)->pp.flags & t)) (SCHEME_PRIMP(o) && ((((Scheme_Primitive_Proc *)o)->pp.flags & (t)) == (v)))
#define STRUCT_PROCP(o, t) STRUCT_mPROCP(o, t, t)
static Scheme_Object * static Scheme_Object *
struct_setter_p(int argc, Scheme_Object *argv[]) 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); ? scheme_true : scheme_false);
} }
static Scheme_Object * static Scheme_Object *
struct_getter_p(int argc, Scheme_Object *argv[]) 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); ? scheme_true : scheme_false);
} }
@ -1467,7 +1510,9 @@ struct_pred_p(int argc, Scheme_Object *argv[])
static Scheme_Object * static Scheme_Object *
struct_constr_p(int argc, Scheme_Object *argv[]) 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); ? scheme_true : scheme_false);
} }
@ -1481,10 +1526,11 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
char digitbuf[20]; char digitbuf[20];
int fieldstrlen; int fieldstrlen;
if (!STRUCT_PROCP(argv[0], (getter if (!STRUCT_mPROCP(argv[0],
? SCHEME_PRIM_IS_STRUCT_GETTER SCHEME_PRIM_IS_STRUCT_OTHER | SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK,
: SCHEME_PRIM_IS_STRUCT_SETTER)) SCHEME_PRIM_IS_STRUCT_OTHER | (getter
|| (((Scheme_Primitive_Proc *)argv[0])->mina == (getter ? 1 : 2))) { ? SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER
: SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER))) {
scheme_wrong_type(who, (getter scheme_wrong_type(who, (getter
? "accessor procedure that requires a field index" ? "accessor procedure that requires a field index"
: "mutator 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_ProcT proc_type, int field_num)
{ {
Scheme_Object *p, *a[1]; Scheme_Object *p, *a[1];
short flags = SCHEME_PRIM_IS_STRUCT_PROC; short flags = 0;
if (proc_type == SCHEME_CONSTR) { if (proc_type == SCHEME_CONSTR) {
int simple;
simple = is_simple_struct_type(struct_type);
a[0] = (Scheme_Object *)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, 1, a,
func_name, func_name,
struct_type->num_islots, struct_type->num_islots,
struct_type->num_islots, struct_type->num_islots,
0); 0);
flags |= SCHEME_PRIM_IS_STRUCT_CONSTR; flags |= SCHEME_PRIM_STRUCT_TYPE_CONSTR | SCHEME_PRIM_IS_STRUCT_OTHER;
} else if (proc_type == SCHEME_PRED) { } else if (proc_type == SCHEME_PRED) {
a[0] = (Scheme_Object *)struct_type; a[0] = (Scheme_Object *)struct_type;
p = scheme_make_folding_prim_closure(struct_pred, p = scheme_make_folding_prim_closure(struct_pred,
@ -1989,7 +2039,10 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
1, a, 1, a,
func_name, func_name,
1 + need_pos, 1 + need_pos, 1); 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. /* Cache the accessor only if `struct_info' is used.
This avoids keep lots of useless accessors. This avoids keep lots of useless accessors.
if (need_pos) struct_type->accessor = p; */ if (need_pos) struct_type->accessor = p; */
@ -1998,7 +2051,10 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
1, a, 1, a,
func_name, func_name,
2 + need_pos, 2 + need_pos, 0); 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: /* See note above:
if (need_pos) struct_type->mutator = p; */ if (need_pos) struct_type->mutator = p; */
} }