int
scheme_is_zero(const Scheme_Object *o)
{
Scheme_Type t;
if (SCHEME_INTP(o))
return o == zeroi;
t = _SCHEME_TYPE(o);
#ifdef MZ_USE_SINGLE_FLOATS
if (t == scheme_float_type) {
# ifdef NAN_EQUALS_ANYTHING
if (MZ_IS_NAN(SCHEME_FLT_VAL(o)))
return 0;
# endif
return SCHEME_FLT_VAL(o) == 0.0f;
}
#endif
if (t == scheme_double_type) {
#ifdef NAN_EQUALS_ANYTHING
if (MZ_IS_NAN(SCHEME_DBL_VAL(o)))
return 0;
#endif
return SCHEME_DBL_VAL(o) == 0.0;
}
if (t == scheme_complex_type) {
if (scheme_is_zero(scheme_complex_imaginary_part(o)))
return scheme_is_zero(scheme_complex_real_part(o));
return 0;
}
if ((t >= scheme_bignum_type) && (t <= scheme_complex_type))
return 0;
return -1;
}
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;
}
