mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

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

Browse source 
* 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.
This commit is contained in:
Mark H Weaver 2013-08-07 00:46:34 -04:00
parent d8d7c7bf57
commit 6dce942c46
19 changed files with 468 additions and 573 deletions
Download patch file Download diff file Expand all files Collapse all files

16
benchmark-suite/benchmarks/ports.bm
View file

@ -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)))))

24
doc/ref/api-io.texi
View file

@ -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

19
doc/ref/srfi-modules.texi
View file

@ -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

39
libguile/strports.c
View file

@ -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;

4
module/ice-9/boot-9.scm
View file

@ -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

7
module/ice-9/format.scm
View file

@ -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)

274
module/ice-9/pretty-print.scm
View file

@ -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)
(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
(define ellipsis
;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
;; on the encoding of PORT.
(let ((e "…"))
(catch 'encoding-error
(lambda ()
(print x width))))))
(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
((= 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 ()
(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)))))

6
module/rnrs/io/ports.scm
View file

@ -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)))))

20
module/srfi/srfi-6.scm
View file

@ -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

21
test-suite/test-suite/lib.scm
View file

@ -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)

8
test-suite/tests/chars.test
View file

@ -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)))
"#\\◌͓")))))

6
test-suite/tests/ecmascript.test
View file

@ -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 ()

137
test-suite/tests/ports.test
View file

@ -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?"))))
(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 [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 "안녕하세요"))))
(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

42
test-suite/tests/print.test
View file

@ -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")))

21
test-suite/tests/r6rs-ports.test
View file

@ -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)))))))

368
test-suite/tests/rdelim.test
View file

@ -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"
(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 "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, 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, 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, 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 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 "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)
(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)))))))
;; 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))))))
(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!"
(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"
(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, 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, 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, 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 "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"
(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, 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 "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"
(eof-object? (read-delimited! ":" (make-string 7)
(open-input-string ""))))
(pass-if "eof, split"
(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"
(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 "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 "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) "")))))
(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!"
(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 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 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) "."))))))
(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)

6
test-suite/tests/reader.test
View file

@ -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)))

18
test-suite/tests/regexp.test
View file

@ -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)))

5
test-suite/tests/srfi-105.test
View file

@ -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)))