equal? and hashing work on cyclic values

svn: r8132
This commit is contained in:
Matthew Flatt 2007-12-27 11:07:14 +00:00
parent 8f20fce7f6
commit c0872f69ea
22 changed files with 461 additions and 166 deletions

View File

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

View File

@ -185,56 +185,79 @@ namespace.
(define-teach beginner exit (define-teach beginner exit
(lambda () (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) (define (tequal? a b epsilon)
(let ? ([a a][b b]) (let* ([ht (make-hash-table)]
(or (equal? a b) [union-find (lambda (a)
(cond (let loop ([prev a]
[(box? a) [prev-prev a])
(and (box? b) (let ([v (hash-table-get ht prev #f)])
(? (unbox a) (unbox b)))] (if v
[(pair? a) (loop v prev)
(and (pair? b) (begin
(? (car a) (car b)) (let loop ([a a])
(? (cdr a) (cdr b)))] (unless (eq? a prev-prev)
[(vector? a) (let ([v (hash-table-get ht a)])
(and (vector? b) (hash-table-put! ht a prev)
(= (vector-length a) (vector-length b)) (loop v))))
(andmap ? prev)))))]
(vector->list a) [union-equal? (lambda (a b)
(vector->list b)))] (let ([a (union-find a)]
[(image? a) [b (union-find b)])
(and (image? b) (if (eq? a b)
(image=? a b))] #t
[(real? a) (begin
(and epsilon (hash-table-put! ht b a)
(real? b) #f))))])
(beginner-=~ a b epsilon))] (let ? ([a a][b b])
[(struct? a) (or (eqv? a b)
(and (struct? b) (cond
(let-values ([(ta sa?) (struct-info a)] [(box? a)
[(tb sb?) (struct-info b)]) (and (box? b)
(and (not sa?) (? (unbox a) (unbox b)))]
(not sb?) [(pair? a)
(eq? ta tb) (and (pair? b)
(? (struct->vector a) (or (union-equal? a b)
(struct->vector b)))))] (and (? (car a) (car b))
[(hash-table? a) (? (cdr a) (cdr b)))))]
(and (hash-table? b) [(vector? a)
(eq? (immutable? a) (immutable? b)) (and (vector? b)
(eq? (hash-table? a 'weak) (hash-table? b 'weak)) (= (vector-length a) (vector-length b))
(eq? (hash-table? a 'equal) (hash-table? b 'equal)) (or (union-equal? a b)
(let ([al (hash-table-map a cons)] (andmap ?
[bl (hash-table-map b cons)]) (vector->list a)
(and (= (length al) (length bl)) (vector->list b))))]
(for-each [(image? a)
(lambda (ai) (and (image? b)
(? (hash-table-get b (car ai) (lambda () (not (cdr ai)))) (image=? a b))]
(cdr ai))) [(real? a)
al))))] (and epsilon
[else #f])))) (real? b)
(beginner-=~ a b epsilon))]
[(struct? a)
(and (struct? b)
(let-values ([(ta sa?) (struct-info a)]
[(tb sb?) (struct-info b)])
(and (not sa?)
(not sb?)
(eq? ta tb)
(or (union-equal? a b)
(? (struct->vector a)
(struct->vector b))))))]
[(hash-table? a)
(and (hash-table? b)
(eq? (immutable? a) (immutable? b))
(eq? (hash-table? a 'weak) (hash-table? b 'weak))
(eq? (hash-table? a 'equal) (hash-table? b 'equal))
(let ([al (hash-table-map a cons)]
[bl (hash-table-map b cons)])
(and (= (length al) (length bl))
(or (union-equal? a b)
(andmap
(lambda (ai)
(? (hash-table-get b (car ai) (lambda () (not (cdr ai))))
(cdr ai)))
al)))))]
[else (equal? a b)])))))
(define-teach beginner equal? (define-teach beginner equal?
(lambda (a b) (lambda (a b)

View File

@ -26,9 +26,46 @@ Returns 1 if the Scheme values are @scheme[eqv?].}
Returns 1 if the Scheme values are @scheme[equal?].} 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 @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] [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] [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] [int c]
[Scheme_Object** elems])]{ [Scheme_Object** elems])]{

View File

@ -727,21 +727,36 @@ Writes the content of @var{str} --- starting from @var{offset} and
[Scheme_Secondary_Hash_Proc hash2])]{ [Scheme_Secondary_Hash_Proc hash2])]{
Installs an equality predicate and associated hash functions for 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 @verbatim[#<<EOS
typedef int (*Scheme_Equal_Proc)(Scheme_Object *obj1, typedef int (*Scheme_Equal_Proc)(Scheme_Object* obj1,
Scheme_Object *obj2); Scheme_Object* obj2,
typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, void* cycle_data);
long base); typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object* obj,
typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj); long base,
void* cycle_data);
typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object* obj,
void* cycle_data);
EOS EOS
] ]
The two hash functions are use to generate primary and secondary keys The two hash functions are use to generate primary and secondary keys
for double hashing in an @scheme[equal?]-based hash table. The result for double hashing in an @scheme[equal?]-based hash table. The result
of the primary-key function should depend on both @var{obj} and 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).}

View File

@ -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?], Two values are @scheme[equal?] if and only if they are @scheme[eqv?],
unless otherwise specified for a particular datatype. 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?]{ @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 Returns an exact integer; for any two @scheme[equal?] values, the
returned integer is the same. Furthermore, for the result integer returned integer is the same. Furthermore, for the result integer
@scheme[k] and any other exact integer @scheme[j], @scheme[(= k j)] @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"] @include-section["sequences.scrbl"]

View File

@ -193,13 +193,20 @@
(load (build-path (collection-path "tests" "mzscheme") "shared-tests.ss")) (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? (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) 'apple) 0.1))
(htdp-test #t 'equal~? (equal~? (vector (list 10) 'apple) (vector (list 10.02) '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 #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))))
(htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10)) 0.1)) (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 #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 ;; Simulate set! in the repl
(module my-advanced-module (lib "htdp-advanced.ss" "lang") (module my-advanced-module (lib "htdp-advanced.ss" "lang")

View File

@ -107,56 +107,77 @@
(test #t 'equal? (equal? deep-list (read (open-input-string (get-output-string s))))) (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-struct a (b c) #:inspector (make-inspector) #:mutable)
(define l1 (make-a 0 #f)) (define l1 (make-a 0 #f))
(set-a-b! l1 l1) (set-a-b! l1 l1)
(define l2 (make-a 0 #f)) (define l2 (make-a 0 #f))
(set-a-b! l2 l2) (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)) (define l1 (box 0))
(set-box! l1 l1) (set-box! l1 l1)
(define l2 (box 0)) (define l2 (box 0))
(set-box! l2 l2) (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: ;; Overflow in hashing:

View File

@ -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)

View File

@ -1159,7 +1159,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
#endif #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 /* These declarations avoid linker problems when using
-mmacosx-version-min. See gc2/vm_osx.c for details. */ -mmacosx-version-min. See gc2/vm_osx.c for details. */

View File

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

View File

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

View File

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

View File

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

View File

@ -319,9 +319,9 @@ typedef struct Scheme_Vector {
typedef struct Scheme_Print_Params Scheme_Print_Params; typedef struct Scheme_Print_Params Scheme_Print_Params;
typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp); 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 */ /* This file defines all the built-in types */
#ifdef INCLUDE_WITHOUT_PATHS #ifdef INCLUDE_WITHOUT_PATHS

View File

@ -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 *eqv_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *equal_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) void scheme_init_true_false(void)
{ {
@ -116,7 +123,13 @@ eqv_prim (int argc, Scheme_Object *argv[])
static Scheme_Object * static Scheme_Object *
equal_prim (int argc, Scheme_Object *argv[]) 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) int scheme_eq (Scheme_Object *obj1, Scheme_Object *obj2)
@ -199,22 +212,102 @@ int scheme_eqv (Scheme_Object *obj1, Scheme_Object *obj2)
return 0; 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_Thread *p = scheme_current_thread;
Scheme_Object *v1 = (Scheme_Object *)p->ku.k.p1; Scheme_Object *v1 = (Scheme_Object *)p->ku.k.p1;
Scheme_Object *v2 = (Scheme_Object *)p->ku.k.p2; 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 /* Number of lists/vectors/structs/boxes to compare before
paying for a stack check. */ paying for a stack check. */
#define EQUAL_COUNT_START 20 #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; static int equal_counter = EQUAL_COUNT_START;
@ -225,7 +318,13 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
return 0; return 0;
else if (SCHEME_PAIRP(obj1)) { else if (SCHEME_PAIRP(obj1)) {
# include "mzeqchk.inc" # 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); obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2); obj2 = SCHEME_CDR(obj2);
goto top; goto top;
@ -233,7 +332,9 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
return 0; return 0;
} else if (SCHEME_MUTABLE_PAIRP(obj1)) { } else if (SCHEME_MUTABLE_PAIRP(obj1)) {
# include "mzeqchk.inc" # 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); obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2); obj2 = SCHEME_CDR(obj2);
goto top; goto top;
@ -241,7 +342,9 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
return 0; return 0;
} else if (SCHEME_VECTORP(obj1)) { } else if (SCHEME_VECTORP(obj1)) {
# include "mzeqchk.inc" # 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) } else if (SCHEME_BYTE_STRINGP(obj1)
|| SCHEME_GENERAL_PATHP(obj1)) { || SCHEME_GENERAL_PATHP(obj1)) {
int l1, l2; int l1, l2;
@ -264,35 +367,47 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
if (scheme_inspector_sees_part(obj1, insp, -2) if (scheme_inspector_sees_part(obj1, insp, -2)
&& scheme_inspector_sees_part(obj2, insp, -2)) { && scheme_inspector_sees_part(obj2, insp, -2)) {
# include "mzeqchk.inc" # include "mzeqchk.inc"
return struct_equal(obj1, obj2); if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, obj2, eql);
} else } else
return 0; return 0;
} }
} else if (SCHEME_BOXP(obj1)) { } else if (SCHEME_BOXP(obj1)) {
SCHEME_USE_FUEL(1); SCHEME_USE_FUEL(1);
if (union_check(obj1, obj2, eql))
return 1;
obj1 = SCHEME_BOX_VAL(obj1); obj1 = SCHEME_BOX_VAL(obj1);
obj2 = SCHEME_BOX_VAL(obj2); obj2 = SCHEME_BOX_VAL(obj2);
goto top; goto top;
} else if (SCHEME_HASHTP(obj1)) { } else if (SCHEME_HASHTP(obj1)) {
# include "mzeqchk.inc" # include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2); return scheme_hash_table_equal((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2);
} else if (SCHEME_BUCKTP(obj1)) { } else if (SCHEME_BUCKTP(obj1)) {
# include "mzeqchk.inc" # include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2); return scheme_bucket_table_equal((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2);
} else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) { } 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)) { } 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 { } 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; 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; int i, len;
@ -303,14 +418,14 @@ static int vector_equal(Scheme_Object *vec1, Scheme_Object *vec2)
SCHEME_USE_FUEL(len); SCHEME_USE_FUEL(len);
for (i = 0; i < len; i++) { 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 0;
} }
return 1; 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; Scheme_Structure *s1, *s2;
int i; int i;
@ -319,13 +434,18 @@ int struct_equal(Scheme_Object *obj1, Scheme_Object *obj2)
s2 = (Scheme_Structure *)obj2; s2 = (Scheme_Structure *)obj2;
for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) { 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 0;
} }
return 1; 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 */ /* used by external programs that cannot link to variables */
Scheme_Object * scheme_make_true (void) Scheme_Object * scheme_make_true (void)
{ {

View File

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

View File

@ -6,14 +6,7 @@
#ifdef DO_STACK_CHECK #ifdef DO_STACK_CHECK
{ {
#include "mzstkchk.h" #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 #endif
} }

View File

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

View File

@ -980,11 +980,14 @@ XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
#endif #endif
MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o); MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o);
MZ_EXTERN long scheme_equal_hash_key2(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, MZ_EXTERN void scheme_set_type_equality(Scheme_Type type,
Scheme_Equal_Proc f, Scheme_Equal_Proc f,
Scheme_Primary_Hash_Proc hash1, Scheme_Primary_Hash_Proc hash1,
Scheme_Secondary_Hash_Proc hash2); 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(int argc, Scheme_Object **argv);
MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta); MZ_EXTERN Scheme_Object *scheme_build_list_offset(int argc, Scheme_Object **argv, int delta);

View File

@ -811,10 +811,13 @@ long (*scheme_hash_key)(Scheme_Object *o);
#endif #endif
long (*scheme_equal_hash_key)(Scheme_Object *o); long (*scheme_equal_hash_key)(Scheme_Object *o);
long (*scheme_equal_hash_key2)(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, void (*scheme_set_type_equality)(Scheme_Type type,
Scheme_Equal_Proc f, Scheme_Equal_Proc f,
Scheme_Primary_Hash_Proc hash1, Scheme_Primary_Hash_Proc hash1,
Scheme_Secondary_Hash_Proc hash2); 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)(int argc, Scheme_Object **argv);
Scheme_Object *(*scheme_build_list_offset)(int argc, Scheme_Object **argv, int delta); Scheme_Object *(*scheme_build_list_offset)(int argc, Scheme_Object **argv, int delta);
int (*scheme_is_list)(Scheme_Object *obj1); int (*scheme_is_list)(Scheme_Object *obj1);

View File

@ -552,7 +552,10 @@
#endif #endif
scheme_extension_table->scheme_equal_hash_key = scheme_equal_hash_key; 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_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_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 = scheme_build_list;
scheme_extension_table->scheme_build_list_offset = scheme_build_list_offset; scheme_extension_table->scheme_build_list_offset = scheme_build_list_offset;
scheme_extension_table->scheme_is_list = scheme_is_list; scheme_extension_table->scheme_is_list = scheme_is_list;

View File

@ -552,7 +552,10 @@
#endif #endif
#define scheme_equal_hash_key (scheme_extension_table->scheme_equal_hash_key) #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_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_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 (scheme_extension_table->scheme_build_list)
#define scheme_build_list_offset (scheme_extension_table->scheme_build_list_offset) #define scheme_build_list_offset (scheme_extension_table->scheme_build_list_offset)
#define scheme_is_list (scheme_extension_table->scheme_is_list) #define scheme_is_list (scheme_extension_table->scheme_is_list)