equal? and hashing work on cyclic values

svn: r8132

collects/frtime/frp-core.ss

@@ -543,8 +543,6 @@
               (lambda () (heap-empty? heap)))))
   
   (define (schedule-alarm ms beh)
-    (when (> ms 1073741824)
-      (set! ms (- ms 2147483647)))
     (if (eq? (self) man)
         (alarms-enqueue ms beh)
         (! man (make-alarm ms beh))))

collects/lang/private/teachprims.ss

@@ -185,26 +185,47 @@ namespace.
   (define-teach beginner exit
     (lambda () (exit)))
   
-  ;; This equality predicate doesn't handle hash tables.
-  ;; (It could, but there are no hash tables in the teaching
-  ;;  languages.)
   (define (tequal? a b epsilon)
+    (let* ([ht (make-hash-table)]
+           [union-find (lambda (a)
+                         (let loop ([prev a]
+                                    [prev-prev a])
+                           (let ([v (hash-table-get ht prev #f)])
+                             (if v
+                                 (loop v prev)
+                                 (begin
+                                   (let loop ([a a])
+                                     (unless (eq? a prev-prev)
+                                       (let ([v (hash-table-get ht a)])
+                                         (hash-table-put! ht a prev)
+                                         (loop v))))
+                                   prev)))))]
+           [union-equal? (lambda (a b)
+                           (let ([a (union-find a)]
+                                 [b (union-find b)])
+                             (if (eq? a b)
+                                 #t
+                                 (begin
+                                   (hash-table-put! ht b a)
+                                   #f))))])
       (let ? ([a a][b b])
-      (or (equal? a b)
+        (or (eqv? a b)
             (cond
              [(box? a)
               (and (box? b)
                    (? (unbox a) (unbox b)))]
              [(pair? a)
               (and (pair? b)
-	       (? (car a) (car b))
+                   (or (union-equal? a b)
-	       (? (cdr a) (cdr b)))]
+                       (and (? (car a) (car b))
+                            (? (cdr a) (cdr b)))))]
              [(vector? a)
               (and (vector? b)
                    (= (vector-length a) (vector-length b))
+                   (or (union-equal? a b)
                        (andmap ?
                                (vector->list a)
-		 (vector->list b)))]
+                               (vector->list b))))]
              [(image? a)
               (and (image? b)
                    (image=? a b))]
@@ -219,8 +240,9 @@ namespace.
                      (and (not sa?)
                           (not sb?)
                           (eq? ta tb)
+                          (or (union-equal? a b)
                               (? (struct->vector a)
-		      (struct->vector b)))))]
+                                 (struct->vector b))))))]
              [(hash-table? a)
               (and (hash-table? b)
                    (eq? (immutable? a) (immutable? b))
@@ -229,12 +251,13 @@ namespace.
                    (let ([al (hash-table-map a cons)]
                          [bl (hash-table-map b cons)])
                      (and (= (length al) (length bl))
-		   (for-each 
+                          (or (union-equal? a b)
+                              (andmap
                                (lambda (ai)
                                  (? (hash-table-get b (car ai) (lambda () (not (cdr ai))))
                                     (cdr ai)))
-		     al))))]
+                               al)))))]
-	    [else #f]))))
+             [else (equal? a b)])))))
 
   (define-teach beginner equal?
     (lambda (a b)

collects/scribblings/inside/misc.scrbl

@@ -26,9 +26,46 @@ Returns 1 if the Scheme values are @scheme[eqv?].}
 
 Returns 1 if the Scheme values are @scheme[equal?].}
 
+@function[(int scheme_recur_equal
+           [Scheme_Object* obj1]
+           [Scheme_Object* obj2]
+           [void* cycle_data])]{
+
+Like @cpp{scheme_equal}, but accepts an extra value for cycle
+tracking. This procedure is meant to be called by a procedure
+installed with @cpp{scheme_set_type_equality}.}
+
+Returns 1 if the Scheme values are @scheme[equal?].}
+
 @function[(long scheme_equal_hash_key
+           [Scheme_Object* obj])]{
+
+Returns the primary @scheme[equal?]-hash key for \var{obj}.}
+
+@function[(long scheme_equal_hash_key2
+           [Scheme_Object* obj])]{
+
+Returns the secondary @scheme[equal?]-hash key for \var{obj}.}
+
+@function[(long scheme_recur_equal_hash_key
            [Scheme_Object* obj]
+           [void* cycle_data])]{
+
+Like @cpp{scheme_equal_hash_key}, but accepts an extra value for cycle
+tracking. This procedure is meant to be called by a hasing procedure
+installed with @cpp{scheme_set_type_equality}.}
+
+Returns the primary @scheme[equal?]-hash key for \var{obj}.}
+
+@function[(long scheme_recur_equal_hash_key2
            [Scheme_Object* obj]
+           [void* cycle_data])]{
+
+Like @cpp{scheme_equal_hash_key2}, but accepts an extra value for
+cycle tracking. This procedure is meant to be called by a secondary
+hashing procedure installed with @cpp{scheme_set_type_equality}.}
+
+@function[(long scheme_build_list
            [int c]
            [Scheme_Object** elems])]{
 

collects/scribblings/inside/values.scrbl

@@ -727,21 +727,36 @@ Writes the content of @var{str} --- starting from @var{offset} and
            [Scheme_Secondary_Hash_Proc hash2])]{
 
 Installs an equality predicate and associated hash functions for
- values that have the type tag @var{type}. The @var{equalp} predicate is
+values that have the type tag @var{type}. The @var{equalp} predicate
- only applied to values that both have tag @var{type}.
+is only applied to values that both have tag @var{type}.
 
-The type of @var{equalp}, @var{hash1}, and @var{hash2} are defined as follows:
+The type of @var{equalp}, @var{hash1}, and @var{hash2} are defined as
+follows:
 
 @verbatim[#<<EOS
  typedef int (*Scheme_Equal_Proc)(Scheme_Object* obj1, 
-                                  Scheme_Object *obj2);
+                                  Scheme_Object* obj2,
+                                  void* cycle_data);
  typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object* obj, 
-                                          long base);
+                                          long base,
- typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj);
+                                          void* cycle_data);
+ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object* obj,
+                                           void* cycle_data);
 EOS
 ]
 
 The two hash functions are use to generate primary and secondary keys
 for double hashing in an @scheme[equal?]-based hash table. The result
 of the primary-key function should depend on both @var{obj} and
-@var{base}.}
+@var{base}.
+
+The @var{cycle_data} argument in each case allows checking and hashing
+on cyclic values. It is intended for use in recursive checking or
+hashing via @cpp{scheme_recur_equal},
+@cpp{scheme_recur_equal_hash_key}, and
+@cpp{scheme_recur_equal_hash_key}. That is, do not call plain
+@cpp{scheme_equal}, @cpp{scheme_equal_hash_key}, or
+@cpp{scheme_equal_hash_key} for recursive checking or hashing on
+sub-elements of the given value(s).}
+
+

collects/scribblings/reference/data.scrbl

@@ -36,8 +36,12 @@ Returns @scheme[#t] if @scheme[v] is @scheme[#f], @scheme[#f] otherwise.
 Two values are @scheme[equal?] if and only if they are @scheme[eqv?],
 unless otherwise specified for a particular datatype.
 
-Datatypes with further specification of @scheme[equal?] include strings,
+Datatypes with further specification of @scheme[equal?] include
-byte strings, numbers, pairs, vectors, and hash tables.}
+strings, byte strings, numbers, pairs, mutable pairs, vectors, hash
+tables, and inspectable structures. In the last five cases, equality
+is recursively defined; if both @scheme[v1] and @scheme[v2] contain
+reference cycles, they are equal when the infinite unfoldings of the
+values would be equal.}
 
 
 @defproc[(eqv? [v1 any/c] [v2 any/c]) boolean?]{
@@ -550,10 +554,9 @@ implies @scheme[(eq? k j)].}
 Returns an exact integer; for any two @scheme[equal?] values, the
 returned integer is the same.  Furthermore, for the result integer
 @scheme[k] and any other exact integer @scheme[j], @scheme[(= k j)]
-implies @scheme[(eq? k j)]. If @scheme[v] contains a cycle through
+implies @scheme[(eq? k j)]. A has code is computed even when
-pairs, vectors, boxes, and/or inspectable structure fields, then
+@scheme[v] contains a cycle through pairs, vectors, boxes, and/or
-@scheme[equal-hash-code] applied to @scheme[v] will loop
+inspectable structure fields.}
-indefinitely.}
 
 @; ----------------------------------------------------------------------
 @include-section["sequences.scrbl"]

collects/tests/mzscheme/advanced.ss

@@ -193,13 +193,20 @@
 (load (build-path (collection-path "tests" "mzscheme") "shared-tests.ss"))
 
 (htdp-test #t 'equal? (equal? (vector (list 10) 'apple) (vector (list 10) 'apple)))
+(htdp-test #t 'equal? (equal?  (shared ([x (cons 10 x)]) x) (shared ([x (cons 10 x)]) x)))
+(htdp-test #t 'equal? (equal?  (shared ([x (cons (vector x) x)]) x) (shared ([x (cons (vector x) x)]) x)))
+(htdp-test #f 'equal? (equal?  (shared ([x (cons 10 x)]) x) (shared ([x (cons 10 (cons 11 x))]) x)))
+(htdp-test #f 'equal? (equal?  (shared ([x (cons (vector x) x)]) x) (shared ([x (cons (box x) x)]) x)))
+
 (htdp-test #t 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10) 'apple) 0.1))
 (htdp-test #t 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10.02) 'apple) 0.1))
 (htdp-test #f 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10.2) 'apple) 0.1))
 (htdp-test #t 'equal? (equal? (box (list 10)) (box (list 10))))
 (htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10)) 0.1))
 (htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10.02)) 0.1))
-(htdp-test #f 'equal~? (equal~? (box (list 10)) (box (list 10.2)) 0.1))
+
+(htdp-test #t 'equal~? (equal~?  (shared ([x (cons 10 x)]) x) (shared ([x (cons 10.02 x)]) x) 0.1))
+(htdp-test #f 'equal~? (equal~?  (shared ([x (cons 10 x)]) x) (shared ([x (cons 10.2 x)]) x) 0.1))
 
 ;; Simulate set! in the repl
 (module my-advanced-module (lib "htdp-advanced.ss" "lang")

collects/tests/mzscheme/deep.ss

@@ -107,56 +107,77 @@
 
 (test #t 'equal? (equal? deep-list (read (open-input-string (get-output-string s)))))
 
-(define going? #t)
+(define (try-pairs mk-a mk-d cons)
-(define (equal?-forever l1 l2 deep?)
+  (let ()
-  (let ([t (thread (lambda () 
+    (define l1 (mk-a 0))
-		     (equal? l1 l2) ; runs forever; could run out of memory
+    (define l2 (mk-a 0))
-		     (set! going? #f)))]
+    (define l3 (mk-a 1))
-	[v1 (make-vector 6)]
+    (test #t equal? l1 l2)
-	[v2 (make-vector 6)])
+    (test #f equal? l1 l3)
-    (if deep?
+    (test #t equal? (cons l1 l3) (cons l2 l3))
-	(begin
+    (test #f equal? (cons l1 l2) (cons l2 l3))
-	  (sleep)
+    (test #t = (equal-hash-code l1) (equal-hash-code l2)))
-	  (vector-set-performance-stats! v1)
-	  (let loop ()
-	    (sleep)
-	    (vector-set-performance-stats! v2)
-	    (unless (> (vector-ref v2 5)
-		       (+ (vector-ref v1 5) 2))
-	      (loop))))
-	(sleep 0.3))
-    (kill-thread t)
-    going?))
 
+  (let ()
+    (define l1 (mk-d #f))
+    (define l2 (mk-d #f))
+    (define l3 (mk-d #t))
+    (test #t equal? l1 l2)
+    (test #f equal? l1 l3)
+    (test #t equal? (cons l1 l3) (cons l2 l3))
+    (test #f equal? (cons l1 l2) (cons l2 l3))
+    (test #t = (equal-hash-code l1) (equal-hash-code l2))))
 
-(define l1 (read (open-input-string "#0=(cons 0 #0#)")))
+(try-pairs (lambda (v)
-(define l2 (read (open-input-string "#0=(cons 0 #0#)")))
+             (read (open-input-string (format "#0=(cons ~a #0#)" v))))
-(test #t 'equal?-forever (equal?-forever l1 l2 #f))
+           (lambda (v)
+             (read (open-input-string (format "#0=(cons #0# ~a)" v))))
+           cons)
 
-(define l1 (read (open-input-string "#0=(cons #0# #f)")))
+(try-pairs (lambda (v)
-(define l2 (read (open-input-string "#0=(cons #0# #f)")))
+             (let ([p (mcons v v)])
-(test #t 'equal?-forever/memory (equal?-forever l1 l2 #t))
+               (set-mcdr! p p)
+               p))
+           (lambda (v)
+             (let ([p (mcons v v)])
+               (set-mcar! p p)
+               p))
+           mcons)
 
-(define l1 (vector 0))
+(define (vec-test i)
-(vector-set! l1 0 l1)
+  (define l1 (vector 0 0))
-(define l2 (vector 0))
+  (define l2 (vector 0 0))
-(vector-set! l2 0 l2)
+  (define l3 (vector 1 1))
-(test #t 'equal?-forever/vector (equal?-forever l1 l2 #t))
+  (vector-set! l1 i l1)
+  (vector-set! l2 i l2)
+  (vector-set! l3 i l3)
+  (test #t equal? l1 l2)
+  (test #f equal? l1 l3)
+  (test #t equal? (vector l1 l3) (vector l2 l3))
+  (test #f equal? (vector l1 l2) (vector l2 l3))
+  (test #t = (equal-hash-code l1) (equal-hash-code l2)))
+(vec-test 0)
+(vec-test 1)
 
 (define-struct a (b c) #:inspector (make-inspector) #:mutable)
 (define l1 (make-a 0 #f))
 (set-a-b! l1 l1)
 (define l2 (make-a 0 #f))
 (set-a-b! l2 l2)
-(test #t 'equal?-forever/struct (equal?-forever l1 l2 #t))
+(define l3 (make-a 0 #t))
+(set-a-b! l3 l2)
+(test #t equal? l1 l2)
+(test #f equal? l1 l3)
+(test #t equal? (make-a l1 l3) (make-a l2 l3))
+(test #f equal? (make-a l1 l2) (make-a l2 l3))
+(test #t = (equal-hash-code l1) (equal-hash-code l2))
 
 (define l1 (box 0))
 (set-box! l1 l1)
 (define l2 (box 0))
 (set-box! l2 l2)
-(test #t 'equal?-forever/box (equal?-forever l1 l2 #f))
+(test #t equal? l1 l2)
-
+(test #t = (equal-hash-code l1) (equal-hash-code l2))
-(test #t 'equal?-forever/box (call-in-nested-thread (lambda () (equal?-forever l1 l2 #f))))
 
 ;; ----------------------------------------
 ;; Overflow in hashing:

collects/tests/mzscheme/htdp.ss

@@ -0,0 +1,10 @@
+
+(load-relative "loadtest.ss")
+
+(load-in-sandbox "beginner.ss")
+(load-in-sandbox "beginner-abbr.ss")
+(load-in-sandbox "intermediate.ss")
+(load-in-sandbox "intermediate-lambda.ss")
+(load-in-sandbox "advanced.ss")
+
+(report-errs)

src/mzscheme/cmdline.inc

@@ -1159,7 +1159,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
 #endif
 }
 
-#if defined(OS_X) && defined(MZ_PRECISE_GC)
+#if defined(OS_X) && defined(MZ_PRECISE_GC) && defined(EXTRA_EXCEPTION_STUBS)
 
 /* These declarations avoid linker problems when using
    -mmacosx-version-min. See gc2/vm_osx.c for details. */

src/mzscheme/include/mzscheme.exp

@@ -497,7 +497,10 @@ scheme_eqv
 scheme_equal
 scheme_equal_hash_key
 scheme_equal_hash_key2
+scheme_recur_equal_hash_key
+scheme_recur_equal_hash_key2
 scheme_set_type_equality
+scheme_recur_equal
 scheme_build_list
 scheme_build_list_offset
 scheme_is_list

src/mzscheme/include/mzscheme3m.exp

@@ -508,7 +508,10 @@ scheme_equal
 scheme_hash_key
 scheme_equal_hash_key
 scheme_equal_hash_key2
+scheme_recur_equal_hash_key
+scheme_recur_equal_hash_key2
 scheme_set_type_equality
+scheme_recur_equal
 scheme_build_list
 scheme_build_list_offset
 scheme_is_list

src/mzscheme/include/mzwin.def

@@ -485,7 +485,10 @@ EXPORTS
  scheme_equal
  scheme_equal_hash_key
  scheme_equal_hash_key2
+ scheme_recur_equal_hash_key
+ scheme_recur_equal_hash_key2
  scheme_set_type_equality
+ scheme_recur_equal
  scheme_build_list
  scheme_build_list_offset
  scheme_is_list

src/mzscheme/include/mzwin3m.def

@@ -500,7 +500,10 @@ EXPORTS
  scheme_hash_key
  scheme_equal_hash_key
  scheme_equal_hash_key2
+ scheme_recur_equal_hash_key
+ scheme_recur_equal_hash_key2
  scheme_set_type_equality
+ scheme_recur_equal
  scheme_build_list
  scheme_build_list_offset
  scheme_is_list

src/mzscheme/include/scheme.h

@@ -319,9 +319,9 @@ typedef struct Scheme_Vector {
 typedef struct Scheme_Print_Params Scheme_Print_Params;
 typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
 
-typedef int (*Scheme_Equal_Proc)(Scheme_Object *obj1, Scheme_Object *obj2);
+typedef int (*Scheme_Equal_Proc)(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_data);
-typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, long base);
+typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, long base, void *cycle_data);
-typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj);
+typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data);
 
 /* This file defines all the built-in types */
 #ifdef INCLUDE_WITHOUT_PATHS

src/mzscheme/src/bool.c

@@ -49,8 +49,15 @@ static Scheme_Object *eq_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *eqv_prim (int argc, Scheme_Object *argv[]);
 static Scheme_Object *equal_prim (int argc, Scheme_Object *argv[]);
 
-static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2);
+typedef struct Equal_Info {
-static int struct_equal (Scheme_Object *s1, Scheme_Object *s2);
+  long depth; /* always odd */
+  long car_depth; /* always odd */
+  Scheme_Hash_Table *ht;
+} Equal_Info;
+
+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)
 {
@@ -116,7 +123,13 @@ eqv_prim (int argc, Scheme_Object *argv[])
 static Scheme_Object *
 equal_prim (int argc, Scheme_Object *argv[])
 {
-  return (scheme_equal(argv[0], argv[1]) ? scheme_true : scheme_false);
+  Equal_Info eql;
+
+  eql.depth = 1;
+  eql.car_depth = 1;
+  eql.ht = NULL;
+
+  return (is_equal(argv[0], argv[1], &eql) ? scheme_true : scheme_false);
 }
 
 int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
@@ -199,22 +212,102 @@ int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
     return 0;
 }
 
-static Scheme_Object *equal_k(void)
+int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
+{
+  Equal_Info eql;
+
+  eql.depth = 1;
+  eql.car_depth = 1;
+  eql.ht = NULL;
+
+  return is_equal(obj1, obj2, &eql);
+}
+
+static Scheme_Object *union_find(Scheme_Object *obj1, Scheme_Hash_Table *ht)
+{
+  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;
+}
+
+static int union_check(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) 
+{
+  if (eql->depth < 50) {
+    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;
+  }
+}
+
+static Scheme_Object *equal_k()
 {
   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 = p->ku.k.p2 = NULL;
+  p->ku.k.p1 = NULL;
+  p->ku.k.p2 = NULL;
+  p->ku.k.p3 = NULL;
 
-  return scheme_equal(v1, v2) ? scheme_true : scheme_false;
+  return is_equal(v1, v2, eql) ? scheme_true : scheme_false;
+}
+
+static int is_equal_overflow(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
+{
+  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);
 }
 
 /* Number of lists/vectors/structs/boxes to compare before
    paying for a stack check. */
 #define EQUAL_COUNT_START 20
 
-int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
+int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
 {
   static int equal_counter = EQUAL_COUNT_START;
 
@@ -225,7 +318,13 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
     return 0;
   else if (SCHEME_PAIRP(obj1)) {
 #   include "mzeqchk.inc"
-    if (scheme_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2))) {
+    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;
@@ -233,7 +332,9 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
       return 0;
   } else if (SCHEME_MUTABLE_PAIRP(obj1)) {
 #   include "mzeqchk.inc"
-    if (scheme_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2))) {
+    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;
@@ -241,7 +342,9 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
       return 0;
   } else if (SCHEME_VECTORP(obj1)) {
 #   include "mzeqchk.inc"
-    return vector_equal(obj1, obj2);
+    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;
@@ -264,35 +367,47 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
       if (scheme_inspector_sees_part(obj1, insp, -2)
 	  && scheme_inspector_sees_part(obj2, insp, -2)) {
 #       include "mzeqchk.inc"
-	return struct_equal(obj1, obj2);
+        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((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2);
   } else if (SCHEME_BUCKTP(obj1)) {
 #   include "mzeqchk.inc"
+    if (union_check(obj1, obj2, eql))
+      return 1;
     return scheme_bucket_table_equal((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2);
   } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) {
-    return vector_equal(obj1, obj2);
+    return vector_equal(obj1, obj2, eql);
   } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_resolved_module_path_type)) {
-    return scheme_equal(SCHEME_PTR_VAL(obj1), SCHEME_PTR_VAL(obj2));
+    obj1 = SCHEME_PTR_VAL(obj1);
+    obj2 = SCHEME_PTR_VAL(obj2);
+    goto top;
   } else {
-    Scheme_Equal_Proc eql = scheme_type_equals[SCHEME_TYPE(obj1)];
+    Scheme_Equal_Proc eqlp = scheme_type_equals[SCHEME_TYPE(obj1)];
-    if (eql)
+    if (eqlp) {
-      return eql(obj1, obj2);
+      if (union_check(obj1, obj2, eql))
-    else
+        return 1;
+      return eqlp(obj1, obj2, eql);
+    } else
       return 0;
   }
 }
 
-static int vector_equal(Scheme_Object *vec1, Scheme_Object *vec2)
+static int vector_equal(Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eql)
 {
   int i, len;
 
@@ -303,14 +418,14 @@ static int vector_equal(Scheme_Object *vec1, Scheme_Object *vec2)
   SCHEME_USE_FUEL(len);
 
   for (i = 0; i < len; i++) {
-    if (!scheme_equal(SCHEME_VEC_ELS(vec1)[i], SCHEME_VEC_ELS(vec2)[i]))
+    if (!is_equal(SCHEME_VEC_ELS(vec1)[i], SCHEME_VEC_ELS(vec2)[i], eql))
       return 0;
   }
 
   return 1;
 }
 
-int struct_equal(Scheme_Object *obj1, Scheme_Object *obj2)
+int struct_equal(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
 {
   Scheme_Structure *s1, *s2;
   int i;
@@ -319,13 +434,18 @@ int struct_equal(Scheme_Object *obj1, Scheme_Object *obj2)
   s2 = (Scheme_Structure *)obj2;
 
   for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) {
-    if (!scheme_equal(s1->slots[i], s2->slots[i]))
+    if (!is_equal(s1->slots[i], s2->slots[i], eql))
       return 0;
   }
 
   return 1;
 }
 
+int scheme_recur_equal(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info)
+{
+  return is_equal(obj1, obj2, (Equal_Info *)cycle_info);
+}
+
 /* used by external programs that cannot link to variables */
 Scheme_Object * scheme_make_true (void)
 {

src/mzscheme/src/hash.c

@@ -66,6 +66,8 @@ typedef int (*Hash_Compare_Proc)(void*, void*);
 
 typedef unsigned long hash_v_t;
 
+#define MAX_HASH_DEPTH 128
+
 /*========================================================================*/
 /*                         hashing functions                              */
 /*========================================================================*/
@@ -844,7 +846,8 @@ END_XFORM_SKIP;
 /*                           equal? hashing                               */
 /*========================================================================*/
 
-static long equal_hash_key(Scheme_Object *o, long k);
+static long equal_hash_key(Scheme_Object *o, long k, long depth);
+static long equal_hash_key2(Scheme_Object *o, long depth);
 
 static Scheme_Object *hash_k(void)
 {
@@ -854,7 +857,7 @@ static Scheme_Object *hash_k(void)
 
   p->ku.k.p1 = NULL;
   
-  nv = equal_hash_key(v, p->ku.k.i1);
+  nv = equal_hash_key(v, p->ku.k.i1, p->ku.k.i2);
 
   return scheme_make_integer_value(nv);
 }
@@ -865,12 +868,13 @@ static Scheme_Object *hash_k(void)
 
 #define MZ_HASH_K hash_k
 #define MZ_HASH_I1 (k - t)
+#define MZ_HASH_I2 depth
 
 /* Based on Bob Jenkins's one-at-a-time hash function at
    http://www.burtleburtle.net/bob/hash/doobs.html: */
 #define MZ_MIX(k) (k += (k << 10), k ^= (k >> 6))
 
-static long equal_hash_key(Scheme_Object *o, long k)
+static long equal_hash_key(Scheme_Object *o, long k, long depth)
 {
   Scheme_Type t;
   static int hash_counter = HASH_COUNT_START;
@@ -879,6 +883,9 @@ static long equal_hash_key(Scheme_Object *o, long k)
   t = SCHEME_TYPE(o);
   k += t;
 
+  if (depth > MAX_HASH_DEPTH)
+    return k;
+  
   switch(t) {
   case scheme_integer_type:
     return k + SCHEME_INT_VAL(o);
@@ -923,7 +930,7 @@ static long equal_hash_key(Scheme_Object *o, long k)
     break;
   case scheme_rational_type:
     {
-      k += equal_hash_key(scheme_rational_numerator(o), 0);
+      k += equal_hash_key(scheme_rational_numerator(o), 0, depth);
       o = scheme_rational_denominator(o);
       break;
     }
@@ -931,21 +938,23 @@ static long equal_hash_key(Scheme_Object *o, long k)
   case scheme_complex_izi_type:
     {
       Scheme_Complex *c = (Scheme_Complex *)o;
-      k += equal_hash_key(c->r, 0);
+      k += equal_hash_key(c->r, 0, depth);
       o = c->i;
       break;
     }
   case scheme_pair_type:
     {
 #     include "mzhashchk.inc"
-      k += equal_hash_key(SCHEME_CAR(o), 0);
+      depth++;
+      k += equal_hash_key(SCHEME_CAR(o), 0, depth);
       o = SCHEME_CDR(o);
       break;
     }
   case scheme_mutable_pair_type:
     {
 #     include "mzhashchk.inc"
-      k += equal_hash_key(SCHEME_CAR(o), 0);
+      depth++;
+      k += equal_hash_key(SCHEME_CAR(o), 0, depth);
       o = SCHEME_CDR(o);
       break;
     }
@@ -958,10 +967,11 @@ static long equal_hash_key(Scheme_Object *o, long k)
       if (!len)
 	return k + 1;
       
+      depth++;
       --len;
       for (i = 0; i < len; i++) {
 	SCHEME_USE_FUEL(1);
-	val = equal_hash_key(SCHEME_VEC_ELS(o)[i], 0);
+	val = equal_hash_key(SCHEME_VEC_ELS(o)[i], 0, depth);
 	k = (k << 5) + k + val;
       }
       
@@ -1007,8 +1017,10 @@ static long equal_hash_key(Scheme_Object *o, long k)
 	
 #       include "mzhashchk.inc"
 	
+        depth++;
+
 	for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) {
-	  k += equal_hash_key(s1->slots[i], 0);
+	  k += equal_hash_key(s1->slots[i], 0, depth);
           MZ_MIX(k);
 	}
 	
@@ -1022,6 +1034,7 @@ static long equal_hash_key(Scheme_Object *o, long k)
       SCHEME_USE_FUEL(1);
       k += 1;
       o = SCHEME_BOX_VAL(o);
+      depth++;
       break;
     }
   case scheme_hash_table_type:
@@ -1034,14 +1047,15 @@ static long equal_hash_key(Scheme_Object *o, long k)
 #     include "mzhashchk.inc"
 
       k = (k << 1) + 3;
+      depth++;
       
       keys = ht->keys;
       vals = ht->vals;
       for (i = ht->size; i--; ) {
 	if (vals[i]) {
-          vk = equal_hash_key(keys[i], 0);
+          vk = equal_hash_key(keys[i], 0, depth);
           MZ_MIX(vk);
-	  vk += equal_hash_key(vals[i], 0);
+	  vk += equal_hash_key(vals[i], 0, depth);
           MZ_MIX(vk);
           k += vk;  /* can't mix k, because the key order shouldn't matter */
 	}
@@ -1061,6 +1075,7 @@ static long equal_hash_key(Scheme_Object *o, long k)
 
       buckets = ht->buckets;
       weak = ht->weak;
+      depth++;
       
       k = (k << 1) + 7;
       
@@ -1073,9 +1088,9 @@ static long equal_hash_key(Scheme_Object *o, long k)
 	    key = bucket->key;
 	  }
 	  if (key) {
-	    vk = equal_hash_key((Scheme_Object *)bucket->val, 0);
+	    vk = equal_hash_key((Scheme_Object *)bucket->val, 0, depth);
             MZ_MIX(vk);
-	    vk += equal_hash_key((Scheme_Object *)key, 0);
+	    vk += equal_hash_key((Scheme_Object *)key, 0, depth);
             MZ_MIX(vk);
             k += vk; /* can't mix k, because the key order shouldn't matter */
 	  }
@@ -1118,7 +1133,7 @@ static long equal_hash_key(Scheme_Object *o, long k)
     {
       Scheme_Primary_Hash_Proc h1 = scheme_type_hash1s[t];
       if (h1)
-        return h1(o, k);
+        return h1(o, k, scheme_make_integer(depth));
       else
         return k + (PTR_TO_LONG(o) >> 4);
     }
@@ -1130,7 +1145,12 @@ static long equal_hash_key(Scheme_Object *o, long k)
 
 long scheme_equal_hash_key(Scheme_Object *o)
 {
-  return equal_hash_key(o, 0);
+  return equal_hash_key(o, 0, 0);
+}
+
+long scheme_equal_hash_key2(Scheme_Object *o)
+{
+  return equal_hash_key2(o, 0);
 }
 
 static Scheme_Object *hash2_k(void)
@@ -1141,7 +1161,7 @@ static Scheme_Object *hash2_k(void)
 
   p->ku.k.p1 = NULL;
   
-  nv = scheme_equal_hash_key2(v);
+  nv = equal_hash_key2(v, p->ku.k.i2);
 
   return scheme_make_integer(nv);
 }
@@ -1150,8 +1170,9 @@ static Scheme_Object *hash2_k(void)
 #undef MZ_HASH_I1
 #define MZ_HASH_K hash2_k
 #define MZ_HASH_I1 0
+#define MZ_HASH_I2 depth
 
-long scheme_equal_hash_key2(Scheme_Object *o)
+static long equal_hash_key2(Scheme_Object *o, long depth)
 {
   Scheme_Type t;
   static int hash_counter = HASH_COUNT_START;
@@ -1159,6 +1180,9 @@ long scheme_equal_hash_key2(Scheme_Object *o)
  top:
   t = SCHEME_TYPE(o);
 
+  if (depth > MAX_HASH_DEPTH)
+    return t;
+  
   switch(t) {
   case scheme_integer_type:
     return t;
@@ -1184,30 +1208,30 @@ long scheme_equal_hash_key2(Scheme_Object *o)
   case scheme_bignum_type:
     return SCHEME_BIGDIG(o)[0];
   case scheme_rational_type:
-    return scheme_equal_hash_key2(scheme_rational_numerator(o));
+    return equal_hash_key2(scheme_rational_numerator(o), depth);
   case scheme_complex_type:
   case scheme_complex_izi_type:
     {
       long v1, v2;
       Scheme_Complex *c = (Scheme_Complex *)o;
-      v1 = scheme_equal_hash_key2(c->r);
+      v1 = equal_hash_key2(c->r, depth);
-      v2 = scheme_equal_hash_key2(c->i);
+      v2 = equal_hash_key2(c->i, depth);
       return v1 + v2;
     }
   case scheme_pair_type:
     {
       long v1, v2;
 #     include "mzhashchk.inc"
-      v1 = scheme_equal_hash_key2(SCHEME_CAR(o));
+      v1 = equal_hash_key2(SCHEME_CAR(o), depth + 1);
-      v2 = scheme_equal_hash_key2(SCHEME_CDR(o));
+      v2 = equal_hash_key2(SCHEME_CDR(o), depth + 1);
       return v1 + v2;
     }
   case scheme_mutable_pair_type:
     {
       long v1, v2;
 #     include "mzhashchk.inc"
-      v1 = scheme_equal_hash_key2(SCHEME_CAR(o));
+      v1 = equal_hash_key2(SCHEME_CAR(o), depth + 1);
-      v2 = scheme_equal_hash_key2(SCHEME_CDR(o));
+      v2 = equal_hash_key2(SCHEME_CDR(o), depth + 1);
       return v1 + v2;
     }
   case scheme_vector_type:
@@ -1218,9 +1242,11 @@ long scheme_equal_hash_key2(Scheme_Object *o)
 
 #     include "mzhashchk.inc"
 
+      depth++;
+
       for (i = 0; i < len; i++) {
 	SCHEME_USE_FUEL(1);
-	k += scheme_equal_hash_key2(SCHEME_VEC_ELS(o)[i]);
+	k += equal_hash_key2(SCHEME_VEC_ELS(o)[i], depth);
       }
       
       return k;
@@ -1263,8 +1289,10 @@ long scheme_equal_hash_key2(Scheme_Object *o)
 	
 #       include "mzhashchk.inc"
 	
+        depth++;
+
 	for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) {
-	  k += scheme_equal_hash_key2(s1->slots[i]);
+	  k += equal_hash_key2(s1->slots[i], depth);
 	}
 	
 	return k;
@@ -1273,6 +1301,7 @@ long scheme_equal_hash_key2(Scheme_Object *o)
     }
   case scheme_box_type:
     o = SCHEME_BOX_VAL(o);
+    depth++;
     goto top;
   case scheme_hash_table_type:
     {
@@ -1283,12 +1312,14 @@ long scheme_equal_hash_key2(Scheme_Object *o)
       
 #     include "mzhashchk.inc"
 
+      depth++;
+
       keys = ht->keys;
       vals = ht->vals;
       for (i = ht->size; i--; ) {
 	if (vals[i]) {
-	  k += scheme_equal_hash_key2(keys[i]);
+	  k += equal_hash_key2(keys[i], depth);
-	  k += scheme_equal_hash_key2(vals[i]);
+	  k += equal_hash_key2(vals[i], depth);
 	}
       }
       
@@ -1307,6 +1338,8 @@ long scheme_equal_hash_key2(Scheme_Object *o)
       buckets = ht->buckets;
       weak = ht->weak;
       
+      depth++;
+
       for (i = ht->size; i--; ) {
 	bucket = buckets[i];
 	if (bucket) {
@@ -1316,8 +1349,8 @@ long scheme_equal_hash_key2(Scheme_Object *o)
 	    key = bucket->key;
 	  }
 	  if (key) {
-	    k += scheme_equal_hash_key((Scheme_Object *)bucket->val);
+	    k += equal_hash_key2((Scheme_Object *)bucket->val, depth);
-	    k += scheme_equal_hash_key((Scheme_Object *)key);
+	    k += equal_hash_key2((Scheme_Object *)key, depth);
 	  }
 	}
       }
@@ -1332,9 +1365,19 @@ long scheme_equal_hash_key2(Scheme_Object *o)
     {
       Scheme_Secondary_Hash_Proc h2 = scheme_type_hash2s[t];
       if (h2)
-        return h2(o);
+        return h2(o, scheme_make_integer(depth));
       else
         return t;
     }
   }
 }
+
+long scheme_recur_equal_hash_key(Scheme_Object *o, void *cycle_data)
+{
+  return equal_hash_key(o, 0, SCHEME_INT_VAL(cycle_data));
+}
+
+long scheme_recur_equal_hash_key2(Scheme_Object *o, void *cycle_data)
+{
+  return equal_hash_key2(o, SCHEME_INT_VAL(cycle_data));
+}

src/mzscheme/src/mzeqchk.inc

@@ -6,14 +6,7 @@
 #ifdef DO_STACK_CHECK
       {
 #include "mzstkchk.h"
-	{
+        return is_equal_overflow(obj1, obj2, eql);
-#ifndef ERROR_ON_OVERFLOW
-	  Scheme_Thread *p = scheme_current_thread;
-	  p->ku.k.p1 = (void *)obj1;
-	  p->ku.k.p2 = (void *)obj2;
-#endif
-	  return SCHEME_TRUEP(scheme_handle_stack_overflow(equal_k));
-	}
       }
 #endif
     }

src/mzscheme/src/mzhashchk.inc

@@ -13,6 +13,7 @@
 	  Scheme_Thread *p = scheme_current_thread;
 	  p->ku.k.p1 = (void *)o;
           p->ku.k.i1 = MZ_HASH_I1;
+          p->ku.k.i2 = MZ_HASH_I2;
 #endif
 	  nv = scheme_handle_stack_overflow(MZ_HASH_K);
 	  scheme_get_int_val(nv, &val);

src/mzscheme/src/schemef.h

@@ -980,11 +980,14 @@ XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
 #endif
 MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o);
 MZ_EXTERN long scheme_equal_hash_key2(Scheme_Object *o);
+MZ_EXTERN long scheme_recur_equal_hash_key(Scheme_Object *o, void *cycle_data);
+MZ_EXTERN long scheme_recur_equal_hash_key2(Scheme_Object *o, void *cycle_data);
 
 MZ_EXTERN void scheme_set_type_equality(Scheme_Type type, 
                                         Scheme_Equal_Proc f,
                                         Scheme_Primary_Hash_Proc hash1,
                                         Scheme_Secondary_Hash_Proc hash2);
+MZ_EXTERN int scheme_recur_equal(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info);
 
 MZ_EXTERN Scheme_Object *scheme_build_list(int argc, Scheme_Object **argv);
 MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta);

src/mzscheme/src/schemex.h

@@ -811,10 +811,13 @@ long (*scheme_hash_key)(Scheme_Object *o);
 #endif
 long (*scheme_equal_hash_key)(Scheme_Object *o);
 long (*scheme_equal_hash_key2)(Scheme_Object *o);
+long (*scheme_recur_equal_hash_key)(Scheme_Object *o, void *cycle_data);
+long (*scheme_recur_equal_hash_key2)(Scheme_Object *o, void *cycle_data);
 void (*scheme_set_type_equality)(Scheme_Type type, 
                                         Scheme_Equal_Proc f,
                                         Scheme_Primary_Hash_Proc hash1,
                                         Scheme_Secondary_Hash_Proc hash2);
+int (*scheme_recur_equal)(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_info);
 Scheme_Object *(*scheme_build_list)(int argc, Scheme_Object **argv);
 Scheme_Object *(*scheme_build_list_offset)(int argc, Scheme_Object **argv, int delta);
 int (*scheme_is_list)(Scheme_Object *obj1);

src/mzscheme/src/schemex.inc

@@ -552,7 +552,10 @@
 #endif
   scheme_extension_table->scheme_equal_hash_key = scheme_equal_hash_key;
   scheme_extension_table->scheme_equal_hash_key2 = scheme_equal_hash_key2;
+  scheme_extension_table->scheme_recur_equal_hash_key = scheme_recur_equal_hash_key;
+  scheme_extension_table->scheme_recur_equal_hash_key2 = scheme_recur_equal_hash_key2;
   scheme_extension_table->scheme_set_type_equality = scheme_set_type_equality;
+  scheme_extension_table->scheme_recur_equal = scheme_recur_equal;
   scheme_extension_table->scheme_build_list = scheme_build_list;
   scheme_extension_table->scheme_build_list_offset = scheme_build_list_offset;
   scheme_extension_table->scheme_is_list = scheme_is_list;

src/mzscheme/src/schemexm.h

@@ -552,7 +552,10 @@
 #endif
 #define scheme_equal_hash_key (scheme_extension_table->scheme_equal_hash_key)
 #define scheme_equal_hash_key2 (scheme_extension_table->scheme_equal_hash_key2)
+#define scheme_recur_equal_hash_key (scheme_extension_table->scheme_recur_equal_hash_key)
+#define scheme_recur_equal_hash_key2 (scheme_extension_table->scheme_recur_equal_hash_key2)
 #define scheme_set_type_equality (scheme_extension_table->scheme_set_type_equality)
+#define scheme_recur_equal (scheme_extension_table->scheme_recur_equal)
 #define scheme_build_list (scheme_extension_table->scheme_build_list)
 #define scheme_build_list_offset (scheme_extension_table->scheme_build_list_offset)
 #define scheme_is_list (scheme_extension_table->scheme_is_list)