summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorAndreas Rottmann <a.rottmann@gmx.at>2011-05-14 19:29:26 +0200
committerAndreas Rottmann <a.rottmann@gmx.at>2011-05-14 19:29:26 +0200
commitb6a66c21fc3791bb5ea50f6e7a0ccc2e8f55e27a (patch)
tree6bdcb9bcd01bbc0fc2fbca5aaa2b0ef0bff79022 /module/rnrs
parent2002f1f84797c2c46d0634eabd5ac5fd61e13d73 (diff)
downloadguile-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.scm78
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)))
;;;