[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-53-gb8596c0

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b8596c08ac2ef2201c1e8559ac5f4d62ebde3d91

The branch, master has been updated
       via  b8596c08ac2ef2201c1e8559ac5f4d62ebde3d91 (commit)
       via  8c6eea2f1a6fab2d2be4d0de6a6826273eb2c3c9 (commit)
       via  c5f171027d9b237630a71dc43d4b1b3dc391c591 (commit)
      from  a1dcb961a6d819c154cfa5767ce4193f31cf29b3 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit b8596c08ac2ef2201c1e8559ac5f4d62ebde3d91
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 29 13:26:41 2009 +0100

    add address@hidden truncated printing directive to format
    
    * doc/ref/misc-modules.texi (Formatted Output): Add documentation for
      the new address@hidden format directive.
      (Pretty Printing): Add documentation for truncated-write.
    
    * module/ice-9/format.scm (format): Add address@hidden, for doing a 
truncated
      print. Also, allow both ~y variants to take a width parameter.

commit 8c6eea2f1a6fab2d2be4d0de6a6826273eb2c3c9
Author: Andy Wingo <address@hidden>
Date:   Mon Dec 28 18:10:51 2009 +0100

    add truncated-print to (ice-9 pretty-print)
    
    * module/ice-9/pretty-print.scm (pretty-print): Rework so "port" is the
      kwarg, and "port*" is the optional arg. #:port is still the keyword.
    
      (truncated-print): Add a printer that will ensure that the output
      stays within a certain width. It could use genwrite but it doesn't
      because it seems nice to allow breadth-first allocation of screen
      space, and it's also nice to balance some delimiters (e.g. #< and >).

commit c5f171027d9b237630a71dc43d4b1b3dc391c591
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 29 12:35:13 2009 +0100

    fix bug in string array implementation type mask
    
    * libguile/strings.c (SCM_ARRAY_IMPLEMENTATION): The mask for the string
      array implementation should be 0x7f, without masking out 0x2.
      Otherwise numbers were being thought to be vectors!
    
    * test-suite/tests/unif.test: Add test.
    
    * libguile/vectors.c (SCM_ARRAY_IMPLEMENTATION): Only register one
      implementation, because weak vectors can be checked with the mask &
      ~2, and the functions are the same.

-----------------------------------------------------------------------

Summary of changes:
 doc/ref/misc-modules.texi     |   75 ++++++++++++++++++++-
 libguile/strings.c            |    2 +-
 libguile/vectors.c            |    5 +-
 module/ice-9/format.scm       |   23 +++++--
 module/ice-9/pretty-print.scm |  144 +++++++++++++++++++++++++++++++++++++++-
 test-suite/tests/unif.test    |    7 ++
 6 files changed, 239 insertions(+), 17 deletions(-)

diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi
index 28a636f..1449292 100644
--- a/doc/ref/misc-modules.texi
+++ b/doc/ref/misc-modules.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006
address@hidden Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 
2009
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -16,7 +16,7 @@ The module @code{(ice-9 pretty-print)} provides the procedure
 objects.  This is especially useful for deeply nested or complex data
 structures, such as lists and vectors.
 
-The module is loaded by simply saying.
+The module is loaded by entering the following:
 
 @lisp
 (use-modules (ice-9 pretty-print))
@@ -60,6 +60,65 @@ Print within the given @var{columns}.  The default is 79.
 @end deffn
 
 
address@hidden truncated printing
+Also exported by the @code{(ice-9 pretty-print)} module is
address@hidden, a procedure to print Scheme datums, truncating
+the output to a certain number of characters. This is useful when you
+need to present an arbitrary datum to the user, but you only have one
+line in which to do so.
+
address@hidden
+(define exp '(a b #(c d e) f . g))
+(truncated-print exp #:width 10) (newline)
address@hidden (a b . #)
+(truncated-print exp #:width 15) (newline)
address@hidden (a b # f . g)
+(truncated-print exp #:width 18) (newline)
address@hidden (a b #(c ...) . #)
+(truncated-print exp #:width 20) (newline)
address@hidden (a b #(c d e) f . g)
+(truncated-print "The quick brown fox" #:width 10) (newline)
address@hidden "The quick brown..."
+(truncated-print (current-module) #:width 20) (newline)
address@hidden #<directory (gui...>
address@hidden lisp
+
address@hidden will not output a trailing newline. If an
+expression does not fit in the given width, it will be truncated --
+possibly ellipsized, or in the worst case, displayed as @nicode{#}. 
+
address@hidden {Scheme Procedure} truncated-print obj [port] [keyword-options]
+Print @var{obj}, truncating the output, if necessary, to make it fit
+into @var{width} characters. By default, @var{x} will be printed using
address@hidden, though that behavior can be overriden via the
address@hidden keyword argument.
+
+The default behaviour is to print depth-first, meaning that the entire
+remaining width will be available to each sub-expressoin of @var{x} --
+e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
+``ration'' the available width, trying to allocate it equally to each
+sub-expression, via the @var{breadth-first?} keyword argument.
+
+The further @var{keyword-options} are keywords and parameters as
+follows,
+
address@hidden @asis
address@hidden @nicode{#:display?} @var{flag}
+If @var{flag} is true then print using @code{display}.  The default is
address@hidden which means use @code{write} style.  (@pxref{Writing})
+
address@hidden @nicode{#:width} @var{columns}
+Print within the given @var{columns}.  The default is 79.
+
address@hidden @nicode{#:breadth-first?} @var{flag}
+If @var{flag} is true, then allocate the available width breadth-first
+among elements of a compound data structure (list, vector, pair,
+etc.). The default is @code{#f} which means that any element is
+allowed to consume all of the available width.
address@hidden table
address@hidden deffn
+
+
 @page
 @node Formatted Output
 @section Formatted Output
@@ -577,9 +636,17 @@ to help.  When using @code{gettext} to translate messages
 (@pxref{Internationalization}).
 
 @item @nicode{~y}
-Pretty print.  No parameters.
+Structured printing.  Parameters: @var{width}.
+
address@hidden outputs an argument using @code{pretty-print}
+(@pxref{Pretty Printing}). The result will be formatted to fit within
address@hidden columns (79 by default), consuming multiple lines if
+necessary.
 
-Output an argument with @code{pretty-print} (@pxref{Pretty Printing}).
address@hidden@@y} outputs an argument using @code{truncated-print}
+(@pxref{Pretty Printing}). The resulting code will be formatted to fit
+within @var{width} columns (79 by default), on a single line. The
+output will be truncated if necessary.
 
 @item @nicode{~?}
 @itemx @nicode{~k}
diff --git a/libguile/strings.c b/libguile/strings.c
index 711da9c..3151bbe 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1891,7 +1891,7 @@ string_get_handle (SCM v, scm_t_array_handle *h)
   h->elements = h->writable_elements = NULL;
 }
 
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f & ~2,
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f,
                           string_handle_ref, string_handle_set,
                           string_get_handle)
 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string)
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 7875328..eabd4c4 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -625,12 +625,11 @@ vector_get_handle (SCM v, scm_t_array_handle *h)
   h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
 }
 
+/* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
+   tags.h. */
 SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
                           vector_handle_ref, vector_handle_set,
                           vector_get_handle)
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_wvect, 0x7f & ~2,
-                          vector_handle_ref, vector_handle_set,
-                          vector_get_handle)
 SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)
 
 
diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm
index 4bf6237..2d12dbf 100644
--- a/module/ice-9/format.scm
+++ b/module/ice-9/format.scm
@@ -13,7 +13,7 @@
 
 (define-module (ice-9 format)
   :use-module (ice-9 and-let-star)
-  :autoload (ice-9 pretty-print) (pretty-print)
+  :autoload (ice-9 pretty-print) (pretty-print truncated-print)
   :replace (format)
   :export (format:symbol-case-conv
           format:iobj-case-conv
@@ -482,10 +482,23 @@
                      ((#\T)                    ; Tabulate
                       (format:tabulate modifier params)
                       (anychar-dispatch))
-                     ((#\Y)                    ; Pretty-print
-                      (pretty-print (next-arg) format:port)
-                      (set! format:output-col 0)
-                      (anychar-dispatch))
+                     ((#\Y)                    ; Structured print
+                       (let ((width (if (one-positive-integer? params)
+                                        (car params)
+                                        79)))
+                         (case modifier
+                           ((colon colon-at)
+                            (format:error "illegal modifier in ~~?"))
+                           ((at)
+                            (format:out-str
+                             (with-output-to-string 
+                               (lambda ()
+                                 (truncated-print (next-arg) #:width width)))))
+                           (else
+                            (pretty-print (next-arg) format:port
+                                          #:width width)
+                            (set! format:output-col 0))))
+                       (anychar-dispatch))
                      ((#\? #\K)                ; Indirection (is "~K" in 
T-Scheme)
                       (cond
                        ((memq modifier '(colon colon-at))
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index dc39f44..9a0edbd 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -17,7 +17,8 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
 ;;;; 
 (define-module (ice-9 pretty-print)
-  #:export (pretty-print))
+  #:export (pretty-print
+            truncated-print))
 
 
 ;; From SLIB.
@@ -250,9 +251,9 @@
 
   (rev-string-append l 0))
 
-(define* (pretty-print obj #:optional port
+(define* (pretty-print obj #:optional port*
                        #:key 
-                       (port* (or port (current-output-port)) #:port)
+                       (port (or port* (current-output-port)))
                        (width 79)
                        (display? #f)
                        (per-line-prefix ""))
@@ -268,4 +269,139 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
   (generic-write obj display?
                 (- width (string-length per-line-prefix))
                 per-line-prefix
-                (lambda (s) (display s port*) #t)))
+                (lambda (s) (display s port) #t)))
+
+;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
+;; genwrite.scm.
+(define* (truncated-print x #:optional port*
+                          #:key
+                          (port (or port* (current-output-port)))
+                          (width 79)
+                          (display? #f)
+                          (breadth-first? #f))
+  "Print @var{obj}, truncating the output, if necessary, to make it fit
+into @var{width} characters. By default, @var{x} will be printed using
address@hidden, though that behavior can be overriden via the
address@hidden keyword argument.
+
+The default behaviour is to print depth-first, meaning that the entire
+remaining width will be available to each sub-expressoin of @var{x} --
+e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
+\"ration\" the available width, trying to allocate it equally to each
+sub-expression, via the @var{breadth-first?} keyword argument."
+
+  (define (print-sequence x width len ref next)
+    (let lp ((x x)
+             (width width)
+             (i 0))
+      (if (> i 0)
+          (display #\space))
+      (cond
+       ((= i len)) ; catches 0-length case
+       ((= i (1- len))
+        (print (ref x i) (if (zero? i) width (1- width))))
+       ((<= width 4)
+        (display "..."))
+       (else
+        (let ((str (with-output-to-string
+                     (lambda ()
+                       (print (ref x i)
+                              (if breadth-first?
+                                  (max 1
+                                       (1- (floor (/ width (- len i)))))
+                                  (- width 4)))))))
+          (display str)
+          (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
+
+  (define (print-tree x width)
+    ;; width is >= the width of # . #, which is 5
+    (let lp ((x x)
+             (width width))
+      (cond
+       ((or (not (pair? x)) (<= width 4))
+        (display ". ")
+        (print x (- width 2)))
+       (else
+        ;; width >= 5
+        (let ((str (with-output-to-string
+                     (lambda ()
+                       (print (car x)
+                              (if breadth-first?
+                                  (floor (/ (- width 3) 2))
+                                  (- width 4)))))))
+          (display str)
+          (display " ")
+          (lp (cdr x) (- width 1 (string-length str))))))))
+
+  (define (truncate-string str width)
+    ;; width is < (string-length str)
+    (let lp ((fixes '(("#<" . ">")
+                      ("#(" . ")")
+                      ("(" . ")")
+                      ("\"" . "\""))))
+      (cond
+       ((null? fixes)
+        "#")
+       ((and (string-prefix? (caar fixes) str)
+             (string-suffix? (cdar fixes) str)
+             (>= (string-length str)
+                 width
+                 (+ (string-length (caar fixes))
+                    (string-length (cdar fixes))
+                    3)))
+        (format #f "~a~a...~a"
+                (caar fixes)
+                (substring str (string-length (caar fixes))
+                           (- width (string-length (cdar fixes)) 3))
+                (cdar fixes)))
+       (else
+        (lp (cdr fixes))))))
+
+  (define (print x width)
+    (cond
+     ((<= width 0)
+      (error "expected a positive width" width))
+     ((list? x)
+      (cond
+       ((>= width 5)
+        (display "(")
+        (print-sequence x (- width 2) (length x) (lambda (x i) (car x)) cdr)
+        (display ")"))
+       (else
+        (display "#"))))
+     ((vector? x)
+      (cond
+       ((>= width 6)
+        (display "#(")
+        (print-sequence x (- width 3) (vector-length x) vector-ref identity)
+        (display ")"))
+       (else
+        (display "#"))))
+     ((uniform-vector? x)
+      (cond
+       ((>= width 9)
+        (format #t  "#~a(" (uniform-vector-element-type x))
+        (print-sequence x (- width 6) (uniform-vector-length x)
+                        uniform-vector-ref identity)
+        (display ")"))
+       (else
+        (display "#"))))
+     ((pair? x)
+      (cond
+       ((>= width 7)
+        (display "(")
+        (print-tree x (- width 2))
+        (display ")"))
+       (else
+        (display "#"))))
+     (else
+      (let* ((str (with-output-to-string
+                    (lambda () (if display? (display x) (write x)))))
+             (len (string-length str)))
+        (display (if (<= (string-length str) width)
+                     str
+                     (truncate-string str width)))))))
+
+  (with-output-to-port port
+    (lambda ()
+      (print x width))))
diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test
index 092f7aa..4ac6204 100644
--- a/test-suite/tests/unif.test
+++ b/test-suite/tests/unif.test
@@ -31,6 +31,13 @@
   (cons 'read-error ".*array length must be non-negative.*"))
 
 
+(with-test-prefix "sanity"
+  ;; At the current time of writing, bignums have a tc7 that is one bit
+  ;; away from strings. It used to be that the vector implementation
+  ;; registered for strings had the TYP7S mask, not the TYP7 mask,
+  ;; making the system think that bignums were vectors. Doh!
+  (pass-if (not (uniform-vector? 12345678901234567890123456789))))
+
 (with-test-prefix "array?"
 
   (let ((bool     (make-typed-array 'b    #t  '(5 6)))


hooks/post-receive
-- 
GNU Guile