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

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

module/rnrs/io/ports.scm

@@ -65,6 +65,9 @@
           make-custom-textual-output-port
           flush-output-port
 
+          ;; input/output ports
+          open-file-input/output-port
+
           ;; binary output
           put-u8 put-bytevector
 
@@ -305,18 +308,45 @@ read from/written to in @var{port}."
   (with-fluids ((%default-port-encoding "UTF-8"))
     (open-input-string str)))
 
+(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 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))
-                               maybe-transcoder)
+                               transcoder)
-  (let ((port (with-i/o-filename-conditions filename
+  "Return an input port for reading from @var{filename}."
-                (lambda ()
+  (r6rs-open filename O_RDONLY buffer-mode transcoder))
-                  (with-fluids ((%default-port-encoding #f))
+
-                    (open filename O_RDONLY))))))
+(define* (open-file-input/output-port filename
-    (cond (maybe-transcoder
+                                      #:optional
-           (set-port-encoding! port (transcoder-codec maybe-transcoder))))
+                                      (file-options (file-options))
-    port))
+                                      (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
@@ -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
+  "Return an output port for writing to @var{filename}."
-                        (if (enum-set-member? 'no-create file-options)
+  (r6rs-open filename
-                            0
+             (file-options->mode file-options O_WRONLY)
-                            O_CREAT)
+             buffer-mode
-                        (if (enum-set-member? 'no-truncate file-options)
+             maybe-transcoder))
-                            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))
 
 (define (call-with-string-output-port proc)
   "Call @var{proc}, passing it a string output port. When @var{proc} returns,

test-suite/tests/r6rs-ports.test

@@ -316,24 +316,27 @@
           (string? (strerror errno)))))))
 
 
-(with-test-prefix "7.2.7 Input Ports"
+(define (test-input-file-opener open filename)
-
+  (let ((contents (string->utf8 "GNU λ")))
-  (let ((filename (test-file))
-        (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)))))))
+                 (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"
+(define (test-output-file-opener open filename)
-
-  (let ((filename (test-file)))
   (with-fluids ((%default-port-encoding "UTF-8"))
-      (pass-if "open-file-output-port [opens binary port]"
+    (pass-if "opens binary output port"
-        (call-with-port (open-file-output-port filename)
+             (call-with-port (open filename)
                (lambda (port)
                  (put-bytevector port '#vu8(1 2 3))
-            (binary-port? port)))))
+                 (and (binary-port? port)
+                      (output-port? port))))))
 
-    (pass-if-condition "open-file-output-port [exception: already-exists]"
+  (pass-if-condition "exception: already-exists"
                      i/o-file-already-exists-error?
-      (open-file-output-port filename))
+                     (open filename))
 
-    (pass-if "open-file-output-port [no-fail no-truncate]"
+  (pass-if "no-fail no-truncate"
            (and
-        (call-with-port (open-file-output-port filename
+             (call-with-port (open filename (file-options no-fail no-truncate))
-                                               (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]"
+  (pass-if "no-fail"
            (and
-        (call-with-port (open-file-output-port filename (file-options no-fail))
+             (call-with-port (open filename (file-options no-fail))
                binary-port?)
              (= 0 (stat:size (stat filename)))))
     
   (delete-file filename)
     
-    (pass-if-condition "open-file-output-port [exception: does-not-exist]"
+  (pass-if-condition "exception: does-not-exist"
                      i/o-file-does-not-exist-error?
-      (open-file-output-port filename (file-options no-create))))
+                     (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)