* Fix array corner cases in truncated-print
@ 2017-02-07 15:30 daniel.llorens
2017-02-07 15:30 ` [PATCH] Fix rank 0 arrays and nested arrays " daniel.llorens
0 siblings, 1 reply; 2+ messages in thread
From: daniel.llorens @ 2017-02-07 15:30 UTC (permalink / raw)
To: guile-devel
This patch fixes a few corner cases in
ee2125c63973e5ebef2a04eb60d85e6a2b3ea412, especially rank-0 arrays which
give an error there.
Regards
Daniel
^ permalink raw reply [flat|nested] 2+ messages in thread
* [PATCH] Fix rank 0 arrays and nested arrays in truncated-print
2017-02-07 15:30 Fix array corner cases in truncated-print daniel.llorens
@ 2017-02-07 15:30 ` daniel.llorens
0 siblings, 0 replies; 2+ messages in thread
From: daniel.llorens @ 2017-02-07 15:30 UTC (permalink / raw)
To: guile-devel; +Cc: Daniel Llorens
From: Daniel Llorens <daniel.llorens@bluewin.ch>
* 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.
---
module/ice-9/pretty-print.scm | 35 +++++++++++++++++++++--------------
test-suite/tests/print.test | 29 ++++++++++++++++++++++++++++-
2 files changed, 49 insertions(+), 15 deletions(-)
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 22bbb8a..d3d7652 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -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)))))
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index 836fa22..82cc776 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -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")))
--
2.10.1
^ permalink raw reply related [flat|nested] 2+ messages in thread
end of thread, other threads:[~2017-02-07 15:30 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2017-02-07 15:30 Fix array corner cases in truncated-print daniel.llorens
2017-02-07 15:30 ` [PATCH] Fix rank 0 arrays and nested arrays " daniel.llorens
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).