From: Chris Hanson Date: Sat, 10 Aug 2019 05:42:22 +0000 (-0700) Subject: Change write to use datum labels only when cycles are present. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=20e1e888f5d7fe65517b28afc0d0c6bfc0e53482;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 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)