CMUCL commit: src/code (extfmts.lisp fd-stream.lisp)

[Raymond Toy]

    Date: Saturday, July 3, 2010 @ 09:39:20
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/code

Modified: extfmts.lisp fd-stream.lisp

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.


----------------+
 extfmts.lisp   |   14 +++++++-------
 fd-stream.lisp |   28 +++++++++++++++++-----------
 2 files changed, 24 insertions(+), 18 deletions(-)


Index: src/code/extfmts.lisp
diff -u src/code/extfmts.lisp:1.29 src/code/extfmts.lisp:1.30
--- src/code/extfmts.lisp:1.29	Fri Jul  2 19:06:26 2010
+++ src/code/extfmts.lisp	Sat Jul  3 09:39:19 2010
@@ -5,7 +5,7 @@
 ;;; domain.
 ;;; 
 (ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.29 2010-07-02 23:06:26 rtoy Exp $")
+ "$Header: /project/cmucl/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))
Index: src/code/fd-stream.lisp
diff -u src/code/fd-stream.lisp:1.106 src/code/fd-stream.lisp:1.107
--- src/code/fd-stream.lisp:1.106	Fri Jul  2 19:06:26 2010
+++ src/code/fd-stream.lisp	Sat Jul  3 09:39:20 2010
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/code/fd-stream.lisp,v 1.106 2010-07-02 23:06:26 rtoy Exp $")
+  "$Header: /project/cmucl/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