/**
* Given some kind of Scheme string value, convert it to a C string
* If scmval is not a string value, returns NULL.
*/
static char *
scheme_object_to_string (Scheme_Object *scmval)
{
char *str = NULL;
// Char strings are the normal Scheme strings. They need to be
// converted to byte strings.
if (SCHEME_CHAR_STRINGP (scmval))
{
scmval = scheme_char_string_to_byte_string_locale (scmval);
str = SCHEME_BYTE_STR_VAL (scmval);
} // if it's a char string
// Byte strings are easy, but not the typical Scheme strings.
else if (SCHEME_BYTE_STRINGP (scmval))
{
str = SCHEME_BYTE_STR_VAL (scmval);
} // if it's a byte string
// A design decision: We'll treat symbols as strings. (It certainly
// makes things easier for the client.)
else if (SCHEME_SYMBOLP (scmval))
{
str = SCHEME_SYM_VAL (scmval);
} // if it's a symbol
// Everything else is not a string
else
{
// Signal an error by setting the return value to NULL.
str = NULL;
} // if it's not a string
return str;
} // scheme_object_to_string
/**
* Convert a Scheme_Object to a string. Returns NULL if it fails.
*/
char *
tostring (Scheme_Object *obj)
{
if (SCHEME_BYTE_STRINGP (obj))
return SCHEME_BYTE_STR_VAL (obj);
else if (SCHEME_CHAR_STRINGP (obj))
return SCHEME_BYTE_STR_VAL (scheme_char_string_to_byte_string (obj));
else
return NULL;
} // tostring
/**
* Convert a Scheme_Object to a string. Returns NULL if it fails.
*/
char *
tostring (Scheme_Object *obj)
{
if (SCHEME_BYTE_STRINGP (obj))
return SCHEME_BYTE_STR_VAL (obj);
else if (SCHEME_CHAR_STRINGP (obj))
// (scheme_char_string_to_byte_string) to be able to convert it to byte string
return SCHEME_BYTE_STR_VAL (scheme_char_string_to_byte_string (obj));
else
return NULL;
} // tostring
static Scheme_Object *catch_eval_error(int argc, Scheme_Object **argv)
{
Scheme_Object *bs;
if (!SCHEME_CHAR_STRINGP(argv[0]))
scheme_wrong_type("eval-string/catch-error", "string", 0, argc, argv);
bs = scheme_char_string_to_byte_string(argv[0]);
return eval_string_or_get_exn_message(SCHEME_BYTE_STR_VAL(bs));
}
GVariant *
scheme_obj_to_gvariant (Scheme_Object *list)
{
GVariant *rvalue;
Scheme_Object *firstelement;
int length;
long i;
char* rstring;
double rdouble;
rvalue = NULL;
length = scheme_list_length (list);
if (length == 0)
{
return rvalue ;
}
else if (length == 1)
{
// Get the first element of the argument
firstelement = scheme_car (list);
// checking the scheme_type to see whether it is an integer or not
// Eventually see if we can convert this to a switch statement.
if (SCHEME_TYPE (firstelement)== scheme_integer_type)
{
// we saved the return value at &i
scheme_get_int_val (list,&i);
// we concert it to g_variant
rvalue = g_variant_new ("(i)", i);
return rvalue;
} // if it's an integer
else if (SCHEME_TYPE (firstelement) == scheme_char_type)
{
//getting the string out of the scheme_object
rstring = SCHEME_BYTE_STR_VAL(list);
// we will convert it to g_variant
rvalue = g_variant_new_string(rstring);
return rvalue;
} // if it's a character
else if (SCHEME_TYPE (firstelement) == scheme_double_type)
{
//getting the double out of the scheme_object
rdouble = scheme_real_to_double(list);
// we will convert it to g_variant
rvalue = g_variant_new_double(rdouble);
return rvalue;
} // if it's a double
} // if we have a single element
return rvalue;
} // scheme_obj_to_gvariant
static Scheme_Object *fromull(int argc, Scheme_Object **argv)
{
umzlonglong l;
if (!SCHEME_BYTE_STRINGP(argv[0])
|| (SCHEME_BYTE_STRTAG_VAL(argv[0]) != sizeof(umzlonglong)))
scheme_wrong_type("unsigned-long-long-bytes->integer",
"byte string of mzlonglong size",
0, argc, argv);
l = *(umzlonglong *)SCHEME_BYTE_STR_VAL(argv[0]);
return scheme_make_integer_value_from_unsigned_long_long(l);
}
/**
*Translating the scheme_object to gvariant type for the client
*This step is used on sending input values onto the DBus
*/
GVariant *
scheme_obj_to_gvariant (Scheme_Object *list)
{
GVariantBuilder *builder;
GVariant *finalr;
GVariant *rvalue = NULL;
Scheme_Object *firstelement;
int length = 0;
gint32 i;
char* rstring;
double rdouble;
builder = g_variant_builder_new(G_VARIANT_TYPE_TUPLE);
length = scheme_list_length (list);
// rvalue = g_new(GVariant *, length);
if (length == 0)
{
// scheme_signal_error("length 0");
return rvalue ;
} // if
else{
while (length != 0)
{
// Get the first element of the argument
firstelement = scheme_car (list);
list = scheme_cdr(list);
length = scheme_list_length(list);
// checking the scheme_type to see whether it is an integer or not
// Eventually see if we can convert this to a switch statement.
if (SCHEME_INTP (firstelement))
{
// we saved the return value at &i
i = SCHEME_INT_VAL(firstelement);
rvalue = g_variant_new ("i",i);
g_variant_builder_add_value(builder,rvalue);
// return rvalue;
} // if it's an integer
else if (SCHEME_BYTE_STRINGP (firstelement)|| SCHEME_CHAR_STRINGP(firstelement))
{
//scheme_signal_error ("We are in Character");
//getting the string out of the scheme_object
rstring = SCHEME_BYTE_STR_VAL(list);
// we will convert it to g_variant
rvalue = g_variant_new ("(&s)", rstring);
g_variant_builder_add_value(builder, rvalue);
} // if it's a character
else if (SCHEME_TYPE (firstelement) == scheme_double_type)
{
//getting the double out of the scheme_object
rdouble = scheme_real_to_double(list);
// we will convert it to g_variant
rvalue = g_variant_new_double(rdouble);
g_variant_builder_add_value(builder, rvalue);
} // if it's a double
} // while loop
finalr = g_variant_builder_end (builder);
return finalr;
} //else
return finalr;
} // scheme_obj_to_gvariant
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
Scheme_Type t1, t2;
int cmp;
top:
if (eql->next_next) {
if (eql->next) {
Scheme_Object *a[2];
a[0] = obj1;
a[1] = obj2;
obj1 = _scheme_apply(eql->next, 2, a);
return SCHEME_TRUEP(obj1);
}
eql->next = eql->next_next;
}
cmp = is_eqv(obj1, obj2);
if (cmp > -1)
return cmp;
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
|| (eql->for_chaperone > 1))) {
obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top;
}
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2)) {
if (!eql->for_chaperone) {
if (SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->val;
goto top;
}
if (SCHEME_CHAPERONEP(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top;
}
}
return 0;
} else if (t1 == scheme_pair_type) {
# include "mzeqchk.inc"
if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
if (union_check(obj1, obj2, eql))
return 1;
}
eql->car_depth += 2;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
eql->car_depth -= 2;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
} else if (t1 == scheme_mutable_pair_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
} else if ((t1 == scheme_vector_type)
|| (t1 == scheme_fxvector_type)) {
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return vector_equal(obj1, obj2, eql);
} else if (t1 == scheme_flvector_type) {
intptr_t l1, l2, i;
l1 = SCHEME_FLVEC_SIZE(obj1);
l2 = SCHEME_FLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
SCHEME_FLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
} else if ((t1 == scheme_byte_string_type)
|| ((t1 >= scheme_unix_path_type)
&& (t1 <= scheme_windows_path_type))) {
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
} else if (t1 == scheme_char_string_type) {
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
} else if (t1 == scheme_regexp_type) {
if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
return 0;
if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
return 0;
obj1 = scheme_regexp_source(obj1);
obj2 = scheme_regexp_source(obj2);
goto top;
} else if ((t1 == scheme_structure_type)
|| (t1 == scheme_proc_struct_type)) {
Scheme_Struct_Type *st1, *st2;
Scheme_Object *procs1, *procs2;
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
if (eql->for_chaperone == 1)
procs1 = NULL;
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2);
}
if (procs1 || procs2) {
/* impersonator-of property trumps other forms of checking */
if (procs1) obj1 = procs1;
if (procs2) obj2 = procs2;
goto top;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = obj1;
a[1] = obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
if (scheme_inspector_sees_part(obj1, insp, -2)
&& scheme_inspector_sees_part(obj2, insp, -2)) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, obj2, eql);
} else
return 0;
}
}
} else if (t1 == scheme_box_type) {
SCHEME_USE_FUEL(1);
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
obj1 = SCHEME_BOX_VAL(obj1);
obj2 = SCHEME_BOX_VAL(obj2);
goto top;
} else if (t1 == scheme_hash_table_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2, eql);
} else if (t1 == scheme_hash_tree_type) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql);
} else if (t1 == scheme_bucket_table_type) {
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql);
} else if (t1 == scheme_cpointer_type) {
return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
== ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
} else if (t1 == scheme_wrap_chunk_type) {
return vector_equal(obj1, obj2, eql);
} else if (t1 == scheme_resolved_module_path_type) {
obj1 = SCHEME_PTR_VAL(obj1);
obj2 = SCHEME_PTR_VAL(obj2);
goto top;
} else if (t1 == scheme_place_bi_channel_type) {
Scheme_Place_Bi_Channel *bc1, *bc2;
bc1 = (Scheme_Place_Bi_Channel *)obj1;
bc2 = (Scheme_Place_Bi_Channel *)obj2;
return (SAME_OBJ(bc1->recvch, bc2->recvch)
&& SAME_OBJ(bc1->sendch, bc2->sendch));
} else if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) {
/* both chaperones */
obj1 = ((Scheme_Chaperone *)obj1)->val;
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top;
} else {
Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
if (eqlp) {
if (union_check(obj1, obj2, eql))
return 1;
return eqlp(obj1, obj2, eql);
} else
return 0;
}
}
/**
* Convert a Scheme object to a GVariant that will serve as one of
* the parameters of a call go g_dbus_proxy_call_.... Returns NULL
* if it is unable to do the conversion.
*/
static GVariant *
scheme_object_to_parameter (Scheme_Object *obj, gchar *type)
{
gchar *str; // A temporary string
// Special case: Array of bytes
if (g_strcmp0 (type, "ay") == 0)
{
if (SCHEME_BYTE_STRINGP (obj))
{
return g_variant_new_fixed_array (G_VARIANT_TYPE_BYTE,
SCHEME_BYTE_STR_VAL (obj),
SCHEME_BYTE_STRLEN_VAL (obj),
sizeof (guchar));
} // if it's a byte string
} // array of bytes
// Handle normal cases
switch (type[0])
{
// Arrays
case 'a':
return scheme_object_to_array (obj, type);
// Doubles
case 'd':
if (SCHEME_DBLP (obj))
return g_variant_new ("d", SCHEME_DBL_VAL (obj));
else if (SCHEME_FLTP (obj))
return g_variant_new ("d", (double) SCHEME_FLT_VAL (obj));
else if (SCHEME_INTP (obj))
return g_variant_new ("d", (double) SCHEME_INT_VAL (obj));
else if (SCHEME_RATIONALP (obj))
return g_variant_new ("d", (double) scheme_rational_to_double (obj));
else
return NULL;
// 32 bit integers
case 'i':
if (SCHEME_INTP (obj))
return g_variant_new ("i", (int) SCHEME_INT_VAL (obj));
else if (SCHEME_DBLP (obj))
return g_variant_new ("i", (int) SCHEME_DBL_VAL (obj));
else if (SCHEME_FLTP (obj))
return g_variant_new ("i", (int) SCHEME_FLT_VAL (obj));
else if (SCHEME_RATIONALP (obj))
return g_variant_new ("i", (int) scheme_rational_to_double (obj));
else
return NULL;
// Strings
case 's':
str = scheme_object_to_string (obj);
if (str == NULL)
return NULL;
return g_variant_new ("s", str);
// 32 bit unsigned integers
case 'u':
if (SCHEME_INTP (obj))
return g_variant_new ("u", (unsigned int) SCHEME_INT_VAL (obj));
else
return NULL;
// Everything else is currently unsupported
default:
return NULL;
} // switch
} // scheme_object_to_parameter
static Scheme_Object *unsafe_bytes_ref (int argc, Scheme_Object *argv[])
{
intptr_t v;
v = (unsigned char)SCHEME_BYTE_STR_VAL(argv[0])[SCHEME_INT_VAL(argv[1])];
return scheme_make_integer(v);
}
static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[])
{
SCHEME_BYTE_STR_VAL(argv[0])[SCHEME_INT_VAL(argv[1])] = (char)SCHEME_INT_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;
}
Scheme_Object *scheme_places_deserialize_worker(Scheme_Object *so)
{
Scheme_Object *new_so = so;
if (SCHEME_INTP(so)) {
return so;
}
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:
case scheme_char_type:
case scheme_rational_type:
case scheme_float_type:
case scheme_double_type:
case scheme_complex_type:
case scheme_char_string_type:
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_flvector_type:
case scheme_fxvector_type:
new_so = so;
break;
case scheme_symbol_type:
scheme_log_abort("scheme_symbol_type: shouldn't be seen during deserialization step");
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 *tmp;
tmp = scheme_places_deserialize_worker(SCHEME_CAR(so));
SCHEME_CAR(so) = tmp;
tmp = scheme_places_deserialize_worker(SCHEME_CDR(so));
SCHEME_CDR(so) = tmp;
new_so = so;
}
break;
case scheme_vector_type:
{
intptr_t i;
intptr_t size = SCHEME_VEC_SIZE(so);
for (i = 0; i <size ; i++) {
Scheme_Object *tmp;
tmp = scheme_places_deserialize_worker(SCHEME_VEC_ELS(so)[i]);
SCHEME_VEC_ELS(so)[i] = tmp;
}
new_so = so;
}
break;
case scheme_structure_type:
scheme_log_abort("scheme_structure_type: shouldn't be seen during deserialization step");
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_deserialize_worker((Scheme_Object*) st->slots[i]);
nst->slots[i] = tmp;
}
new_so = (Scheme_Object*)nst;
}
break;
case scheme_resolved_module_path_type:
default:
scheme_log_abort("cannot deserialize object");
abort();
break;
}
return new_so;
}
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
Scheme_Type t1, t2;
int cmp;
Scheme_Object *orig_obj1, *orig_obj2;
top:
orig_obj1 = obj1;
orig_obj2 = obj2;
if (eql->next_next) {
if (eql->next) {
Scheme_Object *a[2];
a[0] = obj1;
a[1] = obj2;
obj1 = _scheme_apply(eql->next, 2, a);
return SCHEME_TRUEP(obj1);
}
eql->next = eql->next_next;
}
top_after_next:
cmp = is_fast_equal(obj1, obj2, eql->for_chaperone == 1);
if (cmp > -1)
return cmp;
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj2)
&& scheme_is_noninterposing_chaperone(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->prev;
goto top_after_next;
}
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
|| (eql->for_chaperone > 1))) {
/* `obj1` and `obj2` are not eq, otherwise is_fast_equal()
would have returned true */
if (SCHEME_CHAPERONEP(obj2)) {
/* for immutable hashes, it's ok for the two objects to not be eq,
as long as the interpositions are the same and the underlying
values are `{impersonator,chaperone}-of?`: */
if (SCHEME_HASHTRP(((Scheme_Chaperone *)obj1)->val)
&& SCHEME_HASHTRP(((Scheme_Chaperone *)obj2)->val)
/* eq redirects means redirects were propagated: */
&& SAME_OBJ(((Scheme_Chaperone *)obj1)->redirects,
((Scheme_Chaperone *)obj2)->redirects))
obj2 = ((Scheme_Chaperone *)obj2)->prev;
}
obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top_after_next;
}
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2)) {
if (!eql->for_chaperone) {
if (SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->val;
goto top_after_next;
} else if (t1 == scheme_hash_tree_indirection_type) {
obj1 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj1);
goto top_after_next;
}
if (SCHEME_CHAPERONEP(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next;
} else if (t2 == scheme_hash_tree_indirection_type) {
obj2 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj2);
goto top_after_next;
}
}
return 0;
} else {
switch (t1) {
case scheme_pair_type:
{
# include "mzeqchk.inc"
if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
if (union_check(obj1, obj2, eql))
return 1;
}
eql->car_depth += 2;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
eql->car_depth -= 2;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
}
case scheme_mutable_pair_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
}
case scheme_vector_type:
case scheme_fxvector_type:
{
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return vector_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
}
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
}
case scheme_char_string_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
}
case scheme_regexp_type:
{
if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
return 0;
if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
return 0;
obj1 = scheme_regexp_source(obj1);
obj2 = scheme_regexp_source(obj2);
goto top;
}
case scheme_structure_type:
case scheme_proc_struct_type:
{
Scheme_Struct_Type *st1, *st2;
Scheme_Object *procs1, *procs2;
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
if (eql->for_chaperone == 1)
procs1 = NULL;
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = scheme_apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2);
}
if (procs1 || procs2) {
/* impersonator-of property trumps other forms of checking */
if (procs1) { obj1 = procs1; orig_obj1 = obj1; }
if (procs2) { obj2 = procs2; orig_obj2 = obj2; }
goto top_after_next;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = orig_obj1;
a[1] = orig_obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
if (scheme_struct_is_transparent(obj1))
insp = NULL;
else {
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
}
if (!insp || scheme_inspector_sees_part(obj1, insp, -2)) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
} else
return 0;
}
}
}
case scheme_box_type:
{
SCHEME_USE_FUEL(1);
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (SAME_OBJ(obj1, orig_obj1))
obj1 = SCHEME_BOX_VAL(obj1);
else
obj1 = scheme_unbox(orig_obj1);
if (SAME_OBJ(obj2, orig_obj2))
obj2 = SCHEME_BOX_VAL(obj2);
else
obj2 = scheme_unbox(orig_obj2);
goto top;
}
case scheme_hash_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, orig_obj1,
(Scheme_Hash_Table *)obj2, orig_obj2,
eql);
}
case scheme_hash_tree_type:
case scheme_eq_hash_tree_type:
case scheme_eqv_hash_tree_type:
case scheme_hash_tree_indirection_type:
{
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, orig_obj1,
(Scheme_Hash_Tree *)obj2, orig_obj2,
eql);
}
case scheme_bucket_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, orig_obj1,
(Scheme_Bucket_Table *)obj2, orig_obj2,
eql);
}
case scheme_wrap_chunk_type: {
return vector_equal(obj1, obj1, obj2, obj2, eql);
}
case scheme_resolved_module_path_type:
{
obj1 = SCHEME_PTR_VAL(obj1);
obj2 = SCHEME_PTR_VAL(obj2);
goto top;
}
case scheme_module_index_type:
{
Scheme_Modidx *midx1, *midx2;
# include "mzeqchk.inc"
midx1 = (Scheme_Modidx *)obj1;
midx2 = (Scheme_Modidx *)obj2;
if (eql->eq_for_modidx
&& (SCHEME_FALSEP(midx1->path)
|| SCHEME_FALSEP(midx2->path)))
return 0;
else if (is_equal(midx1->path, midx2->path, eql)) {
obj1 = midx1->base;
obj2 = midx2->base;
goto top;
}
}
case scheme_scope_table_type:
{
Scheme_Scope_Table *mt1 = (Scheme_Scope_Table *)obj1;
Scheme_Scope_Table *mt2 = (Scheme_Scope_Table *)obj2;
if (!is_equal((Scheme_Object *)mt1->simple_scopes, (Scheme_Object *)mt2->simple_scopes, eql))
return 0;
obj1 = mt1->multi_scopes;
obj2 = mt2->multi_scopes;
goto top;
}
default:
if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) {
/* both chaperones */
obj1 = ((Scheme_Chaperone *)obj1)->val;
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next;
} else {
Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
if (eqlp) {
if (union_check(obj1, obj2, eql))
return 1;
return eqlp(obj1, obj2, eql);
} else
return 0;
}
}
}
}
XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int for_chaperone)
{
Scheme_Type t1, t2;
int cmp;
cmp = is_eqv(obj1, obj2);
if (cmp > -1)
return cmp;
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2))
return -1;
switch (t1) {
case scheme_flvector_type:
{
intptr_t l1, l2, i;
l1 = SCHEME_FLVEC_SIZE(obj1);
l2 = SCHEME_FLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
SCHEME_FLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
}
#ifdef MZ_LONG_DOUBLE
case scheme_extflvector_type:
{
intptr_t l1, l2, i;
l1 = SCHEME_EXTFLVEC_SIZE(obj1);
l2 = SCHEME_EXTFLVEC_SIZE(obj2);
if (l1 == l2) {
for (i = 0; i < l1; i++) {
if (!mz_long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
SCHEME_EXTFLVEC_ELS(obj2)[i]))
return 0;
}
return 1;
}
return 0;
}
#endif
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
intptr_t l1, l2;
if (for_chaperone) return -1;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
}
case scheme_char_string_type:
{
intptr_t l1, l2;
if (for_chaperone) return -1;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
}
case scheme_cpointer_type:
{
return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
== ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
}
case scheme_place_bi_channel_type:
{
Scheme_Place_Bi_Channel *bc1, *bc2;
bc1 = (Scheme_Place_Bi_Channel *)obj1;
bc2 = (Scheme_Place_Bi_Channel *)obj2;
return (SAME_OBJ(bc1->link->recvch, bc2->link->recvch)
&& SAME_OBJ(bc1->link->sendch, bc2->link->sendch));
}
}
return -1;
}