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 c68d6750519821cceb6a17a06e4dabbb931bcd13..e2df4e8f6e02cf5217768ba1100310c43a010472 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,40 +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 (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 b7ab2393e5ddec39d15cfdd06fafde360f1c5f84..f210137e26866193cdc51af284820adf9b0c62db 100644 (file)
--- 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