conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

This commit is contained in:
Abdulaziz Ghuloum 2008-12-23 21:40:09 -05:00
parent 4918b0e965
commit 788762da44
4 changed files with 74 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
scheme/ikarus.fasl.ss
View File

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

49
scheme/ikarus.fasl.write.ss
View File

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

2
scheme/last-revision
View File

@ -1 +1 @@
1723
1724

33
scheme/tests/fasl.ss
View File

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