From 20e1e888f5d7fe65517b28afc0d0c6bfc0e53482 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 9 Aug 2019 22:42:22 -0700
Subject: [PATCH] Change write to use datum labels only when cycles are
 present.

This is required by R7RS but was not understood earlier.
---
 src/runtime/printer.scm | 50 ++++++++++++++++++++++++++++++++++-------
 1 file changed, 42 insertions(+), 8 deletions(-)

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index d81b83c7e..8fead3c48 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,22 +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 (car object))
-		   (walk (cdr object)))))
+		   (walk (safe-car object))
+		   (walk (safe-cdr object))
+		   (maybe-unmark! object))))
 	    ((vector? object)
 	     (if (mark! object)
-		 (vector-for-each walk 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)
+		 (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))
+		   (maybe-unmark! object))))))
 
     (define (mark! object)
       (let ((value
@@ -279,6 +303,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)
-- 
2.25.1