mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Fix rank 0 arrays and nested arrays in truncated-print

Browse source 
* module/ice-9/pretty-print.scm (print): In the array case, pass
  #:inner? along to (print-sequence), unless we're at the last dimension
  of the array.
  Special case for 0-rank arrays, which cannot be empty and have no
  length.
* test-suite/tests/print.test: Test some of the cases fixed by this
  patch.
This commit is contained in:
Daniel Llorens 2017-02-07 15:49:11 +01:00
parent ee2125c639
commit 93cbaef134
2 changed files with 49 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -328,7 +328,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(let ((ellipsis-width (string-length ellipsis))) (let ((ellipsis-width (string-length ellipsis)))
(define (print-sequence x width len ref next) (define* (print-sequence x width len ref next #:key inner?)
(let lp ((x x) (let lp ((x x)
(width width) (width width)
(i 0)) (i 0))
@ -337,7 +337,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(cond (cond
((= i len)) ; catches 0-length case ((= i len)) ; catches 0-length case
((and (= i (1- len)) (or (zero? i) (> width 1))) ((and (= i (1- len)) (or (zero? i) (> width 1)))
(print (ref x i) (if (zero? i) width (1- width)))) (print (ref x i) (if (zero? i) width (1- width)) #:inner? inner?))
((<= width (+ 1 ellipsis-width)) ((<= width (+ 1 ellipsis-width))
(display ellipsis)) (display ellipsis))
(else (else
@ -347,7 +347,8 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(if breadth-first? (if breadth-first?
(max 1 (max 1
(1- (floor (/ width (- len i))))) (1- (floor (/ width (- len i)))))
(- width (+ 1 ellipsis-width)))))))) (- width (+ 1 ellipsis-width)))
#:inner? inner?)))))
(display str) (display str)
(lp (next x) (- width 1 (string-length str)) (1+ i))))))) (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
@ -397,7 +398,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(else (else
(lp (cdr fixes)))))) (lp (cdr fixes))))))
(define* (print x width #:key top?) (define* (print x width #:key inner?)
(cond (cond
((<= width 0) ((<= width 0)
(error "expected a positive width" width)) (error "expected a positive width" width))
@ -429,19 +430,25 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(else (else
(display "#")))) (display "#"))))
((and (array? x) (not (string? x))) ((and (array? x) (not (string? x)))
(let* ((prefix (if top? (let* ((type (array-type x))
(let ((s (format #f "~a" (prefix
(apply make-typed-array (array-type x) (if inner?
*unspecified* ""
(make-list (array-rank x) 0))))) (if (zero? (array-rank x))
(substring s 0 (- (string-length s) 2))) (string-append "#0" (if (eq? #t type) "" (symbol->string type)))
"")) (let ((s (format #f "~a"
(apply make-typed-array type *unspecified*
(make-list (array-rank x) 0)))))
(substring s 0 (- (string-length s) 2))))))
(width-prefix (string-length prefix))) (width-prefix (string-length prefix)))
(cond (cond
((>= width (+ 2 width-prefix ellipsis-width)) ((>= width (+ 2 width-prefix ellipsis-width))
(format #t "~a(" prefix) (format #t "~a(" prefix)
(print-sequence x (- width width-prefix 2) (array-length x) (if (zero? (array-rank x))
array-cell-ref identity) (print (array-ref x) (- width width-prefix 2))
(print-sequence x (- width width-prefix 2) (array-length x)
array-cell-ref identity
#:inner? (< 1 (array-rank x))))
(display ")")) (display ")"))
(else (else
(display "#"))))) (display "#")))))
@ -463,4 +470,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 #:top? #t))))) (print x width)))))

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

@ -147,6 +147,18 @@
(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 "#0(#)"
(tprint (make-typed-array #t 9.0) 6 "UTF-8"))
(pass-if-equal "#0(9.0)"
(tprint (make-typed-array #t 9.0) 7 "UTF-8"))
(pass-if-equal "#0f64(#)"
(tprint (make-typed-array 'f64 9.0) 8 "UTF-8"))
(pass-if-equal "#0f64(9.0)"
(tprint (make-typed-array 'f64 9.0) 10 "UTF-8"))
(pass-if-equal "#" (pass-if-equal "#"
(tprint (make-typed-array 's32 0 20 20) 7 "UTF-8")) (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8"))
@ -160,4 +172,19 @@
(tprint (make-typed-array 's32 0 20 20) 12 "UTF-8")) (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8"))
(pass-if-equal "#2s32((0 …) …)" (pass-if-equal "#2s32((0 …) …)"
(tprint (make-typed-array 's32 0 20 20) 14 "UTF-8"))) (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8"))
(pass-if-equal "#2((#(9 9) #(9 9)) (#(9 9) #(9 9)))"
(tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8"))
(pass-if-equal "#(#2((9 9) (9 9)) #2((9 9) (9 9)))"
(tprint (make-vector 2 (make-typed-array #t 9 2 2)) 40 "UTF-8"))
(pass-if-equal "(#2((9 9) (9 9)) #2((9 9) (9 9)))"
(tprint (make-list 2 (make-typed-array #t 9 2 2)) 40 "UTF-8"))
(pass-if-equal "(#0(9) #0(9))"
(tprint (make-list 2 (make-typed-array #t 9)) 20 "UTF-8"))
(pass-if-equal "(#0(9) #)"
(tprint (make-list 2 (make-typed-array #t 9)) 10 "UTF-8")))