(unknown)

(unknown)

[dsmich]

Well Fouey.

I thought I'd try building guile on my old mipsel box before the upcoming release.  It failed compiling psyntax-pp.  Here is the compile output.  I don't have a full build log at this time.  This was starting from a git clean -dxf at
v2.0.7-321-g254d313


  GUILEC ice-9/eval.go
wrote `ice-9/eval.go'
  GUILEC ice-9/psyntax-pp.go
/bin/sh: line 5:  8518 Illegal instruction     GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 ../meta/uninstalled-env guild compile --target="mipsel-unknown-linux-gnu" -Wunbound-variable -Warity-mismatch -Wformat -L "/home/dsmith/src/guile/module" -L "/home/dsmith/src/guile/module" -L "/home/dsmith/src/guile/guile-readline" -o "ice-9/psyntax-pp.go" "./ice-9/psyntax.scm"
make[2]: *** [ice-9/psyntax-pp.go] Error 132
make[2]: Leaving directory `/home/dsmith/src/guile/module'
make[1]: *** [all-recursive] Error 1
make[1]: Leaving directory `/home/dsmith/src/guile'
make: *** [all] Error 2

-Dale

(unknown)

[daniel.llorens]

This patch to master fixes (truncated-print) to support general
arrays. It tries to at least print the #(rank)(type) tag and the rest of
the output is handled as a nested list.

Regards

        Daniel

(unknown)

[daniel.llorens]

This (I think last) patch for truncated-print adds support for
bitvectors and also makes sure to print the correct array print prefix
when it's not trivial (non-zero base indices or zero dimensions). For
this I need to pull out a piece of scm_i_print_array as
array-print-prefix.

[PATCH] Fix more corner cases in truncated-print

[daniel.llorens]

From: Daniel Llorens <daniel.llorens@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