Ticket #117: circular.patch

csi.scm

@@ -457 +457 @@
                       (lag (cdr lag)))
                   (or (eq? x lag) (lp x lag))))))))
 
+(define (improper-pairs? x)
+  (let lp ((x x))
+    (if (not (pair? x)) #f
+       (or (eq? x (car x))
+           (lp (cdr x))))))
+
 (define-constant max-describe-lines 40)
 
 (define describer-table (make-vector 37 '()))
@@ -533 +539 @@
                     (lambda ()
                       (write (cadr plist) out) ) )
                    (newline out) ) ) ) ]
-            [(circular-list? x)
-             (fprintf out "circular list: ")
+            [(or (circular-list? x) (improper-pairs? x))
+             (fprintf out "circular structure: ")
              (let loop-print ((x x)
-                              (parsed '()))
-               (if (not (memq (car x) parsed))
-                   (begin
+                              (cdr-refs (list x)))
+               (cond ((or (atom? x)
+                          (null? x)) (printf "eol~%"))
+                     ((memq (car x) cdr-refs)
+                      (fprintf out "(circle)~%" ))
+                  ((not (memq (car x) cdr-refs))
                      (fprintf out "~S -> " (car x))
-                     (loop-print (cdr x) (cons (car x) parsed)))
-                   (fprintf out " ~S (circle)~%" (car (memq (car x) parsed)))))]
+                   (loop-print (cdr x) (cons (car x)  cdr-refs) ))))]
             [(list? x) (descseq "list" length list-ref 0)]
             [(pair? x) (fprintf out "pair with car ~S and cdr ~S~%" (car x) (cdr x))]
             [(procedure? x)