diff --git a/collects/scheme/private/more-scheme.ss b/collects/scheme/private/more-scheme.ss index 6568bbb5ed..7251f16141 100644 --- a/collects/scheme/private/more-scheme.ss +++ b/collects/scheme/private/more-scheme.ss @@ -360,7 +360,7 @@ (define-log log-info info) (define-log log-debug debug) - (define-values (hash-update hash-update!) + (define-values (hash-update hash-update! hash-has-key? hash-ref!) (let* ([not-there (gensym)] [up (lambda (who mut? set ht key xform default) (unless (and (hash? ht) @@ -385,8 +385,19 @@ [(ht key xform default) (up 'hash-update! #t hash-set! ht key xform default)] [(ht key xform) - (hash-update! ht key xform not-there)])]) - (values hash-update hash-update!)))) + (hash-update! ht key xform not-there)])] + [hash-has-key? + (lambda (ht key) + (not (eq? not-there (hash-ref ht key not-there))))] + [hash-ref! + (lambda (ht key new) + (let ([v (hash-ref ht key not-there)]) + (if (eq? not-there v) + (let ([n (if (procedure? new) (new) new)]) + (hash-set! ht key n) + n) + v)))]) + (values hash-update hash-update! hash-has-key? hash-ref!)))) (#%provide case old-case do parameterize parameterize* current-parameterization call-with-parameterization @@ -395,4 +406,4 @@ set!-values let/cc fluid-let time log-fatal log-error log-warning log-info log-debug - hash-update hash-update!)) + hash-ref! hash-has-key? hash-update hash-update!)) diff --git a/collects/scribblings/reference/hashes.scrbl b/collects/scribblings/reference/hashes.scrbl index 18c7c9daef..a4d84730cd 100644 --- a/collects/scribblings/reference/hashes.scrbl +++ b/collects/scribblings/reference/hashes.scrbl @@ -181,7 +181,6 @@ returning the extended hash table. @see-also-mutable-key-caveat[]} - @defproc[(hash-ref [hash hash?] [key any/c] [failure-result any/c (lambda () @@ -203,6 +202,23 @@ result: @see-also-caveats[]} +@defproc[(hash-ref! [hash hash?] [key any/c] [to-set any/c]) + any]{ + +Returns the value for @scheme[key] in @scheme[hash]. If no value is +found for @scheme[key], then @scheme[to-set] determines the result as +in @scheme[hash-ref] (i.e., it is either a thunk that computes a value +or a plain value), and this result is stored in @scheme[hash] for the +@scheme[key]. (Note that is @scheme[to-set] is a thunk, it is not +invoked in tail position.)} + + +@defproc[(hash-has-key? [hash hash?] [key any/c]) + any]{ + +Returns a true value if @scheme[hash] contains the given +@scheme[key].} + @defproc[(hash-update! [hash (and/c hash? (not/c immutable?))] [key any/c] diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss index 3b3743a2f1..ab3117f0ca 100644 --- a/collects/tests/mzscheme/basic.ss +++ b/collects/tests/mzscheme/basic.ss @@ -1920,7 +1920,7 @@ (define (hash-tests make-hash make-hasheq make-hasheqv make-weak-hash make-weak-hasheq make-weak-hasheqv - hash-ref hash-set! hash-update! + hash-ref hash-set! hash-ref! hash-update! hash-has-key? hash-remove! hash-count hash-map hash-for-each hash-iterate-first hash-iterate-next @@ -1942,6 +1942,14 @@ (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) + (test #t hash-has-key? h1 l) + (test #f hash-has-key? h1 (cdr l)) + (when hash-ref! + (test 'ok hash-ref! h1 l 'blah) + (test 'blah hash-ref! h1 (cdr l) 'blah) + (test #t hash-has-key? h1 (cdr l)) + (test 'blah hash-ref h1 (cdr l)) + (hash-remove! h1 (cdr l))) (hash-update! h1 l (curry cons 'more)) (test '(more . ok) hash-ref h1 l) (hash-update! h1 l cdr) @@ -2086,7 +2094,7 @@ (hash-tests make-hash make-hasheq make-hasheqv make-weak-hash make-weak-hasheq make-weak-hasheqv - hash-ref hash-set! hash-update! + hash-ref hash-set! hash-ref! hash-update! hash-has-key? hash-remove! hash-count hash-map hash-for-each hash-iterate-first hash-iterate-next @@ -2101,9 +2109,11 @@ #f #f #f (ub-wrap hash-ref) (lambda (ht k v) (set-box! ht (hash-set (unbox ht) k v))) - (case-lambda + #f + (case-lambda [(ht k u) (set-box! ht (hash-update (unbox ht) k u))] [(ht k u def) (set-box! ht (hash-update (unbox ht) k u def))]) + (ub-wrap hash-has-key?) (lambda (ht k) (set-box! ht (hash-remove (unbox ht) k))) (ub-wrap hash-count) (ub-wrap hash-map)