[Guile-commits] 01/02: Fix more corner cases in truncated-print

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit 196e80fce3c68f0dddcc0658bf97db7342dd1dc6
Author: Daniel Llorens <address@hidden>
Date:   Tue Feb 7 19:24:23 2017 +0100

    Fix more corner cases in truncated-print
    
    * 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 "address@hidden@0((foo foo foo foo …) …)"
+      (tprint (make-array 'foo '(-1 3) 5) 30 "UTF-8"))
+
+  (pass-if-equal "address@hidden:address@hidden:address@hidden: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"))