Implement R7RS write procedures with datum labels.

For now, write and write-shared do the same thing.  Limiting the labeling to
circularities is harder than doing all sharing, and unless I can find some new
algorithms, it is slower too.  So write will generate more datum labels than
strictly necessary, but it is safe for printing circular structures.

diff --git a/src/runtime/output-port.scm b/src/runtime/output-port.scm
index f50d876277e40c04d6d270aeb27fbdd025628df5..eac2b497aaaa595b650c90ee45b8ebcc2394b3bf 100644 (file)
--- a/src/runtime/output-port.scm
+++ b/src/runtime/output-port.scm
@@ -129,18 +129,25 @@ USA.
        (output-port/discretionary-flush port))))
 
 (define (display object #!optional port)
-  (let ((port (optional-output-port port 'display)))
-    (print-top-level object port #f)
-    (output-port/discretionary-flush port)))
+  (%write object port #t #f 'display))
 
 (define (write object #!optional port)
-  (let ((port (optional-output-port port 'write)))
-    (print-top-level object port #t)
+  (%write object port #t 'circularity 'write))
+
+(define (write-shared object #!optional port)
+  (%write object port #t 'sharing 'write-shared))
+
+(define (write-simple object #!optional port)
+  (%write object port #t #f 'write-simple))
+
+(define (%write object port slashify? label-mode caller)
+  (let ((port (optional-output-port port caller)))
+    (print-top-level object port slashify? label-mode)
     (output-port/discretionary-flush port)))
 
 (define (write-line object #!optional port)
   (let ((port (optional-output-port port 'write-line)))
-    (print-top-level object port #t)
+    (print-top-level object port #t 'circularity)
     (output-port/write-char port #\newline)
     (output-port/discretionary-flush port)))
 

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 99007fefff4327abf6f254e376277ca5c008a489..e97bea5dc6462318f33af06e1d282e36e6f7cdbd 100644 (file)
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -139,13 +139,14 @@ USA.
                  *unparser-string-length-limit*))
 \f
 (define-record-type <context>
-    (make-context port mode list-depth in-brackets?
+    (make-context port mode list-depth in-brackets? labeling
                  list-breadth-limit list-depth-limit)
     context?
   (port context-port)
   (mode context-mode)
   (list-depth context-list-depth)
   (in-brackets? context-in-brackets?)
+  (labeling context-labeling)
   (list-breadth-limit context-list-breadth-limit)
   (list-depth-limit context-list-depth-limit))
 
@@ -154,6 +155,7 @@ USA.
                (context-mode context)
                (+ 1 (context-list-depth context))
                (context-in-brackets? context)
+               (context-labeling context)
                (context-list-breadth-limit context)
                (context-list-depth-limit context)))
 
@@ -162,6 +164,7 @@ USA.
                (context-mode context)
                0
                #t
+               (context-labeling context)
                within-brackets:list-breadth-limit
                within-brackets:list-depth-limit))
 
@@ -171,6 +174,9 @@ USA.
 (define (context-slashify? context)
   (eq? 'normal (context-mode context)))
 
+(define (datum-label object context)
+  ((context-labeling context) object))
+
 (define (context-char-set context)
   (textual-port-char-set (context-port context)))
 
@@ -184,38 +190,106 @@ USA.
 \f
 ;;;; Top Level
 
-(define (print-top-level object port slashify?)
-  (guarantee output-port? port)
+(define (print-top-level object port slashify? label-mode)
   (print-object object
                (top-level-context port
-                                  (if slashify? 'normal 'display))))
+                                  (if slashify? 'normal 'display)
+                                  (make-labeling-procedure object
+                                                           label-mode))))
 
-(define (top-level-context port mode)
+(define (top-level-context port mode labeling)
   (let ((context (initial-context)))
     (if context
        (make-context port
                      mode
                      (context-list-depth context)
                      (context-in-brackets? context)
+                     labeling
                      (context-list-breadth-limit context)
                      (context-list-depth-limit context))
        (make-context port
                      mode
                      0
                      #f
+                     labeling
                      (get-param:printer-list-breadth-limit)
                      (get-param:printer-list-depth-limit)))))
 
-(define (printer-mode? object)
-  (or (eq? 'normal object)
-      (eq? 'display object)))
-
-(define-deferred print-object
-  (standard-predicate-dispatcher 'print-object 2))
+(define (make-labeling-procedure object label-mode)
+  (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))
+          (else (error "Unsupported datum labeling mode:" label-mode)))))
+    (if (pair? shared-objects)
+       (let ((table (make-strong-eq-hash-table))
+             (counter 0))
+         (for-each (lambda (object)
+                     (hash-table-set! table object 'unseen))
+                   shared-objects)
+         (lambda (object)
+           (let ((datum (hash-table-ref/default table object #f)))
+             (cond ((not datum) #f)
+                   ((eq? 'unseen datum)
+                    (let ((n counter))
+                      (set! counter (fix:+ counter 1))
+                      (hash-table-set! table object n)
+                      (cons 'def n)))
+                   (else (cons 'ref datum))))))
+       (lambda (object)
+         (declare (ignore object))
+         #f))))
+\f
+(define (find-shared-objects object)
+  (let ((table (make-strong-eq-hash-table)))
+
+    (define (walk object)
+      (cond ((pair? object)
+            (if (mark! object)
+                (begin
+                  (walk (car object))
+                  (walk (cdr object)))))
+           ((vector? object)
+            (if (mark! object)
+                (vector-for-each walk object)))))
+
+    (define (mark! object)
+      (let ((value
+            (case (hash-table-ref/default table object 'unseen)
+              ((unseen) 'seen)
+              ((seen) 'shared))))
+       (hash-table-set! table object value)
+       (eq? 'seen value)))
+
+    (walk object)
+    (hash-table-fold table
+                    (lambda (key datum values)
+                      (if (eq? 'shared datum)
+                          (cons key values)
+                          values))
+                    '())))
+
+(define (print-object object context)
+  (if (let ((label (datum-label object context)))
+        (or (not label)
+            (print-datum-label label context)))
+      (print-object-1 object context)))
+
+(define (print-datum-label label context)
+  (let ((def? (eq? 'def (car label))))
+    (*print-char #\# context)
+    (print-number (cdr label) context)
+    (*print-char (if def? #\= #\#) context)
+    def?))
+
+(define-deferred print-object-1
+  (standard-predicate-dispatcher 'print-object-1 2))
 
 (add-boot-init!
  (lambda ()
-   (define-predicate-dispatch-default-handler print-object
+   (define-predicate-dispatch-default-handler print-object-1
      (lambda (object context)
        ((vector-ref dispatch-table
                    ((ucode-primitive primitive-object-type 1) object))
@@ -223,7 +297,7 @@ USA.
        context)))
    (set! define-unparser-method
         (named-lambda (define-unparser-method predicate unparser)
-          (define-predicate-dispatch-handler print-object
+          (define-predicate-dispatch-handler print-object-1
             (list predicate context?)
             unparser)))
    (run-deferred-boot-actions 'unparser-methods)))
@@ -548,7 +622,7 @@ USA.
        (if (fix:> end 0)
            (begin
              (*print-string "#u8(" context*)
-             (print-object (bytevector-u8-ref bytevector 0) context*)
+             (print-number (bytevector-u8-ref bytevector 0) context*)
              (let loop ((index 1))
                (if (fix:< index end)
                    (if (let ((limit (get-param:printer-list-breadth-limit)))
@@ -557,7 +631,7 @@ USA.
                        (*print-string " ...)" context*)
                        (begin
                          (*print-char #\space context*)
-                         (print-object (bytevector-u8-ref bytevector index)
+                         (print-number (bytevector-u8-ref bytevector index)
                                         context*)
                          (loop (fix:+ index 1))))))
              (*print-char #\) context*))
@@ -603,7 +677,12 @@ USA.
        (kernel context*))))
 
 (define (print-tail l n context)
-  (cond ((pair? l)
+  (cond ((datum-label l context)
+        => (lambda (label)
+             (*print-string " . " context)
+             (if (print-datum-label label context)
+                  (print-object-1 l context))))
+       ((pair? l)
         (*print-char #\space context)
         (print-object (safe-car l) context)
         (if (let ((limit (context-list-breadth-limit context)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 14c2deacb9cd18c76019ef8d40002981f931c5c3..a2eb95de4b8541d0985a72bf6caf747dcd7db3bb 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2795,8 +2795,6 @@ USA.
          (flush-output flush-output-port)
          write-substring)
   (export ()
-         (write-shared write)
-         (write-simple write)
          beep
          call-with-truncated-output-port
          clear
@@ -2820,6 +2818,8 @@ USA.
          write
          write-char
          write-line
+         write-shared
+         write-simple
          write-string
          write-strings-in-columns
          write-strings-in-paragraph)
@@ -4855,7 +4855,6 @@ USA.
          param:printer-list-depth-limit
          param:printer-radix
          param:printer-string-length-limit
-         print-object
          user-object-type
          with-current-unparser-state)
   (export (runtime boot-definitions)