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.
This commit is contained in:
Matthew Flatt 2018-10-10 10:21:43 -06:00
parent 15280640d4
commit 191d17461f
4 changed files with 22 additions and 15 deletions

View File

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

View File

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

View File

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

View File

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