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

[Raymond Toy]

    Date: Saturday, July 3, 2010 @ 10:10:40
  Author: rtoy
    Path: /project/cmucl/cvsroot/src/code

Modified: fd-stream.lisp

In EF-FLUSH, we need to handle bare surrogates ourselves for the case
where the external format does not have a flush-state method.


----------------+
 fd-stream.lisp |   24 +++++++++++++++++-------
 1 file changed, 17 insertions(+), 7 deletions(-)


Index: src/code/fd-stream.lisp
diff -u src/code/fd-stream.lisp:1.107 src/code/fd-stream.lisp:1.108
--- src/code/fd-stream.lisp:1.107	Sat Jul  3 09:39:20 2010
+++ src/code/fd-stream.lisp	Sat Jul  3 10:10:40 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.107 2010-07-03 13:39:20 rtoy Exp $")
+  "$Header: /project/cmucl/cvsroot/src/code/fd-stream.lisp,v 1.108 2010-07-03 14:10:40 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -432,15 +432,25 @@
 	    (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
-	  ;; to work.  This should be ok because we're closing the
-	  ;; file anyway.
-	  (let ((state (fd-stream-co-state stream)))
-	    (when (and state (car state))
+	  ;; character (or signal an error).  We hack the co-state to
+	  ;; what we need for this to work.  This should be ok because
+	  ;; we're closing the file anyway.
+	  (let* ((state (fd-stream-co-state stream))
+		 (c (car state)))
+	    (when (and state c)
 	      (setf (fd-stream-co-state stream)
 		    (cons nil (cdr state)))
 	      (funcall (ef-cout (fd-stream-external-format stream))
-		       stream (car state))))))
+		       stream
+		       ;; Handle bare surrogates or use the
+		       ;; replacement character.
+		       (if (lisp::surrogatep c)
+			   (if (fd-stream-char-to-octets-error stream)
+			       (funcall (fd-stream-char-to-octets-error stream)
+					"Flushing bare surrogate #x~4,0X is illegal"
+					(char-code c))
+			       (code-char stream:+replacement-character-code+))
+			   c))))))
        (values))))
   
 ;;; FLUSH-OUTPUT-BUFFER -- internal