From 8bbc00c7c157340eb235189fd94cace349db4c34 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 14 Apr 2014 10:14:20 -0600 Subject: [PATCH] fix `equal?` on chaperoned values Recursive traversal of components should use chaperoned access of the components, not direct access. --- .../racket-test/tests/racket/chaperone.rktl | 48 ++++++++-- racket/src/racket/src/bool.c | 95 +++++++++++++------ racket/src/racket/src/hash.c | 68 +++++++++---- racket/src/racket/src/schpriv.h | 12 ++- 4 files changed, 170 insertions(+), 53 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl index c038bbe15c..d7cdf7f31b 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl @@ -102,6 +102,8 @@ (test "bad get" exn-message exn))) (err/rt-test (equal-secondary-hash-code b2) (lambda (exn) (test "bad get" exn-message exn))) + (err/rt-test (equal? b2 (box 'bad)) (lambda (exn) + (test "bad get" exn-message exn))) (test (void) set-box! b 'ok) (test 'ok unbox b2) (test (void) set-box! b2 'fine) @@ -165,8 +167,8 @@ (test "bad get" exn-message exn))) (err/rt-test (equal-hash-code b2) (lambda (exn) (test "bad get" exn-message exn))) - (err/rt-test (equal-secondary-hash-code b2) (lambda (exn) - (test "bad get" exn-message exn))) + (err/rt-test (equal? b2 (vector 1 'bad 3)) (lambda (exn) + (test "bad get" exn-message exn))) (test (void) vector-set! b 1 'ok) (test 'ok vector-ref b2 1) (test (void) vector-set! b2 1 'fine) @@ -584,25 +586,49 @@ (test #t values got?) (set! got? #f) (void (equal-secondary-hash-code c1)) + (test #t values got?) + (set! got? #f) + (void (equal? c1 (c 1))) (test #t values got?)) + ;; Hashing with `prop:equal+hash`: (let () (define got? #f) (define mine? #t) (define check! (lambda (o) (set! mine? #t) (d-n o))) (struct d ([n #:mutable]) - #:transparent #:property prop:equal+hash (list - (lambda (a b r) (r a b)) + (lambda (a b r) (r (d-n a) (d-n b))) (lambda (a r) (check! a) 0) (lambda (a r) (check! a) 0))) - (define d1 (chaperone-struct (d 1) d-n (lambda (b v) (set! got? #t) v))) + (define d1 (chaperone-struct (d 1) + d-n (lambda (b v) (set! got? #t) v) + set-d-n! (lambda (b v) v))) (void (equal-hash-code d1)) (test '(#t #t) list got? mine?) (set! got? #f) (set! mine? #f) (void (equal-secondary-hash-code d1)) - (test '(#t #t) list got? mine?))) + (test '(#t #t) list got? mine?) + (set! got? #f) + (set! mine? #f) + (test #t values (equal? d1 (d 1))) + (test '(#t #f) list got? mine?)) + + ;; Hashing without `prop:equal+hash`: + (let () + (define got? #f) + (struct d ([n #:mutable]) + #:transparent) + (define d1 (chaperone-struct (d 1) d-n (lambda (b v) (set! got? #t) v))) + (void (equal-hash-code d1)) + (test '(#t) list got?) + (set! got? #f) + (void (equal-secondary-hash-code d1)) + (test '(#t) list got?) + (set! got? #f) + (test #t values (equal? d1 (d 1))) + (test '(#t) list got?))) ;; ---------------------------------------- @@ -816,6 +842,12 @@ (set! get-v #f) (void (equal-secondary-hash-code h2)) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) + (set! get-k #f) + (set! get-v #f) + (test #t values (equal? h2 (let* ([h2 (make-hash)]) + (test (void) hash-set! h2 'key 'val) + h2))) + (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) (void))) (list make-hash make-hasheq make-hasheqv @@ -880,6 +912,10 @@ (set! get-v #f) (void (equal-secondary-hash-code h2)) (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) + (set! get-k #f) + (set! get-v #f) + (test #t values (equal? h2 (hash-set h1 'key 'val))) + (test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k) (void))))))) (list #hash() #hasheq() #hasheqv())) diff --git a/racket/src/racket/src/bool.c b/racket/src/racket/src/bool.c index 1ccae89b1c..2ee4b0f7d9 100644 --- a/racket/src/racket/src/bool.c +++ b/racket/src/racket/src/bool.c @@ -62,8 +62,12 @@ typedef struct Equal_Info { } 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); +static int vector_equal (Scheme_Object *vec1, Scheme_Object *orig_vec1, + Scheme_Object *vec2, Scheme_Object *orig_vec2, + Equal_Info *eql); +static int struct_equal (Scheme_Object *s1, Scheme_Object *orig_s1, + Scheme_Object *s2, Scheme_Object *orig_s2, + Equal_Info *eql); static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj); void scheme_init_true_false(void) @@ -435,8 +439,12 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) { Scheme_Type t1, t2; int cmp; + Scheme_Object *orig_obj1, *orig_obj2; top: + orig_obj1 = obj1; + orig_obj2 = obj2; + if (eql->next_next) { if (eql->next) { Scheme_Object *a[2]; @@ -448,6 +456,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) eql->next = eql->next_next; } + top_after_next: cmp = is_eqv(obj1, obj2); if (cmp > -1) return cmp; @@ -457,7 +466,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR) || (eql->for_chaperone > 1))) { obj1 = ((Scheme_Chaperone *)obj1)->prev; - goto top; + goto top_after_next; } t1 = SCHEME_TYPE(obj1); @@ -467,11 +476,11 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) if (!eql->for_chaperone) { if (SCHEME_CHAPERONEP(obj1)) { obj1 = ((Scheme_Chaperone *)obj1)->val; - goto top; + goto top_after_next; } if (SCHEME_CHAPERONEP(obj2)) { obj2 = ((Scheme_Chaperone *)obj2)->val; - goto top; + goto top_after_next; } } return 0; @@ -509,7 +518,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) return 0; if (union_check(obj1, obj2, eql)) return 1; - return vector_equal(obj1, obj2, eql); + return vector_equal(obj1, orig_obj1, obj2, orig_obj2, eql); } else if (t1 == scheme_flvector_type) { intptr_t l1, l2, i; l1 = SCHEME_FLVEC_SIZE(obj1); @@ -590,9 +599,9 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) if (procs1 || procs2) { /* impersonator-of property trumps other forms of checking */ - if (procs1) obj1 = procs1; - if (procs2) obj2 = procs2; - goto top; + if (procs1) { obj1 = procs1; orig_obj1 = obj1; } + if (procs2) { obj2 = procs2; orig_obj2 = obj2; } + goto top_after_next; } else { procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1); if (procs1 && (st1 != st2)) { @@ -626,8 +635,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) } memcpy(eql2, eql, sizeof(Equal_Info)); - a[0] = obj1; - a[1] = obj2; + a[0] = orig_obj1; + a[1] = orig_obj2; a[2] = recur; procs1 = SCHEME_VEC_ELS(procs1)[1]; @@ -655,7 +664,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) # include "mzeqchk.inc" if (union_check(obj1, obj2, eql)) return 1; - return struct_equal(obj1, obj2, eql); + return struct_equal(obj1, orig_obj1, obj2, orig_obj2, eql); } else return 0; } @@ -667,8 +676,14 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) return 0; if (union_check(obj1, obj2, eql)) return 1; - obj1 = SCHEME_BOX_VAL(obj1); - obj2 = SCHEME_BOX_VAL(obj2); + if (SAME_OBJ(obj1, orig_obj1)) + obj1 = SCHEME_BOX_VAL(obj1); + else + obj1 = scheme_unbox(orig_obj1); + if (SAME_OBJ(obj2, orig_obj2)) + obj2 = SCHEME_BOX_VAL(obj2); + else + obj2 = scheme_unbox(orig_obj2); goto top; } else if (t1 == scheme_hash_table_type) { # include "mzeqchk.inc" @@ -676,24 +691,30 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) return 0; if (union_check(obj1, obj2, eql)) return 1; - return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2, eql); + return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, orig_obj1, + (Scheme_Hash_Table *)obj2, orig_obj2, + eql); } else if (t1 == scheme_hash_tree_type) { # include "mzeqchk.inc" if (union_check(obj1, obj2, eql)) return 1; - return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql); + return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, orig_obj1, + (Scheme_Hash_Tree *)obj2, orig_obj2, + eql); } else if (t1 == scheme_bucket_table_type) { # include "mzeqchk.inc" if (eql->for_chaperone == 1) return 0; if (union_check(obj1, obj2, eql)) return 1; - return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql); + return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, orig_obj1, + (Scheme_Bucket_Table *)obj2, orig_obj2, + eql); } else if (t1 == scheme_cpointer_type) { return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1)) == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2))); } else if (t1 == scheme_wrap_chunk_type) { - return vector_equal(obj1, obj2, eql); + return vector_equal(obj1, obj1, obj2, obj2, eql); } else if (t1 == scheme_resolved_module_path_type) { obj1 = SCHEME_PTR_VAL(obj1); obj2 = SCHEME_PTR_VAL(obj2); @@ -720,7 +741,7 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) /* both chaperones */ obj1 = ((Scheme_Chaperone *)obj1)->val; obj2 = ((Scheme_Chaperone *)obj2)->val; - goto top; + goto top_after_next; } else { Scheme_Equal_Proc eqlp = scheme_type_equals[t1]; if (eqlp) { @@ -732,9 +753,12 @@ 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 vector_equal(Scheme_Object *vec1, Scheme_Object *orig_vec1, + Scheme_Object *vec2, Scheme_Object *orig_vec2, + Equal_Info *eql) { intptr_t i, len; + Scheme_Object *v1, *v2; len = SCHEME_VEC_SIZE(vec1); if (len != SCHEME_VEC_SIZE(vec2)) @@ -743,23 +767,40 @@ static int vector_equal(Scheme_Object *vec1, Scheme_Object *vec2, Equal_Info *eq SCHEME_USE_FUEL(len); for (i = 0; i < len; i++) { - if (!is_equal(SCHEME_VEC_ELS(vec1)[i], SCHEME_VEC_ELS(vec2)[i], eql)) + if (SAME_OBJ(vec1, orig_vec1)) + v1 = SCHEME_VEC_ELS(vec1)[i]; + else + v1 = scheme_chaperone_vector_ref(orig_vec1, i); + if (SAME_OBJ(vec2, orig_vec1)) + v2 = SCHEME_VEC_ELS(vec2)[i]; + else + v2 = scheme_chaperone_vector_ref(orig_vec2, i); + + if (!is_equal(v1, v2, eql)) return 0; } return 1; } -int struct_equal(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) +int struct_equal (Scheme_Object *s1, Scheme_Object *orig_s1, + Scheme_Object *s2, Scheme_Object *orig_s2, + Equal_Info *eql) { - Scheme_Structure *s1, *s2; + Scheme_Object *v1, *v2; int i; - s1 = (Scheme_Structure *)obj1; - s2 = (Scheme_Structure *)obj2; + for (i = SCHEME_STRUCT_NUM_SLOTS(((Scheme_Structure *)s1)); i--; ) { + if (SAME_OBJ(s1, orig_s1)) + v1 = ((Scheme_Structure *)s1)->slots[i]; + else + v1 = scheme_struct_ref(orig_s1, i); + if (SAME_OBJ(s2, orig_s2)) + v2 = ((Scheme_Structure *)s2)->slots[i]; + else + v2 = scheme_struct_ref(orig_s2, i); - for (i = SCHEME_STRUCT_NUM_SLOTS(s1); i--; ) { - if (!is_equal(s1->slots[i], s2->slots[i], eql)) + if (!is_equal(v1, v2, eql)) return 0; } diff --git a/racket/src/racket/src/hash.c b/racket/src/racket/src/hash.c index 42189a5e7d..683a4a462b 100644 --- a/racket/src/racket/src/hash.c +++ b/racket/src/racket/src/hash.c @@ -485,9 +485,11 @@ void scheme_hash_set_atomic(Scheme_Hash_Table *table, Scheme_Object *key, Scheme scheme_end_atomic_no_swap(); } -int scheme_hash_table_equal_rec(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2, void *eql) +int scheme_hash_table_equal_rec(Scheme_Hash_Table *t1, Scheme_Object *orig_t1, + Scheme_Hash_Table *t2, Scheme_Object *orig_t2, + void *eql) { - Scheme_Object **vals, **keys, *v; + Scheme_Object **vals, **keys, *val1, *val2, *key; int i; if ((t1->count != t2->count) @@ -499,10 +501,21 @@ int scheme_hash_table_equal_rec(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2, vo vals = t1->vals; for (i = t1->size; i--; ) { if (vals[i]) { - v = scheme_hash_get(t2, keys[i]); - if (!v) + key = keys[i]; + + if (!SAME_OBJ((Scheme_Object *)t1, orig_t1)) + val1 = scheme_chaperone_hash_traversal_get(orig_t1, key, &key); + else + val1 = vals[i]; + + if (!SAME_OBJ((Scheme_Object *)t2, orig_t2)) + val2 = scheme_chaperone_hash_get(orig_t2, key); + else + val2 = scheme_hash_get(t2, key); + + if (!val2) return 0; - if (!scheme_recur_equal(vals[i], v, eql)) + if (!scheme_recur_equal(val1, val2, eql)) return 0; } } @@ -846,11 +859,12 @@ scheme_change_in_table (Scheme_Bucket_Table *table, const char *key, void *naya) bucket->val = naya; } -int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2, void *eql) +int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Object *orig_t1, + Scheme_Bucket_Table *t2, Scheme_Object *orig_t2, + void *eql) { Scheme_Bucket **buckets, *bucket; - void *v; - const char *key; + Scheme_Object *key, *val1, *val2; int i, weak, checked = 0; /* We can't compare the count values, because they're merely @@ -868,16 +882,26 @@ int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Bucket_Table * bucket = buckets[i]; if (bucket) { if (weak) { - key = (const char *)HT_EXTRACT_WEAK(bucket->key); + key = (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key); } else { - key = bucket->key; + key = (Scheme_Object *)bucket->key; } if (key) { + if (!SAME_OBJ((Scheme_Object *)t1, orig_t1)) + val1 = scheme_chaperone_hash_traversal_get(orig_t1, key, &key); + else + val1 = (Scheme_Object *)bucket->val; + checked++; - v = scheme_lookup_in_table(t2, key); - if (!v) + + if (!SAME_OBJ((Scheme_Object *)t2, orig_t2)) + val2 = scheme_chaperone_hash_get(orig_t2, key); + else + val2 = (Scheme_Object *)scheme_lookup_in_table(t2, (const char *)key); + + if (!val2) return 0; - if (!scheme_recur_equal((Scheme_Object *)bucket->val, (Scheme_Object *)v, eql)) + if (!scheme_recur_equal(val1, val2, eql)) return 0; } } @@ -894,9 +918,9 @@ int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Bucket_Table * bucket = buckets[i]; if (bucket) { if (weak) { - key = (const char *)HT_EXTRACT_WEAK(bucket->key); + key = (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key); } else { - key = bucket->key; + key = (Scheme_Object *)bucket->key; } if (key) { if (!checked) @@ -2704,7 +2728,9 @@ int scheme_hash_tree_index(Scheme_Hash_Tree *tree, mzlonglong pos, Scheme_Object return path_find(tree->root, pos, _key, _val); } -int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2, void *eql) +int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Object *orig_t1, + Scheme_Hash_Tree *t2, Scheme_Object *orig_t2, + void *eql) { Scheme_Object *k, *v, *v2; int i; @@ -2715,7 +2741,15 @@ int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2, void for (i = scheme_hash_tree_next(t1, -1); i != -1; i = scheme_hash_tree_next(t1, i)) { scheme_hash_tree_index(t1, i, &k, &v); - v2 = scheme_hash_tree_get(t2, k); + + if (!SAME_OBJ((Scheme_Object *)t1, orig_t1)) + v = scheme_chaperone_hash_traversal_get(orig_t1, k, &k); + + if (!SAME_OBJ((Scheme_Object *)t2, orig_t2)) + v2 = scheme_chaperone_hash_get(orig_t2, k); + else + v2 = scheme_hash_tree_get(t2, k); + if (!v2) return 0; if (!scheme_recur_equal(v, v2, eql)) diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index c8ed0eb22c..a27b210c6e 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -3991,9 +3991,15 @@ Scheme_Bucket_Table *scheme_make_weak_equal_table(void); Scheme_Bucket_Table *scheme_make_weak_eqv_table(void); Scheme_Bucket_Table *scheme_make_nonlock_equal_bucket_table(void); -int scheme_hash_table_equal_rec(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2, void *eql); -int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2, void *eql); -int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2, void *eql); +int scheme_hash_table_equal_rec(Scheme_Hash_Table *t1, Scheme_Object *orig_t1, + Scheme_Hash_Table *t2, Scheme_Object *orig_t2, + void *eql); +int scheme_bucket_table_equal_rec(Scheme_Bucket_Table *t1, Scheme_Object *orig_t1, + Scheme_Bucket_Table *t2, Scheme_Object *orig_t2, + void *eql); +int scheme_hash_tree_equal_rec(Scheme_Hash_Tree *t1, Scheme_Object *orig_t1, + Scheme_Hash_Tree *t2, Scheme_Object *orig_t2, + void *eql); void scheme_set_root_param(int p, Scheme_Object *v);