175 lines
5.4 KiB
Scheme
175 lines
5.4 KiB
Scheme
|
|
(library (ikarus hash-tables)
|
|
(export hash-table? make-hash-table get-hash-table put-hash-table!)
|
|
(import
|
|
(except (ikarus) hash-table? make-hash-table
|
|
get-hash-table put-hash-table!))
|
|
|
|
(define-syntax inthash
|
|
(syntax-rules ()
|
|
[(_ x) x]))
|
|
|
|
(define-record hasht (vec count gckey))
|
|
|
|
(define stretch
|
|
(lambda (h v n)
|
|
(set-hasht-gckey! h (collect-key))
|
|
(let ([newv (make-vector (fx* n 2) '())]
|
|
[mask (fx- (* n 2) 1)])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n))
|
|
(let f ([b (vector-ref v i)])
|
|
(unless (null? b)
|
|
(let ([idx (fxlogand (inthash (pointer-value (caar b))) mask)]
|
|
[next (cdr b)])
|
|
(set-cdr! b (vector-ref newv idx))
|
|
(vector-set! newv idx b)
|
|
(f next)))))
|
|
(set-hasht-vec! h newv))))
|
|
|
|
(define rehash
|
|
(lambda (h v)
|
|
(set-hasht-gckey! h (collect-key))
|
|
(let ([n (vector-length v)])
|
|
(let f ([i 0])
|
|
(if (fx= i n)
|
|
(void)
|
|
(let ([b (vector-ref v i)])
|
|
(if (null? b)
|
|
(f (fx+ i 1))
|
|
(begin
|
|
(vector-set! v i '())
|
|
(let g ([i (fx+ i 1)] [loc (last-pair b)])
|
|
(if (fx= i n)
|
|
(let ([mask (fx- n 1)])
|
|
(void)
|
|
(let f ([b b])
|
|
(unless (null? b)
|
|
(let ([idx (fxlogand (inthash (pointer-value (caar b))) mask)])
|
|
(let ([next (cdr b)])
|
|
(set-cdr! b (vector-ref v idx))
|
|
(vector-set! v idx b)
|
|
(f next))))))
|
|
(let ([b (vector-ref v i)])
|
|
(if (null? b)
|
|
(g (fx+ i 1) loc)
|
|
(begin
|
|
(vector-set! v i '())
|
|
(set-cdr! loc b)
|
|
(g (fx+ i 1) (last-pair b)))))))))))))))
|
|
|
|
(define get-hash
|
|
(lambda (h x v)
|
|
(let ([pv (pointer-value x)]
|
|
[vec (hasht-vec h)])
|
|
(let ([ih (inthash pv)])
|
|
(let ([idx (fxlogand ih (fx- (vector-length vec) 1))])
|
|
(let ([b (vector-ref vec idx)])
|
|
(cond
|
|
[(assq x b) => cdr]
|
|
[(not (eq? (hasht-gckey h) (collect-key)))
|
|
(rehash h vec)
|
|
(get-hash h x v)]
|
|
[else v])))))))
|
|
|
|
(define put-hash!
|
|
(lambda (h x v)
|
|
(let ([pv (pointer-value x)]
|
|
[vec (hasht-vec h)])
|
|
(let ([ih (inthash pv)])
|
|
(let ([idx (fxlogand ih (fx- (vector-length vec) 1))])
|
|
(let ([b (vector-ref vec idx)])
|
|
(cond
|
|
[(assq x b) => (lambda (a) (set-cdr! a v))]
|
|
[(not (eq? (hasht-gckey h) (collect-key)))
|
|
(rehash h vec)
|
|
(put-hash! h x v)]
|
|
[else
|
|
(vector-set! vec idx (cons (cons x v) b))
|
|
(let ([ct (hasht-count h)])
|
|
(set-hasht-count! h (fxadd1 ct))
|
|
(let ([n (vector-length vec)])
|
|
(when (fx> ct n)
|
|
(stretch h vec n))))])))))))
|
|
|
|
;;; public interface
|
|
(define (hash-table? x) (hasht? x))
|
|
|
|
(define (make-hash-table)
|
|
(make-hasht (make-vector 32 '()) 0 (collect-key)))
|
|
|
|
(define get-hash-table
|
|
(lambda (h x v)
|
|
(if (hasht? h)
|
|
(get-hash h x v)
|
|
(error 'get-hash-table "~s is not a hash table" h))))
|
|
|
|
(define put-hash-table!
|
|
(lambda (h x v)
|
|
(if (hasht? h)
|
|
(put-hash! h x v)
|
|
(error 'put-hash-table! "~s is not a hash table" h))))
|
|
)
|
|
|
|
#!eof
|
|
|
|
(import rht)
|
|
|
|
(define (test1)
|
|
(printf "test1 ...\n")
|
|
(let ([ls (let f ([i 100000] [ac '()])
|
|
(cond
|
|
[(fx= i 0) ac]
|
|
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
|
(let ([ht (make-hash-table)])
|
|
(for-each (lambda (x) (put-hash-table! ht x x)) ls)
|
|
(let f ([i 1000])
|
|
(unless (fx= i 0)
|
|
(collect)
|
|
(f (fx- i 1))))
|
|
(for-each
|
|
(lambda (x)
|
|
(unless (eq? x (get-hash-table ht x #f))
|
|
(error 'test1 "failed")))
|
|
ls)))
|
|
(printf "passed test1\n"))
|
|
|
|
(define (test2)
|
|
(printf "test2 ...\n")
|
|
(let ([ls (let f ([i 10000] [ac '()])
|
|
(cond
|
|
[(fx= i 0) ac]
|
|
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
|
(let ([ht (make-hash-table)])
|
|
(for-each (lambda (x) (put-hash-table! ht x x)) ls)
|
|
(for-each
|
|
(lambda (x)
|
|
(collect)
|
|
(unless (eq? x (get-hash-table ht x #f))
|
|
(error 'test2 "failed")))
|
|
ls)))
|
|
(printf "passed test2\n"))
|
|
|
|
(define (test3)
|
|
(printf "test3 ...\n")
|
|
(let ([ls (let f ([i 10000] [ac '()])
|
|
(cond
|
|
[(fx= i 0) ac]
|
|
[else (f (fx- i 1) (cons (cons i i) ac))]))])
|
|
(let ([ht (make-hash-table)])
|
|
(for-each (lambda (x)
|
|
(collect)
|
|
(put-hash-table! ht x x))
|
|
ls)
|
|
(for-each
|
|
(lambda (x)
|
|
(unless (eq? x (get-hash-table ht x #f))
|
|
(error 'test3 "failed")))
|
|
ls)))
|
|
(printf "passed test3\n"))
|
|
|
|
(define (test-all)
|
|
(test1)
|
|
(test2)
|
|
(test3))
|