From: Daniel Llorens <daniel.llor...@bluewin.ch>
* libguile/arrays.c (scm_i_print_array_prefix, scm_array_print_prefix):
New functions.
(scm_i_print_array): Reuse scm_i_print_array_prefix(). Make sure to
release the array handle.
* module/ice-9/pretty-print.scm (truncated-print): Add a case for
bitvectors. In the array case, use (array-print-prefix) to compute the
prefix.
* test-suite/tests/print.test: Add tests with bitvectors and custom base
indices in arrays.
---
libguile/arrays.c | 70 ++++++++++++++++++++++++++++++++-----------
module/ice-9/pretty-print.scm | 25 +++++++++++-----
test-suite/tests/print.test | 58 ++++++++++++++++++++++++++++++-----
3 files changed, 119 insertions(+), 34 deletions(-)
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 8b8bc48..0bfb40e 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -908,49 +908,80 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int
dim, int pos,
return 1;
}
-/* Print an array.
+/* Print the array print prefix (showing rank, type, and bounds). This
+ function has been extracted from scm_i_print_array() for the benefit
+ of (truncated-print) in (ice-9 pretty-print).
*/
-int
-scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
+SCM_INTERNAL void scm_i_print_array_prefix (scm_t_array_handle *h, SCM port);
+
+void
+scm_i_print_array_prefix (scm_t_array_handle *h, SCM port)
{
- scm_t_array_handle h;
size_t i;
int print_lbnds = 0, zero_size = 0, print_lens = 0;
- scm_array_get_handle (array, &h);
-
scm_putc ('#', port);
- if (SCM_I_ARRAYP (array))
- scm_intprint (h.ndims, 10, port);
- if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
- scm_write (scm_array_handle_element_type (&h), port);
+ if (h->vector!=h->array)
+ scm_intprint (h->ndims, 10, port);
+ if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
+ scm_write (scm_array_handle_element_type (h), port);
- for (i = 0; i < h.ndims; i++)
+ for (i = 0; i < h->ndims; i++)
{
- if (h.dims[i].lbnd != 0)
+ if (h->dims[i].lbnd != 0)
print_lbnds = 1;
- if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
+ if (h->dims[i].ubnd - h->dims[i].lbnd + 1 == 0)
zero_size = 1;
else if (zero_size)
print_lens = 1;
}
if (print_lbnds || print_lens)
- for (i = 0; i < h.ndims; i++)
+ for (i = 0; i < h->ndims; i++)
{
if (print_lbnds)
{
scm_putc ('@', port);
- scm_intprint (h.dims[i].lbnd, 10, port);
+ scm_intprint (h->dims[i].lbnd, 10, port);
}
if (print_lens)
{
scm_putc (':', port);
- scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
+ scm_intprint (h->dims[i].ubnd - h->dims[i].lbnd + 1,
10, port);
}
}
+}
+
+SCM scm_array_print_prefix (SCM array, SCM port);
+
+SCM_DEFINE (scm_array_print_prefix, "array-print-prefix", 2, 0, 0,
+ (SCM array, SCM port),
+ "Internal Guile function.")
+#define FUNC_NAME s_scm_array_print_prefix
+{
+ scm_t_array_handle h;
+
+ scm_array_get_handle (array, &h);
+ scm_i_print_array_prefix (&h, port);
+ scm_array_handle_release (&h);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Print an array.
+ */
+
+int
+scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
+{
+ scm_t_array_handle h;
+ int d;
+
+ scm_array_get_handle (array, &h);
+ scm_i_print_array_prefix (&h, port);
if (h.ndims == 0)
{
@@ -977,10 +1008,13 @@ scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate)
scm_putc ('(', port);
scm_i_print_array_dimension (&h, 0, 0, port, pstate);
scm_putc (')', port);
- return 1;
+ d = 1;
}
else
- return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
+ d = scm_i_print_array_dimension (&h, 0, 0, port, pstate);
+
+ scm_array_handle_release (&h);
+ return d;
}
void
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index d3d7652..3933dd6 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -429,17 +429,24 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
(display ")"))
(else
(display "#"))))
+ ((bitvector? x)
+ (cond
+ ((>= width (+ 2 (array-length x)))
+ (format #t "~a" x))
+ ;; the truncated bitvector prints as #1b(...), so we print by hand.
+ ((>= width (+ 2 ellipsis-width))
+ (format #t "#*")
+ (array-for-each (lambda (xi) (format #t (if xi "1" "0")))
+ (make-shared-array x list (- width 2
ellipsis-width)))
+ (format #t ellipsis))
+ (else
+ (display "#"))))
((and (array? x) (not (string? x)))
(let* ((type (array-type x))
- (prefix
+ (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))))))
+ (call-with-output-string (lambda (s) (array-print-prefix x
s)))))
(width-prefix (string-length prefix)))
(cond
((>= width (+ 2 width-prefix ellipsis-width))
@@ -447,7 +454,9 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
(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
+ (let ((base (caar (array-shape x))))
+ (lambda (x i) (array-cell-ref x (+ base i))))
+ identity
#:inner? (< 1 (array-rank x))))
(display ")"))
(else
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index 82cc776..f2e3145 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -147,6 +147,35 @@
(pass-if-equal "#<directory (test-…>"
(tprint (current-module) 20 "UTF-8"))
+ ;; bitvectors
+
+ (let ((testv (bitvector #t #f #f #t #t #f #t #t)))
+ (pass-if-equal "#*10011011"
+ (tprint testv 11 "UTF-8"))
+
+ (pass-if-equal "#*10011011"
+ (tprint testv 11 "ISO-8859-1"))
+
+ (pass-if-equal "#*10011…"
+ (tprint testv 8 "UTF-8"))
+
+ (pass-if-equal "#*100..."
+ (tprint testv 8 "ISO-8859-1"))
+
+ (pass-if-equal "#*10…"
+ (tprint testv 5 "UTF-8"))
+
+ (pass-if-equal "#*..."
+ (tprint testv 5 "ISO-8859-1"))
+
+ (pass-if-equal "#*1…"
+ (tprint testv 4 "UTF-8"))
+
+ (pass-if-equal "#"
+ (tprint testv 4 "ISO-8859-1")))
+
+ ;; rank 0 arrays
+
(pass-if-equal "#0(#)"
(tprint (make-typed-array #t 9.0) 6 "UTF-8"))
@@ -162,18 +191,31 @@
(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"))
+ ;; higher dimensional arrays
+
+ (let ((testa (make-typed-array 's32 0 20 20)))
+ (pass-if-equal "#2s32(…)"
+ (tprint testa 8 "UTF-8"))
+
+ (pass-if-equal "#2s32(# …)"
+ (tprint testa 10 "UTF-8"))
- (pass-if-equal "#2s32(# …)"
- (tprint (make-typed-array 's32 0 20 20) 10 "UTF-8"))
+ (pass-if-equal "#2s32((…) …)"
+ (tprint testa 12 "UTF-8"))
- (pass-if-equal "#2s32((…) …)"
- (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8"))
+ (pass-if-equal "#2s32((0 …) …)"
+ (tprint testa 14 "UTF-8")))
- (pass-if-equal "#2s32((0 …) …)"
- (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8"))
+ ;; check that bounds are printed correctly
+ (pass-if-equal "#2@-1@0((foo foo foo foo …) …)"
+ (tprint (make-array 'foo '(-1 3) 5) 30 "UTF-8"))
+
+ (pass-if-equal "#3@-1:5@0:0@0:5(() () () # #)"
+ (tprint (make-array 'foo '(-1 3) 0 5) 30 "UTF-8"))
+
+ ;; nested objects including arrays
+
(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"))
--
2.10.1
