XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
{
Scheme_Type t1, t2;
if (SAME_OBJ(obj1, obj2))
return 1;
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2)) {
#ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS
/* If one is a float and the other is a double, coerce to double */
if ((t1 == scheme_float_type) && (t2 == scheme_double_type))
return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2));
else if ((t2 == scheme_float_type) && (t1 == scheme_double_type))
return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
return -1;
} else {
switch (t1) {
#ifdef MZ_LONG_DOUBLE
case scheme_long_double_type:
return mz_long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
case scheme_float_type:
return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
case scheme_double_type:
return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
case scheme_bignum_type:
return scheme_bignum_eq(obj1, obj2);
case scheme_rational_type:
return scheme_rational_eq(obj1, obj2);
case scheme_complex_type:
{
Scheme_Complex *c1 = (Scheme_Complex *)obj1;
Scheme_Complex *c2 = (Scheme_Complex *)obj2;
return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
}
case scheme_char_type:
return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
case scheme_symbol_type:
case scheme_keyword_type:
case scheme_scope_type:
/* `eqv?` requires `eq?` */
return 0;
default:
return -1;
}
}
}
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;
}
}
XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
{
Scheme_Type t1, t2;
if (SAME_OBJ(obj1, obj2))
return 1;
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2)) {
#ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS
/* If one is a float and the other is a double, coerce to double */
if ((t1 == scheme_float_type) && (t2 == scheme_double_type))
return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2));
else if ((t2 == scheme_float_type) && (t1 == scheme_double_type))
return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
return -1;
#ifdef MZ_LONG_DOUBLE
} else if (t1 == scheme_long_double_type) {
return long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
} else if (t1 == scheme_float_type) {
return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
} else if (t1 == scheme_double_type) {
return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
} else if (t1 == scheme_bignum_type)
return scheme_bignum_eq(obj1, obj2);
else if (t1 == scheme_rational_type)
return scheme_rational_eq(obj1, obj2);
else if (t1 == scheme_complex_type) {
Scheme_Complex *c1 = (Scheme_Complex *)obj1;
Scheme_Complex *c2 = (Scheme_Complex *)obj2;
return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
} else if (t1 == scheme_char_type)
return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
else
return -1;
}
static Scheme_Object *
char_to_integer (int argc, Scheme_Object *argv[])
{
mzchar c;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_type("char->integer", "character", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
return scheme_make_integer_value(c);
}
Scheme_Object *
scheme_checked_char_to_integer (int argc, Scheme_Object *argv[])
{
mzchar c;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_contract("char->integer", "char?", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
return scheme_make_integer_value(c);
}
static Scheme_Object *char_general_category (int argc, Scheme_Object *argv[])
{
mzchar c;
int cat;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_type("char-general-category", "character", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
cat = scheme_general_category(c);
return general_category_symbols[cat];
}
Scheme_Object *scheme_make_char(mzchar ch)
{
Scheme_Object *o;
if (ch < 256)
return scheme_char_constants[ch];
o = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Small_Object));
CLEAR_KEY_FIELD(o);
o->type = scheme_char_type;
SCHEME_CHAR_VAL(o) = ch;
return o;
}
static Scheme_Object *char_utf8_length (int argc, Scheme_Object *argv[])
{
mzchar wc;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_type("char-utf-8-length", "character", 0, argc, argv);
wc = SCHEME_CHAR_VAL(argv[0]);
if (wc < 0x80) {
return scheme_make_integer(1);
} else if (wc < 0x800) {
return scheme_make_integer(2);
} else if (wc < 0x10000) {
return scheme_make_integer(3);
} else if (wc < 0x200000) {
return scheme_make_integer(4);
} else if (wc < 0x4000000) {
return scheme_make_integer(5);
} else {
return scheme_make_integer(6);
}
}
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);
}
static Scheme_Object *unsafe_string_set (int argc, Scheme_Object *argv[])
{
SCHEME_CHAR_STR_VAL(argv[0])[SCHEME_INT_VAL(argv[1])] = SCHEME_CHAR_VAL(argv[2]);
return scheme_void;
}
Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht)
{
Scheme_Object *new_so = so;
if (SCHEME_INTP(so)) {
return so;
}
if (ht) {
Scheme_Object *r;
if ((r = scheme_hash_get(ht, so))) {
return r;
}
}
switch (so->type) {
case scheme_true_type:
case scheme_false_type:
case scheme_null_type:
case scheme_void_type:
/* place_bi_channels are allocated in the master and can be passed along as is */
case scheme_place_bi_channel_type:
new_so = so;
break;
case scheme_place_type:
new_so = ((Scheme_Place *) so)->channel;
break;
case scheme_char_type:
new_so = scheme_make_char(SCHEME_CHAR_VAL(so));
break;
case scheme_rational_type:
{
Scheme_Object *n;
Scheme_Object *d;
n = scheme_rational_numerator(so);
d = scheme_rational_denominator(so);
n = scheme_places_deep_copy_worker(n, ht);
d = scheme_places_deep_copy_worker(d, ht);
new_so = scheme_make_rational(n, d);
}
break;
case scheme_float_type:
new_so = scheme_make_float(SCHEME_FLT_VAL(so));
break;
case scheme_double_type:
new_so = scheme_make_double(SCHEME_DBL_VAL(so));
break;
case scheme_complex_type:
{
Scheme_Object *r;
Scheme_Object *i;
r = scheme_complex_real_part(so);
i = scheme_complex_imaginary_part(so);
r = scheme_places_deep_copy_worker(r, ht);
i = scheme_places_deep_copy_worker(i, ht);
new_so = scheme_make_complex(r, i);
}
break;
case scheme_char_string_type:
new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1);
break;
case scheme_byte_string_type:
if (SHARED_ALLOCATEDP(so)) {
new_so = so;
}
else {
new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
}
break;
case scheme_unix_path_type:
new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1);
break;
case scheme_symbol_type:
if (SCHEME_SYM_UNINTERNEDP(so)) {
scheme_log_abort("cannot copy uninterned symbol");
abort();
} else {
new_so = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(so), 0, SCHEME_SYM_LEN(so), 1);
new_so->type = scheme_serialized_symbol_type;
}
break;
case scheme_serialized_symbol_type:
new_so = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(so), SCHEME_BYTE_STRLEN_VAL(so));
break;
case scheme_pair_type:
{
Scheme_Object *car;
Scheme_Object *cdr;
Scheme_Object *pair;
car = scheme_places_deep_copy_worker(SCHEME_CAR(so), ht);
cdr = scheme_places_deep_copy_worker(SCHEME_CDR(so), ht);
pair = scheme_make_pair(car, cdr);
new_so = pair;
}
break;
case scheme_vector_type:
{
Scheme_Object *vec;
intptr_t i;
intptr_t size = SCHEME_VEC_SIZE(so);
vec = scheme_make_vector(size, 0);
for (i = 0; i <size ; i++) {
Scheme_Object *tmp;
tmp = scheme_places_deep_copy_worker(SCHEME_VEC_ELS(so)[i], ht);
SCHEME_VEC_ELS(vec)[i] = tmp;
}
SCHEME_SET_IMMUTABLE(vec);
new_so = vec;
}
break;
case scheme_fxvector_type:
if (SHARED_ALLOCATEDP(so)) {
new_so = so;
}
else {
Scheme_Vector *vec;
intptr_t i;
intptr_t size = SCHEME_FXVEC_SIZE(so);
vec = scheme_alloc_fxvector(size);
for (i = 0; i < size; i++) {
SCHEME_FXVEC_ELS(vec)[i] = SCHEME_FXVEC_ELS(so)[i];
}
new_so = (Scheme_Object *) vec;
}
break;
case scheme_flvector_type:
if (SHARED_ALLOCATEDP(so)) {
new_so = so;
}
else {
Scheme_Double_Vector *vec;
intptr_t i;
intptr_t size = SCHEME_FLVEC_SIZE(so);
vec = scheme_alloc_flvector(size);
for (i = 0; i < size; i++) {
SCHEME_FLVEC_ELS(vec)[i] = SCHEME_FLVEC_ELS(so)[i];
}
new_so = (Scheme_Object *) vec;
}
break;
case scheme_structure_type:
{
Scheme_Structure *st = (Scheme_Structure*)so;
Scheme_Serialized_Structure *nst;
Scheme_Struct_Type *stype = st->stype;
Scheme_Struct_Type *ptype = stype->parent_types[stype->name_pos - 1];
Scheme_Object *nprefab_key;
intptr_t size = stype->num_slots;
int local_slots = stype->num_slots - (ptype ? ptype->num_slots : 0);
int i = 0;
if (!stype->prefab_key) {
scheme_log_abort("cannot copy non prefab structure");
abort();
}
{
for (i = 0; i < local_slots; i++) {
if (!stype->immutables || stype->immutables[i] != 1) {
scheme_log_abort("cannot copy mutable prefab structure");
abort();
}
}
}
nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht);
nst = (Scheme_Serialized_Structure*) scheme_make_serialized_struct_instance(nprefab_key, size);
for (i = 0; i <size ; i++) {
Scheme_Object *tmp;
tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht);
nst->slots[i] = tmp;
}
new_so = (Scheme_Object*) nst;
}
break;
case scheme_serialized_structure_type:
{
Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so;
Scheme_Struct_Type *stype;
Scheme_Structure *nst;
intptr_t size;
int i = 0;
size = st->num_slots;
stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size);
nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype);
for (i = 0; i <size ; i++) {
Scheme_Object *tmp;
tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht);
nst->slots[i] = tmp;
}
new_so = (Scheme_Object*)nst;
}
break;
case scheme_resolved_module_path_type:
default:
printf("places deep copy cannot copy object of type %hi at %p\n", so->type, so);
scheme_log_abort("places deep copy cannot copy object");
abort();
break;
}
if (ht) {
scheme_hash_set(ht, so, new_so);
}
return new_so;
}
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);
}
static Scheme_Object *
interned_char_p (int argc, Scheme_Object *argv[])
{
return (SCHEME_CHARP(argv[0]) && SCHEME_CHAR_VAL(argv[0]) < 256) ? scheme_true : scheme_false;
}