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

{impersonate,chaperone}-hash: add equal-key-proc wrapper

Browse Source 
The optional `equal-key-proc` wrapper effectively interposes on calls
to `equal?` and `equal-hash-code` for hash-table keys.
This commit is contained in:
Matthew Flatt 2015-12-31 09:21:11 -07:00
parent e92b8610f2
commit 567679bf0a
7 changed files with 364 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.3.0.10")
(define version "6.3.0.11")
(define deps `("racket-lib"
["racket" #:version ,version]))

28
pkgs/racket-doc/scribblings/reference/chaperones.scrbl
View File

@ -446,6 +446,7 @@ or override impersonator-property values of @racket[box].}
[remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)]
[clear-proc (or/c #f (hash? . -> . any)) #f]
[equal-key-proc (or/c #f (hash? any/c . -> . any/c)) #f]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c hash? impersonator?)]{
@ -499,6 +500,19 @@ If @racket[clear-proc] is @racket[#f], then @racket[hash-clear] or
@racket[hash-clear!] on the impersonator is implemented using
@racket[hash-iterate-key] and @racket[hash-remove] or @racket[hash-remove!].
If @racket[equal-key-proc] is not @racket[#f], it effectively
interposes on calls to @racket[equal?], @racket[equal-hash-code], and
@racket[equal-secondary-hash-code] for the keys of @racket[hash]. The
@racket[equal-key-proc] must accept as its arguments @racket[hash] and
a key that is either mapped by @racket[hash] or passed to
@racket[hash-ref], etc., where the latter has potentially been
adjusted by the corresponding @racket[ref-proc], etc@|.__| The result
is a value that is passed to @racket[equal?],
@racket[equal-hash-code], and @racket[equal-secondary-hash-code] as
needed to hash and compare keys. In the case of @racket[hash-set!] or
@racket[hash-set], the key that is passed to @racket[equal-key-proc]
is the one stored in the hash table for future lookup.
The @racket[hash-iterate-value], @racket[hash-map], or
@racket[hash-for-each] functions use a combination of
@racket[hash-iterate-key] and @racket[hash-ref]. If a key
@ -507,7 +521,10 @@ produced by @racket[key-proc] does not yield a value through
Pairs of @racket[prop] and @racket[prop-val] (the number of arguments
to @racket[impersonate-hash] must be odd) add impersonator properties
or override impersonator-property values of @racket[hash].}
or override impersonator-property values of @racket[hash].
@history[#:changed "6.3.0.11" @elem{Added the @racket[equal-key-proc]
argument.}]}
@defproc[(impersonate-channel [channel channel?]
@ -802,6 +819,7 @@ the same value or a chaperone of the value that it is given. The
[remove-proc (hash? any/c . -> . any/c)]
[key-proc (hash? any/c . -> . any/c)]
[clear-proc (or/c #f (hash? . -> . any)) #f]
[equal-key-proc (or/c #f (hash? any/c . -> . any/c)) #f]
[prop impersonator-property?]
[prop-val any] ... ...)
(and/c hash? chaperone?)]{
@ -811,8 +829,12 @@ and support for immutable hashes. The @racket[ref-proc] procedure must
return a found value or a chaperone of the value. The
@racket[set-proc] procedure must produce two values: the key that it
is given or a chaperone of the key and the value that it is given or a
chaperone of the value. The @racket[remove-proc] and @racket[key-proc]
procedures must produce the given key or a chaperone of the key.}
chaperone of the value. The @racket[remove-proc], @racket[key-proc],
and @racket[equal-key-proc]
procedures must produce the given key or a chaperone of the key.
@history[#:changed "6.3.0.11" @elem{Added the @racket[equal-key-proc]
argument.}]}
@defproc[(chaperone-struct-type [struct-type struct-type?]
[struct-info-proc procedure?]

127
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -1202,11 +1202,15 @@
(test #t chaperone? (mk))
(test #t chaperone? (mk #f))
(test #t chaperone? (mk (lambda (ht) (void))))
(test #t chaperone? (mk (lambda (ht) (void)) (lambda (ht k) (void))))
(test #t chaperone? (mk #f (lambda (ht k) (void))))
(err/rt-test (mk (lambda (a b) (void))))
(define-values (prop:blue blue? blue-ref) (make-impersonator-property 'blue))
(test #t chaperone? (mk prop:blue 'ok))
(test #t chaperone? (mk #f prop:blue 'ok))
(err/rt-test (mk (lambda (a b) (void)) prop:blue 'ok)))
(test #t chaperone? (mk #f #f prop:blue 'ok))
(err/rt-test (mk (lambda (a b) (void)) prop:blue 'ok))
(err/rt-test (mk #f (lambda (a) (void)) prop:blue 'ok)))
(for-each
(lambda (make-hash)
@ -1470,7 +1474,124 @@
(define ht4 (hash-clear ht2))
(test #t values hit?)
(test 0 hash-count ht4))))
;; Check use of equal-key-proc argument:
(as-chaperone-or-impersonator
([chaperone-hash impersonate-hash]
[chaperone-procedure impersonate-procedure])
(define saw null)
(define (mk ht)
(chaperone-hash ht
(lambda (h k)
(values k
(lambda (h k v) v)))
(lambda (h k v)
(values k v))
(lambda (h k) k)
(lambda (h k) k)
#f
(lambda (h k) (set! saw (cons k saw)) k)))
(for ([make-hash (in-list (list make-hash make-weak-hash))])
(set! saw null)
(define ht (make-hash))
(define cht (mk ht))
(hash-set! cht "x" 1)
(test '("x") values saw)
(define new-x (make-string 1 #\x))
(void (hash-ref cht new-x))
(test '("x" "x" "x") values saw)
(test #t 'new-x (and (member new-x saw) #t))
(set! saw null)
(hash-set! cht new-x 5)
(test '("x" "x") values saw)
(test #t 'new-x (and (member new-x saw) #t))
(set! saw null)
(hash-remove! cht new-x)
(test '("x" "x") values saw)
(test #t 'new-x (and (member new-x saw) #t)))
(unless (eq? chaperone-hash impersonate-hash)
(for ([hash (in-list (list hash))])
(set! saw null)
(define ht (mk (hash)))
(define ht1 (hash-set ht "x" 1))
(test '("x") values saw)
(define new-x (make-string 1 #\x))
(void (hash-ref ht1 new-x))
(test '("x" "x" "x") values saw)
(test #t 'new-x (and (member new-x saw) #t))
(set! saw null)
(void (hash-set ht1 new-x 5))
(test '("x" "x") values saw)
(test #t 'new-x (and (member new-x saw) #t))
(set! saw null)
(void (hash-remove ht1 new-x))
(test '("x" "x") values saw)
(test #t 'new-x (and (member new-x saw) #t)))))
;; Check that hash table stores given key while
;; coercing key for hashing and equality:
(let ()
(define (mk ht)
(impersonate-hash ht
(lambda (h k)
(values k
(lambda (h k v) v)))
(lambda (h k v)
(values k v))
(lambda (h k) k)
(lambda (h k) k)
#f
(lambda (h k) (inexact->exact (floor k)))))
(for ([make-hash (in-list (list make-hash make-weak-hash))])
(define ht (make-hash))
(define cht (mk ht))
(hash-set! cht 1.2 'one)
(test 'one hash-ref cht 1.3 #f)
(test #f hash-ref ht 1.3 #f)
;; Trying to find 1.2 in `ht` likely won't work, because the hash code was mangled
(test '(1.2) hash-keys ht)
(test '(1.2) hash-keys cht)
(hash-set! cht 1.3 'two)
(test 'two hash-ref cht 1.2 #f))
(let-values ([(prop:blue blue? blue-ref) (make-impersonator-property 'blue)])
(define (mk ht)
(chaperone-hash ht
(lambda (h k)
(values k
(lambda (h k v) v)))
(lambda (h k v)
(values k v))
(lambda (h k) k)
(lambda (h k) k)
#f
(lambda (h k) (chaperone-vector k
(lambda (vec i v)
(if (= i 1)
(error "ONE")
v))
(lambda (vec i v) v)))))
(define (one-exn? s) (regexp-match? #rx"ONE" (exn-message s)))
(let ()
(define cht (mk (hash)))
(err/rt-test (hash-set cht (vector 1 2) 'vec) one-exn?)
(define ht1 (hash-set cht (vector 1) 'vec))
(test 'vec hash-ref ht1 (vector 1) #f)
(test #f hash-ref ht1 (vector 2) #f))
(for ([make-hash (in-list (list make-hash make-weak-hash))])
(define ht (make-hash))
(define cht (mk ht))
(define key (vector 1 2))
(define key7 (vector 7))
(hash-set! cht key7 'vec7)
(test 'vec7 hash-ref cht (vector 7) #f)
(test 'vec7 hash-ref ht (vector 7) #f)
(hash-set! ht key 'vec2)
(test 'vec2 hash-ref ht (vector 1 2))
(err/rt-test (hash-ref cht (vector 1 2) #f) one-exn?)
(test 2 length (hash-keys cht)) ; can extract keys without hashing or comparing
(test 'vec2 hash-ref ht key)
(test 'vec7 hash-ref ht key7))))
;; ----------------------------------------
;; Check broken key impersonator:
@ -2062,7 +2183,7 @@
#:a "x"))
;; ----------------------------------------
;; Check that importantor transformations are applied for printing:
;; Check that impersonator transformations are applied for printing:
(let ()
(define ht

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

@ -164,6 +164,49 @@ static void string_hash_indices(void *_key, intptr_t *_h, intptr_t *_h2)
*_h2 = to_signed_hash(h2);
}
/*========================================================================*/
/* equality with wraps */
/*========================================================================*/
static Scheme_Object *apply_equal_key_wraps(Scheme_Object *key, Scheme_Object *key_wraps)
{
if (key_wraps) {
GC_CAN_IGNORE const char *who = (const char *)SCHEME_CAR(key_wraps);
Scheme_Chaperone *px;
Scheme_Object *a[2], *red;
key_wraps = SCHEME_CDR(key_wraps);
while (!SCHEME_NULLP(key_wraps)) {
px = (Scheme_Chaperone *)SCHEME_CAR(key_wraps);
red = SCHEME_BOX_VAL(px->redirects);
red = SCHEME_VEC_ELS(red)[5];
a[0] = px->prev;
a[1] = key;
key = _scheme_apply(red, 2, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
&& !scheme_chaperone_of(key, a[1])) {
scheme_wrong_chaperoned(who, "key", a[1], key);
return 0;
}
key_wraps = SCHEME_CDR(key_wraps);
}
}
return key;
}
static int equal_w_key_wraps(Scheme_Object *ekey, Scheme_Object *tkey, Scheme_Object *key_wraps)
{
if (key_wraps)
tkey = apply_equal_key_wraps(tkey, key_wraps);
return scheme_equal(ekey, tkey);
}
/*========================================================================*/
/* normal hash table */
/*========================================================================*/
@ -201,9 +244,10 @@ void scheme_clear_hash_table(Scheme_Hash_Table *ht)
ht->mcount = 0;
}
static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int set, Scheme_Object *val)
static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int set, Scheme_Object *val,
Scheme_Object *key_wraps)
{
Scheme_Object *tkey, **keys;
Scheme_Object *tkey, *ekey, **keys;
intptr_t hx, h2x;
hash_v_t h, h2, useme = 0;
uintptr_t mask;
@ -214,8 +258,12 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
if (table->make_hash_indices) {
if (table->compare == scheme_compare_equal) {
if (key_wraps)
ekey = apply_equal_key_wraps(key, key_wraps);
else
ekey = key;
h2 = 0;
hx = scheme_equal_hash_key(key);
hx = scheme_equal_hash_key(ekey);
h = to_unsigned_hash(hx) & mask;
} else {
GC_CAN_IGNORE intptr_t *_h2x;
@ -240,7 +288,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
if (table->compare) {
if (table->compare == scheme_compare_equal) {
/* Direct calls can be significant faster than indirect */
/* Direct calls can be significantly faster than indirect */
scheme_hash_request_count++;
while ((tkey = keys[HASH_TO_ARRAY_INDEX(h, mask)])) {
if (SAME_PTR(tkey, GONE)) {
@ -248,7 +296,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
useme = h;
set = 1;
}
} else if (scheme_equal(tkey, key)) {
} else if (equal_w_key_wraps(ekey, tkey, key_wraps)) {
if (set) {
table->vals[HASH_TO_ARRAY_INDEX(h, mask)] = val;
if (!val) {
@ -261,7 +309,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
}
scheme_hash_iteration_count++;
if (!h2) {
h2x = scheme_equal_hash_key2(key);
h2x = scheme_equal_hash_key2(ekey);
h2 = (to_unsigned_hash(h2x) & (table->size - 1)) | 1;
}
h = (h + h2) & mask;
@ -346,7 +394,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
table->mcount = 0;
for (i = 0; i < oldsize; i++) {
if (oldkeys[i] && !SAME_PTR(oldkeys[i], GONE))
do_hash(table, oldkeys[i], 2, oldvals[i]);
do_hash(table, oldkeys[i], 2, oldvals[i], key_wraps);
}
goto rehash_key;
@ -405,7 +453,7 @@ static Scheme_Object *do_hash_set(Scheme_Hash_Table *table, Scheme_Object *key,
h = useme;
else if (table->mcount * FILL_FACTOR >= table->size) {
/* Use slow path to grow table: */
return do_hash(table, key, 2, val);
return do_hash(table, key, 2, val, NULL);
} else {
table->mcount++;
}
@ -446,7 +494,8 @@ XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Schem
return NULL;
}
void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val)
void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps)
{
if (!table->vals) {
Scheme_Object **ba;
@ -460,21 +509,32 @@ void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object
}
if (table->make_hash_indices)
do_hash(table, key, 2, val);
do_hash(table, key, 2, val, key_wraps);
else
do_hash_set(table, key, val);
}
Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val)
{
scheme_hash_set_w_key_wraps(table, key, val, NULL);
}
Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key,
Scheme_Object *key_wraps)
{
if (!table->vals)
return NULL;
else if (table->make_hash_indices)
return do_hash(table, key, 0, NULL);
return do_hash(table, key, 0, NULL, key_wraps);
else
return do_hash_get(table, key);
}
Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
{
return scheme_hash_get_w_key_wraps(table, key, NULL);
}
Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
/* Specialized to allow XFORM_NONGCING */
{
@ -692,10 +752,12 @@ allocate_bucket (Scheme_Bucket_Table *table, const char *key, void *val)
}
static Scheme_Bucket *
get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket *b)
get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket *b,
Scheme_Object *key_wraps)
{
intptr_t hx, h2x;
hash_v_t h, h2;
void *ekey;
Scheme_Bucket *bucket;
Compare_Proc compare = table->compare;
uintptr_t mask;
@ -705,7 +767,11 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
mask = table->size - 1;
if (table->make_hash_indices) {
table->make_hash_indices((void *)key, &hx, &h2x);
if (key_wraps)
ekey = apply_equal_key_wraps((Scheme_Object *)key, key_wraps);
else
ekey = (void *)key;
table->make_hash_indices(ekey, &hx, &h2x);
h = to_unsigned_hash(hx) & mask;
h2 = to_unsigned_hash(h2x) & mask;
} else {
@ -728,7 +794,10 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
reuse_bucket = h + 1;
} else if (SAME_PTR(hk, key))
return bucket;
else if (compare && !compare((void *)hk, (void *)key))
else if (key_wraps) {
if (equal_w_key_wraps((Scheme_Object *)ekey, (Scheme_Object *)hk, key_wraps))
return bucket;
} else if (compare && !compare((void *)hk, ekey))
return bucket;
} else if (add)
break;
@ -747,7 +816,10 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
while ((bucket = table->buckets[HASH_TO_ARRAY_INDEX(h, mask)])) {
if (SAME_PTR(bucket->key, key))
return bucket;
else if (compare && !compare((void *)bucket->key, (void *)key))
else if (key_wraps) {
if (equal_w_key_wraps((Scheme_Object *)ekey, (Scheme_Object *)bucket->key, key_wraps))
return bucket;
} else if (compare && !compare((void *)bucket->key, (void *)key))
return bucket;
scheme_hash_iteration_count++;
h = (h + h2) & mask;
@ -800,12 +872,12 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
if (table->weak) {
for (i = 0; i < oldsize; i++) {
if (old[i] && old[i]->key && HT_EXTRACT_WEAK(old[i]->key))
get_bucket(table, (char *)HT_EXTRACT_WEAK(old[i]->key), 1, old[i]);
get_bucket(table, (char *)HT_EXTRACT_WEAK(old[i]->key), 1, old[i], key_wraps);
}
} else {
for (i = 0; i < oldsize; i++) {
if (old[i] && old[i]->key)
get_bucket(table, old[i]->key, 1, old[i]);
get_bucket(table, old[i]->key, 1, old[i], key_wraps);
}
}
@ -825,28 +897,35 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
}
Scheme_Bucket *
scheme_bucket_or_null_from_table (Scheme_Bucket_Table *table, const char *key, int add)
scheme_bucket_or_null_from_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key, int add,
Scheme_Object *key_wraps)
{
Scheme_Bucket *b;
b = get_bucket(table, key, add, NULL);
b = get_bucket(table, key, add, NULL, key_wraps);
return b;
}
Scheme_Bucket *
scheme_bucket_or_null_from_table (Scheme_Bucket_Table *table, const char *key, int add)
{
return scheme_bucket_or_null_from_table_w_key_wraps(table, key, add, NULL);
}
Scheme_Bucket *
scheme_bucket_from_table (Scheme_Bucket_Table *table, const char *key)
{
return scheme_bucket_or_null_from_table(table, key, 1);
return scheme_bucket_or_null_from_table_w_key_wraps(table, key, 1, NULL);
}
void
scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val,
int constant)
scheme_add_to_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key, void *val,
int constant, Scheme_Object *key_wraps)
{
Scheme_Bucket *b;
b = get_bucket(table, key, 1, NULL);
b = get_bucket(table, key, 1, NULL, key_wraps);
if (val)
b->val = val;
@ -854,17 +933,25 @@ scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val,
((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_CONST;
}
void
scheme_add_to_table (Scheme_Bucket_Table *table, const char *key, void *val,
int constant)
{
scheme_add_to_table_w_key_wraps(table, key, val, constant, NULL);
}
void scheme_add_bucket_to_table(Scheme_Bucket_Table *table, Scheme_Bucket *b)
{
get_bucket(table, table->weak ? (char *)HT_EXTRACT_WEAK(b->key) : b->key, 1, b);
get_bucket(table, table->weak ? (char *)HT_EXTRACT_WEAK(b->key) : b->key, 1, b, NULL);
}
void *
scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key)
scheme_lookup_in_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key,
Scheme_Object *key_wraps)
{
Scheme_Bucket *bucket;
bucket = get_bucket(table, key, 0, NULL);
bucket = get_bucket(table, key, 0, NULL, key_wraps);
if (bucket)
return bucket->val;
@ -872,12 +959,18 @@ scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key)
return NULL;
}
void *
scheme_lookup_in_table (Scheme_Bucket_Table *table, const char *key)
{
return scheme_lookup_in_table_w_key_wraps(table, key, NULL);
}
void
scheme_change_in_table (Scheme_Bucket_Table *table, const char *key, void *naya)
{
Scheme_Bucket *bucket;
bucket = get_bucket(table, key, 0, NULL);
bucket = get_bucket(table, key, 0, NULL, NULL);
if (bucket)
bucket->val = naya;
@ -2607,7 +2700,8 @@ int scheme_hash_tree_index(Scheme_Hash_Tree *ht, mzlonglong pos, Scheme_Object *
}
static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Scheme_Object *key,
GC_CAN_IGNORE int *_i, GC_CAN_IGNORE uintptr_t *_code)
GC_CAN_IGNORE int *_i, GC_CAN_IGNORE uintptr_t *_code,
Scheme_Object *key_wraps)
/* in the case of hash collisions, we put the colliding elements in a
tree that uses integers as keys; we have to search through the tree
for keys, but the advatange of using a HAMT (instead of a list) is
@ -2624,7 +2718,7 @@ static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Sche
return found_val;
}
} else if (stype == scheme_hash_tree_type) {
if (scheme_equal(key, found_key)) {
if (equal_w_key_wraps(key, found_key, key_wraps)) {
if (_i) *_i = i;
return found_val;
}
@ -2779,7 +2873,8 @@ Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *ke
return NULL;
}
Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key,
Scheme_Object *key_wraps)
{
uintptr_t h;
int stype, pos;
@ -2789,9 +2884,11 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
if (stype == scheme_eq_hash_tree_type)
return scheme_eq_hash_tree_get(tree, key);
else if (stype == scheme_hash_tree_type)
else if (stype == scheme_hash_tree_type) {
if (key_wraps)
key = apply_equal_key_wraps(key, key_wraps);
h = to_unsigned_hash(scheme_equal_hash_key(key));
else
} else
h = to_unsigned_hash(scheme_eqv_hash_key(key));
tree = hamt_assoc(tree, h, &pos, 0);
@ -2801,10 +2898,10 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
if (HASHTR_COLLISIONP(tree->els[pos])) {
/* hash collision; linear search in subtree */
uintptr_t code;
return hamt_linear_search((Scheme_Hash_Tree *)tree->els[pos], stype, key, NULL, &code);
return hamt_linear_search((Scheme_Hash_Tree *)tree->els[pos], stype, key, NULL, &code, key_wraps);
} else {
if (stype == scheme_hash_tree_type) {
if (scheme_equal(key, tree->els[pos]))
if (equal_w_key_wraps(key, tree->els[pos], key_wraps))
return mzHAMT_VAL(tree, pos);
} else {
if (scheme_eqv(key, tree->els[pos]))
@ -2815,20 +2912,29 @@ Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
return NULL;
}
Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val)
Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
{
return scheme_hash_tree_get_w_key_wraps(tree, key, NULL);
}
Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps)
/* val == NULL => remove */
{
uintptr_t h;
Scheme_Hash_Tree *in_tree;
Scheme_Object *ekey = key;
int stype, pos;
stype = SCHEME_TYPE(resolve_placeholder(tree));
if (stype == scheme_eq_hash_tree_type)
h = PTR_TO_LONG((Scheme_Object *)key);
else if (stype == scheme_hash_tree_type)
h = to_unsigned_hash(scheme_equal_hash_key(key));
else
else if (stype == scheme_hash_tree_type) {
if (key_wraps)
ekey = apply_equal_key_wraps(ekey, key_wraps);
h = to_unsigned_hash(scheme_equal_hash_key(ekey));
} else
h = to_unsigned_hash(scheme_eqv_hash_key(key));
in_tree = hamt_assoc(resolve_placeholder(tree), h, &pos, 0);
@ -2847,7 +2953,7 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke
int i, inc;
uintptr_t code;
in_tree = (Scheme_Hash_Tree *)in_tree->els[pos];
if (hamt_linear_search(in_tree, stype, key, &i, &code)) {
if (hamt_linear_search(in_tree, stype, key, &i, &code, key_wraps)) {
/* key is part of the current collision */
if (!val) {
if (in_tree->count == 2) {
@ -2885,7 +2991,7 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke
if (stype == scheme_eq_hash_tree_type)
same = SAME_OBJ(key, in_tree->els[pos]);
else if (stype == scheme_hash_tree_type)
same = scheme_equal(key, in_tree->els[pos]);
same = equal_w_key_wraps(ekey, in_tree->els[pos], key_wraps);
else
same = scheme_eqv(key, in_tree->els[pos]);
@ -2921,6 +3027,11 @@ Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *ke
}
}
Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val)
{
return scheme_hash_tree_set_w_key_wraps(tree, key, val, NULL);
}
static int hamt_equal_entries(int stype, void *eql_data,
Scheme_Object *k1, Scheme_Object *v1,
Scheme_Object *k2, Scheme_Object *v2)

66
racket/src/racket/src/list.c
View File

@ -2944,7 +2944,7 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, i
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects, *clear;
Scheme_Object *redirects, *clear, *equal_key_wrap;
Scheme_Hash_Tree *props;
int start_props = 5;
@ -2967,15 +2967,23 @@ static Scheme_Object *do_chaperone_hash(const char *name, int is_impersonator, i
} else
clear = scheme_false;
if ((argc > 6) && (SCHEME_FALSEP(argv[6]) || SCHEME_PROCP(argv[6]))) {
scheme_check_proc_arity2(name, 2, 6, argc, argv, 1); /* clear */
equal_key_wrap = argv[6];
start_props++;
} else
equal_key_wrap = scheme_false;
/* The allocation of this vector is used to detect when two
chaperoned immutable hash tables can be
`{chaperone,impersonator}-of?` when they're not eq. */
redirects = scheme_make_vector(5, NULL);
redirects = scheme_make_vector(6, NULL);
SCHEME_VEC_ELS(redirects)[0] = argv[1];
SCHEME_VEC_ELS(redirects)[1] = argv[2];
SCHEME_VEC_ELS(redirects)[2] = argv[3];
SCHEME_VEC_ELS(redirects)[3] = argv[4];
SCHEME_VEC_ELS(redirects)[4] = clear;
SCHEME_VEC_ELS(redirects)[5] = equal_key_wrap;
redirects = scheme_box(redirects); /* so it doesn't look like a struct chaperone */
props = scheme_parse_chaperone_props(name, start_props, argc, argv);
@ -3019,7 +3027,7 @@ static Scheme_Object *transfer_chaperone(Scheme_Object *chaperone, Scheme_Object
}
static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k,
Scheme_Object *v, int mode);
Scheme_Object *v, int mode, Scheme_Object *key_wraps);
static Scheme_Object *chaperone_hash_op_k(void)
{
@ -3028,13 +3036,15 @@ static Scheme_Object *chaperone_hash_op_k(void)
Scheme_Object *k = (Scheme_Object *)p->ku.k.p2;
Scheme_Object *v = (Scheme_Object *)p->ku.k.p3;
const char *who = (const char *)p->ku.k.p4;
Scheme_Object *key_wraps = (Scheme_Object *)p->ku.k.p5;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
p->ku.k.p5 = NULL;
o = chaperone_hash_op(who, o, k, v, p->ku.k.i1);
o = chaperone_hash_op(who, o, k, v, p->ku.k.i1, key_wraps);
if (!o)
return scheme_false;
@ -3043,7 +3053,7 @@ static Scheme_Object *chaperone_hash_op_k(void)
}
static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object *o, Scheme_Object *k,
Scheme_Object *v, int mode)
Scheme_Object *v, int mode, Scheme_Object *key_wraps)
{
Scheme_Thread *p = scheme_current_thread;
@ -3052,6 +3062,7 @@ static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object
p->ku.k.p3 = (void *)v;
p->ku.k.p4 = (void *)who;
p->ku.k.i1 = mode;
p->ku.k.p5 = (void *)key_wraps;
o = scheme_handle_stack_overflow(chaperone_hash_op_k);
@ -3062,26 +3073,30 @@ static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object
}
static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k,
Scheme_Object *v, int mode)
Scheme_Object *v, int mode, Scheme_Object *key_wraps)
{
Scheme_Object *wraps = NULL;
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
if (SCHEME_NULLP(key_wraps))
key_wraps = NULL;
else
key_wraps = scheme_make_raw_pair((Scheme_Object *)who, key_wraps);
if (mode == 0) {
/* hash-ref */
if (SCHEME_HASHTP(o))
return scheme_hash_get((Scheme_Hash_Table *)o, k);
return scheme_hash_get_w_key_wraps((Scheme_Hash_Table *)o, k, key_wraps);
else if (SCHEME_HASHTRP(o))
return scheme_hash_tree_get((Scheme_Hash_Tree *)o, k);
return scheme_hash_tree_get_w_key_wraps((Scheme_Hash_Tree *)o, k, key_wraps);
else
return scheme_lookup_in_table((Scheme_Bucket_Table *)o, (const char *)k);
return scheme_lookup_in_table_w_key_wraps((Scheme_Bucket_Table *)o, (const char *)k, key_wraps);
} else if ((mode == 1) || (mode == 2)) {
/* hash-set! or hash-remove! */
if (SCHEME_HASHTP(o))
scheme_hash_set((Scheme_Hash_Table *)o, k, v);
scheme_hash_set_w_key_wraps((Scheme_Hash_Table *)o, k, v, key_wraps);
else if (SCHEME_HASHTRP(o)) {
o = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)o, k, v);
o = (Scheme_Object *)scheme_hash_tree_set_w_key_wraps((Scheme_Hash_Tree *)o, k, v, key_wraps);
while (wraps) {
o = transfer_chaperone(SCHEME_CAR(wraps), o);
wraps = SCHEME_CDR(wraps);
@ -3089,13 +3104,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
return o;
} else if (!v) {
Scheme_Bucket *b;
b = scheme_bucket_or_null_from_table((Scheme_Bucket_Table *)o, (char *)k, 0);
b = scheme_bucket_or_null_from_table_w_key_wraps((Scheme_Bucket_Table *)o, (char *)k, 0, key_wraps);
if (b) {
HT_EXTRACT_WEAK(b->key) = NULL;
b->val = NULL;
}
} else
scheme_add_to_table((Scheme_Bucket_Table *)o, (const char *)k, v, 0);
scheme_add_to_table_w_key_wraps((Scheme_Bucket_Table *)o, (const char *)k, v, 0, key_wraps);
return scheme_void;
} else if (mode == 3)
return k;
@ -3119,14 +3134,21 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_hash_op_overflow(who, o, k, v, mode);
return chaperone_hash_op_overflow(who, o, k, v, mode, key_wraps);
}
#endif
if ((mode != 3) && (mode != 4)) {
red = SCHEME_BOX_VAL(px->redirects);
red = SCHEME_VEC_ELS(red)[5];
if (!SCHEME_FALSEP(red))
key_wraps = scheme_make_pair((Scheme_Object *)px, key_wraps);
}
if (mode == 0)
orig = NULL;
else if (mode == 3) {
orig = chaperone_hash_op(who, px->prev, k, v, mode);
orig = chaperone_hash_op(who, px->prev, k, v, mode, key_wraps);
k = orig;
} else if (mode == 2)
orig = k;
@ -3196,7 +3218,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
who,
red);
orig = chaperone_hash_op(who, px->prev, k, v, mode);
orig = chaperone_hash_op(who, px->prev, k, v, mode, key_wraps);
if (!orig) return NULL;
/* hash-ref */
@ -3240,27 +3262,27 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *key)
{
return chaperone_hash_op("hash-ref", table, key, NULL, 0);
return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null);
}
void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val)
{
(void)chaperone_hash_op(val ? "hash-set!" : "hash-remove!", table, key, val, val ? 1 : 2);
(void)chaperone_hash_op(val ? "hash-set!" : "hash-remove!", table, key, val, val ? 1 : 2, scheme_null);
}
Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val)
{
return chaperone_hash_op(val ? "hash-set" : "hash-remove", table, key, val, val ? 1 : 2);
return chaperone_hash_op(val ? "hash-set" : "hash-remove", table, key, val, val ? 1 : 2, scheme_null);
}
static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key)
{
return chaperone_hash_op(name, table, key, NULL, 3);
return chaperone_hash_op(name, table, key, NULL, 3, scheme_null);
}
static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table)
{
return chaperone_hash_op(name, table, NULL, NULL, 4);
return chaperone_hash_op(name, table, NULL, NULL, 4, scheme_null);
}
Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key,
@ -3268,7 +3290,7 @@ Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_
{
key = chaperone_hash_key("hash-table-iterate-key", table, key);
*alt_key = key;
return chaperone_hash_op("hash-ref", table, key, NULL, 0);
return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null);
}
Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj)

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

@ -597,6 +597,22 @@ Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key,
Scheme_Object *key_wraps);
void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps);
Scheme_Bucket *scheme_bucket_or_null_from_table_w_key_wraps(Scheme_Bucket_Table *table,
const char *key, int add,
Scheme_Object *key_wraps);
void scheme_add_to_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, void *val,
int constant, Scheme_Object *key_wraps);
void *scheme_lookup_in_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key,
Scheme_Object *key_wraps);
Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key,
Scheme_Object *key_wraps);
Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps);
/*========================================================================*/
/* thread state and maintenance */
/*========================================================================*/

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.3.0.10"
#define MZSCHEME_VERSION "6.3.0.11"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 10
#define MZSCHEME_VERSION_W 11
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)