mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 20:30:28 +02:00
R6RS: Have get-char',
get-line', etc. raise an `&i/o-decoding-error'.
* module/rnrs/io/ports.scm (&i/o-decoding): New error condition type. (with-i/o-decoding-error): New macro. (get-char, get-datum, get-line, get-string-all, lookahead-char): Use it. * test-suite/tests/r6rs-ports.test ("8.2.6 Input and output ports")["transcoded-port [error handling mode = raise]"]: Use `guard' and `i/o-decoding-error?'.
This commit is contained in:
parent
b8fff11ed9
commit
b1e76e8f2c
2 changed files with 37 additions and 14 deletions
|
@ -93,7 +93,9 @@
|
||||||
&i/o-file-does-not-exist i/o-file-does-not-exist-error?
|
&i/o-file-does-not-exist i/o-file-does-not-exist-error?
|
||||||
make-i/o-file-does-not-exist-error
|
make-i/o-file-does-not-exist-error
|
||||||
&i/o-port i/o-port-error? make-i/o-port-error
|
&i/o-port i/o-port-error? make-i/o-port-error
|
||||||
i/o-error-port)
|
i/o-error-port
|
||||||
|
&i/o-decoding-error i/o-decoding-error?
|
||||||
|
make-i/o-decoding-error)
|
||||||
(import (only (rnrs base) assertion-violation)
|
(import (only (rnrs base) assertion-violation)
|
||||||
(rnrs enums)
|
(rnrs enums)
|
||||||
(rnrs records syntactic)
|
(rnrs records syntactic)
|
||||||
|
@ -330,23 +332,46 @@ return the characters accumulated in that port."
|
||||||
(else
|
(else
|
||||||
(display s port))))
|
(display s port))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Textual input.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-condition-type &i/o-decoding &i/o-port
|
||||||
|
make-i/o-decoding-error i/o-decoding-error?)
|
||||||
|
|
||||||
|
(define-syntax with-i/o-decoding-error
|
||||||
|
(syntax-rules ()
|
||||||
|
"Convert Guile throws to `decoding-error' to `&i/o-decoding-error'."
|
||||||
|
((_ body ...)
|
||||||
|
;; XXX: This is heavyweight for small functions like `get-char' and
|
||||||
|
;; `lookahead-char'.
|
||||||
|
(with-throw-handler 'decoding-error
|
||||||
|
(lambda ()
|
||||||
|
(begin body ...))
|
||||||
|
(lambda (key subr message errno port)
|
||||||
|
(raise (make-i/o-decoding-error port)))))))
|
||||||
|
|
||||||
(define (get-char port)
|
(define (get-char port)
|
||||||
(read-char port))
|
(with-i/o-decoding-error (read-char port)))
|
||||||
|
|
||||||
(define (get-datum port)
|
(define (get-datum port)
|
||||||
(read port))
|
(with-i/o-decoding-error (read port)))
|
||||||
|
|
||||||
(define (get-line port)
|
(define (get-line port)
|
||||||
(read-line port 'trim))
|
(with-i/o-decoding-error (read-line port 'trim)))
|
||||||
|
|
||||||
(define (get-string-all port)
|
(define (get-string-all port)
|
||||||
(read-delimited "" port 'concat))
|
(with-i/o-decoding-error (read-delimited "" port 'concat)))
|
||||||
|
|
||||||
(define (lookahead-char port)
|
(define (lookahead-char port)
|
||||||
(peek-char port))
|
(with-i/o-decoding-error (peek-char port)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Standard ports.
|
||||||
|
;;;
|
||||||
|
|
||||||
(define (standard-input-port)
|
(define (standard-input-port)
|
||||||
(dup->inport 0))
|
(dup->inport 0))
|
||||||
|
|
||||||
|
|
|
@ -22,6 +22,7 @@
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (rnrs io ports)
|
#:use-module (rnrs io ports)
|
||||||
|
#:use-module (rnrs exceptions)
|
||||||
#:use-module (rnrs bytevectors))
|
#:use-module (rnrs bytevectors))
|
||||||
|
|
||||||
;;; All these tests assume Guile 1.8's port system, where characters are
|
;;; All these tests assume Guile 1.8's port system, where characters are
|
||||||
|
@ -542,13 +543,9 @@
|
||||||
(error-handling-mode raise)))
|
(error-handling-mode raise)))
|
||||||
(b (open-bytevector-input-port #vu8(255 2 1)))
|
(b (open-bytevector-input-port #vu8(255 2 1)))
|
||||||
(tp (transcoded-port b t)))
|
(tp (transcoded-port b t)))
|
||||||
;; FIXME: Should be (guard (c ((i/o-decoding-error? c) #t)) ...).
|
(guard (c ((i/o-decoding-error? c)
|
||||||
(catch 'decoding-error
|
(eq? (i/o-error-port c) tp)))
|
||||||
(lambda ()
|
(get-line tp))))
|
||||||
(get-line tp)
|
|
||||||
#f)
|
|
||||||
(lambda _
|
|
||||||
#t))))
|
|
||||||
|
|
||||||
(pass-if "transcoded-port [error handling mode = replace]"
|
(pass-if "transcoded-port [error handling mode = replace]"
|
||||||
(let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
|
(let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
|
||||||
|
@ -559,4 +556,5 @@
|
||||||
|
|
||||||
;;; Local Variables:
|
;;; Local Variables:
|
||||||
;;; mode: scheme
|
;;; mode: scheme
|
||||||
|
;;; eval: (put 'guard 'scheme-indent-function 1)
|
||||||
;;; End:
|
;;; End:
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue