From 2294993e0dc826d84ef47c834da4fe8d728619e4 Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cantab.net>
Date: Wed, 11 Nov 2009 17:52:39 +0000
Subject: [PATCH] 1.0.32.22: implement output restarts for UCS2

Most of the work was done; we just had to actually turn the catch tag
on, and write tests that are correct rather than wrong.
---
 src/code/external-formats/ucs-2.lisp |    4 +--
 tests/external-format.impure.lisp    |   59 ++++++++++++++++++++++++++++++++++
 version.lisp-expr                    |    2 +-
 3 files changed, 62 insertions(+), 3 deletions(-)

diff --git a/src/code/external-formats/ucs-2.lisp b/src/code/external-formats/ucs-2.lisp
index 8eefcef..def9d96 100644
--- a/src/code/external-formats/ucs-2.lisp
+++ b/src/code/external-formats/ucs-2.lisp
@@ -189,7 +189,7 @@
 
 (instantiate-octets-definition define-ucs-2->string)
 
-(define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) nil
+(define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) t
   2
   (if (< bits #x10000)
       (setf (sap-ref-16le sap tail) bits)
@@ -199,7 +199,7 @@
   ucs-2le->string-aref
   string->ucs-2le)
 
-(define-external-format/variable-width (:ucs-2be :ucs2be) nil
+(define-external-format/variable-width (:ucs-2be :ucs2be) t
   2
   (if (< bits #x10000)
       (setf (sap-ref-16be sap tail) bits)
diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp
index 9311320..0465ebc 100644
--- a/tests/external-format.impure.lisp
+++ b/tests/external-format.impure.lisp
@@ -848,4 +848,63 @@
       (assert (= 113 (count #\? string :start #x80))))))
 (delete-file *test-path*)
 
+;;; ucs-2 tests
+(with-test (:name (:multibyte :ucs2le))
+  (let* ((size 120)
+         (array (map-into (make-array size :element-type '(unsigned-byte 16))
+                          (lambda () (random #x10000)))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
+      (dotimes (i size)
+        (write-byte (ldb (byte 8 0) (aref array i)) s)
+        (write-byte (ldb (byte 8 8) (aref array i)) s)))
+    (with-open-file (s *test-path* :external-format :ucs2le)
+      (let ((string (make-string size)))
+        (read-sequence string s)
+        (dotimes (i size)
+          (assert (= (char-code (char string i)) (aref array i))))))))
+
+(with-test (:name (:multibyte :ucs2be))
+  (let* ((size 120)
+         (array (map-into (make-array size :element-type '(unsigned-byte 16))
+                          (lambda () (random #x10000)))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
+      (dotimes (i size)
+        (write-byte (ldb (byte 8 8) (aref array i)) s)
+        (write-byte (ldb (byte 8 0) (aref array i)) s)))
+    (with-open-file (s *test-path* :external-format :ucs2be)
+      (let ((string (make-string size)))
+        (read-sequence string s)
+        (dotimes (i size)
+          (assert (= (char-code (char string i)) (aref array i))))))))
+
+(with-test (:name (:multibyte :output-replacement :ucs2le))
+  (let* ((size 1200)
+         (string (map-into (make-string size)
+                           (lambda () (code-char (random #x10000))))))
+    (setf (char string 0) (code-char #x10001)
+          (char string (1- size)) (code-char #x10002))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2le :replacement #\replacement_character))
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :ucs2le)
+      (let ((new (make-string size)))
+        (read-sequence new s)
+        (assert (char= (char new 0) #\replacement_character))
+        (assert (char= (char new (1- size)) #\replacement_character))
+        (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
+
+(with-test (:name (:multibyte :output-replacement :ucs2be))
+  (let* ((size 1200)
+         (string (map-into (make-string size)
+                           (lambda () (code-char (random #x10000))))))
+    (setf (char string 0) (code-char #x10001)
+          (char string (1- size)) (code-char #x10002))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede :external-format '(:ucs2be :replacement #\replacement_character))
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :ucs2be)
+      (let ((new (make-string size)))
+        (read-sequence new s)
+        (assert (char= (char new 0) #\replacement_character))
+        (assert (char= (char new (1- size)) #\replacement_character))
+        (assert (string= string new :start1 1 :start2 1 :end1 (1- size) :end2 (1- size)))))))
+
 ;;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index eb84f98..b0940a8 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.32.21"
+"1.0.32.22"
-- 
1.7.10.4