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

added make-eqv-hashtable

This commit is contained in:
Abdulaziz Ghuloum 2008-10-31 23:09:03 -04:00
parent 8afcbbef67
commit 671eba4990
4 changed files with 87 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,7 +15,7 @@
(library (ikarus hash-tables)
(export make-eq-hashtable make-hashtable
(export make-eq-hashtable make-eqv-hashtable make-hashtable
hashtable-ref hashtable-set! hashtable?
hashtable-size hashtable-delete! hashtable-contains?
hashtable-update! hashtable-keys hashtable-mutable?
@ -28,7 +28,7 @@
(ikarus system $tcbuckets)
(ikarus system $fx)
(except (ikarus)
make-eq-hashtable make-hashtable
make-eq-hashtable make-eqv-hashtable make-hashtable
hashtable-ref hashtable-set! hashtable?
hashtable-size hashtable-delete! hashtable-contains?
hashtable-update! hashtable-keys hashtable-mutable?
@ -117,18 +117,21 @@
(void))))))))
(define (get-bucket h x)
(define (get-hashed h x ih)
(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))])))))
(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))]))))))]
(get-hashed h x (hashf x)))]
[(and (eq? eqv? (hasht-equivf h)) (number? x))
(get-hashed h x (number-hash x))]
[else
(let ([pv (pointer-value x)]
[vec (hasht-vec h)])
@ -167,32 +170,35 @@
($set-tcbucket-next! b #f))))
(cond
[(get-bucket h x) =>
(lambda (b)
(lambda (b)
(unlink! h b)
;;; don't forget the count.
(set-hasht-count! h (- (hasht-count h) 1)))]))
(define put-hash!
(lambda (h x v)
(define (put-hashed h x v ih)
(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))])))))
(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))]))))))]
(put-hashed h x v (hashf x)))]
[(and (eq? eqv? (hasht-equivf h)) (number? x))
(put-hashed h x v (number-hash x))]
[else
(let ([pv (pointer-value x)]
[vec (hasht-vec h)])
@ -229,31 +235,6 @@
(define enlarge-table
(lambda (h)
(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)
@ -282,8 +263,15 @@
[(hasht-hashf h) =>
(lambda (hashf)
(enlarge-hashtable h hashf))]
[(eq? eq? (hasht-equivf h))
(enlarge-hashtable h
(lambda (x) (pointer-value x)))]
[else
(enlarge-eq-table h)])))
(enlarge-hashtable h
(lambda (x)
(if (number? x)
(number-hash x)
(pointer-value x))))])))
(define init-vec
(lambda (v i n)
@ -300,9 +288,10 @@
(define (clear-hash! h)
(let ([v (hasht-vec h)])
(init-vec v 0 (vector-length v)))
(set-hasht-tc! h
(let ([x (cons #f #f)])
(cons x x)))
(unless (hasht-hashf h)
(set-hasht-tc! h
(let ([x (cons #f #f)])
(cons x x))))
(set-hasht-count! h 0))
(define (get-keys h)
@ -347,7 +336,7 @@
(define (hasht-copy h mutable?)
(define (dup-hasht h mutable? n)
(let* ([hashf (hasht-hashf h)]
[tc (and hashf (let ([x (cons #f #f)]) (cons x x)))])
[tc (and (not 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))])
@ -380,6 +369,17 @@
(make-eq-hashtable)
(die 'make-eq-hashtable "invalid initial capacity" k))]))
(define make-eqv-hashtable
(case-lambda
[()
(let ([x (cons #f #f)])
(let ([tc (cons x x)])
(make-hasht (make-base-vec 32) 0 tc #t #f eqv?)))]
[(k)
(if (and (or (fixnum? k) (bignum? k)) (>= k 0))
(make-eqv-hashtable)
(die 'make-eqv-hashtable "invalid initial capacity" k))]))
(define make-hashtable
(case-lambda
[(hashf equivf) (make-hashtable hashf equivf 0)]
@ -514,4 +514,18 @@
(foreign-call "ikrt_string_hash" (symbol->string s))
(die 'symbol-hash "not a symbol" s)))
(define (number-hash x)
(cond
[(fixnum? x) x]
[(flonum? x) (foreign-call "ikrt_flonum_hash" x)]
[(bignum? x) (foreign-call "ikrt_bignum_hash" x)]
[(ratnum? x)
(fxxor
(number-hash (numerator x))
(number-hash (denominator x)))]
[else
(fxxor
(number-hash (real-part x))
(number-hash (imag-part x)))]))
)

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

@ -8,7 +8,7 @@
open-file-input/output-port output-port-buffer-mode
port-has-set-port-position!?
set-port-position!
make-eqv-hashtable equal-hash
equal-hash
)
(import (except (ikarus)
@ -19,7 +19,7 @@
open-file-input/output-port output-port-buffer-mode
port-has-set-port-position!?
set-port-position!
make-eqv-hashtable equal-hash
equal-hash
))
(define-syntax not-yet
@ -49,7 +49,7 @@
bitwise-rotate-bit-field bitwise-reverse-bit-field
fxreverse-bit-field
;;; not top priority at the moment
make-eqv-hashtable equal-hash
equal-hash
;;; won't be implemented
make-custom-binary-input/output-port
make-custom-textual-input/output-port

2
scheme/last-revision
View File

@ -1 +1 @@
1655
1656

11
src/ikarus-numerics.c
View File

@ -2122,3 +2122,14 @@ ikrt_exact_bignum_sqrt(ikptr bn, ikpcb* pcb){
}
ikptr
ikrt_flonum_hash(ikptr x /*, ikpcb* pcb */) {
return fix(0);
}
ikptr
ikrt_bignum_hash(ikptr x /*, ikpcb* pcb */) {
return fix(0);
}