mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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)))
(define (print-sequence x width len ref next)
(define* (print-sequence x width len ref next #:key inner?)
(let lp ((x x)
(width width)
(i 0))
@ -337,7 +337,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(cond
((= i len)) ; catches 0-length case
((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))
(display ellipsis))
(else
@ -347,7 +347,8 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(if breadth-first?
(max 1
(1- (floor (/ width (- len i)))))
(- width (+ 1 ellipsis-width))))))))
(- width (+ 1 ellipsis-width)))
#:inner? inner?)))))
(display str)
(lp (next x) (- width 1 (string-length str)) (1+ i)))))))
@ -397,7 +398,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(else
(lp (cdr fixes))))))
(define* (print x width #:key top?)
(define* (print x width #:key inner?)
(cond
((<= width 0)
(error "expected a positive width" width))
@ -429,19 +430,25 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(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)))
""))
(let* ((type (array-type x))
(prefix
(if inner?
""
(if (zero? (array-rank x))
(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)))
(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)
(if (zero? (array-rank x))
(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 ")"))
(else
(display "#")))))
@ -463,4 +470,4 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(with-output-to-port port
(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-…>"
(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 "#"
(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"))
(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")))