From 788762da4421454e46b3e0670e76b359198b1203 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Tue, 23 Dec 2008 21:40:09 -0500 Subject: [PATCH] eq- and eqv-hashtables are now fasl-writable. --- scheme/ikarus.fasl.ss | 8 ++++++ scheme/ikarus.fasl.write.ss | 49 +++++++++++++++++++++++++------------ scheme/last-revision | 2 +- scheme/tests/fasl.ss | 33 ++++++++++++++++++++++++- 4 files changed, 74 insertions(+), 18 deletions(-) diff --git a/scheme/ikarus.fasl.ss b/scheme/ikarus.fasl.ss index 19d4604..77d46e2 100644 --- a/scheme/ikarus.fasl.ss +++ b/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)) diff --git a/scheme/ikarus.fasl.write.ss b/scheme/ikarus.fasl.write.ss index 635c634..6608b10 100644 --- a/scheme/ikarus.fasl.write.ss +++ b/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) - (unless (fixnum? mark) - (die 'fasl-write "BUG: invalid mark" mark)) - (cond - [(fx= mark 0) ; singly referenced - (do-write x p h m)] - [(fx> mark 0) ; marked but not written - (hashtable-set! h x (fx- 0 m)) - (put-tag #\> p) - (write-int32 m p) - (do-write x p h (fxadd1 m))] - [else - (put-tag #\< p) - (write-int32 (fx- 0 mark) p) - m]))] + (lambda (mk) + (let ([mark (if (fixnum? mk) mk (vector-ref mk 0))]) + (cond + [(fx= mark 0) ; singly referenced + (do-write x p h m)] + [(fx> mark 0) ; marked but not written + (if (fixnum? mk) + (hashtable-set! h x (fx- 0 m)) + (vector-set! mk 0 (fx- 0 m))) + (put-tag #\> p) + (write-int32 m p) + (do-write x p h (fxadd1 m))] + [else + (put-tag #\< p) + (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)) diff --git a/scheme/last-revision b/scheme/last-revision index 9b5f360..a858d2d 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1723 +1724 diff --git a/scheme/tests/fasl.ss b/scheme/tests/fasl.ss index 5345195..0875ce4 100644 --- a/scheme/tests/fasl.ss +++ b/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)) ) )