diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss index 3b17296d76..7730d2e0f9 100644 --- a/collects/frtime/frp-core.ss +++ b/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)))) diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index 01af040c18..a825228f09 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -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) diff --git a/collects/scribblings/inside/misc.scrbl b/collects/scribblings/inside/misc.scrbl index 6bb8f8063b..4c50e9354e 100644 --- a/collects/scribblings/inside/misc.scrbl +++ 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])]{ diff --git a/collects/scribblings/inside/values.scrbl b/collects/scribblings/inside/values.scrbl index 1655eab235..82fb801c21 100644 --- a/collects/scribblings/inside/values.scrbl +++ b/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 - 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[#< (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: diff --git a/collects/tests/mzscheme/htdp.ss b/collects/tests/mzscheme/htdp.ss new file mode 100644 index 0000000000..e317b4c005 --- /dev/null +++ b/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) diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc index 42b763465d..6772ef5b70 100644 --- a/src/mzscheme/cmdline.inc +++ b/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. */ diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index cd8331e171..2a42cfd036 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/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 diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index ad23db8746..15bf60e8e9 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/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 diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index add58ef73f..c95a780f6e 100644 --- a/src/mzscheme/include/mzwin.def +++ b/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 diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index d25ca4a4a0..1ec30af225 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/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 diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 620fcdb920..b60af575ec 100644 --- a/src/mzscheme/include/scheme.h +++ b/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 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 diff --git a/src/mzscheme/src/bool.c b/src/mzscheme/src/bool.c index f0b498c8ec..f766d2761d 100644 --- a/src/mzscheme/src/bool.c +++ b/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); -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) { diff --git a/src/mzscheme/src/hash.c b/src/mzscheme/src/hash.c index 065749579d..1230449efd 100644 --- a/src/mzscheme/src/hash.c +++ b/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; @@ -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)); +} diff --git a/src/mzscheme/src/mzeqchk.inc b/src/mzscheme/src/mzeqchk.inc index a51e64189f..6183711c13 100644 --- a/src/mzscheme/src/mzeqchk.inc +++ b/src/mzscheme/src/mzeqchk.inc @@ -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 } diff --git a/src/mzscheme/src/mzhashchk.inc b/src/mzscheme/src/mzhashchk.inc index b740714614..2c6e8fb97b 100644 --- a/src/mzscheme/src/mzhashchk.inc +++ b/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); diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 1efa2ca8b7..342ff282a9 100644 --- a/src/mzscheme/src/schemef.h +++ b/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); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 8acd0b72f4..d711a9d995 100644 --- a/src/mzscheme/src/schemex.h +++ b/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); diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index 798dbaa20d..000cd4e34c 100644 --- a/src/mzscheme/src/schemex.inc +++ b/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; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index 7688b9a5b9..352cc4deea 100644 --- a/src/mzscheme/src/schemexm.h +++ b/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)