diff options
author | Ludovic Courtès <ludo@gnu.org> | 2011-02-02 18:00:49 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2011-02-02 18:06:29 +0100 |
commit | eed98cbc9274bdcd8aba7261325f658e00fa3663 (patch) | |
tree | 5475da43ecb8fcf985edcad411c7591d370d11c1 /module/rnrs | |
parent | 6851d3be80bef46993e192b0f4ea708248f97921 (diff) | |
download | guile-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.scm | 45 |
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))))) ;;; |