Fixes bug 174594: Record read/write now terminate on cycles.

lab/io-spec.ss

@@ -160,7 +160,7 @@
     (syntax-rules ()
       [(_ name)
        (define (name . args) 
-         (error 'name "not implemented" args))]))
+         (apply error 'name "not implemented" args))]))
 
   ;;; ----------------------------------------------------------
   (module (get-char lookahead-char)

lab/io-test.ss

@@ -8,9 +8,9 @@
   (syntax-rules ()
     [(_ name body) 
      (begin
-       (printf "running ~s ..." 'name)
+       (printf "running ~s ... " 'name)
        body
-       (printf " ok\n"))]))
+       (printf "ok\n"))]))
 
 (define (make-n-byte-custom-binary-input-port n)
   (assert (<= 0 n 256))

scheme/ikarus.writer.ss

@@ -633,7 +633,23 @@
            [(hashtable-ref h x #f) =>
             (lambda (n)
               (hashtable-set! h x (fxadd1 n)))])]
-        ;;; FIXME: recursive records/structs
+        [(struct? x) 
+         (cond
+           [(hashtable-ref h x #f) =>
+            (lambda (n) 
+              (hashtable-set! h x (fxadd1 n)))]
+           [else
+            (hashtable-set! h x 0)
+            (let ([rtd (struct-type-descriptor x)])
+              (unless 
+                (and (record-type-descriptor? rtd) 
+                     (record-type-opaque? rtd))
+                (graph (struct-name x) h)
+                (let ([n (struct-length x)])
+                  (let f ([idx 0])
+                    (unless (fx= idx n)
+                      (graph (struct-ref x idx) h)
+                      (f (fxadd1 idx)))))))])]
         ))
     (define (dynamic x h)
       (cond
@@ -660,6 +676,26 @@
             (when (and (hashtable-ref h x #f)
                        (fxzero? (hashtable-ref h x #f)))
               (hashtable-set! h x #f))])]
+        [(struct? x) 
+         (cond
+           [(hashtable-ref h x #f) =>
+            (lambda (n) 
+              (hashtable-set! h x (fxadd1 n)))]
+           [else
+            (hashtable-set! h x 0)
+            (let ([rtd (struct-type-descriptor x)])
+              (unless 
+                (and (record-type-descriptor? rtd) 
+                     (record-type-opaque? rtd))
+                (dynamic (struct-name x) h)
+                (let ([n (struct-length x)])
+                  (let f ([idx 0])
+                    (unless (fx= idx n)
+                      (dynamic (struct-ref x idx) h)
+                      (f (fxadd1 idx)))))))
+            (when (and (hashtable-ref h x #f)
+                       (fxzero? (hashtable-ref h x #f)))
+              (hashtable-set! h x #f))])]
         ;;; FIXME: recursive records/structs
         ))
     (if (print-graph) 

scheme/last-revision

@@ -1 +1 @@
-1191
+1192