From b7392a688e7d16afeeb89a3f032ac0b033a2c63a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Jul 2018 20:23:49 -0600 Subject: [PATCH] hash-iterate-value & co.: add an optional bad-index result The new argument to `hash-iterate-value` and most other `...-hash-iterate-...` functions determines a result to be returned in place of raising a "bad index" exception. For most kinds of hash tables, a "bad index" exception will only happen when the provided index is wrong or when a hash table is mutated during an iteration. Mutation during iteration is generally a bad idea, but in the case of a weak hash table, a potential background mutation by the garbage collector is difficult to suppress or ignore. Adding an option to control bad-index behavior makes it easier to write loops that defend against uncooperative tables, including loops where a hash-table key disappears asynchronously. Racket's printer was already using this functionality internally, so the change to `hash-iterate-value` and company mostly exposes existing functionality. The `in-hash` form and related sequence constructors similarly support a bad-index alternate value so iterations can handle that case explicitly. They do not use the new bad-index support implicitly to skip missing entries, because that idea does not play well with the iteration API. A hash-table index can go bad after `in-hash` has selected the index and determined that it should be used for the next iteration, and a sequence can't take back that decision. --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/hashes.scrbl | 115 +++-- .../scribblings/reference/sequences.scrbl | 103 ++++- .../scribblings/reference/unsafe.scrbl | 169 +++++-- pkgs/racket-test-core/tests/racket/basic.rktl | 49 ++- pkgs/racket-test-core/tests/racket/for.rktl | 9 + pkgs/racket-test-core/tests/racket/hash.rktl | 67 ++- .../racket-test-core/tests/racket/unsafe.rktl | 59 ++- racket/collects/racket/private/for.rkt | 89 ++-- racket/src/cs/rumble/hash.ss | 414 ++++++++---------- racket/src/io/print/graph.rkt | 12 +- racket/src/racket/src/list.c | 194 +++++--- racket/src/racket/src/schvers.h | 4 +- 13 files changed, 820 insertions(+), 466 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index d92eb2d3d9..4df2125a53 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.0.0.9") +(define version "7.0.0.10") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/hashes.scrbl b/pkgs/racket-doc/scribblings/reference/hashes.scrbl index fa74682f01..193b74125d 100644 --- a/pkgs/racket-doc/scribblings/reference/hashes.scrbl +++ b/pkgs/racket-doc/scribblings/reference/hashes.scrbl @@ -464,9 +464,18 @@ Returns @racket[#f] if @racket[hash] contains no elements, otherwise it returns an integer that is an index to the first element in the hash table; ``first'' refers to an unspecified ordering of the table elements, and the index values are not necessarily consecutive -integers. For a mutable @racket[hash], this index is guaranteed to -refer to the first item only as long as no items are added to or -removed from @racket[hash].} +integers. + +For a mutable @racket[hash], this index is guaranteed to refer to the +first item only as long as no items are added to or removed from +@racket[hash]. More generally, an index is guaranteed to be a +@deftech{valid hash index} for a given hash table only as long it comes +from @racket[hash-iterate-first] or @racket[hash-iterate-next], and +only as long as the hash table is not modified. In the case of a hash +table with weakly held keys, the hash table can be implicitly modified +by the garbage collector (see @secref["gc-model"]) when it discovers +that the key is not reachable.} + @defproc[(hash-iterate-next [hash hash?] [pos exact-nonnegative-integer?]) @@ -475,49 +484,105 @@ removed from @racket[hash].} Returns either an integer that is an index to the element in @racket[hash] after the element indexed by @racket[pos] (which is not necessarily one more than @racket[pos]) or @racket[#f] if @racket[pos] -refers to the last element in @racket[hash]. If @racket[pos] is not a -valid index, then the @exnraise[exn:fail:contract]. For a mutable -@racket[hash], the result index is guaranteed to refer to its item -only as long as no items are added to or removed from @racket[hash].} +refers to the last element in @racket[hash]. + +If @racket[pos] is not a @tech{valid hash index} of @racket[hash], +then the result may be @racket[#f] or it may be the next later index +that remains valid. The latter result is guaranteed if a hash table +has been modified only by the removal of keys. + +@history[#:changed "7.0.0.10" @elem{Handle an invalid index by returning @scheme[#f] + instead of raising @racket[exn:fail:contract].}]} +@deftogether[( @defproc[(hash-iterate-key [hash hash?] [pos exact-nonnegative-integer?]) - any]{ - + any/c] +@defproc[#:link-target? #f + (hash-iterate-key [hash hash?] + [pos exact-nonnegative-integer?] + [bad-index-v any/c]) + any/c] +)]{ + Returns the key for the element in @racket[hash] at index -@racket[pos]. If @racket[pos] is not a valid index for -@racket[hash], the @exnraise[exn:fail:contract].} +@racket[pos]. + +If @racket[pos] is not a @tech{valid hash index} for @racket[hash], +the result is @racket[bad-index-v] if provided, otherwise the +@exnraise[exn:fail:contract]. + +@history[#:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} +@deftogether[( @defproc[(hash-iterate-value [hash hash?] [pos exact-nonnegative-integer?]) - any]{ + any] +@defproc[#:link-target? #f + (hash-iterate-value [hash hash?] + [pos exact-nonnegative-integer?] + [bad-index-v any/c]) + any] +)]{ Returns the value for the element in @racket[hash] at index -@racket[pos]. If @racket[pos] is not a valid index for -@racket[hash], the @exnraise[exn:fail:contract].} +@racket[pos]. +If @racket[pos] is not a @tech{valid hash index} for @racket[hash], +the result is @racket[bad-index-v] if provided, otherwise the +@exnraise[exn:fail:contract]. + +@history[#:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} + + + +@deftogether[( @defproc[(hash-iterate-pair [hash hash?] - [pos exact-nonnegative-integer?]) - (cons any any)]{ + [pos exact-nonnegative-integer?]) + (cons any/c any/c)] +@defproc[#:link-target? #f + (hash-iterate-pair [hash hash?] + [pos exact-nonnegative-integer?] + [bad-index-v any/c]) + (cons any/c any/c)] +)]{ Returns a pair containing the key and value for the element -in @racket[hash] at index -@racket[pos]. If @racket[pos] is not a valid index for -@racket[hash], the @exnraise[exn:fail:contract].} +in @racket[hash] at index @racket[pos]. -@history[#:added "6.4.0.5"] +If @racket[pos] is not a @tech{valid hash index} for @racket[hash], +the result is @racket[(cons bad-index-v bad-index-v)] if +@racket[bad-index-v] is provided, otherwise the +@exnraise[exn:fail:contract]. +@history[#:added "6.4.0.5" + #:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} + + +@deftogether[( @defproc[(hash-iterate-key+value [hash hash?] - [pos exact-nonnegative-integer?]) - (values any any)]{ + [pos exact-nonnegative-integer?]) + (values any/c any/c)] +@defproc[#:link-target? #f + (hash-iterate-key+value [hash hash?] + [pos exact-nonnegative-integer?] + [bad-index-v any/c]) + (values any/c any/c)] +)]{ Returns the key and value for the element in @racket[hash] at index -@racket[pos]. If @racket[pos] is not a valid index for -@racket[hash], the @exnraise[exn:fail:contract].} +@racket[pos]. + +If @racket[pos] is not a @tech{valid hash index} for @racket[hash], +the result is @racket[(values bad-index-v bad-index-v)] if +@racket[bad-index-v] is provided, otherwise the +@exnraise[exn:fail:contract]. + +@history[#:added "6.4.0.5" + #:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} -@history[#:added "6.4.0.5"] @defproc[(hash-copy [hash hash?]) (and/c hash? (not/c immutable?))]{ diff --git a/pkgs/racket-doc/scribblings/reference/sequences.scrbl b/pkgs/racket-doc/scribblings/reference/sequences.scrbl index ccfa04d6ba..2db99dadaf 100644 --- a/pkgs/racket-doc/scribblings/reference/sequences.scrbl +++ b/pkgs/racket-doc/scribblings/reference/sequences.scrbl @@ -349,8 +349,19 @@ each element in the sequence. that the default mode is @racket['any], whereas the default mode of @racket[read-bytes-line] is @racket['linefeed].} -@defproc[(in-hash [hash hash?]) sequence?]{ - Returns a sequence equivalent to @racket[hash]. +@defproc*[([(in-hash [hash hash?]) sequence?] + [(in-hash [hash hash?] [bad-index-v any/c]) sequence?])]{ + Returns a sequence equivalent to @racket[hash], except when @racket[bad-index-v] + is supplied. + + If @racket[bad-index-v] is supplied, then @racket[bad-index-v] is + returned as both the key and the value in the case that the + @racket[hash] is modified concurrently so that iteration does not have a + @tech{valid hash index}. Providing @racket[bad-index-v] is particularly + useful when iterating through a hash table with weakly held keys, since + entries can be removed asynchronously (i.e., after @racket[in-hash] has + committed to another iteration, but before it can access the entry for the + next iteration). @examples[ (define table (hash 'a 1 'b 2)) @@ -358,82 +369,144 @@ each element in the sequence. (printf "key: ~a value: ~a\n" key value))] @info-on-seq["hashtables" "hash tables"] -} -@defproc[(in-hash-keys [hash hash?]) sequence?]{ - Returns a sequence whose elements are the keys of @racket[hash]. + @history[#:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} + +@defproc*[([(in-hash-keys [hash hash?]) sequence?] + [(in-hash-keys [hash hash?] [bad-index-v any/c]) sequence?])]{ + Returns a sequence whose elements are the keys of @racket[hash], using + @racket[bad-index-v] in the same way as @racket[in-hash]. @examples[ (define table (hash 'a 1 'b 2)) (for ([key (in-hash-keys table)]) (printf "key: ~a\n" key))] -} -@defproc[(in-hash-values [hash hash?]) sequence?]{ - Returns a sequence whose elements are the values of @racket[hash]. + @history[#:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} + +@defproc*[([(in-hash-values [hash hash?]) sequence?] + [(in-hash-values [hash hash?] [bad-index-v any/c]) sequence?])]{ + Returns a sequence whose elements are the values of @racket[hash], using + @racket[bad-index-v] in the same way as @racket[in-hash]. @examples[ (define table (hash 'a 1 'b 2)) (for ([value (in-hash-values table)]) (printf "value: ~a\n" value))] -} -@defproc[(in-hash-pairs [hash hash?]) sequence?]{ + @history[#:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} + +@defproc*[([(in-hash-pairs [hash hash?]) sequence?] + [(in-hash-pairs [hash hash?] [bad-index-v any/c]) sequence?])]{ Returns a sequence whose elements are pairs, each containing a key and its value from @racket[hash] (as opposed to using @racket[hash] directly as a sequence to get the key and value as separate values - for each element). + for each element). + + The @racket[bad-index-v] argument, if supplied, is used in the same + way as by @racket[in-hash]. When an invalid index is encountered, + the pair in the sequence with have @racket[bad-index-v] as both its + @racket[car] and @racket[cdr]. @examples[ (define table (hash 'a 1 'b 2)) (for ([key+value (in-hash-pairs table)]) (printf "key and value: ~a\n" key+value))] -} + + @history[#:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} @deftogether[( @defproc[(in-mutable-hash [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))]) sequence?] +@defproc[#:link-target? #f + (in-mutable-hash + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] [bad-index-v any/c]) + sequence?] @defproc[(in-mutable-hash-keys [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))]) sequence?] +@defproc[#:link-target? #f + (in-mutable-hash-keys + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] [bad-index-v any/c]) + sequence?] @defproc[(in-mutable-hash-values [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))]) sequence?] +@defproc[#:link-target? #f + (in-mutable-hash-values + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] [bad-index-v any/c]) + sequence?] @defproc[(in-mutable-hash-pairs [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))]) sequence?] +@defproc[#:link-target? #f + (in-mutable-hash-pairs + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] [bad-index-v any/c]) + sequence?] @defproc[(in-immutable-hash [hash (and/c hash? immutable?)]) sequence?] +@defproc[#:link-target? #f + (in-immutable-hash + [hash (and/c hash? immutable?)] [bad-index-v any/c]) + sequence?] @defproc[(in-immutable-hash-keys [hash (and/c hash? immutable?)]) sequence?] +@defproc[#:link-target? #f + (in-immutable-hash-keys + [hash (and/c hash? immutable?)] [bad-index-v any/c]) + sequence?] @defproc[(in-immutable-hash-values [hash (and/c hash? immutable?)]) sequence?] +@defproc[#:link-target? #f + (in-immutable-hash-values + [hash (and/c hash? immutable?)] [bad-index-v any/c]) + sequence?] @defproc[(in-immutable-hash-pairs [hash (and/c hash? immutable?)]) sequence?] +@defproc[#:link-target? #f + (in-immutable-hash-pairs + [hash (and/c hash? immutable?)] [bad-index-v any/c]) + sequence?] @defproc[(in-weak-hash [hash (and/c hash? hash-weak?)]) sequence?] +@defproc[#:link-target? #f + (in-weak-hash + [hash (and/c hash? hash-weak?)] [bad-index-v any/c]) + sequence?] @defproc[(in-weak-hash-keys [hash (and/c hash? hash-weak?)]) sequence?] +@defproc[#:link-target? #f + (in-weak-hash-keys + [hash (and/c hash? hash-weak?)] [bad-index-v any/c]) + sequence?] @defproc[(in-weak-hash-values [hash (and/c hash? hash-weak?)]) sequence?] +@defproc[#:link-target? #f + (in-weak-hash-keys + [hash (and/c hash? hash-weak?)] [bad-index-v any/c]) + sequence?] @defproc[(in-weak-hash-pairs [hash (and/c hash? hash-weak?)]) sequence?] +@defproc[#:link-target? #f + (in-weak-hash-pairs + [hash (and/c hash? hash-weak?)] [bad-index-v any/c]) + sequence?] )]{ Sequence constructors for specific kinds of hash tables. - These may perform better than the analogous @racket[in-hash] - forms. However, they may consume more space to help with iteration. + forms. - @history[#:added "6.4.0.6"] + @history[#:added "6.4.0.6" + #:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}] } diff --git a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl index 8206559694..dcc272be51 100644 --- a/pkgs/racket-doc/scribblings/reference/unsafe.scrbl +++ b/pkgs/racket-doc/scribblings/reference/unsafe.scrbl @@ -356,91 +356,168 @@ is analogous to @racket[box-cas!] to perform an atomic compare-and-set. @deftogether[( @defproc[(unsafe-mutable-hash-iterate-first - [h (and/c hash? (not/c immutable?) (not/c hash-weak?))]) + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))]) (or/c #f any/c)] @defproc[(unsafe-mutable-hash-iterate-next - [h (and/c hash? (not/c immutable?) (not/c hash-weak?))] - [i any/c]) + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c]) (or/c #f any/c)] @defproc[(unsafe-mutable-hash-iterate-key - [h (and/c hash? (not/c immutable?) (not/c hash-weak?))] - [i any/c]) + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c]) + any/c] +@defproc[#:link-target? #f + (unsafe-mutable-hash-iterate-key + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c] + [bad-index-v any/c]) any/c] @defproc[(unsafe-mutable-hash-iterate-value - [h (and/c hash? (not/c immutable?) (not/c hash-weak?))] - [i any/c]) + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c]) + any/c] +@defproc[#:link-target? #f + (unsafe-mutable-hash-iterate-value + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c] + [bad-index-v any/c]) any/c] @defproc[(unsafe-mutable-hash-iterate-key+value - [h (and/c hash? (not/c immutable?) (not/c hash-weak?))] - [i any/c]) + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c]) + (values any/c any/c)] +@defproc[#:link-target? #f + (unsafe-mutable-hash-iterate-key+value + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c] + [bad-index-v any/c]) (values any/c any/c)] @defproc[(unsafe-mutable-hash-iterate-pair - [h (and/c hash? (not/c immutable?) (not/c hash-weak?))] - [i any/c]) + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c]) + pair?] +@defproc[#:link-target? #f + (unsafe-mutable-hash-iterate-pair + [hash (and/c hash? (not/c immutable?) (not/c hash-weak?))] + [pos any/c] + [bad-index-v any/c]) pair?] @defproc[(unsafe-immutable-hash-iterate-first - [h (and/c hash? immutable?)]) + [hash (and/c hash? immutable?)]) (or/c #f any/c)] @defproc[(unsafe-immutable-hash-iterate-next - [h (and/c hash? immutable?)] - [i any/c]) + [hash (and/c hash? immutable?)] + [pos any/c]) (or/c #f any/c)] @defproc[(unsafe-immutable-hash-iterate-key - [h (and/c hash? immutable?)] - [i any/c]) + [hash (and/c hash? immutable?)] + [pos any/c]) + any/c] +@defproc[#:link-target? #f + (unsafe-immutable-hash-iterate-key + [hash (and/c hash? immutable?)] + [pos any/c] + [bad-index-v any/c]) any/c] @defproc[(unsafe-immutable-hash-iterate-value - [h (and/c hash? immutable?)] - [i any/c]) + [hash (and/c hash? immutable?)] + [pos any/c]) + any/c] +@defproc[#:link-target? #f + (unsafe-immutable-hash-iterate-value + [hash (and/c hash? immutable?)] + [pos any/c] + [bad-index-v any/c]) any/c] @defproc[(unsafe-immutable-hash-iterate-key+value - [h (and/c hash? immutable?)] - [i any/c]) + [hash (and/c hash? immutable?)] + [pos any/c]) + (values any/c any/c)] +@defproc[#:link-target? #f + (unsafe-immutable-hash-iterate-key+value + [hash (and/c hash? immutable?)] + [pos any/c] + [bad-index-v any/c]) (values any/c any/c)] @defproc[(unsafe-immutable-hash-iterate-pair - [h (and/c hash? immutable?)] - [i any/c]) + [hash (and/c hash? immutable?)] + [pos any/c]) + pair?] +@defproc[#:link-target? #f + (unsafe-immutable-hash-iterate-pair + [hash (and/c hash? immutable?)] + [pos any/c] + [bad-index-v any/c]) pair?] @defproc[(unsafe-weak-hash-iterate-first - [h (and/c hash? hash-weak?)]) + [hash (and/c hash? hash-weak?)]) (or/c #f any/c)] @defproc[(unsafe-weak-hash-iterate-next - [h (and/c hash? hash-weak?)] - [i any/c]) + [hash (and/c hash? hash-weak?)] + [pos any/c]) (or/c #f any/c)] @defproc[(unsafe-weak-hash-iterate-key - [h (and/c hash? hash-weak?)] - [i any/c]) + [hash (and/c hash? hash-weak?)] + [pos any/c]) + any/c] +@defproc[#:link-target? #f + (unsafe-weak-hash-iterate-key + [hash (and/c hash? hash-weak?)] + [pos any/c] + [bad-index-v any/c]) any/c] @defproc[(unsafe-weak-hash-iterate-value - [h (and/c hash? hash-weak?)] - [i any/c]) + [hash (and/c hash? hash-weak?)] + [pos any/c]) + any/c] +@defproc[#:link-target? #f + (unsafe-weak-hash-iterate-value + [hash (and/c hash? hash-weak?)] + [pos any/c] + [bad-index-v any/c]) any/c] @defproc[(unsafe-weak-hash-iterate-key+value - [h (and/c hash? hash-weak?)] - [i any/c]) + [hash (and/c hash? hash-weak?)] + [pos any/c]) + (values any/c any/c)] +@defproc[#:link-target? #f + (unsafe-weak-hash-iterate-key+value + [hash (and/c hash? hash-weak?)] + [pos any/c] + [bad-index-v any/c]) (values any/c any/c)] @defproc[(unsafe-weak-hash-iterate-pair - [h (and/c hash? hash-weak?)] - [i any/c]) + [hash (and/c hash? hash-weak?)] + [pos any/c]) + pair?] +@defproc[#:link-target? #f + (unsafe-weak-hash-iterate-pair + [hash (and/c hash? hash-weak?)] + [pos any/c] + [bad-index-v any/c]) pair?] )]{ -Unsafe versions of @racket[hash-iterate-key] and similar ops. These operations -support @tech{chaperones} and @tech{impersonators}. +Unsafe versions of @racket[hash-iterate-key] and similar procedures. +These operations support @tech{chaperones} and @tech{impersonators}. -Each unsafe @code{-first} and @code{-next} operation may not return a number -index but rather an internal representation of a view into the hash structure, -enabling faster iteration. +Each unsafe ...@code{-first} and ...@code{-next} procedure may return, +instead of a number index, an internal representation of a view into +the hash structure, enabling faster iteration. The result of these +...@code{-first} and ...@code{-next} functions should be given as +@racket[pos] to the corresponding unsafe accessor functions. -The result of these @code{-first} and @code{-next}] functions should be given -to the corresponding unsafe accessor functions. +If the @racket[pos] provided to an accessor function for a mutable +@racket[hash] was formerly a @tech{valid hash index} but is no longer +a @tech{valid hash index} for @racket[hash], and if +@racket[bad-index-v] is not provided, then the +@exnraise[exn:fail:contract]. No behavior is specified for a +@racket[pos] that was never a @tech{valid hash index} for +@racket[hash]. Note that @racket[bad-index-v] argument is technically +not useful for the @code{unsafe-immutable-hash-iterate-} functions, +since an index cannot become invalid for an immutable @racket[hash]. -If the key or value at the position returned by the @code{-first} and -@code{-next} ops becomes invalid (e.g., because of mutation or garbage -collection), then the operations @exnraise[exn:fail:contract]. - -@history[#:added "6.4.0.6"] -} +@history[#:added "6.4.0.6" + #:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} @; ------------------------------------------------------------------------ diff --git a/pkgs/racket-test-core/tests/racket/basic.rktl b/pkgs/racket-test-core/tests/racket/basic.rktl index d5bd2d6efb..5dc3955473 100644 --- a/pkgs/racket-test-core/tests/racket/basic.rktl +++ b/pkgs/racket-test-core/tests/racket/basic.rktl @@ -2597,18 +2597,45 @@ (test #f hash-iterate-first (make-hasheq)) (test #f hash-iterate-first (make-weak-hasheq)) -(err/rt-test (hash-iterate-next (make-hasheq) 0)) -(err/rt-test (hash-iterate-next (make-weak-hasheq) 0)) +(test #f hash-iterate-next (make-hasheq) 0) +(test #f hash-iterate-next (make-weak-hasheq) 0) -(let ([check-all-bad - (lambda (op) - (err/rt-test (op #f 0)) - (err/rt-test (op (make-hasheq) -1)) - (err/rt-test (op (make-hasheq) (- (expt 2 100)))) - (err/rt-test (op (make-hasheq) 1.0)))]) - (check-all-bad hash-iterate-next) - (check-all-bad hash-iterate-key) - (check-all-bad hash-iterate-value)) +(let ([hts (list (make-hash) + (make-hasheq) + (make-hasheqv) + (make-weak-hash) + (make-weak-hasheq) + (make-weak-hasheqv) + (hash) + (hasheq) + (hasheqv))]) + (let* ([check-all-bad + (lambda (op) + (err/rt-test (op #f 0)) + (err/rt-test (op (make-hasheq) -1)) + (err/rt-test (op (make-hasheq) (- (expt 2 100)))) + (err/rt-test (op (make-hasheq) 1.0)))] + [check-all-bad-v + (lambda (op) + (check-all-bad op) + (for ([ht (in-list hts)]) + (test 'nope op ht 17 'nope)))] + [check-all-bad-pair + (lambda (op) + (check-all-bad op) + (for ([ht (in-list hts)]) + (test '(nope . nope) op ht 17 'nope)))] + [check-all-bad-values + (lambda (op) + (check-all-bad op) + (for ([ht (in-list hts)]) + (test-values '(nope nope) + (lambda () (op ht 17 'nope)))))]) + (check-all-bad hash-iterate-next) + (check-all-bad-v hash-iterate-key) + (check-all-bad-v hash-iterate-value) + (check-all-bad-pair hash-iterate-pair) + (check-all-bad-values hash-iterate-key+value))) (test (list 1 2 3) sort (hash-keys #hasheq((1 . a) (2 . b) (3 . c))) <) (test (list 'a 'b 'c) diff --git a/pkgs/racket-test-core/tests/racket/for.rktl b/pkgs/racket-test-core/tests/racket/for.rktl index a82d8ff6f4..0c21a97839 100644 --- a/pkgs/racket-test-core/tests/racket/for.rktl +++ b/pkgs/racket-test-core/tests/racket/for.rktl @@ -645,6 +645,15 @@ exn:fail:contract:arity? #rx"expected number of values not received") +(err/rt-test (for ([x (in-hash 1 2 3)]) x) + exn:fail:contract:arity?) +(err/rt-test (for ([x (in-hash-keys 1 2 3)]) x) + exn:fail:contract:arity?) +(err/rt-test (for ([x (in-hash-values 1 2 3)]) x) + exn:fail:contract:arity?) +(err/rt-test (for ([x (in-hash-pairs 1 2 3)]) x) + exn:fail:contract:arity?) + (err/rt-test (for/sum ([x (in-vector (vector 1 2) 2 -1 -1)]) x) ; pr 15227 exn:fail:contract? #rx"starting index is out of range") diff --git a/pkgs/racket-test-core/tests/racket/hash.rktl b/pkgs/racket-test-core/tests/racket/hash.rktl index d9a3679545..bd5c9c314e 100644 --- a/pkgs/racket-test-core/tests/racket/hash.rktl +++ b/pkgs/racket-test-core/tests/racket/hash.rktl @@ -5,6 +5,8 @@ (require racket/hash) +;; ---------------------------------------- + (test #hash([4 . four] [3 . three] [1 . one] [2 . two]) hash-union #hash([1 . one] [2 . two]) #hash([3 . three] [4 . four])) (test #hash([four . 4] [three . 3] [one . 1] [two . 2]) @@ -295,16 +297,16 @@ (test #t equal? (call-with-values (lambda () (hash-iterate-key+value ht i)) cons) '((1 2 3 4 5 6 7 8 9 10) . val)) - (test #t boolean? (hash-iterate-next ht i)) + (test #f hash-iterate-next ht i) ;; collect key, everything should error - (collect-garbage)(collect-garbage)(collect-garbage) + (collect-garbage) (test #t boolean? (hash-iterate-first ht)) (err/rt-test (hash-iterate-key ht i) exn:fail:contract? err-msg) (err/rt-test (hash-iterate-value ht i) exn:fail:contract? err-msg) (err/rt-test (hash-iterate-pair ht i) exn:fail:contract? err-msg) (err/rt-test (hash-iterate-key+value ht i) exn:fail:contract? err-msg) - (err/rt-test (hash-iterate-next ht i) exn:fail:contract? err-msg)) + (test #f hash-iterate-next ht i)) ;; Check that unsafe mutable hash table operations do not segfault ;; after getting valid index from unsafe-mutable-hash-iterate-first and -next. @@ -331,7 +333,7 @@ (err/rt-test (hash-iterate-value ht i) exn:fail:contract? err-msg) (err/rt-test (hash-iterate-pair ht i) exn:fail:contract? err-msg) (err/rt-test (hash-iterate-key+value ht i) exn:fail:contract? err-msg) - (err/rt-test (hash-iterate-next ht i) exn:fail:contract? err-msg)) + (test #f hash-iterate-next ht i)) (let () @@ -356,6 +358,61 @@ (err/rt-test (hash-iterate-value ht i) exn:fail:contract?) (err/rt-test (hash-iterate-pair ht i) exn:fail:contract?) (err/rt-test (hash-iterate-key+value ht i) exn:fail:contract?) - (err/rt-test (hash-iterate-next ht i) exn:fail:contract?))) + (test #f hash-iterate-next ht i))) + +;; ---------------------------------------- + +(define-syntax-rule (hash-remove-iterate-test make-hash (X ...) in-hash-X sel) + (let ([ht (make-hash)]) + (arity-test in-hash-X 1 2) + (test 'in-hash-X object-name in-hash-X) + (define keys (for/list ([k (in-range 10)]) + (gensym))) + (define (add-keys!) + (for ([k (in-list keys)] + [i (in-naturals)]) + (hash-set! ht k i))) + (add-keys!) + (test 5 '(remove-during-loop make-hash in-hash-X) + (for/sum ([(X ...) (in-hash-X ht #f)] + [i (in-naturals)]) + (when (= i 4) + (for ([k (in-list keys)]) + (hash-remove! ht k))) + (if (sel X ...) 1 0))) + (add-keys!) + (test 'ok '(remove-during-loop make-hash in-hash-X) + (for/fold ([v 'ok]) ([(X ...) (in-hash-X ht #f)] + [i (in-naturals)]) + (when (= i 4) + (set! keys #f) + (collect-garbage)) + v)))) + +(define-syntax-rule (hash-remove-iterate-test* [make-hash ...] (X ...) in-hash-X in-Y-hash-X sel) + (begin + (hash-remove-iterate-test make-hash (X ...) in-hash-X sel) ... + (hash-remove-iterate-test make-hash (X ...) in-Y-hash-X sel) ...)) + +(hash-remove-iterate-test* [make-hash make-hasheq make-hasheqv] + (k v) in-hash in-mutable-hash and) +(hash-remove-iterate-test* [make-hash make-hasheq make-hasheqv] + (k) in-hash-keys in-mutable-hash-keys values) +(hash-remove-iterate-test* [make-hash make-hasheq make-hasheqv] + (v) in-hash-values in-mutable-hash-values values) +(hash-remove-iterate-test* [make-hash make-hasheq make-hasheqv] + (p) in-hash-pairs in-mutable-hash-pairs car) + +(hash-remove-iterate-test* [make-weak-hash make-weak-hasheq make-weak-hasheqv] + (k v) in-hash in-weak-hash and) +(hash-remove-iterate-test* [make-weak-hash make-weak-hasheq make-weak-hasheqv] + (k) in-hash-keys in-weak-hash-keys values) +(hash-remove-iterate-test* [make-weak-hash make-weak-hasheq make-weak-hasheqv] + (v) in-hash-values in-weak-hash-values values) +(hash-remove-iterate-test* [make-weak-hash make-weak-hasheq make-weak-hasheqv] + (p) in-hash-pairs in-weak-hash-pairs car) + + +;; ---------------------------------------- (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/unsafe.rktl b/pkgs/racket-test-core/tests/racket/unsafe.rktl index a226280ec8..73e91f93dc 100644 --- a/pkgs/racket-test-core/tests/racket/unsafe.rktl +++ b/pkgs/racket-test-core/tests/racket/unsafe.rktl @@ -634,16 +634,15 @@ ;; collect key, everything should error (but not segfault) (collect-garbage)(collect-garbage)(collect-garbage) (test #t boolean? (unsafe-weak-hash-iterate-first ht)) - (err/rt-test - (unsafe-weak-hash-iterate-key ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-weak-hash-iterate-value ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-weak-hash-iterate-pair ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-weak-hash-iterate-key+value ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-weak-hash-iterate-next ht i) exn:fail:contract? err-msg)) + (err/rt-test (unsafe-weak-hash-iterate-key ht i) exn:fail:contract? err-msg) + (test 'gone unsafe-weak-hash-iterate-key ht i 'gone) + (err/rt-test (unsafe-weak-hash-iterate-value ht i) exn:fail:contract? err-msg) + (test 'gone unsafe-weak-hash-iterate-value ht i 'gone) + (err/rt-test (unsafe-weak-hash-iterate-pair ht i) exn:fail:contract? err-msg) + (test '(gone . gone) unsafe-weak-hash-iterate-pair ht i 'gone) + (err/rt-test (unsafe-weak-hash-iterate-key+value ht i) exn:fail:contract? err-msg) + (test-values '(gone gone) (lambda () (unsafe-weak-hash-iterate-key+value ht i 'gone))) + (test #f unsafe-weak-hash-iterate-next ht i)) ;; Check that unsafe mutable hash table operations do not segfault ;; after getting valid index from unsafe-mutable-hash-iterate-first and -next. @@ -661,21 +660,20 @@ (call-with-values (lambda () (unsafe-mutable-hash-iterate-key+value ht i)) cons) '(a . b)) - (test #t boolean? (unsafe-mutable-hash-iterate-next ht i)) + (test #f unsafe-mutable-hash-iterate-next ht i) ;; remove element, everything should error (but not segfault) (hash-remove! ht 'a) (test #t boolean? (unsafe-mutable-hash-iterate-first ht)) - (err/rt-test - (unsafe-mutable-hash-iterate-key ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-mutable-hash-iterate-value ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-mutable-hash-iterate-pair ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-mutable-hash-iterate-key+value ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-mutable-hash-iterate-next ht i) exn:fail:contract? err-msg)) + (err/rt-test (unsafe-mutable-hash-iterate-key ht i) exn:fail:contract? err-msg) + (test 'gone unsafe-mutable-hash-iterate-key ht i 'gone) + (err/rt-test (unsafe-mutable-hash-iterate-value ht i) exn:fail:contract? err-msg) + (test 'gone unsafe-mutable-hash-iterate-value ht i 'gone) + (err/rt-test (unsafe-mutable-hash-iterate-pair ht i) exn:fail:contract? err-msg) + (test '(gone . gone) unsafe-mutable-hash-iterate-pair ht i 'gone) + (err/rt-test (unsafe-mutable-hash-iterate-key+value ht i) exn:fail:contract? err-msg) + (test-values '(gone gone) (lambda () (unsafe-mutable-hash-iterate-key+value ht i 'gone))) + (test #f unsafe-mutable-hash-iterate-next ht i)) (let () (define ht (make-weak-hash '((a . b)))) @@ -695,16 +693,15 @@ ;; remove element, everything should error (but not segfault) (hash-remove! ht 'a) (test #t boolean? (unsafe-weak-hash-iterate-first ht)) - (err/rt-test - (unsafe-weak-hash-iterate-key ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-weak-hash-iterate-value ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-weak-hash-iterate-pair ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-weak-hash-iterate-key+value ht i) exn:fail:contract? err-msg) - (err/rt-test - (unsafe-weak-hash-iterate-next ht i) exn:fail:contract? err-msg))) + (err/rt-test (unsafe-weak-hash-iterate-key ht i) exn:fail:contract? err-msg) + (test 'gone unsafe-weak-hash-iterate-key ht i 'gone) + (err/rt-test (unsafe-weak-hash-iterate-value ht i) exn:fail:contract? err-msg) + (test 'gone unsafe-weak-hash-iterate-value ht i 'gone) + (err/rt-test (unsafe-weak-hash-iterate-pair ht i) exn:fail:contract? err-msg) + (test '(gone . gone) unsafe-weak-hash-iterate-pair ht i 'gone) + (err/rt-test (unsafe-weak-hash-iterate-key+value ht i) exn:fail:contract? err-msg) + (test-values '(gone gone) (lambda () (unsafe-weak-hash-iterate-key+value ht i 'gone))) + (test #f unsafe-weak-hash-iterate-next ht i))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt index b9c376ca27..72c0400a2a 100644 --- a/racket/collects/racket/private/for.rkt +++ b/racket/collects/racket/private/for.rkt @@ -734,14 +734,24 @@ ;; hash sequences ;; assembles hash iterator functions to give to make-do-sequence - (define (:hash-gen ht -get -first -next) - (values (lambda (pos) (-get ht pos)) - #f - (lambda (pos) (-next ht pos)) - (-first ht) - (lambda (pos) pos) ; #f position means stop - #f - #f)) + (define :hash-gen + (case-lambda + [(ht -get -first -next) + (values (lambda (pos) (-get ht pos)) + #f + (lambda (pos) (-next ht pos)) + (-first ht) + (lambda (pos) pos) ; #f position means stop + #f + #f)] + [(ht -get -first -next bad-v) + (values (lambda (pos) (-get ht pos bad-v)) + #f + (lambda (pos) (-next ht pos)) + (-first ht) + (lambda (pos) pos) ; #f position means stop + #f + #f)])) (define (mutable? ht) (not (immutable? ht))) (define (not-weak? ht) (not (hash-weak? ht))) @@ -796,34 +806,47 @@ (define (CHECK-SEQ ht) (unless (HASHTYPE? ht) (raise-argument-error 'IN-HASH-SEQ ERR-STR ht)))) - (define (AS-EXPR-SEQ ht) - (CHECK-SEQ ht) - (make-do-sequence (lambda () (:hash-gen ht -VAL -first -next)))) + (define AS-EXPR-SEQ + (let ([IN-HASH-SEQ + (case-lambda + [(ht) + (CHECK-SEQ ht) + (make-do-sequence (lambda () (:hash-gen ht -VAL -first -next)))] + [(ht bad-v) + (CHECK-SEQ ht) + (make-do-sequence (lambda () (:hash-gen ht -VAL -first -next bad-v)))])]) + IN-HASH-SEQ)) (define-sequence-syntax IN-HASH-SEQ (lambda () #'AS-EXPR-SEQ) (lambda (stx) - (syntax-case stx () - [[(V ...) (_ ht-expr)] - (for-clause-syntax-protect - #'[(V ...) - (:do-in - ;;outer bindings - ([(ht) ht-expr]) - ;; outer check - (unless-unsafe (CHECK-SEQ ht)) - ;; loop bindings - ([i (-first ht)]) - ;; pos check - i - ;; inner bindings - ([(V ...) (-VAL ht i)]) - ;; pre guard - #t - ;; post guard - #t - ;; loop args - ((-next ht i)))])] - [_ #f]))))))])) + (define (transform stx) + (syntax-case stx () + [[(V ...) (_ ht-expr . extra-args)] + (for-clause-syntax-protect + #'[(V ...) + (:do-in + ;;outer bindings + ([(ht) ht-expr]) + ;; outer check + (unless-unsafe (CHECK-SEQ ht)) + ;; loop bindings + ([i (-first ht)]) + ;; pos check + i + ;; inner bindings + ([(V ...) (-VAL ht i . extra-args)]) + ;; pre guard + #t + ;; post guard + #t + ;; loop args + ((-next ht i)))])])) + (syntax-case stx () + [[(V ...) (_ ht-expr)] + (transform stx)] + [[(V ...) (_ ht-expr bad-index-expr)] + (transform stx)] + [_ #f]))))))])) ;; 2) define sequence syntaxes (using just-defined definer): (IN-HASH-DEFINER hash-type: hash) (IN-HASH-DEFINER hash-type: mutable-hash checks: mutable? not-weak?) diff --git a/racket/src/cs/rumble/hash.ss b/racket/src/cs/rumble/hash.ss index 33b1418d3b..3e07544a11 100644 --- a/racket/src/cs/rumble/hash.ss +++ b/racket/src/cs/rumble/hash.ss @@ -1,9 +1,17 @@ +;; Mutable and weak-equal hash tables need a lock +;; and an iteration vector +(define-record locked-iterable-hash (lock + cells ; vector of cells for iteration + retry?)) ; is `cells` maybe incomplete? + ;; To support iteration and locking, we wrap Chez's mutable hash -;; tables in a `mutable-hash` record: -(define-record mutable-hash (ht ; Chez Scheme hashtable - cells ; vector of keys for iteration - lock)) -(define (create-mutable-hash ht kind) (make-mutable-hash ht #f (make-lock kind))) +;; tables in a `mutable-hash` record +(define-record mutable-hash locked-iterable-hash + (ht)) ; Chez Scheme hashtable +(define (create-mutable-hash ht kind) (make-mutable-hash (make-lock kind) #f #f ht)) + +(define (mutable-hash-lock ht) (locked-iterable-hash-lock ht)) +(define (mutable-hash-cells ht) (locked-iterable-hash-cells ht)) (define (authentic-hash? v) (or (intmap? v) (mutable-hash? v) (weak-equal-hash? v))) (define (hash? v) (or (authentic-hash? v) @@ -74,10 +82,8 @@ (cond [(mutable-hash? ht) (lock-acquire (mutable-hash-lock ht)) - (when (and (mutable-hash-cells ht) - (not (hashtable-contains? (mutable-hash-ht ht) k))) - (set-mutable-hash-cells! ht #f)) (hashtable-set! (mutable-hash-ht ht) k v) + (set-locked-iterable-hash-retry?! ht #t) (lock-release (mutable-hash-lock ht))] [(weak-equal-hash? ht) (weak-hash-set! ht k v)] [(and (impersonator? ht) @@ -96,9 +102,10 @@ (hashtable-contains? (mutable-hash-ht ht) k)) (let ([cell (hashtable-cell (mutable-hash-ht ht) k #f)]) (hashtable-delete! (mutable-hash-ht ht) k) - ;; Clear cell, because it may be in `(mutable-hash-cells ht)` + ;; Clear cell, because it may be in `(locked-iterable-hash-cells ht)` (set-car! cell #!bwp) - (set-cdr! cell #!bwp))] + (set-cdr! cell #!bwp) + (set-locked-iterable-hash-retry?! ht #t))] [else (hashtable-delete! (mutable-hash-ht ht) k)]) (lock-release (mutable-hash-lock ht))] @@ -114,7 +121,7 @@ (cond [(mutable-hash? ht) (lock-acquire (mutable-hash-lock ht)) - (set-mutable-hash-cells! ht #f) + (set-locked-iterable-hash-cells! ht #f) (hashtable-clear! (mutable-hash-ht ht)) (lock-release (mutable-hash-lock ht))] [(weak-equal-hash? ht) (weak-hash-clear! ht)] @@ -419,23 +426,35 @@ ;; and then get more as needed, so that an N-step traversals ;; is O(N) even if the hash table has more than O(N) entries. (define (prepare-iterate! ht i) - (lock-acquire (mutable-hash-lock ht)) - (let ([vec (mutable-hash-cells ht)]) + (lock-acquire (locked-iterable-hash-lock ht)) + (let ([vec (locked-iterable-hash-cells ht)]) (cond [(and vec - (fx> (#%vector-length vec) (or i 0))) - (lock-release (mutable-hash-lock ht)) + (let ([len (#%vector-length vec)] + [want-len (or i 0)]) + (or (> len want-len) + (and (fx= len want-len) + (not (locked-iterable-hash-retry? ht)))))) + (lock-release (locked-iterable-hash-lock ht)) vec] [else - (let ([vec (cells-merge vec - (hashtable-cells - (mutable-hash-ht ht) - (if vec - (fx* 2 (#%vector-length vec)) - 32)))]) - (set-mutable-hash-cells! ht vec) - (lock-release (mutable-hash-lock ht)) - vec)]))) + (let ([new-vec (get-locked-iterable-hash-cells + ht + (fxmax (if vec + (fx* 2 (#%vector-length vec)) + 0) + 32))]) + (when (= (#%vector-length new-vec) (hash-count ht)) + (set-locked-iterable-hash-retry?! ht #f)) + (let ([vec (cells-merge vec new-vec)]) + (set-locked-iterable-hash-cells! ht vec) + (lock-release (locked-iterable-hash-lock ht)) + vec))]))) + +(define (get-locked-iterable-hash-cells ht n) + (cond + [(mutable-hash? ht) (hashtable-cells (mutable-hash-ht ht) n)] + [else (weak-equal-hash-cells ht n)])) ;; Separate calls to `hashtable-cells` may return the ;; cells in a different order, so we have to merge the @@ -481,9 +500,8 @@ (cond [(intmap? ht) (intmap-iterate-first ht)] - [(mutable-hash? ht) - (mutable-hash-iterate-next ht #f)] - [(weak-equal-hash? ht) (weak-hash-iterate-first ht)] + [(locked-iterable-hash? ht) + (locked-iterable-hash-iterate-next ht #f)] [(and (impersonator? ht) (authentic-hash? (impersonator-val ht))) ;; `hash-iterate-first` must not hash any keys: @@ -498,25 +516,24 @@ [(intmap? ht) (check-i 'hash-iterate-next i) (intmap-iterate-next ht i)] - [(mutable-hash? ht) + [(locked-iterable-hash? ht) (check-i 'hash-iterate-next i) - (mutable-hash-iterate-next ht i)] - [(weak-equal-hash? ht) - (check-i 'hash-iterate-next i) - (weak-hash-iterate-next ht i)] + (locked-iterable-hash-iterate-next ht i)] [(and (impersonator? ht) (authentic-hash? (impersonator-val ht))) ;; `hash-iterate-next` must not hash any keys: (hash-iterate-next (impersonator-val ht) i)] [else (raise-argument-error who "hash?" ht)])) -(define (mutable-hash-iterate-next ht init-i) +(define (locked-iterable-hash-iterate-next ht init-i) (let loop ([i (or init-i -1)]) (let* ([i (add1 i)] [vec (prepare-iterate! ht i)] ; vec expected to have >= `i` elements - [len (vector-length vec)]) + [len (#%vector-length vec)]) (cond [(> i len) + #f + #; (raise-arguments-error 'hash-iterate-next "no element at index" "index" init-i "within length" len @@ -524,7 +541,7 @@ [(= i len) #f] [else - (let* ([p (vector-ref vec i)] + (let* ([p (#%vector-ref vec i)] [key (car p)]) (cond [(bwp-object? key) @@ -534,19 +551,21 @@ (define (do-hash-iterate-key+value who ht i intmap-iterate-key+value - weak-hash-iterate-key+value - key? value? pair?) + key? value? pair? + bad-index-v) (cond [(intmap? ht) (check-i who i) (call-with-values (lambda () (intmap-iterate-key+value ht i none)) (case-lambda [(v) (if (eq? v none) - (raise-arguments-error who "no element at index" - "index" i) + (if (eq? bad-index-v none) + (raise-arguments-error who "no element at index" + "index" i) + (bad-index-result key? value? pair? bad-index-v)) v)] [(k v) (values k v)]))] - [(mutable-hash? ht) + [(locked-iterable-hash? ht) (check-i who i) (let* ([vec (prepare-iterate! ht i)] [len (#%vector-length vec)] @@ -558,8 +577,10 @@ none (cdr p))]) (if (eq? v none) - (raise-arguments-error who "no element at index" - "index" i) + (if (eq? bad-index-v none) + (raise-arguments-error who "no element at index" + "index" i) + (bad-index-result key? value? pair? bad-index-v)) (cond [(and key? value?) (if pair? @@ -567,37 +588,46 @@ (values key v))] [key? key] [else v])))] - [(weak-equal-hash? ht) - (check-i who i) - (weak-hash-iterate-key+value ht i)] [(and (impersonator? ht) (authentic-hash? (impersonator-val ht))) - (impersonate-hash-iterate-key+value who ht i key? value? pair?)] + (impersonate-hash-iterate-key+value who ht i key? value? pair? bad-index-v)] [else (raise-argument-error who "hash?" ht)])) -(define (hash-iterate-key ht i) - (do-hash-iterate-key+value 'hash-iterate-key ht i - intmap-iterate-key - weak-hash-iterate-key - #t #f #f)) +(define hash-iterate-key + (case-lambda + [(ht i) (hash-iterate-key ht i none)] + [(ht i bad-index-v) + (do-hash-iterate-key+value 'hash-iterate-key ht i + intmap-iterate-key + #t #f #f + bad-index-v)])) -(define (hash-iterate-value ht i) - (do-hash-iterate-key+value 'hash-iterate-value ht i - intmap-iterate-value - weak-hash-iterate-value - #f #t #f)) +(define hash-iterate-value + (case-lambda + [(ht i) (hash-iterate-value ht i none)] + [(ht i bad-index-v) + (do-hash-iterate-key+value 'hash-iterate-value ht i + intmap-iterate-value + #f #t #f + bad-index-v)])) -(define (hash-iterate-key+value ht i) - (do-hash-iterate-key+value 'hash-iterate-key+value ht i - intmap-iterate-key+value - weak-hash-iterate-key+value - #t #t #f)) +(define hash-iterate-key+value + (case-lambda + [(ht i) (hash-iterate-key+value ht i none)] + [(ht i bad-index-v) + (do-hash-iterate-key+value 'hash-iterate-key+value ht i + intmap-iterate-key+value + #t #t #f + bad-index-v)])) -(define (hash-iterate-pair ht i) - (do-hash-iterate-key+value 'hash-iterate-pair ht i - intmap-iterate-pair - weak-hash-iterate-pair - #t #t #t)) +(define hash-iterate-pair + (case-lambda + [(ht i) (hash-iterate-pair ht i none)] + [(ht i bad-index-v) + (do-hash-iterate-key+value 'hash-iterate-pair ht i + intmap-iterate-pair + #t #t #t + bad-index-v)])) (define (unsafe-immutable-hash-iterate-first ht) (if (impersonator? ht) @@ -616,20 +646,29 @@ (hash-iterate-key ht i) (unsafe-intmap-iterate-key ht i))) -(define (unsafe-immutable-hash-iterate-value ht i) - (if (iterator-for-impersonator? i) - (hash-iterate-value ht i) - (unsafe-intmap-iterate-value ht i))) +(define unsafe-immutable-hash-iterate-value + (case-lambda + [(ht i) (unsafe-immutable-hash-iterate-value ht i none)] + [(ht i bad-index-v) + (if (iterator-for-impersonator? i) + (hash-iterate-value ht i bad-index-v) + (unsafe-intmap-iterate-value ht i))])) -(define (unsafe-immutable-hash-iterate-key+value ht i) - (if (iterator-for-impersonator? i) - (hash-iterate-key+value ht i) - (unsafe-intmap-iterate-key+value ht i))) +(define unsafe-immutable-hash-iterate-key+value + (case-lambda + [(ht i) (unsafe-immutable-hash-iterate-key+value ht i none)] + [(ht i bad-index-v) + (if (iterator-for-impersonator? i) + (hash-iterate-key+value ht i bad-index-v) + (unsafe-intmap-iterate-key+value ht i))])) -(define (unsafe-immutable-hash-iterate-pair ht i) - (if (iterator-for-impersonator? i) - (hash-iterate-pair ht i) - (unsafe-intmap-iterate-pair ht i))) +(define unsafe-immutable-hash-iterate-pair + (case-lambda + [(ht i) (unsafe-immutable-hash-iterate-pair ht i none)] + [(ht i bad-index-v) + (if (iterator-for-impersonator? i) + (hash-iterate-pair ht i bad-index-v) + (unsafe-intmap-iterate-pair ht i))])) (define unsafe-mutable-hash-iterate-first hash-iterate-first) (define unsafe-mutable-hash-iterate-next hash-iterate-next) @@ -650,26 +689,28 @@ ;; Chez Scheme doesn't provide weak hash table with `equal?` comparisons, ;; so build our own -(define-record weak-equal-hash (lock - keys-ht ; integer[equal hash code] -> weak list of keys - vals-ht ; weak, eq?-based hash table: key -> value - count ; number of items in the table (= sum of list lengths) - prune-at ; count at which we should try to prune empty weak boxes - keys)) ; for iteration: a vector that is enlarged on demand +(define-record weak-equal-hash locked-iterable-hash + (keys-ht ; integer[equal hash code] -> weak list of keys + vals-ht ; weak, eq?-based hash table: key -> value + count ; number of items in the table (= sum of list lengths) + prune-at)) ; count at which we should try to prune empty weak boxes + +(define (weak-equal-hash-lock t) (locked-iterable-hash-lock t)) (define make-weak-hash (case-lambda - [() (make-weak-equal-hash (make-lock 'equal?) (hasheqv) (make-weak-eq-hashtable) 0 128 #f)] + [() (make-weak-equal-hash (make-lock 'equal?) #f #f (hasheqv) (make-weak-eq-hashtable) 0 128)] [(alist) (fill-hash! 'make-weak-hash (make-weak-hash) alist)])) (define (weak-hash-copy ht) (lock-acquire (weak-equal-hash-lock ht)) (let ([new-ht (make-weak-equal-hash (weak-equal-hash-lock ht) + #f + #t (weak-equal-hash-keys-ht ht) (hashtable-copy (weak-equal-hash-vals-ht ht) #t) (weak-equal-hash-count ht) - (weak-equal-hash-prune-at ht) - #f)]) + (weak-equal-hash-prune-at ht))]) (lock-release (weak-equal-hash-lock ht)) new-ht)) @@ -708,12 +749,12 @@ (define (weak-hash-set! t k v) (let ([code (key-equal-hash-code k)]) (lock-acquire (weak-equal-hash-lock t)) + (set-locked-iterable-hash-retry?! t #t) (let ([keys (intmap-ref (weak-equal-hash-keys-ht t) code '())]) (let loop ([keys keys]) (cond [(null? keys) ;; Not in the table: - (set-weak-equal-hash-keys! t #f) (when (= (weak-equal-hash-count t) (weak-equal-hash-prune-at t)) (prune-table! t)) (let* ([ht (weak-equal-hash-keys-ht t)]) @@ -734,34 +775,40 @@ (let ([code (key-equal-hash-code k)]) (lock-acquire (weak-equal-hash-lock t)) (let* ([keys (intmap-ref (weak-equal-hash-keys-ht t) code '())] - [keep-bwp? - ;; If we have a `keys` array, then preserve the shape of - ;; each key lst in `(weak-equal-hash-keys-ht t)` so that - ;; the `keys` array remains consistent with that shape - (and (weak-equal-hash-keys t) #t)] [new-keys (let loop ([keys keys]) (cond [(null? keys) ;; Not in the table #f] - [(key-equal? (car keys) k) - (hashtable-delete! (weak-equal-hash-vals-ht t) (car keys)) - (if keep-bwp? - (cons #!bwp keys) - (cdr keys))] + [(let ([a (car keys)]) + (and (key-equal? a k) + a)) + => (lambda (a) + (let ([ht (weak-equal-hash-vals-ht t)]) + (cond + [(locked-iterable-hash-cells t) + ;; Clear cell, because it may be in `(locked-iterable-hash-cells ht)` + (let ([cell (hashtable-cell ht a #f)]) + (hashtable-delete! ht a) + (set-car! cell #!bwp) + (set-cdr! cell #!bwp))] + [else + (hashtable-delete! ht a)])) + (cdr keys))] [else (let ([new-keys (loop (cdr keys))]) (and new-keys - (if (and (not keep-bwp?) - (bwp-object? (car keys))) - new-keys - (weak/fl-cons (car keys) new-keys))))]))]) + (let ([a (car keys)]) + (if (bwp-object? a) + new-keys + (weak/fl-cons a new-keys)))))]))]) (when new-keys (set-weak-equal-hash-keys-ht! t (if (null? new-keys) (intmap-remove (weak-equal-hash-keys-ht t) code) (intmap-set (weak-equal-hash-keys-ht t) code new-keys)))) + (set-locked-iterable-hash-retry?! t #t) (lock-release (weak-equal-hash-lock t))))) (define (weak-hash-clear! t) @@ -770,7 +817,7 @@ (hashtable-clear! (weak-equal-hash-vals-ht t)) (set-weak-equal-hash-count! t 0) (set-weak-equal-hash-prune-at! t 128) - (set-weak-equal-hash-keys! t #f) + (set-locked-iterable-hash-cells! t #f) (lock-release (weak-equal-hash-lock t))) (define (weak-hash-for-each t proc) @@ -798,122 +845,40 @@ (define (weak-hash-count t) (hashtable-size (weak-equal-hash-vals-ht t))) -(define (prepare-weak-iterate! ht i) - (let* ([current-vec (weak-equal-hash-keys ht)]) - (or (and current-vec - (> (vector-length current-vec) (or i 1)) - current-vec) - (let* ([len (max 16 - (* 2 (if current-vec - (vector-length current-vec) - 0)) - (if i (* 2 i) 0))] - [vec (make-vector len #f)] - [pos (box 0)]) - (call/cc - (lambda (esc) - (intmap-for-each - (weak-equal-hash-keys-ht ht) - (lambda (k l) - (let loop ([l l]) - (cond - [(null? l) (void)] - [else - ;; Add `l` even if the key is #!bwp, - ;; so that iteration works right if a key - ;; is removed - (vector-set! vec (unbox pos) l) - (set-box! pos (add1 (unbox pos))) - (if (= (unbox pos) len) - ;; That's enough keys - (esc (void)) - (loop (cdr l)))])))))) - (set-weak-equal-hash-keys! ht vec) - vec)))) - -(define (weak-hash-iterate-first ht) - (weak-hash-iterate-next ht #f)) - -(define (weak-hash-iterate-next ht init-i) - (lock-acquire (weak-equal-hash-lock ht)) - (let retry ([i (and init-i (add1 init-i))]) - (let* ([vec (prepare-weak-iterate! ht i)] - [len (vector-length vec)]) - (let loop ([i (or i 0)]) - (cond - [(= i len) - ;; expand set of prepared keys - (retry i)] - [(> i len) - (lock-release (weak-equal-hash-lock ht)) - (raise-arguments-error 'hash-iterate-next "no element at weak index" - "index" init-i)] - [else - (let ([p (vector-ref vec i)]) +(define (weak-equal-hash-cells ht len) + (let ([vals-ht (weak-equal-hash-vals-ht ht)] + [vec (make-vector len #f)] + [pos (box 0)]) + (call/cc + (lambda (esc) + (intmap-for-each + (weak-equal-hash-keys-ht ht) + (lambda (k l) + (let loop ([l l]) (cond - [(not p) - ;; no more keys available - (lock-release (weak-equal-hash-lock ht)) - #f] - [(bwp-object? (car p)) (loop (add1 i))] - [(not (hashtable-contains? (weak-equal-hash-vals-ht ht) (car p))) - ;; key was removed from table after `keys` array was formed - (loop (add1 i))] + [(null? l) (void)] [else - (lock-release (weak-equal-hash-lock ht)) - i]))]))))) - -(define (do-weak-hash-iterate-key who ht i release-lock?) - (lock-acquire (weak-equal-hash-lock ht)) - (let* ([vec (weak-equal-hash-keys ht)] - [p (and vec - (< i (vector-length vec)) - (vector-ref vec i))] - [k (if p - (car p) - #!bwp)]) - (when release-lock? - (lock-release (weak-equal-hash-lock ht))) + (let ([key (car l)]) + (cond + [(eq? #!bwp key) (loop (cdr l))] + [else + (#%vector-set! vec (unbox pos) (hashtable-cell vals-ht key #f)) + (set-box! pos (add1 (unbox pos))) + (if (= (unbox pos) len) + ;; That's enough keys + (esc (void)) + (loop (cdr l)))]))])))))) + ;; Resize `vec` if we got fewer than `len` keys (cond - [(bwp-object? k) - (raise-arguments-error who "no element at index" - "index" i)] - [else k]))) - -(define (weak-hash-iterate-key ht i) - (do-weak-hash-iterate-key 'hash-iterate-key ht i #t)) - -(define (weak-hash-iterate-value ht i) - (let* ([key (do-weak-hash-iterate-key 'hash-iterate-value ht i #f)] - [val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) - (lock-release (weak-equal-hash-lock ht)) - (if (eq? val none) - (raise-arguments-error - 'weak-hash-iterate-value "no element at index" - "index" i) - val))) - -(define (weak-hash-iterate-key+value ht i) - (let ([key (do-weak-hash-iterate-key 'hash-iterate-key+value ht i #f)]) - (values key - (let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) - (lock-release (weak-equal-hash-lock ht)) - (if (eq? val none) - (raise-arguments-error - 'weak-hash-iterate-key+value "no element at index" - "index" i) - val))))) - -(define (weak-hash-iterate-pair ht i) - (let ([key (do-weak-hash-iterate-key 'hash-iterate-pair ht i #f)]) - (cons key - (let ([val (hashtable-ref (weak-equal-hash-vals-ht ht) key none)]) - (lock-release (weak-equal-hash-lock ht)) - (if (eq? val none) - (raise-arguments-error - 'weak-hash-iterate-paur "no element at index" - "index" i) - val))))) + [(< (unbox pos) len) + (let* ([len (unbox pos)] + [compact-vec (make-vector len)]) + (let loop ([i 0]) + (unless (fx= i len) + (#%vector-set! compact-vec i (#%vector-ref vec i)) + (loop (fx+ i 1)))) + compact-vec)] + [else vec]))) ;; Remove empty weak boxes from a table. Count the number ;; of remaining entries, and remember to prune again when @@ -1184,9 +1149,10 @@ (loop (hash-iterate-next ht i)))] [else new-ht])))) -(define (impersonate-hash-iterate-key+value who ht i key? value? pair?) - (let ([key (impersonate-hash-iterate-key who ht i)]) +(define (impersonate-hash-iterate-key+value who ht i key? value? pair? bad-index-v) + (let ([key (impersonate-hash-iterate-key who ht i (if (eq? bad-index-v none) none none2))]) (cond + [(eq? key none2) (bad-index-result key? value? pair? bad-index-v)] [(not value?) key] [else (let ([val (hash-ref ht key none)]) @@ -1201,7 +1167,7 @@ [key? (values key val)] [else val]))]))) -(define (impersonate-hash-iterate-key who ht i) +(define (impersonate-hash-iterate-key who ht i bad-index-v) ;; We don't have to set up `get-k`, because `hash-iterate-key` ;; is prohibited from hashing any keys (let loop ([ht ht]) @@ -1224,5 +1190,11 @@ ;; The same as `hash-iterate-key`, but with the correct `who`: (do-hash-iterate-key+value who ht i intmap-iterate-key - weak-hash-iterate-key - #t #f #f)]))) + #t #f #f + bad-index-v)]))) + +(define (bad-index-result key? value? pair? bad-index-v) + (cond + [pair? (cons bad-index-v bad-index-v)] + [(and value? key?) (values bad-index-v bad-index-v)] + [else bad-index-v])) diff --git a/racket/src/io/print/graph.rkt b/racket/src/io/print/graph.rkt index 56ddec3316..6d9f4dd161 100644 --- a/racket/src/io/print/graph.rkt +++ b/racket/src/io/print/graph.rkt @@ -43,9 +43,12 @@ (not (hash-weak? v)) (config-get config print-hash-table)) (and (not print-graph?) - (for/fold ([fuel (sub1 fuel)]) ([(k v) (in-hash v)] + ;; Using `(in-hash-keys v #f)` and `(hash-ref v k #f)` + ;; defends against misbehaving hash tables + (for/fold ([fuel (sub1 fuel)]) ([k (in-hash-keys v #f)] #:break (not fuel)) - (quick-no-graph? v (quick-no-graph? k fuel))))] + (define val (hash-ref v k #f)) + (quick-no-graph? val (quick-no-graph? k fuel))))] [(mpair? v) (and (not print-graph?) (not (eq? mode PRINT-MODE/UNQUOTED)) @@ -149,9 +152,10 @@ (config-get config print-hash-table)) (checking! v) (define unquoted? - (for/fold ([unquoted? #f]) ([(k v) (in-hash v)]) + (for/fold ([unquoted? #f]) ([k (in-hash-keys v)]) + (define val (hash-ref v k #f)) (define k-unquoted? (build-graph k mode)) - (or (build-graph v mode) + (or (build-graph val mode) k-unquoted? unquoted?))) (done! v unquoted?)] diff --git a/racket/src/racket/src/list.c b/racket/src/racket/src/list.c index f183c9bf4d..4355e3c250 100644 --- a/racket/src/racket/src/list.c +++ b/racket/src/racket/src/list.c @@ -696,22 +696,22 @@ scheme_init_list (Scheme_Startup_Env *env) scheme_addto_prim_instance("hash-iterate-value", scheme_make_noncm_prim(scheme_hash_table_iterate_value, "hash-iterate-value", - 2, 2), + 2, 3), env); scheme_addto_prim_instance("hash-iterate-key", scheme_make_noncm_prim(scheme_hash_table_iterate_key, "hash-iterate-key", - 2, 2), + 2, 3), env); scheme_addto_prim_instance("hash-iterate-pair", scheme_make_immed_prim(scheme_hash_table_iterate_pair, "hash-iterate-pair", - 2, 2), + 2, 3), env); scheme_addto_prim_instance("hash-iterate-key+value", scheme_make_prim_w_arity2(scheme_hash_table_iterate_key_value, - "hash-iterate-key+value", - 2, 2, 2, 2), + "hash-iterate-key+value", + 2, 3, 2, 2), env); scheme_addto_prim_instance("hash-keys-subset?", @@ -1000,21 +1000,21 @@ scheme_init_unsafe_hash (Scheme_Startup_Env *env) /* unsafe-hash-iterate-key ---------------------------------------- */ p = scheme_make_noncm_prim(unsafe_hash_table_iterate_key, - "unsafe-mutable-hash-iterate-key", 2, 2); + "unsafe-mutable-hash-iterate-key", 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-key", p, env); p = scheme_make_noncm_prim(unsafe_hash_tree_iterate_key, - "unsafe-immutable-hash-iterate-key", 2, 2); + "unsafe-immutable-hash-iterate-key", 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-key", p, env); p = scheme_make_noncm_prim(unsafe_bucket_table_iterate_key, - "unsafe-weak-hash-iterate-key", 2, 2); + "unsafe-weak-hash-iterate-key", 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); @@ -1022,21 +1022,21 @@ scheme_init_unsafe_hash (Scheme_Startup_Env *env) /* unsafe-hash-iterate-value ---------------------------------------- */ p = scheme_make_noncm_prim(unsafe_hash_table_iterate_value, - "unsafe-mutable-hash-iterate-value", 2, 2); + "unsafe-mutable-hash-iterate-value", 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); scheme_addto_prim_instance ("unsafe-mutable-hash-iterate-value", p, env); p = scheme_make_noncm_prim(unsafe_hash_tree_iterate_value, - "unsafe-immutable-hash-iterate-value", 2, 2); + "unsafe-immutable-hash-iterate-value", 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-value", p, env); p = scheme_make_noncm_prim(unsafe_bucket_table_iterate_value, - "unsafe-weak-hash-iterate-value", 2, 2); + "unsafe-weak-hash-iterate-value", 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); @@ -1045,7 +1045,7 @@ scheme_init_unsafe_hash (Scheme_Startup_Env *env) /* unsafe-hash-iterate-key+value ---------------------------------------- */ p = scheme_make_prim_w_arity2(unsafe_hash_table_iterate_key_value, "unsafe-mutable-hash-iterate-key+value", - 2, 2, 2, 2); + 2, 3, 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); @@ -1053,7 +1053,7 @@ scheme_init_unsafe_hash (Scheme_Startup_Env *env) p = scheme_make_prim_w_arity2(unsafe_hash_tree_iterate_key_value, "unsafe-immutable-hash-iterate-key+value", - 2, 2, 2, 2); + 2, 3, 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL | SCHEME_PRIM_IS_UNSAFE_NONALLOCATE); @@ -1061,7 +1061,7 @@ scheme_init_unsafe_hash (Scheme_Startup_Env *env) p = scheme_make_prim_w_arity2(unsafe_bucket_table_iterate_key_value, "unsafe-weak-hash-iterate-key+value", - 2, 2, 2, 2); + 2, 3, 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE | SCHEME_PRIM_IS_UNSAFE_OMITABLE); @@ -1070,7 +1070,7 @@ scheme_init_unsafe_hash (Scheme_Startup_Env *env) /* unsafe-hash-iterate-pair ---------------------------------------- */ p = scheme_make_immed_prim(unsafe_hash_table_iterate_pair, "unsafe-mutable-hash-iterate-pair", - 2, 2); + 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION | SCHEME_PRIM_IS_UNSAFE_OMITABLE); @@ -1078,14 +1078,14 @@ scheme_init_unsafe_hash (Scheme_Startup_Env *env) p = scheme_make_immed_prim(unsafe_hash_tree_iterate_pair, "unsafe-immutable-hash-iterate-pair", - 2, 2); + 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_addto_prim_instance ("unsafe-immutable-hash-iterate-pair", p, env); p = scheme_make_immed_prim(unsafe_bucket_table_iterate_pair, "unsafe-weak-hash-iterate-pair", - 2, 2); + 2, 3); SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION | SCHEME_PRIM_IS_UNSAFE_OMITABLE); @@ -3047,13 +3047,18 @@ Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[]) scheme_wrong_contract("hash-iterate-next", "exact-nonnegative-integer?", 1, argc, argv); - scheme_contract_error("hash-iterate-next", "no element at index", - "index", 1, argv[1], - NULL); - return NULL; + if (0) { + scheme_contract_error("hash-iterate-next", "no element at index", + "index", 1, argv[1], + NULL); + return NULL; + } else + return scheme_false; } -static int hash_table_index(const char *name, int argc, Scheme_Object *argv[], Scheme_Object **_k, Scheme_Object **_v) +static int hash_table_index(const char *name, int argc, Scheme_Object *argv[], + Scheme_Object **_k, Scheme_Object **_v, + Scheme_Object *bad_index_v) { Scheme_Object *p = argv[1], *obj = argv[0]; mzlonglong pos; @@ -3082,10 +3087,16 @@ static int hash_table_index(const char *name, int argc, Scheme_Object *argv[], S && (SCHEME_INT_VAL(p) >= 0)) || (SCHEME_BIGNUMP(p) && SCHEME_BIGPOS(p))) { - scheme_contract_error(name, "no element at index", - "index", 1, p, - NULL); - return 0; + if (bad_index_v) { + if (_k) *_k = bad_index_v; + if (_v) *_v = bad_index_v; + return 0; + } else { + scheme_contract_error(name, "no element at index", + "index", 1, p, + NULL); + return 0; + } } scheme_wrong_contract(name, "exact-nonnegative-integer?", 1, argc, argv); @@ -3096,21 +3107,19 @@ Scheme_Object *scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]) { const char *name = "hash-iterate-key"; Scheme_Object *key; - if (hash_table_index(name, argc, argv, &key, NULL)) { + if (hash_table_index(name, argc, argv, &key, NULL, ((argc > 2) ? argv[2] : NULL))) { Scheme_Object *obj = argv[0]; if (SCHEME_NP_CHAPERONEP(obj)) return chaperone_hash_key(name, obj, key); - else - return key; } - return NULL; + return key; } Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]) { const char *name = "hash-iterate-value"; Scheme_Object *key, *val; - if (hash_table_index(name, argc, argv, &key, &val)) { + if (hash_table_index(name, argc, argv, &key, &val, ((argc > 2) ? argv[2] : NULL))) { Scheme_Object *obj = argv[0]; if (SCHEME_NP_CHAPERONEP(obj)) { Scheme_Object *chap_key, *chap_val; @@ -3118,17 +3127,15 @@ Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]) chaperone_hash_key_value(name, obj, key, &chap_key, &chap_val, ischap); return chap_val; } - else - return val; } - return NULL; + return val; } Scheme_Object *scheme_hash_table_iterate_pair(int argc, Scheme_Object *argv[]) { const char *name = "hash-iterate-pair"; Scheme_Object *key, *val; - if (hash_table_index(name, argc, argv, &key, &val)) { + if (hash_table_index(name, argc, argv, &key, &val, ((argc > 2) ? argv[2] : NULL))) { Scheme_Object *obj = argv[0]; if (SCHEME_NP_CHAPERONEP(obj)) { Scheme_Object *chap_key, *chap_val; @@ -3136,29 +3143,24 @@ Scheme_Object *scheme_hash_table_iterate_pair(int argc, Scheme_Object *argv[]) chaperone_hash_key_value(name, obj, key, &chap_key, &chap_val, ischap); return scheme_make_pair(chap_key, chap_val); } - else - return scheme_make_pair(key, val); } - return NULL; + return scheme_make_pair(key, val); } Scheme_Object *scheme_hash_table_iterate_key_value(int argc, Scheme_Object *argv[]) { const char *name = "hash-iterate-key+value"; - Scheme_Object *key, *val; - if (hash_table_index(name, argc, argv, &key, &val)) { - Scheme_Object *res[2], *obj = argv[0]; + Scheme_Object *key, *val, *res[2]; + if (hash_table_index(name, argc, argv, &key, &val, ((argc > 2) ? argv[2] : NULL))) { + Scheme_Object *obj = argv[0]; if (SCHEME_NP_CHAPERONEP(obj)) { int ischap = SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj)); - chaperone_hash_key_value(name, obj, key, &res[0], &res[1], ischap); + chaperone_hash_key_value(name, obj, key, &key, &val, ischap); } - else { - res[0] = key; - res[1] = val; - } - return scheme_values(2, res); } - return NULL; + res[0] = key; + res[1] = val; + return scheme_values(2, res); } static Scheme_Object *hash_keys_subset_p_slow(int argc, Scheme_Object *argv[]) @@ -4242,12 +4244,14 @@ Scheme_Object *unsafe_hash_table_iterate_next(int argc, Scheme_Object *argv[]) if (res) return res; - else + else if (0) { scheme_contract_error("unsafe-mutable-hash-iterate-next", "no element at index", "index", 1, argv[1], NULL); - return NULL; + return NULL; + } else + return scheme_false; } Scheme_Object *unsafe_hash_table_iterate_key(int argc, Scheme_Object *argv[]) @@ -4265,8 +4269,13 @@ Scheme_Object *unsafe_hash_table_iterate_key(int argc, Scheme_Object *argv[]) if (scheme_hash_table_index((Scheme_Hash_Table *)obj, pos, &key, NULL)) return key; } - scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); - return NULL; + + if (argc > 2) + return argv[2]; + else { + scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); + return NULL; + } } static Scheme_Object *unsafe_hash_table_iterate_value_slow(int argc, Scheme_Object *argv[]) @@ -4283,11 +4292,16 @@ static Scheme_Object *unsafe_hash_table_iterate_value_slow(int argc, Scheme_Obje return chap_val; } } else { - if(scheme_hash_table_index((Scheme_Hash_Table *)obj, pos, &key, &val)) + if (scheme_hash_table_index((Scheme_Hash_Table *)obj, pos, &key, &val)) return val; } - scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); - return NULL; + + if (argc > 2) + return argv[2]; + else { + scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); + return NULL; + } } Scheme_Object *unsafe_hash_table_iterate_value(int argc, Scheme_Object *argv[]) @@ -4320,8 +4334,13 @@ Scheme_Object *unsafe_hash_table_iterate_pair(int argc, Scheme_Object *argv[]) if (scheme_hash_table_index((Scheme_Hash_Table *)obj, pos, &key, &val)) return scheme_make_pair(key, val); } - scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); - return NULL; + + if (argc > 2) + return scheme_make_pair(argv[2], argv[2]); + else { + scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); + return NULL; + } } Scheme_Object *unsafe_hash_table_iterate_key_value(int argc, Scheme_Object *argv[]) @@ -4341,8 +4360,15 @@ Scheme_Object *unsafe_hash_table_iterate_key_value(int argc, Scheme_Object *argv if (scheme_hash_table_index((Scheme_Hash_Table *)obj, pos, &res[0], &res[1])) return scheme_values(2, res); } - scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); - return NULL; + + if (argc > 2) { + res[0] = argv[2]; + res[1] = argv[2]; + return scheme_values(2, res); + } else { + scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); + return NULL; + } } /* unsafe_hash_tree, ie SCHEME_HASHTRP, ops */ @@ -4469,12 +4495,14 @@ Scheme_Object *unsafe_bucket_table_iterate_next(int argc, Scheme_Object *argv[]) SCHEME_INT_VAL(argv[1])); if (res) return res; - else + else if (0) { scheme_contract_error("unsafe-weak-hash-iterate-next", "no element at index", "index", 1, argv[1], NULL); - return NULL; + return NULL; + } else + return scheme_false; } Scheme_Object *unsafe_bucket_table_iterate_key(int argc, Scheme_Object *argv[]) @@ -4488,11 +4516,16 @@ Scheme_Object *unsafe_bucket_table_iterate_key(int argc, Scheme_Object *argv[]) if (scheme_bucket_table_index(ht, pos, &key, NULL)) return chaperone_hash_key(name, obj, key); } else { - if(scheme_bucket_table_index((Scheme_Bucket_Table *)obj, pos, &key, NULL)) + if (scheme_bucket_table_index((Scheme_Bucket_Table *)obj, pos, &key, NULL)) return key; } - scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); - return NULL; + + if (argc > 2) + return argv[2]; + else { + scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); + return NULL; + } } Scheme_Object *unsafe_bucket_table_iterate_value(int argc, Scheme_Object *argv[]) @@ -4509,11 +4542,16 @@ Scheme_Object *unsafe_bucket_table_iterate_value(int argc, Scheme_Object *argv[] return chap_val; } } else { - if(scheme_bucket_table_index((Scheme_Bucket_Table *)obj, pos, &key, &val)) + if (scheme_bucket_table_index((Scheme_Bucket_Table *)obj, pos, &key, &val)) return val; } - scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); - return NULL; + + if (argc > 2) + return argv[2]; + else { + scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); + return NULL; + } } Scheme_Object *unsafe_bucket_table_iterate_pair(int argc, Scheme_Object *argv[]) @@ -4533,8 +4571,13 @@ Scheme_Object *unsafe_bucket_table_iterate_pair(int argc, Scheme_Object *argv[]) if(scheme_bucket_table_index((Scheme_Bucket_Table *)obj, pos, &key, &val)) return scheme_make_pair(key, val); } - scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); - return NULL; + + if (argc > 2) + return scheme_make_pair(argv[2], argv[2]); + else { + scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); + return NULL; + } } Scheme_Object *unsafe_bucket_table_iterate_key_value(int argc, Scheme_Object *argv[]) @@ -4552,9 +4595,16 @@ Scheme_Object *unsafe_bucket_table_iterate_key_value(int argc, Scheme_Object *ar } } else { Scheme_Bucket_Table *ht = (Scheme_Bucket_Table *)obj; - if(scheme_bucket_table_index(ht, pos, &res[0], &res[1])) + if (scheme_bucket_table_index(ht, pos, &res[0], &res[1])) return scheme_values(2, res); } - scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); - return NULL; + + if (argc > 2) { + res[0] = argv[2]; + res[1] = argv[2]; + return scheme_values(2, res); + } else { + scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL); + return NULL; + } } diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index eda903b9dc..ee9722371a 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "7.0.0.9" +#define MZSCHEME_VERSION "7.0.0.10" #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 9 +#define MZSCHEME_VERSION_W 10 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)