[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-101-gead04a0

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ead04a04cd38909d0d40f1ba7885372c9c65ff38

The branch, stable-2.0 has been updated
       via  ead04a04cd38909d0d40f1ba7885372c9c65ff38 (commit)
       via  74571cfd3b27b79567f27fc43815d08ec1f402cc (commit)
       via  a6c377f7d8a311b0ce4f9c5900b1c81c27b2d60c (commit)
      from  ca33b501a93f8de389c1e3e1bc987f63b6912029 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit ead04a04cd38909d0d40f1ba7885372c9c65ff38
Author: Andreas Rottmann <address@hidden>
Date:   Sun Mar 13 23:14:10 2011 +0100

    Enhance transcoder-related functionality of `(rnrs io ports)'
    
    * module/rnrs/io/ports.scm (transcoder-eol-style)
      (transcoder-error-handling-mode): Export these.
      (textual-port?): Implement this procedure and export it.
    * module/rnrs.scm: Export these here as well.
    
    * module/rnrs/io/ports.scm (port-transcoder): Implement this procedure.
      (binary-port?): Treat only ports without an encoding as binary ports,
      add docstring.
      (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'.
    
    Signed-off-by: Ludovic Courtès <address@hidden>

commit 74571cfd3b27b79567f27fc43815d08ec1f402cc
Author: Andreas Rottmann <address@hidden>
Date:   Sun Mar 13 22:39:26 2011 +0100

    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").
    
    Signed-off-by: Ludovic Courtès <address@hidden>

commit a6c377f7d8a311b0ce4f9c5900b1c81c27b2d60c
Author: Andreas Rottmann <address@hidden>
Date:   Sun Mar 13 22:39:14 2011 +0100

    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 <address@hidden>

-----------------------------------------------------------------------

Summary of changes:
 libguile/r6rs-ports.c            |   42 ++++++++++++++++++++++++++-
 libguile/r6rs-ports.h            |    3 +-
 module/ice-9/binary-ports.scm    |    1 +
 module/rnrs.scm                  |    9 ++++--
 module/rnrs/io/ports.scm         |   59 ++++++++++++++++++++++++++++++-------
 test-suite/tests/r6rs-ports.test |   50 ++++++++++++++++++++++++++++++--
 6 files changed, 145 insertions(+), 19 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..9fff820 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -162,12 +162,14 @@
 
          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?
          port-transcoder
-         binary-port? transcoded-port port-position set-port-position!
+         binary-port? textual-port? transcoded-port
+         port-position set-port-position!
          port-has-port-position? port-has-set-port-position!?
           close-port call-with-port
          open-bytevector-input-port make-custom-binary-input-port get-u8 
@@ -182,7 +184,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..04d167a 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
@@ -68,13 +69,15 @@
           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
 
           ;; 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
@@ -127,11 +130,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)
@@ -188,10 +191,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,
address@hidden 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)
@@ -386,6 +409,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)))
 
@@ -395,13 +429,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..70b5853 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)))))
 
 
 (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)))))
 
 
 (with-test-prefix "8.2.6  Input and output ports"
@@ -565,7 +577,39 @@
                         (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))))))
+
+(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


hooks/post-receive
-- 
GNU Guile