mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
Support arrays in truncated-print
* module/ice-9/pretty-print.scm (print): Handle general arrays. * test-suite/tests/print.test: Test truncated-print with general arrays.
This commit is contained in:
parent
a0028723da
commit
ee2125c639
2 changed files with 35 additions and 3 deletions
|
@ -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)))))
|
||||
|
|
|
@ -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")))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue