Encode/decode astral characters as surrogate pairs on UTF-16 hosts

src/streams.lisp

@@ -124,7 +124,10 @@
 
 (defclass in-memory-output-stream (in-memory-stream
                                    fundamental-binary-output-stream)
-  ()
+  ((pending-high
+    ;; UTF-16 host only: a high surrogate written via STREAM-WRITE-CHAR that is
+    ;; waiting for its low-surrogate half before being encoded.  NIL otherwise.
+    :initform nil :accessor in-memory-stream-pending-high))
   (:documentation "An IN-MEMORY-OUTPUT-STREAM is a binary stream that
                    writes octets to a sequence in RAM."))
 
@@ -312,14 +315,46 @@ contains the octes that were actually output."
   (incf (vector-stream-index stream) (- end start))
   (values))
 
+(defun %stream-encode-and-extend (stream string)
+  "Encode STRING with STREAM's external-format and append the octets."
+  (extend-vector-output-stream-buffer
+   (string-to-octets string :encoding (external-format-of stream)) stream))
+
+;;; UTF-16 host: an astral character reaches STREAM-WRITE-CHAR as two calls (a
+;;; high then a low surrogate).  Buffer the high surrogate until its low half
+;;; arrives, then encode the combined code point as one (the patched
+;;; STRING-TO-OCTETS recombines the pair).  A high surrogate not followed by a
+;;; low one (or a stray low surrogate) is flushed as a lone surrogate, taking
+;;; babel's normal encoding-error / substitution policy.
+(defun %utf16-stream-write-char (stream char)
+  (let ((code (char-code char))
+        (pending (in-memory-stream-pending-high stream)))
+    (cond
+      ((and pending (babel::lo-surrogate-p code))
+       (setf (in-memory-stream-pending-high stream) nil)
+       (%stream-encode-and-extend stream (coerce (list pending char) 'string)))
+      ((babel::hi-surrogate-p code)
+       (when pending
+         (%stream-encode-and-extend stream (string pending)))
+       (setf (in-memory-stream-pending-high stream) char))
+      (t
+       (when pending
+         (setf (in-memory-stream-pending-high stream) nil)
+         (%stream-encode-and-extend stream (string pending)))
+       (%stream-encode-and-extend stream (string char))))))
+
 (defmethod stream-write-char ((stream vector-output-stream) char)
   (declare (optimize speed))
   (check-if-open stream)
-  (if (eq (element-type-of stream) 'character)
-      (vector-push-extend char (vector-stream-vector stream))
-      (let ((octets (string-to-octets (string char)
-                                      :encoding (external-format-of stream))))
-	(extend-vector-output-stream-buffer octets stream)))
+  (cond
+    ((eq (element-type-of stream) 'character)
+     (vector-push-extend char (vector-stream-vector stream)))
+    (babel::+utf16-host-p+
+     (%utf16-stream-write-char stream char))
+    (t
+     (let ((octets (string-to-octets (string char)
+                                     :encoding (external-format-of stream))))
+       (extend-vector-output-stream-buffer octets stream))))
   char)
 
 (defmethod stream-write-sequence ((stream vector-output-stream)
@@ -382,6 +417,11 @@ been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since
 the creation of the stream, whichever occurred most recently. If
 AS-LIST is true the return value is coerced to a list."
   (declare (optimize speed))
+  ;; UTF-16 host: flush a dangling high surrogate (never paired) before reading.
+  (when (and babel::+utf16-host-p+ (in-memory-stream-pending-high stream))
+    (let ((c (in-memory-stream-pending-high stream)))
+      (setf (in-memory-stream-pending-high stream) nil)
+      (%stream-encode-and-extend stream (string c))))
   (let ((vector (vector-stream-vector stream)))
     (prog1
 	(ecase return-as

src/strings.lisp

@@ -129,6 +129,111 @@ are less than UNICODE-CHAR-CODE-LIMIT."
    :code-point-seq-getter string-get
    :code-point-seq-type simple-base-string))
 
+;;;; ---- UTF-16 host support (surrogate-pair aware; dotcl/ABCL) ----
+;;; On UTF-16 lisps (CHAR-CODE-LIMIT = #x10000) a CL string is a sequence of
+;;; UTF-16 code units; an astral character (> #xFFFF) is a surrogate PAIR (2
+;;; chars).  babel's codecs operate in full code-point space, so we bridge at
+;;; the string<->code-point boundary: ENCODE by combining surrogate pairs into a
+;;; code-point vector, DECODE by splitting astral code points back into a pair.
+;;; On UTF-32 hosts +UTF16-HOST-P+ is NIL and all of this is dead code.
+
+(defconstant +utf16-host-p+ (= char-code-limit #x10000)
+  "True on lisps whose CHAR-CODE-LIMIT is exactly #x10000, i.e. strings hold
+UTF-16 code units and astral characters are surrogate pairs (ABCL, etc.).
+An = test, not <=: a non-Unicode build (e.g. CHAR-CODE-LIMIT 256) has no
+surrogates and is correctly excluded.")
+
+(declaim (inline hi-surrogate-p lo-surrogate-p combine-surrogates))
+(defun hi-surrogate-p (code) (<= #xd800 code #xdbff))
+(defun lo-surrogate-p (code) (<= #xdc00 code #xdfff))
+(defun combine-surrogates (hi lo)
+  (+ #x10000 (ash (- hi #xd800) 10) (- lo #xdc00)))
+
+(deftype code-point-vector () '(simple-array (unsigned-byte 32) (*)))
+(defmacro cp-vec-get (vec index) `(aref ,vec ,index))
+(defmacro cp-vec-set (code vec index) `(setf (aref ,vec ,index) ,code))
+
+(defparameter *codepoint-vector-mappings*
+  (instantiate-concrete-mappings
+   :octet-seq-setter ub-set
+   :octet-seq-getter ub-get
+   :octet-seq-type (simple-array (unsigned-byte 8) (*))
+   :code-point-seq-setter cp-vec-set
+   :code-point-seq-getter cp-vec-get
+   :code-point-seq-type code-point-vector))
+
+(defun string-has-surrogates-p (string start end)
+  "True if STRING[start,end) contains any high-surrogate code unit."
+  (declare (type simple-unicode-string string) (fixnum start end))
+  (loop for i fixnum from start below end
+        thereis (hi-surrogate-p (char-code (schar string i)))))
+
+(defun %string-to-codepoints (string start end)
+  "Transcode a UTF-16 host STRING into a fresh code-point vector, combining
+surrogate pairs.  Lone surrogates are passed through as-is (the encoder's
+encodability check then applies babel's normal error/substitution policy)."
+  (declare (type simple-unicode-string string) (fixnum start end))
+  (let* ((n (- end start))
+         (out (make-array n :element-type '(unsigned-byte 32)))
+         (i start) (j 0))
+    (declare (fixnum n i j))
+    (loop while (< i end) do
+      (let ((c (char-code (schar string i))))
+        (declare (fixnum c))
+        (if (and (hi-surrogate-p c)
+                 (< (1+ i) end)
+                 (lo-surrogate-p (char-code (schar string (1+ i)))))
+            (progn
+              (setf (aref out j)
+                    (combine-surrogates c (char-code (schar string (1+ i)))))
+              (incf i 2))
+            (progn (setf (aref out j) c) (incf i)))
+        (incf j)))
+    (if (= j n) out (subseq out 0 j))))
+
+(defun %codepoints-to-string (cps n)
+  "Build a fresh UTF-16 host string from the first N code points of CPS,
+splitting astral (> #xFFFF) code points into surrogate pairs."
+  (declare (type code-point-vector cps) (fixnum n))
+  (let ((nchars 0))
+    (declare (fixnum nchars))
+    (dotimes (k n) (incf nchars (if (> (aref cps k) #xffff) 2 1)))
+    (let ((s (make-string nchars :element-type 'unicode-char))
+          (j 0))
+      (declare (fixnum j))
+      (dotimes (k n)
+        (let ((cp (aref cps k)))
+          (declare (type (unsigned-byte 32) cp))
+          (if (> cp #xffff)
+              (let ((v (- cp #x10000)))
+                (setf (schar s j) (code-char (logior #xd800 (ash v -10))))
+                (setf (schar s (1+ j)) (code-char (logior #xdc00 (logand v #x3ff))))
+                (incf j 2))
+              (progn (setf (schar s j) (code-char cp)) (incf j)))))
+      s)))
+
+(defun %utf16-string-to-octets (string start end encoding use-bom)
+  (let* ((cps (%string-to-codepoints string start end))
+         (n (length cps))
+         (mapping (lookup-mapping *codepoint-vector-mappings* encoding))
+         (bom (bom-vector encoding use-bom))
+         (bom-length (length bom))
+         (result (make-array (+ (the array-index
+                                  (funcall (octet-counter mapping) cps 0 n -1))
+                                bom-length)
+                             :element-type '(unsigned-byte 8))))
+    (replace result bom)
+    (funcall (encoder mapping) cps 0 n result bom-length)
+    result))
+
+(defun %utf16-octets-to-string (vector start end encoding)
+  (let ((mapping (lookup-mapping *codepoint-vector-mappings* encoding)))
+    (multiple-value-bind (size new-end)
+        (funcall (code-point-counter mapping) vector start end -1)
+      (let ((cps (make-array size :element-type '(unsigned-byte 32))))
+        (funcall (decoder mapping) vector start new-end cps 0)
+        (%codepoints-to-string cps size)))))
+
 ;;; Do we want a more a specific error condition here?
 (defun check-vector-bounds (vector start end)
   (unless (<= 0 start end (length vector))
@@ -224,15 +329,19 @@ shouldn't attempt to modify V."
   (check-type vector (vector (unsigned-byte 8)))
   (with-checked-simple-vector ((vector vector) (start start) (end end))
     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
-    (let ((*suppress-character-coding-errors* (not errorp))
-          (mapping (lookup-mapping *string-vector-mappings* encoding)))
-      (multiple-value-bind (size new-end)
-          (funcall (code-point-counter mapping) vector start end -1)
-        ;; TODO we could optimize ASCII here: the result should
-        ;; be a simple-base-string filled using code-char...
-        (let ((string (make-string size :element-type 'unicode-char)))
-          (funcall (decoder mapping) vector start new-end string 0)
-          string)))))
+    (let ((*suppress-character-coding-errors* (not errorp)))
+      (if +utf16-host-p+
+          ;; UTF-16 host: decode through a code-point vector so astral code
+          ;; points become surrogate pairs instead of erroring in CODE-CHAR.
+          (%utf16-octets-to-string vector start end encoding)
+          (let ((mapping (lookup-mapping *string-vector-mappings* encoding)))
+            (multiple-value-bind (size new-end)
+                (funcall (code-point-counter mapping) vector start end -1)
+              ;; TODO we could optimize ASCII here: the result should
+              ;; be a simple-base-string filled using code-char...
+              (let ((string (make-string size :element-type 'unicode-char)))
+                (funcall (decoder mapping) vector start new-end string 0)
+                string)))))))
 
 (defun bom-vector (encoding use-bom)
   (check-type use-bom (member :default t nil))
@@ -286,6 +395,11 @@ shouldn't attempt to modify V."
        (with-checked-simple-vector ((string (coerce string 'unicode-string))
                                     (start start) (end end))
          (declare (type simple-unicode-string string))
+         (when (and +utf16-host-p+ (string-has-surrogates-p string start end))
+           ;; UTF-16 host with astral chars: combine surrogate pairs into code
+           ;; points before encoding (BMP-only strings take the fast path below).
+           (return-from string-to-octets
+             (%utf16-string-to-octets string start end encoding use-bom)))
          (let* ((mapping (lookup-mapping *string-vector-mappings* encoding))
                 (bom (bom-vector encoding use-bom))
                 (bom-length (length bom))

tests/tests.lisp

@@ -1047,3 +1047,53 @@ RESULT defaults to `*last-test-result*' and STREAM defaults to t"
         (let ((oct2 (string-to-octets filtered-str :encoding :iso-2022-jp)))
           (is (eql (length filtered-octets) (length oct2)))
           (is (every #'eql filtered-octets oct2)))))))
+
+;;;; -------------------------------------------------------------------------
+;;;; Astral characters (code points > #xFFFF) on UTF-16 hosts
+;;;;
+;;;; On lisps whose CHAR-CODE-LIMIT is #x10000 (ABCL and others) a string holds
+;;;; UTF-16 code units, so an astral character is a surrogate pair.  Encoding
+;;;; and decoding must combine/split surrogate pairs so that astral text
+;;;; round-trips, exactly as it does on UTF-32 hosts.  The octets are the source
+;;;; of truth here, which keeps these tests host-independent.
+
+(deftest astral.utf-8.roundtrip ()
+  (let ((emoji (ub8v #xf0 #x9f #x98 #x80)))            ; U+1F600 GRINNING FACE
+    (is (equalp (string-to-octets (octets-to-string emoji :encoding :utf-8)
+                                  :encoding :utf-8)
+                emoji))))
+
+(deftest astral.utf-8.mixed ()
+  (let ((bytes (ub8v 97 #xf0 #x9f #x98 #x80 98)))      ; "a" U+1F600 "b"
+    (is (equalp (string-to-octets (octets-to-string bytes :encoding :utf-8)
+                                  :encoding :utf-8)
+                bytes))))
+
+(deftest astral.utf-8.consecutive ()
+  (let ((bytes (ub8v #xf0 #x9f #x98 #x80 #xf0 #x9f #x9a #x80))) ; U+1F600 U+1F680
+    (is (equalp (string-to-octets (octets-to-string bytes :encoding :utf-8)
+                                  :encoding :utf-8)
+                bytes))))
+
+(deftest astral.utf-8.boundary ()
+  ;; U+FFFF is the last BMP code point (3 octets); U+10000 the first astral (4).
+  (is (equalp (string-to-octets (octets-to-string (ub8v #xef #xbf #xbf)
+                                                   :encoding :utf-8)
+                                :encoding :utf-8)
+              (ub8v #xef #xbf #xbf)))
+  (is (equalp (string-to-octets (octets-to-string (ub8v #xf0 #x90 #x80 #x80)
+                                                   :encoding :utf-8)
+                                :encoding :utf-8)
+              (ub8v #xf0 #x90 #x80 #x80))))
+
+(deftest astral.utf-16le.roundtrip ()
+  (let ((bytes (ub8v #x3d #xd8 #x00 #xde)))            ; U+1F600 (D83D DE00) LE
+    (is (equalp (string-to-octets (octets-to-string bytes :encoding :utf-16le)
+                                  :encoding :utf-16le)
+                bytes))))
+
+(deftest astral.utf-32le.roundtrip ()
+  (let ((bytes (ub8v #x00 #xf6 #x01 #x00)))            ; U+1F600 LE
+    (is (equalp (string-to-octets (octets-to-string bytes :encoding :utf-32le)
+                                  :encoding :utf-32le)
+                bytes))))