From 9b7402064725605a59dc1d5d0588dc525bb42ee8 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Wed, 30 Jul 2008 17:28:33 -0700
Subject: [PATCH] fixed a bug in fasl reader for shared/cyclic data structures.

---
 scheme/ikarus.fasl.ss | 10 +++++-----
 scheme/ikarus.io.ss   |  2 +-
 scheme/last-revision  |  2 +-
 scheme/tests/fasl.ss  | 26 +++++++++++++++++++++-----
 4 files changed, 28 insertions(+), 12 deletions(-)

diff --git a/scheme/ikarus.fasl.ss b/scheme/ikarus.fasl.ss
index 3e8e6c4..11bbe0a 100644
--- a/scheme/ikarus.fasl.ss
+++ b/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)
diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss
index 5d15c9e..11ed374 100644
--- a/scheme/ikarus.io.ss
+++ b/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
diff --git a/scheme/last-revision b/scheme/last-revision
index 24458d2..e5fe089 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1563
+1564
diff --git a/scheme/tests/fasl.ss b/scheme/tests/fasl.ss
index f393c8c..998f3d5 100644
--- a/scheme/tests/fasl.ss
+++ b/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))
 
 )