[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-83-g3ae5a02

[Andreas Rottmann]

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=3ae5a02f1d2b85bc54a4ff921da1a904a3915b9c

The branch, stable-2.0 has been updated
       via  3ae5a02f1d2b85bc54a4ff921da1a904a3915b9c (commit)
      from  5ec8fc21341329e92b9b74ca386a14f1b4672cca (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 3ae5a02f1d2b85bc54a4ff921da1a904a3915b9c
Author: Andreas Rottmann <address@hidden>
Date:   Mon Nov 12 20:47:57 2012 +0100

    Add missing R6RS `open-file-input/output-port' procedure
    
    * module/rnrs/io/port.scm (r6rs-open): New internal helper procedure for
      opening files.
      (open-file-input-port, open-file-output-port): Make use of
      `r6rs-open'.
      (open-file-input/output-port): Implement in terms of `r6rs-open',
      add to exported identifiers list.
    
    * module/rnrs.scm (open-file-input/output-port): Add to exported
      identifiers.
    
    * test-suite/tests/r6rs-ports.test (test-input-file-opener): New
      procedure, collects several tests for opening file input ports.
      ("7.2.7 Input Ports"): Use `test-input-file-opener' for checking
      `open-file-input-port'.
      (test-output-file-opener): New procedure, collects several tests for
      opening file output ports.
      ("8.2.10 Output ports"): Use `test-output-file-opener' for checking
      `open-file-output-port'.
      ("8.2.13 Input/output ports"): New test prefix, making use of both
      `test-input-file-opener' and `test-output-file-opener' to check
      `open-file-input/output-port'.

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

Summary of changes:
 module/rnrs.scm                  |    2 +-
 module/rnrs/io/ports.scm         |   70 +++++++++++++++++----------
 test-suite/tests/r6rs-ports.test |   98 +++++++++++++++++++++-----------------
 3 files changed, 100 insertions(+), 70 deletions(-)

diff --git a/module/rnrs.scm b/module/rnrs.scm
index 9fff820..a132c53 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -180,7 +180,7 @@
           call-with-bytevector-output-port
           call-with-string-output-port
           latin-1-codec utf-8-codec utf-16-codec
-          open-file-input-port open-file-output-port
+          open-file-input-port open-file-output-port 
open-file-input/output-port
           make-custom-textual-output-port
           call-with-string-output-port
          flush-output-port put-string
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index fddb491..7c17b0c 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -64,7 +64,10 @@
           call-with-string-output-port
           make-custom-textual-output-port
           flush-output-port
-           
+
+          ;; input/output ports
+          open-file-input/output-port
+
           ;; binary output
           put-u8 put-bytevector
 
@@ -305,19 +308,46 @@ read from/written to in @var{port}."
   (with-fluids ((%default-port-encoding "UTF-8"))
     (open-input-string str)))
 
-(define* (open-file-input-port filename
-                               #:optional
-                               (file-options (file-options))
-                               (buffer-mode (buffer-mode block))
-                               maybe-transcoder)
+(define (r6rs-open filename mode buffer-mode transcoder)
   (let ((port (with-i/o-filename-conditions filename
                 (lambda ()
                   (with-fluids ((%default-port-encoding #f))
-                    (open filename O_RDONLY))))))
-    (cond (maybe-transcoder
-           (set-port-encoding! port (transcoder-codec maybe-transcoder))))
+                    (open filename mode))))))
+    (cond (transcoder
+           (set-port-encoding! port (transcoder-codec transcoder))))
     port))
 
+(define (file-options->mode file-options base-mode)
+  (logior base-mode
+          (if (enum-set-member? 'no-create file-options)
+              0
+              O_CREAT)
+          (if (enum-set-member? 'no-truncate file-options)
+              0
+              O_TRUNC)
+          (if (enum-set-member? 'no-fail file-options)
+              0
+              O_EXCL)))
+
+(define* (open-file-input-port filename
+                               #:optional
+                               (file-options (file-options))
+                               (buffer-mode (buffer-mode block))
+                               transcoder)
+  "Return an input port for reading from @var{filename}."
+  (r6rs-open filename O_RDONLY buffer-mode transcoder))
+
+(define* (open-file-input/output-port filename
+                                      #:optional
+                                      (file-options (file-options))
+                                      (buffer-mode (buffer-mode block))
+                                      transcoder)
+  "Return a port for reading from and writing to @var{filename}."
+  (r6rs-open filename
+             (file-options->mode file-options O_RDWR)
+             buffer-mode
+             transcoder))
+
 (define (open-string-output-port)
   "Return two values: an output port that will collect characters written to it
 as a string, and a thunk to retrieve the characters associated with that port."
@@ -331,23 +361,11 @@ as a string, and a thunk to retrieve the characters 
associated with that port."
                                 (file-options (file-options))
                                 (buffer-mode (buffer-mode block))
                                 maybe-transcoder)
-  (let* ((flags (logior O_WRONLY
-                        (if (enum-set-member? 'no-create file-options)
-                            0
-                            O_CREAT)
-                        (if (enum-set-member? 'no-truncate file-options)
-                            0
-                            O_TRUNC)
-                        (if (enum-set-member? 'no-fail file-options)
-                            0
-                            O_EXCL)))
-         (port (with-i/o-filename-conditions filename
-                 (lambda ()
-                   (with-fluids ((%default-port-encoding #f))
-                     (open filename flags))))))
-    (cond (maybe-transcoder
-           (set-port-encoding! port (transcoder-codec maybe-transcoder))))
-    port))
+  "Return an output port for writing to @var{filename}."
+  (r6rs-open filename
+             (file-options->mode file-options O_WRONLY)
+             buffer-mode
+             maybe-transcoder))
 
 (define (call-with-string-output-port proc)
   "Call @var{proc}, passing it a string output port. When @var{proc} returns,
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 46da67f..ed49598 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -316,24 +316,27 @@
           (string? (strerror errno)))))))
 
 
-(with-test-prefix "7.2.7 Input Ports"
-
-  (let ((filename (test-file))
-        (contents (string->utf8 "GNU λ")))
-    
+(define (test-input-file-opener open filename)
+  (let ((contents (string->utf8 "GNU λ")))
     ;; Create file
     (call-with-output-file filename
       (lambda (port) (put-bytevector port contents)))
   
-    (pass-if "open-file-input-port [opens binary port]"
+    (pass-if "opens binary input port with correct contents"
       (with-fluids ((%default-port-encoding "UTF-8"))
-          (call-with-port (open-file-input-port filename)
-            (lambda (port)
-              (and (binary-port? port)
-                   (bytevector=? contents (get-bytevector-all port)))))))
-
-    (delete-file filename))
+        (call-with-port (open-file-input-port filename)
+          (lambda (port)
+            (and (binary-port? port)
+                 (input-port? port)
+                 (bytevector=? contents (get-bytevector-all port))))))))
   
+  (delete-file filename))
+
+(with-test-prefix "7.2.7 Input Ports"
+
+  (with-test-prefix "open-file-input-port"
+    (test-input-file-opener open-file-input-port (test-file)))
+
   ;; This section appears here so that it can use the binary input
   ;; primitives.
 
@@ -478,39 +481,42 @@
       (binary-port? (standard-input-port)))))
 
 
-(with-test-prefix "8.2.10 Output ports"
-
-  (let ((filename (test-file)))
-    (with-fluids ((%default-port-encoding "UTF-8"))
-      (pass-if "open-file-output-port [opens binary port]"
-        (call-with-port (open-file-output-port filename)
-          (lambda (port)
-            (put-bytevector port '#vu8(1 2 3))
-            (binary-port? port)))))
-    
-    (pass-if-condition "open-file-output-port [exception: already-exists]"
-        i/o-file-already-exists-error?
-      (open-file-output-port filename))
-    
-    (pass-if "open-file-output-port [no-fail no-truncate]"
-      (and
-        (call-with-port (open-file-output-port filename
-                                               (file-options no-fail 
no-truncate))
-          (lambda (port)
-            (= 0 (port-position port))))
-        (= 3 (stat:size (stat filename)))))
-
-    (pass-if "open-file-output-port [no-fail]"
-      (and
-        (call-with-port (open-file-output-port filename (file-options no-fail))
-          binary-port?)
-        (= 0 (stat:size (stat filename)))))
+(define (test-output-file-opener open filename)
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    (pass-if "opens binary output port"
+             (call-with-port (open filename)
+               (lambda (port)
+                 (put-bytevector port '#vu8(1 2 3))
+                 (and (binary-port? port)
+                      (output-port? port))))))
+
+  (pass-if-condition "exception: already-exists"
+                     i/o-file-already-exists-error?
+                     (open filename))
+
+  (pass-if "no-fail no-truncate"
+           (and
+             (call-with-port (open filename (file-options no-fail no-truncate))
+               (lambda (port)
+                 (= 0 (port-position port))))
+             (= 3 (stat:size (stat filename)))))
+
+  (pass-if "no-fail"
+           (and
+             (call-with-port (open filename (file-options no-fail))
+               binary-port?)
+             (= 0 (stat:size (stat filename)))))
     
-    (delete-file filename)
+  (delete-file filename)
     
-    (pass-if-condition "open-file-output-port [exception: does-not-exist]"
-        i/o-file-does-not-exist-error?
-      (open-file-output-port filename (file-options no-create))))
+  (pass-if-condition "exception: does-not-exist"
+                     i/o-file-does-not-exist-error?
+                     (open filename (file-options no-create))))
+
+(with-test-prefix "8.2.10 Output ports"
+
+  (with-test-prefix "open-file-output-port"
+    (test-output-file-opener open-file-output-port (test-file)))
   
   (pass-if "open-bytevector-output-port"
     (let-values (((port get-content)
@@ -801,6 +807,12 @@
         values))
     (delete-file filename)))
 
+(with-test-prefix "8.2.13 Input/output ports"
+  (with-test-prefix "open-file-input/output-port [output]"
+    (test-output-file-opener open-file-input/output-port (test-file)))
+  (with-test-prefix "open-file-input/output-port [input]"
+    (test-input-file-opener open-file-input/output-port (test-file))))
+
 ;;; Local Variables:
 ;;; mode: scheme
 ;;; eval: (put 'guard 'scheme-indent-function 1)


hooks/post-receive
-- 
GNU Guile