guile-devel
[Top][All Lists]
Advanced

[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/>

reply via email to

[Prev in Thread] Current Thread [Next in Thread]