From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 2 Dec 2018 02:08:58 +0000 (+0000)
Subject: pp _is_ busted after all but it takes a hairier example.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~56
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e3f2dd63c2988f5f87d28faea28249ad659304e6;p=mit-scheme.git

pp _is_ busted after all but it takes a hairier example.
---

diff --git a/tests/runtime/test-pp.scm b/tests/runtime/test-pp.scm
index 2174a58e1..9b84ff223 100644
--- a/tests/runtime/test-pp.scm
+++ b/tests/runtime/test-pp.scm
@@ -28,6 +28,9 @@ USA.
 
 (declare (usual-integrations))
 
+(define assert-string
+  (predicate-assertion string? "string"))
+
 (define (carefully procedure if-overflow if-timeout)
   (let ((thread #f)
         (mutex (make-thread-mutex))
@@ -69,7 +72,7 @@ USA.
           (lambda () (do () (result) (suspend-current-thread)))
           (lambda () (deregister-timer-event (set! timer))))))))
 
-(define-test 'circular
+(define-test 'circular/simple
   (lambda ()
     (define (doit)
       (let ((c (cons 0 0)))
@@ -81,3 +84,24 @@ USA.
     (assert-equal
      (carefully doit (lambda () 'stack-overflow) (lambda () 'timeout))
      "(0 0 . #[circularity (current parenthetical level, downstream 1 cdr.)])\n")))
+
+(define-test 'circular/hairy
+  (lambda ()
+    (define (doit)
+      (let ((u (vector 1 2 3))
+            (v (vector 4 5 6)))
+        (vector-set! v 2 u)
+        (vector-set! u 1 v)
+        (let ((c (cons 0 0)))
+          (set-car! c u)
+          (set-cdr! c v)
+          (vector-set! v 1 c))
+        (call-with-output-string
+          (lambda (p)
+            (parameterize ((param:pp-avoid-circularity? #t))
+              (pp v p))))))
+    (expect-failure
+     (lambda ()
+       ;; XXX Figure out what string it should print by hand.
+       (assert-string
+        (carefully doit (lambda () 'stack-overflow) (lambda () 'timeout)))))))