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