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

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

@ -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)
(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)))))))
(rehash-lookup h (hasht-tc h) x))))))]))
(define (get-hash h x v)
(cond
@ -156,6 +174,26 @@
(define put-hash!
(lambda (h x v)
(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])
@ -169,7 +207,8 @@
(void))]
[else
(let ([bucket
($make-tcbucket (hasht-tc h) x v ($vector-ref vec idx))])
($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)]
@ -180,7 +219,7 @@
(let ([ct (hasht-count h)])
(set-hasht-count! h ($fxadd1 ct))
(when ($fx> ct ($vector-length vec))
(enlarge-table h)))])))))))
(enlarge-table h)))])))))])))
(define (update-hash! h x proc default)
(cond
@ -188,6 +227,9 @@
(lambda (b) ($set-tcbucket-val! b (proc ($tcbucket-val b))))]
[else (put-hash! h x (proc default))]))
(define enlarge-table
(lambda (h)
(define (enlarge-eq-table h)
(define insert-b
(lambda (b vec mask)
(let* ([x ($tcbucket-key b)]
@ -199,7 +241,6 @@
($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)
@ -207,15 +248,42 @@
(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))))
(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)))]
(make-hasht (make-base-vec 32) 0 tc #t #f eq?)))]
[(k)
(if (and (or (fixnum? k) (bignum? k))
(>= k 0))
(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,7 +448,7 @@
(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)
@ -379,7 +470,7 @@
(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
@ -397,6 +488,16 @@
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)
(foreign-call "ikrt_string_hash" s)

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

@ -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

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/>.
this-file-is-out-of-date!
(import (ikarus))
;;; library names: