From eade50bb1a913914c290259cbd01b9f79c03b7b4 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Fri, 2 Jul 2010 23:06:26 +0000 Subject: [PATCH] code/extfmts.lisp: o Pass the error handler on for composed external formats. code/fd-stream.lisp: o Forgot to pass the error-handler to char-to-octets in EF-COUT. o In MAKE-FD-STREAM slightly change handling of encoding-error and decoding-error: - If :encoding-error is a character, then the external format will use that character whenever an encoding error happens instead of the default (internally specified by the external format). - If :decoding-error is a character, then the external format will use that character whenever an encoding error happens instead of the default (internally specified by the external format). If :decoding-error is T, then a cerror is signaled; if continued, the Unicode replacement character (#\U+FFFD) is used. o Fix bug in OPEN: The :decoding-error and :encoding-error keyword parameter was placed in the &aux section by mistake. --- code/extfmts.lisp | 10 +++++----- code/fd-stream.lisp | 43 +++++++++++++++++++++++++++++-------------- 2 files changed, 34 insertions(+), 19 deletions(-) diff --git a/code/extfmts.lisp b/code/extfmts.lisp index d8df0ac44..4eb96cacb 100644 --- a/code/extfmts.lisp +++ b/code/extfmts.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.28 2010/07/02 16:29:55 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.29 2010/07/02 23:06:26 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -384,16 +384,16 @@ (make-external-format (%composed-ef-name (ef-name a) (ef-name b)) (make-efx - :octets-to-code (lambda (state input unput) + :octets-to-code (lambda (state input unput error) (let ((nstate (gensym "STATE-"))) `(let ((,nstate ,state)) (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil)))) ,(funcall (ef-octets-to-code b) `(car ,nstate) (funcall (ef-octets-to-code a) - `(cdr ,nstate) input unput) + `(cdr ,nstate) input unput error) unput)))) - :code-to-octets (lambda (code state output) + :code-to-octets (lambda (code state output error) (let ((nstate (gensym "STATE-"))) `(let ((,nstate ,state)) (when (null ,nstate) @@ -401,7 +401,7 @@ ,(funcall (ef-code-to-octets b) code `(car ,nstate) `(lambda (x) ,(funcall (ef-code-to-octets a) - 'x `(cdr ,nstate) output)))))) + 'x `(cdr ,nstate) output error)))))) :cache (make-array +ef-max+ :initial-element nil) :min (* (ef-min-octets a) (ef-min-octets b)) :max (* (ef-max-octets a) (ef-max-octets b))) diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index ac19dbba4..719a0c6ba 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.105 2010/07/02 16:29:55 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.106 2010/07/02 23:06:26 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -590,7 +590,8 @@ (do-output stream sap 0 tail t) (setq sap (fd-stream-obuf-sap stream) tail 0)) - (setf (bref sap (1- (incf tail))) byte))) + (setf (bref sap (1- (incf tail))) byte)) + (fd-stream-char-to-octets-error stream)) (setf (fd-stream-obuf-tail stream) tail)) (if (char= char #\Newline) (setf (fd-stream-char-pos stream) 0) @@ -1816,16 +1817,30 @@ :pathname pathname :buffering buffering :timeout timeout) - (%make-fd-stream :fd fd - :name name - :file file - :original original - :delete-original delete-original - :pathname pathname - :buffering buffering - :timeout timeout - :char-to-octets-error encoding-error - :octets-to-char-error decoding-error)))) + (let ((e (cond ((characterp encoding-error) + (constantly (char-code encoding-error))) + (t + encoding-error))) + (d (cond ((characterp decoding-error) + (constantly (char-code decoding-error))) + ((eq t decoding-error) + #'(lambda (&rest args) + (apply 'cerror + "Use Unicode replacement character instead" + args) + stream:+replacement-character-code+)) + (t + decoding-error)))) + (%make-fd-stream :fd fd + :name name + :file file + :original original + :delete-original delete-original + :pathname pathname + :buffering buffering + :timeout timeout + :char-to-octets-error e + :octets-to-char-error d))))) ;; FIXME: setting the external format here should be better ;; integrated into set-routines. We do it before so that ;; set-routines can create an in-buffer if appropriate. But we @@ -2153,13 +2168,13 @@ (if-does-not-exist nil if-does-not-exist-given) (external-format :default) class mapped input-handle output-handle + decoding-error encoding-error &allow-other-keys &aux ; Squelch assignment warning. (options options) (direction direction) (if-does-not-exist if-does-not-exist) - (if-exists if-exists) - decoding-error encoding-error) + (if-exists if-exists)) "Return a stream which reads from or writes to Filename. Defined keywords: :direction - one of :input, :output, :io, or :probe -- GitLab