diff options
author | Andreas Rottmann <a.rottmann@gmx.at> | 2011-03-13 22:39:14 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2011-03-13 22:39:14 +0100 |
commit | a6c377f7d8a311b0ce4f9c5900b1c81c27b2d60c (patch) | |
tree | 7a4bc6be9ea639d40c53385b1e2858ed717a8099 | |
parent | ca33b501a93f8de389c1e3e1bc987f63b6912029 (diff) | |
download | guile-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.c | 42 | ||||
-rw-r--r-- | libguile/r6rs-ports.h | 3 | ||||
-rw-r--r-- | module/ice-9/binary-ports.scm | 1 | ||||
-rw-r--r-- | module/rnrs.scm | 3 | ||||
-rw-r--r-- | module/rnrs/io/ports.scm | 16 | ||||
-rw-r--r-- | test-suite/tests/r6rs-ports.test | 18 |
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) |