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.

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))
+  (with-i/o-encoding-error
-         (assertion-violation 'put-string "expected string" s))
+   (cond ((not (string? s))
-        ((and start count)
+          (assertion-violation 'put-string "expected string" s))
-         (display (substring/shared s start (+ start count)) port))
+         ((and start count)
-        (start
+          (display (substring/shared s start (+ start count)) port))
-         (display (substring/shared s start (string-length s)) port))
+         (start
-        (else
+          (display (substring/shared s start (string-length s)) port))
-         (display s port))))
+         (else
+          (display s port)))))
 
 
 ;;;

test-suite/tests/r6rs-ports.test

@@ -552,7 +552,20 @@
                                 (error-handling-mode replace)))
            (b  (open-bytevector-input-port #vu8(255 1 2 3 103 110 117)))
            (tp (transcoded-port b t)))
-      (string-suffix? "gnu" (get-line tp)))))
+      (string-suffix? "gnu" (get-line tp))))
+
+  (pass-if "transcoded-port, output [error handling mode = raise]"
+    (let-values (((p get)
+                  (open-bytevector-output-port)))
+      (let* ((t  (make-transcoder (latin-1-codec) (native-eol-style)
+                                  (error-handling-mode raise)))
+             (tp (transcoded-port p t)))
+        (guard (c ((i/o-encoding-error? c)
+                   (and (eq? (i/o-error-port c) tp)
+                        (char=? (i/o-encoding-error-char c) #\λ)
+                        (bytevector=? (get) (string->utf8 "The letter ")))))
+          (put-string tp "The letter λ cannot be represented in Latin-1.")
+          #f)))))
 
 ;;; Local Variables:
 ;;; mode: scheme