From: Daniel Llorens <daniel.llor...@bluewin.ch> * 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