suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add unsafe-hash-iterate ops; add specific hash table sequences

Browse Source 
- refactor for.rkt: abstract in-hash- definitions
- refactor hash_table_next in hash.c
- move hash fn headers to schpriv.h

closes #1229
This commit is contained in:
Stephen Chang 2016-01-29 11:26:05 -05:00
parent 89e00da75e
commit 048c4b4a73
15 changed files with 2211 additions and 1324 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.4.0.5")
(define version "6.4.0.6")
(define deps `("racket-lib"
["racket" #:version ,version]))

47
pkgs/racket-doc/scribblings/reference/sequences.scrbl
View File

@ -378,6 +378,53 @@ each element in the sequence.
(printf "key and value: ~a\n" key+value))]
}
@deftogether[(
@defproc[(in-mutable-hash
[hash (and/c hash? (not/c immutable?) (not/c hash-weak?))])
sequence?]
@defproc[(in-mutable-hash-keys
[hash (and/c hash? (not/c immutable?) (not/c hash-weak?))])
sequence?]
@defproc[(in-mutable-hash-values
[hash (and/c hash? (not/c immutable?) (not/c hash-weak?))])
sequence?]
@defproc[(in-mutable-hash-pairs
[hash (and/c hash? (not/c immutable?) (not/c hash-weak?))])
sequence?]
@defproc[(in-immutable-hash
[hash (and/c hash? immutable?)])
sequence?]
@defproc[(in-immutable-hash-keys
[hash (and/c hash? immutable?)])
sequence?]
@defproc[(in-immutable-hash-values
[hash (and/c hash? immutable?)])
sequence?]
@defproc[(in-immutable-hash-pairs
[hash (and/c hash? immutable?)])
sequence?]
@defproc[(in-weak-hash
[hash (and/c hash? hash-weak?)])
sequence?]
@defproc[(in-weak-hash-keys
[hash (and/c hash? hash-weak?)])
sequence?]
@defproc[(in-weak-hash-values
[hash (and/c hash? hash-weak?)])
sequence?]
@defproc[(in-weak-hash-pairs
[hash (and/c hash? hash-weak?)])
sequence?]
)]{
Sequence constructors for specific kinds of hash tables.
These may be more performant than the analogous @racket[in-hash]
forms. However, they may consume more space to help with iteration.
@history[#:added "6.4.0.6"]
}
@defproc[(in-directory [dir (or/c #f path-string?) #f]
[use-dir? ((and/c path? complete-path?) . -> . any/c)
(lambda (dir-path) #t)])

88
pkgs/racket-doc/scribblings/reference/unsafe.scrbl
View File

@ -347,6 +347,94 @@ The index @racket[k] must be between @racket[0] (inclusive) and
the number of fields in the structure (exclusive). In the case of
@racket[unsafe-struct-set!], the field must be mutable.}
@deftogether[(
@defproc[(unsafe-mutable-hash-iterate-first
[h (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])
(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])
any/c]
@defproc[(unsafe-mutable-hash-iterate-value
[h (and/c hash? (not/c immutable?) (not/c hash-weak?))]
[i 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])
(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])
pair?]
@defproc[(unsafe-immutable-hash-iterate-first
[h (and/c hash? immutable?)])
(or/c #f any/c)]
@defproc[(unsafe-immutable-hash-iterate-next
[h (and/c hash? immutable?)]
[i any/c])
(or/c #f any/c)]
@defproc[(unsafe-immutable-hash-iterate-key
[h (and/c hash? immutable?)]
[i any/c])
any/c]
@defproc[(unsafe-immutable-hash-iterate-value
[h (and/c hash? immutable?)]
[i any/c])
any/c]
@defproc[(unsafe-immutable-hash-iterate-key+value
[h (and/c hash? immutable?)]
[i any/c])
(values any/c any/c)]
@defproc[(unsafe-immutable-hash-iterate-pair
[h (and/c hash? immutable?)]
[i any/c])
pair?]
@defproc[(unsafe-weak-hash-iterate-first
[h (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])
(or/c #f any/c)]
@defproc[(unsafe-weak-hash-iterate-key
[h (and/c hash? hash-weak?)]
[i any/c])
any/c]
@defproc[(unsafe-weak-hash-iterate-value
[h (and/c hash? hash-weak?)]
[i any/c])
any/c]
@defproc[(unsafe-weak-hash-iterate-key+value
[h (and/c hash? hash-weak?)]
[i any/c])
(values any/c any/c)]
@defproc[(unsafe-weak-hash-iterate-pair
[h (and/c hash? hash-weak?)]
[i any/c])
pair?]
)]{
Unsafe versions of @racket[hash-iterate-key] and similar ops. 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.
The result of these @code{-first} and @code{-next}] functions should be given
to the corresponding unsafe accessor functions.
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"]
}
@; ------------------------------------------------------------------------
@section[#:tag "unsafeextfl"]{Unsafe Extflonum Operations}

362
pkgs/racket-test-core/tests/racket/hash.rktl
View File

@ -36,144 +36,240 @@
h))
(let ()
(define (test-hash-iterations lst1 lst2)
(define ht/immut (make-immutable-hash (map cons lst1 lst2)))
(define ht/mut (make-hash (map cons lst1 lst2)))
(define ht/weak (make-weak-hash (map cons lst1 lst2)))
(define fake-ht/immut
(chaperone-hash
ht/immut
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
(define fake-ht/mut
(impersonate-hash
ht/mut
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
(define fake-ht/weak
(impersonate-hash
ht/weak
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
(define ht/immut/seq (in-hash ht/immut))
(define ht/mut/seq (in-hash ht/mut))
(define ht/weak/seq (in-hash ht/weak))
(define ht/immut-pair/seq (in-hash-pairs ht/immut))
(define ht/mut-pair/seq (in-hash-pairs ht/mut))
(define ht/weak-pair/seq (in-hash-pairs ht/weak))
(define ht/immut-keys/seq (in-hash-keys ht/immut))
(define ht/mut-keys/seq (in-hash-keys ht/mut))
(define ht/weak-keys/seq (in-hash-keys ht/weak))
(define ht/immut-vals/seq (in-hash-values ht/immut))
(define ht/mut-vals/seq (in-hash-values ht/mut))
(define ht/weak-vals/seq (in-hash-values ht/weak))
(test #t
=
(for/sum ([(k v) (in-hash ht/immut)]) (+ k v))
(for/sum ([(k v) (in-hash ht/mut)]) (+ k v))
(for/sum ([(k v) (in-hash ht/weak)]) (+ k v))
(for/sum ([(k v) (in-hash fake-ht/immut)]) (+ k v))
(for/sum ([(k v) (in-hash fake-ht/mut)]) (+ k v))
(for/sum ([(k v) (in-hash fake-ht/weak)]) (+ k v))
(for/sum ([(k v) ht/immut/seq]) (+ k v))
(for/sum ([(k v) ht/mut/seq]) (+ k v))
(for/sum ([(k v) ht/weak/seq]) (+ k v))
(for/sum ([k+v (in-hash-pairs ht/immut)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs ht/mut)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs ht/weak)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs fake-ht/immut)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs fake-ht/mut)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs fake-ht/weak)])
(+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/immut-pair/seq]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/mut-pair/seq]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/weak-pair/seq]) (+ (car k+v) (cdr k+v)))
(+ (for/sum ([k (in-hash-keys ht/immut)]) k)
(for/sum ([v (in-hash-values ht/immut)]) v))
(+ (for/sum ([k (in-hash-keys ht/mut)]) k)
(for/sum ([v (in-hash-values ht/mut)]) v))
(+ (for/sum ([k (in-hash-keys ht/weak)]) k)
(for/sum ([v (in-hash-values ht/weak)]) v))
(+ (for/sum ([k (in-hash-keys fake-ht/immut)]) k)
(for/sum ([v (in-hash-values fake-ht/immut)]) v))
(+ (for/sum ([k (in-hash-keys fake-ht/mut)]) k)
(for/sum ([v (in-hash-values fake-ht/mut)]) v))
(+ (for/sum ([k (in-hash-keys fake-ht/weak)]) k)
(for/sum ([v (in-hash-values fake-ht/weak)]) v))
(+ (for/sum ([k ht/immut-keys/seq]) k)
(for/sum ([v ht/immut-vals/seq]) v))
(+ (for/sum ([k ht/mut-keys/seq]) k)
(for/sum ([v ht/mut-vals/seq]) v))
(+ (for/sum ([k ht/weak-keys/seq]) k)
(for/sum ([v ht/weak-vals/seq]) v)))
(test #t
=
(for/sum ([(k v) (in-hash ht/immut)]) k)
(for/sum ([(k v) (in-hash ht/mut)]) k)
(for/sum ([(k v) (in-hash ht/weak)]) k)
(for/sum ([(k v) (in-hash fake-ht/immut)]) k)
(for/sum ([(k v) (in-hash fake-ht/mut)]) k)
(for/sum ([(k v) (in-hash fake-ht/weak)]) k)
(for/sum ([(k v) ht/immut/seq]) k)
(for/sum ([(k v) ht/mut/seq]) k)
(for/sum ([(k v) ht/weak/seq]) k)
(for/sum ([k+v (in-hash-pairs ht/immut)]) (car k+v))
(for/sum ([k+v (in-hash-pairs ht/mut)]) (car k+v))
(for/sum ([k+v (in-hash-pairs ht/weak)]) (car k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/immut)]) (car k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/mut)]) (car k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/weak)]) (car k+v))
(for/sum ([k+v ht/immut-pair/seq]) (car k+v))
(for/sum ([k+v ht/mut-pair/seq]) (car k+v))
(for/sum ([k+v ht/weak-pair/seq]) (car k+v))
(for/sum ([k (in-hash-keys ht/immut)]) k)
(for/sum ([k (in-hash-keys ht/mut)]) k)
(for/sum ([k (in-hash-keys ht/weak)]) k)
(for/sum ([k (in-hash-keys fake-ht/immut)]) k)
(for/sum ([k (in-hash-keys fake-ht/mut)]) k)
(for/sum ([k (in-hash-keys fake-ht/weak)]) k)
(for/sum ([k ht/immut-keys/seq]) k)
(for/sum ([k ht/mut-keys/seq]) k)
(for/sum ([k ht/weak-keys/seq]) k))
(test #t
=
(for/sum ([(k v) (in-hash ht/immut)]) v)
(for/sum ([(k v) (in-hash ht/mut)]) v)
(for/sum ([(k v) (in-hash ht/weak)]) v)
(for/sum ([(k v) (in-hash fake-ht/immut)]) v)
(for/sum ([(k v) (in-hash fake-ht/mut)]) v)
(for/sum ([(k v) (in-hash fake-ht/weak)]) v)
(for/sum ([(k v) ht/immut/seq]) v)
(for/sum ([(k v) ht/mut/seq]) v)
(for/sum ([(k v) ht/weak/seq]) v)
(for/sum ([k+v (in-hash-pairs ht/immut)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs ht/mut)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs ht/weak)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/immut)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/mut)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/weak)]) (cdr k+v))
(for/sum ([k+v ht/immut-pair/seq]) (cdr k+v))
(for/sum ([k+v ht/mut-pair/seq]) (cdr k+v))
(for/sum ([k+v ht/weak-pair/seq]) (cdr k+v))
(for/sum ([v (in-hash-values ht/immut)]) v)
(for/sum ([v (in-hash-values ht/mut)]) v)
(for/sum ([v (in-hash-values ht/weak)]) v)
(for/sum ([v (in-hash-values fake-ht/immut)]) v)
(for/sum ([v (in-hash-values fake-ht/mut)]) v)
(for/sum ([v (in-hash-values fake-ht/weak)]) v)
(for/sum ([v ht/immut-vals/seq]) v)
(for/sum ([v ht/mut-vals/seq]) v)
(for/sum ([v ht/weak-vals/seq]) v)))
(define lst1 (build-list 10 values))
(define lst2 (build-list 10 add1))
(test-hash-iterations lst1 lst2)
(define lst3 (build-list 100000 values))
(define lst4 (build-list 100000 add1))
(test-hash-iterations lst3 lst4))
(define ht/immut (make-immutable-hash (map cons lst1 lst2)))
(define ht/mut (make-hash (map cons lst1 lst2)))
(define ht/weak (make-weak-hash (map cons lst1 lst2)))
(define fake-ht/immut
(chaperone-hash
ht/immut
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
(define fake-ht/mut
(impersonate-hash
ht/mut
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
(define fake-ht/weak
(impersonate-hash
ht/weak
(lambda (h k) (values k (lambda (h k v) v))) ; ref-proc
(lambda (h k v) values k v) ; set-proc
(lambda (h k) k) ; remove-proc
(lambda (h k) k))) ; key-proc
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ht/immut/seq (in-hash ht/immut))
(define ht/mut/seq (in-hash ht/mut))
(define ht/weak/seq (in-hash ht/weak))
(define ht/immut-pair/seq (in-hash-pairs ht/immut))
(define ht/mut-pair/seq (in-hash-pairs ht/mut))
(define ht/weak-pair/seq (in-hash-pairs ht/weak))
(define ht/immut-keys/seq (in-hash-keys ht/immut))
(define ht/mut-keys/seq (in-hash-keys ht/mut))
(define ht/weak-keys/seq (in-hash-keys ht/weak))
(define ht/immut-vals/seq (in-hash-values ht/immut))
(define ht/mut-vals/seq (in-hash-values ht/mut))
(define ht/weak-vals/seq (in-hash-values ht/weak))
(let ()
(define err-msg "no element at index")
;; Check that unsafe-weak-hash-iterate- ops do not segfault
;; when a key is collected before access; throw exception instead.
;; They are used for safe iteration in in-weak-hash- sequence forms
(let ()
(define ht #f)
(test #t
=
(for/sum ([(k v) (in-hash ht/immut)]) (+ k v))
(for/sum ([(k v) (in-hash ht/mut)]) (+ k v))
(for/sum ([(k v) (in-hash ht/weak)]) (+ k v))
(for/sum ([(k v) (in-hash fake-ht/immut)]) (+ k v))
(for/sum ([(k v) (in-hash fake-ht/mut)]) (+ k v))
(for/sum ([(k v) (in-hash fake-ht/weak)]) (+ k v))
(for/sum ([(k v) ht/immut/seq]) (+ k v))
(for/sum ([(k v) ht/mut/seq]) (+ k v))
(for/sum ([(k v) ht/weak/seq]) (+ k v))
(for/sum ([k+v (in-hash-pairs ht/immut)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs ht/mut)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs ht/weak)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs fake-ht/immut)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs fake-ht/mut)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v (in-hash-pairs fake-ht/weak)]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/immut-pair/seq]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/mut-pair/seq]) (+ (car k+v) (cdr k+v)))
(for/sum ([k+v ht/weak-pair/seq]) (+ (car k+v) (cdr k+v)))
(+ (for/sum ([k (in-hash-keys ht/immut)]) k)
(for/sum ([v (in-hash-values ht/immut)]) v))
(+ (for/sum ([k (in-hash-keys ht/mut)]) k)
(for/sum ([v (in-hash-values ht/mut)]) v))
(+ (for/sum ([k (in-hash-keys ht/weak)]) k)
(for/sum ([v (in-hash-values ht/weak)]) v))
(+ (for/sum ([k (in-hash-keys fake-ht/immut)]) k)
(for/sum ([v (in-hash-values fake-ht/immut)]) v))
(+ (for/sum ([k (in-hash-keys fake-ht/mut)]) k)
(for/sum ([v (in-hash-values fake-ht/mut)]) v))
(+ (for/sum ([k (in-hash-keys fake-ht/weak)]) k)
(for/sum ([v (in-hash-values fake-ht/weak)]) v))
(+ (for/sum ([k ht/immut-keys/seq]) k)
(for/sum ([v ht/immut-vals/seq]) v))
(+ (for/sum ([k ht/mut-keys/seq]) k)
(for/sum ([v ht/mut-vals/seq]) v))
(+ (for/sum ([k ht/weak-keys/seq]) k)
(for/sum ([v ht/weak-vals/seq]) v)))
(let ([lst (build-list 10 add1)])
(set! ht (make-weak-hash `((,lst . val)))))
(define i (hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t list? (hash-iterate-key ht i))
(test #t equal? (hash-iterate-value ht i) 'val)
(test #t equal? (cdr (hash-iterate-pair ht i)) 'val)
(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 #t
=
(for/sum ([(k v) (in-hash ht/immut)]) k)
(for/sum ([(k v) (in-hash ht/mut)]) k)
(for/sum ([(k v) (in-hash ht/weak)]) k)
(for/sum ([(k v) (in-hash fake-ht/immut)]) k)
(for/sum ([(k v) (in-hash fake-ht/mut)]) k)
(for/sum ([(k v) (in-hash fake-ht/weak)]) k)
(for/sum ([(k v) ht/immut/seq]) k)
(for/sum ([(k v) ht/mut/seq]) k)
(for/sum ([(k v) ht/weak/seq]) k)
(for/sum ([k+v (in-hash-pairs ht/immut)]) (car k+v))
(for/sum ([k+v (in-hash-pairs ht/mut)]) (car k+v))
(for/sum ([k+v (in-hash-pairs ht/weak)]) (car k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/immut)]) (car k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/mut)]) (car k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/weak)]) (car k+v))
(for/sum ([k+v ht/immut-pair/seq]) (car k+v))
(for/sum ([k+v ht/mut-pair/seq]) (car k+v))
(for/sum ([k+v ht/weak-pair/seq]) (car k+v))
(for/sum ([k (in-hash-keys ht/immut)]) k)
(for/sum ([k (in-hash-keys ht/mut)]) k)
(for/sum ([k (in-hash-keys ht/weak)]) k)
(for/sum ([k (in-hash-keys fake-ht/immut)]) k)
(for/sum ([k (in-hash-keys fake-ht/mut)]) k)
(for/sum ([k (in-hash-keys fake-ht/weak)]) k)
(for/sum ([k ht/immut-keys/seq]) k)
(for/sum ([k ht/mut-keys/seq]) k)
(for/sum ([k ht/weak-keys/seq]) k))
;; collect key, everything should error
(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 #t
=
(for/sum ([(k v) (in-hash ht/immut)]) v)
(for/sum ([(k v) (in-hash ht/mut)]) v)
(for/sum ([(k v) (in-hash ht/weak)]) v)
(for/sum ([(k v) (in-hash fake-ht/immut)]) v)
(for/sum ([(k v) (in-hash fake-ht/mut)]) v)
(for/sum ([(k v) (in-hash fake-ht/weak)]) v)
(for/sum ([(k v) ht/immut/seq]) v)
(for/sum ([(k v) ht/mut/seq]) v)
(for/sum ([(k v) ht/weak/seq]) v)
(for/sum ([k+v (in-hash-pairs ht/immut)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs ht/mut)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs ht/weak)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/immut)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/mut)]) (cdr k+v))
(for/sum ([k+v (in-hash-pairs fake-ht/weak)]) (cdr k+v))
(for/sum ([k+v ht/immut-pair/seq]) (cdr k+v))
(for/sum ([k+v ht/mut-pair/seq]) (cdr k+v))
(for/sum ([k+v ht/weak-pair/seq]) (cdr k+v))
(for/sum ([v (in-hash-values ht/immut)]) v)
(for/sum ([v (in-hash-values ht/mut)]) v)
(for/sum ([v (in-hash-values ht/weak)]) v)
(for/sum ([v (in-hash-values fake-ht/immut)]) v)
(for/sum ([v (in-hash-values fake-ht/mut)]) v)
(for/sum ([v (in-hash-values fake-ht/weak)]) v)
(for/sum ([v ht/immut-vals/seq]) v)
(for/sum ([v ht/mut-vals/seq]) v)
(for/sum ([v ht/weak-vals/seq]) v)))
;; Check that unsafe mutable hash table operations do not segfault
;; after getting valid index from unsafe-mutable-hash-iterate-first and -next.
;; Throw exception instead since they're used for safe iteration
(let ()
(define ht (make-hash '((a . b))))
(define i (hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t equal? (hash-iterate-key ht i) 'a)
(test #t equal? (hash-iterate-value ht i) 'b)
(test #t equal? (hash-iterate-pair ht i) '(a . b))
(test #t equal?
(call-with-values (lambda () (hash-iterate-key+value ht i)) cons)
'(a . b))
(test #t boolean? (hash-iterate-next ht i))
;; remove element, everything should error
(hash-remove! ht 'a)
(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))
(let ()
(define ht (make-weak-hash '((a . b))))
(define i (hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t equal? (hash-iterate-key ht i) 'a)
(test #t equal? (hash-iterate-value ht i) 'b)
(test #t equal? (hash-iterate-pair ht i) '(a . b))
(test #t equal? (call-with-values
(lambda () (hash-iterate-key+value ht i)) cons)
'(a . b))
(test #t boolean? (hash-iterate-next ht i))
;; remove element, everything should error
(hash-remove! ht 'a)
(test #t boolean? (hash-iterate-first ht))
(err/rt-test (hash-iterate-key ht i) exn:fail:contract?)
(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?)))
(report-errs)

1
pkgs/racket-test-core/tests/racket/testing.rktl
View File

@ -217,7 +217,6 @@ transcript.
(syntax
(thunk-error-test (err:mz:lambda () e) (quote-syntax e) exn?))]
[(_ e exn? msg-rx)
(regexp? (syntax-e #'msg-rx))
#'(thunk-error-test
(err:mz:lambda () e)
(quote-syntax e)

100
pkgs/racket-test-core/tests/racket/unsafe.rktl
View File

@ -579,4 +579,104 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ()
(define err-msg "no element at index")
;; Check that unsafe-weak-hash-iterate- ops do not segfault
;; when a key is collected before access; throw exception instead.
;; They are used for safe iteration in in-weak-hash- sequence forms
(let ()
(define ht #f)
(let ([lst (build-list 10 add1)])
(set! ht (make-weak-hash `((,lst . val)))))
(define i (unsafe-weak-hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t list? (unsafe-weak-hash-iterate-key ht i))
(test #t equal? (unsafe-weak-hash-iterate-value ht i) 'val)
(test #t equal? (cdr (unsafe-weak-hash-iterate-pair ht i)) 'val)
(test #t equal?
(call-with-values
(lambda () (unsafe-weak-hash-iterate-key+value ht i)) cons)
'((1 2 3 4 5 6 7 8 9 10) . val))
(test #t boolean? (unsafe-weak-hash-iterate-next ht i))
;; 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))
;; Check that unsafe mutable hash table operations do not segfault
;; after getting valid index from unsafe-mutable-hash-iterate-first and -next.
;; Throw exception instead since they're used for safe iteration
(let ()
(define ht (make-hash '((a . b))))
(define i (unsafe-mutable-hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t equal? (unsafe-mutable-hash-iterate-key ht i) 'a)
(test #t equal? (unsafe-mutable-hash-iterate-value ht i) 'b)
(test #t equal? (unsafe-mutable-hash-iterate-pair ht i) '(a . b))
(test #t equal?
(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))
;; 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))
(let ()
(define ht (make-weak-hash '((a . b))))
(define i (unsafe-weak-hash-iterate-first ht))
;; everything ok
(test #t number? i)
(test #t equal? (unsafe-weak-hash-iterate-key ht i) 'a)
(test #t equal? (unsafe-weak-hash-iterate-value ht i) 'b)
(test #t equal? (unsafe-weak-hash-iterate-pair ht i) '(a . b))
(test #t equal?
(call-with-values
(lambda () (unsafe-weak-hash-iterate-key+value ht i)) cons)
'(a . b))
(test #t boolean? (unsafe-weak-hash-iterate-next ht i))
;; 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)))
(report-errs)

278
racket/collects/racket/private/for.rkt
View File

@ -48,10 +48,24 @@
(rename *in-port in-port)
(rename *in-lines in-lines)
(rename *in-bytes-lines in-bytes-lines)
(rename *in-hash in-hash)
(rename *in-hash-keys in-hash-keys)
(rename *in-hash-values in-hash-values)
(rename *in-hash-pairs in-hash-pairs)
(rename in-hash-key+values in-hash)
in-hash-keys
in-hash-values
in-hash-pairs
(rename in-mutable-hash-key+values in-mutable-hash)
in-mutable-hash-keys
in-mutable-hash-values
in-mutable-hash-pairs
(rename in-immutable-hash-key+values in-immutable-hash)
in-immutable-hash-keys
in-immutable-hash-values
in-immutable-hash-pairs
(rename in-weak-hash-key+values in-weak-hash)
in-weak-hash-keys
in-weak-hash-values
in-weak-hash-pairs
in-directory
in-sequences
@ -88,6 +102,17 @@
(for-syntax make-in-vector-like
for-clause-syntax-protect))
;; redefininition of functions not in #%kernel
(begin-for-syntax
(define (format-id ctx str . args)
(define datum
(string->symbol (apply format str (map syntax->datum args))))
(datum->syntax ctx datum))
(define (init-list n val)
(if (zero? n)
null
(cons val (init-list (sub1 n) val)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sequence transformers:
@ -171,7 +196,7 @@
(define (for-clause-syntax-protect clause)
;; This is slightly painful. The expansion into `:do-in' involves a lot
;; of pieces that are no treated as sub-expressions. We have to push the
;; of pieces that are not treated as sub-expressions. We have to push the
;; taints down to all the relevant identifiers and expressions:
(arm-for-clause clause syntax-arm))
@ -492,7 +517,7 @@
[(string? v) (:string-gen v 0 (string-length v) 1)]
[(bytes? v) (:bytes-gen v 0 (bytes-length v) 1)]
[(input-port? v) (:input-port-gen v)]
[(hash? v) (:hash-key+val-gen v)]
[(hash? v) (:hash-gen v hash-iterate-key+value)]
[(sequence-via-prop? v) ((sequence-ref v) v)]
[(:sequence? v) (make-sequence who ((:sequence-ref v) v))]
[(stream? v) (:stream-gen v)]
@ -656,128 +681,20 @@
(check-in-bytes-lines p mode)
(in-producer (lambda () (read-bytes-line p mode)) eof)]))
(define (in-hash ht)
(unless (hash? ht) (raise-argument-error 'in-hash "hash?" ht))
(make-do-sequence (lambda () (:hash-key+val-gen ht))))
(define (in-stream l)
(unless (stream? l) (raise-argument-error 'in-stream "stream?" l))
(make-do-sequence (lambda () (:stream-gen l))))
(define (:stream-gen l)
(values
unsafe-stream-first unsafe-stream-rest l unsafe-stream-not-empty? #f #f))
(define (:hash-key+val-gen ht) (:hash-gen ht hash-iterate-key+value))
(define-sequence-syntax *in-hash
(lambda () #'in-hash)
(lambda (stx)
(syntax-case stx ()
[[(k v) (_ ht-expr)]
(for-clause-syntax-protect
#'[(k v)
(:do-in
;;outer bindings
([(ht) ht-expr])
;; outer check
(unless (hash? ht) (in-hash ht))
;; loop bindings
([i (hash-iterate-first ht)])
;; pos check
i
;; inner bindings
([(k v) (hash-iterate-key+value ht i)])
;; pre guard
#t
;; post guard
#t
;; loop args
((hash-iterate-next ht i)))])]
[_ #f])))
(define (in-hash-keys ht)
(unless (hash? ht) (raise-argument-error 'in-hash-keys "hash?" ht))
(make-do-sequence (lambda () (:hash-gen ht hash-iterate-key))))
(define-sequence-syntax *in-hash-keys
(lambda () #'in-hash-keys)
(lambda (stx)
(syntax-case stx ()
[[(id) (_ ht-expr)]
(for-clause-syntax-protect
#'[(id)
(:do-in
;;outer bindings
([(ht) ht-expr])
;; outer check
(unless (hash? ht) (in-hash-keys ht))
;; loop bindings
([i (hash-iterate-first ht)])
;; pos check
i
;; inner bindings
([(id) (hash-iterate-key ht i)])
;; pre guard
#t
;; post guard
#t
;; loop args
((hash-iterate-next ht i)))])]
[_ #f])))
(define (in-hash-values ht)
(unless (hash? ht) (raise-argument-error 'in-hash-values "hash?" ht))
(make-do-sequence (lambda () (:hash-gen ht hash-iterate-value))))
(define-sequence-syntax *in-hash-values
(lambda () #'in-hash-values)
(lambda (stx)
(syntax-case stx ()
[[(id) (_ ht-expr)]
(for-clause-syntax-protect
#'[(id)
(:do-in
;;outer bindings
([(ht) ht-expr])
;; outer check
(unless (hash? ht) (in-hash-values ht))
;; loop bindings
([i (hash-iterate-first ht)])
;; pos check
i
;; inner bindings
([(id) (hash-iterate-value ht i)])
;; pre guard
#t
;; post guard
#t
;; loop args
((hash-iterate-next ht i)))])]
[_ #f])))
(define (in-hash-pairs ht)
(unless (hash? ht) (raise-argument-error 'in-hash-values "hash?" ht))
(make-do-sequence (lambda () (:hash-gen ht hash-iterate-pair))))
(define-sequence-syntax *in-hash-pairs
(lambda () #'in-hash-pairs)
(lambda (stx)
(syntax-case stx ()
[[(id) (_ ht-expr)]
(for-clause-syntax-protect
#'[(id)
(:do-in
;;outer bindings
([(ht) ht-expr])
;; outer check
(unless (hash? ht) (in-hash-pairs ht))
;; loop bindings
([i (hash-iterate-first ht)])
;; pos check
i
;; inner bindings
([(id) (hash-iterate-pair ht i)])
;; pre guard
#t
;; post guard
#t
;; loop args
((hash-iterate-next ht i)))])]
[_ #f])))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; hash sequences
;; assembles hash iterator functions to give to make-do-sequence
(define (:hash-gen ht sel)
(values (lambda (pos) (sel ht pos))
(lambda (pos) (hash-iterate-next ht pos))
@ -786,12 +703,109 @@
#f
#f))
(define (in-stream l)
(unless (stream? l) (raise-argument-error 'in-stream "stream?" l))
(make-do-sequence (lambda () (:stream-gen l))))
(define (:stream-gen l)
(values unsafe-stream-first unsafe-stream-rest l unsafe-stream-not-empty? #f #f))
;; each call defines 4 in-hash- sequences for a kind of VAL
;; - one generic
;; - one for each hash table type: immutable, mutable, weak
;; where VAL = key, value, pair, etc
(define-syntax (define-in-hash-sequences stx)
(syntax-case stx (element-type: num-vals:)
[(_ element-type: VAL) ; eg, VAL = key, value, pair
#'(define-in-hash-sequences element-type: VAL num-vals: 1)]
[(_ element-type: VAL num-vals: n)
(with-syntax
([IN-HASH-SEQUENCE-DEFINER-NAME
(format-id #'VAL "define-in-hash-~as-sequence" #'VAL)]
[FALLBACK-SEQUENCE-NAME (format-id #'VAL "default-in-hash-~as" #'VAL)]
[-fallback-accessor (format-id #'VAL "hash-iterate-~a" #'VAL)]
[IDs (generate-temporaries (init-list (syntax-e #'n) 'x))])
#'(begin
;; 1) define fallback sequence constructor function for VAL type
;; (using make-do-sequence)
(define (FALLBACK-SEQUENCE-NAME ht)
(unless (hash? ht)
(raise-argument-error 'FALLBACK-SEQUENCE-NAME "hash?" ht))
(make-do-sequence (lambda () (:hash-gen ht -fallback-accessor))))
;; 2) define sequence syntax definer
;; defines sequences in-HASHTYPE-hash-VALs, eg:
;; - in-mutable-hash-keys
;; - in-immutable-hash-pairs, etc
(define-syntax (IN-HASH-SEQUENCE-DEFINER-NAME stx)
(syntax-case stx (hash-type: outer-check: => :generic)
;; defines generic in-hash-VALs sequence
[(def :generic)
(with-syntax
([_generic-sequence-name (format-id #'def "in-hash-~as" #'VAL)]
[_safe-iterate-fn-prefix (format-id #'def "hash-iterate")])
#'(IN-HASH-SEQUENCE-DEFINER-NAME
_generic-sequence-name
_safe-iterate-fn-prefix
outer-check: (ht) => (hash? ht)))]
;; defines in-hash-VALs sequence for a specific kind of hash table
;; eg, HASHTYPE = mutable, immutable, weak
[(def hash-type: HASHTYPE outer-check: . test-clause)
(with-syntax
([_sequence-name
(format-id #'def "in-~a-hash-~as" #'HASHTYPE #'VAL)]
[_unsafe-iterate-fn-prefix
(format-id #'def "unsafe-~a-hash-iterate" #'HASHTYPE)])
#'(IN-HASH-SEQUENCE-DEFINER-NAME
_sequence-name
_unsafe-iterate-fn-prefix
outer-check: . test-clause))]
;; main (internal) clause
[(_ IN-HASH-SEQUENCE-NAME PREFIX outer-check: (HT) => TEST-EXPR)
(with-syntax
([-iterate-first (format-id #'PREFIX "~a-first" #'PREFIX)]
[-iterate-next (format-id #'PREFIX "~a-next" #'PREFIX)]
[-iterate-VAL (format-id #'PREFIX "~a-~a" #'PREFIX #'VAL)])
#'(define-sequence-syntax IN-HASH-SEQUENCE-NAME
(lambda () #'FALLBACK-SEQUENCE-NAME)
(lambda (stx)
(syntax-case stx ()
[[IDs (_ ht-expr)]
(for-clause-syntax-protect
#'[IDs
(:do-in
;;outer bindings
([(HT) ht-expr])
;; outer check
(unless TEST-EXPR (FALLBACK-SEQUENCE-NAME HT))
;; loop bindings
([i (-iterate-first HT)])
;; pos check
i
;; inner bindings
([IDs (-iterate-VAL HT i)])
;; pre guard
#t
;; post guard
#t
;; loop args
((-iterate-next HT i)))])]
[_ #f]))))]))
;; 3) define sequence syntaxes (using definer):
;; - in-hash-VALs, works for any hash table
;; - one in-HASHTYPE-hash-VALs for each kind of hash table:
;; - immutable, mutable, and weak
;; - enables faster iteration using unsafe functions
(IN-HASH-SEQUENCE-DEFINER-NAME :generic)
(IN-HASH-SEQUENCE-DEFINER-NAME
hash-type: mutable
outer-check: (ht) => (and (hash? ht)
(not (immutable? ht))
(not (hash-weak? ht))))
(IN-HASH-SEQUENCE-DEFINER-NAME
hash-type: immutable
outer-check: (ht) => (and (hash? ht) (immutable? ht)))
(IN-HASH-SEQUENCE-DEFINER-NAME
hash-type: weak
outer-check: (ht) => (and (hash? ht) (hash-weak? ht)))
))]))
(define-in-hash-sequences element-type: key+value num-vals: 2)
(define-in-hash-sequences element-type: key)
(define-in-hash-sequences element-type: value)
(define-in-hash-sequences element-type: pair)
;; Vector-like sequences --------------------------------------------------

1812
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

1
racket/src/racket/src/env.c
View File

@ -337,6 +337,7 @@ static void init_unsafe(Scheme_Env *env)
scheme_init_unsafe_numarith(unsafe_env);
scheme_init_unsafe_numcomp(unsafe_env);
scheme_init_unsafe_list(unsafe_env);
scheme_init_unsafe_hash(unsafe_env);
scheme_init_unsafe_vector(unsafe_env);
scheme_init_unsafe_fun(unsafe_env);

136
racket/src/racket/src/hash.c
View File

@ -657,7 +657,24 @@ void scheme_reset_hash_table(Scheme_Hash_Table *table, int *history)
table->mcount = 0;
}
int scheme_hash_table_index(Scheme_Hash_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val)
Scheme_Object *scheme_hash_table_next(Scheme_Hash_Table *hash,
mzlonglong start)
{
int i, sz = hash->size;
if (start >= 0) {
if ((start >= sz) || !hash->vals[start])
return NULL;
}
for (i = start + 1; i < sz; i++) {
if (hash->vals[i])
return scheme_make_integer(i);
}
return scheme_false;
}
int scheme_hash_table_index(Scheme_Hash_Table *hash, mzlonglong pos,
Scheme_Object **_key, Scheme_Object **_val)
{
if (pos < hash->size) {
if (hash->vals[pos]) {
@ -1117,6 +1134,27 @@ Scheme_Bucket_Table *scheme_clone_bucket_table(Scheme_Bucket_Table *bt)
return table;
}
Scheme_Object *scheme_bucket_table_next(Scheme_Bucket_Table *hash,
mzlonglong start)
{
Scheme_Bucket *bucket;
int i, sz = hash->size;
if (start >= 0) {
bucket = ((start < sz) ? hash->buckets[start] : NULL);
if (!bucket || !bucket->val || !bucket->key)
return NULL;
}
for (i = start + 1; i < sz; i++) {
bucket = hash->buckets[i];
if (bucket && bucket->val && bucket->key) {
return scheme_make_integer(i);
}
}
return scheme_false;
}
int scheme_bucket_table_index(Scheme_Bucket_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val)
{
Scheme_Bucket *bucket;
@ -2669,17 +2707,24 @@ static Scheme_Hash_Tree *hamt_remove(Scheme_Hash_Tree *ht, uintptr_t code, int s
return ht;
}
/* this signature is different from other scheme_<hash type>_next fns */
/* but is used else where, so leave as is */
mzlonglong scheme_hash_tree_next(Scheme_Hash_Tree *tree, mzlonglong pos)
{
if (pos == -1)
pos = 0;
else
pos++;
if (pos == tree->count)
mzlonglong i = pos+1;
if (i == tree->count)
return -1;
else
return pos;
return i;
}
Scheme_Object *scheme_hash_tree_next_pos(Scheme_Hash_Tree *tree, mzlonglong pos)
{
mzlonglong i = pos+1;
if (i == tree->count)
return scheme_false;
else
return scheme_make_integer_value_from_long_long(i);
}
#if REVERSE_HASH_TABLE_ORDER
@ -2690,6 +2735,81 @@ mzlonglong scheme_hash_tree_next(Scheme_Hash_Tree *tree, mzlonglong pos)
# define HAMT_TRAVERSE_NEXT(i) ((i)+1)
#endif
/* instead of returning a pos, these unsafe iteration ops */
/* return a view into the tree consisting of a: */
/* - subtree */
/* - subtree index */
/* - stack of parent subtrees and indices */
/* This speeds up performance of immutable hash table iteration. */
/* These unsafe ops currently do not support REVERSE_HASH_TABLE_ORDER */
/* to avoid unneeded popcount computations */
Scheme_Object *scheme_unsafe_hash_tree_start(Scheme_Hash_Tree *ht)
{
Scheme_Object *stack = scheme_null;
int i;
ht = resolve_placeholder(ht);
if (0 == ht->count)
return scheme_false;
i = hamt_popcount(ht->bitmap)-1;
while (1) {
if (HASHTR_SUBTREEP(ht->els[i])
|| HASHTR_COLLISIONP(ht->els[i])) {
stack = /* go down tree but save return point */
scheme_make_pair((Scheme_Object *)ht,
scheme_make_pair(scheme_make_integer(i),
stack));
ht = (Scheme_Hash_Tree *)ht->els[i];
i = hamt_popcount(ht->bitmap)-1;
} else {
return scheme_make_pair((Scheme_Object *)ht,
scheme_make_pair(scheme_make_integer(i),
stack));
}
}
return NULL;
}
/* args is a (cons subtree (cons subtree-index stack-of-parents)) */
Scheme_Object *scheme_unsafe_hash_tree_next(Scheme_Object *args)
{
Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)SCHEME_CAR(args);
int i = SCHEME_INT_VAL(SCHEME_CADR(args));
Scheme_Object *stack = SCHEME_CDDR(args);
/* ht = resolve_placeholder(ht); /\* only check this in iterate-first *\/ */
while(1) {
if (!i) { /* pop up the tree */
if (SCHEME_NULLP(stack)) {
return scheme_false;
} else {
ht = (Scheme_Hash_Tree *)SCHEME_CAR(stack);
i = SCHEME_INT_VAL(SCHEME_CADR(stack));
stack = SCHEME_CDDR(stack);
}
} else {
i -= 1;
if (HASHTR_SUBTREEP(ht->els[i])
|| HASHTR_COLLISIONP(ht->els[i])) {
stack = /* go down tree but save return point */
scheme_make_pair((Scheme_Object *)ht,
scheme_make_pair(scheme_make_integer(i),
stack));
ht = (Scheme_Hash_Tree *)ht->els[i];
i = hamt_popcount(ht->bitmap);
} else {
return scheme_make_pair((Scheme_Object *)ht,
scheme_make_pair(scheme_make_integer(i),
stack));
}
}
}
return NULL;
}
XFORM_NONGCING static void hamt_at_index(Scheme_Hash_Tree *ht, mzlonglong pos,
Scheme_Object **_key, Scheme_Object **_val, uintptr_t *_code)

550
racket/src/racket/src/list.c
View File

@ -175,7 +175,30 @@ static Scheme_Object *unsafe_unbox_star (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_box (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_box_star (int argc, Scheme_Object *argv[]);
/* unsafe_scheme_hash_table */
Scheme_Object *unsafe_scheme_hash_table_iterate_start(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_table_iterate_pair(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_table_iterate_key_value(int argc, Scheme_Object *argv[]);
/* unsafe_scheme_hash_tree */
Scheme_Object *unsafe_scheme_hash_tree_iterate_start(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_tree_iterate_next(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_tree_iterate_key(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_tree_iterate_value(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_tree_iterate_pair(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_hash_tree_iterate_key_value(int argc, Scheme_Object *argv[]);
/* unsafe_scheme_bucket_table */
Scheme_Object *unsafe_scheme_bucket_table_iterate_start(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_bucket_table_iterate_next(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_bucket_table_iterate_key(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_bucket_table_iterate_value(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_bucket_table_iterate_pair(int argc, Scheme_Object *argv[]);
Scheme_Object *unsafe_scheme_bucket_table_iterate_key_value(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table, Scheme_Object *key);
static void chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *k, Scheme_Object **_chap_key, Scheme_Object **_chap_val, int ischap);
static Scheme_Object *chaperone_hash_tree_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val);
static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table);
@ -861,6 +884,143 @@ scheme_init_unsafe_list (Scheme_Env *env)
}
void
scheme_init_unsafe_hash (Scheme_Env *env)
{
Scheme_Object *p;
/* unsafe-hash-iterate-first ---------------------------------------- */
p = scheme_make_immed_prim(unsafe_scheme_hash_table_iterate_start,
"unsafe-mutable-hash-iterate-first", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant ("unsafe-mutable-hash-iterate-first", p, env);
p = scheme_make_immed_prim(unsafe_scheme_hash_tree_iterate_start,
"unsafe-immutable-hash-iterate-first", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant ("unsafe-immutable-hash-iterate-first", p, env);
p = scheme_make_immed_prim(unsafe_scheme_bucket_table_iterate_start,
"unsafe-weak-hash-iterate-first", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant ("unsafe-weak-hash-iterate-first", p, env);
/* unsafe-hash-iterate-next ---------------------------------------- */
p = scheme_make_immed_prim(unsafe_scheme_hash_table_iterate_next,
"unsafe-mutable-hash-iterate-next", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant ("unsafe-mutable-hash-iterate-next", p, env);
p = scheme_make_immed_prim(unsafe_scheme_hash_tree_iterate_next,
"unsafe-immutable-hash-iterate-next", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant ("unsafe-immutable-hash-iterate-next", p, env);
p = scheme_make_immed_prim(unsafe_scheme_bucket_table_iterate_next,
"unsafe-weak-hash-iterate-next", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant ("unsafe-weak-hash-iterate-next", p, env);
/* unsafe-hash-iterate-key ---------------------------------------- */
p = scheme_make_noncm_prim(unsafe_scheme_hash_table_iterate_key,
"unsafe-mutable-hash-iterate-key", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-mutable-hash-iterate-key", p, env);
p = scheme_make_noncm_prim(unsafe_scheme_hash_tree_iterate_key,
"unsafe-immutable-hash-iterate-key", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_IS_UNSAFE_NONALLOCATE);
scheme_add_global_constant ("unsafe-immutable-hash-iterate-key", p, env);
p = scheme_make_noncm_prim(unsafe_scheme_bucket_table_iterate_key,
"unsafe-weak-hash-iterate-key", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-weak-hash-iterate-key", p, env);
/* unsafe-hash-iterate-value ---------------------------------------- */
p = scheme_make_noncm_prim(unsafe_scheme_hash_table_iterate_value,
"unsafe-mutable-hash-iterate-value", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-mutable-hash-iterate-value", p, env);
p = scheme_make_noncm_prim(unsafe_scheme_hash_tree_iterate_value,
"unsafe-immutable-hash-iterate-value", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_IS_UNSAFE_NONALLOCATE);
scheme_add_global_constant ("unsafe-immutable-hash-iterate-value", p, env);
p = scheme_make_noncm_prim(unsafe_scheme_bucket_table_iterate_value,
"unsafe-weak-hash-iterate-value", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-weak-hash-iterate-value", p, env);
/* unsafe-hash-iterate-key+value ---------------------------------------- */
p = scheme_make_prim_w_arity2(unsafe_scheme_hash_table_iterate_key_value,
"unsafe-mutable-hash-iterate-key+value",
2, 2, 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-mutable-hash-iterate-key+value", p, env);
p = scheme_make_prim_w_arity2(unsafe_scheme_hash_tree_iterate_key_value,
"unsafe-immutable-hash-iterate-key+value",
2, 2, 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
| SCHEME_PRIM_IS_UNSAFE_NONALLOCATE);
scheme_add_global_constant ("unsafe-immutable-hash-iterate-key+value", p, env);
p = scheme_make_prim_w_arity2(unsafe_scheme_bucket_table_iterate_key_value,
"unsafe-weak-hash-iterate-key+value",
2, 2, 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-weak-hash-iterate-key+value", p, env);
/* unsafe-hash-iterate-pair ---------------------------------------- */
p = scheme_make_immed_prim(unsafe_scheme_hash_table_iterate_pair,
"unsafe-mutable-hash-iterate-pair",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-mutable-hash-iterate-pair", p, env);
p = scheme_make_immed_prim(unsafe_scheme_hash_tree_iterate_pair,
"unsafe-immutable-hash-iterate-pair",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant ("unsafe-immutable-hash-iterate-pair", p, env);
p = scheme_make_immed_prim(unsafe_scheme_bucket_table_iterate_pair,
"unsafe-weak-hash-iterate-pair",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |=
scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE_ALLOCATION
| SCHEME_PRIM_IS_UNSAFE_OMITABLE);
scheme_add_global_constant ("unsafe-weak-hash-iterate-pair", p, env);
}
Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
{
#ifdef MZ_PRECISE_GC
@ -2743,53 +2903,11 @@ static Scheme_Object *hash_table_next(const char *name, mzlonglong start, int ar
o = SCHEME_CHAPERONE_VAL(o);
if (SCHEME_HASHTP(o)) {
Scheme_Hash_Table *hash;
int i, sz;
hash = (Scheme_Hash_Table *)o;
sz = hash->size;
if (start >= 0) {
if ((start >= sz) || !hash->vals[start])
return NULL;
}
for (i = start + 1; i < sz; i++) {
if (hash->vals[i])
return scheme_make_integer(i);
}
return scheme_false;
return scheme_hash_table_next((Scheme_Hash_Table *)o, start);
} else if (SCHEME_HASHTRP(o)) {
mzlonglong v;
v = scheme_hash_tree_next((Scheme_Hash_Tree *)o, start);
if (v == -1)
return scheme_false;
else if (v == -2)
return NULL;
else
return scheme_make_integer_value_from_long_long(v);
return scheme_hash_tree_next_pos((Scheme_Hash_Tree *)o, start);
} else if (SCHEME_BUCKTP(o)) {
Scheme_Bucket_Table *hash;
Scheme_Bucket *bucket;
int i, sz;
hash = (Scheme_Bucket_Table *)o;
sz = hash->size;
if (start >= 0) {
bucket = ((start < sz) ? hash->buckets[start] : NULL);
if (!bucket || !bucket->val || !bucket->key)
return NULL;
}
for (i = start + 1; i < sz; i++) {
bucket = hash->buckets[i];
if (bucket && bucket->val && bucket->key) {
return scheme_make_integer(i);
}
}
return scheme_false;
return scheme_bucket_table_next((Scheme_Bucket_Table *)o, start);
} else {
scheme_wrong_contract(name, "hash?", 0, argc, argv);
return NULL;
@ -2815,8 +2933,7 @@ Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[])
v = hash_table_next("hash-iterate-next", pos, argc, argv);
if (v)
return v;
if (v) return v;
if (SCHEME_INTP(p)) {
if (SCHEME_INT_VAL(p) >= 0)
@ -2827,12 +2944,12 @@ Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[])
}
if (p)
scheme_wrong_contract("hash-iterate-next", "exact-nonnegative-integer?", 1, argc, 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;
}
@ -2845,9 +2962,7 @@ static int hash_table_index(const char *name, int argc, Scheme_Object *argv[], S
if (SCHEME_NP_CHAPERONEP(obj))
obj = SCHEME_CHAPERONE_VAL(obj);
if (!scheme_get_long_long_val(p, &pos))
pos = HASH_POS_TOO_BIG;
else if (pos < 0)
if (!scheme_get_long_long_val(p, &pos) || (pos < 0))
pos = HASH_POS_TOO_BIG;
if (SCHEME_HASHTP(obj)) {
@ -2899,10 +3014,8 @@ Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[])
Scheme_Object *obj = argv[0];
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Object *chap_key, *chap_val;
chap_key = chaperone_hash_key(name, obj, key);
chap_val = scheme_chaperone_hash_get(obj, chap_key);
if (!chap_val)
no_post_key(name, chap_key, SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj)));
int ischap = SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj));
chaperone_hash_key_value(name, obj, key, &chap_key, &chap_val, ischap);
return chap_val;
}
else
@ -2919,10 +3032,8 @@ Scheme_Object *scheme_hash_table_iterate_pair(int argc, Scheme_Object *argv[])
Scheme_Object *obj = argv[0];
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Object *chap_key, *chap_val;
chap_key = chaperone_hash_key(name, obj, key);
chap_val = scheme_chaperone_hash_get(obj, chap_key);
if (!chap_val)
no_post_key(name, chap_key, SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj)));
int ischap = SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj));
chaperone_hash_key_value(name, obj, key, &chap_key, &chap_val, ischap);
return scheme_make_pair(chap_key, chap_val);
}
else
@ -2938,13 +3049,8 @@ Scheme_Object *scheme_hash_table_iterate_key_value(int argc, Scheme_Object *argv
if (hash_table_index(name, argc, argv, &key, &val)) {
Scheme_Object *res[2], *obj = argv[0];
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Object *chap_key, *chap_val;
chap_key = chaperone_hash_key(name, obj, key);
chap_val = scheme_chaperone_hash_get(obj, chap_key);
if (!chap_val)
no_post_key(name, chap_key, SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj)));
res[0] = chap_key;
res[1] = chap_val;
int ischap = SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj));
chaperone_hash_key_value(name, obj, key, &res[0], &res[1], ischap);
}
else {
res[0] = key;
@ -3294,6 +3400,16 @@ static Scheme_Object *chaperone_hash_key(const char *name, Scheme_Object *table,
{
return chaperone_hash_op(name, table, key, NULL, 3, scheme_null);
}
static void chaperone_hash_key_value(const char *name, Scheme_Object *obj, Scheme_Object *key, Scheme_Object **_chap_key, Scheme_Object **_chap_val, int ischap)
{
Scheme_Object *chap_key, *chap_val;
chap_key = chaperone_hash_key(name, obj, key);
chap_val = scheme_chaperone_hash_get(obj, chap_key);
if (!chap_val)
no_post_key(name, chap_key, ischap);
*_chap_key = chap_key;
*_chap_val = chap_val;
}
static Scheme_Object *chaperone_hash_clear(const char *name, Scheme_Object *table)
{
@ -3878,3 +3994,303 @@ static Scheme_Object *unsafe_set_box (int argc, Scheme_Object *argv[])
SCHEME_BOX_VAL(argv[0]) = argv[1];
return scheme_void;
}
/************************************************************/
/* unsafe hash table iteration ops */
/************************************************************/
/* unsafe_scheme_hash_table, ie SCHEME_HASHTP, ops */
Scheme_Object *unsafe_scheme_hash_table_iterate_start(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
if (SCHEME_NP_CHAPERONEP(o)) o = SCHEME_CHAPERONE_VAL(o);
return scheme_hash_table_next((Scheme_Hash_Table *)o, -1);
}
Scheme_Object *unsafe_scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0], *res;
if (SCHEME_NP_CHAPERONEP(o)) o = SCHEME_CHAPERONE_VAL(o);
res = scheme_hash_table_next((Scheme_Hash_Table *)o, SCHEME_INT_VAL(argv[1]));
if (res)
return res;
else
scheme_contract_error("unsafe-mutable-hash-iterate-next",
"no element at index",
"index", 1, argv[1],
NULL);
return NULL;
}
Scheme_Object *unsafe_scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[])
{
const char *name = "unsafe-mutable-hash-iterate-key";
Scheme_Object *obj = argv[0], *key;
mzlonglong pos = SCHEME_INT_VAL(argv[1]);
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)SCHEME_CHAPERONE_VAL(obj);
if (scheme_hash_table_index(ht, pos, &key, NULL))
return chaperone_hash_key(name, obj, key);
} else {
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;
}
Scheme_Object *unsafe_scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[])
{
const char *name = "unsafe-mutable-hash-iterate-value";
Scheme_Object *obj = argv[0], *key, *val;
mzlonglong pos = SCHEME_INT_VAL(argv[1]);
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Object *chap_key, *chap_val;
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)SCHEME_CHAPERONE_VAL(obj);
if (scheme_hash_table_index(ht, pos, &key, NULL)) {
chaperone_hash_key_value(name, obj, key, &chap_key, &chap_val, 0);
return chap_val;
}
} else {
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;
}
Scheme_Object *unsafe_scheme_hash_table_iterate_pair(int argc, Scheme_Object *argv[])
{
const char *name = "unsafe-mutable-hash-iterate-pair";
Scheme_Object *obj = argv[0], *key, *val;
mzlonglong pos = SCHEME_INT_VAL(argv[1]);
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Object *chap_key, *chap_val;
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)SCHEME_CHAPERONE_VAL(obj);
if (scheme_hash_table_index(ht, pos, &key, NULL)) {
chaperone_hash_key_value(name, obj, key, &chap_key, &chap_val, 0);
return scheme_make_pair(chap_key, chap_val);
}
} else {
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;
}
Scheme_Object *unsafe_scheme_hash_table_iterate_key_value(int argc, Scheme_Object *argv[])
{
const char *name = "unsafe-mutable-hash-iterate-key+value";
Scheme_Object *obj = argv[0], *res[2];
mzlonglong pos = SCHEME_INT_VAL(argv[1]);
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Object *key;
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)SCHEME_CHAPERONE_VAL(obj);
if (scheme_hash_table_index(ht, pos, &key, NULL)) {
chaperone_hash_key_value(name, obj, key, &res[0], &res[1], 0);
return scheme_values(2, res);
}
} else {
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;
}
/* unsafe_scheme_hash_tree, ie SCHEME_HASHTRP, ops */
Scheme_Object *unsafe_scheme_hash_tree_iterate_start(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
if (SCHEME_NP_CHAPERONEP(o)) o = SCHEME_CHAPERONE_VAL(o);
return scheme_unsafe_hash_tree_start((Scheme_Hash_Tree *)o);
}
Scheme_Object *unsafe_scheme_hash_tree_iterate_next(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
if (SCHEME_NP_CHAPERONEP(o)) o = SCHEME_CHAPERONE_VAL(o);
return scheme_unsafe_hash_tree_next(argv[1]);
}
Scheme_Object *unsafe_scheme_hash_tree_iterate_key(int argc, Scheme_Object *argv[])
{
Scheme_Object *obj = argv[0], *args = argv[1], *key;
Scheme_Hash_Tree *subtree = (Scheme_Hash_Tree *)SCHEME_CAR(args);
int i = SCHEME_INT_VAL(SCHEME_CADR(args));
key = subtree->els[i];
if (SCHEME_NP_CHAPERONEP(obj))
return chaperone_hash_key("unsafe-weak-hash-iterate-key", obj, key);
else
return key;
}
Scheme_Object *unsafe_scheme_hash_tree_iterate_value(int argc, Scheme_Object *argv[])
{
Scheme_Object *obj = argv[0], *args = argv[1];
Scheme_Hash_Tree *subtree = (Scheme_Hash_Tree *)SCHEME_CAR(args);
int i = SCHEME_INT_VAL(SCHEME_CADR(args));
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Object *chap_key, *chap_val;
chaperone_hash_key_value("unsafe-weak-hash-iterate-value",
obj, subtree->els[i], &chap_key, &chap_val, 0);
return chap_val;
} else {
int popcount;
popcount = hamt_popcount(subtree->bitmap);
return subtree->els[i+popcount];
}
}
Scheme_Object *unsafe_scheme_hash_tree_iterate_pair(int argc, Scheme_Object *argv[])
{
Scheme_Object *obj = argv[0], *args = argv[1];
Scheme_Hash_Tree *subtree = (Scheme_Hash_Tree *)SCHEME_CAR(args);
int i = SCHEME_INT_VAL(SCHEME_CADR(args));
Scheme_Object *key = subtree->els[i];
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Object *chap_key, *chap_val;
chaperone_hash_key_value("unsafe-weak-hash-iterate-pair",
obj, subtree->els[i], &chap_key, &chap_val, 0);
return scheme_make_pair(chap_key, chap_val);
} else {
Scheme_Object *val;
int popcount;
popcount = hamt_popcount(subtree->bitmap);
val = subtree->els[i+popcount];
return scheme_make_pair(key, val);
}
}
Scheme_Object *unsafe_scheme_hash_tree_iterate_key_value(int argc, Scheme_Object *argv[])
{
Scheme_Object *obj = argv[0], *args = argv[1], *res[2];
Scheme_Hash_Tree *subtree = (Scheme_Hash_Tree *)SCHEME_CAR(args);
int i = SCHEME_INT_VAL(SCHEME_CADR(args));
Scheme_Object *key = subtree->els[i];
if (SCHEME_NP_CHAPERONEP(obj)) {
chaperone_hash_key_value("unsafe-weak-hash-iterate-pair",
obj, subtree->els[i], &res[0], &res[1], 0);
} else {
Scheme_Object *val;
int popcount;
popcount = hamt_popcount(subtree->bitmap);
val = subtree->els[i+popcount];
res[0] = key;
res[1] = val;
}
return scheme_values(2, res);
}
/* unsafe_scheme_bucket_table, ie SCHEME_BUCKTP, ops */
Scheme_Object *unsafe_scheme_bucket_table_iterate_start(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
if (SCHEME_NP_CHAPERONEP(o)) o = SCHEME_CHAPERONE_VAL(o);
return scheme_bucket_table_next((Scheme_Bucket_Table *)o, -1);
}
Scheme_Object *unsafe_scheme_bucket_table_iterate_next(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0], *res;
if (SCHEME_NP_CHAPERONEP(o)) o = SCHEME_CHAPERONE_VAL(o);
res = scheme_bucket_table_next((Scheme_Bucket_Table *)o,
SCHEME_INT_VAL(argv[1]));
if (res)
return res;
else
scheme_contract_error("unsafe-weak-hash-iterate-next",
"no element at index",
"index", 1, argv[1],
NULL);
return NULL;
}
Scheme_Object *unsafe_scheme_bucket_table_iterate_key(int argc, Scheme_Object *argv[])
{
const char *name = "unsafe-weak-hash-iterate-key";
Scheme_Object *obj = argv[0], *key;
mzlonglong pos = SCHEME_INT_VAL(argv[1]);
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Bucket_Table *ht = (Scheme_Bucket_Table *)SCHEME_CHAPERONE_VAL(obj);
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))
return key;
}
scheme_contract_error(name, "no element at index", "index", 1, argv[1], NULL);
return NULL;
}
Scheme_Object *unsafe_scheme_bucket_table_iterate_value(int argc, Scheme_Object *argv[])
{
const char *name = "unsafe-weak-hash-iterate-value";
Scheme_Object *obj = argv[0], *key, *val;
mzlonglong pos = SCHEME_INT_VAL(argv[1]);
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Bucket_Table *ht = (Scheme_Bucket_Table *)SCHEME_CHAPERONE_VAL(obj);
Scheme_Object *chap_key, *chap_val;
if (scheme_bucket_table_index(ht, pos, &key, NULL)) {
chaperone_hash_key_value(name, obj, key, &chap_key, &chap_val, 0);
return chap_val;
}
} else {
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;
}
Scheme_Object *unsafe_scheme_bucket_table_iterate_pair(int argc, Scheme_Object *argv[])
{
const char *name = "unsafe-weak-hash-iterate-pair";
Scheme_Object *obj = argv[0], *key, *val;
mzlonglong pos = SCHEME_INT_VAL(argv[1]);
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Bucket_Table *ht = (Scheme_Bucket_Table *)SCHEME_CHAPERONE_VAL(obj);
Scheme_Object *chap_key, *chap_val;
if (scheme_bucket_table_index(ht, pos, &key, NULL)) {
chaperone_hash_key_value(name, obj, key, &chap_key, &chap_val, 0);
return scheme_make_pair(chap_key, chap_val);
}
} else {
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;
}
Scheme_Object *unsafe_scheme_bucket_table_iterate_key_value(int argc, Scheme_Object *argv[])
{
const char *name = "unsafe-weak-hash-iterate-key+value";
Scheme_Object *obj = argv[0], *res[2];
mzlonglong pos = SCHEME_INT_VAL(argv[1]);
if (SCHEME_NP_CHAPERONEP(obj)) {
Scheme_Bucket_Table *ht = (Scheme_Bucket_Table *)SCHEME_CHAPERONE_VAL(obj);
Scheme_Object *key;
if (scheme_bucket_table_index(ht, pos, &key, NULL)) {
chaperone_hash_key_value(name, obj, key, &res[0], &res[1], 0);
return scheme_values(2, res);
}
} else {
Scheme_Bucket_Table *ht = (Scheme_Bucket_Table *)obj;
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;
}

40
racket/src/racket/src/schemef.h
View File

@ -484,46 +484,6 @@ MZ_EXTERN void scheme_free_immobile_box(void **b);
MZ_EXTERN Scheme_Object *scheme_add_gc_callback(Scheme_Object *pre, Scheme_Object *post);
MZ_EXTERN void scheme_remove_gc_callback(Scheme_Object *key);
/*========================================================================*/
/* hash tables */
/*========================================================================*/
MZ_EXTERN Scheme_Bucket_Table *scheme_make_bucket_table(intptr_t size_hint, int type);
MZ_EXTERN void scheme_add_to_table(Scheme_Bucket_Table *table, const char *key, void *val, int);
MZ_EXTERN void scheme_change_in_table(Scheme_Bucket_Table *table, const char *key, void *new_val);
MZ_EXTERN void *scheme_lookup_in_table(Scheme_Bucket_Table *table, const char *key);
MZ_EXTERN Scheme_Bucket *scheme_bucket_from_table(Scheme_Bucket_Table *table, const char *key);
MZ_EXTERN int scheme_bucket_table_equal(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2);
MZ_EXTERN Scheme_Bucket_Table *scheme_clone_bucket_table(Scheme_Bucket_Table *bt);
MZ_EXTERN void scheme_clear_bucket_table(Scheme_Bucket_Table *bt);
XFORM_NONGCING MZ_EXTERN int scheme_bucket_table_index(Scheme_Bucket_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
MZ_EXTERN Scheme_Hash_Table *scheme_make_hash_table(int type);
MZ_EXTERN Scheme_Hash_Table *scheme_make_hash_table_equal();
MZ_EXTERN Scheme_Hash_Table *scheme_make_hash_table_eqv();
MZ_EXTERN void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key);
XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key);
MZ_EXTERN void scheme_hash_set_atomic(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN Scheme_Object *scheme_hash_get_atomic(Scheme_Hash_Table *table, Scheme_Object *key);
MZ_EXTERN int scheme_hash_table_equal(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2);
MZ_EXTERN int scheme_is_hash_table_equal(Scheme_Object *o);
MZ_EXTERN int scheme_is_hash_table_eqv(Scheme_Object *o);
MZ_EXTERN Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *ht);
MZ_EXTERN void scheme_clear_hash_table(Scheme_Hash_Table *ht);
XFORM_NONGCING MZ_EXTERN int scheme_hash_table_index(Scheme_Hash_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree(int kind);
MZ_EXTERN Scheme_Hash_Tree *scheme_make_hash_tree_set(int kind);
MZ_EXTERN Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val);
MZ_EXTERN Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key);
XFORM_NONGCING MZ_EXTERN Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key);
XFORM_NONGCING MZ_EXTERN mzlonglong scheme_hash_tree_next(Scheme_Hash_Tree *tree, mzlonglong pos);
XFORM_NONGCING MZ_EXTERN int scheme_hash_tree_index(Scheme_Hash_Tree *tree, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
MZ_EXTERN int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2);
MZ_EXTERN int scheme_is_hash_tree_equal(Scheme_Object *o);
MZ_EXTERN int scheme_is_hash_tree_eqv(Scheme_Object *o);
/*========================================================================*/
/* basic Scheme value constructors */
/*========================================================================*/

2
racket/src/racket/src/schminc.h
View File

@ -15,7 +15,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1144
#define EXPECTED_UNSAFE_COUNT 108
#define EXPECTED_UNSAFE_COUNT 126
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45
#define EXPECTED_FUTURES_COUNT 15

112
racket/src/racket/src/schpriv.h
View File

@ -289,6 +289,7 @@ void scheme_init_logger_wait();
void scheme_init_struct_wait();
void scheme_init_list(Scheme_Env *env);
void scheme_init_unsafe_list(Scheme_Env *env);
void scheme_init_unsafe_hash(Scheme_Env *env);
void scheme_init_stx(Scheme_Env *env);
void scheme_init_module(Scheme_Env *env);
void scheme_init_module_path_table(void);
@ -589,38 +590,6 @@ extern Scheme_Object *scheme_uint32_ctype;
extern Scheme_Object *scheme_int64_ctype;
extern Scheme_Object *scheme_uint64_ctype;
/*========================================================================*/
/* hash functions */
/*========================================================================*/
Scheme_Object *scheme_make_immutable_hash(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_make_immutable_hasheq(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_make_immutable_hasheqv(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_eq_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_eqv_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_equal_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_put(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_start(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key,
Scheme_Object *key_wraps);
void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps);
Scheme_Bucket *scheme_bucket_or_null_from_table_w_key_wraps(Scheme_Bucket_Table *table,
const char *key, int add,
Scheme_Object *key_wraps);
void scheme_add_to_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, void *val,
int constant, Scheme_Object *key_wraps);
void *scheme_lookup_in_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key,
Scheme_Object *key_wraps);
Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key,
Scheme_Object *key_wraps);
Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps);
/*========================================================================*/
/* thread state and maintenance */
/*========================================================================*/
@ -927,6 +896,85 @@ struct Scheme_Hash_Tree {
Scheme_Object *scheme_intern_literal_string(Scheme_Object *str);
Scheme_Object *scheme_intern_literal_number(Scheme_Object *num);
/*========================================================================*/
/* hash functions */
/*========================================================================*/
Scheme_Object *scheme_make_immutable_hash(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_make_immutable_hasheq(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_make_immutable_hasheqv(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_eq_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_eqv_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_equal_p(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_put(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_start(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_next(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_value(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_table_iterate_key(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_hash_get_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key,
Scheme_Object *key_wraps);
void scheme_hash_set_w_key_wraps(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps);
Scheme_Bucket *scheme_bucket_or_null_from_table_w_key_wraps(Scheme_Bucket_Table *table,
const char *key, int add,
Scheme_Object *key_wraps);
void scheme_add_to_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key, void *val,
int constant, Scheme_Object *key_wraps);
void *scheme_lookup_in_table_w_key_wraps(Scheme_Bucket_Table *table, const char *key,
Scheme_Object *key_wraps);
Scheme_Object *scheme_hash_tree_get_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key,
Scheme_Object *key_wraps);
Scheme_Hash_Tree *scheme_hash_tree_set_w_key_wraps(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val,
Scheme_Object *key_wraps);
/*========================================================================*/
/* hash tables */
/*========================================================================*/
Scheme_Bucket_Table *scheme_make_bucket_table(intptr_t size_hint, int type);
void scheme_add_to_table(Scheme_Bucket_Table *table, const char *key, void *val, int);
void scheme_change_in_table(Scheme_Bucket_Table *table, const char *key, void *new_val);
void *scheme_lookup_in_table(Scheme_Bucket_Table *table, const char *key);
Scheme_Bucket *scheme_bucket_from_table(Scheme_Bucket_Table *table, const char *key);
int scheme_bucket_table_equal(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2);
Scheme_Bucket_Table *scheme_clone_bucket_table(Scheme_Bucket_Table *bt);
void scheme_clear_bucket_table(Scheme_Bucket_Table *bt);
Scheme_Object *scheme_bucket_table_next(Scheme_Bucket_Table *hash, mzlonglong start);
XFORM_NONGCING int scheme_bucket_table_index(Scheme_Bucket_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
Scheme_Hash_Table *scheme_make_hash_table(int type);
Scheme_Hash_Table *scheme_make_hash_table_equal();
Scheme_Hash_Table *scheme_make_hash_table_eqv();
void scheme_hash_set(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
Scheme_Object *scheme_hash_get(Scheme_Hash_Table *table, Scheme_Object *key);
XFORM_NONGCING Scheme_Object *scheme_eq_hash_get(Scheme_Hash_Table *table, Scheme_Object *key);
void scheme_hash_set_atomic(Scheme_Hash_Table *table, Scheme_Object *key, Scheme_Object *val);
Scheme_Object *scheme_hash_get_atomic(Scheme_Hash_Table *table, Scheme_Object *key);
int scheme_hash_table_equal(Scheme_Hash_Table *t1, Scheme_Hash_Table *t2);
int scheme_is_hash_table_equal(Scheme_Object *o);
int scheme_is_hash_table_eqv(Scheme_Object *o);
Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *ht);
void scheme_clear_hash_table(Scheme_Hash_Table *ht);
Scheme_Object *scheme_hash_table_next(Scheme_Hash_Table *hash, mzlonglong start);
XFORM_NONGCING int scheme_hash_table_index(Scheme_Hash_Table *hash, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
Scheme_Hash_Tree *scheme_make_hash_tree(int kind);
Scheme_Hash_Tree *scheme_make_hash_tree_set(int kind);
Scheme_Hash_Tree *scheme_hash_tree_set(Scheme_Hash_Tree *tree, Scheme_Object *key, Scheme_Object *val);
Scheme_Object *scheme_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key);
XFORM_NONGCING Scheme_Object *scheme_eq_hash_tree_get(Scheme_Hash_Tree *tree, Scheme_Object *key);
XFORM_NONGCING mzlonglong scheme_hash_tree_next(Scheme_Hash_Tree *tree, mzlonglong pos);
Scheme_Object *scheme_unsafe_hash_tree_start(Scheme_Hash_Tree *ht);
Scheme_Object *scheme_unsafe_hash_tree_next(Scheme_Object *args);
Scheme_Object *scheme_hash_tree_next_pos(Scheme_Hash_Tree *tree, mzlonglong pos);
XFORM_NONGCING int scheme_hash_tree_index(Scheme_Hash_Tree *tree, mzlonglong pos, Scheme_Object **_key, Scheme_Object **_val);
int scheme_hash_tree_equal(Scheme_Hash_Tree *t1, Scheme_Hash_Tree *t2);
int scheme_is_hash_tree_equal(Scheme_Object *o);
int scheme_is_hash_tree_eqv(Scheme_Object *o);
XFORM_NONGCING int hamt_popcount(hash_tree_bitmap_t x);
/*========================================================================*/
/* structs */
/*========================================================================*/

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.4.0.5"
#define MZSCHEME_VERSION "6.4.0.6"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 4
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)