From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 2 Dec 2018 01:55:45 +0000 (+0000)
Subject: Fix find-shared-objects.  pp is still busted.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~59
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b8b25c8829bafbdc09dd91a3d5bf6db048d87d39;p=mit-scheme.git

Fix find-shared-objects.  pp is still busted.
---

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index aead849a8..3cea685fd 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -270,9 +270,11 @@ USA.
 
     (define (mark! object)
       (let ((value
-	     (case (hash-table-ref/default table object 'unseen)
-	       ((unseen) 'seen)
-	       ((seen) 'shared))))
+	     (let ((value (hash-table-ref/default table object 'unseen)))
+	       (case value
+		 ((unseen) 'seen)
+		 ((seen shared) 'shared)
+		 (else (error "Invalid sharing state:" value))))))
 	(hash-table-set! table object value)
 	(eq? 'seen value)))
 
diff --git a/tests/runtime/test-printer.scm b/tests/runtime/test-printer.scm
index e95d97152..b0e3ffd7a 100644
--- a/tests/runtime/test-printer.scm
+++ b/tests/runtime/test-printer.scm
@@ -43,7 +43,5 @@ USA.
       (set-car! c c)
       (set-cdr! c c)
       (let ((s (find-shared-objects c)))
-        (expect-failure
-         (lambda ()
-           (assert-= (length s) 1)
-           (assert-eq (car s) c)))))))
+        (assert-= (length s) 1)
+        (assert-eq (car s) c)))))