summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/rnrs.scm2
-rw-r--r--module/rnrs/io/ports.scm70
-rw-r--r--test-suite/tests/r6rs-ports.test98
3 files changed, 100 insertions, 70 deletions
diff --git a/module/rnrs.scm b/module/rnrs.scm
index 9fff820b3..a132c5364 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 fddb4914b..7c17b0ccc 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 46da67f59..ed4959826 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)