diff options
-rw-r--r-- | module/rnrs.scm | 2 | ||||
-rw-r--r-- | module/rnrs/io/ports.scm | 70 | ||||
-rw-r--r-- | 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 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) |