String ports use UTF-8; ignore %default-port-encoding.

* libguile/strports.c (scm_mkstrport): Use UTF-8; ignore
  %default-port-encoding.  Rename 'str_len' and 'c_pos' to
  'num_bytes' and 'c_byte_pos'.  Interpret 'pos' argument
  as a character index instead of a byte index.

* module/ice-9/boot-9.scm (%cond-expand-features): Add srfi-6 to the
  list of core features.

* module/srfi/srfi-6.scm (open-input-string, open-output-string): Simply
  re-export these, since the core versions are now compliant.

* doc/ref/api-io.texi (String Ports): Remove text that describes
  non-compliant behavior of string ports with regard to encoding.

* doc/ref/srfi-modules.texi (SRFI-0): Add srfi-6 to the list of
  core features.
  (SRFI-6): Remove text that mentions non-compliant behavior of
  core string ports.

* module/ice-9/format.scm (format):
* module/ice-9/pretty-print.scm (truncated-print):
* module/rnrs/io/ports.scm (open-string-input-port,
  open-string-output-port):
* test-suite/test-suite/lib.scm (format-test-name):
* test-suite/tests/chars.test ("combining accent is pretty-printed",
  "combining X is pretty-printed"):
* test-suite/tests/ecmascript.test (eread, eread/1):
* test-suite/tests/rdelim.test:
* test-suite/tests/reader.test (read-string):
* test-suite/tests/regexp.test:
* test-suite/tests/srfi-105.test (read-string): Don't set
  %default-port-encoding before creating string ports.

* benchmark-suite/benchmarks/ports.bm (%latin1-port): Use
  'set-port-encoding!' to set the string port encoding.
  (%utf8/ascii-port, %utf8/wide-port, "rdelim"): Don't set
  %default-port-encoding before creating string ports.

* test-suite/tests/r6rs-ports.test ("lookahead-u8 non-ASCII"): Don't set
  %default-port-encoding before creating string ports.
  ("put-bytevector with UTF-16 string port", "put-bytevector with
  wrong-encoding string port"): Use 'set-port-encoding!' to set the
  string port encoding.

* test-suite/tests/print.test (tprint): Use 'set-port-encoding!' to set
  the string port encoding.
  ("truncated-print"): Use 'pass-if-equal'.

* test-suite/tests/ports.test ("encoding failure leads to exception",
  "%default-port-encoding is honored", "peek-char [latin-1]", "peek-char
  [utf-8]", "peek-char [utf-16]"): Remove tests.
  ("%default-port-encoding is ignored", "peek-char"): Add tests.
  ("suitable encoding [latin-1]", "suitable encoding [latin-3]",
  "wrong encoding, error", "wrong encoding, substitute",
  "wrong encoding, escape"): Use 'set-port-encoding!' to set the
  string port encoding.
  ("%default-port-encoding, wrong encoding"): Rewrite to use
  a file port instead of a string port.

1 files changed, 134 insertions, 138 deletions

diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 5c23cb009..1573c6fd5 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -1,7 +1,7 @@
 ;;;; -*- coding: utf-8; mode: scheme -*-
 ;;;;
 ;;;; 	Copyright (C) 2001, 2004, 2006, 2009, 2010,
-;;;;      2012 Free Software Foundation, Inc.
+;;;;      2012, 2013 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,142 +311,138 @@ 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."
 
-  ;; 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 "#"))))
-         ((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 (+ 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)
+        (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 (+ 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)))))