From: Andreas Rottmann <a.rottmann@gmx.at>
To: guile-devel@gnu.org
Subject: [PATCH] Fix `get-string-n!' &i/o-decoding exception behavior
Date: Thu, 8 Nov 2012 00:51:48 +0100 [thread overview]
Message-ID: <1352332308-5191-1-git-send-email-a.rottmann@gmx.at> (raw)
Previously, `get-string-n!' from `(rnrs io ports)' would not throw the
exception required by R6RS, and could not easily do so due to being
implemented entirely in C.
This change fixes this by introducing a corresponding internal C
function reporting errors by return value and reimplementing the
`get-string-n!' in Scheme on top of that. Along with `get-string-n!',
`get-string-n' gets fixed, inheriting the correct behavior.
* libguile/ports.c (scm_i_getc): New function, a version of `scm_getc'
not using exceptions.
(scm_getc): Implemented using `scm_i_getc'.
* libguile/ports.h (scm_i_getc): Add prototype marked SCM_INTERNAL.
* libguile/r6rs-ports.c (scm_i_get_string_n_x): Exception-free version
of `get-string-n!', making use of `scm_i_getc'.
(scm_get_string_n_x): Removed, now implemented in Scheme.
* module/ice-9/binary-ports.scm (get-string-n!): Removed from export
list, it doesn't fit the module module purpose anyway.
* module/rnrs/io/ports.scm (%get-string-n): Newly defined by internal
reference to `(ice-9 binary-ports)'.
(get-string-n!): Implemented in Scheme on top of `%get-string-n!'.
* test-suite/tests/r6rs-ports.test ("8.2.9 Textual
input")["read-error"]: Activate commented-out exception-behavior tests
of `get-string-n!'.
["decoding error"]: New test prefix with tests for `get-char',
`get-string-n!' and `get-string-n' and `get-line'.
---
libguile/ports.c | 20 ++++++++++++++++----
libguile/ports.h | 1 +
libguile/r6rs-ports.c | 21 +++++++++++----------
module/ice-9/binary-ports.scm | 6 +++---
module/rnrs/io/ports.scm | 14 ++++++++++++++
test-suite/tests/r6rs-ports.test | 24 ++++++++++++++++++++----
6 files changed, 65 insertions(+), 21 deletions(-)
diff --git a/libguile/ports.c b/libguile/ports.c
index 55808e2..b653af4 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1392,12 +1392,10 @@ scm_t_wchar
scm_getc (SCM port)
#define FUNC_NAME "scm_getc"
{
- int err;
- size_t len;
+ int err = 0;
scm_t_wchar codepoint;
- char buf[SCM_MBCHAR_BUF_SIZE];
- err = get_codepoint (port, &codepoint, buf, &len);
+ codepoint = scm_i_getc (port, &err);
if (SCM_UNLIKELY (err != 0))
/* At this point PORT should point past the invalid encoding, as per
R6RS-lib Section 8.2.4. */
@@ -1407,6 +1405,20 @@ scm_getc (SCM port)
}
#undef FUNC_NAME
+/* Read a codepoint from PORT and return it. This version reports
+ errors via the ERROR argument instead of via exceptions. */
+scm_t_wchar
+scm_i_getc (SCM port, int *error)
+{
+ size_t len;
+ scm_t_wchar codepoint;
+ char buf[SCM_MBCHAR_BUF_SIZE];
+
+ *error = get_codepoint (port, &codepoint, buf, &len);
+
+ return codepoint;
+}
+
/* this should only be called when the read buffer is empty. it
tries to refill the read buffer. it returns the first char from
the port, which is either EOF or *(pt->read_pos). */
diff --git a/libguile/ports.h b/libguile/ports.h
index d4d59b7..2f70056 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -281,6 +281,7 @@ SCM_API SCM scm_force_output (SCM port);
SCM_API SCM scm_flush_all_ports (void);
SCM_API SCM scm_read_char (SCM port);
SCM_API scm_t_wchar scm_getc (SCM port);
+SCM_INTERNAL scm_t_wchar scm_i_getc (SCM port, int *error);
SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index e867429..bd10081 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1242,18 +1242,17 @@ SCM_DEFINE (scm_i_make_transcoded_port,
\f
/* Textual I/O */
-SCM_DEFINE (scm_get_string_n_x,
- "get-string-n!", 4, 0, 0,
+SCM_DEFINE (scm_i_get_string_n_x,
+ "%get-string-n!", 4, 0, 0,
(SCM port, SCM str, SCM start, SCM count),
- "Read up to @var{count} characters from @var{port} into "
- "@var{str}, starting at @var{start}. If no characters "
- "can be read before the end of file is encountered, the end "
- "of file object is returned. Otherwise, the number of "
- "characters read is returned.")
-#define FUNC_NAME s_scm_get_string_n_x
+ "Read up to @var{count} characters from @var{port} into @var{str}, "
+ "starting at @var{start}. Returns the end of file object, a list "
+ "containing an errno value, or the number of characters read.")
+#define FUNC_NAME s_scm_i_get_string_n_x
{
size_t c_start, c_count, c_len, c_end, j;
scm_t_wchar c;
+ int err;
SCM_VALIDATE_OPINPORT (1, port);
SCM_VALIDATE_STRING (2, str);
@@ -1267,8 +1266,10 @@ SCM_DEFINE (scm_get_string_n_x,
for (j = c_start; j < c_end; j++)
{
- c = scm_getc (port);
- if (c == EOF)
+ c = scm_i_getc (port, &err);
+ if (SCM_UNLIKELY (err != 0))
+ return scm_list_1 (scm_from_int (err));
+ else if (SCM_UNLIKELY (c == EOF))
{
size_t chars_read = j - c_start;
return chars_read == 0 ? SCM_EOF_VAL : scm_from_size_t (chars_read);
diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm
index c07900b..3f7b9e6 100644
--- a/module/ice-9/binary-ports.scm
+++ b/module/ice-9/binary-ports.scm
@@ -37,14 +37,14 @@
get-bytevector-n!
get-bytevector-some
get-bytevector-all
- get-string-n!
put-u8
put-bytevector
open-bytevector-output-port
make-custom-binary-output-port))
-;; Note that this extension also defines %make-transcoded-port, which is
-;; not exported but is used by (rnrs io ports).
+;; Note that this extension also defines `%make-transcoded-port' and
+;; `%get-string-n!', which are not exported but used by `(rnrs io
+;; ports)'.
(load-extension (string-append "libguile-" (effective-version))
"scm_init_r6rs_ports")
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index fddb491..fb8c795 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -445,6 +445,20 @@ return the characters accumulated in that port."
(define (get-string-all port)
(with-textual-input-conditions port (read-delimited "" port 'concat)))
+(define %get-string-n! (@@ (ice-9 binary-ports) %get-string-n!))
+
+(define (get-string-n! port str start count)
+ "Read up to @var{count} characters from @var{port} into @var{str},
+starting at @var{start}. If no characters can be read before the end of
+file is encountered, the end of file object is returned. Otherwise, the
+number of characters read is returned."
+ (with-i/o-port-error port make-i/o-read-error
+ (lambda ()
+ (let ((result (%get-string-n! port str start count)))
+ (if (pair? result)
+ (raise (make-i/o-decoding-error port))
+ result)))))
+
(define (get-string-n port count)
"Read up to @var{count} characters from @var{port}.
If no characters could be read before encountering the end of file,
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 46da67f..b1d0f25 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -633,6 +633,16 @@
(binary-port? (standard-error-port)))))
\f
+;; Create a textual input port in UTF-8 encoding reading from a byte
+;; vector containing an invalid UTF-8 sequence. Thus any read from that
+;; port should result in an &i/o-decoding-error condition being raised.
+(define (make-invalid-utf8-port)
+ (transcoded-port
+ (open-bytevector-input-port '#vu8(#xFE #xFF))
+ (make-transcoder (utf-8-codec)
+ (native-eol-style)
+ (error-handling-mode raise))))
+
(with-test-prefix "8.2.6 Input and output ports"
(pass-if "transcoded-port [output]"
@@ -724,19 +734,25 @@
(get-char (make-failing-port)))
(pass-if-condition "lookahead-char" i/o-read-error?
(lookahead-char (make-failing-port)))
- ;; FIXME: these are not yet exception-correct
- #|
(pass-if-condition "get-string-n" i/o-read-error?
(get-string-n (make-failing-port) 5))
(pass-if-condition "get-string-n!" i/o-read-error?
(get-string-n! (make-failing-port) (make-string 5) 0 5))
- |#
(pass-if-condition "get-string-all" i/o-read-error?
(get-string-all (make-failing-port 100)))
(pass-if-condition "get-line" i/o-read-error?
(get-line (make-failing-port)))
(pass-if-condition "get-datum" i/o-read-error?
- (get-datum (make-failing-port)))))
+ (get-datum (make-failing-port))))
+ (with-test-prefix "decoding error"
+ (pass-if-condition "get-char" i/o-decoding-error?
+ (get-char (make-invalid-utf8-port)))
+ (pass-if-condition "get-string-n" i/o-decoding-error?
+ (get-string-n (make-invalid-utf8-port) 2))
+ (pass-if-condition "get-string-n!" i/o-decoding-error?
+ (get-string-n! (make-invalid-utf8-port) (make-string 5) 0 5))
+ (pass-if-condition "get-line" i/o-decoding-error?
+ (get-line (make-invalid-utf8-port)))))
(define (encoding-error-predicate char)
(lambda (c)
--
1.7.10.4
next reply other threads:[~2012-11-07 23:51 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2012-11-07 23:51 Andreas Rottmann [this message]
2012-11-11 7:26 ` [PATCH] Fix `get-string-n!' &i/o-decoding exception behavior Mark H Weaver
2012-11-11 18:31 ` Andreas Rottmann
2012-11-11 21:20 ` Mark H Weaver
2012-11-11 23:45 ` Mark H Weaver
2012-11-12 19:52 ` Andreas Rottmann
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=1352332308-5191-1-git-send-email-a.rottmann@gmx.at \
--to=a.rottmann@gmx.at \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).