Adds hash-ref-key primitive

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.

pkgs/base/info.rkt

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

pkgs/racket-doc/scribblings/reference/chaperones.scrbl

@@ -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
+been extracted from @racket[hash] (by @racket[hash-ref-key],
-other operations that use @racket[hash-iterate-key] internally); it
+@racket[hash-iterate-key], or other operations that use
-must produce a replacement for the key, which is then reported as a
+@racket[hash-iterate-key] internally); it must produce a replacement
-key extracted from the table.
+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

pkgs/racket-doc/scribblings/reference/hashes.scrbl

@@ -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!],
+  @racket[hash-ref-key], @racket[hash-set!], @racket[hash-remove!],
-  or @racket[hash-update!] to a hash table that
+  @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]{
 

pkgs/racket-test-core/tests/racket/chaperone.rktl

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

pkgs/racket-test-core/tests/racket/hash.rktl

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

racket/src/cs/primitive/kernel.ss

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

racket/src/cs/rumble.sls

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

racket/src/cs/rumble/datum.ss

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

racket/src/cs/rumble/hash.ss

@@ -257,7 +257,7 @@
 (define hash-ref
   (case-lambda
    [(ht k)
-     (let ([v (hash-ref ht k none)])
+    (let ([v (hash-ref/none ht k)])
       (if (eq? v none)
           (raise-arguments-error
            'hash-ref
@@ -265,23 +265,76 @@
            "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))
-         (if (eq? v none)
+      v)]
-             ($fail fail)
+   [(intmap? ht)
-             v))]
+    (intmap-ref ht k none)]
-      [(intmap? ht) (intmap-ref ht k fail)]
+   [(weak-equal-hash? ht)
-      [(weak-equal-hash? ht) (weak-hash-ref ht k fail)]
+    (weak-hash-ref ht k none)]
    [(and (impersonator? ht)
          (authentic-hash? (impersonator-val ht)))
-       (let ([v (impersonate-hash-ref ht k)])
+    (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)
-             ($fail fail)
+          (raise-arguments-error
+           'hash-ref-key
+           "hash does not contain key"
+           "key" k)
           v))]
-      [else (raise-argument-error 'hash-ref "hash?" ht)])]))
+   [(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)
+            v)]
-                ($fail fail)
-                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

racket/src/cs/rumble/intmap.ss

@@ -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)
+        (do-$intmap-ref et root (hash-code et key) key with-leaf with-pair default)
-        ($fail def))))
+        default)))
 
-(define ($intmap-ref et 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))
-        ($intmap-ref et (Br-left t) h key def)
+          (loop (Br-left t))
-        ($intmap-ref et (Br-right t) h key def))]
+          (loop (Br-right t)))]
 
      [(Lf? t)
       (if (key=? et key (Lf-key t))
-        (Lf-value t)
+          (with-leaf t)
-        ($fail def))]
+          default)]
 
      [(Co? t)
       (if (fx= h (Co-hash t))
-        ($collision-ref et t key def)
+          ($collision-ref et t key with-pair default)
-        ($fail def))]
+          default)]
 
      [else
-    ($fail def)]))
+      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)]
+    (cond [(null? xs) default]
-          [(key=? et key (caar xs)) (cdar xs)]
+          [(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)

racket/src/racket/src/hash.c

@@ -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;
@@ -502,6 +508,7 @@ XFORM_NONGCING static Scheme_Object *do_hash_get(Scheme_Hash_Table *table, Schem
   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++;
@@ -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)
+  if (bucket) {
-    return bucket->val;
+    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;
@@ -3264,7 +3320,7 @@ Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_O
   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,23 +3336,39 @@ 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);
       }
     }
+  }
 
   return NULL;
 }
 
 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) {

racket/src/racket/src/list.c

@@ -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",
+    scheme_contract_error(who,
-                          "no value found for key",
+                          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))
+  } else if (scheme_chaperoned_hashp(v))
-                                         || SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(v))
-                                         || SCHEME_BUCKTP(SCHEME_CHAPERONE_VAL(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;
@@ -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) {
+      if (mode == 0 || mode == 5) {
-        /* hash-ref */
+        /* 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);
         }
+        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)) {
+        if ((mode == 0) || (mode == 1) || (mode == 5)) {
-          /* hash-ref or hash-set! */
+          /* 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;
@@ -3516,6 +3569,19 @@ 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 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) {
@@ -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);

racket/src/racket/src/schminc.h

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

racket/src/racket/src/schpriv.h

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

racket/src/racket/src/schvers.h

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