summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2011-02-02 18:00:49 +0100
committerLudovic Courtès <ludo@gnu.org>2011-02-02 18:06:29 +0100
commiteed98cbc9274bdcd8aba7261325f658e00fa3663 (patch)
tree5475da43ecb8fcf985edcad411c7591d370d11c1 /module/rnrs
parent6851d3be80bef46993e192b0f4ea708248f97921 (diff)
downloadguile-eed98cbc9274bdcd8aba7261325f658e00fa3663.tar.gz
R6RS: Have `put-char', `put-string', etc. raise an `&i/o-encoding-error'.
* module/rnrs/io/ports.scm (&i/o-encoding): New error condition type. (with-i/o-encoding-error): New macro. (put-char, put-datum, put-string): Use it. * test-suite/tests/r6rs-ports.test ("8.2.6 Input and output ports")["transcoded-port, output [error handling mode = raise]"]: New test.
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/io/ports.scm45
1 files changed, 34 insertions, 11 deletions
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 0eac165cf..a5815c85f 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -95,7 +95,9 @@
&i/o-port i/o-port-error? make-i/o-port-error
i/o-error-port
&i/o-decoding-error i/o-decoding-error?
- make-i/o-decoding-error)
+ make-i/o-decoding-error
+ &i/o-encoding-error i/o-encoding-error?
+ make-i/o-encoding-error i/o-encoding-error-char)
(import (only (rnrs base) assertion-violation)
(rnrs enums)
(rnrs records syntactic)
@@ -316,21 +318,42 @@ return the characters accumulated in that port."
(define (flush-output-port port)
(force-output port))
+
+;;;
+;;; Textual output.
+;;;
+
+(define-condition-type &i/o-encoding &i/o-port
+ make-i/o-encoding-error i/o-encoding-error?
+ (char i/o-encoding-error-char))
+
+(define-syntax with-i/o-encoding-error
+ (syntax-rules ()
+ "Convert Guile throws to `encoding-error' to `&i/o-encoding-error'."
+ ((_ body ...)
+ ;; XXX: This is heavyweight for small functions like `put-char'.
+ (with-throw-handler 'encoding-error
+ (lambda ()
+ (begin body ...))
+ (lambda (key subr message errno port chr)
+ (raise (make-i/o-encoding-error port chr)))))))
+
(define (put-char port char)
- (write-char char port))
+ (with-i/o-encoding-error (write-char char port)))
(define (put-datum port datum)
- (write datum port))
+ (with-i/o-encoding-error (write datum port)))
(define* (put-string port s #:optional start count)
- (cond ((not (string? s))
- (assertion-violation 'put-string "expected string" s))
- ((and start count)
- (display (substring/shared s start (+ start count)) port))
- (start
- (display (substring/shared s start (string-length s)) port))
- (else
- (display s port))))
+ (with-i/o-encoding-error
+ (cond ((not (string? s))
+ (assertion-violation 'put-string "expected string" s))
+ ((and start count)
+ (display (substring/shared s start (+ start count)) port))
+ (start
+ (display (substring/shared s start (string-length s)) port))
+ (else
+ (display s port)))))
;;;