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

fix equal? on chaperoned values

Browse Source 
Recursive traversal of components should use chaperoned access of
the components, not direct access.
This commit is contained in:
Matthew Flatt 2014-04-14 10:14:20 -06:00
parent 94aa7a03a5
commit 8bbc00c7c1
4 changed files with 170 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

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

95
racket/src/racket/src/bool.c
View File

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

68
racket/src/racket/src/hash.c
View File

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

12
racket/src/racket/src/schpriv.h
View File

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