Merge commit '2f3b7e9a41677bfe802e8a1ee851827297384c58'

Conflicts:
	module/ice-9/pretty-print.scm

diff --cc module/ice-9/pretty-print.scm
index 1573c6f,6f54227..007061f
--- 1/module/ice-9/pretty-print.scm
--- 2/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@@ -1,7 -1,7 +1,7 @@@
  ;;;; -*- coding: utf-8; mode: scheme -*-
  ;;;;
  ;;;;  Copyright (C) 2001, 2004, 2006, 2009, 2010,
- ;;;;      2012, 2013 Free Software Foundation, Inc.
 -;;;;      2012, 2014 Free Software Foundation, Inc.
++;;;;      2012, 2013, 2014 Free Software Foundation, Inc.
  ;;;; 
  ;;;; This library is free software; you can redistribute it and/or
  ;;;; modify it under the terms of the GNU Lesser General Public
@@@ -311,138 -312,142 +312,138 @@@ e.g., if @var{x} is a vector, each memb
  \"ration\" the available width, trying to allocate it equally to each
  sub-expression, via the @var{breadth-first?} keyword argument."
  
 -  ;; Make sure string ports are created with the right encoding.
 -  (with-fluids ((%default-port-encoding (port-encoding port)))
 -
 -    (define ellipsis
 -      ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
 -      ;; on the encoding of PORT.
 -      (let ((e "…"))
 -        (catch 'encoding-error
 -          (lambda ()
 -            (with-fluids ((%default-port-conversion-strategy 'error))
 -              (with-output-to-string
 -                (lambda ()
 -                  (display e)))))
 -          (lambda (key . args)
 -            "..."))))
 -
 -    (let ((ellipsis-width (string-length ellipsis)))
 -
 -      (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
 -           ((and (= i (1- len)) (or (zero? i) (> width 1)))
 -            (print (ref x i) (if (zero? i) width (1- width))))
 -           ((<= width (+ 1 ellipsis-width))
 -            (display ellipsis))
 -           (else
 -            (let ((str
 -                   (with-fluids ((%default-port-encoding (port-encoding port)))
 -                     (with-output-to-string
 -                           (lambda ()
 -                             (print (ref x i)
 -                                    (if breadth-first?
 -                                        (max 1
 -                                             (1- (floor (/ width (- len i)))))
 -                                        (- width (+ 1 ellipsis-width)))))))))
 -              (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))
 -                        ellipsis-width)))
 -            (format #f "~a~a~a~a"
 -                    (caar fixes)
 -                    (substring str (string-length (caar fixes))
 -                               (- width (string-length (cdar fixes))
 -                                  ellipsis-width))
 -                    ellipsis
 -                    (cdar fixes)))
 -           (else
 -            (lp (cdr fixes))))))
 -
 -      (define (print x width)
 +  (define ellipsis
 +    ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
 +    ;; on the encoding of PORT.
 +    (let ((e "…"))
 +      (catch 'encoding-error
 +        (lambda ()
 +          (with-fluids ((%default-port-conversion-strategy 'error))
 +            (call-with-output-string
 +             (lambda (p)
 +               (set-port-encoding! p (port-encoding port))
 +               (display e p)))))
 +        (lambda (key . args)
 +          "..."))))
 +
 +  (let ((ellipsis-width (string-length ellipsis)))
 +
 +    (define (print-sequence x width len ref next)
 +      (let lp ((x x)
 +               (width width)
 +               (i 0))
 +        (if (> i 0)
 +            (display #\space))
          (cond
 -         ((<= width 0)
 -          (error "expected a positive width" width))
 -         ((list? x)
 -          (cond
 -           ((>= width (+ 2 ellipsis-width))
 -            (display "(")
 -            (print-sequence x (- width 2) (length x)
 -                            (lambda (x i) (car x)) cdr)
 -            (display ")"))
 -           (else
 -            (display "#"))))
 -         ((vector? x)
 -          (cond
 -           ((>= width (+ 3 ellipsis-width))
 -            (display "#(")
 -            (print-sequence x (- width 3) (vector-length x)
 -                            vector-ref identity)
 -            (display ")"))
 -           (else
 -            (display "#"))))
 -         ((bytevector? x)
 -          (cond
 -           ((>= width 9)
 -            (format #t  "#~a(" (array-type x))
 -            (print-sequence x (- width 6) (array-length x)
 -                            array-ref identity)
 -            (display ")"))
 -           (else
 -            (display "#"))))
 -         ((pair? x)
 -          (cond
 -           ((>= width (+ 4 ellipsis-width))
 -            (display "(")
 -            (print-tree x (- width 2))
 -            (display ")"))
 -           (else
 -            (display "#"))))
 +         ((= 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))))
 +         ((<= width (+ 1 ellipsis-width))
 +          (display ellipsis))
           (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))))))
 +          (let ((str (with-output-to-string
 +                       (lambda ()
 +                         (print (ref x i)
 +                                (if breadth-first?
 +                                    (max 1
 +                                         (1- (floor (/ width (- len i)))))
 +                                    (- width (+ 1 ellipsis-width))))))))
 +            (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))
 +                      ellipsis-width)))
 +          (format #f "~a~a~a~a"
 +                  (caar fixes)
 +                  (substring str (string-length (caar fixes))
 +                             (- width (string-length (cdar fixes))
 +                                ellipsis-width))
 +                  ellipsis
 +                  (cdar fixes)))
 +         (else
 +          (lp (cdr fixes))))))
 +
 +    (define (print x width)
 +      (cond
 +       ((<= width 0)
 +        (error "expected a positive width" width))
 +       ((list? x)
 +        (cond
 +         ((>= width (+ 2 ellipsis-width))
 +          (display "(")
 +          (print-sequence x (- width 2) (length x)
 +                          (lambda (x i) (car x)) cdr)
 +          (display ")"))
 +         (else
 +          (display "#"))))
 +       ((vector? x)
 +        (cond
 +         ((>= width (+ 3 ellipsis-width))
 +          (display "#(")
 +          (print-sequence x (- width 3) (vector-length x)
 +                          vector-ref identity)
 +          (display ")"))
 +         (else
 +          (display "#"))))
-        ((uniform-vector? x)
++       ((bytevector? 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)
++          (format #t  "#~a(" (array-type x))
++          (print-sequence x (- width 6) (array-length x)
++                          array-ref identity)
 +          (display ")"))
 +         (else
 +          (display "#"))))
 +       ((pair? x)
 +        (cond
 +         ((>= width (+ 4 ellipsis-width))
 +          (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)))))