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:
parent
15280640d4
commit
191d17461f
|
@ -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!
|
||||
|
|
|
@ -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))])))))
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue
Block a user