added make-hashtable.
This commit is contained in:
Abdulaziz Ghuloum
parent
d8058e0cbf
commit
8d460a32af
|
|
@ -15,23 +15,28 @@
|
|||
|
||||
|
||||
(library (ikarus hash-tables)
|
||||
(export make-eq-hashtable hashtable-ref hashtable-set! hashtable?
|
||||
(export make-eq-hashtable make-hashtable
|
||||
hashtable-ref hashtable-set! hashtable?
|
||||
hashtable-size hashtable-delete! hashtable-contains?
|
||||
hashtable-update! hashtable-keys hashtable-mutable?
|
||||
hashtable-clear! hashtable-entries hashtable-copy
|
||||
hashtable-equivalence-function hashtable-hash-function
|
||||
string-hash string-ci-hash symbol-hash)
|
||||
(import
|
||||
(ikarus system $pairs)
|
||||
(ikarus system $vectors)
|
||||
(ikarus system $tcbuckets)
|
||||
(ikarus system $fx)
|
||||
(except (ikarus) make-eq-hashtable hashtable-ref hashtable-set! hashtable?
|
||||
(except (ikarus)
|
||||
make-eq-hashtable make-hashtable
|
||||
hashtable-ref hashtable-set! hashtable?
|
||||
hashtable-size hashtable-delete! hashtable-contains?
|
||||
hashtable-update! hashtable-keys hashtable-mutable?
|
||||
hashtable-clear! hashtable-entries hashtable-copy
|
||||
hashtable-equivalence-function hashtable-hash-function
|
||||
string-hash string-ci-hash symbol-hash))
|
||||
|
||||
(define-struct hasht (vec count tc mutable?))
|
||||
(define-struct hasht (vec count tc mutable? hashf equivf))
|
||||
|
||||
;;; directly from Dybvig's paper
|
||||
(define tc-pop
|
||||
|
|
@ -112,13 +117,26 @@
|
|||
(void))))))))
|
||||
|
||||
(define (get-bucket h x)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (hasht-vec h)])
|
||||
(let ([ih pv])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(or (direct-lookup x b)
|
||||
(rehash-lookup h (hasht-tc h) x)))))))
|
||||
(cond
|
||||
[(hasht-hashf h) =>
|
||||
(lambda (hashf)
|
||||
(let ([ih (hashf x)])
|
||||
(let ([equiv? (hasht-equivf h)]
|
||||
[vec (hasht-vec h)])
|
||||
(let ([idx (bitwise-and ih ($fx- ($vector-length vec) 1))])
|
||||
(let f ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(fixnum? b) #f]
|
||||
[(equiv? x ($tcbucket-key b)) b]
|
||||
[else (f ($tcbucket-next b))]))))))]
|
||||
[else
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (hasht-vec h)])
|
||||
(let ([ih pv])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(or (direct-lookup x b)
|
||||
(rehash-lookup h (hasht-tc h) x))))))]))
|
||||
|
||||
(define (get-hash h x v)
|
||||
(cond
|
||||
|
|
@ -156,31 +174,52 @@
|
|||
|
||||
(define put-hash!
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (hasht-vec h)])
|
||||
(let ([ih pv])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(or (direct-lookup x b) (rehash-lookup h (hasht-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($set-tcbucket-val! b v)
|
||||
(void))]
|
||||
[else
|
||||
(let ([bucket
|
||||
($make-tcbucket (hasht-tc h) x v ($vector-ref vec idx))])
|
||||
(if ($fx= (pointer-value x) pv)
|
||||
($vector-set! vec idx bucket)
|
||||
(let* ([ih (pointer-value x)]
|
||||
[idx
|
||||
($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
($set-tcbucket-next! bucket ($vector-ref vec idx))
|
||||
($vector-set! vec idx bucket))))
|
||||
(let ([ct (hasht-count h)])
|
||||
(set-hasht-count! h ($fxadd1 ct))
|
||||
(when ($fx> ct ($vector-length vec))
|
||||
(enlarge-table h)))])))))))
|
||||
(cond
|
||||
[(hasht-hashf h) =>
|
||||
(lambda (hashf)
|
||||
(let ([ih (hashf x)])
|
||||
(let ([equiv? (hasht-equivf h)]
|
||||
[vec (hasht-vec h)])
|
||||
(let ([idx (bitwise-and ih ($fx- ($vector-length vec) 1))])
|
||||
(let f ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(fixnum? b)
|
||||
($vector-set! vec idx
|
||||
(vector x v ($vector-ref vec idx)))
|
||||
(let ([ct (hasht-count h)])
|
||||
(set-hasht-count! h ($fxadd1 ct))
|
||||
(when ($fx> ct ($vector-length vec))
|
||||
(enlarge-table h)))]
|
||||
[(equiv? x ($tcbucket-key b))
|
||||
($set-tcbucket-val! b v)]
|
||||
[else (f ($tcbucket-next b))]))))))]
|
||||
[else
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (hasht-vec h)])
|
||||
(let ([ih pv])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(or (direct-lookup x b) (rehash-lookup h (hasht-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($set-tcbucket-val! b v)
|
||||
(void))]
|
||||
[else
|
||||
(let ([bucket
|
||||
($make-tcbucket (hasht-tc h) x v
|
||||
($vector-ref vec idx))])
|
||||
(if ($fx= (pointer-value x) pv)
|
||||
($vector-set! vec idx bucket)
|
||||
(let* ([ih (pointer-value x)]
|
||||
[idx
|
||||
($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
($set-tcbucket-next! bucket ($vector-ref vec idx))
|
||||
($vector-set! vec idx bucket))))
|
||||
(let ([ct (hasht-count h)])
|
||||
(set-hasht-count! h ($fxadd1 ct))
|
||||
(when ($fx> ct ($vector-length vec))
|
||||
(enlarge-table h)))])))))])))
|
||||
|
||||
(define (update-hash! h x proc default)
|
||||
(cond
|
||||
|
|
@ -188,34 +227,63 @@
|
|||
(lambda (b) ($set-tcbucket-val! b (proc ($tcbucket-val b))))]
|
||||
[else (put-hash! h x (proc default))]))
|
||||
|
||||
(define insert-b
|
||||
(lambda (b vec mask)
|
||||
(let* ([x ($tcbucket-key b)]
|
||||
[pv (pointer-value x)]
|
||||
[ih pv]
|
||||
[idx ($fxlogand ih mask)]
|
||||
[next ($tcbucket-next b)])
|
||||
($set-tcbucket-next! b ($vector-ref vec idx))
|
||||
($vector-set! vec idx b)
|
||||
(unless (fixnum? next)
|
||||
(insert-b next vec mask)))))
|
||||
|
||||
(define move-all
|
||||
(lambda (vec1 i n vec2 mask)
|
||||
(unless ($fx= i n)
|
||||
(let ([b ($vector-ref vec1 i)])
|
||||
(unless (fixnum? b)
|
||||
(insert-b b vec2 mask))
|
||||
(move-all vec1 ($fxadd1 i) n vec2 mask)))))
|
||||
|
||||
(define enlarge-table
|
||||
(lambda (h)
|
||||
(let* ([vec1 (hasht-vec h)]
|
||||
[n1 ($vector-length vec1)]
|
||||
[n2 ($fxsll n1 1)]
|
||||
[vec2 (make-base-vec n2)])
|
||||
(move-all vec1 0 n1 vec2 ($fx- n2 1))
|
||||
(set-hasht-vec! h vec2))))
|
||||
(define (enlarge-eq-table h)
|
||||
(define insert-b
|
||||
(lambda (b vec mask)
|
||||
(let* ([x ($tcbucket-key b)]
|
||||
[pv (pointer-value x)]
|
||||
[ih pv]
|
||||
[idx ($fxlogand ih mask)]
|
||||
[next ($tcbucket-next b)])
|
||||
($set-tcbucket-next! b ($vector-ref vec idx))
|
||||
($vector-set! vec idx b)
|
||||
(unless (fixnum? next)
|
||||
(insert-b next vec mask)))))
|
||||
(define move-all
|
||||
(lambda (vec1 i n vec2 mask)
|
||||
(unless ($fx= i n)
|
||||
(let ([b ($vector-ref vec1 i)])
|
||||
(unless (fixnum? b)
|
||||
(insert-b b vec2 mask))
|
||||
(move-all vec1 ($fxadd1 i) n vec2 mask)))))
|
||||
(let* ([vec1 (hasht-vec h)]
|
||||
[n1 ($vector-length vec1)]
|
||||
[n2 ($fxsll n1 1)]
|
||||
[vec2 (make-base-vec n2)])
|
||||
(move-all vec1 0 n1 vec2 ($fx- n2 1))
|
||||
(set-hasht-vec! h vec2)))
|
||||
(define (enlarge-hashtable h hashf)
|
||||
(define insert-b
|
||||
(lambda (b vec mask)
|
||||
(let* ([x ($tcbucket-key b)]
|
||||
[ih (hashf x)]
|
||||
[idx (bitwise-and ih mask)]
|
||||
[next ($tcbucket-next b)])
|
||||
($set-tcbucket-next! b ($vector-ref vec idx))
|
||||
($vector-set! vec idx b)
|
||||
(unless (fixnum? next)
|
||||
(insert-b next vec mask)))))
|
||||
(define move-all
|
||||
(lambda (vec1 i n vec2 mask)
|
||||
(unless ($fx= i n)
|
||||
(let ([b ($vector-ref vec1 i)])
|
||||
(unless (fixnum? b)
|
||||
(insert-b b vec2 mask))
|
||||
(move-all vec1 ($fxadd1 i) n vec2 mask)))))
|
||||
(let* ([vec1 (hasht-vec h)]
|
||||
[n1 ($vector-length vec1)]
|
||||
[n2 ($fxsll n1 1)]
|
||||
[vec2 (make-base-vec n2)])
|
||||
(move-all vec1 0 n1 vec2 ($fx- n2 1))
|
||||
(set-hasht-vec! h vec2)))
|
||||
(cond
|
||||
[(hasht-hashf h) =>
|
||||
(lambda (hashf)
|
||||
(enlarge-hashtable h hashf))]
|
||||
[else
|
||||
(enlarge-eq-table h)])))
|
||||
|
||||
(define init-vec
|
||||
(lambda (v i n)
|
||||
|
|
@ -278,9 +346,9 @@
|
|||
|
||||
(define (hasht-copy h mutable?)
|
||||
(define (dup-hasht h mutable? n)
|
||||
(let ([x (cons #f #f)])
|
||||
(let ([tc (cons x x)])
|
||||
(make-hasht (make-base-vec n) 0 tc mutable?))))
|
||||
(let* ([hashf (hasht-hashf h)]
|
||||
[tc (and hashf (let ([x (cons #f #f)]) (cons x x)))])
|
||||
(make-hasht (make-base-vec n) 0 tc mutable? hashf (hasht-equivf h))))
|
||||
(let ([v (hasht-vec h)] [n (hasht-count h)])
|
||||
(let ([r (dup-hasht h mutable? (vector-length v))])
|
||||
(let f ([i ($fxsub1 n)] [j ($fxsub1 (vector-length v))] [r r] [v v])
|
||||
|
|
@ -306,13 +374,36 @@
|
|||
[()
|
||||
(let ([x (cons #f #f)])
|
||||
(let ([tc (cons x x)])
|
||||
(make-hasht (make-base-vec 32) 0 tc #t)))]
|
||||
[(k)
|
||||
(if (and (or (fixnum? k) (bignum? k))
|
||||
(>= k 0))
|
||||
(make-hasht (make-base-vec 32) 0 tc #t #f eq?)))]
|
||||
[(k)
|
||||
(if (and (or (fixnum? k) (bignum? k)) (>= k 0))
|
||||
(make-eq-hashtable)
|
||||
(die 'make-eq-hashtable
|
||||
"invalid initial capacity" k))]))
|
||||
(die 'make-eq-hashtable "invalid initial capacity" k))]))
|
||||
|
||||
(define make-hashtable
|
||||
(case-lambda
|
||||
[(hashf equivf) (make-hashtable hashf equivf 0)]
|
||||
[(hashf equivf k)
|
||||
(define who 'make-hashtable)
|
||||
(define (wrap f)
|
||||
(cond
|
||||
[(or (eq? f symbol-hash)
|
||||
(eq? f string-hash)
|
||||
(eq? f string-ci-hash))
|
||||
f]
|
||||
[else
|
||||
(lambda (k)
|
||||
(let ([i (f k)])
|
||||
(if (and (or (fixnum? i) (bignum? i)) (>= i 0))
|
||||
i
|
||||
(die #f "invalid return value from hash function" i))))]))
|
||||
(unless (procedure? hashf)
|
||||
(die who "hash function is not a procedure" hashf))
|
||||
(unless (procedure? equivf)
|
||||
(die who "equivalence function is not a procedure" equivf))
|
||||
(if (and (or (fixnum? k) (bignum? k)) (>= k 0))
|
||||
(make-hasht (make-base-vec 32) 0 #f #t (wrap hashf) equivf)
|
||||
(die who "invalid initial capacity" k))]))
|
||||
|
||||
(define hashtable-ref
|
||||
(lambda (h x v)
|
||||
|
|
@ -357,11 +448,11 @@
|
|||
(if (hasht? h)
|
||||
(if (hasht-mutable? h)
|
||||
(del-hash h x)
|
||||
(die 'hashtable-delete! "hashtable is immutable" h))
|
||||
(die 'hashtable-delete! "hash table is immutable" h))
|
||||
(die 'hashtable-delete! "not a hash table" h))))
|
||||
|
||||
(define (hashtable-entries h)
|
||||
(if (hasht? h)
|
||||
(if (hasht? h)
|
||||
(get-entries h)
|
||||
(die 'hashtable-entries "not a hash table" h)))
|
||||
|
||||
|
|
@ -379,14 +470,14 @@
|
|||
(if (hasht? h)
|
||||
(if (hasht-mutable? h)
|
||||
(clear-hash! h)
|
||||
(die 'hashtable-clear! "hashtable is immutable" h))
|
||||
(die 'hashtable-clear! "hash table is immutable" h))
|
||||
(die 'hashtable-clear! "not a hash table" h)))
|
||||
|
||||
(define hashtable-copy
|
||||
(case-lambda
|
||||
[(h)
|
||||
(if (hasht? h)
|
||||
(if (hasht-mutable? h)
|
||||
(if (hasht-mutable? h)
|
||||
(hasht-copy h #f)
|
||||
h)
|
||||
(die 'hashtable-copy "not a hash table" h))]
|
||||
|
|
@ -397,8 +488,18 @@
|
|||
h)
|
||||
(die 'hashtable-copy "not a hash table" h))]))
|
||||
|
||||
(define (hashtable-equivalence-function h)
|
||||
(if (hasht? h)
|
||||
(hasht-equivf h)
|
||||
(die 'hashtable-equivalence-function "not a hash table" h)))
|
||||
|
||||
(define (hashtable-hash-function h)
|
||||
(if (hasht? h)
|
||||
(hasht-hashf h)
|
||||
(die 'hashtable-hash-function "not a hash table" h)))
|
||||
|
||||
(define (string-hash s)
|
||||
(if (string? s)
|
||||
(if (string? s)
|
||||
(foreign-call "ikrt_string_hash" s)
|
||||
(die 'string-hash "not a string" s)))
|
||||
|
||||
|
|
|
|||
|
|
@ -7,9 +7,8 @@
|
|||
make-custom-textual-input/output-port
|
||||
open-file-input/output-port output-port-buffer-mode
|
||||
port-has-set-port-position!?
|
||||
set-port-position! make-eqv-hashtable
|
||||
hashtable-hash-function make-hashtable
|
||||
hashtable-equivalence-function equal-hash
|
||||
set-port-position!
|
||||
make-eqv-hashtable equal-hash
|
||||
string-normalize-nfc string-normalize-nfd
|
||||
string-normalize-nfkc string-normalize-nfkd string-titlecase
|
||||
)
|
||||
|
|
@ -21,9 +20,8 @@
|
|||
make-custom-textual-input/output-port
|
||||
open-file-input/output-port output-port-buffer-mode
|
||||
port-has-set-port-position!?
|
||||
set-port-position! make-eqv-hashtable
|
||||
hashtable-hash-function make-hashtable
|
||||
hashtable-equivalence-function equal-hash
|
||||
set-port-position!
|
||||
make-eqv-hashtable equal-hash
|
||||
string-normalize-nfc string-normalize-nfd
|
||||
string-normalize-nfkc string-normalize-nfkd string-titlecase
|
||||
))
|
||||
|
|
@ -56,8 +54,7 @@
|
|||
bitwise-rotate-bit-field bitwise-reverse-bit-field
|
||||
fxreverse-bit-field
|
||||
;;; not top priority at the moment
|
||||
make-eqv-hashtable make-hashtable equal-hash
|
||||
hashtable-hash-function hashtable-equivalence-function
|
||||
make-eqv-hashtable equal-hash
|
||||
string-normalize-nfc string-normalize-nfd
|
||||
string-normalize-nfkc string-normalize-nfkd
|
||||
;;; won't be implemented
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1638
|
||||
1641
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@
|
|||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
this-file-is-out-of-date!
|
||||
(import (ikarus))
|
||||
|
||||
;;; library names:
|
||||
|
|
|
|||
Loading…
Reference in New Issue