unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [PATCH] Several tweaks for R6RS ports
@ 2011-03-06 16:38 Andreas Rottmann
  2011-03-08  0:58 ` Andreas Rottmann
  0 siblings, 1 reply; 7+ messages in thread
From: Andreas Rottmann @ 2011-03-06 16:38 UTC (permalink / raw)
  To: Guile Development

[-- Attachment #1: Type: text/plain, Size: 673 bytes --]

Hi!

Here's a few patches related to R6RS port support, in short:

- Add missing `get-string-n!' and `get-string-n'
- Fix a few missing exports
- A bit of work on transcoder-related stuff

See the patch headers for details.  

The patches are attached in the order they should be applied, although
"get-string-n.diff" and the other two have been developed independently,
so applying them in this order will result in offsets and fuzzyness for
the later patches.  If there are issues with that, apply either
"get-string-n" or both of "rnrs-io-current-ports" and
"rnrs-transcoders", and come back to me, so I can regenerate the
remaining patches to make them apply cleanly.


[-- Attachment #2: get-string-n.diff --]
[-- Type: text/x-diff, Size: 7116 bytes --]

From: Andreas Rottmann <a.rottmann@gmx.at>
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
 
 \f
+/* 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
+
+\f
 /* 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: (d59dd06..) t/get-string-n (depends on: stable-2.0)

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: rnrs-io-current-ports.diff --]
[-- Type: text/x-diff, Size: 847 bytes --]

From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Export `current-*-port' from `(rnrs io ports)'

* module/rnrs/io/ports.scm: Export `current-input-port',
  `current-output-port' and `current-error-port' (see R6RS 8.2.7 "Input
  ports" and 8.2.10 "Output ports").

---
 module/rnrs/io/ports.scm |    1 +
 1 files changed, 1 insertions(+), 0 deletions(-)

diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index d3a81b7..b98811a 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -75,6 +75,7 @@
 
           ;; standard ports
           standard-input-port standard-output-port standard-error-port
+          current-input-port current-output-port current-error-port
 
           ;; condition types
           &i/o i/o-error? make-i/o-error
-- 
tg: (d59dd06..) t/rnrs-io-current-ports (depends on: stable-2.0)

[-- Attachment #4: rnrs-transcoders.diff --]
[-- Type: text/x-diff, Size: 6735 bytes --]

From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Enhance transcoder-related functionality of `(rnrs io ports)'

* module/rnrs/io/ports.scm (transcoder-eol-style)
  (transcoder-error-handling-mode): Export these.
* module/rnrs.scm: Ditto here.

* module/rnrs/io/ports.scm (port-transcoder): Implement this procedure.
  (binary-port?): Treat only ports without an encoding as binary ports, 
  add docstring.
  (textual-port?): Implement this procedure.
  (standard-input-port, standard-output-port, standard-error-port): Ensure these 
  are created without an encoding.
  (eol-style): Add `none' as enumeration member.
  (native-eol-style): Switch to `none' from `lf'.
* test-suite/tests/r6rs-ports.test (7.2.7 Input ports)
  (8.2.10 Output ports): Test binary-ness of `standard-input-port',
  `standard-output-port' and `standard-error-port'.
  (8.2.6 Input and output ports): Add test for `port-transcoder'.

---
 module/rnrs.scm                  |    3 +-
 module/rnrs/io/ports.scm         |   42 +++++++++++++++++++++++++++++--------
 test-suite/tests/r6rs-ports.test |   32 ++++++++++++++++++++++++++--
 3 files changed, 64 insertions(+), 13 deletions(-)

diff --git a/module/rnrs.scm b/module/rnrs.scm
index 476a3ab..58d9638 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -162,7 +162,8 @@
 
 	  file-options buffer-mode buffer-mode?
 	  eol-style native-eol-style error-handling-mode
-	  make-transcoder transcoder-codec native-transcoder
+	  make-transcoder transcoder-codec transcoder-eol-style
+          transcoder-error-handling-mode native-transcoder
 	  latin-1-codec utf-8-codec utf-16-codec
 	  
 	  eof-object? port? input-port? output-port? eof-object port-eof?
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index b98811a..097c9d3 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -32,13 +32,14 @@
           ;; auxiliary types
           file-options buffer-mode buffer-mode?
           eol-style native-eol-style error-handling-mode
-          make-transcoder transcoder-codec native-transcoder
+          make-transcoder transcoder-codec transcoder-eol-style
+          transcoder-error-handling-mode native-transcoder
           latin-1-codec utf-8-codec utf-16-codec
            
           ;; input & output ports
           port? input-port? output-port?
           port-eof?
-          port-transcoder binary-port? transcoded-port
+          port-transcoder binary-port? textual-port? transcoded-port
           port-position set-port-position!
           port-has-port-position? port-has-set-port-position!?
           call-with-port close-port
@@ -128,11 +129,11 @@
   (enum-set-member? symbol (enum-set-universe (buffer-modes))))
 
 (define-enumeration eol-style
-  (lf cr crlf nel crnel ls)
+  (lf cr crlf nel crnel ls none)
   eol-styles)
 
 (define (native-eol-style)
-  (eol-style lf))
+  (eol-style none))
 
 (define-enumeration error-handling-mode
   (ignore raise replace)
@@ -189,10 +190,30 @@
 ;;;
 
 (define (port-transcoder port)
-  (error "port transcoders are not supported" port))
+  "Return the transcoder object associated with @var{port}, or @code{#f}
+if the port has no transcoder."
+  (cond ((port-encoding port)
+         => (lambda (encoding)
+              (make-transcoder
+               encoding
+               (native-eol-style)
+               (case (port-conversion-strategy port)
+                 ((error) 'raise)
+                 ((substitute) 'replace)
+                 (else
+                  (assertion-violation 'port-transcoder
+                                       "unsupported error handling mode"))))))
+        (else
+         #f)))
 
 (define (binary-port? port)
-  ;; So far, we don't support transcoders other than the binary transcoder.
+  "Returns @code{#t} if @var{port} does not have an associated encoding,
+@code{#f} otherwise."
+  (not (port-encoding port)))
+
+(define (textual-port? port)
+  "Always returns @var{#t}, as all ports can be used for textual I/O in
+Guile."
   #t)
 
 (define (port-eof? port)
@@ -396,13 +417,16 @@ return the characters accumulated in that port."
 ;;;
 
 (define (standard-input-port)
-  (dup->inport 0))
+  (with-fluids ((%default-port-encoding #f))
+    (dup->inport 0)))
 
 (define (standard-output-port)
-  (dup->outport 1))
+  (with-fluids ((%default-port-encoding #f))
+    (dup->outport 1)))
 
 (define (standard-error-port)
-  (dup->outport 2))
+  (with-fluids ((%default-port-encoding #f))
+    (dup->outport 2)))
 
 )
 
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index df056a4..d0f5666 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -397,7 +397,11 @@
 
       (close-port port)
       (gc) ; Test for marking a closed port.
-      closed?)))
+      closed?))
+
+  (pass-if "standard-input-port is binary"
+    (with-fluids ((%default-port-encoding "UTF-8"))
+      (binary-port? (standard-input-port)))))
 
 \f
 (with-test-prefix "8.2.10 Output ports"
@@ -509,7 +513,15 @@
       (put-bytevector port source)
       (and (= sink-pos (bytevector-length source))
            (not eof?)
-           (bytevector=? sink source)))))
+           (bytevector=? sink source))))
+
+  (pass-if "standard-output-port is binary"
+    (with-fluids ((%default-port-encoding "UTF-8"))
+      (binary-port? (standard-output-port))))
+
+  (pass-if "standard-error-port is binary"
+    (with-fluids ((%default-port-encoding "UTF-8"))
+      (binary-port? (standard-error-port)))))
 
 \f
 (with-test-prefix "8.2.6  Input and output ports"
@@ -565,7 +577,21 @@
                         (char=? (i/o-encoding-error-char c) #\λ)
                         (bytevector=? (get) (string->utf8 "The letter ")))))
           (put-string tp "The letter λ cannot be represented in Latin-1.")
-          #f)))))
+          #f))))
+
+  (pass-if "port-transcoder [binary port]"
+    (not (port-transcoder (open-bytevector-input-port #vu8()))))
+
+  (pass-if "port-transcoder [transcoded port]"
+    (let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
+                               (make-transcoder (utf-8-codec))))
+           (t (port-transcoder p)))
+      (and t
+           (transcoder-codec t)
+           (eq? (native-eol-style)
+                (transcoder-eol-style t))
+           (eq? (error-handling-mode replace)
+                (transcoder-error-handling-mode t))))))
 
 ;;; Local Variables:
 ;;; mode: scheme
-- 
tg: (9421ef5..) t/rnrs-transcoders (depends on: t/rnrs-io-current-ports)

[-- Attachment #5: Type: text/plain, Size: 63 bytes --]


Regards, Rotty
-- 
Andreas Rottmann -- <http://rotty.yi.org/>

^ permalink raw reply related	[flat|nested] 7+ messages in thread
end of thread, other threads:[~2011-04-20 12:55 UTC | newest]

Thread overview: 7+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-03-06 16:38 [PATCH] Several tweaks for R6RS ports Andreas Rottmann
2011-03-08  0:58 ` Andreas Rottmann
2011-03-13 22:21   ` Ludovic Courtès
2011-03-24  0:47     ` Andreas Rottmann
2011-03-24 20:55       ` Ludovic Courtès
2011-04-15  9:37       ` Andy Wingo
2011-04-20 12:55         ` Andreas Rottmann

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).