From 007f05989b30d339e65296ba206174aa2af11734 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Mon, 12 Nov 2007 00:50:00 -0500
Subject: [PATCH] * Added hashtable-copy

---
 scheme/ikarus.hash-tables.ss | 38 ++++++++++++++++++++++++++++++++++--
 scheme/makefile.ss           |  2 +-
 scheme/todo-r6rs.ss          |  2 +-
 3 files changed, 38 insertions(+), 4 deletions(-)

diff --git a/scheme/ikarus.hash-tables.ss b/scheme/ikarus.hash-tables.ss
index 5095806..2798409 100644
--- a/scheme/ikarus.hash-tables.ss
+++ b/scheme/ikarus.hash-tables.ss
@@ -18,7 +18,7 @@
    (export make-eq-hashtable hashtable-ref hashtable-set! hashtable?
            hashtable-size hashtable-delete! hashtable-contains?
            hashtable-update! hashtable-keys hashtable-mutable?
-           hashtable-clear! hashtable-entries)
+           hashtable-clear! hashtable-entries hashtable-copy)
    (import 
      (ikarus system $pairs)
      (ikarus system $vectors)
@@ -27,7 +27,7 @@
      (except (ikarus) make-eq-hashtable hashtable-ref hashtable-set! hashtable?
              hashtable-size hashtable-delete! hashtable-contains?
              hashtable-update! hashtable-keys hashtable-mutable?
-             hashtable-clear! hashtable-entries))
+             hashtable-clear! hashtable-entries hashtable-copy))
 
    (define-struct hasht (vec count tc mutable?))
 
@@ -280,6 +280,28 @@
                             [else (f i b kv vv)])))
                       ($fxsub1 j) kv vv v)))])))))
 
+  (define (hasht-copy h mutable?)
+    (define (dup-hasht h mutable? n)
+      (let ([x (cons #f #f)])
+        (let ([tc (cons x x)])
+          (make-hasht (make-base-vec n) 0 tc mutable?))))
+    (let ([v (hasht-vec h)] [n (hasht-count h)])
+      (let ([r (dup-hasht h mutable? (vector-length v))])
+        (let f ([i ($fxsub1 n)] [j ($fxsub1 (vector-length v))] [r r] [v v])
+          (cond
+            [($fx= i -1) r]
+            [else 
+             (let ([b ($vector-ref v j)])
+               (if (fixnum? b) 
+                   (f i ($fxsub1 j) r v)
+                   (f (let f ([i i] [b b] [r r])
+                        (put-hash! r ($tcbucket-key b) ($tcbucket-val b))
+                        (let ([b ($tcbucket-next b)] [i ($fxsub1 i)])
+                          (cond
+                            [(fixnum? b) i]
+                            [else (f i b r)])))
+                      ($fxsub1 j) r v)))])))))
+
   ;;; public interface
   (define (hashtable? x) (hasht? x))
 
@@ -366,4 +388,16 @@
             (clear-hash! h)
             (error 'hashtable-clear! "hashtable is immutable" h))
         (error 'hashtable-clear! "not a hash table" h)))
+
+  (define hashtable-copy 
+    (case-lambda
+      [(h) 
+       (if (hasht? h) 
+           (hasht-copy h #f)
+           (error 'hashtable-copy "not a hash table" h))]
+      [(h mutable?)
+       (if (hasht? h) 
+           (hasht-copy h (and mutable? #t))
+           (error 'hashtable-copy "not a hash table" h))]))
+
 )
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index c06fea4..cfd5ca0 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -1163,7 +1163,7 @@
     [call-with-output-file                       i r is se]
     [hashtable-clear!                            i r ht]
     [hashtable-contains?                         i r ht]
-    [hashtable-copy                              r ht]
+    [hashtable-copy                              i r ht]
     [hashtable-delete!                           i r ht]
     [hashtable-entries                           i r ht]
     [hashtable-keys                              i r ht]
diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss
index e3a4906..018d384 100755
--- a/scheme/todo-r6rs.ss
+++ b/scheme/todo-r6rs.ss
@@ -683,7 +683,7 @@
     ;;;
     [hashtable-clear!                           C ht]
     [hashtable-contains?                        C ht]
-    [hashtable-copy                             S ht]
+    [hashtable-copy                             C ht]
     [hashtable-delete!                          C ht]
     [hashtable-entries                          C ht]
     [hashtable-keys                             C ht]