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

Adds hash-ref-key primitive

Browse Source 
For now, the operation is implemented on mutable tables in Chez
using a combination of hashtable-contains? and hashtable-cell.
A more efficient version will require modifying Chez.
This commit is contained in:
Jon Zeppieri 2019-07-23 15:26:36 -04:00 committed by Matthew Flatt
parent 2e26e99a60
commit 0ebc43ef24
15 changed files with 518 additions and 158 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 "7.4.0.2")
(define version "7.4.0.3")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

@ -491,7 +491,9 @@ In addition, operations like
keys from the table, use @racket[key-proc] to replace keys extracted
from the table. Operations like @racket[hash-iterate-value] or
@racket[hash-values] implicitly use @racket[hash-ref] and
therefore redirect through @racket[ref-proc].
therefore redirect through @racket[ref-proc]. The @racket[hash-ref-key]
operation uses both @racket[ref-proc] and @racket[key-proc], the
former to lookup the requested key and the latter to extract it.
The @racket[ref-proc] must accept @racket[hash] and a key passed
to @racket[hash-ref]. It must return a replacement key
@ -499,7 +501,8 @@ as well as a procedure. The returned procedure is called only if the
returned key is found in @racket[hash] via @racket[hash-ref], in which
case the procedure is called with @racket[hash], the previously
returned key, and the found value. The returned procedure must itself
return a replacement for the found value.
return a replacement for the found value. The returned procedure
is ignored by @racket[hash-ref-key].
The @racket[set-proc] must accept @racket[hash], a key passed to
@racket[hash-set!] or @racket[hash-set], and the value passed to
@ -515,10 +518,10 @@ replacement for the key, which is used with @racket[hash-remove!] or
mapping using the (impersonator-replaced) key.
The @racket[key-proc] must accept @racket[hash] and a key that has
been extracted from @racket[hash] (by @racket[hash-iterate-key] or
other operations that use @racket[hash-iterate-key] internally); it
must produce a replacement for the key, which is then reported as a
key extracted from the table.
been extracted from @racket[hash] (by @racket[hash-ref-key],
@racket[hash-iterate-key], or other operations that use
@racket[hash-iterate-key] internally); it must produce a replacement
for the key, which is then reported as a key extracted from the table.
If @racket[clear-proc] is not @racket[#f], it must accept
@racket[hash] as an argument, and its result is ignored. The fact that

75
pkgs/racket-doc/scribblings/reference/hashes.scrbl
View File

@ -71,8 +71,8 @@ a table-specific semaphore as needed. Three caveats apply, however:
@itemize[
@item{If a thread is terminated while applying @racket[hash-ref],
@racket[hash-set!], @racket[hash-remove!], @racket[hash-ref!],
or @racket[hash-update!] to a hash table that
@racket[hash-ref-key], @racket[hash-set!], @racket[hash-remove!],
@racket[hash-ref!], or @racket[hash-update!] to a hash table that
uses @racket[equal?] or @racket[eqv?] key comparisons, all current
and future operations on the hash table may block indefinitely.}
@ -273,6 +273,77 @@ result:
@see-also-caveats[]}
@defproc[(hash-ref-key [hash hash?]
[key any/c]
[failure-result (failure-result/c any/c)
(lambda ()
(raise (make-exn:fail:contract ....)))])
any]{
Returns the key held by @racket[hash] that is equivalent to @racket[key]
according to @racket[hash]'s key-comparison function. If no key is found,
then @racket[failure-result] is used as in @racket[hash-ref] to determine
the result.
If @racket[hash] is not an @tech{impersonator}, then the returned key,
assuming it is found, will be @racket[eq?]-equivalent to the one
actually retained by @racket[hash]:
@examples[
#:eval the-eval
(define original-key "hello")
(define key-copy (string-copy original-key))
(equal? original-key key-copy)
(eq? original-key key-copy)
(define table (make-hash))
(hash-set! table original-key 'value)
(eq? (hash-ref-key table "hello") original-key)
(eq? (hash-ref-key table "hello") key-copy)
]
If a mutable hash is updated multiple times using keys that are
not @racket[eq?]-equivalent but are equivalent according to the
hash's key-comparison procedure, the hash retains the first one:
@examples[
#:eval the-eval
(define original-key "hello")
(define key-copy (string-copy original-key))
(define table (make-hash))
(hash-set! table original-key 'one)
(hash-set! table key-copy 'two)
(eq? (hash-ref-key table "hello") original-key)
(eq? (hash-ref-key table "hello") key-copy)
]
Conversely, an immutable hash retains the key that was most-recently
used to update it:
@examples[
#:eval the-eval
(define original-key "hello")
(define key-copy (string-copy original-key))
(define table0 (hash))
(define table1 (hash-set table0 original-key 'one))
(define table2 (hash-set table1 key-copy 'two))
(eq? (hash-ref-key table2 "hello") original-key)
(eq? (hash-ref-key table2 "hello") key-copy)
]
If @racket[hash] is an @tech{impersonator}, then the returned key
will be determined as described in the documentation to
@racket[impersonate-hash].
@see-also-caveats[]
@history[#:added "7.4.0.3"]}
@defproc[(hash-ref! [hash hash?] [key any/c] [to-set (failure-result/c any/c)])
any]{

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

@ -2006,14 +2006,18 @@
(test '(key val key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h2 'key2 #f)
(test '(key2 val2 key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'key2 hash-ref-key h1 'key2 #f)
(test '(key2 val2 key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'key2 hash-ref-key h2 'key2 #f)
(test '(key2 val2 key2 val2 #f key2) list get-k get-v set-k set-v remove-k access-k)
(test (void) hash-remove! h2 'key3)
(test '(key2 val2 key2 val2 key3 #f) list get-k get-v set-k set-v remove-k access-k)
(test '(key2 val2 key2 val2 key3 key2) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h2 'key2)
(test '(key2 val2 key2 val2 key3 #f) list get-k get-v set-k set-v remove-k access-k)
(test '(key2 val2 key2 val2 key3 key2) list get-k get-v set-k set-v remove-k access-k)
(test (void) hash-remove! h2 'key2)
(test '(key2 val2 key2 val2 key2 #f) list get-k get-v set-k set-v remove-k access-k)
(test '(key2 val2 key2 val2 key2 key2) list get-k get-v set-k set-v remove-k access-k)
(test #f hash-ref h2 'key2 #f)
(test '(key2 val2 key2 val2 key2 #f) list get-k get-v set-k set-v remove-k access-k)
(test '(key2 val2 key2 val2 key2 key2) list get-k get-v set-k set-v remove-k access-k)
(hash-for-each h2 void)
(test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
(set! get-k #f)
@ -2077,14 +2081,16 @@
(test '(key val key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h2 'key2 #f)
(test '(key2 val2 key2 val2 #f #f) list get-k get-v set-k set-v remove-k access-k)
(test 'key2 hash-ref-key h2 'key2)
(test '(key2 val2 key2 val2 #f key2) list get-k get-v set-k set-v remove-k access-k)
(let ([h2 (hash-remove h2 'key3)])
(test '(key2 val2 key2 val2 key3 #f) list get-k get-v set-k set-v remove-k access-k)
(test '(key2 val2 key2 val2 key3 key2) list get-k get-v set-k set-v remove-k access-k)
(test 'val2 hash-ref h2 'key2)
(test '(key2 val2 key2 val2 key3 #f) list get-k get-v set-k set-v remove-k access-k)
(test '(key2 val2 key2 val2 key3 key2) list get-k get-v set-k set-v remove-k access-k)
(let ([h2 (hash-remove h2 'key2)])
(test '(key2 val2 key2 val2 key2 #f) list get-k get-v set-k set-v remove-k access-k)
(test '(key2 val2 key2 val2 key2 key2) list get-k get-v set-k set-v remove-k access-k)
(test #f hash-ref h2 'key2 #f)
(test '(key2 val2 key2 val2 key2 #f) list get-k get-v set-k set-v remove-k access-k)
(test '(key2 val2 key2 val2 key2 key2) list get-k get-v set-k set-v remove-k access-k)
(hash-for-each h2 void)
(test '(key val key2 val2 key2 key) list get-k get-v set-k set-v remove-k access-k)
(set! get-k #f)
@ -3540,6 +3546,37 @@
(test '(7) s-ref a-s 0))
;; ----------------------------------------
;; Check that `hash-ref-key` works with
;; multiple layers of impersonation.
(let ()
(define (ref-proc ht k)
(values (string-append "-" k)
(lambda (ht k v) v)))
(define (set-proc ht k v)
(values (string-append "-" k)
v))
(define (rem-proc ht k)
(string-append "-" k))
(define (key-proc ht k)
(substring k 1))
(define ht0 (make-hash))
(define ht1 (impersonate-hash ht0 ref-proc set-proc rem-proc key-proc))
(define ht2 (impersonate-hash ht1 ref-proc set-proc rem-proc key-proc))
(hash-set! ht2 "key" "value")
(test #t hash-has-key? ht0 "--key")
(test "key" hash-ref-key ht2 "key")
(test "-key" hash-ref-key ht1 "-key")
(test #f hash-ref-key ht2 "absent" #f)
(test #f hash-ref-key ht1 "absent" #f)
(err/rt-test (hash-ref-key ht2 "absent") exn:fail:contract?))
;; ----------------------------------------
(report-errs)

47
pkgs/racket-test-core/tests/racket/hash.rktl
View File

@ -465,5 +465,52 @@
(p) in-hash-pairs in-weak-hash-pairs car)
;; ----------------------------------------
;; hash-ref-key
(let ()
(arity-test hash-ref-key 2 3)
(define (test-hash-ref-key ht eql? expected-retained-key expected-excised-key)
(define actual-retained-key (hash-ref-key ht expected-excised-key))
(define non-key (gensym 'nope))
(test #t eql? expected-retained-key expected-excised-key)
(test #t eq? actual-retained-key expected-retained-key)
(test (eq? eql? eq?) eq? actual-retained-key expected-excised-key)
(test #t eq? (hash-ref-key ht non-key 'absent) 'absent)
(test #t eq? (hash-ref-key ht non-key (lambda () 'absent)) 'absent)
(err/rt-test (hash-ref-key ht non-key) exn:fail:contract?))
(define (test-hash-ref-key/mut ht eql? expected-retained-key expected-excised-key)
(hash-set! ht expected-retained-key 'here)
(hash-set! ht expected-excised-key 'there)
(test-hash-ref-key ht eql? expected-retained-key expected-excised-key))
(define (test-hash-ref-key/immut ht eql? expected-retained-key expected-excised-key)
(define ht1 (hash-set (hash-set ht expected-excised-key 'here)
expected-retained-key
'there))
(test-hash-ref-key ht1 eql? expected-retained-key expected-excised-key))
;; equal?-based hashes
(let* ([k1 "hello"]
[k2 (substring k1 0)])
(test-hash-ref-key/mut (make-hash) equal? k1 k2)
(test-hash-ref-key/mut (make-weak-hash) equal? k1 k2)
(test-hash-ref-key/immut (hash) equal? k1 k2))
;; eqv?-based hashes
(let ([k1 (expt 2 64)]
[k2 (expt 2 64)])
(test-hash-ref-key/mut (make-hasheqv) eqv? k1 k2)
(test-hash-ref-key/mut (make-weak-hasheqv) eqv? k1 k2)
(test-hash-ref-key/immut (hasheqv) eqv? k1 k2))
;; eq?-based hashes
(test-hash-ref-key/mut (make-hasheqv) eq? 'foo 'foo)
(test-hash-ref-key/mut (make-weak-hasheqv) eq? 'foo 'foo)
(test-hash-ref-key/immut (hasheqv) eq? 'foo 'foo))
;; ----------------------------------------
;;
(report-errs)

1
racket/src/cs/primitive/kernel.ss
View File

@ -419,6 +419,7 @@
[hash-map (known-procedure 12)]
[hash-placeholder? (known-procedure/pure/folding 2)]
[hash-ref (known-procedure 12)]
[hash-ref-key (known-procedure 12)]
[hash-remove (known-procedure 4)]
[hash-remove! (known-procedure 4)]
[hash-set (known-procedure 8)]

2
racket/src/cs/rumble.sls
View File

@ -254,7 +254,7 @@
make-hash make-hasheqv make-hasheq
make-immutable-hash make-immutable-hasheqv make-immutable-hasheq
make-weak-hash make-weak-hasheq make-weak-hasheqv
hash-ref hash-set hash-set! hash-remove hash-remove!
hash-ref hash-ref-key hash-set hash-set! hash-remove hash-remove!
hash-for-each hash-map hash-copy hash-clear hash-clear!
hash-iterate-first hash-iterate-next
hash-iterate-key hash-iterate-value

2
racket/src/cs/rumble/datum.ss
View File

@ -11,7 +11,7 @@
(bytes? v)
(intern-regexp? v))
(with-interrupts-disabled
(or (weak-hash-ref-key datums v)
(or (weak-hash-ref-key datums v #f)
(let ([v (cond
[(string? v) (string->immutable-string v)]
[(bytes? v) (bytes->immutable-bytes v)]

142
racket/src/cs/rumble/hash.ss
View File

@ -256,32 +256,85 @@
(define hash-ref
(case-lambda
[(ht k)
(let ([v (hash-ref ht k none)])
(if (eq? v none)
(raise-arguments-error
'hash-ref
"no value found for key"
"key" k)
v))]
[(ht k fail)
(cond
[(mutable-hash? ht)
(lock-acquire (mutable-hash-lock ht))
(let ([v (hashtable-ref (mutable-hash-ht ht) k none)])
(lock-release (mutable-hash-lock ht))
(if (eq? v none)
($fail fail)
v))]
[(intmap? ht) (intmap-ref ht k fail)]
[(weak-equal-hash? ht) (weak-hash-ref ht k fail)]
[(and (impersonator? ht)
(authentic-hash? (impersonator-val ht)))
(let ([v (impersonate-hash-ref ht k)])
(if (eq? v none)
($fail fail)
v))]
[else (raise-argument-error 'hash-ref "hash?" ht)])]))
[(ht k)
(let ([v (hash-ref/none ht k)])
(if (eq? v none)
(raise-arguments-error
'hash-ref
"no value found for key"
"key" k)
v))]
[(ht k fail)
(let ([v (hash-ref/none ht k)])
(if (eq? v none)
(fail-hash-ref 'hash-ref fail)
v))]))
(define (hash-ref/none ht k)
(cond
[(mutable-hash? ht)
(lock-acquire (mutable-hash-lock ht))
(let ([v (hashtable-ref (mutable-hash-ht ht) k none)])
(lock-release (mutable-hash-lock ht))
v)]
[(intmap? ht)
(intmap-ref ht k none)]
[(weak-equal-hash? ht)
(weak-hash-ref ht k none)]
[(and (impersonator? ht)
(authentic-hash? (impersonator-val ht)))
(impersonate-hash-ref ht k)]
[else
(raise-argument-error 'hash-ref "hash?" ht)]))
(define hash-ref-key
(case-lambda
[(ht k)
(let ([v (hash-ref-key/none ht k)])
(if (eq? v none)
(raise-arguments-error
'hash-ref-key
"hash does not contain key"
"key" k)
v))]
[(ht k fail)
(let ([v (hash-ref-key/none ht k)])
(if (eq? v none)
(fail-hash-ref 'hash-ref-key fail)
v))]))
(define (hash-ref-key/none ht k)
(cond
[(mutable-hash? ht)
(lock-acquire (mutable-hash-lock ht))
(let ([v (if (hashtable-contains? (mutable-hash-ht ht) k)
(car (hashtable-cell (mutable-hash-ht ht) k #f))
none)])
(lock-release (mutable-hash-lock ht))
v)]
[(intmap? ht)
(intmap-ref-key ht k none)]
[(weak-equal-hash? ht)
(weak-hash-ref-key ht k none)]
[(and (impersonator? ht)
(authentic-hash? (impersonator-val ht)))
(impersonate-hash-ref-key ht k)]
[else
(raise-argument-error 'hash-ref-key "hash?" ht)]))
(define (fail-hash-ref who default)
(if (procedure? default)
(if (procedure-arity-includes? default 0)
(|#%app| default)
(raise (|#%app|
exn:fail:contract:arity
(string-append (symbol->string who)
": arity mismatch for failure procedure;\n"
" given procedure does not accept zero arguments\n"
" procedure: "
(error-value->string default))
(current-continuation-marks))))
default))
(define/who hash-for-each
(case-lambda
@ -807,25 +860,23 @@
[(null? keys)
;; Not in the table:
(lock-release (weak-equal-hash-lock t))
($fail fail)]
fail]
[(key-equal? (car keys) key)
(let* ([k (car keys)]
[v (hashtable-ref (weak-equal-hash-vals-ht t) (car keys) none)])
(lock-release (weak-equal-hash-lock t))
(if (eq? v none)
($fail fail)
v))]
v)]
[else (loop (cdr keys))])))]
[(t key fail)
(weak-hash-ref t key fail (key-equal-hash-code key) key-equal?)]))
;; Only used in atomic mode:
(define (weak-hash-ref-key ht key)
(define (weak-hash-ref-key ht key default)
(let* ([code (key-equal-hash-code key)]
[keys (intmap-ref (weak-equal-hash-keys-ht ht) code '())])
(let loop ([keys keys])
(cond
[(null? keys) #f]
[(null? keys) default]
[(key-equal? (car keys) key) (car keys)]
[else (loop (cdr keys))]))))
@ -1058,15 +1109,26 @@
;; ----------------------------------------
(define (impersonate-hash-ref ht k)
(impersonate-hash-ref/set 'hash-ref #f
(impersonate-hash-ref/set 'hash-ref "value" #f
(lambda (ht k v) (hash-ref ht k none))
(lambda (procs ht k none-v)
(|#%app| (hash-procs-ref procs) ht k))
hash-procs-ref
ht k none))
(define (impersonate-hash-ref-key ht k)
(impersonate-hash-ref/set 'hash-ref-key "key" #f
(lambda (ht k v) (hash-ref-key ht k none))
(lambda (procs ht k none-v)
(let-values ([(new-k _) (|#%app| (hash-procs-ref procs) ht k)])
(values new-k
(lambda (ht k none-v)
(|#%app| (hash-procs-key procs) ht k)))))
hash-procs-ref
ht k none))
(define (impersonate-hash-set! ht k v)
(impersonate-hash-ref/set 'hash-set! #t
(impersonate-hash-ref/set 'hash-set! "void" #t
hash-set!
(lambda (procs ht k v)
(|#%app| (hash-procs-set procs) ht k v))
@ -1074,7 +1136,7 @@
ht k v))
(define (impersonate-hash-set ht k v)
(impersonate-hash-ref/set 'hash-set #t
(impersonate-hash-ref/set 'hash-set "hash" #t
hash-set
(lambda (procs ht k v)
(|#%app| (hash-procs-set procs) ht k v))
@ -1082,7 +1144,7 @@
ht k v))
(define (impersonate-hash-remove! ht k)
(impersonate-hash-ref/set 'hash-remove! #t
(impersonate-hash-ref/set 'hash-remove! "void" #t
(lambda (ht k false-v) (hash-remove! ht k))
(lambda (procs ht k false-v)
(values (|#%app| (hash-procs-remove procs) ht k) #f))
@ -1090,14 +1152,14 @@
ht k #f))
(define (impersonate-hash-remove ht k)
(impersonate-hash-ref/set 'hash-remove #t
(impersonate-hash-ref/set 'hash-remove "hash" #t
(lambda (ht k false-v) (hash-remove ht k))
(lambda (procs ht k false-v)
(values (|#%app| (hash-procs-remove procs) ht k) #f))
hash-procs-remove
ht k #f))
(define (impersonate-hash-ref/set who set? authentic-op apply-wrapper get-wrapper ht k v)
(define (impersonate-hash-ref/set who what-r set? authentic-op apply-wrapper get-wrapper ht k v)
(let ([wrap-key? (hash-equal? ht)])
(let loop ([ht ht] [get-k (and wrap-key? values)] [k k] [v v])
(cond
@ -1123,7 +1185,7 @@
(raise-chaperone-error who "value" new-v-or-wrap v))))
;; Recur...
(let ([r (loop next-ht get-k new-k (if set? new-v-or-wrap none))])
;; In `ref` mode, `r` is the result value.
;; In `ref` mode, `r` is the result value (hash-ref) or key (hash-ref-key).
;; In `set` mode, `r` is void or an updated hash table.
(cond
[(and set? (void? r))
@ -1139,7 +1201,7 @@
(let ([new-r (new-v-or-wrap next-ht new-k r)])
(when chaperone?
(unless (chaperone-of? new-r r)
(raise-chaperone-error who "value" new-r r)))
(raise-chaperone-error who what-r new-r r)))
new-r)]))]
[args
(raise-arguments-error who

68
racket/src/cs/rumble/intmap.ss
View File

@ -33,8 +33,6 @@
[nongenerative #{Co pfwguidjcvqbvofiirp097jco-3}]
[sealed #t])
(define *nothing* (gensym))
(define immutable-hash? intmap?)
(define empty-hash (make-intmap 'equal #f))
@ -63,35 +61,42 @@
[(Co? t) (length (Co-pairs t))]
[else 0]))
(define (intmap-ref t key def)
(define (do-intmap-ref t key with-leaf with-pair default)
(let ([et (intmap-eqtype t)]
[root (intmap-root t)])
(if root
($intmap-ref et root (hash-code et key) key def)
($fail def))))
(do-$intmap-ref et root (hash-code et key) key with-leaf with-pair default)
default)))
(define ($intmap-ref et t h key def)
(cond
[(Br? t)
(if (fx<= h (Br-prefix t))
($intmap-ref et (Br-left t) h key def)
($intmap-ref et (Br-right t) h key def))]
(define (do-$intmap-ref et t h key with-leaf with-pair default)
(let loop ([t t])
(cond
[(Br? t)
(if (fx<= h (Br-prefix t))
(loop (Br-left t))
(loop (Br-right t)))]
[(Lf? t)
(if (key=? et key (Lf-key t))
(Lf-value t)
($fail def))]
[(Lf? t)
(if (key=? et key (Lf-key t))
(with-leaf t)
default)]
[(Co? t)
(if (fx= h (Co-hash t))
($collision-ref et t key def)
($fail def))]
[(Co? t)
(if (fx= h (Co-hash t))
($collision-ref et t key with-pair default)
default)]
[else
($fail def)]))
[else
default])))
(define (intmap-ref t key default)
(do-intmap-ref t key Lf-value cdr default))
(define (intmap-ref-key t key default)
(do-intmap-ref t key Lf-key car default))
(define ($intmap-has-key? et t h key)
(not (eq? *nothing* ($intmap-ref et t h key *nothing*))))
(do-$intmap-ref et t h key (lambda (_) #t) (lambda (_) #t) #f))
(define (intmap-set t key val)
(let ([et (intmap-eqtype t)])
@ -182,10 +187,10 @@
#f]))
;; collision ops
(define ($collision-ref et t key def)
(define ($collision-ref et t key with-pair default)
(let loop ([xs (Co-pairs t)])
(cond [(null? xs) ($fail def)]
[(key=? et key (caar xs)) (cdar xs)]
(cond [(null? xs) default]
[(key=? et key (caar xs)) (with-pair (car xs))]
[else (loop (cdr xs))])))
(define ($collision-set et t key val)
@ -253,19 +258,6 @@
[(eq? et 'eqv) (eqv-hash-code k)]
[else (key-equal-hash-code k)]))
(define ($fail default)
(if (procedure? default)
(if (procedure-arity-includes? default 0)
(|#%app| default)
(raise (|#%app|
exn:fail:contract:arity
(string-append "hash-ref: arity mismatch for failure procedure;\n"
" given procedure does not accept zero arguments\n"
" procedure: "
(error-value->string default))
(current-continuation-marks))))
default))
;; iteration
(define (intmap-iterate-first t)
(and (fx> (intmap-count t) 0)

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

@ -260,7 +260,8 @@ void scheme_clear_hash_table(Scheme_Hash_Table *ht)
}
static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int set, Scheme_Object *val,
Scheme_Object *key_wraps)
Scheme_Object *key_wraps,
GC_CAN_IGNORE Scheme_Object **_interned_key)
{
Scheme_Object *tkey, *ekey, **keys;
intptr_t hx, h2x;
@ -314,6 +315,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
set = 1;
}
} else if (equal_w_key_wraps(ekey, tkey, key_wraps)) {
if (_interned_key) *_interned_key = tkey;
if (set) {
table->vals[HASH_TO_ARRAY_INDEX(h, mask)] = val;
if (!val) {
@ -340,6 +342,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
set = 1;
}
} else if (!table->compare(tkey, (char *)key)) {
if (_interned_key) *_interned_key = tkey;
if (set) {
table->vals[HASH_TO_ARRAY_INDEX(h, mask)] = val;
if (!val) {
@ -362,6 +365,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
scheme_hash_request_count++;
while ((tkey = keys[HASH_TO_ARRAY_INDEX(h, mask)])) {
if (SAME_PTR(tkey, key)) {
if (_interned_key) *_interned_key = tkey;
if (set) {
table->vals[HASH_TO_ARRAY_INDEX(h, mask)] = val;
if (!val) {
@ -411,7 +415,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], key_wraps);
do_hash(table, oldkeys[i], 2, oldvals[i], key_wraps, _interned_key);
}
goto rehash_key;
@ -423,6 +427,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
table->keys[HASH_TO_ARRAY_INDEX(h, mask)] = key;
table->vals[HASH_TO_ARRAY_INDEX(h, mask)] = val;
if (_interned_key) *_interned_key = key;
return val;
}
@ -470,7 +475,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, NULL);
return do_hash(table, key, 2, val, NULL, NULL);
} else {
table->mcount++;
}
@ -482,7 +487,8 @@ static Scheme_Object *do_hash_set(Scheme_Hash_Table *table, Scheme_Object *key,
return val;
}
XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Scheme_Object *key,
GC_CAN_IGNORE Scheme_Object **_interned_key)
{
Scheme_Object *tkey, **keys;
hash_v_t h, h2;
@ -498,12 +504,13 @@ XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Schem
h2 |= 1;
keys = table->keys;
scheme_hash_request_count++;
while ((tkey = keys[HASH_TO_ARRAY_INDEX(h, mask)])) {
if (SAME_PTR(tkey, key)) {
if (_interned_key) *_interned_key = tkey;
return table->vals[HASH_TO_ARRAY_INDEX(h, mask)];
}
}
scheme_hash_iteration_count++;
h = (h + h2) & mask;
}
@ -526,7 +533,7 @@ void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, S
}
if (table->make_hash_indices)
do_hash(table, key, 2, val, key_wraps);
do_hash(table, key, 2, val, key_wraps, NULL);
else
do_hash_set(table, key, val);
}
@ -537,19 +544,31 @@ void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object
}
Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key,
Scheme_Object *key_wraps)
Scheme_Object *key_wraps,
GC_CAN_IGNORE Scheme_Object **_interned_key)
{
if (!table->vals)
return NULL;
else if (table->make_hash_indices)
return do_hash(table, key, 0, NULL, key_wraps);
return do_hash(table, key, 0, NULL, key_wraps, _interned_key);
else
return do_hash_get(table, key);
return do_hash_get(table, key, _interned_key);
}
Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
{
return scheme_hash_get_w_key_wraps(table, key, NULL);
return scheme_hash_get_w_key_wraps(table, key, NULL, NULL);
}
Scheme_Object *scheme_hash_get_key(Scheme_Hash_Table *table, Scheme_Object *key)
{
Scheme_Object *interned_key, *v;
v = scheme_hash_get_w_key_wraps(table, key, NULL, &interned_key);
if (v)
return interned_key;
else
return NULL;
}
Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
@ -558,7 +577,7 @@ Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key)
if (!table->vals)
return NULL;
else
return do_hash_get(table, key);
return do_hash_get(table, key, NULL);
}
Scheme_Object *scheme_hash_get_atomic(Scheme_Hash_Table *table, Scheme_Object *key)
@ -996,22 +1015,42 @@ void scheme_add_bucket_to_table(Scheme_Bucket_Table *table, Scheme_Bucket *b)
void *
scheme_lookup_in_table_w_key_wraps (Scheme_Bucket_Table *table, const char *key,
Scheme_Object *key_wraps)
Scheme_Object *key_wraps,
GC_CAN_IGNORE Scheme_Object **_interned_key)
{
Scheme_Bucket *bucket;
bucket = get_bucket(table, key, 0, NULL, key_wraps);
if (bucket)
return bucket->val;
if (bucket) {
if (_interned_key) {
if (table->weak)
*_interned_key = (Scheme_Object *)HT_EXTRACT_WEAK(bucket->key);
else
*_interned_key = (Scheme_Object *)bucket->key;
}
return bucket->val;
} else {
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);
return scheme_lookup_in_table_w_key_wraps(table, key, NULL, NULL);
}
Scheme_Object *
scheme_lookup_key_in_table (Scheme_Bucket_Table *table, const char *key)
{
Scheme_Object *interned_key, *v;
v = scheme_lookup_in_table_w_key_wraps(table, key, NULL, &interned_key);
if (v)
return interned_key;
else
return NULL;
}
void
@ -3068,7 +3107,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,
Scheme_Object *key_wraps)
Scheme_Object *key_wraps,
GC_CAN_IGNORE Scheme_Object **_interned_key)
/* 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
@ -3082,16 +3122,19 @@ static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Sche
if (stype == scheme_eq_hash_tree_type) {
if (SAME_OBJ(key, found_key)) {
if (_i) *_i = i;
if (_interned_key) *_interned_key = found_key;
return found_val;
}
} else if (stype == scheme_hash_tree_type) {
if (equal_w_key_wraps(key, found_key, key_wraps)) {
if (_i) *_i = i;
if (_interned_key) *_interned_key = found_key;
return found_val;
}
} else {
if (scheme_eqv(key, found_key)) {
if (_i) *_i = i;
if (_interned_key) *_interned_key = found_key;
return found_val;
}
}
@ -3100,7 +3143,8 @@ static Scheme_Object *hamt_linear_search(Scheme_Hash_Tree *tree, int stype, Sche
return NULL;
}
XFORM_NONGCING static Scheme_Object *hamt_eq_linear_search(Scheme_Hash_Tree *tree, Scheme_Object *key)
XFORM_NONGCING static Scheme_Object *hamt_eq_linear_search(Scheme_Hash_Tree *tree, Scheme_Object *key,
GC_CAN_IGNORE Scheme_Object **_interned_key)
/* specialized for `eq?`, where we know that comparison doesn't trigger a GC */
{
int i;
@ -3109,9 +3153,11 @@ XFORM_NONGCING static Scheme_Object *hamt_eq_linear_search(Scheme_Hash_Tree *tre
for (i = 0; i < tree->count; i++) {
hamt_at_index(tree, i, &found_key, &found_val, &found_code);
if (SAME_OBJ(key, found_key))
if (SAME_OBJ(key, found_key)) {
if (_interned_key) *_interned_key = found_key;
return found_val;
}
}
return NULL;
}
@ -3228,7 +3274,9 @@ Scheme_Hash_Tree *scheme_hash_tree_resolve_placeholder(Scheme_Hash_Tree *t)
return resolve_placeholder(t);
}
Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
XFORM_NONGCING static Scheme_Object *
scheme_eq_hash_tree_get_w_interned_key(Scheme_Hash_Tree *tree, Scheme_Object *key,
GC_CAN_IGNORE Scheme_Object **_interned_key)
{
uintptr_t h;
int pos;
@ -3242,17 +3290,25 @@ Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *ke
if (HASHTR_COLLISIONP(tree->els[pos])) {
/* hash collision; linear search in subtree */
return hamt_eq_linear_search((Scheme_Hash_Tree *)tree->els[pos], key);
return hamt_eq_linear_search((Scheme_Hash_Tree *)tree->els[pos], key, _interned_key);
} else {
if (SAME_OBJ(key, tree->els[pos]))
if (SAME_OBJ(key, tree->els[pos])) {
if (_interned_key) *_interned_key = tree->els[pos];
return mzHAMT_VAL(tree, pos);
}
}
return NULL;
}
Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
{
return scheme_eq_hash_tree_get_w_interned_key(tree, key, NULL);
}
Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key,
Scheme_Object *key_wraps)
Scheme_Object *key_wraps,
GC_CAN_IGNORE Scheme_Object **_interned_key)
{
uintptr_t h;
int stype, pos;
@ -3262,9 +3318,9 @@ Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_O
return NULL;
stype = SCHEME_TYPE(tree);
if (stype == scheme_eq_hash_tree_type)
return scheme_eq_hash_tree_get(tree, key);
return scheme_eq_hash_tree_get_w_interned_key(tree, key, _interned_key);
else if (stype == scheme_hash_tree_type) {
if (key_wraps)
key = apply_equal_key_wraps(key, key_wraps);
@ -3280,14 +3336,19 @@ Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_O
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, key_wraps);
return hamt_linear_search((Scheme_Hash_Tree *)tree->els[pos], stype, key, NULL, &code, key_wraps,
_interned_key);
} else {
if (stype == scheme_hash_tree_type) {
if (equal_w_key_wraps(key, tree->els[pos], key_wraps))
if (equal_w_key_wraps(key, tree->els[pos], key_wraps)) {
if (_interned_key) *_interned_key = tree->els[pos];
return mzHAMT_VAL(tree, pos);
}
} else {
if (scheme_eqv(key, tree->els[pos]))
if (scheme_eqv(key, tree->els[pos])) {
if (_interned_key) *_interned_key = tree->els[pos];
return mzHAMT_VAL(tree, pos);
}
}
}
@ -3296,7 +3357,18 @@ Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_O
Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key)
{
return scheme_hash_tree_get_w_key_wraps(tree, key, NULL);
return scheme_hash_tree_get_w_key_wraps(tree, key, NULL, NULL);
}
Scheme_Object *scheme_hash_tree_get_key(Scheme_Hash_Tree *tree, Scheme_Object *key)
{
Scheme_Object *interned_key, *v;
v = scheme_hash_tree_get_w_key_wraps(tree, key, NULL, &interned_key);
if (v)
return interned_key;
else
return NULL;
}
Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val,
@ -3336,7 +3408,7 @@ Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Schem
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, key_wraps)) {
if (hamt_linear_search(in_tree, stype, key, &i, &code, key_wraps, NULL)) {
/* key is part of the current collision */
if (!val) {
if (in_tree->count == 2) {

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

@ -111,6 +111,7 @@ Scheme_Object *scheme_hash_eq_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_eqv_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_equal_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_weak_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_ref_key(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_put_bang(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_put(int argc, Scheme_Object *argv[]);
static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[]);
@ -640,6 +641,11 @@ scheme_init_list (Scheme_Startup_Env *env)
REGISTER_SO(scheme_hash_ref_proc);
scheme_hash_ref_proc = scheme_make_prim_w_arity(scheme_checked_hash_ref, "hash-ref", 2, 3);
scheme_addto_prim_instance("hash-ref", scheme_hash_ref_proc, env);
scheme_addto_prim_instance("hash-ref-key",
scheme_make_noncm_prim(hash_table_ref_key,
"hash-ref-key",
2, 3),
env);
scheme_addto_prim_instance("hash-remove!",
scheme_make_noncm_prim(hash_table_remove_bang,
"hash-remove!",
@ -2561,7 +2567,8 @@ Scheme_Object *scheme_hash_table_put(int argc, Scheme_Object *argv[])
return (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)v, argv[1], argv[2]);
}
static Scheme_Object *hash_failed(int argc, Scheme_Object *argv[])
static Scheme_Object *hash_failed(const char *who, const char *contract_error_message,
int argc, Scheme_Object *argv[])
{
Scheme_Object *v;
@ -2570,24 +2577,36 @@ static Scheme_Object *hash_failed(int argc, Scheme_Object *argv[])
if (SCHEME_PROCP(v)) {
if (!scheme_check_proc_arity(NULL, 0, 2, argc, argv)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
"hash-ref: arity mismatch for failure procedure;\n"
"%s: arity mismatch for failure procedure;\n"
" given procedure does not accept zero arguments\n"
" procedure: %V",
v);
who, v);
return NULL;
}
return _scheme_tail_apply(v, 0, NULL);
} else
return v;
} else {
scheme_contract_error("hash-ref",
"no value found for key",
scheme_contract_error(who,
contract_error_message,
"key", 1, argv[1],
NULL);
return scheme_void;
}
}
static Scheme_Object *hash_ref_failed(int argc, Scheme_Object *argv[])
{
return hash_failed("hash-ref", "no value found for key", argc, argv);
}
static int scheme_chaperoned_hashp(Scheme_Object *v)
{
return (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v))));
}
static Scheme_Object *gen_hash_table_get(int argc, Scheme_Object *argv[])
{
Scheme_Object *v;
@ -2605,9 +2624,7 @@ static Scheme_Object *gen_hash_table_get(int argc, Scheme_Object *argv[])
}
} else if (SCHEME_HASHTRP(v)) {
v = scheme_hash_tree_get((Scheme_Hash_Tree *)v, argv[1]);
} else if (SCHEME_NP_CHAPERONEP(v) && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v))
|| SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(v))))
} else if (scheme_chaperoned_hashp(v))
v = scheme_chaperone_hash_get(v, argv[1]);
else if (SCHEME_BUCKTP(v)) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
@ -2622,7 +2639,7 @@ static Scheme_Object *gen_hash_table_get(int argc, Scheme_Object *argv[])
if (v)
return v;
else
return hash_failed(argc, argv);
return hash_ref_failed(argc, argv);
}
Scheme_Object *scheme_checked_hash_ref(int argc, Scheme_Object *argv[]) XFORM_ASSERT_NO_CONVERSION
@ -2637,7 +2654,7 @@ Scheme_Object *scheme_checked_hash_ref(int argc, Scheme_Object *argv[]) XFORM_AS
if (v)
return v;
else
return hash_failed(argc, argv);
return hash_ref_failed(argc, argv);
}
} else if (SCHEME_HASHTRP(v)) {
if (SAME_TYPE(scheme_eq_hash_tree_type, SCHEME_HASHTR_TYPE(v))) {
@ -2645,13 +2662,42 @@ Scheme_Object *scheme_checked_hash_ref(int argc, Scheme_Object *argv[]) XFORM_AS
if (v)
return v;
else
return hash_failed(argc, argv);
return hash_ref_failed(argc, argv);
}
}
return gen_hash_table_get(argc, argv);
}
Scheme_Object *hash_table_ref_key(int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
if (SCHEME_HASHTP(v)) {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)v;
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_hash_get_key(t, argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
} else if (SCHEME_HASHTRP(v)) {
v = scheme_hash_tree_get_key((Scheme_Hash_Tree *)v, argv[1]);
} else if (scheme_chaperoned_hashp(v)) {
v = scheme_chaperone_hash_get_key(v, argv[1]);
} else if (SCHEME_BUCKTP(v)) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)v;
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = (Scheme_Object *)scheme_lookup_key_in_table(t, (char *)argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
} else {
scheme_wrong_contract("hash-ref-key", "hash?", 0, argc, argv);
return NULL;
}
if (v)
return v;
else
return hash_failed("hash-ref-key", "hash does not contain key", argc, argv);
}
static Scheme_Object *hash_table_remove_bang(int argc, Scheme_Object *argv[])
{
Scheme_Object *v;
@ -3343,7 +3389,7 @@ static Scheme_Object *chaperone_hash_op_overflow(const char *who, Scheme_Object
return SCHEME_BOX_VAL(o);
}
static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k,
static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Scheme_Object *k,
Scheme_Object *v, int mode, Scheme_Object *key_wraps)
{
Scheme_Object *wraps = NULL;
@ -3354,22 +3400,26 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
key_wraps = NULL;
else
key_wraps = scheme_make_raw_pair((Scheme_Object *)who, key_wraps);
if (mode == 0) {
/* hash-ref */
if (mode == 0 || mode == 5) {
/* hash-ref or hash-ref-key */
Scheme_Object *interned_key;
if (SCHEME_HASHTP(o)) {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)o;
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_hash_get_w_key_wraps(t, k, key_wraps);
v = scheme_hash_get_w_key_wraps(t, k, key_wraps, &interned_key);
if (t->mutex) scheme_post_sema(t->mutex);
} else if (SCHEME_HASHTRP(o))
v = scheme_hash_tree_get_w_key_wraps((Scheme_Hash_Tree *)o, k, key_wraps);
v = scheme_hash_tree_get_w_key_wraps((Scheme_Hash_Tree *)o, k, key_wraps, &interned_key);
else {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)o;
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_lookup_in_table_w_key_wraps(t, (const char *)k, key_wraps);
v = scheme_lookup_in_table_w_key_wraps(t, (const char *)k, key_wraps, &interned_key);
if (t->mutex) scheme_post_sema(t->mutex);
}
return v;
if (mode == 0)
return v;
else
return interned_key;
} else if ((mode == 1) || (mode == 2)) {
/* hash-set! or hash-remove! */
if (SCHEME_HASHTP(o)) {
@ -3439,7 +3489,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
else if (mode == 3) {
orig = chaperone_hash_op(who, px->prev, k, v, mode, key_wraps);
k = orig;
} else if (mode == 2)
} else if ((mode == 2) || (mode == 5))
orig = k;
else if (mode == 4)
orig = scheme_void;
@ -3450,8 +3500,11 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
/* chaperone was on property accessors */
o = orig;
} else {
int red_idx;
red_idx = (mode == 5) ? 0 : mode;
red = SCHEME_BOX_VAL(px->redirects);
red = SCHEME_VEC_ELS(red)[mode];
red = SCHEME_VEC_ELS(red)[red_idx];
if ((mode == 4) && SCHEME_FALSEP(red))
return NULL; /* => fall back to a sequence of removes */
@ -3460,13 +3513,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
a[1] = k;
a[2] = orig;
if ((mode == 0) || (mode == 1)) {
/* hash-ref or hash-set! */
if ((mode == 0) || (mode == 1) || (mode == 5)) {
/* hash-ref, hash-set!, or hash-ref-key */
Scheme_Object **vals;
int cnt;
Scheme_Thread *p;
o = _scheme_apply_multi(red, ((mode == 0) ? 2 : 3), a);
o = _scheme_apply_multi(red, ((red_idx == 0) ? 2 : 3), a);
if (SAME_OBJ(o, SCHEME_MULTIPLE_VALUES)) {
p = scheme_current_thread;
@ -3503,7 +3556,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: chaperone produced a second value that does not match the expected contract\n"
" expected: (procedure-arity-includes/c 3)\n"
" received: %V",
" received: %V",
who,
red);
@ -3516,7 +3569,20 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
a[2] = orig;
o = _scheme_apply(red, 3, a);
what = "result";
} else
} else if (mode == 5) {
/* hash-ref-key */
orig = chaperone_hash_op(who, px->prev, k, v, mode, key_wraps);
if (!orig) return NULL;
red = SCHEME_BOX_VAL(px->redirects);
red = SCHEME_VEC_ELS(red)[3];
a[0] = px->prev;
a[1] = orig;
o = scheme_apply(red, 2, a);
what = "key";
} else
what = "value";
} else if (mode == 4) {
/* hash-clear */
@ -3534,7 +3600,7 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem
scheme_wrong_chaperoned(who, what, orig, o);
}
if ((mode == 0) || (mode == 3))
if ((mode == 0) || (mode == 3) || (mode == 5))
return o;
else {
if (mode == 1)
@ -3554,6 +3620,11 @@ Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *ke
return chaperone_hash_op("hash-ref", table, key, NULL, 0, scheme_null);
}
Scheme_Object *scheme_chaperone_hash_get_key(Scheme_Object *table, Scheme_Object *key)
{
return chaperone_hash_op("hash-ref-key", table, key, NULL, 5, 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, scheme_null);

2
racket/src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1453
#define EXPECTED_PRIM_COUNT 1454
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -1025,19 +1025,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_key(Scheme_Hash_Table *table, Scheme_Object *key);
Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key,
Scheme_Object *key_wraps);
Scheme_Object *key_wraps, Scheme_Object **_interned_key);
void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps);
Scheme_Object *scheme_lookup_key_in_table(Scheme_Bucket_Table *table, const char *key);
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 *key_wraps, Scheme_Object **_interned_key);
Scheme_Object *scheme_hash_tree_get_key(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);
Scheme_Object *key_wraps, Scheme_Object **_interned_key);
Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps);
@ -1270,6 +1273,7 @@ Scheme_Object *scheme_chaperone_props_get(Scheme_Object *props, Scheme_Object *p
Scheme_Object *scheme_chaperone_props_remove(Scheme_Object *props, Scheme_Object *prop);
Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *key);
Scheme_Object *scheme_chaperone_hash_get_key(Scheme_Object *table, Scheme_Object *key);
Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key, Scheme_Object **alt_key);
void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val);

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

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_W 3
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x