summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2013-08-07 00:46:34 -0400
committerMark H Weaver <mhw@netris.org>2013-08-07 01:22:22 -0400
commit6dce942c46494460369b8a93d3c657e1f6e57fed (patch)
treef8242c3dea0e724e78018a32c558f9d11d763bc5
parentd8d7c7bf5706ce7873257eb88f0a5cc01b541858 (diff)
downloadguile-6dce942c46494460369b8a93d3c657e1f6e57fed.tar.gz
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.
-rw-r--r--benchmark-suite/benchmarks/ports.bm16
-rw-r--r--doc/ref/api-io.texi24
-rw-r--r--doc/ref/srfi-modules.texi19
-rw-r--r--libguile/strports.c39
-rw-r--r--module/ice-9/boot-9.scm4
-rw-r--r--module/ice-9/format.scm7
-rw-r--r--module/ice-9/pretty-print.scm272
-rw-r--r--module/rnrs/io/ports.scm6
-rw-r--r--module/srfi/srfi-6.scm20
-rw-r--r--test-suite/test-suite/lib.scm21
-rw-r--r--test-suite/tests/chars.test8
-rw-r--r--test-suite/tests/ecmascript.test6
-rw-r--r--test-suite/tests/ports.test139
-rw-r--r--test-suite/tests/print.test42
-rw-r--r--test-suite/tests/r6rs-ports.test21
-rw-r--r--test-suite/tests/rdelim.test422
-rw-r--r--test-suite/tests/reader.test6
-rw-r--r--test-suite/tests/regexp.test18
-rw-r--r--test-suite/tests/srfi-105.test5
19 files changed, 495 insertions, 600 deletions
diff --git a/benchmark-suite/benchmarks/ports.bm b/benchmark-suite/benchmarks/ports.bm
index 630ece290..0b1d7f5f3 100644
--- a/benchmark-suite/benchmarks/ports.bm
+++ b/benchmark-suite/benchmarks/ports.bm
@@ -1,6 +1,6 @@
;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
@@ -34,16 +34,15 @@
(string-concatenate (make-list (* iteration-factor 10000) s)))
(define %latin1-port
- (with-fluids ((%default-port-encoding #f))
- (open-input-string (large-string "hello, world"))))
+ (let ((p (open-input-string (large-string "hello, world"))))
+ (set-port-encoding! p "ISO-8859-1")
+ p))
(define %utf8/ascii-port
- (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string (large-string "hello, world"))))
+ (open-input-string (large-string "hello, world")))
(define %utf8/wide-port
- (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string (large-string "안녕하세요"))))
+ (open-input-string (large-string "안녕하세요")))
(with-benchmark-prefix "peek-char"
@@ -87,6 +86,5 @@
(let ((str (string-concatenate (make-list 1000 "one line\n"))))
(benchmark "read-line" 1000
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str))))
+ (let ((port (open-input-string str)))
(sequence (read-line port) 1000)))))
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 4c42de8d0..8e3d40a69 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -1066,28 +1066,6 @@ away from its default.
Calls the one-argument procedure @var{proc} with a newly created output
port. When the function returns, the string composed of the characters
written into the port is returned. @var{proc} should not close the port.
-
-Note that which characters can be written to a string port depend on the port's
-encoding. The default encoding of string ports is specified by the
-@code{%default-port-encoding} fluid (@pxref{Ports,
-@code{%default-port-encoding}}). For instance, it is an error to write Greek
-letter alpha to an ISO-8859-1-encoded string port since this character cannot be
-represented with ISO-8859-1:
-
-@example
-(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
-
-(with-fluids ((%default-port-encoding "ISO-8859-1"))
- (call-with-output-string
- (lambda (p)
- (display alpha p))))
-
-@result{}
-Throw to key `encoding-error'
-@end example
-
-Changing the string port's encoding to a Unicode-capable encoding such as UTF-8
-solves the problem.
@end deffn
@deffn {Scheme Procedure} call-with-input-string string proc
@@ -1101,8 +1079,6 @@ read. The value yielded by the @var{proc} is returned.
Calls the zero-argument procedure @var{thunk} with the current output
port set temporarily to a new string port. It returns a string
composed of the characters written to the current output.
-
-See @code{call-with-output-string} above for character encoding considerations.
@end deffn
@deffn {Scheme Procedure} with-input-from-string string thunk
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index f0158d5e8..d97f49820 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -146,6 +146,7 @@ guile-2 ;; starting from Guile 2.x
r5rs
srfi-0
srfi-4
+srfi-6
srfi-13
srfi-14
srfi-23
@@ -1851,19 +1852,11 @@ uniform numeric vector, it is returned unchanged.
@cindex SRFI-6
SRFI-6 defines the procedures @code{open-input-string},
-@code{open-output-string} and @code{get-output-string}.
-
-Note that although versions of these procedures are included in the
-Guile core, the core versions are not fully conformant with SRFI-6:
-attempts to read or write characters that are not supported by the
-current @code{%default-port-encoding} will fail.
-
-We therefore recommend that you import this module, which supports all
-characters:
-
-@example
-(use-modules (srfi srfi-6))
-@end example
+@code{open-output-string} and @code{get-output-string}. These
+procedures are included in the Guile core, so using this module does not
+make any difference at the moment. But it is possible that support for
+SRFI-6 will be factored out of the core library in the future, so using
+this module does not hurt, after all.
@node SRFI-8
@subsection SRFI-8 - receive
diff --git a/libguile/strports.c b/libguile/strports.c
index 40f656e4b..f10ede962 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -251,57 +251,60 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
{
SCM z, buf;
scm_t_port *pt;
- const char *encoding;
- size_t read_buf_size, str_len, c_pos;
+ size_t read_buf_size, num_bytes, c_byte_pos;
char *c_buf;
if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
- encoding = scm_i_default_port_encoding ();
-
if (scm_is_false (str))
{
/* Allocate a new buffer to write to. */
- str_len = INITIAL_BUFFER_SIZE;
- buf = scm_c_make_bytevector (str_len);
+ num_bytes = INITIAL_BUFFER_SIZE;
+ buf = scm_c_make_bytevector (num_bytes);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
/* Reset `read_buf_size'. It will contain the actual number of
bytes written to the port. */
read_buf_size = 0;
- c_pos = 0;
+ c_byte_pos = 0;
}
else
{
- /* STR is a string. */
char *copy;
SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
- /* Create a copy of STR in ENCODING. */
- copy = scm_to_stringn (str, &str_len, encoding,
- SCM_FAILED_CONVERSION_ERROR);
- buf = scm_c_make_bytevector (str_len);
+ /* STR is a string. */
+ /* Create a copy of STR in UTF-8. */
+ copy = scm_to_utf8_stringn (str, &num_bytes);
+ buf = scm_c_make_bytevector (num_bytes);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
- memcpy (c_buf, copy, str_len);
+ memcpy (c_buf, copy, num_bytes);
free (copy);
- c_pos = scm_to_unsigned_integer (pos, 0, str_len);
- read_buf_size = str_len;
+ read_buf_size = num_bytes;
+
+ if (scm_is_eq (pos, SCM_INUM0))
+ c_byte_pos = 0;
+ else
+ /* Inefficient but simple way to convert the character position
+ POS into a byte position C_BYTE_POS. */
+ free (scm_to_utf8_stringn (scm_substring (str, SCM_INUM0, pos),
+ &c_byte_pos));
}
z = scm_c_make_port_with_encoding (scm_tc16_strport, modes,
- encoding,
+ "UTF-8",
scm_i_default_port_conversion_handler (),
(scm_t_bits)buf);
pt = SCM_PTAB_ENTRY (z);
pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
- pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
+ pt->read_pos = pt->write_pos = pt->read_buf + c_byte_pos;
pt->read_buf_size = read_buf_size;
- pt->write_buf_size = str_len;
+ pt->write_buf_size = num_bytes;
pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
pt->rw_random = 1;
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8bf724824..30aabb9fc 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -4196,9 +4196,7 @@ when none is available, reading FILE-NAME with READER."
r5rs
srfi-0 ;; cond-expand itself
srfi-4 ;; homogeneous numeric vectors
- ;; We omit srfi-6 because the 'open-input-string' etc in Guile
- ;; core are not conformant with SRFI-6; they expose details
- ;; of the binary I/O model and may fail to support some characters.
+ srfi-6 ;; string ports
srfi-13 ;; string library
srfi-14 ;; character sets
srfi-23 ;; `error` procedure
diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm
index eed8cbb0e..1ef4cb5ef 100644
--- a/module/ice-9/format.scm
+++ b/module/ice-9/format.scm
@@ -1,5 +1,5 @@
;;;; "format.scm" Common LISP text output formatter for SLIB
-;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 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
@@ -42,10 +42,7 @@
(let* ((port
(cond
- ((not destination)
- ;; Use a Unicode-capable output string port.
- (with-fluids ((%default-port-encoding "UTF-8"))
- (open-output-string)))
+ ((not destination) (open-output-string))
((boolean? destination) (current-output-port)) ; boolean but not false
((output-port? destination) destination)
((number? destination)
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)))))
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 069574a49..2968dbd9f 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -303,8 +303,7 @@ read from/written to in @var{port}."
(define (open-string-input-port str)
"Open an input port that will read from @var{str}."
- (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str)))
+ (open-input-string str))
(define (r6rs-open filename mode buffer-mode transcoder)
(let ((port (with-i/o-filename-conditions filename
@@ -349,8 +348,7 @@ read from/written to in @var{port}."
(define (open-string-output-port)
"Return two values: an output port that will collect characters written to it
as a string, and a thunk to retrieve the characters associated with that port."
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-output-string))))
+ (let ((port (open-output-string)))
(values port
(lambda () (get-output-string port)))))
diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm
index 7b8bcb114..e6f8b438a 100644
--- a/module/srfi/srfi-6.scm
+++ b/module/srfi/srfi-6.scm
@@ -1,6 +1,7 @@
;;; srfi-6.scm --- Basic String Ports
-;; Copyright (C) 2001, 2002, 2003, 2006, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2006, 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
@@ -23,21 +24,6 @@
;;; Code:
(define-module (srfi srfi-6)
- #:replace (open-input-string open-output-string)
- #:re-export (get-output-string))
-
-;; SRFI-6 says nothing about encodings, and assumes that any character
-;; or string can be written to a string port. Thus, make all SRFI-6
-;; string ports Unicode capable. See <http://bugs.gnu.org/11197>.
-
-(define (open-input-string s)
- (with-fluids ((%default-port-encoding "UTF-8"))
- ((@ (guile) open-input-string) s)))
-
-(define (open-output-string)
- (with-fluids ((%default-port-encoding "UTF-8"))
- ((@ (guile) open-output-string))))
-
-(cond-expand-provide (current-module) '(srfi-6))
+ #:re-export (open-input-string open-output-string get-output-string))
;;; srfi-6.scm ends here
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index e25df7891..740beb1ee 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -428,18 +428,15 @@
;;;; Turn a test name into a nice human-readable string.
(define (format-test-name name)
- ;; Choose a Unicode-capable encoding so that the string port can contain any
- ;; valid Unicode character.
- (with-fluids ((%default-port-encoding "UTF-8"))
- (call-with-output-string
- (lambda (port)
- (let loop ((name name)
- (separator ""))
- (if (pair? name)
- (begin
- (display separator port)
- (display (car name) port)
- (loop (cdr name) ": "))))))))
+ (call-with-output-string
+ (lambda (port)
+ (let loop ((name name)
+ (separator ""))
+ (if (pair? name)
+ (begin
+ (display separator port)
+ (display (car name) port)
+ (loop (cdr name) ": ")))))))
;;;; For a given test-name, deliver the full name including all prefixes.
(define (full-name name)
diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test
index 98854f73a..55cfead23 100644
--- a/test-suite/tests/chars.test
+++ b/test-suite/tests/chars.test
@@ -1,7 +1,7 @@
;;;; chars.test --- Characters. -*- coding: utf-8; mode: scheme; -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
-;;;; Copyright (C) 2000, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2006, 2009, 2010, 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
@@ -316,13 +316,11 @@
(pass-if "combining accent is pretty-printed"
(let ((accent (integer->char #x030f))) ; COMBINING DOUBLE GRAVE ACCENT
(string=?
- (with-fluids ((%default-port-encoding "UTF-8"))
- (with-output-to-string (lambda () (write accent))))
+ (with-output-to-string (lambda () (write accent)))
"#\\◌̏")))
(pass-if "combining X is pretty-printed"
(let ((x (integer->char #x0353))) ; COMBINING X BELOW
(string=?
- (with-fluids ((%default-port-encoding "UTF-8"))
- (with-output-to-string (lambda () (write x))))
+ (with-output-to-string (lambda () (write x)))
"#\\◌͓")))))
diff --git a/test-suite/tests/ecmascript.test b/test-suite/tests/ecmascript.test
index 17036f93d..96b1d6666 100644
--- a/test-suite/tests/ecmascript.test
+++ b/test-suite/tests/ecmascript.test
@@ -23,11 +23,9 @@
(define (eread str)
- (with-fluids ((%default-port-encoding "utf-8"))
- (call-with-input-string str read-ecmascript)))
+ (call-with-input-string str read-ecmascript))
(define (eread/1 str)
- (with-fluids ((%default-port-encoding "utf-8"))
- (call-with-input-string str read-ecmascript/1)))
+ (call-with-input-string str read-ecmascript/1))
(define-syntax parse
(syntax-rules ()
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 65c87da10..3d0bba588 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -698,32 +698,15 @@
(pass-if "output check"
(string=? text result)))
- (pass-if "encoding failure leads to exception"
- ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
- ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
- (catch 'encoding-error
- (lambda ()
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (let ((p (open-input-string "λ"))) ; raise an exception
- #f)))
- (lambda (key . rest)
- #t)
- (lambda (key . rest)
- ;; At this point, the port-table mutex used to be still held,
- ;; hence the deadlock. This situation would occur when trying
- ;; to print a backtrace, for instance.
- (input-port? (open-input-string "foo")))))
-
- (pass-if "%default-port-encoding is honored"
- (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
- (equal? (map (lambda (e)
- (with-fluids ((%default-port-encoding e))
- (call-with-output-string
- (lambda (p)
- (and (string=? e (port-encoding p))
- (display (port-encoding p) p))))))
- encodings)
- encodings)))
+ (pass-if "%default-port-encoding is ignored"
+ (let ((str "ĉu bone?"))
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-conversion-strategy! p 'substitute)
+ (display str p)))
+ "ĉu bone?"))))
(pass-if "%default-port-conversion-strategy is honored"
(let ((strategies '(error substitute escape)))
@@ -740,77 +723,58 @@
(map symbol->string strategies))))
(pass-if "suitable encoding [latin-1]"
- (let ((str "hello, world"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (equal? str
- (with-output-to-string
- (lambda ()
- (display str)))))))
+ (let ((str "hello, world")
+ (encoding "ISO-8859-1"))
+ (equal? str
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (display str p))))))
(pass-if "suitable encoding [latin-3]"
- (let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-3"))
- (equal? str
- (with-output-to-string
- (lambda ()
- (display str)))))))
+ (let ((str "ĉu bone?")
+ (encoding "ISO-8859-3"))
+ (equal? str
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (display str p))))))
(pass-if "wrong encoding, error"
(let ((str "ĉu bone?"))
(catch 'encoding-error
(lambda ()
- ;; Latin-1 cannot represent ‘ĉ’.
- (with-fluids ((%default-port-encoding "ISO-8859-1")
- (%default-port-conversion-strategy 'error))
- (with-output-to-string
- (lambda ()
- (display str))))
- #f) ; so the test really fails here
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (call-with-output-string
+ (lambda (p)
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (set-port-encoding! p "ISO-8859-1")
+ (display str p))))
+ #f) ; so the test really fails here
(lambda (key subr message errno port chr)
(and (eqv? chr #\ĉ)
(string? (strerror errno)))))))
(pass-if "wrong encoding, substitute"
(let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (string=? (with-output-to-string
- (lambda ()
- (set-port-conversion-strategy! (current-output-port)
- 'substitute)
- (display str)))
- "?u bone?"))))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p "ISO-8859-1")
+ (set-port-conversion-strategy! p 'substitute)
+ (display str p)))
+ "?u bone?")))
(pass-if "wrong encoding, escape"
(let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (string=? (with-output-to-string
- (lambda ()
- (set-port-conversion-strategy! (current-output-port)
- 'escape)
- (display str)))
- "\\u0109u bone?"))))
-
- (pass-if "peek-char [latin-1]"
- (let ((p (with-fluids ((%default-port-encoding #f))
- (open-input-string "hello, world"))))
- (and (char=? (peek-char p) #\h)
- (char=? (peek-char p) #\h)
- (char=? (peek-char p) #\h)
- (= (port-line p) 0)
- (= (port-column p) 0))))
-
- (pass-if "peek-char [utf-8]"
- (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "안녕하세요"))))
- (and (char=? (peek-char p) #\안)
- (char=? (peek-char p) #\안)
- (char=? (peek-char p) #\안)
- (= (port-line p) 0)
- (= (port-column p) 0))))
-
- (pass-if "peek-char [utf-16]"
- (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
- (open-input-string "안녕하세요"))))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p "ISO-8859-1")
+ (set-port-conversion-strategy! p 'escape)
+ (display str p)))
+ "\\u0109u bone?")))
+
+ (pass-if "peek-char"
+ (let ((p (open-input-string "안녕하세요")))
(and (char=? (peek-char p) #\안)
(char=? (peek-char p) #\안)
(char=? (peek-char p) #\안)
@@ -1207,10 +1171,15 @@
(set-port-encoding! p "does-not-exist")
(read p)))
- (pass-if-exception "%default-port-encoding, wrong encoding"
- exception:miscellaneous-error
- (read (with-fluids ((%default-port-encoding "does-not-exist"))
- (open-input-string "")))))
+ (let ((filename (test-file)))
+ (with-output-to-file filename (lambda () (write 'test)))
+
+ (pass-if-exception "%default-port-encoding, wrong encoding"
+ exception:miscellaneous-error
+ (read (with-fluids ((%default-port-encoding "does-not-exist"))
+ (open-input-file filename))))
+
+ (delete-file filename)))
;;;
;;; port-for-each
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index e60a40f7d..47a107736 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -1,6 +1,6 @@
;;;; -*- coding: utf-8; mode: scheme; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 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
@@ -59,31 +59,31 @@
(define exp '(a b #(c d e) f . g))
(define (tprint x width encoding)
- (with-fluids ((%default-port-encoding encoding))
- (with-output-to-string
- (lambda ()
- (truncated-print x #:width width)))))
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (truncated-print x p #:width width))))
- (pass-if (equal? (tprint exp 10 "ISO-8859-1")
- "(a b . #)"))
+ (pass-if-equal "(a b . #)"
+ (tprint exp 10 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 15 "ISO-8859-1")
- "(a b # f . g)"))
+ (pass-if-equal "(a b # f . g)"
+ (tprint exp 15 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 18 "ISO-8859-1")
- "(a b #(c ...) . #)"))
+ (pass-if-equal "(a b #(c ...) . #)"
+ (tprint exp 18 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 20 "ISO-8859-1")
- "(a b #(c d e) f . g)"))
+ (pass-if-equal "(a b #(c d e) f . g)"
+ (tprint exp 20 "ISO-8859-1"))
- (pass-if (equal? (tprint "The quick brown fox" 20 "ISO-8859-1")
- "\"The quick brown...\""))
+ (pass-if-equal "\"The quick brown...\""
+ (tprint "The quick brown fox" 20 "ISO-8859-1"))
- (pass-if (equal? (tprint "The quick brown fox" 20 "UTF-8")
- "\"The quick brown f…\""))
+ (pass-if-equal "\"The quick brown f…\""
+ (tprint "The quick brown fox" 20 "UTF-8"))
- (pass-if (equal? (tprint (current-module) 20 "ISO-8859-1")
- "#<directory (tes...>"))
+ (pass-if-equal "#<directory (tes...>"
+ (tprint (current-module) 20 "ISO-8859-1"))
- (pass-if (equal? (tprint (current-module) 20 "UTF-8")
- "#<directory (test-…>")))
+ (pass-if-equal "#<directory (test-…>"
+ (tprint (current-module) 20 "UTF-8")))
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 4b756cce8..d0ae9d395 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,6 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -98,8 +98,7 @@
(eof-object? (get-u8 port)))))
(pass-if "lookahead-u8 non-ASCII"
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "λ"))))
+ (let ((port (open-input-string "λ")))
(and (= 206 (lookahead-u8 port))
(= 206 (lookahead-u8 port))
(= 206 (get-u8 port))
@@ -272,21 +271,21 @@
(let* ((str "hello, world")
(bv (string->utf16 str)))
(equal? str
- (with-fluids ((%default-port-encoding "UTF-16BE"))
- (call-with-output-string
- (lambda (port)
- (put-bytevector port bv)))))))
+ (call-with-output-string
+ (lambda (port)
+ (set-port-encoding! port "UTF-16BE")
+ (put-bytevector port bv))))))
(pass-if "put-bytevector with wrong-encoding string port"
(let* ((str "hello, world")
(bv (string->utf16 str)))
(catch 'decoding-error
(lambda ()
- (with-fluids ((%default-port-encoding "UTF-32")
- (%default-port-conversion-strategy 'error))
+ (with-fluids ((%default-port-conversion-strategy 'error))
(call-with-output-string
- (lambda (port)
- (put-bytevector port bv)))
+ (lambda (port)
+ (set-port-encoding! port "UTF-32")
+ (put-bytevector port bv)))
#f)) ; fail if we reach this point
(lambda (key subr message errno port)
(string? (strerror errno)))))))
diff --git a/test-suite/tests/rdelim.test b/test-suite/tests/rdelim.test
index 5cfe6460d..437a0ee40 100644
--- a/test-suite/tests/rdelim.test
+++ b/test-suite/tests/rdelim.test
@@ -22,227 +22,225 @@
#:use-module ((rnrs io ports) #:select (open-bytevector-input-port))
#:use-module (test-suite lib))
-(with-fluids ((%default-port-encoding "UTF-8"))
-
- (with-test-prefix "read-line"
-
- (pass-if "one line"
- (let* ((s "hello, world")
- (p (open-input-string s)))
- (and (string=? s (read-line p))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, trim"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? (string-tokenize s)
- (list (read-line p) (read-line p)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, concat"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '("foo\n" "bar\n")
- (list (read-line p 'concat)
- (read-line p 'concat)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, peek"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '("foo" #\newline "bar" #\newline)
- (list (read-line p 'peek) (read-char p)
- (read-line p 'peek) (read-char p)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, split"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '(("foo" . #\newline)
- ("bar" . #\newline))
- (list (read-line p 'split)
- (read-line p 'split)))
- (eof-object? (read-line p)))))
-
- (pass-if "two Greek lines, trim"
- (let* ((s "λαμβδα\nμυ\n")
- (p (open-input-string s)))
- (and (equal? (string-tokenize s)
- (list (read-line p) (read-line p)))
- (eof-object? (read-line p)))))
-
- (pass-if "decoding error"
- (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'error)
- (catch 'decoding-error
- (lambda ()
- (read-line p)
- #f)
- (lambda (key subr message err port)
- (and (eq? port p)
-
- ;; PORT should now point past the error.
- (string=? (read-line p) "BCD")
- (eof-object? (read-line p)))))))
-
- (pass-if "decoding error, substitute"
- (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'substitute)
- (and (string=? (read-line p) "A?BCD")
- (eof-object? (read-line p))))))
+(with-test-prefix "read-line"
+
+ (pass-if "one line"
+ (let* ((s "hello, world")
+ (p (open-input-string s)))
+ (and (string=? s (read-line p))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, trim"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? (string-tokenize s)
+ (list (read-line p) (read-line p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, concat"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '("foo\n" "bar\n")
+ (list (read-line p 'concat)
+ (read-line p 'concat)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, peek"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '("foo" #\newline "bar" #\newline)
+ (list (read-line p 'peek) (read-char p)
+ (read-line p 'peek) (read-char p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, split"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '(("foo" . #\newline)
+ ("bar" . #\newline))
+ (list (read-line p 'split)
+ (read-line p 'split)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two Greek lines, trim"
+ (let* ((s "λαμβδα\nμυ\n")
+ (p (open-input-string s)))
+ (and (equal? (string-tokenize s)
+ (list (read-line p) (read-line p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "decoding error"
+ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
+ (set-port-encoding! p "UTF-8")
+ (set-port-conversion-strategy! p 'error)
+ (catch 'decoding-error
+ (lambda ()
+ (read-line p)
+ #f)
+ (lambda (key subr message err port)
+ (and (eq? port p)
+
+ ;; PORT should now point past the error.
+ (string=? (read-line p) "BCD")
+ (eof-object? (read-line p)))))))
+
+ (pass-if "decoding error, substitute"
+ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
+ (set-port-encoding! p "UTF-8")
+ (set-port-conversion-strategy! p 'substitute)
+ (and (string=? (read-line p) "A?BCD")
+ (eof-object? (read-line p))))))
- (with-test-prefix "read-delimited"
+(with-test-prefix "read-delimited"
- (pass-if "delimiter hit"
- (let ((p (open-input-string "hello, world!")))
- (and (string=? "hello" (read-delimited ",.;" p))
- (string=? " world!" (read-delimited ",.;" p))
- (eof-object? (read-delimited ",.;" p)))))
+ (pass-if "delimiter hit"
+ (let ((p (open-input-string "hello, world!")))
+ (and (string=? "hello" (read-delimited ",.;" p))
+ (string=? " world!" (read-delimited ",.;" p))
+ (eof-object? (read-delimited ",.;" p)))))
- (pass-if "delimiter hit, split"
- (equal? '("hello" . #\,)
- (read-delimited ",.;"
- (open-input-string "hello, world!")
- 'split)))
+ (pass-if "delimiter hit, split"
+ (equal? '("hello" . #\,)
+ (read-delimited ",.;"
+ (open-input-string "hello, world!")
+ 'split)))
- (pass-if "delimiter hit, concat"
- (equal? '"hello,"
- (read-delimited ",.;" (open-input-string "hello, world!")
- 'concat)))
+ (pass-if "delimiter hit, concat"
+ (equal? '"hello,"
+ (read-delimited ",.;" (open-input-string "hello, world!")
+ 'concat)))
- (pass-if "delimiter hit, peek"
- (let ((p (open-input-string "hello, world!")))
- (and (string=? "hello" (read-delimited ",.;" p 'peek))
- (char=? #\, (peek-char p)))))
+ (pass-if "delimiter hit, peek"
+ (let ((p (open-input-string "hello, world!")))
+ (and (string=? "hello" (read-delimited ",.;" p 'peek))
+ (char=? #\, (peek-char p)))))
- (pass-if "eof"
- (eof-object? (read-delimited "}{" (open-input-string "")))))
+ (pass-if "eof"
+ (eof-object? (read-delimited "}{" (open-input-string "")))))
- (with-test-prefix "read-delimited!"
-
- (pass-if "delimiter hit"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p))
- (string=? (substring s 0 5) "hello")
- (= 7 (read-delimited! ",.;" s p))
- (string=? (substring s 0 7) " world!")
- (eof-object? (read-delimited! ",.;" s p)))))
-
- (pass-if "delimiter hit, start+end"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p 'trim 10 30))
- (string=? (substring s 10 15) "hello"))))
-
- (pass-if "delimiter hit, split"
- (let ((s (make-string 123)))
- (and (equal? '(5 . #\,)
- (read-delimited! ",.;" s
- (open-input-string "hello, world!")
- 'split))
- (string=? (substring s 0 5) "hello"))))
-
- (pass-if "delimiter hit, concat"
- (let ((s (make-string 123)))
- (and (= 6 (read-delimited! ",.;" s
- (open-input-string "hello, world!")
- 'concat))
- (string=? (substring s 0 6) "hello,"))))
-
- (pass-if "delimiter hit, peek"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p 'peek))
- (string=? (substring s 0 5) "hello")
- (char=? #\, (peek-char p)))))
-
- (pass-if "string too small"
- (let ((s (make-string 7)))
- (and (= 7 (read-delimited! "}{" s
- (open-input-string "hello, world!")))
- (string=? s "hello, "))))
-
- (pass-if "string too small, start+end"
- (let ((s (make-string 123)))
- (and (= 7 (read-delimited! "}{" s
- (open-input-string "hello, world!")
- 'trim
- 70 77))
- (string=? (substring s 70 77) "hello, "))))
-
- (pass-if "string too small, split"
- (let ((s (make-string 7)))
- (and (equal? '(7 . #f)
- (read-delimited! "}{" s
- (open-input-string "hello, world!")
- 'split))
- (string=? s "hello, "))))
-
- (pass-if "eof"
- (eof-object? (read-delimited! ":" (make-string 7)
- (open-input-string ""))))
-
- (pass-if "eof, split"
- (eof-object? (read-delimited! ":" (make-string 7)
- (open-input-string "")))))
-
- (with-test-prefix "read-string"
-
- (pass-if "short string"
- (let* ((s "hello, world!")
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if "100 chars"
- (let* ((s (make-string 100 #\space))
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if "longer than 100 chars"
- (let* ((s (string-concatenate (make-list 20 "hello, world!")))
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) "")))))
-
- (with-test-prefix "read-string!"
-
- (pass-if "buf smaller"
- (let* ((s "hello, world!")
- (len (1- (string-length s)))
- (buf (make-string len #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? buf (substring s 0 len))
- (= (read-string! buf p) 1)
- (string=? (substring buf 0 1) (substring s len)))))
-
- (pass-if "buf right size"
- (let* ((s "hello, world!")
- (len (string-length s))
- (buf (make-string len #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? buf (substring s 0 len))
- (= (read-string! buf p) 0)
- (string=? buf (substring s 0 len)))))
-
- (pass-if "buf bigger"
- (let* ((s "hello, world!")
- (len (string-length s))
- (buf (make-string (1+ len) #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? (substring buf 0 len) s)
- (= (read-string! buf p) 0)
- (string=? (substring buf 0 len) s)
- (string=? (substring buf len) "."))))))
+(with-test-prefix "read-delimited!"
+
+ (pass-if "delimiter hit"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p))
+ (string=? (substring s 0 5) "hello")
+ (= 7 (read-delimited! ",.;" s p))
+ (string=? (substring s 0 7) " world!")
+ (eof-object? (read-delimited! ",.;" s p)))))
+
+ (pass-if "delimiter hit, start+end"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p 'trim 10 30))
+ (string=? (substring s 10 15) "hello"))))
+
+ (pass-if "delimiter hit, split"
+ (let ((s (make-string 123)))
+ (and (equal? '(5 . #\,)
+ (read-delimited! ",.;" s
+ (open-input-string "hello, world!")
+ 'split))
+ (string=? (substring s 0 5) "hello"))))
+
+ (pass-if "delimiter hit, concat"
+ (let ((s (make-string 123)))
+ (and (= 6 (read-delimited! ",.;" s
+ (open-input-string "hello, world!")
+ 'concat))
+ (string=? (substring s 0 6) "hello,"))))
+
+ (pass-if "delimiter hit, peek"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p 'peek))
+ (string=? (substring s 0 5) "hello")
+ (char=? #\, (peek-char p)))))
+
+ (pass-if "string too small"
+ (let ((s (make-string 7)))
+ (and (= 7 (read-delimited! "}{" s
+ (open-input-string "hello, world!")))
+ (string=? s "hello, "))))
+
+ (pass-if "string too small, start+end"
+ (let ((s (make-string 123)))
+ (and (= 7 (read-delimited! "}{" s
+ (open-input-string "hello, world!")
+ 'trim
+ 70 77))
+ (string=? (substring s 70 77) "hello, "))))
+
+ (pass-if "string too small, split"
+ (let ((s (make-string 7)))
+ (and (equal? '(7 . #f)
+ (read-delimited! "}{" s
+ (open-input-string "hello, world!")
+ 'split))
+ (string=? s "hello, "))))
+
+ (pass-if "eof"
+ (eof-object? (read-delimited! ":" (make-string 7)
+ (open-input-string ""))))
+
+ (pass-if "eof, split"
+ (eof-object? (read-delimited! ":" (make-string 7)
+ (open-input-string "")))))
+
+(with-test-prefix "read-string"
+
+ (pass-if "short string"
+ (let* ((s "hello, world!")
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if "100 chars"
+ (let* ((s (make-string 100 #\space))
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if "longer than 100 chars"
+ (let* ((s (string-concatenate (make-list 20 "hello, world!")))
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) "")))))
+
+(with-test-prefix "read-string!"
+
+ (pass-if "buf smaller"
+ (let* ((s "hello, world!")
+ (len (1- (string-length s)))
+ (buf (make-string len #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? buf (substring s 0 len))
+ (= (read-string! buf p) 1)
+ (string=? (substring buf 0 1) (substring s len)))))
+
+ (pass-if "buf right size"
+ (let* ((s "hello, world!")
+ (len (string-length s))
+ (buf (make-string len #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? buf (substring s 0 len))
+ (= (read-string! buf p) 0)
+ (string=? buf (substring s 0 len)))))
+
+ (pass-if "buf bigger"
+ (let* ((s "hello, world!")
+ (len (string-length s))
+ (buf (make-string (1+ len) #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? (substring buf 0 len) s)
+ (= (read-string! buf p) 0)
+ (string=? (substring buf 0 len) s)
+ (string=? (substring buf len) ".")))))
;;; Local Variables:
;;; eval: (put 'with-test-prefix 'scheme-indent-function 1)
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 6e02255ad..e1fe22dad 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,6 +1,7 @@
;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*-
;;;;
-;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010, 2011,
+;;;; 2013 Free Software Foundation, Inc.
;;;; Jim Blandy <jimb@red-bean.com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -47,8 +48,7 @@
(define (read-string s)
- (with-fluids ((%default-port-encoding #f))
- (with-input-from-string s (lambda () (read)))))
+ (with-input-from-string s (lambda () (read))))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index 6799423fc..d25a3d42d 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -155,14 +155,6 @@
(define char-code-limit 256)
-;; Since `regexp-quote' uses string ports, and since it is used below
-;; with non-ASCII characters, these ports must be Unicode-capable.
-(define-syntax with-unicode
- (syntax-rules ()
- ((_ exp)
- (with-fluids ((%default-port-encoding "UTF-8"))
- exp))))
-
(with-test-prefix "regexp-quote"
(pass-if-exception "no args" exception:wrong-num-args
@@ -191,7 +183,7 @@
(s (string c)))
(pass-if (list "char" i (format #f "~s ~s" c s))
(with-ascii-or-latin1-locale i
- (let* ((q (with-unicode (regexp-quote s)))
+ (let* ((q (regexp-quote s))
(m (regexp-exec (make-regexp q flag) s)))
(and (= 0 (match:start m))
(= 1 (match:end m))))))))
@@ -204,7 +196,7 @@
((>= i 256))
(let* ((c (integer->char i))
(s (string #\a c))
- (q (with-unicode (regexp-quote s))))
+ (q (regexp-quote s)))
(pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
(with-ascii-or-latin1-locale i
(let* ((m (regexp-exec (make-regexp q flag) s)))
@@ -213,9 +205,9 @@
(pass-if "string of all chars"
(with-latin1-locale
- (let ((m (regexp-exec (make-regexp (with-unicode
- (regexp-quote allchars))
- flag) allchars)))
+ (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
+ flag)
+ allchars)))
(and (= 0 (match:start m))
(= (string-length allchars) (match:end m)))))))))
lst)))
diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test
index 99a084bb3..d212bd084 100644
--- a/test-suite/tests/srfi-105.test
+++ b/test-suite/tests/srfi-105.test
@@ -1,6 +1,6 @@
;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 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
@@ -21,8 +21,7 @@
#:use-module (srfi srfi-1))
(define (read-string s)
- (with-fluids ((%default-port-encoding #f))
- (with-input-from-string s read)))
+ (with-input-from-string s read))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))