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;