From 6afe1d62087db4480a8654fdaa6f36107b095118 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Sat, 3 Jul 2010 13:39:20 +0000 Subject: [PATCH] code/extfmts.lisp: o Add error parameter to flush-state in external format definition so we can handle errors when flushing the state to a stream. o Add optional error parameter to flush-state macro. code/fd-stream.lisp: o For the case where an external format has flush method, EF-FLUSH was not calling it correctly. Update so the output function actuall works. o Add error handler to call to flush-state. o For the case where an external format does not have a flush method, output the state value instead of a replacement character so the external format can handle any errors. --- code/extfmts.lisp | 14 +++++++------- code/fd-stream.lisp | 28 +++++++++++++++++----------- 2 files changed, 24 insertions(+), 18 deletions(-) diff --git a/code/extfmts.lisp b/code/extfmts.lisp index 4eb96cacb..6482929c7 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.29 2010/07/02 23:06:26 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.30 2010/07/03 13:39:19 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -168,7 +168,7 @@ ;;; stream's state variable. Output is a form that writes one octet ;;; to the output stream. ;;; -;;; flush-state (state output &rest vars) +;;; flush-state (state output error &rest vars) ;;; Defines a form to be used by the external format to flush out ;;; any state when an output stream is closed. Similar to ;;; CODE-TO-OCTETS, but there is no code. @@ -225,9 +225,9 @@ `(let ((,',code (the lisp:codepoint ,,',tmp))) (declare (ignorable ,',code)) ,,body)))) - (flush-state ((state output &rest vars) body) - `(lambda (,state ,output) - (declare (ignorable ,state ,output)) + (flush-state ((state output error &rest vars) body) + `(lambda (,state ,output ,error) + (declare (ignorable ,state ,output ,error)) (let (,@',slotb ,@(loop for var in vars collect `(,var (gensym)))) ,body))) @@ -667,11 +667,11 @@ +replacement-character-code+) (char-code ,nchar))))))))) -(defmacro flush-state (external-format state output) +(defmacro flush-state (external-format state output &optional error) (let* ((ef (find-external-format external-format)) (f (ef-flush-state ef))) (when f - (funcall f state output)))) + (funcall f state output error)))) (defmacro copy-state (external-format state) (let* ((ef (find-external-format external-format)) diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index 719a0c6ba..566d6c88e 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.106 2010/07/02 23:06:26 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.107 2010/07/03 13:39:20 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -415,15 +415,21 @@ (declare (type index tail)) (cond ((stream::ef-flush-state ,(stream::find-external-format extfmt)) - (stream::flush-state ,extfmt - (fd-stream-co-state stream) - (lambda (byte) - (when (= tail len) - (do-output stream sap 0 tail t) - (setq sap (fd-stream-obuf-sap stream) - tail 0)) - (setf (bref sap (1- (incf tail))) byte))) - (setf (fd-stream-obuf-tail stream) tail)) + (let* ((sap (fd-stream-obuf-sap stream)) + (len (fd-stream-obuf-length stream)) + (tail (fd-stream-obuf-tail stream))) + (declare (type sys:system-area-pointer sap) (type index len tail)) + + (stream::flush-state ,extfmt + (fd-stream-co-state stream) + (lambda (byte) + (when (= tail len) + (do-output stream sap 0 tail t) + (setq sap (fd-stream-obuf-sap stream) + tail 0)) + (setf (bref sap (1- (incf tail))) byte)) + (fd-stream-char-to-octets-error stream)) + (setf (fd-stream-obuf-tail stream) tail))) (t ;; No flush-state function, so just output a replacement ;; character. We hack the co-state to what we need for this @@ -434,7 +440,7 @@ (setf (fd-stream-co-state stream) (cons nil (cdr state))) (funcall (ef-cout (fd-stream-external-format stream)) - stream (code-char stream::+replacement-character-code+)))))) + stream (car state)))))) (values)))) ;;; FLUSH-OUTPUT-BUFFER -- internal -- GitLab