* Added one hashtable test.

* Added hashtable-mutable?
* Added hashtable-clear!

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)
+          (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 (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)
+          (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)))
 )

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")

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))))]))
+

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-keys                             C ht]
-    [hashtable-mutable?                         S ht]
+    [hashtable-mutable?                         C ht]
     [hashtable-ref                              C ht]
     [hashtable-set!                             C ht]
     [hashtable-size                             C ht]