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