void scheme_init_char_constants(void)
{
int i;
REGISTER_SO(scheme_char_constants);
REGISTER_SO(general_category_symbols);
scheme_char_constants =
(Scheme_Object **)scheme_malloc_eternal(256 * sizeof(Scheme_Object*));
for (i = 0; i < 256; i++) {
Scheme_Object *sc;
sc = scheme_alloc_eternal_small_object();
sc->type = scheme_char_type;
SCHEME_CHAR_VAL(sc) = i;
scheme_char_constants[i] = sc;
}
for (i = 0; i < NUM_GENERAL_CATEGORIES; i++) {
Scheme_Object *s;
s = scheme_intern_symbol(general_category_names[i]);
general_category_symbols[i] = s;
}
}
void scheme_init_bool (Scheme_Env *env)
{
Scheme_Object *p;
REGISTER_SO(scheme_not_prim);
REGISTER_SO(scheme_eq_prim);
REGISTER_SO(scheme_eqv_prim);
REGISTER_SO(scheme_equal_prim);
p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
scheme_not_prim = p;
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("not", p, env);
p = scheme_make_folding_prim(boolean_p_prim, "boolean?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("boolean?", p, env);
p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_eq_prim = p;
scheme_add_global_constant("eq?", p, env);
p = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_eqv_prim = p;
scheme_add_global_constant("eqv?", scheme_eqv_prim, env);
p = scheme_make_prim_w_arity(equal_prim, "equal?", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_equal_prim = p;
scheme_add_global_constant("equal?", scheme_equal_prim, env);
scheme_add_global_constant("equal?/recur",
scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3),
env);
p = scheme_make_immed_prim(chaperone_p, "chaperone?", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("chaperone?", p, env);
p = scheme_make_immed_prim(impersonator_p, "impersonator?", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("impersonator?", p, env);
scheme_add_global_constant("chaperone-of?",
scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
env);
scheme_add_global_constant("impersonator-of?",
scheme_make_prim_w_arity(impersonator_of, "impersonator-of?", 2, 2),
env);
}
void scheme_init_char (Scheme_Env *env)
{
Scheme_Object *p;
REGISTER_SO(scheme_char_p_proc);
p = scheme_make_folding_prim(char_p, "char?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_char_p_proc = p;
scheme_add_global_constant("char?", p, env);
REGISTER_SO(scheme_interned_char_p_proc);
p = scheme_make_folding_prim(interned_char_p, "interned-char?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_interned_char_p_proc = p;
scheme_add_global_constant("interned-char?", p, env);
p = scheme_make_folding_prim(char_eq, "char=?", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
scheme_add_global_constant("char=?", p, env);
GLOBAL_FOLDING_PRIM("char<?", char_lt, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char>?", char_gt, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char<=?", char_lt_eq, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char>=?", char_gt_eq, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci=?", char_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci<?", char_lt_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci>?", char_gt_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-alphabetic?", char_alphabetic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-numeric?", char_numeric, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-symbolic?", char_symbolic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-graphic?", char_graphic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-whitespace?", char_whitespace, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-blank?", char_blank, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-iso-control?", char_control, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-punctuation?", char_punctuation, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-upper-case?", char_upper_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-lower-case?", char_lower_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env);
p = scheme_make_folding_prim(scheme_checked_char_to_integer, "char->integer", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
scheme_add_global_constant("char->integer", p, env);
p = scheme_make_folding_prim(scheme_checked_integer_to_char, "integer->char", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED);
scheme_add_global_constant("integer->char", p, env);
GLOBAL_FOLDING_PRIM("char-upcase", char_upcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-downcase", char_downcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-titlecase", char_titlecase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-foldcase", char_foldcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-general-category", char_general_category, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-utf-8-length", char_utf8_length, 1, 1, 1, env);
GLOBAL_IMMED_PRIM("make-known-char-range-list", char_map_list, 0, 0, env);
}
void scheme_dont_gc_ptr(void *p)
{
int i, oldsize;
void **naya;
int *nayac;
/* look for existing: */
for (i = 0; i < dgc_size; i++) {
if (dgc_array[i] == p) {
dgc_count[i]++;
return;
}
}
/* look for empty slot: */
for (i = 0; i < dgc_size; i++) {
if (!dgc_array[i]) {
dgc_array[i] = p;
dgc_count[i] = 1;
return;
}
}
/* Make more room: */
oldsize = dgc_size;
if (!dgc_array) {
REGISTER_SO(dgc_array);
REGISTER_SO(dgc_count);
dgc_size = 50;
} else
dgc_size *= 2;
naya = MALLOC_N(void*, dgc_size);
nayac = MALLOC_N(int, dgc_size);
for (i = 0; i < oldsize; i++) {
naya[i] = dgc_array[i];
nayac[i] = dgc_count[i];
}
for (; i < dgc_size; i++) {
naya[i] = NULL;
nayac[i] = 0;
}
dgc_array = naya;
dgc_count = nayac;
dgc_array[oldsize] = p;
dgc_count[oldsize] = 1;
}
void scheme_init_jitprep()
{
REGISTER_SO(current_linklet_native_lambdas);
if (getenv("PLT_EAGER_JIT"))
force_jit = 1;
}
/*========================================================================*/
void scheme_init_place(Scheme_Env *env)
{
Scheme_Env *plenv;
#ifdef MZ_PRECISE_GC
register_traversers();
#endif
plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env);
GLOBAL_PRIM_W_ARITY("place-enabled?", scheme_place_enabled, 0, 0, plenv);
GLOBAL_PRIM_W_ARITY("place-shared?", scheme_place_shared, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place", scheme_place, 2, 2, plenv);
PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel", scheme_place_channel, 0, 0, plenv);
PLACE_PRIM_W_ARITY("place-channel-send", scheme_place_send, 1, 2, plenv);
PLACE_PRIM_W_ARITY("place-channel-recv", scheme_place_recv, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel?", scheme_place_channel_p, 1, 1, plenv);
#ifdef MZ_USE_PLACES
REGISTER_SO(scheme_def_place_exit_proc);
scheme_def_place_exit_proc = scheme_make_prim_w_arity(def_place_exit_handler_proc, "default-place-exit-handler", 1, 1);
#endif
scheme_finish_primitive_module(plenv);
}
void scheme_init_setjumpup(void)
{
if (scheme_starting_up) {
REGISTER_SO(first_copied_stack);
}
first_copied_stack = MALLOC_LINK();
*first_copied_stack = NULL;
GC_push_last_roots = init_push_copied_stacks;
GC_push_last_roots_again = update_push_copied_stacks;
}
static void init_type_arrays()
{
intptr_t n;
#ifdef MZ_USE_PLACES
mzrt_mutex_create(&type_array_mutex);
#endif
REGISTER_SO(type_names);
REGISTER_SO(scheme_type_equals);
REGISTER_SO(scheme_type_hash1s);
REGISTER_SO(scheme_type_hash2s);
maxtype = _scheme_last_type_;
allocmax = maxtype + 100;
type_names = RAW_MALLOC_N(char *, allocmax);
memset(type_names, 0, allocmax * sizeof(char *));
#ifdef MEMORY_COUNTING_ON
scheme_type_table_count += n;
scheme_misc_count += (allocmax * sizeof(char *));
#endif
#ifdef MEMORY_COUNTING_ON
scheme_type_table_count += n;
#endif
scheme_type_equals = RAW_MALLOC_N(Scheme_Equal_Proc, allocmax);
n = allocmax * sizeof(Scheme_Equal_Proc);
memset(scheme_type_equals, 0, n);
scheme_type_hash1s = RAW_MALLOC_N(Scheme_Primary_Hash_Proc, allocmax);
n = allocmax * sizeof(Scheme_Primary_Hash_Proc);
memset(scheme_type_hash1s, 0, n);
scheme_type_hash2s = RAW_MALLOC_N(Scheme_Secondary_Hash_Proc, allocmax);
n = allocmax * sizeof(Scheme_Secondary_Hash_Proc);
memset(scheme_type_hash2s, 0, n);
}
void scheme_init_sema_places() {
REGISTER_SO(scheme_system_idle_channel);
scheme_system_idle_channel = scheme_make_channel();
}
void
scheme_init_vector (Scheme_Env *env)
{
Scheme_Object *p;
REGISTER_SO(scheme_vector_p_proc);
p = scheme_make_folding_prim(vector_p, "vector?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("vector?", p, env);
scheme_vector_p_proc = p;
REGISTER_SO(scheme_make_vector_proc);
p = scheme_make_immed_prim(scheme_checked_make_vector, "make-vector", 1, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED);
scheme_add_global_constant("make-vector", p, env);
scheme_make_vector_proc = p;
REGISTER_SO(scheme_vector_proc);
p = scheme_make_immed_prim(vector, "vector", 0, -1);
scheme_vector_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
scheme_add_global_constant("vector", p, env);
REGISTER_SO(scheme_vector_immutable_proc);
p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1);
scheme_vector_immutable_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_NARY_INLINED
| SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
scheme_add_global_constant("vector-immutable", p, env);
p = scheme_make_folding_prim(vector_length, "vector-length", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_add_global_constant("vector-length", p, env);
REGISTER_SO(scheme_vector_ref_proc);
p = scheme_make_noncm_prim(scheme_checked_vector_ref,
"vector-ref",
2, 2);
scheme_vector_ref_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
scheme_add_global_constant("vector-ref", p, env);
REGISTER_SO(scheme_vector_set_proc);
p = scheme_make_noncm_prim(scheme_checked_vector_set,
"vector-set!",
3, 3);
scheme_vector_set_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("vector-set!", p, env);
scheme_add_global_constant("vector->list",
scheme_make_immed_prim(vector_to_list,
"vector->list",
1, 1),
env);
REGISTER_SO(scheme_list_to_vector_proc);
p = scheme_make_immed_prim(list_to_vector,
"list->vector",
1, 1);
scheme_list_to_vector_proc = p;
scheme_add_global_constant("list->vector", p, env);
scheme_add_global_constant("vector-fill!",
scheme_make_immed_prim(vector_fill,
"vector-fill!",
2, 2),
env);
scheme_add_global_constant("vector-copy!",
scheme_make_immed_prim(vector_copy_bang,
"vector-copy!",
3, 5),
env);
scheme_add_global_constant("vector->immutable-vector",
scheme_make_immed_prim(vector_to_immutable,
"vector->immutable-vector",
1, 1),
env);
scheme_add_global_constant("vector->values",
scheme_make_prim_w_arity2(vector_to_values,
"vector->values",
1, 3,
0, -1),
env);
scheme_add_global_constant("chaperone-vector",
scheme_make_prim_w_arity(chaperone_vector,
"chaperone-vector",
3, -1),
env);
scheme_add_global_constant("impersonate-vector",
scheme_make_prim_w_arity(impersonate_vector,
"impersonate-vector",
3, -1),
env);
}
void
scheme_init_unsafe_vector (Scheme_Env *env)
{
Scheme_Object *p;
REGISTER_SO(scheme_unsafe_vector_length_proc);
p = scheme_make_immed_prim(unsafe_vector_len, "unsafe-vector-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_add_global_constant("unsafe-vector-length", p, env);
scheme_unsafe_vector_length_proc = p;
p = scheme_make_immed_prim(unsafe_vector_star_len, "unsafe-vector*-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_add_global_constant("unsafe-vector*-length", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("unsafe-vector-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_star_ref, "unsafe-vector*-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("unsafe-vector*-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-vector-set!", p, env);
p = scheme_make_immed_prim(unsafe_vector_star_set, "unsafe-vector*-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-vector*-set!", p, env);
REGISTER_SO(scheme_unsafe_struct_ref_proc);
p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2);
scheme_unsafe_struct_ref_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("unsafe-struct-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_star_ref, "unsafe-struct*-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("unsafe-struct*-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-struct-set!", p, env);
p = scheme_make_immed_prim(unsafe_struct_star_set, "unsafe-struct*-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-struct*-set!", p, env);
REGISTER_SO(scheme_unsafe_string_length_proc);
p = scheme_make_immed_prim(unsafe_string_len, "unsafe-string-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_add_global_constant("unsafe-string-length", p, env);
scheme_unsafe_string_length_proc = p;
p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("unsafe-string-ref", p, env);
p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-string-set!", p, env);
REGISTER_SO(scheme_unsafe_byte_string_length_proc);
p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_add_global_constant("unsafe-bytes-length", p, env);
scheme_unsafe_byte_string_length_proc = p;
p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_add_global_constant("unsafe-bytes-ref", p, env);
p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_add_global_constant("unsafe-bytes-set!", p, env);
}
void
scheme_init_unsafe_vector (Scheme_Startup_Env *env)
{
Scheme_Object *p;
REGISTER_SO(scheme_unsafe_vector_length_proc);
p = scheme_make_immed_prim(unsafe_vector_len, "unsafe-vector-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-vector-length", p, env);
scheme_unsafe_vector_length_proc = p;
REGISTER_SO(scheme_unsafe_vector_star_length_proc);
p = scheme_make_immed_prim(unsafe_vector_star_len, "unsafe-vector*-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-vector*-length", p, env);
scheme_unsafe_vector_star_length_proc = p;
p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_addto_prim_instance("unsafe-vector-ref", p, env);
REGISTER_SO(scheme_unsafe_vector_star_ref_proc);
p = scheme_make_immed_prim(unsafe_vector_star_ref, "unsafe-vector*-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_addto_prim_instance("unsafe-vector*-ref", p, env);
scheme_unsafe_vector_star_ref_proc = p;
p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_addto_prim_instance("unsafe-vector-set!", p, env);
REGISTER_SO(scheme_unsafe_vector_star_set_proc);
p = scheme_make_immed_prim(unsafe_vector_star_set, "unsafe-vector*-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_addto_prim_instance("unsafe-vector*-set!", p, env);
scheme_unsafe_vector_star_set_proc = p;
p = scheme_make_immed_prim(unsafe_vector_star_cas, "unsafe-vector*-cas!", 4, 4);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_addto_prim_instance("unsafe-vector*-cas!", p, env);
REGISTER_SO(scheme_unsafe_struct_ref_proc);
p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2);
scheme_unsafe_struct_ref_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_addto_prim_instance("unsafe-struct-ref", p, env);
REGISTER_SO(scheme_unsafe_struct_ref_proc);
p = scheme_make_immed_prim(unsafe_struct_star_ref, "unsafe-struct*-ref", 2, 2);
scheme_unsafe_struct_star_ref_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_addto_prim_instance("unsafe-struct*-ref", p, env);
REGISTER_SO(scheme_unsafe_struct_set_proc);
p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct-set!", 3, 3);
scheme_unsafe_struct_set_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_addto_prim_instance("unsafe-struct-set!", p, env);
REGISTER_SO(scheme_unsafe_struct_star_set_proc);
p = scheme_make_immed_prim(unsafe_struct_star_set, "unsafe-struct*-set!", 3, 3);
scheme_unsafe_struct_star_set_proc = p;
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_addto_prim_instance("unsafe-struct*-set!", p, env);
p = scheme_make_immed_prim(unsafe_struct_star_cas, "unsafe-struct*-cas!", 4, 4);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_addto_prim_instance("unsafe-struct*-cas!", p, env);
REGISTER_SO(scheme_unsafe_string_length_proc);
p = scheme_make_immed_prim(unsafe_string_len, "unsafe-string-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-string-length", p, env);
scheme_unsafe_string_length_proc = p;
REGISTER_SO(scheme_unsafe_string_ref_proc);
p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE);
scheme_addto_prim_instance("unsafe-string-ref", p, env);
scheme_unsafe_string_ref_proc = p;
REGISTER_SO(scheme_unsafe_string_set_proc);
p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_addto_prim_instance("unsafe-string-set!", p, env);
scheme_unsafe_string_set_proc = p;
REGISTER_SO(scheme_unsafe_byte_string_length_proc);
p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-bytes-length", p, env);
scheme_unsafe_byte_string_length_proc = p;
REGISTER_SO(scheme_unsafe_bytes_ref_proc);
p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_OMITABLE
| SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_PRODUCES_FIXNUM);
scheme_addto_prim_instance("unsafe-bytes-ref", p, env);
scheme_unsafe_bytes_ref_proc = p;
REGISTER_SO(scheme_unsafe_bytes_set_proc);
p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
scheme_addto_prim_instance("unsafe-bytes-set!", p, env);
scheme_unsafe_bytes_set_proc = p;
scheme_addto_prim_instance("unsafe-impersonate-vector",
scheme_make_prim_w_arity(unsafe_impersonate_vector,
"unsafe-impersonate-vector",
2, -1),
env);
scheme_addto_prim_instance("unsafe-chaperone-vector",
scheme_make_prim_w_arity(unsafe_chaperone_vector,
"unsafe-chaperone-vector",
2, -1),
env);
}
void scheme_init_char (Scheme_Env *env)
{
Scheme_Object *p;
int i;
REGISTER_SO(scheme_char_constants);
REGISTER_SO(general_category_symbols);
scheme_char_constants =
(Scheme_Object **)scheme_malloc_eternal(256 * sizeof(Scheme_Object*));
for (i = 0; i < 256; i++) {
Scheme_Object *sc;
sc = scheme_alloc_eternal_small_object();
sc->type = scheme_char_type;
SCHEME_CHAR_VAL(sc) = i;
scheme_char_constants[i] = sc;
}
for (i = 0; i < NUM_GENERAL_CATEGORIES; i++) {
Scheme_Object *s;
s = scheme_intern_symbol(general_category_names[i]);
general_category_symbols[i] = s;
}
p = scheme_make_folding_prim(char_p, "char?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("char?", p, env);
p = scheme_make_folding_prim(char_eq, "char=?", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
scheme_add_global_constant("char=?", p, env);
GLOBAL_FOLDING_PRIM("char<?", char_lt, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char>?", char_gt, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char<=?", char_lt_eq, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char>=?", char_gt_eq, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci=?", char_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci<?", char_lt_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci>?", char_gt_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-alphabetic?", char_alphabetic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-numeric?", char_numeric, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-symbolic?", char_symbolic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-graphic?", char_graphic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-whitespace?", char_whitespace, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-blank?", char_blank, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-iso-control?", char_control, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-punctuation?", char_punctuation, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-upper-case?", char_upper_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-lower-case?", char_lower_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char->integer", char_to_integer, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("integer->char", integer_to_char, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-upcase", char_upcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-downcase", char_downcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-titlecase", char_titlecase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-foldcase", char_foldcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-general-category", char_general_category, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-utf-8-length", char_utf8_length, 1, 1, 1, env);
GLOBAL_IMMED_PRIM("make-known-char-range-list", char_map_list, 0, 0, env);
}
void
scheme_init_list (Scheme_Env *env)
{
scheme_null->type = scheme_null_type;
scheme_add_global_constant ("null", scheme_null, env);
scheme_add_global_constant ("pair?",
scheme_make_folding_prim(pair_p_prim,
"pair?",
1, 1, 1),
env);
scheme_add_global_constant ("cons",
scheme_make_prim_w_arity(cons_prim,
"cons",
2, 2),
env);
scheme_add_global_constant ("car",
scheme_make_prim_w_arity(car_prim,
"car",
1, 1),
env);
scheme_add_global_constant ("cdr",
scheme_make_prim_w_arity(cdr_prim,
"cdr",
1, 1),
env);
scheme_add_global_constant ("set-car!",
scheme_make_prim_w_arity(set_car_prim,
"set-car!",
2, 2),
env);
scheme_add_global_constant ("set-cdr!",
scheme_make_prim_w_arity(set_cdr_prim,
"set-cdr!",
2, 2),
env);
scheme_add_global_constant ("cons-immutable",
scheme_make_prim_w_arity(cons_immutable,
"cons-immutable",
2, 2),
env);
scheme_add_global_constant ("null?",
scheme_make_folding_prim(null_p_prim,
"null?",
1, 1, 1),
env);
scheme_add_global_constant ("list?",
scheme_make_prim_w_arity(list_p_prim,
"list?",
1, 1),
env);
scheme_add_global_constant ("list",
scheme_make_prim_w_arity(list_prim,
"list",
0, -1),
env);
scheme_add_global_constant ("list-immutable",
scheme_make_prim_w_arity(list_immutable_prim,
"list-immutable",
0, -1),
env);
scheme_add_global_constant ("list*",
scheme_make_prim_w_arity(list_star_prim,
"list*",
1, -1),
env);
scheme_add_global_constant ("list*-immutable",
scheme_make_prim_w_arity(list_star_immutable_prim,
"list*-immutable",
1, -1),
env);
scheme_add_global_constant("immutable?",
scheme_make_folding_prim(immutablep,
"immutable?",
1, 1, 1),
env);
scheme_add_global_constant ("length",
scheme_make_prim_w_arity(length_prim,
"length",
1, 1),
env);
scheme_add_global_constant ("append",
scheme_make_prim_w_arity(append_prim,
"append",
0, -1),
env);
scheme_add_global_constant ("append!",
scheme_make_prim_w_arity(append_bang_prim,
"append!",
0, -1),
env);
scheme_add_global_constant ("reverse",
scheme_make_prim_w_arity(reverse_prim,
"reverse",
1, 1),
env);
scheme_add_global_constant ("reverse!",
scheme_make_prim_w_arity(reverse_bang_prim,
"reverse!",
1, 1),
env);
scheme_add_global_constant ("list-tail",
scheme_make_prim_w_arity(list_tail_prim,
"list-tail",
2, 2),
env);
scheme_add_global_constant ("list-ref",
scheme_make_prim_w_arity(list_ref_prim,
"list-ref",
2, 2),
env);
scheme_add_global_constant ("memq",
scheme_make_prim_w_arity(memq,
"memq",
2, 2),
env);
scheme_add_global_constant ("memv",
scheme_make_prim_w_arity(memv,
"memv",
2, 2),
env);
scheme_add_global_constant ("member",
scheme_make_prim_w_arity(member,
"member",
2, 2),
env);
scheme_add_global_constant ("assq",
scheme_make_prim_w_arity(assq,
"assq",
2, 2),
env);
scheme_add_global_constant ("assv",
scheme_make_prim_w_arity(assv,
"assv",
2, 2),
env);
scheme_add_global_constant ("assoc",
scheme_make_prim_w_arity(assoc,
"assoc",
2, 2),
env);
scheme_add_global_constant ("caar",
scheme_make_prim_w_arity(caar_prim,
"caar",
1, 1),
env);
scheme_add_global_constant ("cadr",
scheme_make_prim_w_arity(cadr_prim,
"cadr",
1, 1),
env);
scheme_add_global_constant ("cdar",
scheme_make_prim_w_arity(cdar_prim,
"cdar",
1, 1),
env);
scheme_add_global_constant ("cddr",
scheme_make_prim_w_arity(cddr_prim,
"cddr",
1, 1),
env);
scheme_add_global_constant ("caaar",
scheme_make_prim_w_arity(caaar_prim,
"caaar",
1, 1),
env);
scheme_add_global_constant ("caadr",
scheme_make_prim_w_arity(caadr_prim,
"caadr",
1, 1),
env);
scheme_add_global_constant ("cadar",
scheme_make_prim_w_arity(cadar_prim,
"cadar",
1, 1),
env);
scheme_add_global_constant ("cdaar",
scheme_make_prim_w_arity(cdaar_prim,
"cdaar",
1, 1),
env);
scheme_add_global_constant ("cdadr",
scheme_make_prim_w_arity(cdadr_prim,
"cdadr",
1, 1),
env);
scheme_add_global_constant ("cddar",
scheme_make_prim_w_arity(cddar_prim,
"cddar",
1, 1),
env);
scheme_add_global_constant ("caddr",
scheme_make_prim_w_arity(caddr_prim,
"caddr",
1, 1),
env);
scheme_add_global_constant ("cdddr",
scheme_make_prim_w_arity(cdddr_prim,
"cdddr",
1, 1),
env);
scheme_add_global_constant ("cddddr",
scheme_make_prim_w_arity(cddddr_prim,
"cddddr",
1, 1),
env);
scheme_add_global_constant ("cadddr",
scheme_make_prim_w_arity(cadddr_prim,
"cadddr",
1, 1),
env);
scheme_add_global_constant ("cdaddr",
scheme_make_prim_w_arity(cdaddr_prim,
"cdaddr",
1, 1),
env);
scheme_add_global_constant ("cddadr",
scheme_make_prim_w_arity(cddadr_prim,
"cddadr",
1, 1),
env);
scheme_add_global_constant ("cdddar",
scheme_make_prim_w_arity(cdddar_prim,
"cdddar",
1, 1),
env);
scheme_add_global_constant ("caaddr",
scheme_make_prim_w_arity(caaddr_prim,
"caaddr",
1, 1),
env);
scheme_add_global_constant ("cadadr",
scheme_make_prim_w_arity(cadadr_prim,
"cadadr",
1, 1),
env);
scheme_add_global_constant ("caddar",
scheme_make_prim_w_arity(caddar_prim,
"caddar",
1, 1),
env);
scheme_add_global_constant ("cdaadr",
scheme_make_prim_w_arity(cdaadr_prim,
"cdaadr",
1, 1),
env);
scheme_add_global_constant ("cdadar",
scheme_make_prim_w_arity(cdadar_prim,
"cdadar",
1, 1),
env);
scheme_add_global_constant ("cddaar",
scheme_make_prim_w_arity(cddaar_prim,
"cddaar",
1, 1),
env);
scheme_add_global_constant ("cdaaar",
scheme_make_prim_w_arity(cdaaar_prim,
"cdaaar",
1, 1),
env);
scheme_add_global_constant ("cadaar",
scheme_make_prim_w_arity(cadaar_prim,
"cadaar",
1, 1),
env);
scheme_add_global_constant ("caadar",
scheme_make_prim_w_arity(caadar_prim,
"caadar",
1, 1),
env);
scheme_add_global_constant ("caaadr",
scheme_make_prim_w_arity(caaadr_prim,
"caaadr",
1, 1),
env);
scheme_add_global_constant ("caaaar",
scheme_make_prim_w_arity(caaaar_prim,
"caaaar",
1, 1),
env);
scheme_add_global_constant(BOX,
scheme_make_prim_w_arity(box,
BOX,
1, 1),
env);
scheme_add_global_constant("box-immutable",
scheme_make_prim_w_arity(immutable_box,
"box-immutable",
1, 1),
env);
scheme_add_global_constant(BOXP,
scheme_make_folding_prim(box_p,
BOXP,
1, 1, 1),
env);
scheme_add_global_constant(UNBOX,
scheme_make_prim_w_arity(unbox,
UNBOX,
1, 1),
env);
scheme_add_global_constant(SETBOX,
scheme_make_prim_w_arity(set_box,
SETBOX,
2, 2),
env);
scheme_add_global_constant("make-hash-table",
scheme_make_prim_w_arity(make_hash_table,
"make-hash-table",
0, 2),
env);
scheme_add_global_constant("make-immutable-hash-table",
scheme_make_prim_w_arity(make_immutable_hash_table,
"make-immutable-hash-table",
1, 2),
env);
scheme_add_global_constant("hash-table?",
scheme_make_folding_prim(hash_table_p,
"hash-table?",
1, 3, 1),
env);
scheme_add_global_constant("hash-table-count",
scheme_make_prim_w_arity(hash_table_count,
"hash-table-count",
1, 1),
env);
scheme_add_global_constant("hash-table-copy",
scheme_make_prim_w_arity(hash_table_copy,
"hash-table-copy",
1, 1),
env);
scheme_add_global_constant("hash-table-put!",
scheme_make_prim_w_arity(hash_table_put,
"hash-table-put!",
3, 3),
env);
scheme_add_global_constant("hash-table-get",
scheme_make_prim_w_arity(hash_table_get,
"hash-table-get",
2, 3),
env);
scheme_add_global_constant("hash-table-remove!",
scheme_make_prim_w_arity(hash_table_remove,
"hash-table-remove!",
2, 2),
env);
scheme_add_global_constant("hash-table-map",
scheme_make_prim_w_arity(hash_table_map,
"hash-table-map",
2, 2),
env);
scheme_add_global_constant("hash-table-for-each",
scheme_make_prim_w_arity(hash_table_for_each,
"hash-table-for-each",
2, 2),
env);
scheme_add_global_constant("eq-hash-code",
scheme_make_prim_w_arity(eq_hash_code,
"eq-hash-code",
1, 1),
env);
scheme_add_global_constant("equal-hash-code",
scheme_make_prim_w_arity(equal_hash_code,
"equal-hash-code",
1, 1),
env);
scheme_add_global_constant("make-weak-box",
scheme_make_prim_w_arity(make_weak_box,
"make-weak-box",
1, 1),
env);
scheme_add_global_constant("weak-box-value",
scheme_make_prim_w_arity(weak_box_value,
"weak-box-value",
1, 1),
env);
scheme_add_global_constant("weak-box?",
scheme_make_folding_prim(weak_boxp,
"weak-box?",
1, 1, 1),
env);
REGISTER_SO(weak_symbol);
REGISTER_SO(equal_symbol);
weak_symbol = scheme_intern_symbol("weak");
equal_symbol = scheme_intern_symbol("equal");
}
static void add_finalizer(void *v, void (*f)(void*,void*), void *data,
int prim, int ext,
void (**ext_oldf)(void *p, void *data),
void **ext_olddata,
int no_dup, int rmve)
{
finalizer_function oldf;
void *olddata;
Finalizations *fns, **fns_ptr, *prealloced;
Finalization *fn;
if (!traversers_registered) {
#ifdef MZ_PRECISE_GC
GC_REG_TRAV(scheme_rt_finalization, mark_finalization);
GC_REG_TRAV(scheme_rt_finalizations, mark_finalizations);
traversers_registered = 1;
#endif
REGISTER_SO(save_fns_ptr);
}
#ifndef MZ_PRECISE_GC
if (v != GC_base(v))
return;
#endif
/* Allocate everything first so that we're not changing
finalizations when finalizations could run: */
if (save_fns_ptr) {
fns_ptr = save_fns_ptr;
save_fns_ptr = NULL;
} else
fns_ptr = MALLOC_ONE(Finalizations*);
if (!ext && !rmve) {
fn = MALLOC_ONE_RT(Finalization);
#ifdef MZTAG_REQUIRED
fn->type = scheme_rt_finalization;
#endif
fn->f = f;
fn->data = data;
} else
fn = NULL;
if (!rmve) {
prealloced = MALLOC_ONE_RT(Finalizations); /* may not need this... */
#ifdef MZTAG_REQUIRED
prealloced->type = scheme_rt_finalizations;
#endif
} else
prealloced = NULL;
GC_register_eager_finalizer(v, prim ? 2 : 1, do_next_finalization, fns_ptr, &oldf, &olddata);
if (oldf) {
if (oldf != do_next_finalization) {
/* This happens if an extenal use of GC_ routines conflicts with us. */
scheme_warning("warning: non-MzScheme finalization on object dropped!");
} else {
*fns_ptr = *(Finalizations **)olddata;
save_fns_ptr = (Finalizations **)olddata;
*save_fns_ptr = NULL;
}
} else if (rmve) {
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
return;
}
if (!(*fns_ptr)) {
prealloced->lifetime = current_lifetime;
*fns_ptr = prealloced;
}
fns = *fns_ptr;
if (ext) {
if (ext_oldf)
*ext_oldf = fns->ext_f;
fns->ext_f = f;
if (ext_olddata)
*ext_olddata = fns->ext_data;
fns->ext_data = data;
if (!f && !fns->prim_first && !fns->scheme_first) {
/* Removed all finalization */
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
*save_fns_ptr = NULL;
}
} else {
if (prim) {
if (no_dup) {
/* Make sure it's not already here */
Finalization *fnx;
for (fnx = fns->prim_first; fnx; fnx = fnx->next) {
if (fnx->f == f && fnx->data == data) {
if (rmve) {
if (fnx->prev)
fnx->prev->next = fnx->next;
else
fns->prim_first = fnx->next;
if (fnx->next)
fnx->next->prev = fnx->prev;
else
fns->prim_last = fnx->prev;
}
fn = NULL;
break;
}
}
}
if (fn) {
fn->next = fns->prim_first;
fns->prim_first = fn;
if (!fn->next)
fns->prim_last = fn;
else
fn->next->prev = fn;
}
/* Removed all finalization? */
if (!fns->ext_f && !fns->prim_first && !fns->scheme_first) {
GC_register_finalizer(v, NULL, NULL, NULL, NULL);
save_fns_ptr = fns_ptr;
*save_fns_ptr = NULL;
}
} else {
fn->next = fns->scheme_first;
fns->scheme_first = fn;
if (!fn->next)
fns->scheme_last = fn;
else
fn->next->prev = fn;
}
}
}
void scheme_init_sema(Scheme_Env *env)
{
Scheme_Object *o;
#ifdef MZ_PRECISE_GC
register_traversers();
#endif
scheme_add_global_constant("make-semaphore",
scheme_make_prim_w_arity(make_sema,
"make-semaphore",
0, 1),
env);
scheme_add_global_constant("semaphore?",
scheme_make_folding_prim(semap,
"semaphore?",
1, 1, 1),
env);
scheme_add_global_constant("semaphore-post",
scheme_make_prim_w_arity(hit_sema,
"semaphore-post",
1, 1),
env);
scheme_add_global_constant("semaphore-try-wait?",
scheme_make_prim_w_arity(block_sema_p,
"semaphore-try-wait?",
1, 1),
env);
scheme_add_global_constant("semaphore-wait",
scheme_make_prim_w_arity(block_sema,
"semaphore-wait",
1, 1),
env);
scheme_add_global_constant("semaphore-wait/enable-break",
scheme_make_prim_w_arity(block_sema_breakable,
"semaphore-wait/enable-break",
1, 1),
env);
scheme_add_global_constant("semaphore-peek-evt",
scheme_make_prim_w_arity(make_sema_repost,
"semaphore-peek-evt",
1, 1),
env);
scheme_add_global_constant("make-channel",
scheme_make_prim_w_arity(make_channel,
"make-channel",
0, 0),
env);
scheme_add_global_constant("channel-put-evt",
scheme_make_prim_w_arity(make_channel_put,
"channel-put-evt",
2, 2),
env);
scheme_add_global_constant("channel?",
scheme_make_folding_prim(channel_p,
"channel?",
1, 1, 1),
env);
scheme_add_global_constant("thread-send",
scheme_make_prim_w_arity(thread_send,
"thread-send",
2, 3),
env);
scheme_add_global_constant("thread-receive",
scheme_make_prim_w_arity(thread_receive,
"thread-receive",
0, 0),
env);
scheme_add_global_constant("thread-try-receive",
scheme_make_prim_w_arity(thread_try_receive,
"thread-try-receive",
0, 0),
env);
scheme_add_global_constant("thread-receive-evt",
scheme_make_prim_w_arity(thread_receive_evt,
"thread-receive-evt",
0, 0),
env);
scheme_add_global_constant("thread-rewind-receive",
scheme_make_prim_w_arity(thread_rewind_receive,
"thread-rewind-receive",
1, 1),
env);
scheme_add_global_constant("alarm-evt",
scheme_make_prim_w_arity(make_alarm,
"alarm-evt",
1, 1),
env);
scheme_add_global_constant("system-idle-evt",
scheme_make_prim_w_arity(make_sys_idle,
"system-idle-evt",
0, 0),
env);
REGISTER_SO(scheme_always_ready_evt);
scheme_always_ready_evt = scheme_alloc_small_object();
scheme_always_ready_evt->type = scheme_always_evt_type;
scheme_add_global_constant("always-evt", scheme_always_ready_evt, env);
o = scheme_alloc_small_object();
o->type = scheme_never_evt_type;
scheme_add_global_constant("never-evt", o, env);
REGISTER_SO(thread_recv_evt);
o = scheme_alloc_small_object();
o->type = scheme_thread_recv_evt_type;
thread_recv_evt = o;
scheme_add_evt(scheme_sema_type, sema_ready, NULL, NULL, 0);
scheme_add_evt_through_sema(scheme_semaphore_repost_type, sema_for_repost, NULL);
scheme_add_evt(scheme_channel_type, (Scheme_Ready_Fun)channel_get_ready, NULL, NULL, 1);
scheme_add_evt(scheme_channel_put_type, (Scheme_Ready_Fun)channel_put_ready, NULL, NULL, 1);
scheme_add_evt(scheme_channel_syncer_type, (Scheme_Ready_Fun)channel_syncer_ready, NULL, NULL, 0);
scheme_add_evt(scheme_alarm_type, (Scheme_Ready_Fun)alarm_ready, NULL, NULL, 0);
scheme_add_evt(scheme_always_evt_type, always_ready, NULL, NULL, 0);
scheme_add_evt(scheme_never_evt_type, never_ready, NULL, NULL, 0);
scheme_add_evt(scheme_thread_recv_evt_type, (Scheme_Ready_Fun)thread_recv_ready, NULL, NULL, 0);
}
void scheme_init_char (Scheme_Env *env)
{
Scheme_Object *p;
int i;
REGISTER_SO(scheme_char_constants);
REGISTER_SO(general_category_symbols);
scheme_char_constants =
(Scheme_Object **)scheme_malloc_eternal(256 * sizeof(Scheme_Object*));
for (i = 0; i < 256; i++) {
Scheme_Object *sc;
sc = scheme_alloc_eternal_small_object();
sc->type = scheme_char_type;
SCHEME_CHAR_VAL(sc) = i;
scheme_char_constants[i] = sc;
}
p = scheme_make_folding_prim(char_p, "char?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("char?", p, env);
p = scheme_make_folding_prim(char_eq, "char=?", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("char=?", p, env);
scheme_add_global_constant("char<?",
scheme_make_folding_prim(char_lt,
"char<?",
2, -1, 1),
env);
scheme_add_global_constant("char>?",
scheme_make_folding_prim(char_gt,
"char>?",
2, -1, 1),
env);
scheme_add_global_constant("char<=?",
scheme_make_folding_prim(char_lt_eq,
"char<=?",
2, -1, 1),
env);
scheme_add_global_constant("char>=?",
scheme_make_folding_prim(char_gt_eq,
"char>=?",
2, -1, 1),
env);
scheme_add_global_constant("char-ci=?",
scheme_make_folding_prim(char_eq_ci,
"char-ci=?",
2, -1, 1),
env);
scheme_add_global_constant("char-ci<?",
scheme_make_folding_prim(char_lt_ci,
"char-ci<?",
2, -1, 1),
env);
scheme_add_global_constant("char-ci>?",
scheme_make_folding_prim(char_gt_ci,
"char-ci>?",
2, -1, 1),
env);
scheme_add_global_constant("char-ci<=?",
scheme_make_folding_prim(char_lt_eq_ci,
"char-ci<=?",
2, -1, 1),
env);
scheme_add_global_constant("char-ci>=?",
scheme_make_folding_prim(char_gt_eq_ci,
"char-ci>=?",
2, -1, 1),
env);
scheme_add_global_constant("char-alphabetic?",
scheme_make_folding_prim(char_alphabetic,
"char-alphabetic?",
1, 1, 1),
env);
scheme_add_global_constant("char-numeric?",
scheme_make_folding_prim(char_numeric,
"char-numeric?",
1, 1, 1),
env);
scheme_add_global_constant("char-symbolic?",
scheme_make_folding_prim(char_symbolic,
"char-symbolic?",
1, 1, 1),
env);
scheme_add_global_constant("char-graphic?",
scheme_make_folding_prim(char_graphic,
"char-graphic?",
1, 1, 1),
env);
scheme_add_global_constant("char-whitespace?",
scheme_make_folding_prim(char_whitespace,
"char-whitespace?",
1, 1, 1),
env);
scheme_add_global_constant("char-blank?",
scheme_make_folding_prim(char_blank,
"char-blank?",
1, 1, 1),
env);
scheme_add_global_constant("char-iso-control?",
scheme_make_folding_prim(char_control,
"char-iso-control?",
1, 1, 1),
env);
scheme_add_global_constant("char-punctuation?",
scheme_make_folding_prim(char_punctuation,
"char-punctuation?",
1, 1, 1),
env);
scheme_add_global_constant("char-upper-case?",
scheme_make_folding_prim(char_upper_case,
"char-upper-case?",
1, 1, 1),
env);
scheme_add_global_constant("char-title-case?",
scheme_make_folding_prim(char_title_case,
"char-title-case?",
1, 1, 1),
env);
scheme_add_global_constant("char-lower-case?",
scheme_make_folding_prim(char_lower_case,
"char-lower-case?",
1, 1, 1),
env);
scheme_add_global_constant("char-title-case?",
scheme_make_folding_prim(char_title_case,
"char-title-case?",
1, 1, 1),
env);
scheme_add_global_constant("char->integer",
scheme_make_folding_prim(char_to_integer,
"char->integer",
1, 1, 1),
env);
scheme_add_global_constant("integer->char",
scheme_make_folding_prim(integer_to_char,
"integer->char",
1, 1, 1),
env);
scheme_add_global_constant("char-upcase",
scheme_make_folding_prim(char_upcase,
"char-upcase",
1, 1, 1),
env);
scheme_add_global_constant("char-downcase",
scheme_make_folding_prim(char_downcase,
"char-downcase",
1, 1, 1),
env);
scheme_add_global_constant("char-titlecase",
scheme_make_folding_prim(char_titlecase,
"char-titlecase",
1, 1, 1),
env);
scheme_add_global_constant("char-foldcase",
scheme_make_folding_prim(char_foldcase,
"char-foldcase",
1, 1, 1),
env);
scheme_add_global_constant("char-general-category",
scheme_make_folding_prim(char_general_category,
"char-general-category",
1, 1, 1),
env);
scheme_add_global_constant("char-utf-8-length",
scheme_make_folding_prim(char_utf8_length,
"char-utf-8-length",
1, 1, 1),
env);
scheme_add_global_constant("make-known-char-range-list",
scheme_make_noncm_prim(char_map_list,
"make-known-char-range-list",
0, 0),
env);
}
void
scheme_init_vector (Scheme_Env *env)
{
Scheme_Object *p;
REGISTER_SO(zero_length_vector);
zero_length_vector = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector)
- sizeof(Scheme_Object *));
zero_length_vector->type = scheme_vector_type;
SCHEME_VEC_SIZE(zero_length_vector) = 0;
p = scheme_make_folding_prim(vector_p, "vector?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("vector?", p, env);
scheme_add_global_constant("make-vector",
scheme_make_noncm_prim(make_vector,
"make-vector",
1, 2),
env);
scheme_add_global_constant("vector",
scheme_make_noncm_prim(vector,
"vector",
0, -1),
env);
scheme_add_global_constant("vector-immutable",
scheme_make_noncm_prim(vector_immutable,
"vector-immutable",
0, -1),
env);
scheme_add_global_constant("vector-length",
scheme_make_folding_prim(vector_length,
"vector-length",
1, 1, 1),
env);
p = scheme_make_noncm_prim(scheme_checked_vector_ref,
"vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("vector-ref", p, env);
p = scheme_make_noncm_prim(scheme_checked_vector_set,
"vector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_MIN_NARY_INLINED;
scheme_add_global_constant("vector-set!", p, env);
scheme_add_global_constant("vector->list",
scheme_make_noncm_prim(vector_to_list,
"vector->list",
1, 1),
env);
scheme_add_global_constant("list->vector",
scheme_make_noncm_prim(list_to_vector,
"list->vector",
1, 1),
env);
scheme_add_global_constant("vector-fill!",
scheme_make_noncm_prim(vector_fill,
"vector-fill!",
2, 2),
env);
scheme_add_global_constant("vector->immutable-vector",
scheme_make_noncm_prim(vector_to_immutable,
"vector->immutable-vector",
1, 1),
env);
scheme_add_global_constant("vector->values",
scheme_make_prim_w_arity2(vector_to_values,
"vector->values",
1, 3,
0, -1),
env);
}
