From 1325c62e68c6a9febe55456cb27a4abca2605e5c Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Wed, 26 Aug 2009 16:25:41 +0000
Subject: [PATCH] Add support for flushing out any state in an external format
 when closing an output stream.  This causes things like

(with-open-file (s "foo" :direction :output :external-format :utf-8)
  (write-char #\u+d800 s))

to output the replacement character instead of creating an empty file.

code/extfmts.lisp:
o Add new slot to efx structure to hold the function to flush the
  state in an external format.
o Add accessor for the flush-state slot.
o Update DEFINE-EXTERNAL-FORMAT to allow specifying the flush
  function.
o Add macro to call the flush-state function.
o Added +EF-FLUSH+
o Use vm::defenum to name the constants instead of the hand-written
  values.
o Export +REPLACEMENT-CHARACTER-CODE+
o Document the slots in an efx stucture.

code/fd-stream.lisp:
o Add ef-flush def-ef-macro to flush the state of an external format
  when closing an output file.  If ef-flush-state is NIL, we just call
  EF-COUT to send out the replacement character.  Otherwise, the
  flush-state function is called to handle it.
o When closing an output character stream, call ef-flush to flush any
  state before flushing the buffers of the stream.
o Document the unicode slots in an fd-stream.

code/exports.lisp:
o Export +REPLACEMENT-CHARACTER-CODE+
---
 code/exports.lisp   |  5 ++--
 code/extfmts.lisp   | 73 ++++++++++++++++++++++++++++++++++-----------
 code/fd-stream.lisp | 51 +++++++++++++++++++++++++++++--
 3 files changed, 108 insertions(+), 21 deletions(-)

diff --git a/code/exports.lisp b/code/exports.lisp
index 4f70e7fc9..1839f7da6 100644
--- a/code/exports.lisp
+++ b/code/exports.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/exports.lisp,v 1.289 2009/08/26 15:40:40 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.290 2009/08/26 16:25:41 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1532,7 +1532,8 @@
 	   
 	   "STRING-TO-OCTETS" "OCTETS-TO-STRING" "*DEFAULT-EXTERNAL-FORMAT*"
 	   "STRING-ENCODE" "STRING-DECODE"
-	   "SET-SYSTEM-EXTERNAL-FORMAT"))
+	   "SET-SYSTEM-EXTERNAL-FORMAT"
+	   "+REPLACEMENT-CHARACTER-CODE+"))
 
 (defpackage "LOOP")
 (dolist
diff --git a/code/extfmts.lisp b/code/extfmts.lisp
index 505a9ba72..3040de967 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.14 2009/08/13 13:55:13 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.15 2009/08/26 16:25:41 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -14,23 +14,26 @@
 (in-package "STREAM")
 
 (export '(string-to-octets octets-to-string *default-external-format*
-	  string-encode string-decode set-system-external-format))
+	  string-encode string-decode set-system-external-format
+	  +replacement-character-code+))
 
 (defvar *default-external-format* :iso8859-1)
 
 (defvar *external-formats* (make-hash-table :test 'equal))
 (defvar *external-format-aliases* (make-hash-table))
 
-(defconstant +ef-str+ 1)
-(defconstant +ef-cin+ 2)
-(defconstant +ef-cout+ 3)
-(defconstant +ef-sin+ 4)
-(defconstant +ef-sout+ 5)
-(defconstant +ef-os+ 6)
-(defconstant +ef-so+ 7)
-(defconstant +ef-en+ 8)
-(defconstant +ef-de+ 9)
-(defconstant +ef-max+ 10)
+(vm::defenum (:prefix "+EF-" :suffix "+" :start 1)
+  str					; string length
+  cin					; input a character
+  cout					; output a character
+  sin					; input string
+  sout					; output string
+  os					; octets to string
+  so					; string to octets
+  en					; encode
+  de					; decode
+  flush					; flush state
+  max)
 
 ;; Unicode replacement character U+FFFD
 (defconstant +replacement-character-code+ #xFFFD)
@@ -47,10 +50,25 @@
   (error 'external-format-not-implemented))
 
 (defstruct efx
+  ;;
+  ;; Function to read a sequence of octets from a stream and convert
+  ;; them a code point.
   (octets-to-code #'%efni :type function :read-only t)
+  ;;
+  ;; Function to convert a codepoint to a sequence of octets and write
+  ;; them to an output stream.
   (code-to-octets #'%efni :type function :read-only t)
+  ;;
+  ;; Function (or NIL) to force any state in the external format to be
+  ;; flushed to the output stream.  A NIL value means the external
+  ;; format does not need to do anything special.
+  (flush-state nil :type (or null function) :read-only t)
   (cache nil :type (or null simple-vector))
+  ;;
+  ;; Minimum number of octets needed to form a codepoint
   (min 1 :type kernel:index :read-only t)
+  ;;
+  ;; Maximum number of octest needed to form a codepoint.
   (max 1 :type kernel:index :read-only t))
 
 (defstruct (external-format
@@ -72,8 +90,8 @@
 (defun %intern-ef (ef)
   (setf (gethash (ef-name ef) *external-formats*) ef))
 
-(declaim (inline ef-octets-to-code ef-code-to-octets ef-cache
-		 ef-min-octets ef-max-octets))
+(declaim (inline ef-octets-to-code ef-code-to-octets ef-flush-state
+		 ef-cache ef-min-octets ef-max-octets))
 
 (defun ef-octets-to-code (ef)
   (efx-octets-to-code (ef-efx ef)))
@@ -81,6 +99,9 @@
 (defun ef-code-to-octets (ef)
   (efx-code-to-octets (ef-efx ef)))
 
+(defun ef-flush-state (ef)
+  (efx-flush-state (ef-efx ef)))
+
 (defun ef-cache (ef)
   (efx-cache (ef-efx ef)))
 
@@ -106,7 +127,7 @@
 
 ;;; DEFINE-EXTERNAL-FORMAT  -- Public
 ;;;
-;;; name (&key min max size) (&rest slots) octets-to-code code-to-octets
+;;; name (&key min max size) (&rest slots) octets-to-code code-to-octets flush-state
 ;;;   Define a new external format.  Min/Max/Size are the minimum and
 ;;;   maximum number of octets that make up a character (:size N is just
 ;;;   shorthand for :min N :max N).  Slots is a list of slot descriptions
@@ -135,6 +156,11 @@
 ;;;   stream's state variable.  Output is a form that writes one octet
 ;;;   to the output stream.
 ;;;
+;;; flush-state (state output &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.
+;;;
 ;;; Note: external-formats work on code-points, not
 ;;;   characters, so that the entire 31 bit ISO-10646 range can be
 ;;;   used internally regardless of the size of a character recognized
@@ -143,7 +169,7 @@
 ;;;   CODEPOINT-TO-OCTETS, OCTETS-TO-CODEPOINT)
 ;;;
 (defmacro define-external-format (name (&rest args) (&rest slots)
-				       &optional octets-to-code code-to-octets)
+				       &optional octets-to-code code-to-octets flush-state)
   (when (and (oddp (length args)) (not (= (length args) 1)))
     (warn "Nonsensical argument (~S) to DEFINE-EXTERNAL-FORMAT." args))
   (let* ((tmp (gensym))
@@ -180,12 +206,19 @@
 			   ,@(loop for var in vars collect `(,var (gensym))))
 		       `(let ((,',code (the (unsigned-byte 21) ,,',tmp)))
 			  (declare (ignorable ,',code))
-			  ,,body)))))
+			  ,,body))))
+		(flush-state ((state output &rest vars) body)
+		  `(lambda (,state ,output)
+		     (declare (ignorable ,state ,output))
+		     (let (,@',slotb
+			   ,@(loop for var in vars collect `(,var (gensym))))
+		       ,body))))
        (%intern-ef (make-external-format ,name
 		    ,(if base
 			 `(ef-efx (find-external-format ,(ef-name base)))
 			 `(make-efx :octets-to-code ,octets-to-code
 				    :code-to-octets ,code-to-octets
+				    :flush-state ,flush-state	    
 				    :cache (make-array +ef-max+
 							  :initial-element nil)
 				    :min ,(min min max) :max ,(max min max)))
@@ -563,6 +596,12 @@
 			     +replacement-character-code+
 			     (char-code ,nchar)))))))))
 
+(defmacro flush-state (external-format state output)
+  (let* ((ef (find-external-format external-format))
+	 (f (ef-flush-state ef)))
+    (when f
+      (funcall f state output))))
+
 (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+)
   `(lambda (string start end buffer &aux (ptr 0) (state nil))
      (declare #|(optimize (speed 3) (safety 0) (space 0) (debug 0))|#
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
index e3d1e08ca..f9e685f03 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.89 2009/08/10 16:47:41 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.90 2009/08/26 16:25:41 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -235,8 +235,18 @@
   ;; so initialize to NIL and fix it in SET-ROUTINES
   #+unicode
   (external-format nil :type (or null keyword cons))
+  ;;
+  ;; State for octets-to-char (for reading from a stream).  The
+  ;; contents of the state can be anything and is defined by the
+  ;; external format.
   #+unicode
   (oc-state nil)
+  ;;
+  ;; State for char-to-octets (for writing to a stream).  The contents
+  ;; of the state can be anything and is defined by the external
+  ;; format.  If not NIL, then the CAR is used by char-to-octets to
+  ;; hold some state information, and the CDR is available to the
+  ;; external format to hold whatever state information is needed.
   #+unicode
   (co-state nil)
   #+unicode
@@ -365,7 +375,36 @@
 		 (output-later stream base (the index (+ start count))
 			       end reuse-sap)))))))
 
-
+#+unicode
+(stream::def-ef-macro ef-flush (extfmt lisp stream::+ef-max+ stream::+ef-flush+)
+  `(lambda (stream)
+     (declare (type fd-stream stream))
+     (let* ((tail (fd-stream-obuf-tail stream)))
+       (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))
+	 (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))
+	      (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+))))))
+       (values))))
+  
 ;;; FLUSH-OUTPUT-BUFFER -- internal
 ;;;
 ;;;   Flush any data in the output buffer.
@@ -1479,6 +1518,14 @@
 	      (revert-file (fd-stream-file stream)
 			   (fd-stream-original stream))))
 	   (t
+	    #+(and unicode (not unicode-bootstrap))
+	    (when (and (output-stream-p stream)
+		       (eq (stream-element-type stream) 'character))
+	      ;; For output character streams, we need to flush out
+	      ;; any state that the external format might have.
+	      #+nil (format *debug-io* "state = ~S~%" (fd-stream-co-state stream))
+	      (funcall (ef-flush (fd-stream-external-format stream))
+		       stream))
 	    (fd-stream-misc-routine stream :finish-output)
 	    (when (fd-stream-delete-original stream)
 	      (delete-original (fd-stream-file stream)
-- 
GitLab