Back to index

plt-scheme  4.2.1
bool.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 #include "schpriv.h"
00027 #include "schmach.h"
00028 #include <string.h>
00029 #ifdef USE_STACKAVAIL
00030 # include <malloc.c>
00031 #endif
00032 #ifdef USE_IEEE_FP_PREDS
00033 # include <math.h>
00034 #endif
00035 
00036 /* global_constants */
00037 Scheme_Object scheme_true[1];
00038 Scheme_Object scheme_false[1];
00039 
00040 Scheme_Object *scheme_not_prim;
00041 Scheme_Object *scheme_eq_prim;
00042 Scheme_Object *scheme_eqv_prim;
00043 Scheme_Object *scheme_equal_prim;
00044 
00045 /* locals */
00046 static Scheme_Object *not_prim (int argc, Scheme_Object *argv[]);
00047 static Scheme_Object *boolean_p_prim (int argc, Scheme_Object *argv[]);
00048 static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]);
00049 static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
00050 static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);
00051 static Scheme_Object *equalish_prim (int argc, Scheme_Object *argv[]);
00052 
00053 typedef struct Equal_Info {
00054   long depth; /* always odd, so it looks like a fixnum */
00055   long car_depth; /* always odd => fixnum */
00056   Scheme_Hash_Table *ht;
00057   Scheme_Object *recur;
00058   Scheme_Object *next, *next_next;
00059 } Equal_Info;
00060 
00061 static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql);
00062 static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eql);
00063 static int struct_equal (Scheme_Object *s1, Scheme_Object *s2, Equal_Info *eql);
00064 
00065 void scheme_init_true_false(void)
00066 {
00067   scheme_true->type = scheme_true_type;
00068   scheme_false->type = scheme_false_type;
00069   scheme_void->type = scheme_void_type;
00070 }
00071 
00072 void scheme_init_bool (Scheme_Env *env)
00073 {
00074   Scheme_Object *p;
00075 
00076   REGISTER_SO(scheme_not_prim);
00077   REGISTER_SO(scheme_eq_prim);
00078   REGISTER_SO(scheme_eqv_prim);
00079   REGISTER_SO(scheme_equal_prim);
00080 
00081   p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
00082   scheme_not_prim = p;
00083   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00084   scheme_add_global_constant("not", p, env);
00085 
00086   p = scheme_make_folding_prim(boolean_p_prim, "boolean?", 1, 1, 1);
00087   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00088   scheme_add_global_constant("boolean?", p, env);
00089 
00090   p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
00091   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00092   scheme_eq_prim = p;
00093   scheme_add_global_constant("eq?", p, env);
00094 
00095   scheme_eqv_prim = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1);
00096   scheme_add_global_constant("eqv?", scheme_eqv_prim, env);
00097   
00098   scheme_equal_prim = scheme_make_prim_w_arity(equal_prim, "equal?", 2, 2);
00099   scheme_add_global_constant("equal?", scheme_equal_prim, env);
00100 
00101   scheme_add_global_constant("equal?/recur", 
00102                              scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3), 
00103                              env);
00104 }
00105 
00106 static Scheme_Object *
00107 not_prim (int argc, Scheme_Object *argv[])
00108 {
00109   return (SAME_OBJ(argv[0], scheme_false) ? scheme_true : scheme_false);
00110 }
00111 
00112 static Scheme_Object *
00113 boolean_p_prim (int argc, Scheme_Object *argv[])
00114 {
00115   return (SCHEME_BOOLP(argv[0]) ? scheme_true : scheme_false);
00116 }
00117 
00118 static Scheme_Object *
00119 eq_prim (int argc, Scheme_Object *argv[])
00120 {
00121   return (SAME_OBJ(argv[0], argv[1]) ? scheme_true : scheme_false);
00122 }
00123 
00124 static Scheme_Object *
00125 eqv_prim (int argc, Scheme_Object *argv[])
00126 {
00127   return (scheme_eqv(argv[0], argv[1]) ? scheme_true : scheme_false);
00128 }
00129 
00130 static Scheme_Object *
00131 equal_prim (int argc, Scheme_Object *argv[])
00132 {
00133   Equal_Info eql;
00134 
00135   eql.depth = 1;
00136   eql.car_depth = 1;
00137   eql.ht = NULL;
00138   eql.recur = NULL;
00139   eql.next = NULL;
00140   eql.next_next = NULL;
00141 
00142   return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
00143 }
00144 
00145 static Scheme_Object *
00146 equalish_prim (int argc, Scheme_Object *argv[])
00147 {
00148   Equal_Info eql;
00149 
00150   scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv);
00151 
00152   eql.depth = 1;
00153   eql.car_depth = 1;
00154   eql.ht = NULL;
00155   eql.recur = NULL;
00156   eql.next = NULL;
00157   eql.next_next = argv[2];
00158 
00159   return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
00160 }
00161 
00162 int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
00163 {
00164   return SAME_OBJ(obj1, obj2);
00165 }
00166 
00167 XFORM_NONGCING static MZ_INLINE int double_eqv(double a, double b)
00168 {
00169 # ifndef NAN_EQUALS_ANYTHING
00170   if (a != b) {
00171 # endif
00172     /* Double-check for NANs: */
00173     if (MZ_IS_NAN(a)) {
00174       if (MZ_IS_NAN(b))
00175         return 1;
00176 # ifdef NAN_EQUALS_ANYTHING
00177       return 0;
00178 # endif
00179     }
00180 # ifdef NAN_EQUALS_ANYTHING
00181     if (MZ_IS_NAN(b))
00182       return 0;
00183     else {
00184       if (a == 0.0) {
00185         if (b == 0.0) {
00186           return scheme_minus_zero_p(a) == scheme_minus_zero_p(b);
00187         }
00188       }
00189       return (a == b);
00190     }
00191 # else
00192     return 0;
00193   }
00194   if (a == 0.0) {
00195     if (b == 0.0) {
00196       return scheme_minus_zero_p(a) == scheme_minus_zero_p(b);
00197     }
00198   }
00199   return 1;
00200 # endif
00201 }
00202 
00203 int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
00204 {
00205   Scheme_Type t1, t2;
00206 
00207   if (SAME_OBJ(obj1, obj2))
00208     return 1;
00209 
00210   t1 = SCHEME_TYPE(obj1);
00211   t2 = SCHEME_TYPE(obj2);
00212 
00213   if (NOT_SAME_TYPE(t1, t2)) {
00214 #ifdef MZ_USE_SINGLE_FLOATS
00215     /* If one is a float and the other is a double, coerce to double */
00216     if ((t1 == scheme_float_type) && (t2 == scheme_double_type))
00217       return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2));
00218     else if ((t2 == scheme_float_type) && (t1 == scheme_double_type))
00219       return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
00220 #endif
00221     return 0;
00222 #ifdef MZ_USE_SINGLE_FLOATS
00223   } else if (t1 == scheme_float_type) {
00224     return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
00225 #endif
00226   } else if (t1 == scheme_double_type) {
00227     return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
00228   } else if (t1 == scheme_bignum_type)
00229     return scheme_bignum_eq(obj1, obj2);
00230   else if (t1 == scheme_rational_type)
00231     return scheme_rational_eq(obj1, obj2);
00232   else if (t1 == scheme_complex_type) {
00233     Scheme_Complex *c1 = (Scheme_Complex *)obj1;
00234     Scheme_Complex *c2 = (Scheme_Complex *)obj2;
00235     return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
00236   } else if (t1 == scheme_char_type)
00237     return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
00238   else
00239     return 0;
00240 }
00241 
00242 int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
00243 {
00244   Equal_Info eql;
00245 
00246   eql.depth = 1;
00247   eql.car_depth = 1;
00248   eql.ht = NULL;
00249   eql.recur = NULL;
00250   eql.next_next = NULL;
00251   eql.next = NULL;
00252 
00253   return is_equal(obj1, obj2, &eql);
00254 }
00255 
00256 static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht)
00257 {
00258   Scheme_Object *v, *prev = obj1, *prev_prev = obj1;
00259 
00260   while (1) {
00261     v = scheme_hash_get(ht, prev);
00262     if (v) {
00263       prev_prev = prev;
00264       prev = v;
00265     } else 
00266       break;
00267   }
00268 
00269   /* Point all items to prev */
00270   while (obj1 != prev_prev) {
00271     v = scheme_hash_get(ht, obj1);
00272     scheme_hash_set(ht, obj1, prev);
00273     obj1 = v;
00274   }
00275 
00276   return prev;
00277 }
00278 
00279 static int union_check(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) 
00280 {
00281   if (eql->depth < 50) {
00282     if (!eql->next_next)
00283       eql->depth += 2;
00284     return 0;
00285   } else {
00286     Scheme_Hash_Table *ht = eql->ht;
00287     if (!ht) {
00288       ht = scheme_make_hash_table(SCHEME_hash_ptr);
00289       eql->ht = ht;
00290     }
00291     obj1 = union_find(obj1, ht);
00292     obj2 = union_find(obj2, ht);
00293 
00294     if (SAME_OBJ(obj1, obj2))
00295       return 1;
00296 
00297     scheme_hash_set(ht, obj2, obj1);
00298 
00299     return 0;
00300   }
00301 }
00302 
00303 static Scheme_Object *equal_k(void)
00304 {
00305   Scheme_Thread *p = scheme_current_thread;
00306   Scheme_Object *v1 = (Scheme_Object *)p->ku.k.p1;
00307   Scheme_Object *v2 = (Scheme_Object *)p->ku.k.p2;
00308   Equal_Info *eql = (Equal_Info *)p->ku.k.p3;
00309 
00310   p->ku.k.p1 = NULL;
00311   p->ku.k.p2 = NULL;
00312   p->ku.k.p3 = NULL;
00313 
00314   return is_equal(v1, v2, eql) ? scheme_true : scheme_false;
00315 }
00316 
00317 static Scheme_Object *equal_recur(int argc, Scheme_Object **argv, Scheme_Object *prim)
00318 {
00319   Equal_Info *eql = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
00320 
00321   return (is_equal(argv[0], argv[1], eql)
00322           ? scheme_true
00323           : scheme_false);
00324 }
00325 
00326 static int is_equal_overflow(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
00327 {
00328   Scheme_Thread *p = scheme_current_thread;
00329   Equal_Info *eql2;
00330   Scheme_Object *v;
00331 
00332   eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
00333   memcpy(eql2, eql, sizeof(Equal_Info));
00334 
00335   p->ku.k.p1 = (void *)obj1;
00336   p->ku.k.p2 = (void *)obj2;
00337   p->ku.k.p3 = (void *)eql2;
00338 
00339   v = scheme_handle_stack_overflow(equal_k);
00340 
00341   memcpy(eql, eql2, sizeof(Equal_Info));
00342   
00343   return SCHEME_TRUEP(v);
00344 }
00345 
00346 /* Number of lists/vectors/structs/boxes to compare before
00347    paying for a stack check. */
00348 #define EQUAL_COUNT_START 20
00349 
00350 int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
00351 {
00352   static int equal_counter = EQUAL_COUNT_START;
00353 
00354  top:
00355   if (eql->next_next) {
00356     if (eql->next) {
00357       Scheme_Object *a[2];
00358       a[0] = obj1;
00359       a[1] = obj2;
00360       obj1 = _scheme_apply(eql->next, 2, a);
00361       return SCHEME_TRUEP(obj1);
00362     }
00363     eql->next = eql->next_next;
00364   }
00365 
00366   if (scheme_eqv(obj1, obj2))
00367     return 1;
00368   else if (NOT_SAME_TYPE(SCHEME_TYPE(obj1), SCHEME_TYPE(obj2))) {
00369     return 0;
00370   } else if (SCHEME_PAIRP(obj1)) {
00371 #   include "mzeqchk.inc"
00372     if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
00373       if (union_check(obj1, obj2, eql))
00374         return 1;
00375     }
00376     eql->car_depth += 2;
00377     if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
00378       eql->car_depth -= 2;
00379       obj1 = SCHEME_CDR(obj1);
00380       obj2 = SCHEME_CDR(obj2);
00381       goto top;
00382     } else
00383       return 0;
00384   } else if (SCHEME_MUTABLE_PAIRP(obj1)) {
00385 #   include "mzeqchk.inc"
00386     if (union_check(obj1, obj2, eql))
00387       return 1;
00388     if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
00389       obj1 = SCHEME_CDR(obj1);
00390       obj2 = SCHEME_CDR(obj2);
00391       goto top;
00392     } else
00393       return 0;
00394   } else if (SCHEME_VECTORP(obj1)) {
00395 #   include "mzeqchk.inc"
00396     if (union_check(obj1, obj2, eql))
00397       return 1;
00398     return vector_equal(obj1, obj2, eql);
00399   } else if (SCHEME_BYTE_STRINGP(obj1)
00400             || SCHEME_GENERAL_PATHP(obj1)) {
00401     int l1, l2;
00402     l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
00403     l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
00404     return ((l1 == l2)
00405            && !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
00406   } else if (SCHEME_CHAR_STRINGP(obj1)) {
00407     int l1, l2;
00408     l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
00409     l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
00410     return ((l1 == l2)
00411            && !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
00412   } else if (SCHEME_STRUCTP(obj1)) {
00413     Scheme_Struct_Type *st1, *st2;
00414     Scheme_Object *procs1, *procs2;
00415 
00416     st1 = SCHEME_STRUCT_TYPE(obj1);
00417     st2 = SCHEME_STRUCT_TYPE(obj2);
00418 
00419     procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
00420     if (procs1 && (st1 != st2)) {
00421       procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
00422       if (!procs2
00423           || !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
00424         procs1 = NULL;
00425     }
00426 
00427     if (procs1) {
00428       /* Has an equality property: */
00429       Scheme_Object *a[3], *recur;
00430       Equal_Info *eql2;
00431 #     include "mzeqchk.inc"
00432 
00433       if (union_check(obj1, obj2, eql))
00434         return 1;
00435 
00436       /* Create/cache closure to use for recursive equality checks: */
00437       if (eql->recur) {
00438         recur = eql->recur;
00439         eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
00440       } else {
00441         eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
00442         a[0] = (Scheme_Object *)eql2;
00443         recur = scheme_make_prim_closure_w_arity(equal_recur,
00444                                                  1, a,
00445                                                  "equal?/recur",
00446                                                  2, 2);
00447         eql->recur = recur;
00448       }
00449       memcpy(eql2, eql, sizeof(Equal_Info));
00450 
00451       a[0] = obj1;
00452       a[1] = obj2;
00453       a[2] = recur;
00454 
00455       procs1 = SCHEME_VEC_ELS(procs1)[1];
00456 
00457       recur = _scheme_apply(procs1, 3, a);
00458 
00459       memcpy(eql, eql2, sizeof(Equal_Info));
00460 
00461       return SCHEME_TRUEP(recur);
00462     } else if (st1 != st2) {
00463       return 0;
00464     } else {
00465       /* Same types, but doesn't have an equality property, 
00466          so check transparency: */
00467       Scheme_Object *insp;
00468       insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
00469       if (scheme_inspector_sees_part(obj1, insp, -2)
00470          && scheme_inspector_sees_part(obj2, insp, -2)) {
00471 #       include "mzeqchk.inc"
00472         if (union_check(obj1, obj2, eql))
00473           return 1;
00474        return struct_equal(obj1, obj2, eql);
00475       } else
00476        return 0;
00477     }
00478   } else if (SCHEME_BOXP(obj1)) {
00479     SCHEME_USE_FUEL(1);
00480     if (union_check(obj1, obj2, eql))
00481       return 1;
00482     obj1 = SCHEME_BOX_VAL(obj1);
00483     obj2 = SCHEME_BOX_VAL(obj2);
00484     goto top;
00485   } else if (SCHEME_HASHTP(obj1)) {
00486 #   include "mzeqchk.inc"
00487     if (union_check(obj1, obj2, eql))
00488       return 1;
00489     return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2, eql);
00490   } else if (SCHEME_HASHTRP(obj1)) {
00491 #   include "mzeqchk.inc"
00492     if (union_check(obj1, obj2, eql))
00493       return 1;
00494     return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql);
00495   } else if (SCHEME_BUCKTP(obj1)) {
00496 #   include "mzeqchk.inc"
00497     if (union_check(obj1, obj2, eql))
00498       return 1;
00499     return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql);
00500   } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) {
00501     return vector_equal(obj1, obj2, eql);
00502   } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_resolved_module_path_type)) {
00503     obj1 = SCHEME_PTR_VAL(obj1);
00504     obj2 = SCHEME_PTR_VAL(obj2);
00505     goto top;
00506   } else {
00507     Scheme_Equal_Proc eqlp = scheme_type_equals[SCHEME_TYPE(obj1)];
00508     if (eqlp) {
00509       if (union_check(obj1, obj2, eql))
00510         return 1;
00511       return eqlp(obj1, obj2, eql);
00512     } else
00513       return 0;
00514   }
00515 }
00516 
00517 static int vector_equal(Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eql)
00518 {
00519   int i, len;
00520 
00521   len = SCHEME_VEC_SIZE(vec1);
00522   if (len != SCHEME_VEC_SIZE(vec2))
00523     return 0;
00524 
00525   SCHEME_USE_FUEL(len);
00526 
00527   for (i = 0; i < len; i++) {
00528     if (!is_equal(SCHEME_VEC_ELS(vec1)[i], SCHEME_VEC_ELS(vec2)[i], eql))
00529       return 0;
00530   }
00531 
00532   return 1;
00533 }
00534 
00535 int struct_equal(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
00536 {
00537   Scheme_Structure *s1, *s2;
00538   int i;
00539 
00540   s1 = (Scheme_Structure *)obj1;
00541   s2 = (Scheme_Structure *)obj2;
00542 
00543   for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) {
00544     if (!is_equal(s1->slots[i], s2->slots[i], eql))
00545       return 0;
00546   }
00547 
00548   return 1;
00549 }
00550 
00551 int scheme_recur_equal(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info)
00552 {
00553   return is_equal(obj1, obj2, (Equal_Info *)cycle_info);
00554 }
00555 
00556 /* used by external programs that cannot link to variables */
00557 Scheme_Object * scheme_make_true (void)
00558 {
00559   return scheme_true;
00560 }
00561 
00562 Scheme_Object * scheme_make_false (void)
00563 {
00564   return scheme_false;
00565 }