[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 1/2] Support arrays in truncated-print
From: |
daniel . llorens |
Subject: |
[PATCH 1/2] Support arrays in truncated-print |
Date: |
Fri, 3 Feb 2017 13:51:25 +0100 |
From: Daniel Llorens <address@hidden>
* module/ice-9/pretty-print.scm (print): Handle general arrays.
* test-suite/tests/print.test: Test truncated-print with general arrays.
---
module/ice-9/pretty-print.scm | 21 +++++++++++++++++++--
test-suite/tests/print.test | 17 ++++++++++++++++-
2 files changed, 35 insertions(+), 3 deletions(-)
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 007061f6e..22bbb8a94 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -397,7 +397,7 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
(else
(lp (cdr fixes))))))
- (define (print x width)
+ (define* (print x width #:key top?)
(cond
((<= width 0)
(error "expected a positive width" width))
@@ -428,6 +428,23 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
(display ")"))
(else
(display "#"))))
+ ((and (array? x) (not (string? x)))
+ (let* ((prefix (if top?
+ (let ((s (format #f "~a"
+ (apply make-typed-array (array-type
x)
+ *unspecified*
+ (make-list (array-rank x)
0)))))
+ (substring s 0 (- (string-length s) 2)))
+ ""))
+ (width-prefix (string-length prefix)))
+ (cond
+ ((>= width (+ 2 width-prefix ellipsis-width))
+ (format #t "~a(" prefix)
+ (print-sequence x (- width width-prefix 2) (array-length x)
+ array-cell-ref identity)
+ (display ")"))
+ (else
+ (display "#")))))
((pair? x)
(cond
((>= width (+ 4 ellipsis-width))
@@ -446,4 +463,4 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
(with-output-to-port port
(lambda ()
- (print x width)))))
+ (print x width #:top? #t)))))
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index 6ef0e9fc7..836fa2271 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -145,4 +145,19 @@
(tprint (current-module) 20 "ISO-8859-1"))
(pass-if-equal "#<directory (test-…>"
- (tprint (current-module) 20 "UTF-8")))
+ (tprint (current-module) 20 "UTF-8"))
+
+ (pass-if-equal "#"
+ (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8"))
+
+ (pass-if-equal "#2s32(…)"
+ (tprint (make-typed-array 's32 0 20 20) 8 "UTF-8"))
+
+ (pass-if-equal "#2s32(# …)"
+ (tprint (make-typed-array 's32 0 20 20) 10 "UTF-8"))
+
+ (pass-if-equal "#2s32((…) …)"
+ (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8"))
+
+ (pass-if-equal "#2s32((0 …) …)"
+ (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8")))
--
2.11.0
- [no subject], daniel . llorens, 2017/02/03
- [PATCH 1/2] Support arrays in truncated-print,
daniel . llorens <=