mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

Support arrays in truncated-print

Browse source 
* 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:
Daniel Llorens 2017-02-03 12:16:42 +01:00
parent a0028723da
commit ee2125c639
2 changed files with 35 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

21
module/ice-9/pretty-print.scm
View file

@ -397,7 +397,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(else (else
(lp (cdr fixes)))))) (lp (cdr fixes))))))
(define (print x width) (define* (print x width #:key top?)
(cond (cond
((<= width 0) ((<= width 0)
(error "expected a positive width" width)) (error "expected a positive width" width))
@ -428,6 +428,23 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(display ")")) (display ")"))
(else (else
(display "#")))) (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) ((pair? x)
(cond (cond
((>= width (+ 4 ellipsis-width)) ((>= width (+ 4 ellipsis-width))
@ -446,4 +463,4 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(with-output-to-port port (with-output-to-port port
(lambda () (lambda ()
(print x width))))) (print x width #:top? #t)))))

17
test-suite/tests/print.test
View file

@ -145,4 +145,19 @@
(tprint (current-module) 20 "ISO-8859-1")) (tprint (current-module) 20 "ISO-8859-1"))
(pass-if-equal "#<directory (test-…>" (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")))