[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-132-g6dce942
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-132-g6dce942 |
|
Date: |
Wed, 07 Aug 2013 05:26:03 +0000 |
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=6dce942c46494460369b8a93d3c657e1f6e57fed
The branch, master has been updated
via 6dce942c46494460369b8a93d3c657e1f6e57fed (commit)
from d8d7c7bf5706ce7873257eb88f0a5cc01b541858 (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 6dce942c46494460369b8a93d3c657e1f6e57fed
Author: Mark H Weaver <address@hidden>
Date: Wed Aug 7 00:46:34 2013 -0400
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.
-----------------------------------------------------------------------
Summary of changes:
benchmark-suite/benchmarks/ports.bm | 16 +-
doc/ref/api-io.texi | 24 --
doc/ref/srfi-modules.texi | 19 +-
libguile/strports.c | 39 ++--
module/ice-9/boot-9.scm | 4 +-
module/ice-9/format.scm | 7 +-
module/ice-9/pretty-print.scm | 272 +++++++++++------------
module/rnrs/io/ports.scm | 6 +-
module/srfi/srfi-6.scm | 20 +--
test-suite/test-suite/lib.scm | 21 +-
test-suite/tests/chars.test | 8 +-
test-suite/tests/ecmascript.test | 6 +-
test-suite/tests/ports.test | 139 +++++-------
test-suite/tests/print.test | 42 ++--
test-suite/tests/r6rs-ports.test | 21 +-
test-suite/tests/rdelim.test | 422 +++++++++++++++++------------------
test-suite/tests/reader.test | 6 +-
test-suite/tests/regexp.test | 18 +-
test-suite/tests/srfi-105.test | 5 +-
19 files changed, 495 insertions(+), 600 deletions(-)
diff --git a/benchmark-suite/benchmarks/ports.bm
b/benchmark-suite/benchmarks/ports.bm
index 630ece2..0b1d7f5 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 4c42de8..8e3d40a 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
address@hidden fluid (@pxref{Ports,
address@hidden). 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:
-
address@hidden
-(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))))
-
address@hidden
-Throw to key `encoding-error'
address@hidden 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 f0158d5..d97f498 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},
address@hidden 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:
-
address@hidden
-(use-modules (srfi srfi-6))
address@hidden example
address@hidden 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 40f656e..f10ede9 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 8bf7248..30aabb9 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 eed8cbb..1ef4cb5 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 5c23cb0..1573c6f 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 069574a..2968dbd 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 7b8bcb1..e6f8b43 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 e25df78..740beb1 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 98854f7..55cfead 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 <address@hidden>
;;;;
-;;;; 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 17036f9..96b1d66 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 65c87da..3d0bba5 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 e60a40f..47a1077 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 4b756cc..d0ae9d3 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 5cfe646..437a0ee 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 6e02255..e1fe22d 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 <address@hidden>
;;;;
;;;; 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 6799423..d25a3d4 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 99a084b..d212bd0 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)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-132-g6dce942,
Mark H Weaver <=