eq- and eqv-hashtables are now fasl-writable.

scheme/ikarus.fasl.ss

@@ -404,6 +404,14 @@
              (let ([x (make-rectangular real imag)])
                (when m (put-mark m x))
                x))]
+          [(#\h #\H) 
+           (let ([x (if (eqv? h #\h) (make-eq-hashtable) (make-eqv-hashtable))])
+             (when m (put-mark m x))
+             (let* ([keys (read)] [vals (read)])
+               (vector-for-each
+                 (lambda (k v) (hashtable-set! x k v))
+                 keys vals))
+             x)]
           [else
            (die who "Unexpected char as a fasl object header" h p)])))
     (read))

scheme/ikarus.fasl.write.ss

@@ -198,6 +198,13 @@
                (write-byte (code-ref x i) p)
                (f (fxadd1 i) n)))
            (fasl-write-object (code-reloc-vector x) p h m))]
+        [(hashtable? x)
+         (let ([v (hashtable-ref h x #f)])
+           (if (eq? eq? (hashtable-equivalence-function x))
+               (put-tag #\h p)
+               (put-tag #\H p))
+           (fasl-write-object (vector-ref v 2) p h
+             (fasl-write-object (vector-ref v 1) p h m)))]
         [(struct? x)
          (cond
            [(record-type-descriptor? x)
@@ -295,21 +302,22 @@
       (cond
         [(immediate? x) (fasl-write-immediate x p) m]
         [(hashtable-ref h x #f) =>
-         (lambda (mark)
+         (lambda (mk)
-           (unless (fixnum? mark)
+           (let ([mark (if (fixnum? mk) mk (vector-ref mk 0))])
-             (die 'fasl-write "BUG: invalid mark" mark))
+             (cond
-           (cond
+               [(fx= mark 0) ; singly referenced
-             [(fx= mark 0) ; singly referenced
+                (do-write x p h m)]
-              (do-write x p h m)]
+               [(fx> mark 0) ; marked but not written
-             [(fx> mark 0) ; marked but not written
+                (if (fixnum? mk)
-              (hashtable-set! h x (fx- 0 m))
+                    (hashtable-set! h x (fx- 0 m))
-              (put-tag #\> p)
+                    (vector-set! mk 0 (fx- 0 m)))
-              (write-int32 m p)
+                (put-tag #\> p)
-              (do-write x p h (fxadd1 m))]
+                (write-int32 m p)
-             [else
+                (do-write x p h (fxadd1 m))]
-              (put-tag #\< p)
+               [else
-              (write-int32 (fx- 0 mark) p)
+                (put-tag #\< p)
-              m]))]
+                (write-int32 (fx- 0 mark) p)
+                m])))]
         [else (die 'fasl-write "BUG: not in hash table" x)]))) 
   (define make-graph
     (lambda (x h)
@@ -317,7 +325,9 @@
         (cond
           [(hashtable-ref h x #f) =>
            (lambda (i) 
-             (hashtable-set! h x (fxadd1 i)))]
+             (if (vector? i)
+                 (vector-set! i 0 (fxadd1 (vector-ref i 0)))
+                 (hashtable-set! h x (fxadd1 i))))]
           [else
            (hashtable-set! h x 0)
            (cond
@@ -336,6 +346,13 @@
              [(code? x) 
               (make-graph ($code-annotation x) h)
               (make-graph (code-reloc-vector x) h)]
+             [(hashtable? x) 
+              (when (hashtable-hash-function x) 
+                (die 'fasl-write "not fasl-writable" x))
+              (let-values ([(keys vals) (hashtable-entries x)])
+                (make-graph keys h)
+                (make-graph vals h)
+                (hashtable-set! h x (vector 0 keys vals)))]
              [(struct? x)
               (cond
                 [(eq? x (base-rtd))

scheme/last-revision

@@ -1 +1 @@
-1723
+1724

scheme/tests/fasl.ss

@@ -3,10 +3,31 @@
   (export run-tests)
   (import (ikarus) (tests framework))
 
+
+  (define (equal-objects? x y) 
+    (define (vector-andmap f v . v*)
+      (apply andmap f (vector->list v) (map vector->list v*)))
+    (if (and (hashtable? x) (hashtable? y))
+        (and (eqv? (hashtable-hash-function x) 
+                   (hashtable-hash-function y))
+             (eqv? (hashtable-equivalence-function x)
+                   (hashtable-equivalence-function y))
+             (let-values ([(keys vals) (hashtable-entries x)])
+               (vector-andmap 
+                 (lambda (k v) 
+                   (equal-objects? v (hashtable-ref y k (gensym))))
+                 keys vals))
+             (let-values ([(keys vals) (hashtable-entries y)])
+               (vector-andmap 
+                 (lambda (k v)
+                   (equal-objects? v (hashtable-ref x k (gensym))))
+                 keys vals)))
+        (equal? x y)))
+
   (define (test x)
     (printf "test-fasl ~s\n" x)
     (let ([y (deserialize (serialize x))])
-      (unless (equal? x y)
+      (unless (equal-objects? x y)
         (error 'test-fasl "failed/expected" y x))))
   
   (define (serialize x)
@@ -51,6 +72,16 @@
     (test (string #\x3bb))
     (test-cycle)
     (test '#1=((x . #1#) (y . z)))
+    (test (let ([h (make-eq-hashtable)]) 
+            (hashtable-set! h 'foo 12)
+            (hashtable-set! h 'bar 13)
+            (collect)
+            h))
+    (test (let ([h (make-eq-hashtable)]) 
+            (hashtable-set! h (gensym) 12)
+            (hashtable-set! h (gensym) 13)
+            (collect)
+            h))
     )
 
 )