Generalize list-like printing, and support list-breadth limit properly.

diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm
index 63a152b6734a0d98489d24d26c65b70541521a78..85dd682209e9521e45a9f5645fc1d96d0e334c37 100644 (file)
--- a/src/runtime/printer.scm
+++ b/src/runtime/printer.scm
@@ -310,10 +310,9 @@ USA.
            object
            context
            (lambda (context*)
-             (for-each (lambda (part)
-                         (*print-char #\space context*)
-                         (print-object part context*))
-                       (standard-print-method-parts print-method object)))))
+             (*print-items (standard-print-method-parts print-method object)
+                           context*
+                           print-object))))
          (print-method
           (call-print-method print-method object context))
          (else
@@ -417,6 +416,38 @@ USA.
 (define (allowed-char? char context)
   (char-in-set? char (context-char-set context)))
 
+(define (limit-print-depth context kernel)
+  (let ((context* (context-down-list context))
+       (limit (context-list-depth-limit context)))
+    (if (and limit
+            (> (context-list-depth context*) limit))
+       (*print-string "..." context*)
+       (kernel context*))))
+
+(define (limit-print-breadth context n-printed kernel)
+  (if (let ((limit (context-list-breadth-limit context)))
+       (and limit
+            (>= n-printed limit)))
+      (*print-string " ..." context)
+      (kernel)))
+
+(define (*general-print-items items context print-item n-printed split)
+  (let loop ((items items) (n-printed n-printed))
+    (split items
+      (lambda (item rest)
+       (limit-print-breadth context n-printed
+         (lambda ()
+           (if (> n-printed 0)
+               (*print-char #\space context))
+           (print-item item context)
+           (loop rest (+ n-printed 1))))))))
+
+(define (*print-items items context print-item)
+  (*general-print-items items context print-item 0
+    (lambda (items k)
+      (if (pair? items)
+         (k (car items) (cdr items))))))
+
 (define (*print-with-brackets name object context procedure)
   (if (get-param:print-with-maximum-readability?)
       (*print-readable-hash object context)
@@ -648,25 +679,14 @@ USA.
 (define (print-vector vector context)
   (limit-print-depth context
     (lambda (context*)
+      (*print-string "#(" context*)
       (let ((end (vector-length vector)))
-       (if (fix:> end 0)
-           (begin
-             (*print-string "#(" context*)
-             (print-object (safe-vector-ref vector 0) context*)
-             (let loop ((index 1))
-               (if (fix:< index end)
-                   (if (let ((limit
-                              (context-list-breadth-limit context*)))
-                         (and limit
-                              (>= index limit)))
-                       (*print-string " ...)" context*)
-                       (begin
-                         (*print-char #\space context*)
-                         (print-object (safe-vector-ref vector index)
-                                       context*)
-                         (loop (fix:+ index 1))))))
-             (*print-char #\) context*))
-           (*print-string "#()" context*))))))
+       (*general-print-items 0 context* print-object 0
+         (lambda (index k)
+           (if (fix:< index end)
+               (k (safe-vector-ref vector index)
+                  (fix:+ index 1))))))
+      (*print-char #\) context*))))
 
 (define (safe-vector-ref vector index)
   (if (with-absolutely-no-interrupts
@@ -679,24 +699,14 @@ USA.
 (define (print-bytevector bytevector context)
   (limit-print-depth context
     (lambda (context*)
+      (*print-string "#u8(" context*)
       (let ((end (bytevector-length bytevector)))
-       (if (fix:> end 0)
-           (begin
-             (*print-string "#u8(" 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)))
-                         (and limit
-                              (>= index limit)))
-                       (*print-string " ..." context*)
-                       (begin
-                         (*print-char #\space context*)
-                         (print-number (bytevector-u8-ref bytevector index)
-                                       context*)
-                         (loop (fix:+ index 1))))))
-             (*print-char #\) context*))
-           (*print-string "#u8()" context*))))))
+       (*general-print-items 0 context* print-object 0
+         (lambda (index k)
+           (if (fix:< index end)
+               (k (bytevector-u8-ref bytevector index)
+                  (fix:+ index 1))))))
+      (*print-char #\) context*))))
 
 (define (print-record record context)
   (cond ((string? record) (print-string record context))
@@ -724,36 +734,20 @@ USA.
     (lambda (context*)
       (*print-char #\( context*)
       (print-object (safe-car list) context*)
-      (print-tail (safe-cdr list) 2 context*)
+      (*general-print-items (safe-cdr list) context* print-object 1
+       (lambda (tail k)
+         (cond ((datum-label tail context*)
+                => (lambda (label)
+                     (*print-string " . " context*)
+                     (if (print-datum-label label context*)
+                         (print-object-1 tail context*))))
+               ((pair? tail)
+                (k (safe-car tail) (safe-cdr tail)))
+               ((not (null? tail))
+                (*print-string " . " context*)
+                (print-object-1 tail context*)))))
       (*print-char #\) context*))))
 
-(define (limit-print-depth context kernel)
-  (let ((context* (context-down-list context))
-       (limit (context-list-depth-limit context)))
-    (if (and limit
-            (> (context-list-depth-limit context*) limit))
-       (*print-string "..." context*)
-       (kernel context*))))
-
-(define (print-tail l n context)
-  (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)))
-              (and limit
-                   (>= n limit)
-                   (pair? (safe-cdr l))))
-            (*print-string " ..." context)
-            (print-tail (safe-cdr l) (+ n 1) context)))
-        ((not (null? l))
-         (*print-string " . " context)
-         (print-object l context))))
-\f
 (define (prefix-pair? object)
   (and (get-param:printer-abbreviate-quotations?)
        (pair? (safe-cdr object))
@@ -774,30 +768,23 @@ USA.
     (lambda (context*)
       (*print-char #\{ context*)
       (print-object (safe-car stream-pair) context*)
-      (print-stream-tail (safe-cdr stream-pair) 2 context*)
+      (*general-print-items (safe-cdr stream-pair) context* print-object 1
+       (lambda (tail k)
+         (cond ((not (promise? tail))
+                (*print-string " . " context*)
+                (print-object tail context*))
+               ((not (promise-forced? tail))
+                (*print-string " ..." context*))
+               (else
+                (let ((value (promise-value tail)))
+                  (cond ((empty-stream? value))
+                        ((stream-pair? value)
+                         (k (safe-car value) (safe-cdr value)))
+                        (else
+                         (*print-string " . " context*)
+                         (print-object value context*))))))))
       (*print-char #\} context*))))
 
-(define (print-stream-tail tail n context)
-  (cond ((not (promise? tail))
-         (*print-string " . " context)
-         (print-object tail context))
-        ((not (promise-forced? tail))
-         (*print-string " ..." context))
-        (else
-        (let ((value (promise-value tail)))
-          (cond ((empty-stream? value))
-                ((stream-pair? value)
-                 (*print-char #\space context)
-                 (print-object (safe-car value) context)
-                 (if (let ((limit (context-list-breadth-limit context)))
-                       (and limit
-                            (>= n limit)))
-                     (*print-string " ..." context)
-                     (print-stream-tail (safe-cdr value) (+ n 1) context)))
-                (else
-                 (*print-string " . " context)
-                 (print-object value context)))))))
-
 (define (safe-car pair)
   (map-reference-trap (lambda () (car pair))))
 

diff --git a/tests/runtime/test-printer.scm b/tests/runtime/test-printer.scm
index 1432dc32fa79be24570d1a9877c120dcfbdea493..5e88557ddcfe125cbd836667e35cbac00bdc09ff 100644 (file)
--- a/tests/runtime/test-printer.scm
+++ b/tests/runtime/test-printer.scm
@@ -45,3 +45,88 @@ USA.
       (let ((s (find-shared-objects c)))
         (assert-= (length s) 1)
         (assert-eq (car s) c)))))
+
+(define (assert-prints-as object expected . properties)
+  (apply assert-string=
+        (call-with-output-string
+          (lambda (port)
+            (write object port)))
+        expected
+        properties))
+
+(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#)"))))
+
+(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)
+                     "(2 3 5 7 11 13 17 19)")
+    (assert-prints-as '#(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)
+                     "#u8(2 3 5 7 11 13 17 19)")
+    (assert-prints-as '(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)
+                       "(2 ...)")
+      (assert-prints-as '#(2 3 5 7 11 13 17 19)
+                       "#(2 ...)")
+      (assert-prints-as '#u8(2 3 5 7 11 13 17 19)
+                       "#u8(2 ...)")
+      (assert-prints-as '(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)
+                       "(2 3 ...)")
+      (assert-prints-as '#(2 3 5 7 11 13 17 19)
+                       "#(2 3 ...)")
+      (assert-prints-as '#u8(2 3 5 7 11 13 17 19)
+                       "#u8(2 3 ...)")
+      (assert-prints-as '(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)
+                       "(2 3 5 ...)")
+      (assert-prints-as '#(2 3 5 7 11 13 17 19)
+                       "#(2 3 5 ...)")
+      (assert-prints-as '#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)
+                       "(2 3 5 ...)"))))
\ No newline at end of file