From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 10 Aug 2019 05:42:22 +0000 (-0700)
Subject: Change write to use datum labels only when cycles are present.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~95
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f821026072c161106999d3f05a3504b0acf53519;p=mit-scheme.git

Change write to use datum labels only when cycles are present.

This is required by R7RS but was not understood earlier.
---

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index c68d67505..e2df4e8f6 100644
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -231,9 +231,8 @@ USA.
   (let ((shared-objects
 	 (case label-mode
 	   ((#f) '())
-	   ;; There's little advantage to treating circularity specially since
-	   ;; it's more expensive than finding all sharing.
-	   ((sharing circularity) (find-shared-objects object))
+	   ((sharing) (find-shared-objects object #f))
+	   ((circularity) (find-shared-objects object #t))
 	   (else (error "Unsupported datum labeling mode:" label-mode)))))
     (if (pair? shared-objects)
 	(let ((table (make-strong-eq-hash-table))
@@ -254,40 +253,47 @@ USA.
 	  (declare (ignore object))
 	  #f))))
 
-(define (find-shared-objects object)
+(define (find-shared-objects object cycles-only?)
   (let ((table (make-strong-eq-hash-table)))
 
     (define (walk object)
       (cond ((get-print-method-parts object)
 	     => (lambda (parts)
 		  (if (mark! object)
-		      (for-each walk parts))))
+		      (begin
+			(for-each walk parts)
+			(maybe-unmark! object)))))
 	    ((pair? object)
 	     (if (mark! object)
 		 (begin
 		   (walk (safe-car object))
-		   (walk (safe-cdr object)))))
+		   (walk (safe-cdr object))
+		   (maybe-unmark! object))))
 	    ((vector? object)
 	     (if (mark! object)
-		 (let ((end (vector-length object)))
-		   (let loop ((i 0))
-		     (if (< i end)
-			 (if (nmv-header? object i)
-			     ;; An embedded non-marked vector: skip over and
-			     ;; continue.
-			     (loop (+ i 1 (nmv-header-length object i)))
-			     (begin
-			       (walk (safe-vector-ref object i))
-			       (loop (+ i 1)))))))))
-	    ((promise? object)
+		 (begin
+		   (let ((end (vector-length object)))
+		     (let loop ((i 0))
+		       (if (< i end)
+			   (if (nmv-header? object i)
+			       ;; An embedded non-marked vector: skip over and
+			       ;; continue.
+			       (loop (+ i 1 (nmv-header-length object i)))
+			       (begin
+				 (walk (safe-vector-ref object i))
+				 (loop (+ i 1)))))))
+		   (maybe-unmark! object))))
+	    ((and (promise? object) (promise-forced? object))
 	     (if (mark! object)
-		 (if (promise-forced? object)
-		     (walk (promise-value object)))))
+		 (begin
+		   (walk (promise-value object))
+		   (maybe-unmark! object))))
 	    ((%tagged-object? object)
 	     (if (mark! object)
 		 (begin
 		   (walk (%tagged-object-tag object))
-		   (walk (%tagged-object-datum object)))))))
+		   (walk (%tagged-object-datum object))
+		   (maybe-unmark! object))))))
 
     (define (mark! object)
       (let ((value
@@ -299,6 +305,16 @@ USA.
 	(hash-table-set! table object value)
 	(eq? 'seen value)))
 
+    (define maybe-unmark!
+      (if cycles-only?
+	  (lambda (object)
+	    (let ((value (hash-table-ref/default table object 'unseen)))
+	      (if (not (eq? value 'shared))
+		  (hash-table-delete! table object))))
+	  (lambda (object)
+	    (declare (ignore object))
+	    unspecific)))
+
     (walk object)
     (hash-table-fold table
 		     (lambda (key datum values)
diff --git a/tests/runtime/test-printer.scm b/tests/runtime/test-printer.scm
index b7ab2393e..f210137e2 100644
--- a/tests/runtime/test-printer.scm
+++ b/tests/runtime/test-printer.scm
@@ -33,7 +33,7 @@ USA.
   (lambda ()
     (let ((c (cons 0 0)))
       (set-cdr! c c)
-      (let ((s (find-shared-objects c)))
+      (let ((s (find-shared-objects c #f)))
         (assert-= (length s) 1)
         (assert-eq (car s) c)))))
 
@@ -42,93 +42,113 @@ USA.
     (let ((c (cons 0 0)))
       (set-car! c c)
       (set-cdr! c c)
-      (let ((s (find-shared-objects c)))
+      (let ((s (find-shared-objects c #f)))
         (assert-= (length s) 1)
         (assert-eq (car s) c)))))
 
-(define (assert-prints-as object expected . properties)
+(define (assert-prints-as printer object expected . properties)
   (apply assert-string=
 	 (call-with-output-string
 	   (lambda (port)
-	     (write object port)))
+	     (printer object port)))
 	 expected
 	 properties))
 
+(define-test 'print-cyclic-objects
+  (lambda ()
+    (define (use-printer printer)
+      (let ((clist (circular-list 1 3 5 7)))
+	(assert-prints-as printer clist
+			  "#0=(1 3 5 7 . #0#)")
+	(assert-prints-as printer (list clist)
+			  "(#0=(1 3 5 7 . #0#))")
+	(assert-prints-as printer (vector (circular-list 1 3 5 7))
+			  "#(#0=(1 3 5 7 . #0#))")
+	(assert-prints-as printer (circular-list clist)
+			  "#0=(#1=(1 3 5 7 . #1#) . #0#)")
+	(assert-prints-as printer (circular-list clist clist)
+			  "#0=(#1=(1 3 5 7 . #1#) #1# . #0#)"))
+      (let ((cvector (vector 2 4 6 8)))
+	(vector-set! cvector 1 cvector)
+	(assert-prints-as printer cvector
+			  "#0=#(2 #0# 6 8)")
+	(assert-prints-as printer (list cvector cvector)
+			  "(#0=#(2 #0# 6 8) #0#)")
+	(assert-prints-as printer (vector cvector cvector)
+			  "#(#0=#(2 #0# 6 8) #0#)")
+	(assert-prints-as printer (circular-list cvector cvector)
+			  "#0=(#1=#(2 #1# 6 8) #1# . #0#)")))
+    (use-printer write)
+    (use-printer write-shared)))
+
 (define-test 'print-shared-objects
   (lambda ()
-    (let ((clist (circular-list 1 3 5 7)))
-      (assert-prints-as clist
-			"#0=(1 3 5 7 . #0#)")
-      (assert-prints-as (list clist)
-			"(#0=(1 3 5 7 . #0#))")
-      (assert-prints-as (vector (circular-list 1 3 5 7))
-			"#(#0=(1 3 5 7 . #0#))")
-      (assert-prints-as (circular-list clist)
-			"#0=(#1=(1 3 5 7 . #1#) . #0#)")
-      (assert-prints-as (circular-list clist clist)
-			"#0=(#1=(1 3 5 7 . #1#) #1# . #0#)"))
-    (let ((cvector (vector 2 4 6 8)))
-      (vector-set! cvector 1 cvector)
-      (assert-prints-as cvector
-			"#0=#(2 #0# 6 8)")
-      (assert-prints-as (list cvector cvector)
-			"(#0=#(2 #0# 6 8) #0#)")
-      (assert-prints-as (vector cvector cvector)
-			"#(#0=#(2 #0# 6 8) #0#)")
-      (assert-prints-as (circular-list cvector cvector)
-			"#0=(#1=#(2 #1# 6 8) #1# . #0#)"))))
+    (let ((x
+	   (let ((x (list 1 2)))
+	     (list x x))))
+      (assert-prints-as write x
+			"((1 2) (1 2))")
+      (assert-prints-as write-shared x
+			"(#0=(1 2) #0#)"))
+    (let ((x
+	   (let ((x (vector 1 2)))
+	     (vector 3 x 4 x 5))))
+      (assert-prints-as write x
+			"#(3 #(1 2) 4 #(1 2) 5)")
+      (assert-prints-as write-shared x
+			"#(3 #0=#(1 2) 4 #0# 5)"))))
 
 (define-test 'general-item-printer
   (lambda ()
-    (assert-prints-as '() "()")
-    (assert-prints-as '#() "#()")
-    (assert-prints-as '#u8() "#u8()")
-    (assert-prints-as '(2) "(2)")
-    (assert-prints-as '#(2) "#(2)")
-    (assert-prints-as '#u8(2) "#u8(2)")
-    (assert-prints-as '(2 3 5 7 11 13 17 19)
+    (assert-prints-as write '() "()")
+    (assert-prints-as write '#() "#()")
+    (assert-prints-as write '#u8() "#u8()")
+    (assert-prints-as write '(2) "(2)")
+    (assert-prints-as write '#(2) "#(2)")
+    (assert-prints-as write '#u8(2) "#u8(2)")
+    (assert-prints-as write '(2 3 5 7 11 13 17 19)
 		      "(2 3 5 7 11 13 17 19)")
-    (assert-prints-as '#(2 3 5 7 11 13 17 19)
+    (assert-prints-as write '#(2 3 5 7 11 13 17 19)
 		      "#(2 3 5 7 11 13 17 19)")
-    (assert-prints-as '#u8(2 3 5 7 11 13 17 19)
+    (assert-prints-as write '#u8(2 3 5 7 11 13 17 19)
 		      "#u8(2 3 5 7 11 13 17 19)")
-    (assert-prints-as '(2 3 5 7 11 13 17 19 . foo)
+    (assert-prints-as write '(2 3 5 7 11 13 17 19 . foo)
 		      "(2 3 5 7 11 13 17 19 . foo)")))
 
 (define-test 'list-breadth-limit
   (lambda ()
     (parameterize ((param:printer-list-breadth-limit 1))
-      (assert-prints-as '() "()")
-      (assert-prints-as '#() "#()")
-      (assert-prints-as '#u8() "#u8()")
-      (assert-prints-as '(2) "(2)")
-      (assert-prints-as '#(2) "#(2)")
-      (assert-prints-as '#u8(2) "#u8(2)")
-      (assert-prints-as '(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '() "()")
+      (assert-prints-as write '#() "#()")
+      (assert-prints-as write '#u8() "#u8()")
+      (assert-prints-as write '(2) "(2)")
+      (assert-prints-as write '#(2) "#(2)")
+      (assert-prints-as write '#u8(2) "#u8(2)")
+      (assert-prints-as write '(2 3 5 7 11 13 17 19)
 			"(2 ...)")
-      (assert-prints-as '#(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '#(2 3 5 7 11 13 17 19)
 			"#(2 ...)")
-      (assert-prints-as '#u8(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '#u8(2 3 5 7 11 13 17 19)
 			"#u8(2 ...)")
-      (assert-prints-as '(2 3 5 7 11 13 17 19 . foo)
+      (assert-prints-as write '(2 3 5 7 11 13 17 19 . foo)
 			"(2 ...)"))
     (parameterize ((param:printer-list-breadth-limit 2))
-      (assert-prints-as '(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '(2 3 5 7 11 13 17 19)
 			"(2 3 ...)")
-      (assert-prints-as '#(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '#(2 3 5 7 11 13 17 19)
 			"#(2 3 ...)")
-      (assert-prints-as '#u8(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '#u8(2 3 5 7 11 13 17 19)
 			"#u8(2 3 ...)")
-      (assert-prints-as '(2 3 5 7 11 13 17 19 . foo)
+      (assert-prints-as write '(2 3 5 7 11 13 17 19 . foo)
 			"(2 3 ...)"))
     (parameterize ((param:printer-list-breadth-limit 3))
-      (assert-prints-as '(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '(2 3 5 7 11 13 17 19)
 			"(2 3 5 ...)")
-      (assert-prints-as '#(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '#(2 3 5 7 11 13 17 19)
 			"#(2 3 5 ...)")
-      (assert-prints-as '#u8(2 3 5 7 11 13 17 19)
+      (assert-prints-as write '#u8(2 3 5 7 11 13 17 19)
 			"#u8(2 3 5 ...)")
-      (assert-prints-as '(2 3 5 7 11 13 17 19 . foo)
+      (assert-prints-as write '(2 3 5 7 11 13 17 19 . foo)
 			"(2 3 5 ...)"))))
 
 (define-primitives
@@ -142,11 +162,13 @@ USA.
   (lambda ()
     (let ((v (make-vector 10)))
       (insert-nmv! v 2 5)
-      (assert-prints-as v "#(#f #f |#[non-marked section of length 5]| #f #f)"))
+      (assert-prints-as write v
+			"#(#f #f |#[non-marked section of length 5]| #f #f)"))
     (let ((v (make-vector 10)))
       (insert-nmv! v 0 5)
-      (assert-prints-as v "#(|#[non-marked section of length 5]| #f #f #f #f)"))
+      (assert-prints-as write v
+			"#(|#[non-marked section of length 5]| #f #f #f #f)"))
     (let ((v (make-vector 10)))
       (insert-nmv! v 4 5)
-      (assert-prints-as v "#(#f #f #f #f |#[non-marked section of length 5]|)"))
-    ))
\ No newline at end of file
+      (assert-prints-as write v
+			"#(#f #f #f #f |#[non-marked section of length 5]|)"))))
\ No newline at end of file