[Guile-commits] GNU Guile branch, master, updated. v2.1.0-465-g110ef00

[Mark H Weaver]

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=110ef00ba1dfae4461afdd189fed4dfec05ee137

The branch, master has been updated
       via  110ef00ba1dfae4461afdd189fed4dfec05ee137 (commit)
       via  3ae5a02f1d2b85bc54a4ff921da1a904a3915b9c (commit)
      from  eb55a0db5a1b6334e92c283851b8190777285a0b (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 110ef00ba1dfae4461afdd189fed4dfec05ee137
Merge: eb55a0d 3ae5a02
Author: Mark H Weaver <address@hidden>
Date:   Thu Nov 15 05:31:18 2012 -0500

    Merge remote-tracking branch 'origin/stable-2.0'

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

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