summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Rottmann <a.rottmann@gmx.at>2011-03-13 22:39:14 +0100
committerLudovic Courtès <ludo@gnu.org>2011-03-13 22:39:14 +0100
commita6c377f7d8a311b0ce4f9c5900b1c81c27b2d60c (patch)
tree7a4bc6be9ea639d40c53385b1e2858ed717a8099
parentca33b501a93f8de389c1e3e1bc987f63b6912029 (diff)
downloadguile-a6c377f7d8a311b0ce4f9c5900b1c81c27b2d60c.tar.gz
Add `get-string-n' and `get-string-n!' for R6RS ports
* libguile/r6rs-ports.c (scm_get_string_n_x): Implement `get-string-n!' in C for efficiency. * libguile/r6rs-ports.h: Add prototype for this function. * module/ice-9/binary-ports.scm: Export `get-string-n!'. * module/rnrs/io/ports.scm (get-string-n): Implement based on `get-string-n!'. Export both `get-string-n!' and `get-string-n'. * module/rnrs.scm: Also export these. * test-suite/tests/r6rs-ports.test (8.2.9 Textual input): Add a few tests for `get-string-n' and `get-string-n!'. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
-rw-r--r--libguile/r6rs-ports.c42
-rw-r--r--libguile/r6rs-ports.h3
-rw-r--r--module/ice-9/binary-ports.scm1
-rw-r--r--module/rnrs.scm3
-rw-r--r--module/rnrs/io/ports.scm16
-rw-r--r--test-suite/tests/r6rs-ports.test18
6 files changed, 78 insertions, 5 deletions
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 8058ca074..1f724158a 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011 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 License
@@ -1222,6 +1222,46 @@ SCM_DEFINE (scm_i_make_transcoded_port,
#undef FUNC_NAME
+/* Textual I/O */
+
+SCM_DEFINE (scm_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
+{
+ size_t c_start, c_count, c_len, c_end, j;
+ scm_t_wchar c;
+
+ SCM_VALIDATE_OPINPORT (1, port);
+ SCM_VALIDATE_STRING (2, str);
+ c_len = scm_c_string_length (str);
+ c_start = scm_to_size_t (start);
+ c_count = scm_to_size_t (count);
+ c_end = c_start + c_count;
+
+ if (SCM_UNLIKELY (c_end > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+
+ for (j = c_start; j < c_end; j++)
+ {
+ c = scm_getc (port);
+ if (c == EOF)
+ {
+ size_t chars_read = j - c_start;
+ return chars_read == 0 ? SCM_EOF_VAL : scm_from_size_t (chars_read);
+ }
+ scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c));
+ }
+ return count;
+}
+#undef FUNC_NAME
+
+
/* Initialization. */
void
diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h
index edde00520..2ae3e765b 100644
--- a/libguile/r6rs-ports.h
+++ b/libguile/r6rs-ports.h
@@ -1,7 +1,7 @@
#ifndef SCM_R6RS_PORTS_H
#define SCM_R6RS_PORTS_H
-/* Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011 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 License
@@ -38,6 +38,7 @@ SCM_API SCM scm_put_u8 (SCM, SCM);
SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
SCM_API SCM scm_open_bytevector_output_port (SCM);
SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM);
SCM_API void scm_init_r6rs_ports (void);
SCM_INTERNAL void scm_register_r6rs_ports (void);
diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm
index 63d09cf21..c07900b0d 100644
--- a/module/ice-9/binary-ports.scm
+++ b/module/ice-9/binary-ports.scm
@@ -37,6 +37,7 @@
get-bytevector-n!
get-bytevector-some
get-bytevector-all
+ get-string-n!
put-u8
put-bytevector
open-bytevector-output-port
diff --git a/module/rnrs.scm b/module/rnrs.scm
index 476a3ab2d..77090d0e1 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -182,7 +182,8 @@
make-custom-textual-output-port
call-with-string-output-port
flush-output-port put-string
- get-char get-datum get-line get-string-all lookahead-char
+ get-char get-datum get-line get-string-all get-string-n get-string-n!
+ lookahead-char
put-char put-datum put-string
standard-input-port standard-output-port standard-error-port
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index d3a81b7c7..d3b16ac63 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -68,8 +68,9 @@
put-u8 put-bytevector
;; textual input
- get-char get-datum get-line get-string-all lookahead-char
-
+ get-char get-datum get-line get-string-all get-string-n get-string-n!
+ lookahead-char
+
;; textual output
put-char put-datum put-string
@@ -386,6 +387,17 @@ return the characters accumulated in that port."
(define (get-string-all port)
(with-i/o-decoding-error (read-delimited "" port 'concat)))
+(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,
+return the end-of-file object, otherwise return a string containing
+the characters read."
+ (let* ((s (make-string count))
+ (rv (get-string-n! port s 0 count)))
+ (cond ((eof-object? rv) rv)
+ ((= rv count) s)
+ (else (substring/shared s 0 rv)))))
+
(define (lookahead-char port)
(with-i/o-decoding-error (peek-char port)))
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index df056a416..fe2197fe4 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -567,6 +567,24 @@
(put-string tp "The letter λ cannot be represented in Latin-1.")
#f)))))
+(with-test-prefix "8.2.9 Textual input"
+
+ (pass-if "get-string-n [short]"
+ (let ((port (open-input-string "GNU Guile")))
+ (string=? "GNU " (get-string-n port 4))))
+ (pass-if "get-string-n [long]"
+ (let ((port (open-input-string "GNU Guile")))
+ (string=? "GNU Guile" (get-string-n port 256))))
+ (pass-if "get-string-n [eof]"
+ (let ((port (open-input-string "")))
+ (eof-object? (get-string-n port 4))))
+
+ (pass-if "get-string-n! [short]"
+ (let ((port (open-input-string "GNU Guile"))
+ (s (string-copy "Isn't XXX great?")))
+ (and (= 3 (get-string-n! port s 6 3))
+ (string=? s "Isn't GNU great?")))))
+
;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'guard 'scheme-indent-function 1)