1.0.33.22: fix WITH-MUTEX docstring

[sbcl.git] / tests / external-format.impure.lisp

diff --git a/tests/external-format.impure.lisp b/tests/external-format.impure.lisp
index 9311320..96c8608 100644 (file)
--- a/tests/external-format.impure.lisp
+++ b/tests/external-format.impure.lisp
@@ -848,4 +848,140 @@
       (assert (= 113 (count #\? string :start #x80))))))
 (delete-file *test-path*)
 \f
+;;; 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)))))))
+
+(with-test (:name (:multibyte :input-replacement :ucs4le))
+  (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
+      (write-sequence octets s))
+    (with-open-file (s *test-path* :external-format '(:ucs4le :replacement #\replacement_character))
+      (let ((string (read-line s)))
+        (assert (char= (char string 0) (code-char #x10100)))
+        (assert (char= (char string 1) #\replacement_character))))))
+
+(with-test (:name (:multibyte :input-replacement :ucs4le))
+  (let ((octets (coerce '(0 1 1 0 1 0 0 1) '(vector (unsigned-byte 8)))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
+      (write-sequence octets s))
+    (with-open-file (s *test-path* :external-format '(:ucs4be :replacement #\replacement_character))
+      (let ((string (read-line s)))
+        (assert (char= (char string 0) (code-char #x10100)))
+        (assert (char= (char string 1) #\replacement_character))))))
+\f
+;;; utf tests
+(with-test (:name (:utf-16le :roundtrip))
+  (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede
+                       :external-format :utf-16le)
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :utf-16le)
+      (assert (string= string (read-line s))))))
+(with-test (:name (:utf-16be :roundtrip))
+  (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede
+                       :external-format :utf-16be)
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :utf-16be)
+      (assert (string= string (read-line s))))))
+(with-test (:name (:utf-16le :encoding-error))
+  (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede
+                       :external-format '(:utf-16le :replacement #\?))
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :utf-16le)
+      (assert (string= " ???? " (read-line s))))))
+(with-test (:name (:utf-16be :encoding-error))
+  (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede
+                       :external-format '(:utf-16be :replacement #\?))
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :utf-16be)
+      (assert (string= " ???? " (read-line s))))))
+
+(with-test (:name (:utf-32le :roundtrip))
+  (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede
+                       :external-format :utf-32le)
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :utf-32le)
+      (assert (string= string (read-line s))))))
+(with-test (:name (:utf-32be :roundtrip))
+  (let ((string (map 'string 'code-char '(#x20 #x200 #x2000 #xfffd #x10fffd))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede
+                       :external-format :utf-32be)
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :utf-32be)
+      (assert (string= string (read-line s))))))
+(with-test (:name (:utf-32le :encoding-error))
+  (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede
+                       :external-format '(:utf-32le :replacement #\?))
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :utf-32le)
+      (assert (string= " ???? " (read-line s))))))
+(with-test (:name (:utf-32be :encoding-error))
+  (let ((string (map 'string 'code-char '(#x20 #xfffe #xdc00 #xd800 #x1fffe #x20))))
+    (with-open-file (s *test-path* :direction :output :if-exists :supersede
+                       :external-format '(:utf-32be :replacement #\?))
+      (write-string string s))
+    (with-open-file (s *test-path* :external-format :utf-32be)
+      (assert (string= " ???? " (read-line s))))))
+\f
 ;;;; success