* Added hashtable-size, hashtable-delete!, hashtable-contains?, and

hashtable-update!

src/ikarus.hash-tables.ss

@@ -1,12 +1,16 @@
 
 (library (ikarus hash-tables)
-   (export make-eq-hashtable hashtable-ref hashtable-set! hashtable?)
+   (export make-eq-hashtable hashtable-ref hashtable-set! hashtable?
+           hashtable-size hashtable-delete! hashtable-contains?
+           hashtable-update!)
    (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 hashtable-ref hashtable-set! hashtable?
+             hashtable-size hashtable-delete! hashtable-contains?
+             hashtable-update!))
 
    (define-record hasht (vec count tc))
 
@@ -92,20 +96,47 @@
                 ($vector-set! vec idx b)
                 (void))))))))
 
-  (define get-hash
+
-    (lambda (h x v)
+  (define unlink! 
-      (let ([pv (pointer-value x)]
+    (lambda (h b)
-            [vec (hasht-vec h)])
+      (let ([vec (hasht-vec h)]
-        (let ([ih (inthash pv)])
+            [next ($tcbucket-next b)])
-          (let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
+        ;;; first remove it from its old place
-            (let ([b ($vector-ref vec idx)])
+        (let ([idx 
-              (cond
+               (if (fixnum? next)
-                [(or (direct-lookup x b) (rehash-lookup h (hasht-tc h) x))
+                   next
-                 =>
+                   (get-bucket-index next))])
-                 (lambda (b)
+          (let ([fst ($vector-ref vec idx)])
-                   ($tcbucket-val b))]
+            (cond
-                [else v])))))))
+              [(eq? fst b) 
-  
+               ($vector-set! vec idx next)]
+              [else 
+               (replace! fst b next)])))
+        ;;; set next to be #f, denoting, not in table
+        ($set-tcbucket-next! b #f))))
+
+  (define (get-bucket h x)
+    (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)])
+            (or (direct-lookup x b)
+                (rehash-lookup h (hasht-tc h) x)))))))
+
+  (define (get-hash h x v)
+    (cond
+      [(get-bucket h x) =>
+       (lambda (b) ($tcbucket-val b))]
+      [else v]))
+
+  (define (in-hash? h x) 
+    (and (get-bucket h x) #t))
+
+  (define (del-hash h x)
+    (cond
+      [(get-bucket h x) => (lambda (b) (unlink! h b))]))
+
   (define put-hash!
     (lambda (h x v)
       (let ([pv (pointer-value x)]
@@ -134,6 +165,16 @@
                    (when ($fx> ct ($vector-length vec))
                      (enlarge-table h)))])))))))
 
+
+          
+  (define (update-hash! h x proc default)
+    (cond
+      [(get-bucket h x) =>
+       (lambda (b) ($set-tcbucket-val! b (proc ($tcbucket-val b))))]
+      [else (put-hash! h x (proc default))]))
+
+
+
   (define insert-b
     (lambda (b vec mask)
       (let* ([x ($tcbucket-key b)]
@@ -197,6 +238,13 @@
           (get-hash h x v)
           (error 'hashtable-ref "~s is not a hash table" h))))
 
+
+  (define hashtable-contains?
+    (lambda (h x)
+      (if (hasht? h)
+          (in-hash? h x)
+          (error 'hashtable-contains? "~s is not a hash table" h))))
+
   (define hashtable-set!
     (lambda (h x v)
       (if (hasht? h)
@@ -204,4 +252,29 @@
           (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))
+          (error 'hashtable-update! "~s is not a hash table" h))))
+
+
+  (define hashtable-size
+    (lambda (h)
+      (if (hasht? h) 
+          (hasht-count h)
+          (error 'hashtable-size "~s is not a hash table" h))))
+
+  (define hashtable-delete!
+    (lambda (h x) 
+      ;;; FIXME: should shrink table if number of keys drops below
+      ;;; (sqrt (vector-length (hasht-vec h)))
+      (if (hasht? h)
+          (del-hash h x)
+          (error 'hashtable-delete! "~s is not a hash table" h))))
+
+  
+
 )

src/todo-r6rs.ss

@@ -667,17 +667,17 @@
     [call-with-output-file                      C is se]
     ;;;
     [hashtable-clear!                           S ht]
-    [hashtable-contains?                        S ht]
+    [hashtable-contains?                        C ht]
     [hashtable-copy                             S ht]
-    [hashtable-delete!                          S ht]
+    [hashtable-delete!                          C ht]
     [hashtable-entries                          S ht]
     [hashtable-keys                             S ht]
     [hashtable-mutable?                         S ht]
-    [hashtable-ref                              S ht]
+    [hashtable-ref                              C ht]
-    [hashtable-set!                             S ht]
+    [hashtable-set!                             C ht]
-    [hashtable-size                             S ht]
+    [hashtable-size                             C ht]
-    [hashtable-update!                          S ht]
+    [hashtable-update!                          C ht]
-    [hashtable?                                 S ht]
+    [hashtable?                                 C ht]
     [make-eq-hashtable                          C ht]
     [make-eqv-hashtable                         S ht]
     [hashtable-hash-function                    D ht]