conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

added make-hashtable.

This commit is contained in:
Abdulaziz Ghuloum 2008-10-21 05:52:42 -04:00
parent d8058e0cbf
commit 8d460a32af
4 changed files with 183 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

251
scheme/ikarus.hash-tables.ss
View File

@ -15,23 +15,28 @@
(library (ikarus hash-tables) (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-size hashtable-delete! hashtable-contains?
hashtable-update! hashtable-keys hashtable-mutable? hashtable-update! hashtable-keys hashtable-mutable?
hashtable-clear! hashtable-entries hashtable-copy hashtable-clear! hashtable-entries hashtable-copy
hashtable-equivalence-function hashtable-hash-function
string-hash string-ci-hash symbol-hash) string-hash string-ci-hash symbol-hash)
(import (import
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $vectors) (ikarus system $vectors)
(ikarus system $tcbuckets) (ikarus system $tcbuckets)
(ikarus system $fx) (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-size hashtable-delete! hashtable-contains?
hashtable-update! hashtable-keys hashtable-mutable? hashtable-update! hashtable-keys hashtable-mutable?
hashtable-clear! hashtable-entries hashtable-copy hashtable-clear! hashtable-entries hashtable-copy
hashtable-equivalence-function hashtable-hash-function
string-hash string-ci-hash symbol-hash)) 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 ;;; directly from Dybvig's paper
(define tc-pop (define tc-pop
@ -112,13 +117,26 @@
(void)))))))) (void))))))))
(define (get-bucket h x) (define (get-bucket h x)
(let ([pv (pointer-value x)] (cond
[vec (hasht-vec h)]) [(hasht-hashf h) =>
(let ([ih pv]) (lambda (hashf)
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) (let ([ih (hashf x)])
(let ([b ($vector-ref vec idx)]) (let ([equiv? (hasht-equivf h)]
(or (direct-lookup x b) [vec (hasht-vec h)])
(rehash-lookup h (hasht-tc h) x))))))) (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) (define (get-hash h x v)
(cond (cond
@ -156,31 +174,52 @@
(define put-hash! (define put-hash!
(lambda (h x v) (lambda (h x v)
(let ([pv (pointer-value x)] (cond
[vec (hasht-vec h)]) [(hasht-hashf h) =>
(let ([ih pv]) (lambda (hashf)
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))]) (let ([ih (hashf x)])
(let ([b ($vector-ref vec idx)]) (let ([equiv? (hasht-equivf h)]
(cond [vec (hasht-vec h)])
[(or (direct-lookup x b) (rehash-lookup h (hasht-tc h) x)) (let ([idx (bitwise-and ih ($fx- ($vector-length vec) 1))])
=> (let f ([b ($vector-ref vec idx)])
(lambda (b) (cond
($set-tcbucket-val! b v) [(fixnum? b)
(void))] ($vector-set! vec idx
[else (vector x v ($vector-ref vec idx)))
(let ([bucket (let ([ct (hasht-count h)])
($make-tcbucket (hasht-tc h) x v ($vector-ref vec idx))]) (set-hasht-count! h ($fxadd1 ct))
(if ($fx= (pointer-value x) pv) (when ($fx> ct ($vector-length vec))
($vector-set! vec idx bucket) (enlarge-table h)))]
(let* ([ih (pointer-value x)] [(equiv? x ($tcbucket-key b))
[idx ($set-tcbucket-val! b v)]
($fxlogand ih ($fx- ($vector-length vec) 1))]) [else (f ($tcbucket-next b))]))))))]
($set-tcbucket-next! bucket ($vector-ref vec idx)) [else
($vector-set! vec idx bucket)))) (let ([pv (pointer-value x)]
(let ([ct (hasht-count h)]) [vec (hasht-vec h)])
(set-hasht-count! h ($fxadd1 ct)) (let ([ih pv])
(when ($fx> ct ($vector-length vec)) (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
(enlarge-table h)))]))))))) (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) (define (update-hash! h x proc default)
(cond (cond
@ -188,34 +227,63 @@
(lambda (b) ($set-tcbucket-val! b (proc ($tcbucket-val b))))] (lambda (b) ($set-tcbucket-val! b (proc ($tcbucket-val b))))]
[else (put-hash! h x (proc default))])) [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 (define enlarge-table
(lambda (h) (lambda (h)
(let* ([vec1 (hasht-vec h)] (define (enlarge-eq-table h)
[n1 ($vector-length vec1)] (define insert-b
[n2 ($fxsll n1 1)] (lambda (b vec mask)
[vec2 (make-base-vec n2)]) (let* ([x ($tcbucket-key b)]
(move-all vec1 0 n1 vec2 ($fx- n2 1)) [pv (pointer-value x)]
(set-hasht-vec! h vec2)))) [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 (define init-vec
(lambda (v i n) (lambda (v i n)
@ -278,9 +346,9 @@
(define (hasht-copy h mutable?) (define (hasht-copy h mutable?)
(define (dup-hasht h mutable? n) (define (dup-hasht h mutable? n)
(let ([x (cons #f #f)]) (let* ([hashf (hasht-hashf h)]
(let ([tc (cons x x)]) [tc (and hashf (let ([x (cons #f #f)]) (cons x x)))])
(make-hasht (make-base-vec n) 0 tc mutable?)))) (make-hasht (make-base-vec n) 0 tc mutable? hashf (hasht-equivf h))))
(let ([v (hasht-vec h)] [n (hasht-count h)]) (let ([v (hasht-vec h)] [n (hasht-count h)])
(let ([r (dup-hasht h mutable? (vector-length v))]) (let ([r (dup-hasht h mutable? (vector-length v))])
(let f ([i ($fxsub1 n)] [j ($fxsub1 (vector-length v))] [r r] [v 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 ([x (cons #f #f)])
(let ([tc (cons x x)]) (let ([tc (cons x x)])
(make-hasht (make-base-vec 32) 0 tc #t)))] (make-hasht (make-base-vec 32) 0 tc #t #f eq?)))]
[(k) [(k)
(if (and (or (fixnum? k) (bignum? k)) (if (and (or (fixnum? k) (bignum? k)) (>= k 0))
(>= k 0))
(make-eq-hashtable) (make-eq-hashtable)
(die 'make-eq-hashtable (die 'make-eq-hashtable "invalid initial capacity" k))]))
"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 (define hashtable-ref
(lambda (h x v) (lambda (h x v)
@ -357,11 +448,11 @@
(if (hasht? h) (if (hasht? h)
(if (hasht-mutable? h) (if (hasht-mutable? h)
(del-hash h x) (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)))) (die 'hashtable-delete! "not a hash table" h))))
(define (hashtable-entries h) (define (hashtable-entries h)
(if (hasht? h) (if (hasht? h)
(get-entries h) (get-entries h)
(die 'hashtable-entries "not a hash table" h))) (die 'hashtable-entries "not a hash table" h)))
@ -379,14 +470,14 @@
(if (hasht? h) (if (hasht? h)
(if (hasht-mutable? h) (if (hasht-mutable? h)
(clear-hash! 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))) (die 'hashtable-clear! "not a hash table" h)))
(define hashtable-copy (define hashtable-copy
(case-lambda (case-lambda
[(h) [(h)
(if (hasht? h) (if (hasht? h)
(if (hasht-mutable? h) (if (hasht-mutable? h)
(hasht-copy h #f) (hasht-copy h #f)
h) h)
(die 'hashtable-copy "not a hash table" h))] (die 'hashtable-copy "not a hash table" h))]
@ -397,8 +488,18 @@
h) h)
(die 'hashtable-copy "not a hash table" 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) (define (string-hash s)
(if (string? s) (if (string? s)
(foreign-call "ikrt_string_hash" s) (foreign-call "ikrt_string_hash" s)
(die 'string-hash "not a string" s))) (die 'string-hash "not a string" s)))

13
scheme/ikarus.not-yet-implemented.ss
View File

@ -7,9 +7,8 @@
make-custom-textual-input/output-port make-custom-textual-input/output-port
open-file-input/output-port output-port-buffer-mode open-file-input/output-port output-port-buffer-mode
port-has-set-port-position!? port-has-set-port-position!?
set-port-position! make-eqv-hashtable set-port-position!
hashtable-hash-function make-hashtable make-eqv-hashtable equal-hash
hashtable-equivalence-function equal-hash
string-normalize-nfc string-normalize-nfd string-normalize-nfc string-normalize-nfd
string-normalize-nfkc string-normalize-nfkd string-titlecase string-normalize-nfkc string-normalize-nfkd string-titlecase
) )
@ -21,9 +20,8 @@
make-custom-textual-input/output-port make-custom-textual-input/output-port
open-file-input/output-port output-port-buffer-mode open-file-input/output-port output-port-buffer-mode
port-has-set-port-position!? port-has-set-port-position!?
set-port-position! make-eqv-hashtable set-port-position!
hashtable-hash-function make-hashtable make-eqv-hashtable equal-hash
hashtable-equivalence-function equal-hash
string-normalize-nfc string-normalize-nfd string-normalize-nfc string-normalize-nfd
string-normalize-nfkc string-normalize-nfkd string-titlecase string-normalize-nfkc string-normalize-nfkd string-titlecase
)) ))
@ -56,8 +54,7 @@
bitwise-rotate-bit-field bitwise-reverse-bit-field bitwise-rotate-bit-field bitwise-reverse-bit-field
fxreverse-bit-field fxreverse-bit-field
;;; not top priority at the moment ;;; not top priority at the moment
make-eqv-hashtable make-hashtable equal-hash make-eqv-hashtable equal-hash
hashtable-hash-function hashtable-equivalence-function
string-normalize-nfc string-normalize-nfd string-normalize-nfc string-normalize-nfd
string-normalize-nfkc string-normalize-nfkd string-normalize-nfkc string-normalize-nfkd
;;; won't be implemented ;;; won't be implemented

2
scheme/last-revision
View File

@ -1 +1 @@
1638 1641

1
scheme/todo-r6rs.ss
View File

@ -15,6 +15,7 @@
;;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
this-file-is-out-of-date!
(import (ikarus)) (import (ikarus))
;;; library names: ;;; library names: