3rdparties/software/babel-20200218-git/src/enc-unicode.lisp (42416 bytes)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; enc-unicode.lisp --- Unicode encodings. 4 ;;; 5 ;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net> 6 ;;; 7 ;;; Permission is hereby granted, free of charge, to any person 8 ;;; obtaining a copy of this software and associated documentation 9 ;;; files (the "Software"), to deal in the Software without 10 ;;; restriction, including without limitation the rights to use, copy, 11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 12 ;;; of the Software, and to permit persons to whom the Software is 13 ;;; furnished to do so, subject to the following conditions: 14 ;;; 15 ;;; The above copyright notice and this permission notice shall be 16 ;;; included in all copies or substantial portions of the Software. 17 ;;; 18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 25 ;;; DEALINGS IN THE SOFTWARE. 26 27 ;;; This implementation is largely based on OpenMCL's l1-unicode.lisp 28 ;;; Copyright (C) 2006 Clozure Associates and contributors. 29 30 (in-package #:babel-encodings) 31 32 (eval-when (:compile-toplevel :load-toplevel :execute) 33 (defconstant +repl+ #xfffd "Unicode replacement character code point.") 34 (defconstant +byte-order-mark-code+ #xfeff) 35 (defconstant +swapped-byte-order-mark-code+ #xfffe) 36 (defconstant +swapped-byte-order-mark-code-32+ #xfffe0000)) 37 38 ;;; Some convenience macros adding FIXNUM declarations. 39 (defmacro f-ash (integer count) `(the fixnum (ash ,integer ,count))) 40 (defmacro f-logior (&rest integers) `(the fixnum (logior ,@integers))) 41 (defmacro f-logand (&rest integers) `(the fixnum (logand ,@integers))) 42 (defmacro f-logxor (&rest integers) `(the fixnum (logxor ,@integers))) 43 44 ;;;; UTF-8 45 46 (define-character-encoding :utf-8 47 "An 8-bit, variable-length character encoding in which 48 character code points in the range #x00-#x7f can be encoded in a 49 single octet; characters with larger code values can be encoded 50 in 2 to 4 bytes." 51 :max-units-per-char 4 52 :literal-char-code-limit #x80 53 :bom-encoding #(#xef #xbb #xbf) 54 :default-replacement #xfffd) 55 56 (define-condition invalid-utf8-starter-byte (character-decoding-error) 57 () 58 (:documentation "Signalled when an invalid UTF-8 starter byte is found.")) 59 60 (define-condition invalid-utf8-continuation-byte (character-decoding-error) 61 () 62 (:documentation 63 "Signalled when an invalid UTF-8 continuation byte is found.")) 64 65 (define-condition overlong-utf8-sequence (character-decoding-error) 66 () 67 (:documentation "Signalled upon overlong UTF-8 sequences.")) 68 69 (define-octet-counter :utf-8 (getter type) 70 `(named-lambda utf-8-octet-counter (seq start end max) 71 (declare (type ,type seq) (fixnum start end max)) 72 (loop with noctets fixnum = 0 73 for i fixnum from start below end 74 for code of-type code-point = (,getter seq i) do 75 (let ((new (+ (cond ((< code #x80) 1) 76 ((< code #x800) 2) 77 ((< code #x10000) 3) 78 (t 4)) 79 noctets))) 80 (if (and (plusp max) (> new max)) 81 (loop-finish) 82 (setq noctets new))) 83 finally (return (values noctets i))))) 84 85 (define-code-point-counter :utf-8 (getter type) 86 `(named-lambda utf-8-code-point-counter (seq start end max) 87 (declare (type ,type seq) (fixnum start end max)) 88 (loop with nchars fixnum = 0 89 with i fixnum = start 90 while (< i end) do 91 ;; check for invalid continuation bytes 92 (macrolet ((invalid-cb-p (n) 93 `(and (< (+ i ,n) end) 94 (not (< #x7f (,',getter seq (+ i ,n)) #xc0))))) 95 ;; wrote this code with LET instead of FOR because CLISP's 96 ;; LOOP doesn't like WHILE clauses before FOR clauses. 97 (let* ((octet (,getter seq i)) 98 (next-i (+ i (cond ((or (< octet #xc0) (invalid-cb-p 1)) 1) 99 ((or (< octet #xe0) (invalid-cb-p 2)) 2) 100 ((or (< octet #xf0) (invalid-cb-p 3)) 3) 101 ((or (< octet #xf8) (invalid-cb-p 4)) 4) 102 ((or (< octet #xfc) (invalid-cb-p 5)) 5) 103 (t 6))))) 104 (declare (type ub8 octet) (fixnum next-i)) 105 (cond 106 ((> next-i end) 107 ;; Should we add restarts to this error, we'll have 108 ;; to figure out a way to communicate with the 109 ;; decoder since we probably want to do something 110 ;; about it right here when we have a chance to 111 ;; change the count or something. (Like an 112 ;; alternative replacement character or perhaps the 113 ;; existence of this error so that the decoder 114 ;; doesn't have to check for it on every iteration 115 ;; like we do.) 116 ;; 117 ;; FIXME: The data for this error is not right. 118 (decoding-error (vector octet) :utf-8 seq i 119 nil 'end-of-input-in-character) 120 (return (values (1+ nchars) end))) 121 (t 122 (setq nchars (1+ nchars) 123 i next-i) 124 (when (and (plusp max) (= nchars max)) 125 (return (values nchars i))))))) 126 finally (progn 127 (assert (= i end)) 128 (return (values nchars i)))))) 129 130 (define-encoder :utf-8 (getter src-type setter dest-type) 131 `(named-lambda utf-8-encoder (src start end dest d-start) 132 (declare (type ,src-type src) 133 (type ,dest-type dest) 134 (fixnum start end d-start)) 135 (loop with di fixnum = d-start 136 for i fixnum from start below end 137 for code of-type code-point = (,getter src i) do 138 (macrolet ((set-octet (offset value) 139 `(,',setter ,value dest (the fixnum (+ di ,offset))))) 140 (cond 141 ;; 1 octet 142 ((< code #x80) 143 (set-octet 0 code) 144 (incf di)) 145 ;; 2 octets 146 ((< code #x800) 147 (set-octet 0 (logior #xc0 (f-ash code -6))) 148 (set-octet 1 (logior #x80 (f-logand code #x3f))) 149 (incf di 2)) 150 ;; 3 octets 151 ((< code #x10000) 152 (set-octet 0 (logior #xe0 (f-ash code -12))) 153 (set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -6)))) 154 (set-octet 2 (logior #x80 (f-logand code #x3f))) 155 (incf di 3)) 156 ;; 4 octets 157 (t 158 (set-octet 0 (logior #xf0 (f-logand #x07 (f-ash code -18)))) 159 (set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -12)))) 160 (set-octet 2 (logior #x80 (f-logand #x3f (f-ash code -6)))) 161 (set-octet 3 (logior #x80 (logand code #x3f))) 162 (incf di 4)))) 163 finally (return (the fixnum (- di d-start)))))) 164 165 (define-decoder :utf-8 (getter src-type setter dest-type) 166 `(named-lambda utf-8-decoder (src start end dest d-start) 167 (declare (type ,src-type src) 168 (type ,dest-type dest) 169 (fixnum start end d-start)) 170 (let ((u2 0) (u3 0) (u4 0) (u5 0) (u6 0)) 171 (declare (type ub8 u2 u3 u4 u5 u6)) 172 (loop for di fixnum from d-start 173 for i fixnum from start below end 174 for u1 of-type ub8 = (,getter src i) do 175 ;; Note: CONSUME-OCTET doesn't check if I is being 176 ;; incremented past END. We're assuming that END has 177 ;; been calculated with the CODE-POINT-POINTER above that 178 ;; checks this. 179 (macrolet 180 ((consume-octet () 181 `(let ((next-i (incf i))) 182 (if (= next-i end) 183 ;; FIXME: data for this error is incomplete. 184 ;; and signalling this error twice 185 (return-from setter-block 186 (decoding-error nil :utf-8 src i +repl+ 187 'end-of-input-in-character)) 188 (,',getter src next-i)))) 189 (handle-error (n &optional (c 'character-decoding-error)) 190 `(decoding-error 191 (vector ,@(subseq '(u1 u2 u3 u4 u5 u6) 0 n)) 192 :utf-8 src (1+ (- i ,n)) +repl+ ',c)) 193 (handle-error-if-icb (var n) 194 `(when (not (< #x7f ,var #xc0)) 195 (decf i) 196 (return-from setter-block 197 (handle-error ,n invalid-utf8-continuation-byte))))) 198 (,setter 199 (block setter-block 200 (cond 201 ((< u1 #x80) u1) ; 1 octet 202 ((< u1 #xc0) 203 (handle-error 1 invalid-utf8-starter-byte)) 204 (t 205 (setq u2 (consume-octet)) 206 (handle-error-if-icb u2 1) 207 (cond 208 ((< u1 #xc2) 209 (handle-error 2 overlong-utf8-sequence)) 210 ((< u1 #xe0) ; 2 octets 211 (logior (f-ash (f-logand #x1f u1) 6) 212 (f-logxor u2 #x80))) 213 (t 214 (setq u3 (consume-octet)) 215 (handle-error-if-icb u3 2) 216 (cond 217 ((and (= u1 #xe0) (< u2 #xa0)) 218 (handle-error 3 overlong-utf8-sequence)) 219 ((< u1 #xf0) ; 3 octets 220 (let ((start (f-logior (f-ash (f-logand u1 #x0f) 12) 221 (f-ash (f-logand u2 #x3f) 6)))) 222 (if (<= #xd800 start #xdfc0) 223 (handle-error 3 character-out-of-range) 224 (logior start (f-logand u3 #x3f))))) 225 (t ; 4 octets 226 (setq u4 (consume-octet)) 227 (handle-error-if-icb u4 3) 228 (cond 229 ((and (= u1 #xf0) (< u2 #x90)) 230 (handle-error 4 overlong-utf8-sequence)) 231 ((< u1 #xf8) 232 (if (or (> u1 #xf4) (and (= u1 #xf4) (> u2 #x8f))) 233 (handle-error 4 character-out-of-range) 234 (f-logior (f-ash (f-logand u1 7) 18) 235 (f-ash (f-logxor u2 #x80) 12) 236 (f-ash (f-logxor u3 #x80) 6) 237 (f-logxor u4 #x80)))) 238 ;; from here on we'll be getting either 239 ;; invalid continuation bytes or overlong 240 ;; 5-byte or 6-byte sequences. 241 (t 242 (setq u5 (consume-octet)) 243 (handle-error-if-icb u5 4) 244 (cond 245 ((and (= u1 #xf8) (< u2 #x88)) 246 (handle-error 5 overlong-utf8-sequence)) 247 ((< u1 #xfc) 248 (handle-error 5 character-out-of-range)) 249 (t 250 (setq u6 (consume-octet)) 251 (handle-error-if-icb u6 5) 252 (cond 253 ((and (= u1 #xfc) (< u2 #x84)) 254 (handle-error 6 overlong-utf8-sequence)) 255 (t 256 (handle-error 6 character-out-of-range) 257 ))))))))))))) 258 dest di)) 259 finally (return (the fixnum (- di d-start))))))) 260 261 ;;;; UTF-8B 262 263 ;;; The following excerpt from a linux-utf8 message by Markus Kuhn is 264 ;;; the closest thing to a UTF-8B specification: 265 ;;; 266 ;;; <http://mail.nl.linux.org/linux-utf8/2000-07/msg00040.html> 267 ;;; 268 ;;; "D) Emit a malformed UTF-16 sequence for every byte in a malformed 269 ;;; UTF-8 sequence 270 ;;; 271 ;;; All the previous options for converting malformed UTF-8 sequences 272 ;;; to UTF-16 destroy information. This can be highly undesirable in 273 ;;; applications such as text file editors, where guaranteed binary 274 ;;; transparency is a desireable feature. (E.g., I frequently edit 275 ;;; executable code or graphic files with the Emacs text editor and I 276 ;;; hate the idea that my editor might automatically make U+FFFD 277 ;;; substitutions at locations that I haven't even edited when I save 278 ;;; the file again.) 279 ;;; 280 ;;; I therefore suggested 1999-11-02 on the unicode@xxxxxxxxxxx 281 ;;; mailing list the following approach. Instead of using U+FFFD, 282 ;;; simply encode malformed UTF-8 sequences as malformed UTF-16 283 ;;; sequences. Malformed UTF-8 sequences consist excludively of the 284 ;;; bytes 0x80 - 0xff, and each of these bytes can be represented 285 ;;; using a 16-bit value from the UTF-16 low-half surrogate zone 286 ;;; U+DC80 to U+DCFF. Thus, the overlong "K" (U+004B) 0xc1 0x8b from 287 ;;; the above example would be represented in UTF-16 as U+DCC1 288 ;;; U+DC8B. If we simply make sure that every UTF-8 encoded surrogate 289 ;;; character is also treated like a malformed sequence, then there 290 ;;; is no way that a single high-half surrogate could precede the 291 ;;; encoded malformed sequence and cause a valid UTF-16 sequence to 292 ;;; emerge. 293 ;;; 294 ;;; This way 100% binary transparent UTF-8 -> UTF-16 -> UTF-8 295 ;;; round-trip compatibility can be achieved quite easily. 296 ;;; 297 ;;; On an output device, a lonely low-half surrogate character should 298 ;;; be treated just like a character outside the adopted subset of 299 ;;; representable characters, that is for the end user, the display 300 ;;; would look exactly like with semantics B), i.e. one symbol per 301 ;;; byte of a malformed sequence. However in contrast to semantics 302 ;;; B), no information is thrown away, and a cut&paste in an editor 303 ;;; or terminal emulator will be guaranteed to reconstruct the 304 ;;; original byte sequence. This should greatly reduce the incidence 305 ;;; of accidental corruption of binary data by UTF-8 -> UTF-16 -> 306 ;;; UTF-8 conversion round trips." 307 308 (define-character-encoding :utf-8b 309 "An 8-bit, variable-length character encoding in which 310 character code points in the range #x00-#x7f can be encoded in a 311 single octet; characters with larger code values can be encoded 312 in 2 to 4 bytes. Invalid UTF-8 sequences are encoded with #xDCXX 313 code points for each invalid byte." 314 :max-units-per-char 4 315 :literal-char-code-limit #x80 316 :bom-encoding #(#xef #xbb #xbf) 317 :default-replacement nil) 318 319 ;;; TODO: reuse the :UTF-8 octet counter through a simple macro. 320 (define-octet-counter :utf-8b (getter type) 321 `(named-lambda utf-8b-octet-counter (seq start end max) 322 (declare (type ,type seq) (fixnum start end max)) 323 (loop with noctets fixnum = 0 324 for i fixnum from start below end 325 for code of-type code-point = (,getter seq i) do 326 (let ((new (+ (cond ((< code #x80) 1) 327 ((< code #x800) 2) 328 ((<= #xdc80 code #xdcff) 1) 329 ((< code #x10000) 3) 330 (t 4)) 331 noctets))) 332 (if (and (plusp max) (> new max)) 333 (loop-finish) 334 (setq noctets new))) 335 finally (return (values noctets i))))) 336 337 (define-code-point-counter :utf-8b (getter type) 338 `(named-lambda utf-8b-code-point-counter (seq start end max) 339 (declare (type ,type seq) (fixnum start end max)) 340 (loop with nchars fixnum = 0 341 with i fixnum = start 342 while (< i end) do 343 ;; wrote this code with LET instead of FOR because CLISP's 344 ;; LOOP doesn't like WHILE clauses before FOR clauses. 345 (let* ((octet (,getter seq i)) 346 (noctets (cond ((< octet #x80) 1) 347 ((< octet #xe0) 2) 348 ((< octet #xf0) 3) 349 (t 4)))) 350 (declare (type ub8 octet) (fixnum noctets)) 351 (cond 352 ((> (+ i noctets) end) 353 ;; If this error is suppressed these last few bytes 354 ;; will be encoded as raw bytes later. 355 (decoding-error (vector octet) :utf-8 seq i 356 nil 'end-of-input-in-character) 357 (return (values (+ nchars (- end i)) end))) 358 (t 359 ;; FIXME: clean this mess up. 360 (let* ((u1 octet) 361 (u2 (if (>= noctets 2) (,getter seq (1+ i)) 0)) 362 (u3 (if (>= noctets 3) (,getter seq (+ i 2)) 0)) 363 (u4 (if (= noctets 4) (,getter seq (+ i 3)) 0)) 364 (inc (or (and (> noctets 1) 365 (< u1 #xc2)) 366 (and (= noctets 2) 367 (not (logior u2 #x40))) 368 (and (= noctets 3) 369 (not (and (< (f-logxor u2 #x80) #x40) 370 (< (f-logxor u3 #x80) #x40) 371 (or (>= u1 #xe1) (>= u2 #xa0)) 372 (or (/= u1 #xed) (< u2 #xa0) (> u2 #xbf))))) 373 (and (= noctets 4) 374 (not 375 (and (< (f-logxor u2 #x80) #x40) 376 (< (f-logxor u3 #x80) #x40) 377 (< (f-logxor u4 #x80) #x40) 378 (or (>= u1 #xf1) (>= u2 #x90)))))))) 379 (let ((new-nchars (if inc (+ nchars noctets) (1+ nchars)))) 380 (when (and (plusp max) (> new-nchars max)) 381 (return (values nchars i))) 382 (incf i noctets) 383 (setq nchars new-nchars)))))) 384 finally (progn 385 (assert (= i end)) 386 (return (values nchars i)))))) 387 388 ;;; TODO: reuse the :UTF-8 encoder with through a simple macro. 389 (define-encoder :utf-8b (getter src-type setter dest-type) 390 `(named-lambda utf-8b-encoder (src start end dest d-start) 391 (declare (type ,src-type src) 392 (type ,dest-type dest) 393 (fixnum start end d-start)) 394 (loop with di fixnum = d-start 395 for i fixnum from start below end 396 for code of-type code-point = (,getter src i) do 397 (macrolet ((set-octet (offset value) 398 `(,',setter ,value dest (the fixnum (+ di ,offset))))) 399 (cond 400 ;; 1 octet 401 ((< code #x80) 402 (set-octet 0 code) 403 (incf di)) 404 ;; 2 octets 405 ((< code #x800) 406 (set-octet 0 (logior #xc0 (f-ash code -6))) 407 (set-octet 1 (logior #x80 (f-logand code #x3f))) 408 (incf di 2)) 409 ;; 1 octet (invalid octet) 410 ((<= #xdc80 code #xdcff) 411 (set-octet 0 (f-logand code #xff)) 412 (incf di)) 413 ;; 3 octets 414 ((< code #x10000) 415 (set-octet 0 (logior #xe0 (f-ash code -12))) 416 (set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -6)))) 417 (set-octet 2 (logior #x80 (f-logand code #x3f))) 418 (incf di 3)) 419 ;; 4 octets 420 (t 421 (set-octet 0 (logior #xf0 (f-logand #x07 (f-ash code -18)))) 422 (set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -12)))) 423 (set-octet 2 (logior #x80 (f-logand #x3f (f-ash code -6)))) 424 (set-octet 3 (logand #x3f code)) 425 (incf di 4)))) 426 finally (return (the fixnum (- di d-start)))))) 427 428 (define-decoder :utf-8b (getter src-type setter dest-type) 429 `(named-lambda utf-8b-decoder (src start end dest d-start) 430 (declare (type ,src-type src) 431 (type ,dest-type dest) 432 (fixnum start end d-start)) 433 (let ((u2 0) (u3 0) (u4 0)) 434 (declare (type ub8 u2 u3 u4)) 435 (loop for di fixnum from d-start 436 for i fixnum from start below end 437 for u1 of-type ub8 = (,getter src i) do 438 ;; Unlike the UTF-8 version, this version of 439 ;; CONSUME-OCTET needs to check if I is being incremented 440 ;; past END because we might have trailing binary 441 ;; garbage. 442 (macrolet 443 ((consume-octet (n) 444 `(if (= i (1- end)) 445 (encode-raw-octets ,n) 446 (,',getter src (incf i)))) 447 (encode-raw-octets (n) 448 `(progn 449 ,@(loop for i below n and var in '(u1 u2 u3 u4) 450 collect `(,',setter (logior #xdc00 ,var) dest di) 451 unless (= i (1- n)) 452 collect '(incf di)) 453 (return-from set-body)))) 454 (block set-body 455 (,setter (cond 456 ((< u1 #x80) ; 1 octet 457 u1) 458 ((>= u1 #xc2) 459 (setq u2 (consume-octet 1)) 460 (cond 461 ((< u1 #xe0) ; 2 octets 462 (if (< (f-logxor u2 #x80) #x40) 463 (logior (f-ash (f-logand #x1f u1) 6) 464 (f-logxor u2 #x80)) 465 (encode-raw-octets 2))) 466 (t 467 (setq u3 (consume-octet 2)) 468 (cond 469 ((< u1 #xf0) ; 3 octets 470 (if (and (< (f-logxor u2 #x80) #x40) 471 (< (f-logxor u3 #x80) #x40) 472 (or (>= u1 #xe1) (>= u2 #xa0))) 473 (let ((start (f-logior (f-ash (f-logand u1 #x0f) 12) 474 (f-ash (f-logand u2 #x3f) 6)))) 475 (if (<= #xd800 start #xdfc0) 476 (encode-raw-octets 3) 477 (logior start (f-logand u3 #x3f)))) 478 (encode-raw-octets 3))) 479 (t ; 4 octets 480 (setq u4 (consume-octet 3)) 481 (if (and (< (f-logxor u2 #x80) #x40) 482 (< (f-logxor u3 #x80) #x40) 483 (< (f-logxor u4 #x80) #x40) 484 (or (>= u1 #xf1) (>= u2 #x90))) 485 (logior 486 (f-logior (f-ash (f-logand u1 7) 18) 487 (f-ash (f-logxor u2 #x80) 12)) 488 (f-logior (f-ash (f-logxor u3 #x80) 6) 489 (f-logxor u4 #x80))) 490 (encode-raw-octets 4))))))) 491 (t (encode-raw-octets 1))) 492 dest di))) 493 finally (return (the fixnum (- di d-start))))))) 494 495 ;;;; UTF-16 496 497 ;;; TODO: add a way to pass some info at compile-time telling us that, 498 ;;; for example, the maximum code-point will always be < #x10000 in 499 ;;; which case we could simply return (* 2 (- end start)). 500 (defmacro utf16-octet-counter (getter type) 501 `(named-lambda utf-16-octet-counter (seq start end max) 502 (declare (type ,type seq) (fixnum start end max)) 503 (loop with noctets fixnum = 0 504 for i fixnum from start below end 505 for code of-type code-point = (,getter seq i) 506 do (let ((new (the fixnum (+ (if (< code #x10000) 2 4) noctets)))) 507 (if (and (plusp max) (> new max)) 508 (loop-finish) 509 (setq noctets new))) 510 finally (return (values noctets i))))) 511 512 (defmacro utf-16-combine-surrogate-pairs (u1 u2) 513 `(the (unsigned-byte 21) 514 (+ #x10000 515 (the (unsigned-byte 20) 516 (logior 517 (the (unsigned-byte 20) 518 (ash (the (unsigned-byte 10) (- ,u1 #xd800)) 10)) 519 (the (unsigned-byte 10) 520 (- ,u2 #xdc00))))))) 521 522 (defmacro define-utf-16 (name &optional endianness) 523 (check-type endianness (or null (eql :be) (eql :le))) 524 (check-type name keyword) 525 (let ((swap-var (gensym "SWAP")) 526 (code-point-counter-name 527 (format-symbol t '#:~a-code-point-counter (string name))) 528 (encoder-name (format-symbol t '#:~a-encoder (string name))) 529 (decoder-name (format-symbol t '#:~a-decoder (string name)))) 530 (labels ((make-bom-check-form (end start getter seq) 531 (if (null endianness) 532 ``((,',swap-var 533 (when (> ,,end ,,start) 534 (case (,,getter ,,seq ,,start 2 :ne) 535 (#.+byte-order-mark-code+ (incf ,,start 2) nil) 536 (#.+swapped-byte-order-mark-code+ (incf ,,start 2) t) 537 (t #+little-endian t))))) 538 '())) 539 (make-getter-form (getter src i) 540 (case endianness 541 (:le ``(,,getter ,,src ,,i 2 :le)) 542 (:be ``(,,getter ,,src ,,i 2 :be)) 543 (t ``(if ,',swap-var 544 (,,getter ,,src ,,i 2 :re) 545 (,,getter ,,src ,,i 2 :ne))))) 546 (make-setter-form (setter code dest di) 547 (case endianness 548 (:be ``(,,setter ,,code ,,dest ,,di 2 :be)) 549 (:le ``(,,setter ,,code ,,dest ,,di 2 :le)) 550 (t ``(,,setter ,,code ,,dest ,,di 2 :ne))))) 551 `(progn 552 (define-octet-counter ,name (getter type) 553 `(utf16-octet-counter ,getter ,type)) 554 (define-code-point-counter ,name (getter type) 555 `(named-lambda ,',code-point-counter-name (seq start end max) 556 (declare (type ,type seq) (fixnum start end max)) 557 (let* ,,(make-bom-check-form ''end ''start 'getter ''seq) 558 (loop with count fixnum = 0 559 with i fixnum = start 560 while (<= i (- end 2)) do 561 (let* ((code ,,(make-getter-form 'getter ''seq ''i)) 562 (next-i (+ i (if (or (< code #xd800) (>= code #xdc00)) 563 2 564 4)))) 565 (declare (type (unsigned-byte 16) code) (fixnum next-i)) 566 (cond 567 ((> next-i end) 568 (decoding-error 569 (vector (,getter seq i) (,getter seq (1+ i))) 570 ,',name seq i nil 'end-of-input-in-character) 571 (return (values count i))) 572 (t 573 (setq i next-i 574 count (1+ count)) 575 (when (and (plusp max) (= count max)) 576 (return (values count i)))))) 577 finally (progn 578 (assert (= i end)) 579 (return (values count i))))))) 580 (define-encoder ,name (getter src-type setter dest-type) 581 `(named-lambda ,',encoder-name (src start end dest d-start) 582 (declare (type ,src-type src) 583 (type ,dest-type dest) 584 (fixnum start end d-start)) 585 (loop with di fixnum = d-start 586 for i fixnum from start below end 587 for code of-type code-point = (,getter src i) 588 for high-bits fixnum = (- code #x10000) do 589 (cond ((< high-bits 0) 590 ,,(make-setter-form 'setter ''code ''dest ''di) 591 (incf di 2)) 592 (t 593 ,,(make-setter-form 594 'setter ''(logior #xd800 (f-ash high-bits -10)) 595 ''dest ''di) 596 ,,(make-setter-form 597 'setter ''(logior #xdc00 (f-logand high-bits #x3ff)) 598 ''dest ''(+ di 2)) 599 (incf di 4))) 600 finally (return (the fixnum (- di d-start)))))) 601 (define-decoder ,name (getter src-type setter dest-type) 602 `(named-lambda ,',decoder-name (src start end dest d-start) 603 (declare (type ,src-type src) 604 (type ,dest-type dest) 605 (fixnum start end d-start)) 606 (let ,,(make-bom-check-form ''end ''start 'getter ''src) 607 (loop with i fixnum = start 608 for di fixnum from d-start 609 until (= i end) do 610 (let ((u1 ,,(make-getter-form 'getter ''src ''i))) 611 (declare (type (unsigned-byte 16) u1)) 612 (incf i 2) 613 (,setter (cond 614 ((or (< u1 #xd800) (>= u1 #xe000)) ; 2 octets 615 u1) 616 ((< u1 #xdc00) ; 4 octets 617 (let ((u2 ,,(make-getter-form 'getter ''src ''i))) 618 (declare (type (unsigned-byte 16) u2)) 619 (incf i 2) 620 (if (and (>= u2 #xdc00) (< u2 #xe000)) 621 (utf-16-combine-surrogate-pairs u1 u2) 622 (decoding-error 623 (vector (,getter src (- i 4)) 624 (,getter src (- i 3)) 625 (,getter src (- i 2)) 626 (,getter src (- i 1))) 627 ,',name src i +repl+)))) 628 (t 629 (decoding-error (vector (,getter src (- i 2)) 630 (,getter src (- i 1))) 631 ,',name src i +repl+))) 632 dest di)) 633 finally (return (the fixnum (- di d-start))))))) 634 ',name)))) 635 636 (define-character-encoding :utf-16 637 "A 16-bit, variable-length encoding in which characters with 638 code points less than #x10000 can be encoded in a single 16-bit 639 word and characters with larger codes can be encoded in a pair of 640 16-bit words. The endianness of the encoded data is indicated by 641 the endianness of a byte-order-mark character (#\u+feff) 642 prepended to the data; in the absence of such a character on 643 input, the data is assumed to be in big-endian order. Output is 644 written in native byte-order with a leading byte-order mark." 645 :max-units-per-char 2 646 :code-unit-size 16 647 :native-endianness t ; not necessarily true when decoding 648 :decode-literal-code-unit-limit #xd800 649 :encode-literal-code-unit-limit #x10000 650 :use-bom #+big-endian :utf-16be #+little-endian :utf-16le 651 :bom-encoding #+big-endian #(#xfe #xff) #+little-endian #(#xff #xfe) 652 :nul-encoding #(0 0) 653 :default-replacement #xfffd 654 :ambiguous #+little-endian t #+big-endian nil) 655 656 (define-utf-16 :utf-16) 657 658 (define-character-encoding :utf-16le 659 "A 16-bit, variable-length encoding in which characters with 660 code points less than #x10000 can be encoded in a single 16-bit 661 word and characters with larger codes can be encoded in a pair of 662 16-bit words. The data is assumed to be in little-endian order. Output is 663 written in little-endian byte-order without a leading byte-order mark." 664 :aliases '(:utf-16/le) 665 :max-units-per-char 2 666 :code-unit-size 16 667 :native-endianness #+little-endian t #+big-endian nil 668 :decode-literal-code-unit-limit #xd800 669 :encode-literal-code-unit-limit #x10000 670 :nul-encoding #(0 0) 671 :default-replacement #xfffd) 672 673 (define-utf-16 :utf-16le :le) 674 675 (define-character-encoding :utf-16be 676 "A 16-bit, variable-length encoding in which characters with 677 code points less than #x10000 can be encoded in a single 16-bit 678 word and characters with larger codes can be encoded in a pair of 679 16-bit words. The data is assumed to be in big-endian order. Output is 680 written in big-endian byte-order without a leading byte-order mark." 681 :aliases '(:utf-16/be) 682 :max-units-per-char 2 683 :code-unit-size 16 684 :native-endianness #+little-endian nil #+big-endian t 685 :decode-literal-code-unit-limit #xd800 686 :encode-literal-code-unit-limit #x10000 687 :nul-encoding #(0 0) 688 :default-replacement #xfffd) 689 690 (define-utf-16 :utf-16be :be) 691 692 (defmacro define-ucs (name bytes &optional endianness (limit #x110000)) 693 (check-type name keyword) 694 (check-type bytes (or (eql 2) (eql 4))) 695 (check-type endianness (or null (eql :le) (eql :be))) 696 (let ((swap-var (gensym "SWAP")) 697 (code-point-counter-name 698 (format-symbol t '#:~a-code-point-counter (string name))) 699 (encoder-name 700 (format-symbol t '#:~a-encoder (string name))) 701 (decoder-name 702 (format-symbol t '#:~a-decoder (string name)))) 703 (labels ((make-bom-check-form (end start getter src) 704 (if (null endianness) 705 ``(when (not (zerop (- ,,end ,,start))) 706 (case (,,getter ,,src 0 ,',bytes :ne) 707 (#.+byte-order-mark-code+ 708 (incf ,,start ,',bytes) nil) 709 (#.+swapped-byte-order-mark-code-32+ 710 (incf ,,start ,',bytes) t) 711 (t #+little-endian t))) 712 '())) 713 (make-setter-form (setter code dest di) 714 ``(,,setter ,,code ,,dest ,,di ,',bytes 715 ,',(or endianness :ne))) 716 (make-getter-form (getter src i) 717 (if (null endianness) 718 ``(if ,',swap-var 719 (,,getter ,,src ,,i ,',bytes :re) 720 (,,getter ,,src ,,i ,',bytes :ne)) 721 ``(,,getter ,,src ,,i ,',bytes ,',endianness)))) 722 `(progn 723 (define-code-point-counter ,name (getter type) 724 `(named-lambda ,',code-point-counter-name (seq start end max) 725 (declare (type ,type seq) (fixnum start end max)) 726 ;; check for bom 727 ,,(make-bom-check-form ''end ''start 'getter ''seq) 728 (multiple-value-bind (count rem) 729 (floor (- end start) ,',bytes) 730 (cond 731 ((and (plusp max) (> count max)) 732 (values max (the fixnum (+ start (* ,',bytes max))))) 733 (t 734 ;; check for incomplete last character 735 (unless (zerop rem) 736 (let ((vector (make-array ,',bytes :fill-pointer 0))) 737 (dotimes (i rem) 738 (vector-push (,getter seq (+ i (- end rem))) vector)) 739 (decoding-error vector ,',name seq (the fixnum (- end rem)) nil 740 'end-of-input-in-character) 741 (decf end rem))) 742 (values count end)))))) 743 (define-encoder ,name (getter src-type setter dest-type) 744 `(named-lambda ,',encoder-name (src start end dest d-start) 745 (declare (type ,src-type src) 746 (type ,dest-type dest) 747 (fixnum start end d-start)) 748 (loop for i fixnum from start below end 749 and di fixnum from d-start by ,',bytes 750 for code of-type code-point = (,getter src i) 751 do (if (>= code ,',limit) 752 (encoding-error code ,',name src i +repl+) 753 ,,(make-setter-form 'setter ''code ''dest ''di)) 754 finally (return (the fixnum (- di d-start)))))) 755 (define-decoder ,name (getter src-type setter dest-type) 756 `(named-lambda ,',decoder-name (src start end dest d-start) 757 (declare (type ,src-type src) 758 (type ,dest-type dest) 759 (fixnum start end d-start)) 760 (let ((,',swap-var ,,(make-bom-check-form ''end ''start 'getter ''src))) 761 (declare (ignorable ,',swap-var)) 762 (loop for i fixnum from start below end by ,',bytes 763 and di from d-start 764 do (,setter (let ((unit ,,(make-getter-form 'getter ''src ''i))) 765 (if (>= unit ,',limit) 766 (decoding-error 767 (vector (,getter src i) 768 (,getter src (+ i 1)) 769 ,@,(if (= bytes 4) 770 ``((,getter src (+ i 2)) 771 (,getter src (+ i 3))))) 772 ,',name src i +repl+ 773 'character-out-of-range) 774 unit)) 775 dest di) 776 finally (return (the fixnum (- di d-start))))))) 777 ',name)))) 778 779 ;;;; UTF-32 780 781 (define-character-encoding :utf-32 782 "A 32-bit, fixed-length encoding in which all Unicode 783 characters can be encoded in a single 32-bit word. The 784 endianness of the encoded data is indicated by the endianness of 785 a byte-order-mark character (#\u+feff) prepended to the data; in 786 the absence of such a character on input, input data is assumed 787 to be in big-endian order. Output is written in native byte 788 order with a leading byte-order mark." 789 :aliases '(:ucs-4) 790 :max-units-per-char 1 791 :code-unit-size 32 792 :native-endianness t ; not necessarily true when decoding 793 :literal-char-code-limit #x110000 794 :use-bom #+little-endian :utf-32le #+big-endian :utf-32be 795 :bom-encoding 796 #+big-endian #(#x00 #x00 #xfe #xff) 797 #+little-endian #(#xff #xfe #x00 #x00) 798 :nul-encoding #(0 0 0 0) 799 :ambiguous #+little-endian t #+big-endian nil) 800 801 (define-ucs :utf-32 4) 802 803 (define-character-encoding :utf-32le 804 "A 32-bit, fixed-length encoding in which all Unicode 805 characters can be encoded in a single 32-bit word. Input data is assumed 806 to be in little-endian order. Output is also written in little-endian byte 807 order without a leading byte-order mark." 808 :max-units-per-char 1 809 :code-unit-size 32 810 :aliases '(:utf-32/le :ucs-4le :ucs-4/le) 811 :native-endianness #+little-endian t #+big-endian nil 812 :literal-char-code-limit #x110000 813 :nul-encoding #(0 0 0 0)) 814 815 (define-ucs :utf-32le 4 :le) 816 817 (define-character-encoding :utf-32be 818 "A 32-bit, fixed-length encoding in which all Unicode 819 characters can be encoded in a single 32-bit word. Input data is assumed 820 to be in big-endian order. Output is also written in big-endian byte 821 order without a leading byte-order mark." 822 :max-units-per-char 1 823 :code-unit-size 32 824 :aliases '(:utf-32/be :ucs-4be :ucs-4/be) 825 :native-endianness #+little-endian nil #+big-endian t 826 :literal-char-code-limit #x110000 827 :nul-encoding #(0 0 0 0)) 828 829 (define-ucs :utf-32be 4 :be) 830 831 ;; UCS-2 832 833 (define-character-encoding :ucs-2 834 "A 16-bit, fixed-length encoding in which all Unicode 835 characters can be encoded in a single 16-bit word. The 836 endianness of the encoded data is indicated by the endianness of 837 a byte-order-mark character (#\u+feff) prepended to the data; in 838 the absence of such a character on input, input data is assumed 839 to be in big-endian order. Output is written in native byte 840 order with a leading byte-order mark." 841 :aliases '(:ucs-2) 842 :max-units-per-char 1 843 :code-unit-size 16 844 :native-endianness t ; not necessarily true when decoding 845 :literal-char-code-limit #x10000 846 :use-bom #+little-endian :ucs-2le #+big-endian :ucs-2be 847 :bom-encoding 848 #+big-endian #(#xfe #xff) 849 #+little-endian #(#xff #xfe) 850 :nul-encoding #(0 0) 851 :ambiguous #+little-endian t #+big-endian nil) 852 853 (define-ucs :ucs-2 2 nil #x10000) 854 855 (define-character-encoding :ucs-2le 856 "A 16-bit, fixed-length encoding in which all Unicode 857 characters can be encoded in a single 16-bit word. Input data is assumed 858 to be in little-endian order. Output is also written in little-endian byte 859 order without a leading byte-order mark." 860 :max-units-per-char 1 861 :code-unit-size 16 862 :aliases '(:ucs-2/le) 863 :native-endianness #+little-endian t #+big-endian nil 864 :literal-char-code-limit #x10000 865 :nul-encoding #(0 0)) 866 867 (define-ucs :ucs-2le 2 :le #x10000) 868 869 (define-character-encoding :ucs-2be 870 "A 16-bit, fixed-length encoding in which all Unicode 871 characters can be encoded in a single 16-bit word. Input data is assumed 872 to be in big-endian order. Output is also written in big-endian byte 873 order without a leading byte-order mark." 874 :max-units-per-char 1 875 :code-unit-size 16 876 :aliases '(:ucs-2/be) 877 :native-endianness #+little-endian nil #+big-endian t 878 :literal-char-code-limit #x10000 879 :nul-encoding #(0 0)) 880 881 (define-ucs :ucs-2be 2 :be #x10000)