fixed a bug in fasl reader for shared/cyclic data structures.

This commit is contained in:
Abdulaziz Ghuloum 2008-07-30 17:28:33 -07:00
parent f2d6f433bb
commit 9b74020647
4 changed files with 28 additions and 12 deletions

View File

@ -209,7 +209,7 @@
(let ([code (read-code #f m)]) (let ([code (read-code #f m)])
(if m (vector-ref marks m) ($code->closure code)))] (if m (vector-ref marks m) ($code->closure code)))]
[(#\<) [(#\<)
(let ([cm (read-int p)]) (let ([cm (read-u32 p)])
(unless (fx< cm (vector-length marks)) (unless (fx< cm (vector-length marks))
(die who "invalid mark" m)) (die who "invalid mark" m))
(let ([code (vector-ref marks cm)]) (let ([code (vector-ref marks cm)])
@ -217,7 +217,7 @@
(when m (put-mark m proc)) (when m (put-mark m proc))
proc)))] proc)))]
[(#\>) [(#\>)
(let ([cm (read-int p)]) (let ([cm (read-u32 p)])
(assert-eq? (read-u8-as-char p) #\x) (assert-eq? (read-u8-as-char p) #\x)
(let ([code (read-code cm m)]) (let ([code (read-code cm m)])
(if m (vector-ref marks m) ($code->closure code))))] (if m (vector-ref marks m) ($code->closure code))))]
@ -314,10 +314,10 @@
[(#\C) (integer->char (read-int p))] [(#\C) (integer->char (read-int p))]
[(#\c) (read-u8-as-char p)] [(#\c) (read-u8-as-char p)]
[(#\>) [(#\>)
(let ([m (read-int p)]) (let ([m (read-u32 p)])
(read/mark m))] (read/mark m))]
[(#\<) [(#\<)
(let ([m (read-int p)]) (let ([m (read-u32 p)])
(unless (fx< m (vector-length marks)) (unless (fx< m (vector-length marks))
(die who "invalid mark" m)) (die who "invalid mark" m))
(or (vector-ref marks m) (or (vector-ref marks m)
@ -401,7 +401,7 @@
(when m (put-mark m x)) (when m (put-mark m x))
x))] x))]
[else [else
(die who "Unexpected char as a fasl object header" h)]))) (die who "Unexpected char as a fasl object header" h p)])))
(read)) (read))
(define $fasl-read (define $fasl-read
(lambda (p) (lambda (p)

View File

@ -404,7 +404,7 @@
(fxior textual-output-port-bits fast-u8-text-tag)] (fxior textual-output-port-bits fast-u8-text-tag)]
[(eq? 'utf-8-codec (transcoder-codec x)) [(eq? 'utf-8-codec (transcoder-codec x))
(fxior textual-output-port-bits fast-u7-text-tag)] (fxior textual-output-port-bits fast-u7-text-tag)]
[else textual-output-port-bits])) [else (die who "unsupported codec" (transcoder-codec x))]))
(define open-bytevector-input-port (define open-bytevector-input-port
(case-lambda (case-lambda

View File

@ -1 +1 @@
1563 1564

View File

@ -5,12 +5,27 @@
(define (test x) (define (test x)
(printf "test-fasl ~s\n" x) (printf "test-fasl ~s\n" x)
(let ([y (deserialize (serialize x))])
(unless (equal? x y)
(error 'test-fasl "failed/expected" y x))))
(define (serialize x)
(let-values ([(p e) (open-bytevector-output-port)]) (let-values ([(p e) (open-bytevector-output-port)])
(fasl-write x p) (fasl-write x p)
(let ([bv (e)]) (e)))
(let ([y (fasl-read (open-bytevector-input-port bv))]) (define (deserialize x)
(unless (equal? x y) (fasl-read (open-bytevector-input-port x)))
(error 'test-fasl "failed/expected" y x))))))
(define (test-cycle)
(let ([x (cons 1 2)])
(set-car! x x)
(set-cdr! x x)
(printf "test-fasl ~s\n" x)
(let ([x (deserialize (serialize x))])
(assert (pair? x))
(assert (eq? x (car x)))
(assert (eq? x (cdr x))))))
(define (test-fasl) (define (test-fasl)
(test 12) (test 12)
@ -30,7 +45,8 @@
(test -2389478923749872389723894/23498739874892379482374) (test -2389478923749872389723894/23498739874892379482374)
(test 127487384734.4) (test 127487384734.4)
(test (make-rectangular 12 13)) (test (make-rectangular 12 13))
(test (make-rectangular 12.0 13.0))) (test (make-rectangular 12.0 13.0))
(test-cycle))
) )