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

scheme/ikarus.fasl.ss

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

scheme/ikarus.io.ss

@@ -404,7 +404,7 @@
        (fxior textual-output-port-bits fast-u8-text-tag)]
       [(eq? 'utf-8-codec (transcoder-codec x))
        (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
     (case-lambda

scheme/last-revision

@@ -1 +1 @@
-1563
+1564

scheme/tests/fasl.ss

@@ -5,12 +5,27 @@
 
   (define (test 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)])
       (fasl-write x p)
-      (let ([bv (e)])
-        (let ([y (fasl-read (open-bytevector-input-port bv))])
-          (unless (equal? x y)
-            (error 'test-fasl "failed/expected" y x))))))
+      (e)))
+  (define (deserialize x)
+    (fasl-read (open-bytevector-input-port 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) 
     (test 12)
@@ -30,7 +45,8 @@
     (test -2389478923749872389723894/23498739874892379482374)
     (test 127487384734.4)
     (test (make-rectangular 12 13))
-    (test (make-rectangular 12.0 13.0)))
+    (test (make-rectangular 12.0 13.0))
+    (test-cycle))
 
 )