suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

equal? and hashing work on cyclic values

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/frtime/frp-core.ss
View File

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

121
collects/lang/private/teachprims.ss
View File

@ -185,56 +185,79 @@ 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 ? ([a a][b b])
(or (equal? a b)
(cond
[(box? a)
(and (box? b)
(? (unbox a) (unbox b)))]
[(pair? a)
(and (pair? b)
(? (car a) (car b))
(? (cdr a) (cdr b)))]
[(vector? a)
(and (vector? b)
(= (vector-length a) (vector-length b))
(andmap ?
(vector->list a)
(vector->list b)))]
[(image? a)
(and (image? b)
(image=? a b))]
[(real? a)
(and epsilon
(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)
(? (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))
(for-each
(lambda (ai)
(? (hash-table-get b (car ai) (lambda () (not (cdr ai))))
(cdr ai)))
al))))]
[else #f]))))
(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 (eqv? a b)
(cond
[(box? a)
(and (box? b)
(? (unbox a) (unbox b)))]
[(pair? a)
(and (pair? b)
(or (union-equal? a 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))))]
[(image? a)
(and (image? b)
(image=? a b))]
[(real? a)
(and epsilon
(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?
(lambda (a b)

37
collects/scribblings/inside/misc.scrbl
View File

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

33
collects/scribblings/inside/values.scrbl
View File

@ -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
only applied to values that both have tag @var{type}.
values that have the type tag @var{type}. The @var{equalp} predicate
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);
typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj,
long base);
typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj);
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,
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).}

15
collects/scribblings/reference/data.scrbl
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?],
unless otherwise specified for a particular datatype.
Datatypes with further specification of @scheme[equal?] include strings,
byte strings, numbers, pairs, vectors, and hash tables.}
Datatypes with further specification of @scheme[equal?] include
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
pairs, vectors, boxes, and/or inspectable structure fields, then
@scheme[equal-hash-code] applied to @scheme[v] will loop
indefinitely.}
implies @scheme[(eq? k j)]. A has code is computed even when
@scheme[v] contains a cycle through pairs, vectors, boxes, and/or
inspectable structure fields.}
@; ----------------------------------------------------------------------
@include-section["sequences.scrbl"]

9
collects/tests/mzscheme/advanced.ss
View File

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

91
collects/tests/mzscheme/deep.ss
View File

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

10
collects/tests/mzscheme/htdp.ss Normal file
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)

2
src/mzscheme/cmdline.inc
View File

@ -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. */

3
src/mzscheme/include/mzscheme.exp
View File

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

3
src/mzscheme/include/mzscheme3m.exp
View File

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

3
src/mzscheme/include/mzwin.def
View File

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

3
src/mzscheme/include/mzwin3m.def
View File

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

6
src/mzscheme/include/scheme.h
View File

@ -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 long (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, long base);
typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj);
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, void *cycle_data);
typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data);
/* This file defines all the built-in types */
#ifdef INCLUDE_WITHOUT_PATHS

162
src/mzscheme/src/bool.c
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 *equal_prim (int argc, Scheme_Object *argv[]);
static int vector_equal (Scheme_Object *vec1, Scheme_Object *vec2);
static int struct_equal (Scheme_Object *s1, Scheme_Object *s2);
typedef struct Equal_Info {
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)];
if (eql)
return eql(obj1, obj2);
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;
}
}
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)
{

105
src/mzscheme/src/hash.c
View File

@ -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;
@ -878,6 +882,9 @@ static long equal_hash_key(Scheme_Object *o, long k)
top:
t = SCHEME_TYPE(o);
k += t;
if (depth > MAX_HASH_DEPTH)
return k;
switch(t) {
case scheme_integer_type:
@ -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);
v2 = scheme_equal_hash_key2(c->i);
v1 = equal_hash_key2(c->r, depth);
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));
v2 = scheme_equal_hash_key2(SCHEME_CDR(o));
v1 = equal_hash_key2(SCHEME_CAR(o), depth + 1);
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));
v2 = scheme_equal_hash_key2(SCHEME_CDR(o));
v1 = equal_hash_key2(SCHEME_CAR(o), depth + 1);
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 += scheme_equal_hash_key2(vals[i]);
k += equal_hash_key2(keys[i], depth);
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 += scheme_equal_hash_key((Scheme_Object *)key);
k += equal_hash_key2((Scheme_Object *)bucket->val, depth);
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));
}

9
src/mzscheme/src/mzeqchk.inc
View File

@ -6,14 +6,7 @@
#ifdef DO_STACK_CHECK
{
#include "mzstkchk.h"
{
#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));
}
return is_equal_overflow(obj1, obj2, eql);
}
#endif
}

1
src/mzscheme/src/mzhashchk.inc
View File

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

3
src/mzscheme/src/schemef.h
View File

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

3
src/mzscheme/src/schemex.h
View File

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

3
src/mzscheme/src/schemex.inc
View File

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

3
src/mzscheme/src/schemexm.h
View File

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