Fancy unparsing of streams.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 55cabe5ce8aa7fc775592827f85b285d1de8ab65..656e729d4c90843ab0e2a4c046c6ba2ca7738d71 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4911,6 +4911,7 @@ USA.
          *unparse-abbreviate-quotations?*
          *unparse-compound-procedure-names?*
          *unparse-primitives-by-name?*
+         *unparse-streams?*
          *unparse-uninterned-symbols-by-name?*
          *unparse-with-datum?*
          *unparse-with-maximum-readability?*

diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 261515c86e0ef4a19d680bb0a1af7fe1c2612844..7db55082fd7ba3fefb3c98049af8861ae90c89fa 100644 (file)
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -44,6 +44,7 @@ USA.
   (set! *unparse-compound-procedure-names?* (make-fluid #t))
   (set! *unparse-with-datum?* (make-fluid #f))
   (set! *unparse-abbreviate-quotations?* (make-fluid #f))
+  (set! *unparse-streams?* (make-fluid #t))
   (set! system-global-unparser-table (make-system-global-unparser-table))
   (set! *unparser-table* (make-fluid system-global-unparser-table))
   (set! *default-unparser-state* (make-fluid #f))
@@ -71,6 +72,7 @@ USA.
 (define *unparse-compound-procedure-names?*)
 (define *unparse-with-datum?*)
 (define *unparse-abbreviate-quotations?*)
+(define *unparse-streams?*)
 (define system-global-unparser-table)
 (define *unparser-table*)
 (define *default-unparser-state*)
@@ -550,6 +552,8 @@ USA.
          => (lambda (prefix) (unparse-list/prefix-pair prefix pair)))
         ((unparse-list/unparser pair)
          => (lambda (method) (invoke-user-method method pair)))
+        ((and (fluid *unparse-streams?*) (stream-pair? pair))
+         (unparse-list/stream-pair pair))
         (else
          (unparse-list pair))))
 
@@ -616,6 +620,34 @@ USA.
          ((UNQUOTE-SPLICING) ",@")
          (else #f))))
 
+(define (unparse-list/stream-pair stream-pair)
+  (limit-unparse-depth
+   (lambda ()
+     (*unparse-char #\{)
+     (*unparse-object (safe-car stream-pair))
+     (unparse-stream-tail (safe-cdr stream-pair) 2)
+     (*unparse-char #\}))))
+
+(define (unparse-stream-tail tail n)
+  (cond ((not (promise? tail))
+         (*unparse-string " . ")
+         (*unparse-object tail))
+        ((not (promise-forced? tail))
+         (*unparse-string " ..."))
+        (else (let ((value (promise-value tail)))
+                (cond ((empty-stream? value))
+                      ((stream-pair? value)
+                       (*unparse-char #\space)
+                       (*unparse-object (safe-car value))
+                       (if (let ((limit (fluid *unparser-list-breadth-limit*)))
+                             (and limit
+                                  (>= n limit)))
+                           (*unparse-string " ...")
+                           (unparse-stream-tail (safe-cdr value) (+ n 1))))
+                      (else
+                       (*unparse-string " . ")
+                       (*unparse-object value)))))))
+
 (define (safe-car pair)
   (map-reference-trap (lambda () (car pair))))