/** * 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; }