Back to index

plt-scheme  4.2.1
Classes | Defines | Typedefs | Functions | Variables
bool.c File Reference
#include "schpriv.h"
#include "schmach.h"
#include <string.h>
#include "mzeqchk.inc"

Go to the source code of this file.

Classes

struct  Equal_Info

Defines

#define EQUAL_COUNT_START   20

Typedefs

typedef struct Equal_Info Equal_Info

Functions

static Scheme_Objectnot_prim (int argc, Scheme_Object *argv[])
static Scheme_Objectboolean_p_prim (int argc, Scheme_Object *argv[])
static Scheme_Objecteq_prim (int argc, Scheme_Object *argv[])
static Scheme_Objecteqv_prim (int argc, Scheme_Object *argv[])
static Scheme_Objectequal_prim (int argc, Scheme_Object *argv[])
static Scheme_Objectequalish_prim (int argc, Scheme_Object *argv[])
static int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eql)
static int struct_equal (Scheme_Object *s1, Scheme_Object *s2, Equal_Info *eql)
void scheme_init_true_false (void)
void scheme_init_bool (Scheme_Env *env)
int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
static XFORM_NONGCING MZ_INLINE int double_eqv (double a, double b)
int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
static Scheme_Objectunion_find (Scheme_Object *obj1, Scheme_Hash_Table *ht)
static int union_check (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
static Scheme_Objectequal_k (void)
static Scheme_Objectequal_recur (int argc, Scheme_Object **argv, Scheme_Object *prim)
static int is_equal_overflow (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
int scheme_recur_equal (Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info)
Scheme_Objectscheme_make_true (void)
Scheme_Objectscheme_make_false (void)

Variables

Scheme_Object scheme_true [1]
Scheme_Object scheme_false [1]
Scheme_Objectscheme_not_prim
Scheme_Objectscheme_eq_prim
Scheme_Objectscheme_eqv_prim
Scheme_Objectscheme_equal_prim

Class Documentation

struct Equal_Info

Definition at line 53 of file bool.c.

Collaboration diagram for Equal_Info:
Class Members
long car_depth
long depth
Scheme_Hash_Table * ht
Scheme_Object * next
Scheme_Object * next_next
Scheme_Object * recur

Define Documentation

#define EQUAL_COUNT_START   20

Definition at line 348 of file bool.c.


Typedef Documentation


Function Documentation

static Scheme_Object * boolean_p_prim ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 113 of file bool.c.

{
  return (SCHEME_BOOLP(argv[0]) ? scheme_true : scheme_false);
}

Here is the caller graph for this function:

static XFORM_NONGCING MZ_INLINE int double_eqv ( double  a,
double  b 
) [static]

Definition at line 167 of file bool.c.

{
# ifndef NAN_EQUALS_ANYTHING
  if (a != b) {
# endif
    /* Double-check for NANs: */
    if (MZ_IS_NAN(a)) {
      if (MZ_IS_NAN(b))
        return 1;
# ifdef NAN_EQUALS_ANYTHING
      return 0;
# endif
    }
# ifdef NAN_EQUALS_ANYTHING
    if (MZ_IS_NAN(b))
      return 0;
    else {
      if (a == 0.0) {
        if (b == 0.0) {
          return scheme_minus_zero_p(a) == scheme_minus_zero_p(b);
        }
      }
      return (a == b);
    }
# else
    return 0;
  }
  if (a == 0.0) {
    if (b == 0.0) {
      return scheme_minus_zero_p(a) == scheme_minus_zero_p(b);
    }
  }
  return 1;
# endif
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * eq_prim ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 119 of file bool.c.

{
  return (SAME_OBJ(argv[0], argv[1]) ? scheme_true : scheme_false);
}

Here is the caller graph for this function:

static Scheme_Object* equal_k ( void  ) [static]

Definition at line 303 of file bool.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *v1 = (Scheme_Object *)p->ku.k.p1;
  Scheme_Object *v2 = (Scheme_Object *)p->ku.k.p2;
  Equal_Info *eql = (Equal_Info *)p->ku.k.p3;

  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;
  p->ku.k.p3 = NULL;

  return is_equal(v1, v2, eql) ? scheme_true : scheme_false;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * equal_prim ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 131 of file bool.c.

{
  Equal_Info eql;

  eql.depth = 1;
  eql.car_depth = 1;
  eql.ht = NULL;
  eql.recur = NULL;
  eql.next = NULL;
  eql.next_next = NULL;

  return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* equal_recur ( int  argc,
Scheme_Object **  argv,
Scheme_Object prim 
) [static]

Definition at line 317 of file bool.c.

{
  Equal_Info *eql = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];

  return (is_equal(argv[0], argv[1], eql)
          ? scheme_true
          : scheme_false);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * equalish_prim ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 146 of file bool.c.

{
  Equal_Info eql;

  scheme_check_proc_arity("equal?/recur", 2, 2, argc, argv);

  eql.depth = 1;
  eql.car_depth = 1;
  eql.ht = NULL;
  eql.recur = NULL;
  eql.next = NULL;
  eql.next_next = argv[2];

  return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * eqv_prim ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 125 of file bool.c.

{
  return (scheme_eqv(argv[0], argv[1]) ? scheme_true : scheme_false);
}

Here is the caller graph for this function:

int is_equal ( Scheme_Object obj1,
Scheme_Object obj2,
Equal_Info eql 
) [static]

Definition at line 350 of file bool.c.

{
  static int equal_counter = EQUAL_COUNT_START;

 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;
  }

  if (scheme_eqv(obj1, obj2))
    return 1;
  else if (NOT_SAME_TYPE(SCHEME_TYPE(obj1), SCHEME_TYPE(obj2))) {
    return 0;
  } else if (SCHEME_PAIRP(obj1)) {
#   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 (SCHEME_MUTABLE_PAIRP(obj1)) {
#   include "mzeqchk.inc"
    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 (SCHEME_VECTORP(obj1)) {
#   include "mzeqchk.inc"
    if (union_check(obj1, obj2, eql))
      return 1;
    return vector_equal(obj1, obj2, eql);
  } else if (SCHEME_BYTE_STRINGP(obj1)
            || SCHEME_GENERAL_PATHP(obj1)) {
    int l1, l2;
    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 (SCHEME_CHAR_STRINGP(obj1)) {
    int l1, l2;
    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 (SCHEME_STRUCTP(obj1)) {
    Scheme_Struct_Type *st1, *st2;
    Scheme_Object *procs1, *procs2;

    st1 = SCHEME_STRUCT_TYPE(obj1);
    st2 = SCHEME_STRUCT_TYPE(obj2);

    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 {
      /* Same types, but doesn't have an equality property, 
         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 (SCHEME_BOXP(obj1)) {
    SCHEME_USE_FUEL(1);
    if (union_check(obj1, obj2, eql))
      return 1;
    obj1 = SCHEME_BOX_VAL(obj1);
    obj2 = SCHEME_BOX_VAL(obj2);
    goto top;
  } else if (SCHEME_HASHTP(obj1)) {
#   include "mzeqchk.inc"
    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 (SCHEME_HASHTRP(obj1)) {
#   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 (SCHEME_BUCKTP(obj1)) {
#   include "mzeqchk.inc"
    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 (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) {
    return vector_equal(obj1, obj2, eql);
  } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_resolved_module_path_type)) {
    obj1 = SCHEME_PTR_VAL(obj1);
    obj2 = SCHEME_PTR_VAL(obj2);
    goto top;
  } else {
    Scheme_Equal_Proc eqlp = scheme_type_equals[SCHEME_TYPE(obj1)];
    if (eqlp) {
      if (union_check(obj1, obj2, eql))
        return 1;
      return eqlp(obj1, obj2, eql);
    } else
      return 0;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int is_equal_overflow ( Scheme_Object obj1,
Scheme_Object obj2,
Equal_Info eql 
) [static]

Definition at line 326 of file bool.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Equal_Info *eql2;
  Scheme_Object *v;

  eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
  memcpy(eql2, eql, sizeof(Equal_Info));

  p->ku.k.p1 = (void *)obj1;
  p->ku.k.p2 = (void *)obj2;
  p->ku.k.p3 = (void *)eql2;

  v = scheme_handle_stack_overflow(equal_k);

  memcpy(eql, eql2, sizeof(Equal_Info));
  
  return SCHEME_TRUEP(v);
}

Here is the call graph for this function:

static Scheme_Object * not_prim ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 107 of file bool.c.

{
  return (SAME_OBJ(argv[0], scheme_false) ? scheme_true : scheme_false);
}

Here is the caller graph for this function:

int scheme_eq ( Scheme_Object obj1,
Scheme_Object obj2 
)

Definition at line 162 of file bool.c.

{
  return SAME_OBJ(obj1, obj2);
}
int scheme_equal ( Scheme_Object obj1,
Scheme_Object obj2 
)

Definition at line 242 of file bool.c.

{
  Equal_Info eql;

  eql.depth = 1;
  eql.car_depth = 1;
  eql.ht = NULL;
  eql.recur = NULL;
  eql.next_next = NULL;
  eql.next = NULL;

  return is_equal(obj1, obj2, &eql);
}

Here is the call graph for this function:

int scheme_eqv ( Scheme_Object obj1,
Scheme_Object obj2 
)

Definition at line 203 of file bool.c.

{
  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 MZ_USE_SINGLE_FLOATS
    /* 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 0;
#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 0;
}

Here is the call graph for this function:

Definition at line 65 of file bool.c.

Here is the caller graph for this function:

Definition at line 562 of file bool.c.

{
  return scheme_false;
}

Definition at line 557 of file bool.c.

{
  return scheme_true;
}
int scheme_recur_equal ( Scheme_Object obj1,
Scheme_Object obj2,
void cycle_info 
)

Definition at line 551 of file bool.c.

{
  return is_equal(obj1, obj2, (Equal_Info *)cycle_info);
}

Here is the call graph for this function:

int struct_equal ( Scheme_Object s1,
Scheme_Object s2,
Equal_Info eql 
) [static]

Definition at line 535 of file bool.c.

{
  Scheme_Structure *s1, *s2;
  int i;

  s1 = (Scheme_Structure *)obj1;
  s2 = (Scheme_Structure *)obj2;

  for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) {
    if (!is_equal(s1->slots[i], s2->slots[i], eql))
      return 0;
  }

  return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int union_check ( Scheme_Object obj1,
Scheme_Object obj2,
Equal_Info eql 
) [static]

Definition at line 279 of file bool.c.

{
  if (eql->depth < 50) {
    if (!eql->next_next)
      eql->depth += 2;
    return 0;
  } else {
    Scheme_Hash_Table *ht = eql->ht;
    if (!ht) {
      ht = scheme_make_hash_table(SCHEME_hash_ptr);
      eql->ht = ht;
    }
    obj1 = union_find(obj1, ht);
    obj2 = union_find(obj2, ht);

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

    scheme_hash_set(ht, obj2, obj1);

    return 0;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* union_find ( Scheme_Object obj1,
Scheme_Hash_Table ht 
) [static]

Definition at line 256 of file bool.c.

{
  Scheme_Object *v, *prev = obj1, *prev_prev = obj1;

  while (1) {
    v = scheme_hash_get(ht, prev);
    if (v) {
      prev_prev = prev;
      prev = v;
    } else 
      break;
  }

  /* Point all items to prev */
  while (obj1 != prev_prev) {
    v = scheme_hash_get(ht, obj1);
    scheme_hash_set(ht, obj1, prev);
    obj1 = v;
  }

  return prev;
}

Here is the caller graph for this function:

static int vector_equal ( Scheme_Object vec1,
Scheme_Object vec2,
Equal_Info eql 
) [static]

Definition at line 517 of file bool.c.

{
  int i, len;

  len = SCHEME_VEC_SIZE(vec1);
  if (len != SCHEME_VEC_SIZE(vec2))
    return 0;

  SCHEME_USE_FUEL(len);

  for (i = 0; i < len; i++) {
    if (!is_equal(SCHEME_VEC_ELS(vec1)[i], SCHEME_VEC_ELS(vec2)[i], eql))
      return 0;
  }

  return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:


Variable Documentation

Definition at line 41 of file bool.c.

Definition at line 43 of file bool.c.

Definition at line 42 of file bool.c.

Definition at line 38 of file bool.c.

Definition at line 40 of file bool.c.

Definition at line 37 of file bool.c.