From 191d17461fb815a362b7177606e5052d4f3a7bc9 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 10 Oct 2018 10:21:43 -0600
Subject: [PATCH] hash-ref: adjust error message for bad failure thunk

Refines 2ef8d60cc6 to avoid characterizing the failure as a `(-> any)`
contract on `hash-ref`, since `hash-ref` doesn't enforce that contract
in general. Go back to an `exn:fail:contract:arity` error, but keep
the specialization of the error message to clarify that it's from
`hash-ref`. Also, bring RacketCS into sync.
---
 pkgs/racket-test-core/tests/racket/basic.rktl |  2 +-
 racket/src/cs/rumble/hash.ss                  | 16 ++++------------
 racket/src/cs/rumble/intmap.ss                | 10 +++++++++-
 racket/src/racket/src/list.c                  |  9 ++++++++-
 4 files changed, 22 insertions(+), 15 deletions(-)

diff --git a/pkgs/racket-test-core/tests/racket/basic.rktl b/pkgs/racket-test-core/tests/racket/basic.rktl
index 7b75671b80..4573a7a090 100644
--- a/pkgs/racket-test-core/tests/racket/basic.rktl
+++ b/pkgs/racket-test-core/tests/racket/basic.rktl
@@ -2215,7 +2215,7 @@
       (test #t eq? (equal-hash-code l) (equal-hash-code (list 1 2 3)))
       (hash-set! h1 l 'ok)
       (test 'ok hash-ref h1 l)
-      (err/rt-test (hash-ref h1 'nonesuch (lambda (x) 'bad-proc)) exn:fail:contract? "hash-ref")
+      (err/rt-test (hash-ref h1 'nonesuch (lambda (x) 'bad-proc)) exn:fail:contract:arity? "hash-ref")
       (test #t hash-has-key? h1 l)
       (test #f hash-has-key? h1 (cdr l))
       (when hash-ref!
diff --git a/racket/src/cs/rumble/hash.ss b/racket/src/cs/rumble/hash.ss
index e377a8163b..3fd114daef 100644
--- a/racket/src/cs/rumble/hash.ss
+++ b/racket/src/cs/rumble/hash.ss
@@ -256,9 +256,7 @@
        (let ([v (hashtable-ref (mutable-hash-ht ht) k none)])
          (lock-release (mutable-hash-lock ht))
          (if (eq? v none)
-             (if (procedure? fail)
-                 (|#%app| fail)
-                 fail)
+             ($fail fail)
              v))]
       [(intmap? ht) (intmap-ref ht k fail)]
       [(weak-equal-hash? ht) (weak-hash-ref ht k fail)]
@@ -266,9 +264,7 @@
             (authentic-hash? (impersonator-val ht)))
        (let ([v (impersonate-hash-ref ht k)])
          (if (eq? v none)
-             (if (procedure? fail)
-                 (|#%app| fail)
-                 fail)
+             ($fail fail)
              v))]
       [else (raise-argument-error 'hash-ref "hash?" ht)])]))
 
@@ -744,17 +740,13 @@
          [(null? keys)
           ;; Not in the table:
           (lock-release (weak-equal-hash-lock t))
-          (if (procedure? fail)
-              (|#%app| fail)
-              fail)]
+          ($fail fail)]
          [(key-equal? (car keys) key)
           (let* ([k (car keys)]
                  [v (hashtable-ref (weak-equal-hash-*vals-ht t k) (car keys) none)])
             (lock-release (weak-equal-hash-lock t))
             (if (eq? v none)
-                (if (procedure? fail)
-                    (|#%app| fail)
-                    fail)
+                ($fail fail)
                 v))]
          [else (loop (cdr keys))])))))
 
diff --git a/racket/src/cs/rumble/intmap.ss b/racket/src/cs/rumble/intmap.ss
index afc363279d..3e39730ea2 100644
--- a/racket/src/cs/rumble/intmap.ss
+++ b/racket/src/cs/rumble/intmap.ss
@@ -249,7 +249,15 @@
 
 (define ($fail default)
   (if (procedure? default)
-      (|#%app| 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
diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c
index 77f5206b2e..ea5cae9c12 100644
--- a/racket/src/racket/src/list.c
+++ b/racket/src/racket/src/list.c
@@ -2604,7 +2604,14 @@ static Scheme_Object *hash_failed(int argc, Scheme_Object *argv[])
   if (argc == 3) {
     v = argv[2];
     if (SCHEME_PROCP(v)) {
-      scheme_check_proc_arity("hash-ref", 0, 2, argc, argv);
+      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"
+                         " given procedure does not accept zero arguments\n"
+                         "  procedure: %V",
+                         v);
+        return NULL;
+      }
       return _scheme_tail_apply(v, 0, NULL);
     } else
       return v;