[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Add `get-string-n' and `get-string-n!' for R6RS ports
From: |
Andreas Rottmann |
Subject: |
[PATCH] Add `get-string-n' and `get-string-n!' for R6RS ports |
Date: |
Thu, 03 Mar 2011 00:39:52 +0100 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.0.50 (gnu/linux) |
These are missing currently; the attached patch adds them.
From: Andreas Rottmann <address@hidden>
Subject: 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!'.
---
libguile/r6rs-ports.c | 42 +++++++++++++++++++++++++++++++++++++-
libguile/r6rs-ports.h | 3 +-
module/ice-9/binary-ports.scm | 1 +
module/rnrs.scm | 3 +-
module/rnrs/io/ports.scm | 16 ++++++++++++-
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 8058ca0..1f72415 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 edde005..2ae3e76 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 63d09cf..c07900b 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 476a3ab..77090d0 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 d3a81b7..d3b16ac 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 df056a4..fe2197f 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)
--
tg: (fba502d..) t/get-string-n (depends on: stable-2.0)
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [PATCH] Add `get-string-n' and `get-string-n!' for R6RS ports,
Andreas Rottmann <=