1 #include "schpriv.h"
2 #include "schmach.h"
3 #include <string.h>
4 #ifdef USE_STACKAVAIL
5 # include <malloc.c>
6 #endif
7
8 /* global_constants */
9 READ_ONLY Scheme_Object scheme_true[1];
10 READ_ONLY Scheme_Object scheme_false[1];
11
12 READ_ONLY Scheme_Object *scheme_not_proc;
13 READ_ONLY Scheme_Object *scheme_true_object_p_proc;
14 READ_ONLY Scheme_Object *scheme_boolean_p_proc;
15 READ_ONLY Scheme_Object *scheme_eq_proc;
16 READ_ONLY Scheme_Object *scheme_eqv_proc;
17 READ_ONLY Scheme_Object *scheme_equal_proc;
18
19 /* locals */
20 static Scheme_Object *not_prim (int argc, Scheme_Object *argv[]);
21 static Scheme_Object *true_object_p_prim (int argc, Scheme_Object *argv[]);
22 static Scheme_Object *boolean_p_prim (int argc, Scheme_Object *argv[]);
23 static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]);
24 static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
25 static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);
26 static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]);
27 static Scheme_Object *chaperone_p (int argc, Scheme_Object *argv[]);
28 static Scheme_Object *impersonator_p (int argc, Scheme_Object *argv[]);
29 static Scheme_Object *procedure_impersonator_star_p (int argc, Scheme_Object *argv[]);
30 static Scheme_Object *chaperone_of (int argc, Scheme_Object *argv[]);
31 static Scheme_Object *impersonator_of (int argc, Scheme_Object *argv[]);
32
33 typedef struct Equal_Info {
34 /* All pointers, 0, or odd numbers, because it's allocated with scheme_malloc(): */
35 intptr_t depth; /* always odd, so it looks like a fixnum */
36 intptr_t car_depth; /* always odd => fixnum */
37 Scheme_Hash_Table *ht;
38 Scheme_Object *recur;
39 Scheme_Object *next, *next_next;
40 Scheme_Object *insp;
41 intptr_t for_chaperone; /* 3 => for impersonator */
42 } Equal_Info;
43
44 static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
45 static int vector_equal (Scheme_Object *vec1, Scheme_Object *orig_vec1,
46 Scheme_Object *vec2, Scheme_Object *orig_vec2,
47 Equal_Info *eql);
48 static int struct_equal (Scheme_Object *s1, Scheme_Object *orig_s1,
49 Scheme_Object *s2, Scheme_Object *orig_s2,
50 Equal_Info *eql);
51
scheme_init_true_false(void)52 void scheme_init_true_false(void)
53 {
54 scheme_true->type = scheme_true_type;
55 scheme_false->type = scheme_false_type;
56 scheme_void->type = scheme_void_type;
57 }
58
scheme_init_bool(Scheme_Startup_Env * env)59 void scheme_init_bool (Scheme_Startup_Env *env)
60 {
61 Scheme_Object *p;
62
63 REGISTER_SO(scheme_not_proc);
64 REGISTER_SO(scheme_true_object_p_proc);
65 REGISTER_SO(scheme_boolean_p_proc);
66 REGISTER_SO(scheme_eq_proc);
67 REGISTER_SO(scheme_eqv_proc);
68 REGISTER_SO(scheme_equal_proc);
69
70 p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
71 scheme_not_proc = p;
72 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
73 | SCHEME_PRIM_IS_OMITABLE
74 | SCHEME_PRIM_PRODUCES_BOOL);
75 scheme_addto_prim_instance("not", p, env);
76
77 p = scheme_make_folding_prim(true_object_p_prim, "true-object?", 1, 1, 1);
78 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
79 | SCHEME_PRIM_IS_OMITABLE
80 | SCHEME_PRIM_PRODUCES_BOOL);
81 scheme_true_object_p_proc = p;
82 scheme_addto_prim_instance("true-object?", p, env);
83
84 p = scheme_make_folding_prim(boolean_p_prim, "boolean?", 1, 1, 1);
85 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
86 | SCHEME_PRIM_IS_OMITABLE
87 | SCHEME_PRIM_PRODUCES_BOOL);
88 scheme_boolean_p_proc = p;
89 scheme_addto_prim_instance("boolean?", p, env);
90
91 p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
92 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
93 | SCHEME_PRIM_IS_OMITABLE
94 | SCHEME_PRIM_PRODUCES_BOOL);
95 scheme_eq_proc = p;
96 scheme_addto_prim_instance("eq?", p, env);
97
98 p = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1);
99 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
100 | SCHEME_PRIM_IS_OMITABLE
101 | SCHEME_PRIM_PRODUCES_BOOL);
102 scheme_eqv_proc = p;
103 scheme_addto_prim_instance("eqv?", scheme_eqv_proc, env);
104
105 p = scheme_make_noncm_prim(equal_prim, "equal?", 2, 2);
106 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
107 | SCHEME_PRIM_PRODUCES_BOOL);
108 scheme_equal_proc = p;
109 scheme_addto_prim_instance("equal?", scheme_equal_proc, env);
110
111 scheme_addto_prim_instance("equal?/recur",
112 scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3),
113 env);
114
115 p = scheme_make_immed_prim(chaperone_p, "chaperone?", 1, 1);
116 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
117 | SCHEME_PRIM_IS_OMITABLE
118 | SCHEME_PRIM_PRODUCES_BOOL);
119 scheme_addto_prim_instance("chaperone?", p, env);
120
121 p = scheme_make_immed_prim(impersonator_p, "impersonator?", 1, 1);
122 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
123 | SCHEME_PRIM_IS_OMITABLE
124 | SCHEME_PRIM_PRODUCES_BOOL);
125 scheme_addto_prim_instance("impersonator?", p, env);
126 p = scheme_make_immed_prim(procedure_impersonator_star_p, "procedure-impersonator*?", 1, 1);
127 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE
128 | SCHEME_PRIM_PRODUCES_BOOL);
129 scheme_addto_prim_instance("procedure-impersonator*?", p, env);
130
131 scheme_addto_prim_instance("chaperone-of?",
132 scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
133 env);
134 scheme_addto_prim_instance("impersonator-of?",
135 scheme_make_prim_w_arity(impersonator_of, "impersonator-of?", 2, 2),
136 env);
137 }
138
139 static Scheme_Object *
not_prim(int argc,Scheme_Object * argv[])140 not_prim (int argc, Scheme_Object *argv[])
141 {
142 return (SAME_OBJ(argv[0], scheme_false) ? scheme_true : scheme_false);
143 }
144
145 static Scheme_Object *
true_object_p_prim(int argc,Scheme_Object * argv[])146 true_object_p_prim (int argc, Scheme_Object *argv[])
147 {
148 return (SAME_OBJ(argv[0], scheme_true) ? scheme_true : scheme_false);
149 }
150
151 static Scheme_Object *
boolean_p_prim(int argc,Scheme_Object * argv[])152 boolean_p_prim (int argc, Scheme_Object *argv[])
153 {
154 return (SCHEME_BOOLP(argv[0]) ? scheme_true : scheme_false);
155 }
156
157 static Scheme_Object *
eq_prim(int argc,Scheme_Object * argv[])158 eq_prim (int argc, Scheme_Object *argv[])
159 {
160 return (SAME_OBJ(argv[0], argv[1]) ? scheme_true : scheme_false);
161 }
162
163 static Scheme_Object *
eqv_prim(int argc,Scheme_Object * argv[])164 eqv_prim (int argc, Scheme_Object *argv[])
165 {
166 return (scheme_eqv(argv[0], argv[1]) ? scheme_true : scheme_false);
167 }
168
init_equal_info(Equal_Info * eql)169 XFORM_NONGCING static void init_equal_info(Equal_Info *eql)
170 {
171 eql->depth = 1;
172 eql->car_depth = 1;
173 eql->ht = NULL;
174 eql->recur = NULL;
175 eql->next = NULL;
176 eql->next_next = NULL;
177 eql->insp = NULL;
178 eql->for_chaperone = 0;
179 }
180
181 static Scheme_Object *
equal_prim(int argc,Scheme_Object * argv[])182 equal_prim (int argc, Scheme_Object *argv[])
183 {
184 Equal_Info eql;
185
186 init_equal_info(&eql);
187
188 return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
189 }
190
191 static Scheme_Object *
equalish_prim(int argc,Scheme_Object * argv[])192 equalish_prim (int argc, Scheme_Object *argv[])
193 {
194 Equal_Info eql;
195
196 scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv);
197
198 init_equal_info(&eql);
199 eql.next_next = argv[2];
200
201 return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
202 }
203
scheme_eq(Scheme_Object * obj1,Scheme_Object * obj2)204 int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
205 {
206 return SAME_OBJ(obj1, obj2);
207 }
208
209 #ifdef MZ_LONG_DOUBLE
mz_long_double_eqv(long_double a,long_double b)210 XFORM_NONGCING static MZ_INLINE int mz_long_double_eqv(long_double a, long_double b)
211 {
212 # ifndef NAN_EQUALS_ANYTHING
213 if (!long_double_eqv(a, b)) {
214 # endif
215 /* Double-check for NANs: */
216 if (MZ_IS_LONG_NAN(a)) {
217 if (MZ_IS_LONG_NAN(b))
218 return 1;
219 # ifdef NAN_EQUALS_ANYTHING
220 return 0;
221 # endif
222 }
223 # ifdef NAN_EQUALS_ANYTHING
224 if (MZ_IS_LONG_NAN(b))
225 return 0;
226 else {
227 if (long_double_eqv(a, get_long_double_zero())) {
228 if (long_double_eqv(b, get_long_double_zero())) {
229 return scheme_long_minus_zero_p(a) == scheme_long_minus_zero_p(b);
230 }
231 }
232 return long_double_eqv(a, b);
233 }
234 # else
235 return 0;
236 }
237 if (long_double_eqv(a, get_long_double_zero())) {
238 if (long_double_eqv(b, get_long_double_zero())) {
239 return scheme_long_minus_zero_p(a) == scheme_long_minus_zero_p(b);
240 }
241 }
242 return 1;
243 # endif
244 }
245 #endif
double_eqv(double a,double b)246 XFORM_NONGCING static MZ_INLINE int double_eqv(double a, double b)
247 {
248 # ifndef NAN_EQUALS_ANYTHING
249 if (a != b) {
250 # endif
251 /* Double-check for NANs: */
252 if (MZ_IS_NAN(a)) {
253 if (MZ_IS_NAN(b))
254 return 1;
255 # ifdef NAN_EQUALS_ANYTHING
256 return 0;
257 # endif
258 }
259 # ifdef NAN_EQUALS_ANYTHING
260 if (MZ_IS_NAN(b))
261 return 0;
262 else {
263 if (a == 0.0) {
264 if (b == 0.0) {
265 return scheme_minus_zero_p(a) == scheme_minus_zero_p(b);
266 }
267 }
268 return (a == b);
269 }
270 # else
271 return 0;
272 }
273 if (a == 0.0) {
274 if (b == 0.0) {
275 return scheme_minus_zero_p(a) == scheme_minus_zero_p(b);
276 }
277 }
278 return 1;
279 # endif
280 }
281
is_eqv(Scheme_Object * obj1,Scheme_Object * obj2)282 XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
283 {
284 Scheme_Type t1, t2;
285
286 if (SAME_OBJ(obj1, obj2))
287 return 1;
288
289 t1 = SCHEME_TYPE(obj1);
290 t2 = SCHEME_TYPE(obj2);
291
292 if (NOT_SAME_TYPE(t1, t2)) {
293 #ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS
294 /* If one is a float and the other is a double, coerce to double */
295 if ((t1 == scheme_float_type) && (t2 == scheme_double_type))
296 return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2));
297 else if ((t2 == scheme_float_type) && (t1 == scheme_double_type))
298 return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
299 #endif
300 return -1;
301 } else {
302 switch (t1) {
303 #ifdef MZ_LONG_DOUBLE
304 case scheme_long_double_type:
305 return mz_long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
306 #endif
307 #ifdef MZ_USE_SINGLE_FLOATS
308 case scheme_float_type:
309 return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
310 #endif
311 case scheme_double_type:
312 return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
313 case scheme_bignum_type:
314 return scheme_bignum_eq(obj1, obj2);
315 case scheme_rational_type:
316 return scheme_rational_eq(obj1, obj2);
317 case scheme_complex_type:
318 {
319 Scheme_Complex *c1 = (Scheme_Complex *)obj1;
320 Scheme_Complex *c2 = (Scheme_Complex *)obj2;
321 return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
322 }
323 case scheme_char_type:
324 return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
325 case scheme_symbol_type:
326 case scheme_keyword_type:
327 /* `eqv?` requires `eq?` */
328 return 0;
329 default:
330 return -1;
331 }
332 }
333 }
334
scheme_eqv(Scheme_Object * obj1,Scheme_Object * obj2)335 int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
336 {
337 return (is_eqv(obj1, obj2) > 0);
338 }
339
is_fast_equal(Scheme_Object * obj1,Scheme_Object * obj2,int for_chaperone)340 XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int for_chaperone)
341 {
342 Scheme_Type t1, t2;
343 int cmp;
344
345 cmp = is_eqv(obj1, obj2);
346 if (cmp > -1)
347 return cmp;
348
349 t1 = SCHEME_TYPE(obj1);
350 t2 = SCHEME_TYPE(obj2);
351
352 if (NOT_SAME_TYPE(t1, t2))
353 return -1;
354
355 switch (t1) {
356 case scheme_flvector_type:
357 {
358 intptr_t l1, l2, i;
359 l1 = SCHEME_FLVEC_SIZE(obj1);
360 l2 = SCHEME_FLVEC_SIZE(obj2);
361 if (l1 == l2) {
362 for (i = 0; i < l1; i++) {
363 if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
364 SCHEME_FLVEC_ELS(obj2)[i]))
365 return 0;
366 }
367 return 1;
368 }
369 return 0;
370 }
371 #ifdef MZ_LONG_DOUBLE
372 case scheme_extflvector_type:
373 {
374 intptr_t l1, l2, i;
375 l1 = SCHEME_EXTFLVEC_SIZE(obj1);
376 l2 = SCHEME_EXTFLVEC_SIZE(obj2);
377 if (l1 == l2) {
378 for (i = 0; i < l1; i++) {
379 if (!mz_long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
380 SCHEME_EXTFLVEC_ELS(obj2)[i]))
381 return 0;
382 }
383 return 1;
384 }
385 return 0;
386 }
387 #endif
388 case scheme_byte_string_type:
389 case scheme_unix_path_type:
390 case scheme_windows_path_type:
391 {
392 intptr_t l1, l2;
393 if (for_chaperone) return -1;
394 l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
395 l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
396 return ((l1 == l2)
397 && !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
398 }
399 case scheme_char_string_type:
400 {
401 intptr_t l1, l2;
402 if (for_chaperone) return -1;
403 l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
404 l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
405 return ((l1 == l2)
406 && !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
407 }
408 case scheme_cpointer_type:
409 {
410 return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
411 == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
412 }
413 case scheme_place_bi_channel_type:
414 {
415 Scheme_Place_Bi_Channel *bc1, *bc2;
416 bc1 = (Scheme_Place_Bi_Channel *)obj1;
417 bc2 = (Scheme_Place_Bi_Channel *)obj2;
418 return (SAME_OBJ(bc1->link->recvch, bc2->link->recvch)
419 && SAME_OBJ(bc1->link->sendch, bc2->link->sendch));
420 }
421 }
422
423 return -1;
424 }
425
is_slow_equal(Scheme_Object * obj1,Scheme_Object * obj2)426 int is_slow_equal (Scheme_Object *obj1, Scheme_Object *obj2)
427 {
428 Equal_Info eql;
429
430 init_equal_info(&eql);
431
432 return is_equal(obj1, obj2, &eql);
433 }
434
scheme_equal(Scheme_Object * obj1,Scheme_Object * obj2)435 int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2) XFORM_ASSERT_NO_CONVERSION
436 {
437 int v;
438
439 v = is_fast_equal(obj1, obj2, 0);
440 if (v > -1)
441 return v;
442
443 return is_slow_equal(obj1, obj2);
444 }
445
union_find(Scheme_Object * obj1,Scheme_Hash_Table * ht)446 static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht)
447 {
448 Scheme_Object *v, *prev = obj1, *prev_prev = obj1;
449
450 while (1) {
451 v = scheme_hash_get(ht, prev);
452 if (v) {
453 prev_prev = prev;
454 prev = v;
455 } else
456 break;
457 }
458
459 /* Point all items to prev */
460 while (obj1 != prev_prev) {
461 v = scheme_hash_get(ht, obj1);
462 scheme_hash_set(ht, obj1, prev);
463 obj1 = v;
464 }
465
466 return prev;
467 }
468
union_check(Scheme_Object * obj1,Scheme_Object * obj2,Equal_Info * eql)469 static int union_check(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
470 {
471 if (eql->depth < 50) {
472 if (!eql->next_next)
473 eql->depth += 2;
474 return 0;
475 } else {
476 Scheme_Hash_Table *ht = eql->ht;
477 if (!ht) {
478 ht = scheme_make_hash_table(SCHEME_hash_ptr);
479 eql->ht = ht;
480 }
481 obj1 = union_find(obj1, ht);
482 obj2 = union_find(obj2, ht);
483
484 if (SAME_OBJ(obj1, obj2))
485 return 1;
486
487 scheme_hash_set(ht, obj2, obj1);
488
489 return 0;
490 }
491 }
492
equal_k(void)493 static Scheme_Object *equal_k(void)
494 {
495 Scheme_Thread *p = scheme_current_thread;
496 Scheme_Object *v1 = (Scheme_Object *)p->ku.k.p1;
497 Scheme_Object *v2 = (Scheme_Object *)p->ku.k.p2;
498 Equal_Info *eql = (Equal_Info *)p->ku.k.p3;
499
500 p->ku.k.p1 = NULL;
501 p->ku.k.p2 = NULL;
502 p->ku.k.p3 = NULL;
503
504 return is_equal(v1, v2, eql) ? scheme_true : scheme_false;
505 }
506
equal_recur(int argc,Scheme_Object ** argv,Scheme_Object * prim)507 static Scheme_Object *equal_recur(int argc, Scheme_Object **argv, Scheme_Object *prim)
508 {
509 Equal_Info *eql = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
510 int is_eq;
511
512 eql->insp = NULL; /* in case the inspector is changed by context */
513
514 is_eq = is_equal(argv[0], argv[1], eql);
515
516 eql->insp = NULL;
517
518 return (is_eq
519 ? scheme_true
520 : scheme_false);
521 }
522
is_equal_overflow(Scheme_Object * obj1,Scheme_Object * obj2,Equal_Info * eql)523 static int is_equal_overflow(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
524 {
525 Scheme_Thread *p = scheme_current_thread;
526 Equal_Info *eql2;
527 Scheme_Object *v;
528
529 eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
530 memcpy(eql2, eql, sizeof(Equal_Info));
531
532 p->ku.k.p1 = (void *)obj1;
533 p->ku.k.p2 = (void *)obj2;
534 p->ku.k.p3 = (void *)eql2;
535
536 v = scheme_handle_stack_overflow(equal_k);
537
538 memcpy(eql, eql2, sizeof(Equal_Info));
539
540 return SCHEME_TRUEP(v);
541 }
542
is_equal(Scheme_Object * obj1,Scheme_Object * obj2,Equal_Info * eql)543 int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
544 {
545 Scheme_Type t1, t2;
546 int cmp;
547 Scheme_Object *orig_obj1, *orig_obj2;
548
549 top:
550 orig_obj1 = obj1;
551 orig_obj2 = obj2;
552
553 if (eql->next_next) {
554 if (eql->next) {
555 Scheme_Object *a[2];
556 a[0] = obj1;
557 a[1] = obj2;
558 obj1 = _scheme_apply(eql->next, 2, a);
559 return SCHEME_TRUEP(obj1);
560 }
561 eql->next = eql->next_next;
562 }
563
564 top_after_next:
565 cmp = is_fast_equal(obj1, obj2, eql->for_chaperone == 1);
566 if (cmp > -1)
567 return cmp;
568
569 if (eql->for_chaperone
570 && SCHEME_CHAPERONEP(obj2)
571 && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj2) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
572 || (eql->for_chaperone > 1))
573 && scheme_is_noninterposing_chaperone(obj2)) {
574 obj2 = ((Scheme_Chaperone *)obj2)->prev;
575 goto top_after_next;
576 }
577
578 if (eql->for_chaperone
579 && SCHEME_CHAPERONEP(obj1)
580 && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
581 || (eql->for_chaperone > 1))) {
582 /* `obj1` and `obj2` are not eq, otherwise is_fast_equal()
583 would have returned true */
584 if (SCHEME_CHAPERONEP(obj2)) {
585 /* for immutable hashes, it's ok for the two objects to not be eq,
586 as long as the interpositions are the same and the underlying
587 values are `{impersonator,chaperone}-of?`: */
588 if (SCHEME_HASHTRP(((Scheme_Chaperone *)obj1)->val)
589 && SCHEME_HASHTRP(((Scheme_Chaperone *)obj2)->val)
590 /* eq redirects means redirects were propagated: */
591 && SAME_OBJ(((Scheme_Chaperone *)obj1)->redirects,
592 ((Scheme_Chaperone *)obj2)->redirects))
593 obj2 = ((Scheme_Chaperone *)obj2)->prev;
594 }
595 obj1 = ((Scheme_Chaperone *)obj1)->prev;
596 goto top_after_next;
597 }
598
599 t1 = SCHEME_TYPE(obj1);
600 t2 = SCHEME_TYPE(obj2);
601
602 if (NOT_SAME_TYPE(t1, t2)) {
603 if (t1 == scheme_hash_tree_indirection_type) {
604 obj1 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj1);
605 goto top_after_next;
606 }
607 if (t2 == scheme_hash_tree_indirection_type) {
608 obj2 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj2);
609 goto top_after_next;
610 }
611 if (!eql->for_chaperone) {
612 if (SCHEME_CHAPERONEP(obj1)) {
613 /* OPT only use prev for unsafe-chaperone-vector, use val otherwise */
614 obj1 = ((Scheme_Chaperone *)obj1)->prev;
615 goto top_after_next;
616 }
617 if (SCHEME_CHAPERONEP(obj2)) {
618 obj2 = ((Scheme_Chaperone *)obj2)->val;
619 goto top_after_next;
620 }
621 }
622 return 0;
623 } else {
624 switch (t1) {
625 case scheme_pair_type:
626 {
627 # include "mzeqchk.inc"
628 if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
629 if (union_check(obj1, obj2, eql))
630 return 1;
631 }
632 eql->car_depth += 2;
633 if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
634 eql->car_depth -= 2;
635 obj1 = SCHEME_CDR(obj1);
636 obj2 = SCHEME_CDR(obj2);
637 goto top;
638 } else
639 return 0;
640 }
641 case scheme_mutable_pair_type:
642 {
643 # include "mzeqchk.inc"
644 if (eql->for_chaperone == 1)
645 return 0;
646 if (union_check(obj1, obj2, eql))
647 return 1;
648 if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
649 obj1 = SCHEME_CDR(obj1);
650 obj2 = SCHEME_CDR(obj2);
651 goto top;
652 } else
653 return 0;
654 }
655 case scheme_vector_type:
656 case scheme_fxvector_type:
657 {
658 # include "mzeqchk.inc"
659 if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
660 || !SCHEME_IMMUTABLEP(obj2)))
661 return 0;
662 if (union_check(obj1, obj2, eql))
663 return 1;
664 return vector_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
665 }
666 case scheme_byte_string_type:
667 case scheme_unix_path_type:
668 case scheme_windows_path_type:
669 {
670 intptr_t l1, l2;
671 if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
672 || !SCHEME_IMMUTABLEP(obj2)))
673 return 0;
674 l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
675 l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
676 return ((l1 == l2)
677 && !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
678 }
679 case scheme_char_string_type:
680 {
681 intptr_t l1, l2;
682 if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
683 || !SCHEME_IMMUTABLEP(obj2)))
684 return 0;
685 l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
686 l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
687 return ((l1 == l2)
688 && !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
689 }
690 case scheme_regexp_type:
691 {
692 if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
693 return 0;
694 if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
695 return 0;
696 obj1 = scheme_regexp_source(obj1);
697 obj2 = scheme_regexp_source(obj2);
698 goto top;
699 }
700 case scheme_structure_type:
701 case scheme_proc_struct_type:
702 {
703 Scheme_Struct_Type *st1, *st2;
704 Scheme_Object *procs1, *procs2;
705
706 st1 = SCHEME_STRUCT_TYPE(obj1);
707 st2 = SCHEME_STRUCT_TYPE(obj2);
708
709 if (eql->for_chaperone == 1)
710 procs1 = NULL;
711 else
712 procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
713 if (procs1)
714 procs1 = scheme_apply_impersonator_of(eql->for_chaperone, procs1, obj1);
715 if (eql->for_chaperone)
716 procs2 = NULL;
717 else {
718 procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
719 if (procs2)
720 procs2 = scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2);
721 }
722
723 if (procs1 || procs2) {
724 /* impersonator-of property trumps other forms of checking */
725 if (procs1) { obj1 = procs1; orig_obj1 = obj1; }
726 if (procs2) { obj2 = procs2; orig_obj2 = obj2; }
727 goto top_after_next;
728 } else {
729 /* don't discard `prop:impersonator-of` if checking for `impersonator-of?`
730 or `chaperone-of?` */
731 if (eql->for_chaperone) {
732 procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
733 if (procs2 && scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2))
734 return 0;
735 }
736
737 procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
738 if (procs1 && (st1 != st2)) {
739 procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
740 if (!procs2
741 || !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
742 procs1 = NULL;
743 }
744
745 if (procs1) {
746 /* Has an equality property: */
747 Scheme_Object *a[3], *recur;
748 Equal_Info *eql2;
749 # include "mzeqchk.inc"
750
751 if (union_check(obj1, obj2, eql))
752 return 1;
753
754 /* Create/cache closure to use for recursive equality checks: */
755 if (eql->recur) {
756 recur = eql->recur;
757 eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
758 } else {
759 eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
760 a[0] = (Scheme_Object *)eql2;
761 recur = scheme_make_prim_closure_w_arity(equal_recur,
762 1, a,
763 "equal?/recur",
764 2, 2);
765 eql->recur = recur;
766 }
767 memcpy(eql2, eql, sizeof(Equal_Info));
768
769 a[0] = orig_obj1;
770 a[1] = orig_obj2;
771 a[2] = recur;
772
773 procs1 = SCHEME_VEC_ELS(procs1)[1];
774
775 recur = _scheme_apply(procs1, 3, a);
776
777 memcpy(eql, eql2, sizeof(Equal_Info));
778
779 return SCHEME_TRUEP(recur);
780 } else if (st1 != st2) {
781 return 0;
782 } else if ((eql->for_chaperone == 1)
783 && !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
784 return 0;
785 } else {
786 /* Same types, but doesn't have an equality property
787 (or checking for chaperone), so check transparency: */
788 Scheme_Object *insp;
789 if (scheme_struct_is_transparent(obj1))
790 insp = NULL;
791 else {
792 insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
793 }
794 if (!insp || scheme_inspector_sees_part(obj1, insp, -2)) {
795 # include "mzeqchk.inc"
796 if (union_check(obj1, obj2, eql))
797 return 1;
798 return struct_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
799 } else
800 return 0;
801 }
802 }
803 }
804 case scheme_box_type:
805 {
806 SCHEME_USE_FUEL(1);
807 if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
808 || !SCHEME_IMMUTABLEP(obj2)))
809 return 0;
810 if (union_check(obj1, obj2, eql))
811 return 1;
812 if (SAME_OBJ(obj1, orig_obj1))
813 obj1 = SCHEME_BOX_VAL(obj1);
814 else
815 obj1 = scheme_unbox(orig_obj1);
816 if (SAME_OBJ(obj2, orig_obj2))
817 obj2 = SCHEME_BOX_VAL(obj2);
818 else
819 obj2 = scheme_unbox(orig_obj2);
820 goto top;
821 }
822 case scheme_hash_table_type:
823 {
824 # include "mzeqchk.inc"
825 if (eql->for_chaperone == 1)
826 return 0;
827 if (union_check(obj1, obj2, eql))
828 return 1;
829 return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, orig_obj1,
830 (Scheme_Hash_Table *)obj2, orig_obj2,
831 eql);
832 }
833 case scheme_hash_tree_type:
834 case scheme_eq_hash_tree_type:
835 case scheme_eqv_hash_tree_type:
836 case scheme_hash_tree_indirection_type:
837 {
838 # include "mzeqchk.inc"
839 if (union_check(obj1, obj2, eql))
840 return 1;
841 return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, orig_obj1,
842 (Scheme_Hash_Tree *)obj2, orig_obj2,
843 eql);
844 }
845 case scheme_bucket_table_type:
846 {
847 # include "mzeqchk.inc"
848 if (eql->for_chaperone == 1)
849 return 0;
850 if (union_check(obj1, obj2, eql))
851 return 1;
852 return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, orig_obj1,
853 (Scheme_Bucket_Table *)obj2, orig_obj2,
854 eql);
855 }
856 default:
857 if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
858 || (t1 == scheme_proc_chaperone_type))) {
859 /* both chaperones */
860 obj1 = ((Scheme_Chaperone *)obj1)->val;
861 obj2 = ((Scheme_Chaperone *)obj2)->val;
862 goto top_after_next;
863 } else {
864 Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
865 if (eqlp) {
866 if (union_check(obj1, obj2, eql))
867 return 1;
868 return eqlp(obj1, obj2, eql);
869 } else
870 return 0;
871 }
872 }
873 }
874 }
875
vector_equal(Scheme_Object * vec1,Scheme_Object * orig_vec1,Scheme_Object * vec2,Scheme_Object * orig_vec2,Equal_Info * eql)876 static int vector_equal(Scheme_Object *vec1, Scheme_Object *orig_vec1,
877 Scheme_Object *vec2, Scheme_Object *orig_vec2,
878 Equal_Info *eql)
879 {
880 intptr_t i, len;
881 Scheme_Object *v1, *v2;
882
883 len = SCHEME_VEC_SIZE(vec1);
884 if (len != SCHEME_VEC_SIZE(vec2))
885 return 0;
886
887 SCHEME_USE_FUEL(len);
888
889 for (i = 0; i < len; i++) {
890 if (SAME_OBJ(vec1, orig_vec1))
891 v1 = SCHEME_VEC_ELS(vec1)[i];
892 else
893 v1 = scheme_chaperone_vector_ref(orig_vec1, i);
894 if (SAME_OBJ(vec2, orig_vec2))
895 v2 = SCHEME_VEC_ELS(vec2)[i];
896 else
897 v2 = scheme_chaperone_vector_ref(orig_vec2, i);
898
899 if (!is_equal(v1, v2, eql))
900 return 0;
901 }
902
903 return 1;
904 }
905
struct_equal(Scheme_Object * s1,Scheme_Object * orig_s1,Scheme_Object * s2,Scheme_Object * orig_s2,Equal_Info * eql)906 int struct_equal (Scheme_Object *s1, Scheme_Object *orig_s1,
907 Scheme_Object *s2, Scheme_Object *orig_s2,
908 Equal_Info *eql)
909 {
910 Scheme_Object *v1, *v2;
911 int i;
912
913 for (i = SCHEME_STRUCT_NUM_SLOTS(((Scheme_Structure *)s1)); i--; ) {
914 if (SAME_OBJ(s1, orig_s1))
915 v1 = ((Scheme_Structure *)s1)->slots[i];
916 else
917 v1 = scheme_struct_ref(orig_s1, i);
918 if (SAME_OBJ(s2, orig_s2))
919 v2 = ((Scheme_Structure *)s2)->slots[i];
920 else
921 v2 = scheme_struct_ref(orig_s2, i);
922
923 if (!is_equal(v1, v2, eql))
924 return 0;
925 }
926
927 return 1;
928 }
929
scheme_recur_equal(Scheme_Object * obj1,Scheme_Object * obj2,void * cycle_info)930 int scheme_recur_equal(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info)
931 {
932 return is_equal(obj1, obj2, (Equal_Info *)cycle_info);
933 }
934
935 /* used by external programs that cannot link to variables */
scheme_make_true(void)936 Scheme_Object * scheme_make_true (void)
937 {
938 return scheme_true;
939 }
940
scheme_make_false(void)941 Scheme_Object * scheme_make_false (void)
942 {
943 return scheme_false;
944 }
945
chaperone_p(int argc,Scheme_Object * argv[])946 static Scheme_Object *chaperone_p(int argc, Scheme_Object *argv[])
947 {
948 return ((SCHEME_CHAPERONEP(argv[0])
949 && !(SCHEME_CHAPERONE_FLAGS(((Scheme_Chaperone *)argv[0])) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
950 ? scheme_true
951 : scheme_false);
952 }
953
impersonator_p(int argc,Scheme_Object * argv[])954 static Scheme_Object *impersonator_p(int argc, Scheme_Object *argv[])
955 {
956 return (SCHEME_CHAPERONEP(argv[0]) ? scheme_true : scheme_false);
957 }
958
959 /* Was this value created with `impersonate-procedure*` or `chaperone-procedure*`? */
procedure_impersonator_star_p(int argc,Scheme_Object * argv[])960 static Scheme_Object *procedure_impersonator_star_p(int argc, Scheme_Object *argv[])
961 {
962 Scheme_Vector *redirects;
963 if (SCHEME_CHAPERONEP(argv[0])) {
964 redirects = (Scheme_Vector *)(((Scheme_Chaperone *)(argv[0]))->redirects);
965 if ((SCHEME_VEC_SIZE(redirects) % 2 == 1) /* odd size => procedure chaperone */
966 && ((SCHEME_VEC_SIZE(redirects) == 5) /* size 5 => we are a chap/imp* */
967 || SCHEME_IMMUTABLEP(redirects))) { /* immutable => chap/imp* in our ancestry */
968 return scheme_true;
969 }
970 }
971 return scheme_false;
972 }
973
chaperone_of(int argc,Scheme_Object * argv[])974 static Scheme_Object *chaperone_of(int argc, Scheme_Object *argv[])
975 {
976 return (scheme_chaperone_of(argv[0], argv[1]) ? scheme_true : scheme_false);
977 }
978
impersonator_of(int argc,Scheme_Object * argv[])979 static Scheme_Object *impersonator_of(int argc, Scheme_Object *argv[])
980 {
981 return (scheme_impersonator_of(argv[0], argv[1]) ? scheme_true : scheme_false);
982 }
983
scheme_chaperone_of(Scheme_Object * obj1,Scheme_Object * obj2)984 int scheme_chaperone_of(Scheme_Object *obj1, Scheme_Object *obj2)
985 {
986 Equal_Info eql;
987
988 init_equal_info(&eql);
989 eql.for_chaperone = 1;
990
991 return is_equal(obj1, obj2, &eql);
992 }
993
scheme_impersonator_of(Scheme_Object * obj1,Scheme_Object * obj2)994 int scheme_impersonator_of(Scheme_Object *obj1, Scheme_Object *obj2)
995 {
996 Equal_Info eql;
997
998 init_equal_info(&eql);
999 eql.for_chaperone = 3;
1000
1001 return is_equal(obj1, obj2, &eql);
1002 }
1003
scheme_apply_impersonator_of(int for_chaperone,Scheme_Object * procs,Scheme_Object * obj)1004 Scheme_Object *scheme_apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
1005 {
1006 Scheme_Object *a[1], *v, *oprocs;
1007
1008 a[0] = obj;
1009 v = _scheme_apply(SCHEME_CDR(procs), 1, a);
1010
1011 if (SCHEME_FALSEP(v))
1012 return NULL;
1013
1014 oprocs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);
1015 if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
1016 scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
1017 "impersonator-of property procedure returned a value with a different prop:impersonator-of source",
1018 "original value", 1, obj,
1019 "returned value", 1, v,
1020 NULL);
1021
1022 procs = scheme_struct_type_property_ref(scheme_equal_property, obj);
1023 oprocs = scheme_struct_type_property_ref(scheme_equal_property, v);
1024 if (procs || oprocs)
1025 if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0],
1026 SCHEME_VEC_ELS(procs)[0]))
1027 scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
1028 "impersonator-of property procedure returned a value with a different prop:equal+hash source",
1029 "original value", 1, obj,
1030 "returned value", 1, v,
1031 NULL);
1032
1033 return v;
1034 }
1035