From 8f0dc98ad37e6b555a59f85708a3f8679cbd3554 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 13 Aug 2009 13:55:13 +0000
Subject: [PATCH] Illegal surrogate sequences (leading surrogate without
 trailing surrogate or a lone trailing surrogate) get replaced with the
 replacement character.

---
 code/extfmts.lisp | 17 +++++++++++++----
 1 file changed, 13 insertions(+), 4 deletions(-)

diff --git a/code/extfmts.lisp b/code/extfmts.lisp
index d387eed56..505a9ba72 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.13 2009/08/11 03:30:27 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/extfmts.lisp,v 1.14 2009/08/13 13:55:13 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -543,16 +543,25 @@
     `(let ((,nchar ,char)
 	   (,nstate ,state))
        (when (null ,nstate) (setq ,nstate (setf ,state (cons nil nil))))
-       (if (<= #xD800 (char-code ,nchar) #xDBFF)
+       (if (lisp::surrogatep (char-code ,nchar) :high)
 	   (setf (car ,nstate) ,nchar)
 	   (flet ((,wryte (,ch)
 		    (codepoint-to-octets ,external-format ,ch (cdr ,nstate)
 					 ,output)))
 	     (declare (dynamic-extent #',wryte))
 	     (if (car ,nstate)
-		 (prog1 (,wryte (surrogates-to-codepoint (car ,nstate) ,nchar))
+		 (prog1
+		     ;; Invalid surrogate sequences get replaced with
+		     ;; the replacement character.
+		     (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
+				 (surrogates-to-codepoint (car ,nstate) ,nchar)
+				 +replacement-character-code+))
 		   (setf (car ,nstate) nil))
-		 (,wryte (char-code ,nchar))))))))
+		 ;; A lone trailing (low) surrogate gets replaced with
+		 ;; the replacement character.
+		 (,wryte (if (lisp::surrogatep (char-code ,nchar) :low)
+			     +replacement-character-code+
+			     (char-code ,nchar)))))))))
 
 (def-ef-macro ef-string-to-octets (extfmt lisp::lisp +ef-max+ +ef-so+)
   `(lambda (string start end buffer &aux (ptr 0) (state nil))
-- 
GitLab