Scheme_Object *scheme_make_sema_repost(Scheme_Object *sema)
{
Scheme_Object *o;
o = scheme_alloc_small_object();
o->type = scheme_semaphore_repost_type;
SCHEME_PTR_VAL(o) = sema;
return o;
}
static Scheme_Linklet *eval_linklet_string(const char *str, intptr_t len, int extract)
{
Scheme_Object *port, *expr;
if (len < 0)
len = strlen(str);
port = scheme_make_sized_byte_string_input_port(str, -len); /* negative means it's constant */
expr = scheme_internal_read(port, 1, 1, -1, scheme_init_load_on_demand ? scheme_true : scheme_false);
if (extract) {
/* expr is a linklet bundle; 'startup is mapped to the linklet */
return (Scheme_Linklet *)scheme_hash_tree_get((Scheme_Hash_Tree *)SCHEME_PTR_VAL(expr),
scheme_intern_symbol("startup"));
} else {
return scheme_compile_and_optimize_linklet(scheme_datum_to_syntax(expr, scheme_false, 0),
scheme_intern_symbol("startup"));
}
}
static Scheme_Object *sema_for_repost(Scheme_Object *s, int *repost)
{
*repost = 1;
return SCHEME_PTR_VAL(s);
}
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;
}
}
long scheme_count_memory(Scheme_Object *root, Scheme_Hash_Table *ht)
{
Scheme_Type type;
long s = sizeof(Scheme_Simple_Object), e = 0;
int need_align = 0;
struct GC_Set *home;
if (!root || SCHEME_INTP(root))
return 0;
type = SCHEME_TYPE(root);
if (type >= _scheme_last_type_)
return 0;
if (ht && scheme_hash_get(ht, root))
return 0;
home = GC_set(root);
#if CAN_TRACE_HOME
if ((home != real_tagged)
&& (home != tagged_atomic)
&& (home != tagged_uncollectable)
&& (home != tagged_eternal)) {
scheme_console_printf("Bad Scheme object: %lx\n", (unsigned long)root);
return 0;
}
#endif
if (ht)
scheme_hash_set(ht, root, scheme_true);
#define COUNT(x) (ht ? scheme_count_memory((Scheme_Object *)x, ht) : 0)
switch (type) {
case scheme_variable_type:
s = sizeof(Scheme_Bucket);
#if FORCE_SUBPARTS
e = COUNT(((Scheme_Bucket *)root)->key)
+ COUNT(((Scheme_Bucket *)root)->val);
#endif
break;
case scheme_local_type:
case scheme_local_unbox_type:
s = sizeof(Scheme_Local);
break;
case scheme_syntax_type:
#if FORCE_KNOWN_SUBPARTS
e = COUNT(SCHEME_IPTR_VAL(root));
#endif
break;
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)root;
int i;
s = sizeof(Scheme_App_Rec) + (app->num_args * sizeof(Scheme_Object *))
+ (app->num_args + 1);
need_align = 1;
#if FORCE_KNOWN_SUBPARTS
e = COUNT(app->args[0]);
for (i = 1; i <= app->num_args; i++) {
e += COUNT(app->args[i]);
}
#endif
}
break;
case scheme_sequence_type:
case scheme_case_lambda_sequence_type:
case scheme_begin0_sequence_type:
{
Scheme_Sequence *seq = (Scheme_Sequence *)root;
int i;
s = sizeof(Scheme_Sequence) + (seq->count - 1) * sizeof(Scheme_Object *);
#if FORCE_KNOWN_SUBPARTS
for (i = e = 0; i < seq->count; i++) {
e += COUNT(seq->array[i]);
}
#endif
}
break;
case scheme_branch_type:
{
Scheme_Branch_Rec *rec = (Scheme_Branch_Rec *)root;
s = sizeof(Scheme_Branch_Rec);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(rec->test) + COUNT(rec->tbranch) + COUNT(rec->fbranch);
#endif
}
break;
case scheme_unclosed_procedure_type:
case scheme_compiled_unclosed_procedure_type:
{
Scheme_Closure_Data *data =
(Scheme_Closure_Data *)root;
s = sizeof(Scheme_Closure_Data);
s += data->closure_size * sizeof(mzshort);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(data->code);
#endif
}
break;
case scheme_let_value_type:
{
Scheme_Let_Value *let = (Scheme_Let_Value *)root;
s = sizeof(Scheme_Let_Value);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->value) + COUNT(let->body);
#endif
}
break;
case scheme_compiled_let_value_type:
{
Scheme_Compiled_Let_Value *let = (Scheme_Compiled_Let_Value *)root;
s = sizeof(Scheme_Compiled_Let_Value);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->value) + COUNT(let->body);
#endif
}
break;
case scheme_let_void_type:
{
Scheme_Let_Void *let = (Scheme_Let_Void *)root;
s = sizeof(Scheme_Let_Void);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->body);
#endif
}
break;
case scheme_compiled_let_void_type:
{
Scheme_Let_Header *let = (Scheme_Let_Header *)root;
s = sizeof(Scheme_Let_Header);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->body);
#endif
}
break;
case scheme_letrec_type:
{
Scheme_Letrec *let = (Scheme_Letrec *)root;
int i;
s = sizeof(Scheme_Letrec);
s += let->count * sizeof(Scheme_Object *);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(let->body);
for (i = 0; i < let->count; i++) {
e += COUNT(let->procs[i]);
}
#endif
}
break;
case scheme_char_type:
s = sizeof(Scheme_Small_Object);
break;
case scheme_integer_type:
s = 0;
break;
case scheme_double_type:
s = sizeof(Scheme_Double);
break;
case scheme_float_type:
break;
case scheme_char_string_type:
s += (SCHEME_CHAR_STRTAG_VAL(root) + 1) * sizeof(mzchar);
need_align = 1;
break;
case scheme_byte_string_type:
s += SCHEME_BYTE_STRTAG_VAL(root) + 1;
need_align = 1;
break;
case scheme_symbol_type:
s = sizeof(Scheme_Symbol) + SCHEME_SYM_LEN(root) - 1;
need_align = 1;
break;
case scheme_null_type:
break;
case scheme_pair_type:
#if FORCE_KNOWN_SUBPARTS
e = COUNT(SCHEME_CAR(root)) + COUNT(SCHEME_CDR(root));
#endif
break;
case scheme_vector_type:
{
int count = SCHEME_VEC_SIZE(root), i;
Scheme_Object **array = SCHEME_VEC_ELS(root);
s += count * sizeof(Scheme_Object*);
#if FORCE_KNOWN_SUBPARTS
for (i = e = 0; i < count; i++) {
e += COUNT(array[i]);
}
#endif
}
break;
case scheme_prim_type:
{
if (((Scheme_Primitive_Proc *)root)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
s = sizeof(Scheme_Prim_W_Result_Arity);
else
s = sizeof(Scheme_Primitive_Proc);
}
break;
case scheme_closure_type:
{
Scheme_Closure_Data *data;
Scheme_Object **vals;
data = SCHEME_COMPILED_CLOS_CODE(root);
vals = SCHEME_COMPILED_CLOS_ENV(root);
s += (data->closure_size * sizeof(Scheme_Object *));
#if FORCE_KNOWN_SUBPARTS
e = COUNT(data) + scheme_count_closure(vals, data->closure_size, ht);
#endif
}
break;
case scheme_closed_prim_type:
{
if (((Scheme_Closed_Primitive_Proc *)root)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
s = sizeof(Scheme_Closed_Prim_W_Result_Arity);
else
s = sizeof(Scheme_Closed_Primitive_Proc);
}
break;
case scheme_cont_type:
{
Scheme_Cont *c = (Scheme_Cont *)root;
Scheme_Saved_Stack *rs;
s = sizeof(Scheme_Cont);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(c->home);
#endif
for (rs = c->runstack_copied; rs; rs = rs->prev) {
s += sizeof(Scheme_Saved_Stack);
scheme_count_closure(rs->runstack,
rs->runstack_size
- (rs->runstack
- rs->runstack_start),
ht);
}
}
break;
case scheme_input_port_type:
scheme_count_input_port(root, &s, &e, ht);
break;
case scheme_output_port_type:
scheme_count_output_port(root, &s, &e, ht);
break;
case scheme_eof_type:
case scheme_true_type:
case scheme_false_type:
case scheme_void_type:
case scheme_undefined_type:
/* Only one */
break;
case scheme_syntax_compiler_type:
break;
case scheme_macro_type:
case scheme_set_macro_type:
s = sizeof(Scheme_Small_Object);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(SCHEME_PTR_VAL(root));
#endif
break;
case scheme_box_type:
s = sizeof(Scheme_Small_Object);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(SCHEME_BOX_VAL(root));
#endif
break;
case scheme_will_executor_type:
s = sizeof(Scheme_Simple_Object);
break;
case scheme_custodian_type:
{
Scheme_Custodian *m = (Scheme_Custodian *)root;
s = sizeof(Scheme_Custodian);
e = m->alloc * (sizeof(Scheme_Object **)
+ sizeof(Scheme_Custodian_Reference *)
+ sizeof(void *)
+ sizeof(void *));
}
break;
case scheme_thread_type:
{
Scheme_Thread *p = (Scheme_Thread *)root;
Scheme_Saved_Stack *saved;
s = sizeof(Scheme_Thread)
+ ((p->runstack_size + p->tail_buffer_size) * sizeof(Scheme_Object *));
#if FORCE_KNOWN_SUBPARTS
e = COUNT(p->init_config);
#endif
/* Check stack: */
scheme_count_closure(p->runstack, /* p->runstack may be wrong, but count_closure is turned off */
p->runstack_size
- (p->runstack
- p->runstack_start),
ht);
for (saved = p->runstack_saved; saved; saved = saved->prev) {
s += (saved->runstack_size * sizeof(Scheme_Object *));
scheme_count_closure(saved->runstack,
saved->runstack_size
- (saved->runstack
- saved->runstack_start),
ht);
}
}
break;
case scheme_namespace_type:
{
Scheme_Env *env = (Scheme_Env *)root;
s = sizeof(Scheme_Env);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(env->toplevel);
#endif
}
break;
case scheme_config_type:
{
s = sizeof(Scheme_Config) + (sizeof(Scheme_Object *) * __MZCONFIG_BUILTIN_COUNT__);
#if FORCE_SUBPARTS
{
Scheme_Config *c = (Scheme_Config *)root;
int i;
e = COUNT(c->extensions) + COUNT(c->base);
for (i = 0; i < __MZCONFIG_BUILTIN_COUNT__; i++) {
e += COUNT(*c->configs[i]);
}
}
#endif
}
break;
case scheme_proc_struct_type:
case scheme_structure_type:
{
Scheme_Object **slots = ((Scheme_Structure *)root)->slots;
int i, count = SCHEME_STRUCT_NUM_SLOTS(root);
s = sizeof(Scheme_Structure) + (count - 1) * sizeof(Scheme_Object *);
#if FORCE_KNOWN_SUBPARTS
for (i = e = 0; i < count; i++) {
e += COUNT(slots[i]);
}
e += COUNT(((Scheme_Structure *)root)->stype);
#endif
}
break;
case scheme_bignum_type:
{
int count = SCHEME_BIGLEN(root);
if (count < 0)
count = -count;
s = sizeof(Small_Bignum) + (count - 1) * sizeof(bigdig);
}
break;
case scheme_escaping_cont_type:
s = sizeof(Scheme_Escaping_Cont);
break;
case scheme_sema_type:
s = sizeof(Scheme_Sema);
break;
case scheme_compilation_top_type:
s = sizeof(Scheme_Compilation_Top);
break;
case scheme_hash_table_type:
{
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)root;
s = sizeof(Scheme_Hash_Table)
+ ht->size * sizeof(Scheme_Object *);
#if FORCE_SUBPARTS
{
int i;
for (i = e = 0; i < ht->size; i++) {
if (ht->buckets[i]) {
if (ht->by_address)
e += COUNT(ht->buckets[i]);
else
e += COUNT(ht->buckets[i]->val);
}
}
}
#endif
}
break;
case scheme_weak_box_type:
s = sizeof(Scheme_Small_Object);
e = COUNT(SCHEME_BOX_VAL(root));
break;
case scheme_complex_type:
case scheme_complex_izi_type:
s = sizeof(Scheme_Complex);
e = COUNT(((Scheme_Complex *)root)->r) + COUNT(((Scheme_Complex *)root)->i);
break;
case scheme_rational_type:
s = sizeof(Scheme_Rational);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(((Scheme_Rational *)root)->num)
+ COUNT(((Scheme_Rational *)root)->denom);
#endif
break;
case scheme_struct_type_type:
{
Scheme_Struct_Type *st = (Scheme_Struct_Type *)root;
s = sizeof(Scheme_Struct_Type) + st->name_pos * sizeof(Scheme_Object*);
#if FORCE_KNOWN_SUBPARTS
e = COUNT(st->name);
if (st->name_pos)
e += COUNT(st->parent_types[st->name_pos - 1]);
#endif
}
break;
case scheme_listener_type:
s = sizeof(Scheme_Small_Object);
break;
case scheme_random_state_type:
s = 130; /* wild guess */
break;
case scheme_eval_waiting_type:
case scheme_tail_call_waiting_type:
/* Only one */
break;
case scheme_multiple_values_type:
/* Only one */
break;
case scheme_placeholder_type:
s = 0; /* Infrequent */
break;
default:
s = 0;
break;
}
if (need_align) {
/* Round up to sizeof(void*) boundary: */
if (s & (sizeof(void*) - 1))
s += sizeof(void*) - (s & (sizeof(void*) - 1));
}
scheme_memory_count[type]++;
scheme_memory_size[type] += s;
return s;
}
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;
}
}
}
}
