diff --git a/src/ikarus.boot b/src/ikarus.boot index e95966d..13647e4 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.hash-tables.ss b/src/ikarus.hash-tables.ss index 497fc15..5c4fa67 100644 --- a/src/ikarus.hash-tables.ss +++ b/src/ikarus.hash-tables.ss @@ -2,7 +2,8 @@ (library (ikarus hash-tables) (export make-eq-hashtable hashtable-ref hashtable-set! hashtable? hashtable-size hashtable-delete! hashtable-contains? - hashtable-update!) + hashtable-update! hashtable-keys hashtable-mutable? + hashtable-clear!) (import (ikarus system $pairs) (ikarus system $vectors) @@ -10,9 +11,10 @@ (ikarus system $fx) (except (ikarus) make-eq-hashtable hashtable-ref hashtable-set! hashtable? hashtable-size hashtable-delete! hashtable-contains? - hashtable-update!)) + hashtable-update! hashtable-keys hashtable-mutable? + hashtable-clear!)) - (define-record hasht (vec count tc)) + (define-record hasht (vec count tc mutable?)) ;;; directly from Dybvig's paper (define tc-pop @@ -216,6 +218,33 @@ (lambda (n) (init-vec (make-vector n) 0 n))) + (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))) + (set-hasht-count! h 0)) + + (define (get-keys h) + (let ([v (hasht-vec h)] [n (hasht-count h)]) + (let ([kv (make-vector n)]) + (let f ([i ($fxsub1 n)] [j ($fxsub1 (vector-length v))] [kv kv] [v v]) + (cond + [($fx= i -1) kv] + [else + (let ([b ($vector-ref v j)]) + (if (fixnum? b) + (f i ($fxsub1 j) kv v) + (f (let f ([i i] [b b] [kv kv]) + ($vector-set! kv i ($tcbucket-key b)) + (let ([b ($tcbucket-next b)] + [i ($fxsub1 i)]) + (cond + [(fixnum? b) i] + [else (f i b kv)]))) + ($fxsub1 j) kv v)))]))))) + ;;; public interface (define (hashtable? x) (hasht? x)) @@ -224,7 +253,7 @@ [() (let ([x (cons #f #f)]) (let ([tc (cons x x)]) - (make-hasht (make-base-vec 32) 0 tc)))] + (make-hasht (make-base-vec 32) 0 tc #t)))] [(k) (if (and (or (fixnum? k) (bignum? k)) (>= k 0)) @@ -248,16 +277,20 @@ (define hashtable-set! (lambda (h x v) (if (hasht? h) - (put-hash! h x v) + (if (hasht-mutable? h) + (put-hash! h x v) + (error 'hashtable-set! "~s is immutable" h)) (error 'hashtable-set! "~s is not a hash table" h)))) (define hashtable-update! (lambda (h x proc default) (if (hasht? h) - (if (procedure? proc) - (update-hash! h x proc default) - (error 'hashtable-update! "~s is not a procedure" proc)) + (if (hasht-mutable? h) + (if (procedure? proc) + (update-hash! h x proc default) + (error 'hashtable-update! "~s is not a procedure" proc)) + (error 'hashtable-update! "~s is immutable" h)) (error 'hashtable-update! "~s is not a hash table" h)))) @@ -272,9 +305,25 @@ ;;; FIXME: should shrink table if number of keys drops below ;;; (sqrt (vector-length (hasht-vec h))) (if (hasht? h) - (del-hash h x) + (if (hasht-mutable? h) + (del-hash h x) + (error 'hashtable-delete! "~s is immutable" h)) (error 'hashtable-delete! "~s is not a hash table" h)))) - + (define (hashtable-keys h) + (if (hasht? h) + (get-keys h) + (error 'hashtable-keys "~s is not a hash table" h))) + (define (hashtable-mutable? h) + (if (hasht? h) + (hasht-mutable? h) + (error 'hashtable-mutable? "~s is not a hash table" h))) + + (define (hashtable-clear! h) + (if (hasht? h) + (if (hasht-mutable? h) + (clear-hash! h) + (error 'hashtable-clear! "~s is immutable" h)) + (error 'hashtable-clear! "~s is not a hash table" h))) ) diff --git a/src/run-tests.ss b/src/run-tests.ss index 516420d..8b6603c 100755 --- a/src/run-tests.ss +++ b/src/run-tests.ss @@ -5,6 +5,7 @@ (tests lists) (tests bytevectors) (tests strings) + (tests hashtables) ;(tests numbers) ;(tests bignums) (tests fxcarry) @@ -34,4 +35,5 @@ ;(test-bignums) (test-fxcarry) (test-lists) +(test-hashtables) (printf "Happy Happy Joy Joy\n") diff --git a/src/tests/hashtables.ss b/src/tests/hashtables.ss new file mode 100644 index 0000000..d35e3dc --- /dev/null +++ b/src/tests/hashtables.ss @@ -0,0 +1,15 @@ +(library (tests hashtables) + (export test-hashtables) + (import + (ikarus) + (rnrs hashtables) + (tests framework)) + + (define-tests test-hashtables + [values + (let ([h (make-eq-hashtable)]) + (hashtable-set! h 'foo 12) + (hashtable-set! h 'bar 13) + (or (equal? (hashtable-keys h) '#(foo bar)) + (equal? (hashtable-keys h) '#(bar foo))))])) + diff --git a/src/todo-r6rs.ss b/src/todo-r6rs.ss index 65a6608..f18b46d 100755 --- a/src/todo-r6rs.ss +++ b/src/todo-r6rs.ss @@ -666,13 +666,13 @@ [call-with-input-file C is se] [call-with-output-file C is se] ;;; - [hashtable-clear! S ht] + [hashtable-clear! C ht] [hashtable-contains? C ht] [hashtable-copy S ht] [hashtable-delete! C ht] [hashtable-entries S ht] - [hashtable-keys S ht] - [hashtable-mutable? S ht] + [hashtable-keys C ht] + [hashtable-mutable? C ht] [hashtable-ref C ht] [hashtable-set! C ht] [hashtable-size C ht]