diff options
author | Andreas Rottmann <a.rottmann@gmx.at> | 2011-05-14 19:29:26 +0200 |
---|---|---|
committer | Andreas Rottmann <a.rottmann@gmx.at> | 2011-05-14 19:29:26 +0200 |
commit | b6a66c21fc3791bb5ea50f6e7a0ccc2e8f55e27a (patch) | |
tree | 6bdcb9bcd01bbc0fc2fbca5aaa2b0ef0bff79022 /module/rnrs | |
parent | 2002f1f84797c2c46d0634eabd5ac5fd61e13d73 (diff) | |
download | guile-b6a66c21fc3791bb5ea50f6e7a0ccc2e8f55e27a.tar.gz |
Improve R6RS conformance wrt. conditions in the I/O libraries
* module/rnrs/io/ports.scm (open-file-output-port): Handle `no-fail'
file option.
(with-i/o-filename-conditions): Use `with-throw-handler' instead of `catch'.
(with-i/o-port-error,
with-textual-output-conditions. with-textual-input-conditions): New
exception-conversion helpers.
(put-char, put-datum, put-string, display): Use
`with-textual-output-conditions' instead of `with-i/o-encoding-error'
to get proper conditions in case of write errors.
(get-char, get-datum, get-line, get-string-all, lookahead-char):
Likewise, for the input case.
* test-suite/tests/r6rs-ports.test (pass-if-condition, test-file,
make-failing-port): New helpers.
("8.2.10 Output ports"): Add some tests for `open-file-output-port'.
("8.2.9 Textual Input"): Add tests read error conditions.
("8.2.12 Textual Output"): Add tests for write error conditions.
("8.3 Simple I/O"): Add tests for conditions, `call-with-input-file'
and `call-with-output-file'.
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/io/ports.scm | 78 |
1 files changed, 51 insertions, 27 deletions
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 3dbaa039b..4ae01be68 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -170,22 +170,44 @@ ;;; (define (with-i/o-filename-conditions filename thunk) - (catch 'system-error - thunk - (lambda args - (let ((errno (system-error-errno args))) - (let ((construct-condition - (cond ((= errno EACCES) - make-i/o-file-protection-error) - ((= errno EEXIST) - make-i/o-file-already-exists-error) - ((= errno ENOENT) - make-i/o-file-does-not-exist-error) - ((= errno EROFS) - make-i/o-file-is-read-only-error) - (else - make-i/o-filename-error)))) - (raise (construct-condition filename))))))) + (with-throw-handler 'system-error + thunk + (lambda args + (let ((errno (system-error-errno args))) + (let ((construct-condition + (cond ((= errno EACCES) + make-i/o-file-protection-error) + ((= errno EEXIST) + make-i/o-file-already-exists-error) + ((= errno ENOENT) + make-i/o-file-does-not-exist-error) + ((= errno EROFS) + make-i/o-file-is-read-only-error) + (else + make-i/o-filename-error)))) + (raise (construct-condition filename))))))) + +(define (with-i/o-port-error port make-primary-condition thunk) + (with-throw-handler 'system-error + thunk + (lambda args + (let ((errno (system-error-errno args))) + (if (memv errno (list EIO EFBIG ENOSPC EPIPE)) + (raise (condition (make-primary-condition) + (make-i/o-port-error port))) + (apply throw args)))))) + +(define-syntax with-textual-output-conditions + (syntax-rules () + ((_ port body0 body ...) + (with-i/o-port-error port make-i/o-write-error + (lambda () (with-i/o-encoding-error body0 body ...)))))) + +(define-syntax with-textual-input-conditions + (syntax-rules () + ((_ port body0 body ...) + (with-i/o-port-error port make-i/o-read-error + (lambda () (with-i/o-decoding-error body0 body ...)))))) ;;; @@ -313,7 +335,10 @@ as a string, and a thunk to retrieve the characters associated with that port." O_CREAT) (if (enum-set-member? 'no-truncate file-options) 0 - O_TRUNC))) + O_TRUNC) + (if (enum-set-member? 'no-fail file-options) + 0 + O_EXCL))) (port (with-i/o-filename-conditions filename (lambda () (open filename flags))))) (cond (maybe-transcoder @@ -363,13 +388,13 @@ return the characters accumulated in that port." (raise (make-i/o-encoding-error port chr))))))) (define (put-char port char) - (with-i/o-encoding-error (write-char char port))) + (with-textual-output-conditions port (write-char char port))) (define (put-datum port datum) - (with-i/o-encoding-error (write datum port))) + (with-textual-output-conditions port (write datum port))) (define* (put-string port s #:optional start count) - (with-i/o-encoding-error + (with-textual-output-conditions port (cond ((not (string? s)) (assertion-violation 'put-string "expected string" s)) ((and start count) @@ -382,8 +407,7 @@ return the characters accumulated in that port." ;; Defined here to be able to make use of `with-i/o-encoding-error', but ;; not exported from here, but from `(rnrs io simple)'. (define* (display object #:optional (port (current-output-port))) - (with-i/o-encoding-error - (guile:display object port))) + (with-textual-output-conditions port (guile:display object port))) ;;; @@ -406,16 +430,16 @@ return the characters accumulated in that port." (raise (make-i/o-decoding-error port))))))) (define (get-char port) - (with-i/o-decoding-error (read-char port))) + (with-textual-input-conditions port (read-char port))) (define (get-datum port) - (with-i/o-decoding-error (read port))) + (with-textual-input-conditions port (read port))) (define (get-line port) - (with-i/o-decoding-error (read-line port 'trim))) + (with-textual-input-conditions port (read-line port 'trim))) (define (get-string-all port) - (with-i/o-decoding-error (read-delimited "" port 'concat))) + (with-textual-input-conditions port (read-delimited "" port 'concat))) (define (get-string-n port count) "Read up to @var{count} characters from @var{port}. @@ -429,7 +453,7 @@ the characters read." (else (substring/shared s 0 rv))))) (define (lookahead-char port) - (with-i/o-decoding-error (peek-char port))) + (with-textual-input-conditions port (peek-char port))) ;;; |