From 0c3220f329489c342bbe8e3e5e22544d9c138e22 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Sat, 3 Jul 2010 13:45:01 +0000
Subject: [PATCH] Add flush-state method to flush out the UTF16 state.  This
 allows us to signal errors on bare surrogates at the end of the output.

---
 .../external-formats/utf-16-be.lisp               | 15 +++++++++++++--
 .../external-formats/utf-16-le.lisp               | 15 +++++++++++++--
 pcl/simple-streams/external-formats/utf-16.lisp   | 15 +++++++++++++--
 3 files changed, 39 insertions(+), 6 deletions(-)

diff --git a/pcl/simple-streams/external-formats/utf-16-be.lisp b/pcl/simple-streams/external-formats/utf-16-be.lisp
index a68ae5abf..a4150f26e 100644
--- a/pcl/simple-streams/external-formats/utf-16-be.lisp
+++ b/pcl/simple-streams/external-formats/utf-16-be.lisp
@@ -4,7 +4,7 @@
 ;;; This code was written by Paul Foley and has been placed in the public
 ;;; domain.
 ;;;
-(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16-be.lisp,v 1.6 2010/07/02 23:13:11 rtoy Exp $")
+(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16-be.lisp,v 1.7 2010/07/03 13:45:01 rtoy Exp $")
 
 (in-package "STREAM")
 
@@ -71,7 +71,18 @@
 		(output (logior ,c2 #xDC00))))
 	     (t
 	      (output +replacement-character-code+)))))
-  nil
+  (flush-state (state output error c)
+    `(flet ((out (code)
+	      (,output (ldb (byte 8 8) code))
+	      (,output (ldb (byte 8 0) code))))
+       (let ((,c (car ,state)))
+	 (,output (if (lisp::surrogatep ,c)
+		      (if ,error
+			  (funcall ,error
+				   "Flushing bare surrogate #x~4,0X is illegal for UTF-16"
+				   (char-code ,c))
+			  +replacement-character-code+)
+		      ,c)))))
   (copy-state (state)
     ;; The state is either NIL or a codepoint, so nothing really
     ;; special is needed to copy it.
diff --git a/pcl/simple-streams/external-formats/utf-16-le.lisp b/pcl/simple-streams/external-formats/utf-16-le.lisp
index 4034ce532..365eea5ff 100644
--- a/pcl/simple-streams/external-formats/utf-16-le.lisp
+++ b/pcl/simple-streams/external-formats/utf-16-le.lisp
@@ -4,7 +4,7 @@
 ;;; This code was written by Paul Foley and has been placed in the public
 ;;; domain.
 ;;;
-(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16-le.lisp,v 1.6 2010/07/02 23:13:11 rtoy Exp $")
+(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16-le.lisp,v 1.7 2010/07/03 13:45:01 rtoy Exp $")
 
 (in-package "STREAM")
 
@@ -72,7 +72,18 @@
 		(output (logior ,c2 #xDC00))))
 	     (t
 	      (output +replacement-character-code+)))))
-  nil
+  (flush-state (state output error c)
+    `(flet ((out (code)
+	      (,output (ldb (byte 8 0) code))
+	      (,output (ldb (byte 8 8) code))))
+       (let ((,c (car ,state)))
+	 (,output (if (lisp::surrogatep ,c)
+		      (if ,error
+			  (funcall ,error
+				   "Flushing bare surrogate #x~4,0X is illegal for UTF-16"
+				   (char-code ,c))
+			  +replacement-character-code+)
+		      ,c)))))
   (copy-state (state)
     ;; The state is either NIL or a codepoint, so nothing really
     ;; special is needed.
diff --git a/pcl/simple-streams/external-formats/utf-16.lisp b/pcl/simple-streams/external-formats/utf-16.lisp
index e64e8f5fd..04e268687 100644
--- a/pcl/simple-streams/external-formats/utf-16.lisp
+++ b/pcl/simple-streams/external-formats/utf-16.lisp
@@ -1,7 +1,7 @@
 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: STREAM -*-
 ;;;
 ;;; **********************************************************************
-(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16.lisp,v 1.8 2010/07/02 23:13:11 rtoy Exp $")
+(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/external-formats/utf-16.lisp,v 1.9 2010/07/03 13:45:01 rtoy Exp $")
 
 (in-package "STREAM")
 
@@ -112,7 +112,18 @@
 		(output (logior ,c2 #xDC00))))
 	     (t
 	      (output +replacement-character-code+)))))
-  nil
+  (flush-state (state output error c)
+    `(flet ((out (code)
+	      (,output (ldb (byte 8 8) code))
+	      (,output (ldb (byte 8 0) code))))
+       (let ((,c (car ,state)))
+	 (out (if (lisp::surrogatep ,c)
+		  (if ,error
+		      (funcall ,error
+			       "Flushing bare surrogate #x~4,0X is illegal for UTF-16"
+			       (char-code ,c))
+		      +replacement-character-code+)
+		  ,c)))))
   (copy-state (state)
     ;; The state is list. Copy it
     `(copy-list ,state)))
-- 
GitLab