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