Exemple #1
0
XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
{
  Scheme_Type t1, t2;

  if (SAME_OBJ(obj1, obj2))
    return 1;

  t1 = SCHEME_TYPE(obj1);
  t2 = SCHEME_TYPE(obj2);

  if (NOT_SAME_TYPE(t1, t2)) {
#ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS
    /* If one is a float and the other is a double, coerce to double */
    if ((t1 == scheme_float_type) && (t2 == scheme_double_type))
      return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2));
    else if ((t2 == scheme_float_type) && (t1 == scheme_double_type))
      return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
    return -1;
  } else {
    switch (t1) {
#ifdef MZ_LONG_DOUBLE
    case scheme_long_double_type:
      return mz_long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
    case scheme_float_type:
      return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
    case scheme_double_type:
      return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
    case scheme_bignum_type:
      return scheme_bignum_eq(obj1, obj2);
    case scheme_rational_type:
      return scheme_rational_eq(obj1, obj2);
    case scheme_complex_type:
      {
        Scheme_Complex *c1 = (Scheme_Complex *)obj1;
        Scheme_Complex *c2 = (Scheme_Complex *)obj2;
        return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
      }
    case scheme_char_type:
      return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
    case scheme_symbol_type:
    case scheme_keyword_type:
    case scheme_scope_type:
      /* `eqv?` requires `eq?` */
      return 0;
    default:
      return -1;
    }
  }
}
Exemple #2
0
XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2)
{
  Scheme_Type t1, t2;

  if (SAME_OBJ(obj1, obj2))
    return 1;

  t1 = SCHEME_TYPE(obj1);
  t2 = SCHEME_TYPE(obj2);

  if (NOT_SAME_TYPE(t1, t2)) {
#ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS
    /* If one is a float and the other is a double, coerce to double */
    if ((t1 == scheme_float_type) && (t2 == scheme_double_type))
      return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2));
    else if ((t2 == scheme_float_type) && (t1 == scheme_double_type))
      return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
    return -1;
#ifdef MZ_LONG_DOUBLE
  } else if (t1 == scheme_long_double_type) {
    return long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2));
#endif
#ifdef MZ_USE_SINGLE_FLOATS
  } else if (t1 == scheme_float_type) {
    return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2));
#endif
  } else if (t1 == scheme_double_type) {
    return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2));
  } else if (t1 == scheme_bignum_type)
    return scheme_bignum_eq(obj1, obj2);
  else if (t1 == scheme_rational_type)
    return scheme_rational_eq(obj1, obj2);
  else if (t1 == scheme_complex_type) {
    Scheme_Complex *c1 = (Scheme_Complex *)obj1;
    Scheme_Complex *c2 = (Scheme_Complex *)obj2;
    return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i);
  } else if (t1 == scheme_char_type)
    return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2);
  else
    return -1;
}
Exemple #3
0
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;
  }
}
Exemple #4
0
XFORM_NONGCING int is_fast_equal (Scheme_Object *obj1, Scheme_Object *obj2, int for_chaperone)
{
  Scheme_Type t1, t2;
  int cmp;

  cmp = is_eqv(obj1, obj2);
  if (cmp > -1)
    return cmp;

  t1 = SCHEME_TYPE(obj1);
  t2 = SCHEME_TYPE(obj2);

  if (NOT_SAME_TYPE(t1, t2))
    return -1;

 switch (t1) {
 case scheme_flvector_type:
   {
     intptr_t l1, l2, i;
     l1 = SCHEME_FLVEC_SIZE(obj1);
     l2 = SCHEME_FLVEC_SIZE(obj2);
     if (l1 == l2) {
       for (i = 0; i < l1; i++) {
         if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i],
                         SCHEME_FLVEC_ELS(obj2)[i]))
           return 0;
       }
       return 1;
     }
     return 0;
   }
#ifdef MZ_LONG_DOUBLE
 case scheme_extflvector_type:
   {
     intptr_t l1, l2, i;
     l1 = SCHEME_EXTFLVEC_SIZE(obj1);
     l2 = SCHEME_EXTFLVEC_SIZE(obj2);
     if (l1 == l2) {
       for (i = 0; i < l1; i++) {
         if (!mz_long_double_eqv(SCHEME_EXTFLVEC_ELS(obj1)[i],
                                 SCHEME_EXTFLVEC_ELS(obj2)[i]))
           return 0;
       }
       return 1;
     }
     return 0;
   }
#endif
 case scheme_byte_string_type:
 case scheme_unix_path_type:
 case scheme_windows_path_type:
   {
     intptr_t l1, l2;
     if (for_chaperone) return -1;
     l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
     l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
     return ((l1 == l2)
             && !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
   }
 case scheme_char_string_type:
   {
     intptr_t l1, l2;
     if (for_chaperone) return -1;
     l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
     l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
     return ((l1 == l2)
             && !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
   }
 case scheme_cpointer_type:
   {
     return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1))
             == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2)));
   }
 case scheme_place_bi_channel_type:
   {
     Scheme_Place_Bi_Channel *bc1, *bc2;
     bc1 = (Scheme_Place_Bi_Channel *)obj1;
     bc2 = (Scheme_Place_Bi_Channel *)obj2;
     return (SAME_OBJ(bc1->link->recvch, bc2->link->recvch)
             && SAME_OBJ(bc1->link->sendch, bc2->link->sendch));
   }
 }

 return -1;
}