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 d81b83c7ef5296770c617b4639c6fe38d3f3fa61..8fead3c48ff572cbdbeddc8136a78de08295e43b 100644 (file)
--- 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))))
 \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)