From 83e14536ef85cee621e5357de04f233afdd7a57a Mon Sep 17 00:00:00 2001 From: "SANO,Masatoshi" Date: Tue, 30 Jun 2026 16:57:52 +0900 Subject: [PATCH] Encode/decode astral characters as surrogate pairs on UTF-16 hosts On Lisp implementations whose CHAR-CODE-LIMIT is exactly #x10000 (ABCL, and others backed by a UTF-16 string type) a string holds UTF-16 code units, so a character above the BMP is a surrogate pair (two characters). Babel's codecs work in full code-point space, but the string<->code-point bridge assumed one character per code point, so astral text was mangled: - STRING-TO-OCTETS encoded each surrogate half separately (CESU-8): e.g. U+1F600 -> ED A0 BD ED B8 80 instead of F0 9F 98 80. - OCTETS-TO-STRING handed an astral code point to CODE-CHAR; ABCL silently truncated it to 16 bits (U+1F600 -> U+F600), other UTF-16 hosts errored. Fix the bridge, leaving every codec untouched. STRING-TO-OCTETS combines surrogate pairs into a code-point vector before encoding; OCTETS-TO-STRING decodes into a code-point vector and splits astral code points back into surrogate pairs. BMP-only strings keep an unchanged fast path. Everything is gated on +UTF16-HOST-P+ ((= CHAR-CODE-LIMIT #x10000), an exact test so a non-Unicode build with CHAR-CODE-LIMIT 256 is excluded), and is dead code on UTF-32 hosts, so SBCL/CCL/etc. are unaffected. babel-streams' STREAM-WRITE-CHAR buffers a high surrogate until its low half arrives. Add host-independent astral round-trip tests (UTF-8/16/32; octets are the source of truth). Verified on ABCL 1.9.3 (UTF-16) and SBCL (UTF-32, inert). --- src/streams.lisp | 52 ++++++++++++++++--- src/strings.lisp | 132 +++++++++++++++++++++++++++++++++++++++++++---- tests/tests.lisp | 50 ++++++++++++++++++ 3 files changed, 219 insertions(+), 15 deletions(-) diff --git a/src/streams.lisp b/src/streams.lisp index a272f22..e011187 100644 --- a/src/streams.lisp +++ b/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 diff --git a/src/strings.lisp b/src/strings.lisp index 54ace22..47d96b5 100644 --- a/src/strings.lisp +++ b/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)) diff --git a/tests/tests.lisp b/tests/tests.lisp index 8cb5b66..ddb18e6 100644 --- a/tests/tests.lisp +++ b/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))))