source: trunk/source/level-1/l1-unicode.lisp

Last change on this file was 16798, checked in by svspire, 3 years ago

Fixed typo

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 177.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;; Copyright 2006-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17
18;;; Unicode translation stuff, mostly in support of I/O.
19
20(in-package "CCL")
21
22
23(defvar *character-encodings* (make-hash-table :test #'eq))
24
25(defun lookup-character-encoding (name)
26  (gethash name *character-encodings*))
27
28(defun get-character-encoding (name)
29  (or (lookup-character-encoding name)
30      (error "Unknown character encoding: ~s." name)))
31
32(defun (setf get-character-encoding) (new name)
33  (setf (gethash name *character-encodings*) new))
34
35(defun ensure-character-encoding (thing)
36  (if (typep thing 'character-encoding)
37    thing
38    (or (lookup-character-encoding thing)
39        (error "~s is not a character-encoding or the name of a character-encoding."
40               thing))))
41
42
43(defun character-encoded-in-single-octet (c)
44  (declare (ignore c))
45  1)
46
47(defstruct character-encoding
48  (name ())                             ;canonical name
49  (code-unit-size 8)                    ;in bits: 8, 16, 32
50  (native-endianness t)                 ;if nil, need to swap 16,32-bit units
51  (max-units-per-char 1)                ;usually 1-4
52
53  ;; Writes CHAR (or a replacement character if CHAR can't be encoded)
54  ;; to STREAM and returns the number of code-units written.
55  stream-encode-function                ;(CHAR WRITE-FUNCTION STREAM)
56 
57  ;; Returns a charcter (possibly #\Replacement_Character) or :EOF.
58  stream-decode-function                ;(1ST-UNIT NEXT-UNIT STREAM)
59
60  ;; Sets 1 or more units in a vector argument and returns a value 1
61  ;; greater than the index of the last octet written to the vector
62  vector-encode-function                ;(STRING VECTOR INDEX START END)
63 
64  ;; Returns a value 1 greater than the last octet index consumed from
65  ;; the vector argument.
66  vector-decode-function                ;(VECTOR INDEX NOCTETS STRING)
67 
68  ;; Sets one or more units in memory at the address denoted by
69  ;; the pointer and index arguments and returns (+ idx number of
70  ;; units written to memory), else returns NIL if any character
71  ;; can't be encoded.
72  memory-encode-function                ;(STRING POINTER INDEX START END)
73
74 
75  ;; Returns (as multiple values) the  string encoded in memory
76  ;; at the address denoted by the address and index args and the
77  ;; sum of the index arg and the number of octets consumed.
78  memory-decode-function                ;(POINTER NOCTETS INDEX STRING)
79 
80  ;; Returns the number of octets needed to encode STRING between START and END
81  octets-in-string-function              ;(STRING START END)
82
83  ;; Returns the number of (full) characters encoded in VECTOR, and
84  ;; the index of the first octet not used to encode
85  ;; them. (The second value may be less than END.
86  length-of-vector-encoding-function    ;(VECTOR START END)
87
88  ;; Returns the number of (full) characters encoded in memory at (+ POINTER START)
89  ;; and the number of octets used to encode them.  (The second value may be less
90  ;; than NOCTETS.)
91  length-of-memory-encoding-function    ;(POINTER NOCTETS START)
92
93  ;; Code units less than this value map to themselves on input.
94  (decode-literal-code-unit-limit 0)
95
96  ;; Does a byte-order-mark determine the endianness of input ?
97  ;; Should we prepend a BOM to output ?
98  ;; If non-nil, the value should be the name of the an encoding
99  ;; that implements this encoding with swapped byte order.
100  (use-byte-order-mark nil)
101  ;; What alternate line-termination conventions can be encoded ?  (This basically
102  ;; means "can #\Line_Separator be encoded?", since :CR and :CRLF can always
103  ;; be encoded.)
104  (alternate-line-termination-conventions '(:cr :crlf))
105  ;; By what other MIME names is this encoding known ?
106  (aliases nil)
107  (documentation nil)
108  ;; What does a native byte-order-mark look like (as a sequence of octets)
109  ;; in this encoding ? (NIL if a BOM can't be encoded.)
110  (bom-encoding nil)
111  ;; How is #\NUL encoded, as a sequence of octets ?  (Typically, as a minimal-
112  ;; length sequenve of 0s, but there are exceptions.)
113  (nul-encoding #(0))
114  ;; Char-codes less than  this value map to themselves on output.
115  (encode-literal-char-code-limit 0)
116  (character-size-in-octets-function 'character-encoded-in-single-octet)
117  )
118
119(defconstant byte-order-mark #\u+feff)
120(defconstant byte-order-mark-char-code (char-code byte-order-mark))
121(defconstant swapped-byte-order-mark-char-code #xfffe)
122
123;;; Map 30-bit integers to 30-bit integers, using binary search.
124;;; This is mostly to avoid using hash tables with integer key/value
125;;; pairs and to avoid the GC impact of using such hash tables.
126(defstruct pv-map
127  keys
128  values)
129
130
131
132(defun %pv-map-lookup (code keys values)
133  (declare (type (signed-byte 30) code)
134           (type (simple-array (signed-byte 30) (*)) keys values)
135           (optimize (speed 3) (safety 0)))
136  (let* ((right (length keys))
137         (left 0)
138         (mid (ash right -1)))
139    (declare (fixnum left right mid))
140    (loop
141      (if (>= left right)
142        (return)
143        (let* ((val (aref keys mid)))
144          (declare (type (signed-byte 30) val))
145          (if (= val code)
146            (return (aref values mid))
147            (progn
148              (if (< val code)
149                (setq left (1+ mid))
150                (setq right mid))
151              (setq mid (+ left (the fixnum (ash (the fixnum (- right left)) -1)))))))))))
152
153(defun pv-map-lookup (code map)
154  (%pv-map-lookup code (pv-map-keys map) (pv-map-values map)))
155
156
157(defun pv-map-vectors (alist reverse-mapping)
158  #-cross-compiling
159  (dolist (pair alist)
160    (unless (and (consp pair)
161                 (typep (car pair) '(signed-byte 30))
162                 (typep (cdr pair) '(signed-byte 30)))
163      (error "Alist element ~s is not a CONS of two 30-bit integers" pair)))
164  (let* ((n (length alist))
165         (cars (make-array n :element-type '(signed-byte 30)))
166         (cdrs (make-array n :element-type '(signed-byte 30)))
167         (i 0))
168    (declare (fixnum i n))
169    (dolist (pair (sort-list  (copy-list alist) #'<  (if reverse-mapping (lambda (x) (cdr x)) (lambda (x) (car x)))))
170      (setf (aref cars i) (car pair)
171            (aref cdrs i) (cdr pair))
172      (incf i))
173    (if reverse-mapping
174      (values cdrs cars)
175      (values cars cdrs))))
176
177(defun init-pv-map (alist &key reverse-mapping)
178  (multiple-value-bind (keys values) (pv-map-vectors alist reverse-mapping)
179    (make-pv-map :keys keys :values values)))
180
181
182(defmethod default-character-encoding ((domain t))
183  (character-encoding-name (get-character-encoding nil)))
184
185(defun decode-character-encoded-vector (encoding vector start-index noctets string)
186  (setq encoding (ensure-character-encoding encoding))
187  (unless (= (the (unsigned-byte 8) (typecode vector))
188             target::subtag-u8-vector)
189    (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
190  (unless (= (the (unsigned-byte 8) (typecode string))
191             target::subtag-simple-base-string)
192    (report-bad-arg vector 'simple-string))
193  (let* ((len (length vector)))
194    (declare (type index len))
195    (unless (and (typep start-index 'fixnum)
196                 (>= (the fixnum start-index) 0)
197                 (< (the fixnum start-index) len))
198      (error "~s is an invalid start index for ~s" start-index vector))
199    (unless (and (typep noctets 'fixnum)
200                 (>= (the fixnum noctets) 0)
201                 (<= (+ (the fixnum start-index) (the fixnum noctets)) len))
202      (error "~S is an invalid octet count for ~s at ~s" noctets vector start-index))
203    (funcall (character-encoding-vector-decode-function encoding)
204             vector
205             start-index
206             noctets
207             string)))
208
209
210(defmethod print-object ((ce character-encoding) stream)
211  (print-unreadable-object (ce stream :type t :identity t)
212    (format stream "~a" (character-encoding-name ce))))
213
214(defun note-stream-decoding-problem (stream)
215  (let* ((source (if (typep stream 'ioblock)
216                   (ioblock-stream stream)
217                   stream))
218         (position (stream-position source))
219         (encoding-name
220          (character-encoding-name
221           (lookup-character-encoding (external-format-character-encoding (stream-external-format source))))))
222    (signal (make-condition 'decoding-problem
223                            :source source
224                            :position position
225                            :encoding-name encoding-name))
226    #\Replacement_Character))
227
228(defun note-vector-decoding-problem (vector index encoding)
229  (signal (make-condition 'decoding-problem
230                          :source vector
231                          :position index
232                          :encoding-name (let* ((enc (if (typep encoding 'character-encoding)
233                                                       encoding
234                                                       (lookup-character-encoding encoding))))
235                                           (if enc (character-encoding-name enc) encoding))))
236  #\Replacement_Character)
237
238(defun note-encoding-problem (char destination encoding code)
239  (signal (make-condition 'encoding-problem
240                          :character char
241                          :destination (if (typep destination 'ioblock)
242                                         (ioblock-stream destination)
243                                         destination)
244                          :encoding-name (let* ((enc (if (typep encoding 'character-encoding)
245                                                       encoding
246                                                       (lookup-character-encoding encoding))))
247                                           (if enc (character-encoding-name enc) encoding))))
248  code)
249
250
251(defun remove-character-encoding-alias (alias)
252  "(REMOVE-CHARACTER-ENCODING-ALIAS alias)
253alias - a keyword which is an alias for a defined character encoding.
254Makes the keyword cease to be an alias for that encoding and returns T."
255  (let* ((encoding (get-character-encoding alias))
256         (aliases (character-encoding-aliases encoding)))
257    (if (not (member alias aliases))
258      (error "~S is not an alias for ~s." alias encoding)
259      (progn
260        (setf (character-encoding-aliases encoding)
261              (remove alias aliases))
262        (remhash alias *character-encodings*)
263        t))))
264             
265 
266(defun define-character-encoding-alias (alias existing)
267  "(DEFINE-CHARACTER-ENCODING-ALIAS alias existing)
268alias - a keyword
269existing - a defined character encoding or a keyword that names one.
270Tries to make alias an alias for the existing encoding and returns
271that encoding."
272  (check-type alias keyword)
273  (let* ((canonical-encoding (ensure-character-encoding existing))
274         (current (lookup-character-encoding alias)))
275    (unless (eq current canonical-encoding)
276      (if (and current
277               (eq alias (character-encoding-name current)))
278        (error "Can't make ~s an alias for ~s, since it already names ~s."
279               alias existing current)
280        (progn
281          (when current
282            (setf (character-encoding-aliases current)
283                  (remove alias (character-encoding-aliases current))))
284          (pushnew alias (character-encoding-aliases canonical-encoding))
285          (setf (get-character-encoding alias) canonical-encoding))))
286    canonical-encoding))
287
288                         
289;;; N.B.  (ccl:nfunction <name> (lambda (...) ...)) is just  like
290;;;       (cl:function (lambda (...) ...)), except that the resulting
291;;; function will have "name" <name> (this is often helpful when debugging.)
292
293(defmacro define-character-encoding (name doc &rest args &key &allow-other-keys)
294  (setq name (intern (string name) "KEYWORD"))
295  (let* ((encoding (gensym))
296         (alias (gensym)))
297  `(let* ((,encoding (make-character-encoding :name ,name :documentation ,doc ,@args)))
298    (setf (get-character-encoding ,name) ,encoding)
299    (dolist (,alias (character-encoding-aliases ,encoding))
300      (setf (get-character-encoding ,alias) ,encoding))
301    ',name)))
302
303(defun encoding-name (encoding)
304  (character-encoding-name (or encoding (get-character-encoding nil))))
305
306;;; ISO-8859-1 is trivial, though of course it can't really encode characters
307;;; whose CHAR-CODE is >= 256
308
309(defun 8-bit-fixed-width-octets-in-string (string start end)
310  (declare (ignore string))
311  (if (>= end start)
312    (- end start)
313    0))
314
315(defun 8-bit-fixed-width-length-of-vector-encoding (vector start end)
316  (declare (ignore vector))
317  (if (>= end start)
318    (values (- end start) end)
319    (values 0 start)))
320
321(defun 8-bit-fixed-width-length-of-memory-encoding (pointer noctets start)
322  (declare (ignore pointer start))
323  (values noctets noctets))
324
325(define-character-encoding :iso-8859-1
326  "An 8-bit, fixed-width character encoding in which all character
327codes map to their Unicode equivalents. Intended to support most
328characters used in most Western European languages."
329
330  ;; The NIL alias is used internally to mean that ISO-8859-1 is
331  ;; the "null" 8-bit encoding
332  :aliases '(nil :iso_8859-1 :latin1 :l1 :ibm819 :cp819 :csISOLatin1)
333  :stream-encode-function
334  (nfunction
335   iso-8859-1-stream-encode
336   (lambda (char write-function stream)
337     (let* ((code (char-code char)))
338       (declare (type (mod #x110000) code))
339       (if (>= code 256)
340         (setq code (note-encoding-problem char stream :iso-8859-1 (char-code #\Sub))))
341       (funcall write-function stream code)
342       1)))
343  :stream-decode-function
344  (nfunction
345   iso-8859-1-stream-decode
346   (lambda (1st-unit next-unit-function stream)
347     (declare (ignore next-unit-function stream)
348              (type (unsigned-byte 8) 1st-unit))
349     (code-char 1st-unit)))
350  :vector-encode-function
351  (nfunction
352   iso-8859-1-vector-encode
353   (lambda (string vector idx start end)
354     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
355              (fixnum idx))
356     (do* ((i start (1+ i)))
357          ((>= i end) idx)
358       (let* ((char (schar string i))
359              (code (char-code char)))
360         (declare (type (mod #x110000) code))
361         (if (>= code 256)
362           (setq code (note-encoding-problem char vector :iso-8859-1 (char-code #\Sub))))
363         (progn
364           (setf (aref vector idx) code)
365           (incf idx))))))
366  :vector-decode-function
367  (nfunction
368   iso-8859-1-vector-decode
369   (lambda (vector idx noctets string)
370     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
371     (do* ((i 0 (1+ i))
372           (index idx (1+ index)))
373          ((>= i noctets) index)
374       (setf (schar string i) (code-char (the (unsigned-byte 8)
375                                             (aref vector index)))))))
376  :memory-encode-function
377  (nfunction
378   iso-8859-1-memory-encode
379   (lambda (string pointer idx start end)
380     (do* ((i start (1+ i)))
381          ((>= i end) idx)
382       (let* ((char (schar string i))
383              (code (char-code char)))
384         (declare (type (mod #x110000) code))
385         (if (>= code 256)
386           (setq code (note-encoding-problem char pointer :iso-8859-1 (char-code #\Sub))))
387         (setf (%get-unsigned-byte pointer idx) code)
388         (incf idx)))))
389  :memory-decode-function
390  (nfunction
391   iso-8859-1-memory-decode
392   (lambda (pointer noctets idx string)
393     (do* ((i 0 (1+ i))
394           (index idx (1+ index)))
395          ((>= i noctets) index)
396         (setf (schar string i) (code-char (the (unsigned-byte 8)
397                                             (%get-unsigned-byte pointer index)))))))
398  :octets-in-string-function
399  #'8-bit-fixed-width-octets-in-string
400  :length-of-vector-encoding-function
401  #'8-bit-fixed-width-length-of-vector-encoding
402  :length-of-memory-encoding-function 
403  #'8-bit-fixed-width-length-of-memory-encoding
404  :decode-literal-code-unit-limit 256
405  :encode-literal-char-code-limit 256
406
407  )
408
409(define-character-encoding :us-ascii
410  "A 7-bit, fixed-width character encoding in which all character
411codes map to their Unicode equivalents."
412
413  :aliases '(:csASCII :cp637 :IBM637 :us :ISO646-US :ascii :ISO-ir-6)
414  :stream-encode-function
415  (nfunction
416   ascii-stream-encode
417   (lambda (char write-function stream)
418     (let* ((code (char-code char)))
419       (declare (type (mod #x110000) code))
420       (when (>= code 128)
421         (setq code (note-encoding-problem char stream :us-ascii (char-code #\Sub))))
422       (funcall write-function stream code)
423       1)))
424  :stream-decode-function
425  (nfunction
426   ascii-stream-decode
427   (lambda (1st-unit next-unit-function stream)
428     (declare (ignore next-unit-function)
429              (type (unsigned-byte 8) 1st-unit))
430     (if (< 1st-unit 128)
431       (code-char 1st-unit)
432       (note-stream-decoding-problem stream))))
433  :vector-encode-function
434  (nfunction
435   ascii-vector-encode
436   (lambda (string vector idx start end)
437     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
438              (fixnum idx))
439     (do* ((i start (1+ i)))
440          ((>= i end) idx)
441       (let* ((char (schar string i))
442              (code (char-code char)))
443         (declare (type (mod #x110000) code))
444         (if (>= code 128)
445           (setq code (note-encoding-problem char vector :us-ascii (char-code #\Sub))))
446         (setf (aref vector idx) code)
447         (incf idx)))))
448  :vector-decode-function
449  (nfunction
450   ascii-vector-decode
451   (lambda (vector idx noctets string)
452     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
453     (do* ((i 0 (1+ i))
454           (index idx (1+ index)))
455          ((>= i noctets) index)
456       (let* ((code (aref vector index)))
457         (declare (type (unsigned-byte 8) code))
458         (setf (schar string i) (if (< code 128)
459                                  (code-char code)
460                                  (note-vector-decoding-problem vector index :us-ascii)))))))
461  :memory-encode-function
462  (nfunction
463   ascii-memory-encode
464   (lambda (string pointer idx start end)
465     (do* ((i start (1+ i)))
466          ((>= i end) idx)
467       (let* ((char (schar string i))
468              (code (char-code char)))
469         (declare (type (mod #x110000) code))
470         (if (>= code 128)
471           (setq code (note-encoding-problem char pointer :us-ascii (char-code #\Sub))))
472         (setf (%get-unsigned-byte pointer idx) code)
473         (incf idx)))))
474  :memory-decode-function
475  (nfunction
476   ascii-memory-decode
477   (lambda (pointer noctets idx string)
478     (do* ((i 0 (1+ i))
479           (index idx (1+ index)))
480          ((>= i noctets) index)
481       (let* ((code (%get-unsigned-byte pointer index)))
482         (declare (type (unsigned-byte 8) code))
483         (if (>= code 128)
484           (setf (schar string i) (note-vector-decoding-problem pointer index :us-ascii))
485           (setf (schar string i) (code-char code)))))))
486  :octets-in-string-function
487  #'8-bit-fixed-width-octets-in-string
488  :length-of-vector-encoding-function
489  #'8-bit-fixed-width-length-of-vector-encoding
490  :length-of-memory-encoding-function 
491  #'8-bit-fixed-width-length-of-memory-encoding
492  :decode-literal-code-unit-limit 128
493  :encode-literal-char-code-limit 128
494  )
495
496
497
498;;; Other 1-byte, fixed-width encodings.  Typically, codes in the range
499;;; #x00-#x9f maps straight through, while codes #xa0-#xff select arbitrary
500;;; Unicode characters that are commonly used in some locale.  (Sometimes
501;;; the break is at #x80 or #xd0 instead of #xa0).
502
503(defmacro define-8-bit-fixed-width-encoding (name doc aliases encode-map decode-string mapping &optional (literal-limit #xa0))
504  (unless (= (length mapping) (- 256 literal-limit))
505    (error "Mapping data for encoding ~s should contain exactly ~d elements, not ~d" name (- 256 literal-limit) (length mapping)))
506  `(progn
507    (defstatic ,encode-map (init-pv-map ',(loop
508                                             for i from literal-limit to 256
509                                             for code across mapping
510                                             unless (eql code (char-code #\replacement_character))
511                                             collect (cons i code))
512                                          :reverse-mapping t))
513    (defstatic ,decode-string ,(map 'string #'code-char mapping))
514    (define-character-encoding ,name
515        ,doc
516      :aliases ',aliases
517      :stream-encode-function
518      (nfunction ,(intern (concatenate 'string (string name) "-STREAM-ENCODE"))
519       (lambda (char write-function stream)
520         (let* ((code (char-code char))
521                (c2 (if (< code ,literal-limit)
522                      code
523                      (pv-map-lookup code ,encode-map))))
524           (declare (type (mod #x110000) code))
525           (funcall write-function stream (or c2 (note-encoding-problem char stream ,name (char-code #\Sub))))
526           1)))
527      :stream-decode-function
528      (nfunction
529       ,(intern (concatenate 'string (string name) "-STREAM-DECODE"))
530       (lambda (1st-unit next-unit-function stream)
531         (declare (ignore next-unit-function)
532                  (type (unsigned-byte 8) 1st-unit))
533         (if (< 1st-unit ,literal-limit)
534           (code-char 1st-unit)
535           (let* ((char (schar ,decode-string (- 1st-unit ,literal-limit))))
536             (when (eql char #\replacement_character)
537               (note-stream-decoding-problem stream))
538             char))))
539      :vector-encode-function
540      (nfunction
541       ,(intern (concatenate 'string (string name) "-VECTOR-ENCODE"))
542       (lambda (string vector idx start end)
543         (declare (type (simple-array (unsigned-byte 8) (*)) vector)
544                  (fixnum idx))
545         (do* ((i start (1+ i)))
546              ((>= i end) idx)
547           (let* ((char (schar string i))
548                  (code (char-code char))
549                  (c2 (if (< code ,literal-limit)
550                        code
551                        (pv-map-lookup code ,encode-map))))
552             (declare (type (mod #x110000) code))
553             (setf (aref vector idx) (or c2 (note-encoding-problem char vector ,name (char-code #\Sub))))
554             (incf idx)))))
555      :vector-decode-function
556      (nfunction
557       ,(intern (concatenate 'string (string name) "-VECTOR-DECODE"))
558       (lambda (vector idx noctets string)
559         (declare (type (simple-array (unsigned-byte 8) (*)) vector))
560         (do* ((i 0 (1+ i))
561               (index idx (1+ index)))
562              ((>= i noctets) index)
563           (let* ((1st-unit (aref vector index)))
564             (declare (type (unsigned-byte 8) 1st-unit))
565             (setf (schar string i)
566                   (if (< 1st-unit ,literal-limit)
567                     (code-char 1st-unit)
568                     (let* ((char (schar ,decode-string (the fixnum (- 1st-unit ,literal-limit)))))
569                       (when (eql char #\replacement_character)
570                         (note-vector-decoding-problem vector i ,name ))
571                       char)))))))
572      :memory-encode-function
573      (nfunction
574       ,(intern (concatenate 'string (string name) "-MEMORY-ENCODE"))
575       (lambda (string pointer idx start end)
576         (do* ((i start (1+ i)))
577              ((>= i end) idx)
578           (let* ((char (schar string i))
579                  (code (char-code char))
580                  (c2 (if (< code ,literal-limit)
581                        code
582                        (pv-map-lookup code ,encode-map))))
583             (declare (type (mod #x110000) code))
584             (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer ,name (char-code #\Sub))))
585             (incf idx)))))
586      :memory-decode-function
587      (nfunction
588       ,(intern (concatenate 'string (string name) "-MEMORY-DECODE"))
589       (lambda (pointer noctets idx string)
590         (do* ((i 0 (1+ i))
591               (index idx (1+ index)))
592              ((>= i noctets) index)
593           (let* ((1st-unit (%get-unsigned-byte pointer index)))
594             (declare (type (unsigned-byte 8) 1st-unit))
595             (setf (schar string i)
596                   (if (< 1st-unit ,literal-limit)
597                     (code-char 1st-unit)
598                     (let* ((char (schar ,decode-string (the fixnum (- 1st-unit ,literal-limit)))))
599                       (when (eql char #\replacement_character)
600                         (note-vector-decoding-problem pointer index ,name ))
601                       char)))))))
602      :octets-in-string-function
603      #'8-bit-fixed-width-octets-in-string
604      :length-of-vector-encoding-function
605      #'8-bit-fixed-width-length-of-vector-encoding
606      :length-of-memory-encoding-function 
607      #'8-bit-fixed-width-length-of-memory-encoding
608      :decode-literal-code-unit-limit ,literal-limit
609      :encode-literal-char-code-limit ,literal-limit)))
610
611(define-8-bit-fixed-width-encoding :iso-8859-2
612    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
613map to their Unicode equivalents and other codes map to other Unicode
614character values.  Intended to provide most characters found in most
615languages used in Central/Eastern Europe."
616  (:iso_8859-2 :latin2 :l2 :csISOLatin2)
617  *unicode-to-iso-8859-2-map*
618  *iso-to-8859-2-to-unicode-string*
619  #(#xA0 #x104 #x2D8 #x141 #xA4 #x13D #x15A #xA7 #xA8 #x160 #x15E #x164
620    #x179 #xAD #x17D #x17B #xB0 #x105 #x2DB #x142 #xB4 #x13E #x15B #x2C7
621    #xB8 #x161 #x15F #x165 #x17A #x2DD #x17E #x17C #x154 #xC1 #xC2 #x102
622    #xC4 #x139 #x106 #xC7 #x10C #xC9 #x118 #xCB #x11A #xCD #xCE #x10E
623    #x110 #x143 #x147 #xD3 #xD4 #x150 #xD6 #xD7 #x158 #x16E #xDA #x170
624    #xDC #xDD #x162 #xDF #x155 #xE1 #xE2 #x103 #xE4 #x13A #x107 #xE7
625    #x10D #xE9 #x119 #xEB #x11B #xED #xEE #x10F #x111 #x144 #x148 #xF3
626    #xF4 #x151 #xF6 #xF7 #x159 #x16F #xFA #x171 #xFC #xFD #x163 #x2D9))
627
628(define-8-bit-fixed-width-encoding :iso-8859-3
629  "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
630map to their Unicode equivalents and other codes map to other Unicode
631character values.  Intended to provide most characters found in most
632languages used in Southern Europe."
633  (:iso_8859-3 :latin3 :l3 :csisolatin3)
634  *unicode-to-iso-8859-3-map*
635  *iso-to-8859-3-to-unicode-string*
636  #(
637    ;; #xa0
638    #x00a0 #x0126 #x02d8 #x00a3 #x00a4 #xfffd #x0124 #x00a7
639    #x00a8 #x0130 #x015e #x011e #x0134 #x00ad #xfffd #x017b
640    ;; #xb0
641    #x00b0 #x0127 #x00b2 #x00b3 #x00b4 #x00b5 #x0125 #x00b7
642    #x00b8 #x0131 #x015f #x011f #x0135 #x00bd #xfffd #x017c
643    ;; #xc0
644    #x00c0 #x00c1 #x00c2 #xfffd #x00c4 #x010a #x0108 #x00c7
645    #x00c8 #x00c9 #x00ca #x00cb #x00cc #x00cd #x00ce #x00cf
646    ;; #xd0
647    #xfffd #x00d1 #x00d2 #x00d3 #x00d4 #x0120 #x00d6 #x00d7
648    #x011c #x00d9 #x00da #x00db #x00dc #x016c #x015c #x00df
649    ;; #xe0
650    #x00e0 #x00e1 #x00e2 #xfffd #x00e4 #x010b #x0109 #x00e7
651    #x00e8 #x00e9 #x00ea #x00eb #x00ec #x00ed #x00ee #x00ef
652    ;; #xf0
653    #xfffd #x00f1 #x00f2 #x00f3 #x00f4 #x0121 #x00f6 #x00f7
654    #x011d #x00f9 #x00fa #x00fb #x00fc #x016d #x015d #x02d9
655    ))
656
657(define-8-bit-fixed-width-encoding :iso-8859-4
658  "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
659map to their Unicode equivalents and other codes map to other Unicode
660character values.  Intended to provide most characters found in most
661languages used in Northern Europe."
662  (:iso_8859-4 :latin4 :l4 :csisolatin4)
663  *unicode-to-iso-8859-4-map*
664  *iso-to-8859-4-to-unicode-string*
665  #(
666    ;; #xa0
667    #x00a0 #x0104 #x0138 #x0156 #x00a4 #x0128 #x013b #x00a7
668    #x00a8 #x0160 #x0112 #x0122 #x0166 #x00ad #x017d #x00af
669    ;; #xb0
670    #x00b0 #x0105 #x02db #x0157 #x00b4 #x0129 #x013c #x02c7
671    #x00b8 #x0161 #x0113 #x0123 #x0167 #x014a #x017e #x014b
672    ;; #xc0
673    #x0100 #x00c1 #x00c2 #x00c3 #x00c4 #x00c5 #x00c6 #x012e
674    #x010c #x00c9 #x0118 #x00cb #x0116 #x00cd #x00ce #x012a
675    ;; #xd0
676    #x0110 #x0145 #x014c #x0136 #x00d4 #x00d5 #x00d6 #x00d7
677    #x00d8 #x0172 #x00da #x00db #x00dc #x0168 #x016a #x00df
678    ;; #xe0
679    #x0101 #x00e1 #x00e2 #x00e3 #x00e4 #x00e5 #x00e6 #x012f
680    #x010d #x00e9 #x0119 #x00eb #x0117 #x00ed #x00ee #x012b
681    ;; #xf0
682    #x0111 #x0146 #x014d #x0137 #x00f4 #x00f5 #x00f6 #x00f7
683    #x00f8 #x0173 #x00fa #x00fb #x00fc #x0169 #x016b #x02d9
684    ))
685
686(define-8-bit-fixed-width-encoding :iso-8859-5
687  "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
688map to their Unicode equivalents and other codes map to other Unicode
689character values.  Intended to provide most characters found in the
690Cyrillic alphabet."
691  (:iso_8859-5 :cyrillic :csISOLatinCyrillic :iso-ir-144)
692  *unicode-to-iso-8859-5-map*
693  *iso-to-8859-5-to-unicode-string*
694  #(
695    ;; #xa0
696    #x00a0 #x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407
697    #x0408 #x0409 #x040a #x040b #x040c #x00ad #x040e #x040f
698    ;; #xb0
699    #x0410 #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417
700    #x0418 #x0419 #x041a #x041b #x041c #x041d #x041e #x041f
701    ;; #xc0
702    #x0420 #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427
703    #x0428 #x0429 #x042a #x042b #x042c #x042d #x042e #x042f
704    ;; #xd0
705    #x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437
706    #x0438 #x0439 #x043a #x043b #x043c #x043d #x043e #x043f
707    ;; #xe0
708    #x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447
709    #x0448 #x0449 #x044a #x044b #x044c #x044d #x044e #x044f
710    ;; #xf0
711    #x2116 #x0451 #x0452 #x0453 #x0454 #x0455 #x0456 #x0457
712    #x0458 #x0459 #x045a #x045b #x045c #x00a7 #x045e #x045f
713    ))
714
715(define-8-bit-fixed-width-encoding :iso-8859-6
716    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
717map to their Unicode equivalents and other codes map to other Unicode
718character values.  Intended to provide most characters found in the
719Arabic alphabet."
720  (:iso_8859-6 :arabic :csISOLatinArabic :iso-ir-127)
721  *unicode-to-iso-8859-6-map*
722  *iso-to-8859-6-to-unicode-string*
723  #(
724    ;; #xa0
725    #x00a0 #xfffd #xfffd #xfffd #x00a4 #xfffd #xfffd #xfffd
726    #xfffd #xfffd #xfffd #xfffd #x060c #x00ad #xfffd #xfffd
727    ;; #xb0
728    #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd
729    #xfffd #xfffd #xfffd #x061b #xfffd #xfffd #xfffd #x061f
730    ;; #xc0
731    #xfffd #x0621 #x0622 #x0623 #x0624 #x0625 #x0626 #x0627
732    #x0628 #x0629 #x062a #x062b #x062c #x062d #x062e #x062f
733    ;; #xd0
734    #x0630 #x0631 #x0632 #x0633 #x0634 #x0635 #x0636 #x0637
735    #x0638 #x0639 #x063a #xfffd #xfffd #xfffd #xfffd #xfffd
736    ;; #xe0
737    #x0640 #x0641 #x0642 #x0643 #x0644 #x0645 #x0646 #x0647
738    #x0648 #x0649 #x064a #x064b #x064c #x064d #x064e #x064f
739    ;; #xf0
740    #x0650 #x0651 #x0652 #xfffd #xfffd #xfffd #xfffd #xfffd
741    #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd
742    ))
743
744(define-8-bit-fixed-width-encoding :iso-8859-7
745    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
746map to their Unicode equivalents and other codes map to other Unicode
747character values.  Intended to provide most characters found in the
748Greek alphabet."
749  (:iso_8859-7 :greek  :greek8 :csISOLatinGreek :iso-ir-126 :ELOT_928 :ecma-118)
750  *unicode-to-iso-8859-7-map*
751  *iso-to-8859-7-to-unicode-string*
752  #(
753    ;; #xa0
754    #x00a0 #x2018 #x2019 #x00a3 #x20ac #x20af #x00a6 #x00a7
755    #x00a8 #x00a9 #x037a #x00ab #x00ac #x00ad #xfffd #x2015
756    ;; #xb0
757    #x00b0 #x00b1 #x00b2 #x00b3 #x0384 #x0385 #x0386 #x00b7
758    #x0388 #x0389 #x038a #x00bb #x038c #x00bd #x038e #x038f
759    ;; #xc0
760    #x0390 #x0391 #x0392 #x0393 #x0394 #x0395 #x0396 #x0397
761    #x0398 #x0399 #x039a #x039b #x039c #x039d #x039e #x039f
762    ;; #xd0
763    #x03a0 #x03a1 #xfffd #x03a3 #x03a4 #x03a5 #x03a6 #x03a7
764    #x03a8 #x03a9 #x03aa #x03ab #x03ac #x03ad #x03ae #x03af
765    ;; #xe0
766    #x03b0 #x03b1 #x03b2 #x03b3 #x03b4 #x03b5 #x03b6 #x03b7
767    #x03b8 #x03b9 #x03ba #x03bb #x03bc #x03bd #x03be #x03bf
768    ;; #xf0
769    #x03c0 #x03c1 #x03c2 #x03c3 #x03c4 #x03c5 #x03c6 #x03c7
770    #x03c8 #x03c9 #x03ca #x03cb #x03cc #x03cd #x03ce #xfffd
771    ))
772
773(define-8-bit-fixed-width-encoding :iso-8859-8
774    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
775map to their Unicode equivalents and other codes map to other Unicode
776character values.  Intended to provide most characters found in the
777Hebrew alphabet."
778  (:iso_8859-8 :hebrew :csISOLatinHebrew :iso-ir-138)
779  *unicode-to-iso-8859-8-map*
780  *iso-to-8859-8-to-unicode-string*
781  #(
782    ;; #xa0
783    #x00a0 #xfffd #x00a2 #x00a3 #x00a4 #x00a5 #x00a6 #x00a7
784    #x00a8 #x00a9 #x00d7 #x00ab #x00ac #x00ad #x00ae #x00af
785    ;; #xb0
786    #x00b0 #x00b1 #x00b2 #x00b3 #x00b4 #x00b5 #x00b6 #x00b7
787    #x00b8 #x00b9 #x00f7 #x00bb #x00bc #x00bd #x00be #xfffd
788    ;; #xc0
789    #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd
790    #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd
791    ;; #xd0
792    #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd
793    #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #xfffd #x2017
794    ;; #xe0
795    #x05d0 #x05d1 #x05d2 #x05d3 #x05d4 #x05d5 #x05d6 #x05d7
796    #x05d8 #x05d9 #x05da #x05db #x05dc #x05dd #x05de #x05df
797    ;; #xf0
798    #x05e0 #x05e1 #x05e2 #x05e3 #x05e4 #x05e5 #x05e6 #x05e7
799    #x05e8 #x05e9 #x05ea #xfffd #xfffd #x200e #x200f #xfffd
800    ))
801
802(define-8-bit-fixed-width-encoding :iso-8859-9
803    "An 8-bit, fixed-width character encoding in which codes #x00-#xcf
804map to their Unicode equivalents and other codes map to other Unicode
805character values.  Intended to provide most characters found in the
806Turkish alphabet."
807  (:iso_8859-9 :latin5 :csISOLatin5 :iso-ir-148)
808  *unicode-to-iso-8859-9-map*
809  *iso-to-8859-9-to-unicode-string*
810  #(
811    ;; #xd0
812    #x011e #x00d1 #x00d2 #x00d3 #x00d4 #x00d5 #x00d6 #x00d7
813    #x00d8 #x00d9 #x00da #x00db #x00dc #x0130 #x015e #x00df
814    ;; #xe0
815    #x00e0 #x00e1 #x00e2 #x00e3 #x00e4 #x00e5 #x00e6 #x00e7
816    #x00e8 #x00e9 #x00ea #x00eb #x00ec #x00ed #x00ee #x00ef
817    ;; #xf0
818    #x011f #x00f1 #x00f2 #x00f3 #x00f4 #x00f5 #x00f6 #x00f7
819    #x00f8 #x00f9 #x00fa #x00fb #x00fc #x0131 #x015f #x00ff
820    )
821  #xd0)
822
823(define-8-bit-fixed-width-encoding :iso-8859-10
824    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
825map to their Unicode equivalents and other codes map to other Unicode
826character values.  Intended to provide most characters found in Nordic
827alphabets."
828  (:iso_8859-10 :latin6 :csISOLatin6 :iso-ir-157)
829  *unicode-to-iso-8859-10-map*
830  *iso-to-8859-10-to-unicode-string*
831  #(
832    ;; #xa0
833    #x00a0 #x0104 #x0112 #x0122 #x012a #x0128 #x0136 #x00a7
834    #x013b #x0110 #x0160 #x0166 #x017d #x00ad #x016a #x014a
835    ;; #xb0
836    #x00b0 #x0105 #x0113 #x0123 #x012b #x0129 #x0137 #x00b7
837    #x013c #x0111 #x0161 #x0167 #x017e #x2015 #x016b #x014b
838    ;; #xc0
839    #x0100 #x00c1 #x00c2 #x00c3 #x00c4 #x00c5 #x00c6 #x012e
840    #x010c #x00c9 #x0118 #x00cb #x0116 #x00cd #x00ce #x00cf
841    ;; #xd0
842    #x00d0 #x0145 #x014c #x00d3 #x00d4 #x00d5 #x00d6 #x0168
843    #x00d8 #x0172 #x00da #x00db #x00dc #x00dd #x00de #x00df
844    ;; #xe0
845    #x0101 #x00e1 #x00e2 #x00e3 #x00e4 #x00e5 #x00e6 #x012f
846    #x010d #x00e9 #x0119 #x00eb #x0117 #x00ed #x00ee #x00ef
847    ;; #xf0
848    #x00f0 #x0146 #x014d #x00f3 #x00f4 #x00f5 #x00f6 #x0169
849    #x00f8 #x0173 #x00fa #x00fb #x00fc #x00fd #x00fe #x0138
850    ))
851
852(define-character-encoding :iso-8859-11
853    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
854map to their Unicode equivalents and other codes map to other Unicode
855character values.  Intended to provide most characters found the  Thai
856alphabet."
857  :aliases '()
858  :stream-encode-function
859  (nfunction
860   iso-8859-11-stream-encode
861   (lambda (char write-function stream)
862     (let* ((code (char-code char))
863            (c2 (cond ((< code #xa1) code)
864                      ((and (<= code #xfb)
865                            (not (and (>= code #xdb) (<= code #xde))))
866                       (+ code #x0d60)))))
867       (declare (type (mod #x110000) code))
868       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-11 (char-code #\Sub))))
869       1)))
870  :stream-decode-function
871  (nfunction
872   iso-8859-11-stream-decode
873   (lambda (1st-unit next-unit-function stream)
874     (declare (ignore next-unit-function)
875              (type (unsigned-byte 8) 1st-unit))
876     (if (< 1st-unit #xa1)
877       (code-char 1st-unit)
878       (if (and (>= 1st-unit #xe01)
879                (<= 1st-unit #xe5b)
880                (not (and (>= 1st-unit #xe3b)
881                          (<= 1st-unit #xe3e))))
882         (code-char (- 1st-unit #xd60))
883         (note-stream-decoding-problem stream)))))
884  :vector-encode-function
885  (nfunction
886   iso-8859-11-vector-encode
887   (lambda (string vector idx start end)
888     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
889              (fixnum idx))
890     (do* ((i start (1+ i)))
891          ((>= i end) idx)
892       (let* ((char (schar string i))
893              (code (char-code char))
894              (c2 (cond ((< code #xa1) code)
895                      ((and (<= code #xfb)
896                            (not (and (>= code #xdb) (<= code #xde))))
897                       (+ code #x0d60)))))
898         (declare (type (mod #x110000) code))
899         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-11 (char-code #\Sub))))
900         (incf idx)))))
901  :vector-decode-function
902  (nfunction
903   iso-8859-11-vector-decode
904   (lambda (vector idx noctets string)
905     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
906     (do* ((i 0 (1+ i))
907           (index idx (1+ index)))
908          ((>= i noctets) index)
909       (let* ((1st-unit (aref vector index)))
910         (declare (type (unsigned-byte 8) 1st-unit))
911         (setf (schar string i)
912               (if (< 1st-unit #xa1)
913                 (code-char 1st-unit)
914                 (if (and (>= 1st-unit #xe01)
915                          (<= 1st-unit #xe5b)
916                          (not (and (>= 1st-unit #xe3b)
917                                    (<= 1st-unit #xe3e))))
918                   (code-char (- 1st-unit #xd60))
919                   (note-vector-decoding-problem vector index :iso-8859-11))))))))
920  :memory-encode-function
921  (nfunction
922   iso-8859-11-memory-encode
923   (lambda (string pointer idx start end)
924     (do* ((i start (1+ i)))
925          ((>= i end) idx)
926       (let* ((char (schar string i))
927              (code (char-code char))
928              (c2 (cond ((< code #xa1) code)
929                      ((and (<= code #xfb)
930                            (not (and (>= code #xdb) (<= code #xde))))
931                       (+ code #x0d60)))))
932         (declare (type (mod #x110000) code))
933         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-11 (char-code #\Sub))))
934         (incf idx)))))
935  :memory-decode-function
936  (nfunction
937   iso-8859-11-memory-decode
938   (lambda (pointer noctets idx string)
939     (do* ((i 0 (1+ i))
940           (index idx (1+ index)))
941          ((>= i noctets) index)
942       (let* ((1st-unit (%get-unsigned-byte pointer index)))
943         (declare (type (unsigned-byte 8) 1st-unit))
944         (setf (schar string i)
945               (if (< 1st-unit #xa1)
946                 (code-char 1st-unit)
947                 (if (and (>= 1st-unit #xe01)
948                          (<= 1st-unit #xe5b)
949                          (not (and (>= 1st-unit #xe3b)
950                                    (<= 1st-unit #xe3e))))
951                   (code-char (- 1st-unit #xd60))
952                   (note-vector-decoding-problem pointer index :iso-8859-11))))))))
953  :octets-in-string-function
954  #'8-bit-fixed-width-octets-in-string
955  :length-of-vector-encoding-function
956  #'8-bit-fixed-width-length-of-vector-encoding
957  :length-of-memory-encoding-function 
958  #'8-bit-fixed-width-length-of-memory-encoding
959  :decode-literal-code-unit-limit #xa0
960  :encode-literal-char-code-limit #xa0 
961  )
962
963;;; There is no iso-8859-12 encoding.
964
965(define-8-bit-fixed-width-encoding :iso-8859-13
966    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
967map to their Unicode equivalents and other codes map to other Unicode
968character values.  Intended to provide most characters found in Baltic
969alphabets."
970  () 
971  *unicode-to-iso-8859-13-map*
972  *iso-to-8859-13-to-unicode-string*
973  #(
974    ;; #xa0
975    #x00a0 #x201d #x00a2 #x00a3 #x00a4 #x201e #x00a6 #x00a7
976    #x00d8 #x00a9 #x0156 #x00ab #x00ac #x00ad #x00ae #x00c6
977    ;; #xb0
978    #x00b0 #x00b1 #x00b2 #x00b3 #x201c #x00b5 #x00b6 #x00b7
979    #x00f8 #x00b9 #x0157 #x00bb #x00bc #x00bd #x00be #x00e6
980    ;; #xc0
981    #x0104 #x012e #x0100 #x0106 #x00c4 #x00c5 #x0118 #x0112
982    #x010c #x00c9 #x0179 #x0116 #x0122 #x0136 #x012a #x013b
983    ;; #xd0
984    #x0160 #x0143 #x0145 #x00d3 #x014c #x00d5 #x00d6 #x00d7
985    #x0172 #x0141 #x015a #x016a #x00dc #x017b #x017d #x00df
986    ;; #xe0
987    #x0105 #x012f #x0101 #x0107 #x00e4 #x00e5 #x0119 #x0113
988    #x010d #x00e9 #x017a #x0117 #x0123 #x0137 #x012b #x013c
989    ;; #xf0
990    #x0161 #x0144 #x0146 #x00f3 #x014d #x00f5 #x00f6 #x00f7
991    #x0173 #x0142 #x015b #x016b #x00fc #x017c #x017e #x2019
992    ))
993
994(define-8-bit-fixed-width-encoding :iso-8859-14
995    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
996map to their Unicode equivalents and other codes map to other Unicode
997character values.  Intended to provide most characters found in Celtic
998languages."
999  (:iso_8859-14 :iso-ir-199 :latin8 :l8 :iso-celtic)
1000  *unicode-to-iso-8859-14-map*
1001  *iso-to-8859-14-to-unicode-string*
1002  #(
1003    ;; #xa0
1004    #x00a0 #x1e02 #x1e03 #x00a3 #x010a #x010b #x1e0a #x00a7
1005    #x1e80 #x00a9 #x1e82 #x1e0b #x1ef2 #x00ad #x00ae #x0178
1006    ;; #xb0
1007    #x1e1e #x1e1f #x0120 #x0121 #x1e40 #x1e41 #x00b6 #x1e56
1008    #x1e81 #x1e57 #x1e83 #x1e60 #x1ef3 #x1e84 #x1e85 #x1e61
1009    ;; #xc0
1010    #x00c0 #x00c1 #x00c2 #x00c3 #x00c4 #x00c5 #x00c6 #x00c7
1011    #x00c8 #x00c9 #x00ca #x00cb #x00cc #x00cd #x00ce #x00cf
1012    ;; #xd0
1013    #x0174 #x00d1 #x00d2 #x00d3 #x00d4 #x00d5 #x00d6 #x1e6a
1014    #x00d8 #x00d9 #x00da #x00db #x00dc #x00dd #x0176 #x00df
1015    ;; #xe0
1016    #x00e0 #x00e1 #x00e2 #x00e3 #x00e4 #x00e5 #x00e6 #x00e7
1017    #x00e8 #x00e9 #x00ea #x00eb #x00ec #x00ed #x00ee #x00ef
1018    ;; #xf0
1019    #x0175 #x00f1 #x00f2 #x00f3 #x00f4 #x00f5 #x00f6 #x1e6b
1020    #x00f8 #x00f9 #x00fa #x00fb #x00fc #x00fd #x0177 #x00ff
1021    ))
1022
1023(define-8-bit-fixed-width-encoding :iso-8859-15
1024    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
1025map to their Unicode equivalents and other codes map to other Unicode
1026character values.  Intended to provide most characters found in
1027Western European languages (including the Euro sign and some other
1028characters missing from ISO-8859-1.)"
1029  (:iso_8859-15 :latin9)
1030  *unicode-to-iso-8859-15-map*
1031  *iso-to-8859-15-to-unicode-string*
1032  #(
1033    ;; #xa0
1034    #x00a0 #x00a1 #x00a2 #x00a3 #x20ac #x00a5 #x0160 #x00a7
1035    #x0161 #x00a9 #x00aa #x00ab #x00ac #x00ad #x00ae #x00af
1036    ;; #xb0
1037    #x00b0 #x00b1 #x00b2 #x00b3 #x017d #x00b5 #x00b6 #x00b7
1038    #x017e #x00b9 #x00ba #x00bb #x0152 #x0153 #x0178 #x00bf
1039    ;; #xc0
1040    #x00c0 #x00c1 #x00c2 #x00c3 #x00c4 #x00c5 #x00c6 #x00c7 
1041    ;; #xc8
1042    #x00c8 #x00c9 #x00ca #x00cb #x00cc #x00cd #x00ce #x00cf 
1043    ;; #xd0
1044    #x00d0 #x00d1 #x00d2 #x00d3 #x00d4 #x00d5 #x00d6 #x00d7 
1045    ;; #xd8
1046    #x00d8 #x00d9 #x00da #x00db #x00dc #x00dd #x00de #x00df 
1047    ;; #xe0
1048    #x00e0 #x00e1 #x00e2 #x00e3 #x00e4 #x00e5 #x00e6 #x00e7 
1049    ;; #xe8
1050    #x00e8 #x00e9 #x00ea #x00eb #x00ec #x00ed #x00ee #x00ef 
1051    ;; #xf0
1052    #x00f0 #x00f1 #x00f2 #x00f3 #x00f4 #x00f5 #x00f6 #x00f7 
1053    ;; #xf8
1054    #x00f8 #x00f9 #x00fa #x00fb #x00fc #x00fd #x00fe #x00ff 
1055    ))
1056
1057(define-8-bit-fixed-width-encoding :iso-8859-16
1058    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
1059map to their Unicode equivalents and other codes map to other Unicode
1060character values.  Intended to provide most characters found in Southeast
1061European languages."
1062  (:iso_8859-16 :latin10 :l1 :iso-ir-226)
1063  *unicode-to-iso-8859-16-map*
1064  *iso-to-8859-16-to-unicode-string*
1065  #(
1066    ;; #xa0
1067    #x00a0 #x0104 #x0105 #x0141 #x20ac #x201e #x0160 #x00a7
1068    #x0161 #x00a9 #x0218 #x00ab #x0179 #x00ad #x017a #x017b
1069    ;; #xb0
1070    #x00b0 #x00b1 #x010c #x0142 #x017d #x201d #x00b6 #x00b7
1071    #x017e #x010d #x0219 #x00bb #x0152 #x0153 #x0178 #x017c
1072    ;; #xc0
1073    #x00c0 #x00c1 #x00c2 #x0102 #x00c4 #x0106 #x00c6 #x00c7
1074    #x00c8 #x00c9 #x00ca #x00cb #x00cc #x00cd #x00ce #x00cf
1075    ;; #xd0
1076    #x0110 #x0143 #x00d2 #x00d3 #x00d4 #x0150 #x00d6 #x015a
1077    #x0170 #x00d9 #x00da #x00db #x00dc #x0118 #x021a #x00df
1078    ;; #xe0
1079    #x00e0 #x00e1 #x00e2 #x0103 #x00e4 #x0107 #x00e6 #x00e7
1080    #x00e8 #x00e9 #x00ea #x00eb #x00ec #x00ed #x00ee #x00ef
1081    ;; #xf0
1082    #x0111 #x0144 #x00f2 #x00f3 #x00f4 #x0151 #x00f6 #x015b
1083    #x0171 #x00f9 #x00fa #x00fb #x00fc #x0119 #x021b #x00ff
1084    ))
1085
1086(define-8-bit-fixed-width-encoding :macintosh
1087    "An 8-bit, fixed-width character encoding in which codes #x00-#x7f
1088map to their Unicode equivalents and other codes map to other Unicode
1089character values.  Traditionally used on Classic MacOS to encode characters
1090used in western languages."
1091  (:macos-roman :macosroman :mac-roman :macroman)
1092  *unicode-to-macintosh-map*
1093  *macintosh-to-unicode-string*
1094  #(
1095    ;; #x80
1096    #x00c4 #x00c5 #x00c7 #x00c9 #x00d1 #x00d6 #x00dc #x00e1
1097    #x00e0 #x00e2 #x00e4 #x00e3 #x00e5 #x00e7 #x00e9 #x00e8
1098    ;; #x90
1099    #x00ea #x00eb #x00ed #x00ec #x00ee #x00ef #x00f1 #x00f3
1100    #x00f2 #x00f4 #x00f6 #x00f5 #x00fa #x00f9 #x00fb #x00fc
1101    ;; #xa0
1102    #x2020 #x00b0 #x00a2 #x00a3 #x00a7 #x2022 #x00b6 #x00df
1103    #x00ae #x00a9 #x2122 #x00b4 #x00a8 #x2260 #x00c6 #x00d8
1104    ;; #xb0
1105    #x221e #x00b1 #x2264 #x2265 #x00a5 #x00b5 #x2202 #x2211
1106    #x220f #x03c0 #x222b #x00aa #x00ba #x2126 #x00e6 #x00f8
1107    ;; #xc0
1108    #x00bf #x00a1 #x00ac #x221a #x0192 #x2248 #x2206 #x00ab
1109    #x00bb #x2026 #x00a0 #x00c0 #x00c3 #x00d5 #x0152 #x0153
1110    ;; #xd0
1111    #x2013 #x2014 #x201c #x201d #x2018 #x2019 #x00f7 #x25ca
1112    #x00ff #x0178 #x2044 #x00a4 #x2039 #x203a #xfb01 #xfb02
1113    ;; #xe0
1114    #x2021 #x00b7 #x201a #x201e #x2030 #x00c2 #x00ca #x00c1
1115    #x00cb #x00c8 #x00cd #x00ce #x00cf #x00cc #x00d3 #x00d4
1116    ;; #xf0
1117    #xf8ff #x00d2 #x00da #x00db #x00d9 #x0131 #x02c6 #x02dc
1118    #x00af #x02d8 #x02d9 #x02da #x00b8 #x02dd #x02db #x02c7
1119    )
1120  #x80)
1121
1122
1123
1124;;; UTF-8.  Decoding checks for malformed sequences; it might be faster (and
1125;;; would certainly be simpler) if it didn't.
1126(define-character-encoding :utf-8
1127    "An 8-bit, variable-length character encoding in which characters
1128with CHAR-CODEs in the range #x00-#x7f can be encoded in a single
1129octet; characters with larger code values can be encoded in 2 to 4
1130bytes."
1131    :max-units-per-char 4
1132    :stream-encode-function
1133    (nfunction
1134     utf-8-stream-encode
1135     (lambda (char write-function stream)
1136       (let* ((code (char-code char)))
1137         (declare (type (mod #x110000) code))
1138         (cond ((< code #x80)
1139                (funcall write-function stream code)
1140                1)
1141               ((< code #x800)
1142                (let* ((y (ldb (byte 5 6) code))
1143                       (z (ldb (byte 6 0) code)))
1144                  (declare (fixnum y z))
1145                  (funcall write-function stream (logior #xc0 y))
1146                  (funcall write-function stream (logior #x80 z))
1147                  2))
1148               ((< code #x10000)
1149                (let* ((x (ldb (byte 4 12) code))
1150                       (y (ldb (byte 6 6) code))
1151                       (z (ldb (byte 6 0) code)))
1152                  (declare (fixnum x y z))
1153                  (funcall write-function stream (logior #xe0 x))
1154                  (funcall write-function stream (logior #x80 y))
1155                  (funcall write-function stream (logior #x80 z))
1156                  3))
1157               (t
1158                (let* ((w (ldb (byte 3 18) code))
1159                       (x (ldb (byte 6 12) code))
1160                       (y (ldb (byte 6 6) code))
1161                       (z (ldb (byte 6 0) code)))
1162                  (declare (fixnum w x y z))
1163                  (funcall write-function stream (logior #xf0 w))
1164                  (funcall write-function stream (logior #x80 x))
1165                  (funcall write-function stream (logior #x80 y))
1166                  (funcall write-function stream (logior #x80 z))
1167                  4))))))
1168    :stream-decode-function
1169    (nfunction
1170     utf-8-stream-decode
1171     (lambda (1st-unit next-unit-function stream)
1172       (declare (type (unsigned-byte 8) 1st-unit))
1173       (if (< 1st-unit #x80)
1174         (code-char 1st-unit)
1175         (if (>= 1st-unit #xc2)
1176           (let* ((s1 (funcall next-unit-function stream)))
1177             (if (eq s1 :eof)
1178               s1
1179               (locally
1180                   (declare (type (unsigned-byte 8) s1))
1181                 (if (< 1st-unit #xe0)
1182                   (if (< (the fixnum (logxor s1 #x80)) #x40)
1183                     (code-char
1184                      (logior
1185                       (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
1186                       (the fixnum (logxor s1 #x80))))
1187                     (note-stream-decoding-problem stream))
1188                   (let* ((s2 (funcall next-unit-function stream)))
1189                     (if (eq s2 :eof)
1190                       s2
1191                       (locally
1192                           (declare (type (unsigned-byte 8) s2))
1193                         (if (< 1st-unit #xf0)
1194                           (if (and (< (the fixnum (logxor s1 #x80)) #x40)
1195                                    (< (the fixnum (logxor s2 #x80)) #x40)
1196                                    (or (>= 1st-unit #xe1)
1197                                        (>= s1 #xa0)))
1198                             (or (code-char (the fixnum
1199                                          (logior (the fixnum
1200                                                    (ash (the fixnum (logand 1st-unit #xf))
1201                                                         12))
1202                                                  (the fixnum
1203                                                    (logior
1204                                                     (the fixnum
1205                                                       (ash (the fixnum (logand s1 #x3f))
1206                                                            6))
1207                                                     (the fixnum (logand s2 #x3f)))))))
1208                                 (note-stream-decoding-problem stream))
1209                             (note-stream-decoding-problem stream))
1210                           (if (< 1st-unit #xf8)
1211                             (let* ((s3 (funcall next-unit-function stream)))
1212                               (if (eq s3 :eof)
1213                                 s3
1214                                 (locally
1215                                     (declare (type (unsigned-byte 8) s3))
1216                                   (if (and (< (the fixnum (logxor s1 #x80)) #x40)
1217                                            (< (the fixnum (logxor s2 #x80)) #x40)
1218                                            (< (the fixnum (logxor s3 #x80)) #x40)
1219                                            (or (>= 1st-unit #xf1)
1220                                                (>= s1 #x90)))
1221                                     (code-char
1222                                      (logior
1223                                       (the fixnum
1224                                         (logior
1225                                          (the fixnum
1226                                            (ash (the fixnum (logand 1st-unit 7)) 18))
1227                                          (the fixnum
1228                                            (ash (the fixnum (logxor s1 #x80)) 12))))
1229                                       (the fixnum
1230                                         (logior
1231                                          (the fixnum
1232                                            (ash (the fixnum (logxor s2 #x80)) 6))
1233                                          (the fixnum (logxor s3 #x80))))))
1234
1235
1236                                     (note-stream-decoding-problem stream)))))
1237                             (note-stream-decoding-problem stream))))))))))
1238           (note-stream-decoding-problem stream)))))
1239    :vector-encode-function
1240    (nfunction
1241     utf-8-vector-encode
1242     (lambda (string vector idx start end)
1243       (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1244                (fixnum idx))
1245       (do* ((i start (1+ i)))
1246            ((>= i end) idx)
1247         (let* ((char (schar string i))
1248                (code (char-code char)))
1249           (declare (type (mod #x110000) code))
1250           (cond ((< code #x80)
1251                  (setf (aref vector idx) code)
1252                  (incf idx))
1253                 ((< code #x800)
1254                  (setf (aref vector idx)
1255                        (logior #xc0 (the fixnum (ash code -6))))
1256                  (setf (aref vector (the fixnum (1+ idx)))
1257                        (logior #x80 (the fixnum (logand code #x3f))))
1258                  (incf idx 2))
1259                 ((< code #x10000)
1260                  (setf (aref vector idx)
1261                        (logior #xe0 (the fixnum (ash code -12))))
1262                  (setf (aref vector (the fixnum (1+ idx)))
1263                        (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
1264                  (setf (aref vector (the fixnum (+ idx 2)))
1265                        (logior #x80 (the fixnum (logand code #x3f))))
1266                  (incf idx 3))
1267                 (t
1268                   (setf (aref vector idx)
1269                         (logior #xf0
1270                                 (the fixnum (logand #x7 (the fixnum (ash code -18))))))
1271                   (setf (aref vector (the fixnum (1+ idx)))
1272                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
1273                   (setf (aref vector (the fixnum (+ idx 2)))
1274                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
1275                   (setf (aref vector (the fixnum (+ idx 3)))
1276                         (logior #x80 (logand #x3f code)))
1277                   (incf idx 4)))))))
1278    :vector-decode-function
1279    (nfunction
1280     utf-8-vector-decode
1281     (lambda (vector idx noctets string)
1282       (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1283                (type index idx))
1284       (do* ((i 0 (1+ i))
1285             (end (+ idx noctets))
1286             (index idx (1+ index)))
1287            ((= index end) index)
1288           (let* ((1st-unit (aref vector index)))
1289             (declare (type (unsigned-byte 8) 1st-unit))
1290             (let* ((char 
1291                     (if (< 1st-unit #x80)
1292                       (code-char 1st-unit)
1293                       (if (>= 1st-unit #xc2)
1294                           (let* ((2nd-unit (aref vector (incf index))))
1295                             (declare (type (unsigned-byte 8) 2nd-unit))
1296                             (if (< 1st-unit #xe0)
1297                               (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
1298                                 (code-char
1299                                  (logior
1300                                   (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
1301                                   (the fixnum (logxor 2nd-unit #x80)))))
1302                               (let* ((3rd-unit (aref vector (incf index))))
1303                                 (declare (type (unsigned-byte 8) 3rd-unit))
1304                                 (if (< 1st-unit #xf0)
1305                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
1306                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
1307                                            (or (>= 1st-unit #xe1)
1308                                                (>= 2nd-unit #xa0)))
1309                                     (code-char (the fixnum
1310                                                  (logior (the fixnum
1311                                                            (ash (the fixnum (logand 1st-unit #xf))
1312                                                                 12))
1313                                                          (the fixnum
1314                                                            (logior
1315                                                             (the fixnum
1316                                                               (ash (the fixnum (logand 2nd-unit #x3f))
1317                                                                    6))
1318                                                             (the fixnum (logand 3rd-unit #x3f))))))))
1319                                   (let* ((4th-unit (aref vector (incf index))))
1320                                     (declare (type (unsigned-byte 8) 4th-unit))
1321                                     (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
1322                                              (< (the fixnum (logxor 3rd-unit #x80)) #x40)
1323                                              (< (the fixnum (logxor 4th-unit #x80)) #x40)
1324                                              (or (>= 1st-unit #xf1)
1325                                                  (>= 2nd-unit #x90)))
1326                                       (code-char
1327                                        (logior
1328                                         (the fixnum
1329                                           (logior
1330                                            (the fixnum
1331                                              (ash (the fixnum (logand 1st-unit 7)) 18))
1332                                            (the fixnum
1333                                              (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
1334                                         (the fixnum
1335                                           (logior
1336                                            (the fixnum
1337                                              (ash (the fixnum (logxor 3rd-unit #x80)) 6))
1338                                            (the fixnum (logxor 4th-unit #x80))))))))))))))))
1339               (setf (schar string i) (or char (note-vector-decoding-problem vector index :utf-8))))))))
1340    :memory-encode-function
1341    #'utf-8-memory-encode
1342    :memory-decode-function
1343    #'utf-8-memory-decode
1344    :octets-in-string-function
1345    #'utf-8-octets-in-string
1346    :length-of-vector-encoding-function
1347    (nfunction
1348     utf-8-length-of-vector-encoding
1349     (lambda (vector start end)
1350       (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1351       (do* ((i start)
1352             (nchars 0))
1353            ((>= i end)
1354             (values nchars i))
1355         (declare (fixnum i))
1356         (let* ((code (aref vector i))
1357                (nexti (+ i (cond ((< code #xc2) 1)
1358                                  ((< code #xe0) 2)
1359                                  ((< code #xf0) 3)
1360                                  ((< code #xf8) 4)
1361                                  (t 1)))))
1362           (declare (type (unsigned-byte 8) code))
1363           (if (> nexti end)
1364             (return (values nchars i))
1365             (setq nchars (1+ nchars) i nexti))))))
1366    :length-of-memory-encoding-function
1367    #'utf-8-length-of-memory-encoding
1368    :decode-literal-code-unit-limit #x80
1369    :encode-literal-char-code-limit #x80   
1370    :bom-encoding #(#xef #xbb #xbf)
1371    :character-size-in-octets-function  (lambda (c)
1372                                          (let* ((code (char-code c)))
1373                                            (declare (type (mod #x110000) code))
1374                                            (if (< code #x80)
1375                                              1
1376                                              (if (< code #x800)
1377                                                2
1378                                                (if (< code #x10000)
1379                                                  3
1380                                                  4)))))
1381     
1382    )
1383
1384
1385;;; For a code-unit-size greater than 8: the stream-encode function's write-function
1386;;; accepts a code-unit in native byte order and swaps it if necessary and the
1387;;; stream-decode function receives a first-unit in native byte order and its
1388;;; next-unit-function returns a unit in native byte order.  The memory/vector
1389;;; functions have to do their own byte swapping.
1390
1391
1392(defmacro utf-16-combine-surrogate-pairs (a b)
1393  `(code-char
1394    (the (unsigned-byte 21)
1395      (+ #x10000
1396         (the (unsigned-byte 20)
1397           (logior
1398            (the (unsigned-byte 20) (ash (the (unsigned-byte 10)
1399                                           (- ,a #xd800))
1400                                         10))
1401            (the (unsigned-byte 10) (- ,b #xdc00))))))))
1402   
1403(defun utf-16-stream-encode (char write-function stream)
1404  (let* ((code (char-code char))
1405         (highbits (- code #x10000)))
1406    (declare (type (mod #x110000) code)
1407             (fixnum highbits))
1408    (if (< highbits 0)
1409      (progn
1410        (funcall write-function stream code)
1411        1)
1412      (progn
1413        (funcall write-function stream (logior #xd800 (the fixnum (ash highbits -10))))
1414        (funcall write-function stream (logior #xdc00 (the fixnum (logand highbits #x3ff))))
1415        2))))
1416
1417(defun utf-16-stream-decode (1st-unit next-unit-function stream)
1418  (declare (type (unsigned-byte 16) 1st-unit))
1419  (if (or (< 1st-unit #xd800)
1420          (>= 1st-unit #xe000))
1421    (code-char 1st-unit)
1422    (if (< 1st-unit #xdc00)
1423      (let* ((2nd-unit (funcall next-unit-function stream)))
1424        (if (eq 2nd-unit :eof)
1425          2nd-unit
1426          (locally (declare (type (unsigned-byte 16) 2nd-unit))
1427            (if (and (>= 2nd-unit #xdc00)
1428                     (< 2nd-unit #xe000))
1429              (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)
1430              (note-stream-decoding-problem stream)))))
1431      (note-stream-decoding-problem stream))))
1432
1433
1434
1435(declaim (inline %big-endian-u8-ref-u16 %little-endian-u8-ref-u16))
1436(defun %big-endian-u8-ref-u16 (u8-vector idx)
1437  (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector)
1438           (fixnum idx))
1439  (logior (the (unsigned-byte 16) (ash (the (unsigned-byte 8) (aref u8-vector idx)) 8))
1440          (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx))))))
1441
1442(defun %little-endian-u8-ref-u16 (u8-vector idx)
1443  (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector)
1444           (fixnum idx))
1445  (logior (the (unsigned-byte 16) (ash (the (unsigned-byte 8)
1446                                         (aref u8-vector (the fixnum (1+ idx)))) 8))
1447          (the (unsigned-byte 8) (aref u8-vector idx))))
1448
1449#+big-endian-target
1450(progn
1451(defmacro %native-u8-ref-u16 (vector idx)
1452  `(%big-endian-u8-ref-u16 ,vector ,idx))
1453
1454(defmacro %reversed-u8-ref-u16 (vector idx)
1455  `(%little-endian-u8-ref-u16 ,vector ,idx))
1456)
1457
1458#+little-endian-target
1459(progn
1460(defmacro %native-u8-ref-u16 (vector idx)
1461  `(%little-endian-u8-ref-u16 ,vector ,idx))
1462
1463(defmacro %reversed-u8-ref-u16 (vector idx)
1464  `(%big-endian-u8-ref-u16 ,vector ,idx))
1465)
1466
1467
1468(declaim (inline (setf %big-endian-u8-ref-u16) (setf %little-endian-u8-ref-u16)))
1469(defun (setf %big-endian-u8-ref-u16) (val u8-vector idx)
1470  (declare (type (unsigned-byte 16) val)
1471           (type (simple-array (unsigned-byte 8) (*)) u8-vector)
1472           (fixnum idx))
1473  (setf (aref u8-vector idx) (ldb (byte 8 8) val)
1474        (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 0) val))
1475  val)
1476
1477(defun (setf %little-endian-u8-ref-u16) (val u8-vector idx)
1478  (declare (type (unsigned-byte 16) val)
1479           (type (simple-array (unsigned-byte 8) (*)) u8-vector)
1480           (fixnum idx))
1481  (setf (aref u8-vector idx) (ldb (byte 8 0) val)
1482        (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 8) val))
1483  val)
1484
1485(defun utf-16-character-size-in-octets (c)
1486  (let* ((code (char-code c)))
1487    (declare (type (mod #x110000) code))
1488    (if (< code #x10000)
1489      2
1490      4)))
1491
1492;;; utf-16, native byte order.
1493(define-character-encoding #+big-endian-target :utf-16be #-big-endian-target :utf-16le
1494    #+big-endian-target
1495    "A 16-bit, variable-length encoding in which characters with
1496CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
1497big-endian word and characters with larger codes can be encoded in a
1498pair of 16-bit big-endian words.  The endianness of the encoded data
1499is implicit in the encoding; byte-order-mark characters are not
1500interpreted on input or prepended to output."
1501    #+little-endian-target
1502    "A 16-bit, variable-length encoding in which characters with
1503CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
1504little-endian word and characters with larger codes can be encoded in
1505a pair of 16-bit little-endian words.  The endianness of the encoded
1506data is implicit in the encoding; byte-order-mark characters are not
1507interpreted on input or prepended to output."
1508    :max-units-per-char 2
1509    :code-unit-size 16
1510    :native-endianness t
1511    :stream-encode-function
1512    #'utf-16-stream-encode
1513    :stream-decode-function
1514    #'utf-16-stream-decode
1515    :vector-encode-function
1516    (nfunction
1517     native-utf-16-vector-encode
1518     (lambda (string vector idx start end)
1519       (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1520                (fixnum idx start end))
1521       (do* ((i start (1+ i)))
1522            ((>= i end) idx)
1523         (declare (fixnum i))
1524         (let* ((char (schar string i))
1525                (code (char-code char))
1526                (highbits (- code #x10000)))
1527           (declare (type (mod #x110000) code)
1528                    (fixnum highbits))
1529           (cond ((< highbits 0)
1530                  (setf (%native-u8-ref-u16 vector idx) code)
1531                  (incf idx 2))
1532                 (t
1533                  (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10))))
1534                         (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
1535                    (declare (type (unsigned-byte 16) firstword secondword))
1536                    (setf (%native-u8-ref-u16 vector idx) firstword
1537                          (%native-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword)
1538                    (incf idx 4))))))))
1539    :vector-decode-function
1540    (nfunction
1541     native-utf-16-vector-decode
1542     (lambda (vector idx noctets string)
1543       (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1544                (type index idx))
1545       (do* ((i 0 (1+ i))
1546             (end (+ idx noctets))
1547             (index idx))
1548            ((= index end) index)
1549         (declare (fixnum i end index))
1550         (let* ((1st-unit (%native-u8-ref-u16 vector index)))
1551           (declare (type (unsigned-byte 16) 1st-unit))
1552           (incf index 2)
1553           (let* ((char
1554                   (if (or (< 1st-unit #xd800)
1555                           (>= 1st-unit #xe000))
1556                     (code-char 1st-unit)
1557                     (if (< 1st-unit #xdc00)
1558                       (let* ((2nd-unit (%native-u8-ref-u16 vector index)))
1559                         (declare (type (unsigned-byte 16) 2nd-unit))
1560                         (incf index 2)
1561                         (if (and (>= 2nd-unit #xdc00)
1562                                  (< 2nd-unit #xe000))
1563                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
1564             (setf (schar string i) (or char (note-vector-decoding-problem vector index #+big-endian-target :utf-16be #-big-endian-target :utf-16le))))))))
1565    :memory-encode-function
1566    (nfunction
1567     native-utf-16-memory-encode
1568     (lambda (string pointer idx start end)
1569       (declare (fixnum idx))
1570       (do* ((i start (1+ i)))
1571            ((>= i end) idx)
1572         (let* ((code (char-code (schar string i)))
1573                (highbits (- code #x10000)))
1574           (declare (type (mod #x110000) code)
1575                  (fixnum  highbits))
1576         (cond ((< highbits 0)
1577                (setf (%get-unsigned-word pointer idx) code)
1578                (incf idx 2))
1579               (t
1580                (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10))))
1581                (incf idx 2)
1582                (setf (%get-unsigned-word pointer idx) (logior #xdc00 (the fixnum (logand highbits #x3ff))))
1583                (incf idx 2)))))))
1584    :memory-decode-function
1585    (nfunction
1586     native-utf-16-memory-decode
1587     (lambda (pointer noctets idx string)
1588       (declare (fixnum noctets idx))
1589       (do* ((i 0 (1+ i))
1590             (end (+ idx noctets))
1591             (index idx))
1592            ((>= index end) index)
1593         (declare (fixnum i index end))
1594         (let* ((1st-unit (%get-unsigned-word pointer index)))
1595           (declare (type (unsigned-byte 16) 1st-unit))
1596           (incf index 2)
1597           (let* ((char
1598                   (if (or (< 1st-unit #xd800)
1599                           (>= 1st-unit #xe000))
1600                     (code-char 1st-unit)
1601                     (if (< 1st-unit #xdc00)
1602                       (let* ((2nd-unit (%get-unsigned-word pointer index)))
1603                           (declare (type (unsigned-byte 16) 2nd-unit))
1604                           (incf index)
1605                           (if (and (>= 2nd-unit #xdc00)
1606                                    (< 2nd-unit #xe000))
1607                             (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
1608            (setf (schar string i) (or char (note-vector-decoding-problem pointer index #+big-endian-target :utf-16be #-big-endian-target :utf-16le))))))))
1609    :octets-in-string-function
1610    #'utf-16-octets-in-string
1611    :length-of-vector-encoding-function
1612    (nfunction
1613     native-utf-16-length-of-vector-encoding
1614     (lambda (vector start end)
1615       (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1616       (declare (fixnum start end))
1617       (do* ((i start)
1618             (j (+ 2 i) (+ 2 i))
1619             (nchars 0))
1620            ((> j end) (values nchars i))
1621         (declare (fixnum i j nchars))
1622         (let* ((code (%native-u8-ref-u16 vector i))
1623                (nexti (+ i (if (or (< code #xd800)
1624                                    (>= code #xdc00))
1625                              2
1626                              4))))
1627           (declare (type (unsigned-byte 16) code)
1628                    (fixnum nexti))
1629           (if (> nexti end)
1630             (return (values nchars i))
1631             (setq i nexti nchars (1+ nchars)))))))
1632    :length-of-memory-encoding-function
1633    (nfunction
1634     native-utf-16-length-of-memory-encoding
1635     (lambda (pointer noctets start)
1636       (do* ((i start)
1637             (j (+ i 2) (+ i 2))
1638             (end (+ start noctets))
1639             (nchars 0))
1640            ((> j end) (values nchars i))
1641         (let* ((code (%get-unsigned-word pointer i))
1642                (nexti (+ i (if (or (< code #xd800)
1643                                    (>= code #xdc00))
1644                              2
1645                              4))))
1646           (declare (type (unsigned-byte 16) code)
1647                    (fixnum nexti))
1648           (if (> nexti end)
1649             (return (values nchars i))
1650             (setq i nexti nchars (1+ nchars)))))))
1651    :decode-literal-code-unit-limit #xd800 
1652    :encode-literal-char-code-limit #x10000
1653    :nul-encoding #(0 0)
1654    :character-size-in-octets-function 'utf-16-character-size-in-octets
1655    )
1656
1657;;; utf-16, reversed byte order
1658(define-character-encoding #+big-endian-target :utf-16le #-big-endian-target :utf-16be
1659   #+little-endian-target
1660   "A 16-bit, variable-length encoding in which characters with
1661CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
1662big-endian word and characters with larger codes can be encoded in a
1663pair of 16-bit big-endian words.  The endianness of the encoded data
1664is implicit in the encoding; byte-order-mark characters are not
1665interpreted on input or prepended to output."
1666  #+big-endian-target
1667  "A 16-bit, variable-length encoding in which characters with
1668CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
1669little-endian word and characters with larger codes can be encoded in
1670a pair of 16-bit little-endian words.  The endianness of the encoded
1671data is implicit in the encoding; byte-order-mark characters are not
1672interpreted on input or prepended to output."
1673  :max-units-per-char 2
1674  :code-unit-size 16
1675  :native-endianness nil
1676  :stream-encode-function
1677  #'utf-16-stream-encode
1678  :stream-decode-function
1679  #'utf-16-stream-decode
1680  :vector-encode-function
1681  (nfunction
1682   reversed-utf-16-vector-encode
1683   (lambda (string vector idx start end)
1684     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1685              (fixnum idx start end))
1686     (do* ((i start (1+ i)))
1687          ((>= i end) idx)
1688       (declare (fixnum i))
1689       (let* ((char (schar string i))
1690              (code (char-code char))
1691              (highbits (- code #x10000)))
1692         (declare (type (mod #x110000) code)
1693                  (fixnum highbits))
1694         (cond ((< highbits 0)
1695                (setf (%reversed-u8-ref-u16 vector idx) code)
1696                (incf idx 2))
1697               (t
1698                (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10))))
1699                       (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
1700                  (declare (type (unsigned-byte 16) firstword secondword))
1701                  (setf (%reversed-u8-ref-u16 vector idx) firstword
1702                        (%reversed-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword)
1703                  (incf idx 4))))))))
1704  :vector-decode-function
1705  (nfunction
1706   reversed-utf-16-vector-decode
1707   (lambda (vector idx noctets string)
1708     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1709              (type index idx))
1710     (do* ((i 0 (1+ i))
1711           (end (+ idx noctets))
1712           (index idx))
1713          ((= index end) index)
1714       (declare (fixnum i end index))
1715       (let* ((1st-unit (%reversed-u8-ref-u16 vector index)))
1716         (declare (type (unsigned-byte 16) 1st-unit))
1717         (incf index 2)
1718         (let* ((char
1719                 (if (or (< 1st-unit #xd800)
1720                         (>= 1st-unit #xe000))
1721                   (code-char 1st-unit)
1722                   (if (< 1st-unit #xdc00)
1723                     (let* ((2nd-unit (%reversed-u8-ref-u16 vector index)))
1724                       (declare (type (unsigned-byte 16) 2nd-unit))
1725                       (incf index 2)
1726                       (if (and (>= 2nd-unit #xdc00)
1727                                (< 2nd-unit #xe000))
1728                         (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
1729           (setf (schar string i) (or char (note-vector-decoding-problem vector index #+big-endian-target :utf-16le #-big-endian-target :utf-16be))))))))
1730  :memory-encode-function
1731  (nfunction
1732   reversed-utf-16-memory-encode
1733   (lambda (string pointer idx start end)
1734     (declare (fixnum idx))
1735     (do* ((i start (1+ i)))
1736          ((>= i end) idx)
1737       (let* ((code (char-code (schar string i)))
1738              (highbits (- code #x10000)))
1739         (declare (type (mod #x110000) code)
1740                  (fixnum  highbits))
1741         (cond ((< highbits 0)
1742                (setf (%get-unsigned-word pointer idx) (%swap-u16 code))
1743                (incf idx 2))
1744               (t
1745                (setf (%get-unsigned-word pointer idx) (%swap-u16 (logior #xd800 (the fixnum (ash highbits -10)))))
1746                (incf idx 2)
1747                (setf (%get-unsigned-word pointer idx) (%swap-u16 (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
1748                (incf idx 2)))))))
1749  :memory-decode-function
1750  (nfunction
1751   reversed-utf-16-memory-decode
1752   (lambda (pointer noctets idx string)
1753     (declare (fixnum noctets idx))
1754     (do* ((i 0 (1+ i))
1755           (end (+ idx noctets))
1756           (index idx))
1757          ((>= index end) index)
1758       (declare (fixnum i index end))
1759       (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index))))
1760         (declare (type (unsigned-byte 16) 1st-unit))
1761         (incf index 2)
1762         (let* ((char
1763                 (if (or (< 1st-unit #xd800)
1764                         (>= 1st-unit #xe000))
1765                   (code-char 1st-unit)
1766                   (if (< 1st-unit #xdc00)
1767                     (let* ((2nd-unit (%swap-u16 (%get-unsigned-word pointer index))))
1768                       (declare (type (unsigned-byte 16) 2nd-unit))
1769                       (incf index)
1770                       (if (and (>= 2nd-unit #xdc00)
1771                                (< 2nd-unit #xe000))
1772                         (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
1773           (setf (schar string i) (or char (note-vector-decoding-problem pointer index #+big-endian-target :utf-16le #-big-endian-target :utf-16be))))))))
1774  :octets-in-string-function
1775  #'utf-16-octets-in-string
1776  :length-of-vector-encoding-function
1777  (nfunction
1778   reversed-utf-16-length-of-vector-encoding
1779   (lambda (vector start end)
1780     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1781     (declare (fixnum start end))
1782     (do* ((i start)
1783           (j (+ 2 i) (+ 2 i))
1784           (nchars 0))
1785          ((> j end) (values nchars i))
1786       (declare (fixnum i j nchars))
1787       (let* ((code (%reversed-u8-ref-u16 vector i))
1788              (nexti (+ i (if (or (< code #xd800)
1789                                  (>= code #xdc00))
1790                            2
1791                            4))))
1792         (declare (type (unsigned-byte 16) code)
1793                  (fixnum nexti))
1794         (if (> nexti end)
1795           (return (values nchars i))
1796           (setq i nexti nchars (1+ nchars)))))))
1797  :length-of-memory-encoding-function
1798  (nfunction
1799   reversed-utf-16-length-of-memory-encoding
1800   (lambda (pointer noctets start)
1801     (do* ((i start)
1802           (j (+ i 2) (+ i 2))
1803           (end (+ start noctets))
1804           (nchars 0))
1805          ((> j end) (values nchars i))
1806       (let* ((code (%swap-u16 (%get-unsigned-word pointer i)))
1807              (nexti (+ i (if (or (< code #xd800)
1808                                  (>= code #xdc00))
1809                            2
1810                            4))))
1811         (declare (type (unsigned-byte 16) code)
1812                  (fixnum nexti))
1813         (if (> nexti end)
1814           (return (values nchars i))
1815           (setq i nexti nchars (1+ nchars)))))))
1816  :decode-literal-code-unit-limit #xd800
1817  :encode-literal-char-code-limit #x10000
1818  :nul-encoding #(0 0)
1819  :character-size-in-octets-function 'utf-16-character-size-in-octets
1820  )
1821
1822;;; UTF-16.  Memory and vector functions determine endianness of
1823;;; input by the presence of a byte-order mark (or swapped BOM)
1824;;; at the beginning of input, and assume big-endian order
1825;;; if this mark is missing; on output, a BOM is prepended and
1826;;; things are written in native byte order.
1827;;; The endianness of stream-io operations is determined by
1828;;; stream content; new output streams are written in native
1829;;; endianness with a BOM character prepended.  Input streams
1830;;; are read in native byte order if the initial character is
1831;;; a BOM, in reversed byte order if the initial character is
1832;;; a swapped BOM, and in big-endian order (per RFC 2781) if
1833;;; there is no BOM.
1834
1835(define-character-encoding :utf-16
1836    "A 16-bit, variable-length encoding in which characters with
1837CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
1838word and characters with larger codes can be encoded in a
1839pair of 16-bit words.  The endianness of the encoded data is
1840indicated by the endianness of a byte-order-mark character (#\u+feff)
1841prepended to the data; in the absence of such a character on input,
1842the data is assumed to be in big-endian order. Output is written
1843in native byte-order with a leading byte-order mark."   
1844  :max-units-per-char 2
1845  :code-unit-size 16
1846  :native-endianness t                  ;not necessarily true.
1847  :stream-encode-function
1848  #'utf-16-stream-encode
1849  :stream-decode-function
1850  #'utf-16-stream-decode
1851  :vector-encode-function
1852  (nfunction
1853   utf-16-vector-encode
1854   (lambda (string vector idx start end)
1855     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1856              (fixnum idx))
1857     (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code)
1858     (incf idx 2)
1859     (do* ((i start (1+ i)))
1860            ((>= i end) idx)
1861         (declare (fixnum i))
1862         (let* ((char (schar string i))
1863                (code (char-code char))
1864                (highbits (- code #x10000)))
1865           (declare (type (mod #x110000) code)
1866                    (fixnum highbits))
1867           (cond ((< highbits 0)
1868                  (setf (%native-u8-ref-u16 vector idx) code)
1869                  (incf idx 2))
1870                 (t
1871                  (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10))))
1872                         (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
1873                    (declare (type (unsigned-byte 16) firstword secondword))
1874                    (setf (%native-u8-ref-u16 vector idx) firstword
1875                          (%native-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword)
1876                    (incf idx 4))))))))
1877  :vector-decode-function
1878  (nfunction
1879   utf-16-vector-decode 
1880   (lambda (vector idx noctets string)
1881     (declare (type (simple-array (unsigned-byte 16) (*)) vector)
1882              (type index idx))
1883     (let* ((origin idx)
1884            (swap (if (>= noctets 2)
1885                    (case (%native-u8-ref-u16 vector idx)
1886                      (#.byte-order-mark-char-code
1887                       (incf idx 2) nil)
1888                      (#.swapped-byte-order-mark-char-code
1889                       (incf idx 2) t)
1890                      (t #+little-endian-target t)))))
1891       (do* ((i 0 (1+ i))
1892             (end (+ origin noctets))
1893             (index idx))
1894            ((= index end) index)
1895         (declare (fixnum i end index))
1896         (let* ((1st-unit (if swap
1897                            (%reversed-u8-ref-u16 vector index)
1898                            (%native-u8-ref-u16 vector index))))
1899           (declare (type (unsigned-byte 16) 1st-unit))
1900           (incf index 2)
1901           (let* ((char
1902                   (if (or (< 1st-unit #xd800)
1903                           (>= 1st-unit #xe000))
1904                     (code-char 1st-unit)
1905                     (if (< 1st-unit #xdc00)
1906                       (let* ((2nd-unit (if swap
1907                                          (%reversed-u8-ref-u16 vector index)
1908                                          (%native-u8-ref-u16 vector index))))
1909                         (declare (type (unsigned-byte 16) 2nd-unit))
1910                         (incf index 2)
1911                         (if (and (>= 2nd-unit #xdc00)
1912                                  (< 2nd-unit #xe000))
1913                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
1914             (setf (schar string i) (or char (note-vector-decoding-problem vector index :utf-16)))))))))
1915  :memory-encode-function
1916  (nfunction
1917   utf-16-memory-encode
1918   (lambda (string pointer idx start end)
1919     (declare (fixnum idx))
1920     ;; Output a BOM.
1921     (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code)
1922     (incf idx 2)
1923     (do* ((i start (1+ i)))
1924          ((>= i end) idx)
1925       (let* ((code (char-code (schar string i)))
1926              (highbits (- code #x10000)))
1927         (declare (type (mod #x110000) code)
1928                  (fixnum highbits))
1929         (cond ((< highbits 0)
1930                (setf (%get-unsigned-word pointer idx) code)
1931                (incf idx 2))
1932               (t
1933                (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10))))
1934                (setf (%get-unsigned-word pointer (the fixnum (+ idx 2)))
1935                      (logior #xdc00 (the fixnum (logand highbits #x3ff))))
1936                (incf idx 4)))))))
1937  :memory-decode-function
1938  (nfunction
1939   utf-16-memory-decode
1940   (lambda (pointer noctets idx string)
1941     (declare (fixnum noctets idx))
1942     (let* ((swap (when (> noctets 1)
1943                    (case (%get-unsigned-word pointer idx)
1944                      (#.byte-order-mark-char-code
1945                       (incf idx 2)
1946                       (decf noctets 2)
1947                       nil)
1948                      (#.swapped-byte-order-mark-char-code
1949                       (incf idx 2)
1950                       (decf noctets 2)
1951                       t)
1952                      (t #+little-endian-target t)))))
1953       (do* ((i 0 (1+ i))
1954             (end (+ idx noctets))
1955             (index idx ))
1956            ((>= index end) index)
1957         (declare (fixnum i index end))
1958         (let* ((1st-unit (%get-unsigned-word pointer index)))
1959           (declare (type (unsigned-byte 16) 1st-unit))
1960           (incf index 2)
1961           (if swap (setq 1st-unit (%swap-u16 1st-unit)))
1962           (let* ((char
1963                   (if (or (< 1st-unit #xd800)
1964                           (>= 1st-unit #xe000))
1965                     (code-char 1st-unit)
1966                     (if (< 1st-unit #xdc00)
1967                       (let* ((2nd-unit (%get-unsigned-byte pointer index)))
1968                         (declare (type (unsigned-byte 16) 2nd-unit))
1969                         (if swap (setq 2nd-unit (%swap-u16 2nd-unit)))
1970                         (incf index 2)
1971                         (if (and (>= 2nd-unit #xdc00)
1972                                  (< 2nd-unit #xe000))
1973                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
1974             (setf (schar string i) (or char (note-vector-decoding-problem pointer index :utf-16)))))))))
1975  :octets-in-string-function
1976  (nfunction
1977   utf-16-bom-octets-in-string
1978   (lambda (string start end)
1979     (+ 2 (utf-16-octets-in-string string start end))))
1980  :length-of-vector-encoding-function
1981  (nfunction
1982   utf-16-length-of-vector-encoding
1983   (lambda (vector start end)
1984     (declare (type (simple-array (unsigned-byte 16) (*)) vector))
1985     (let* ((swap (when (>= end (+ start 2))
1986                    (case (%native-u8-ref-u16 vector start)
1987                      (#.byte-order-mark-char-code
1988                       (incf start 2)
1989                       nil)
1990                      (#.swapped-byte-order-mark-char-code
1991                       (incf start 2)
1992                       t)
1993                      (t #+little-endian-target t)))))
1994       (do* ((i start)
1995             (j (+ 2 i) (+ 2 j))
1996             (nchars 0))
1997            ((> j end)
1998             (values nchars i))
1999         (let* ((code (if swap
2000                        (%reversed-u8-ref-u16 vector i)
2001                        (%native-u8-ref-u16 vector i)))
2002                (nexti (+ i (if (or (< code #xd800)
2003                                    (>= code #xdc00))
2004                              2
2005                              4))))
2006           (declare (type (unsigned-byte 16) code)
2007                    (fixnum nexti))
2008           (if (> nexti end)
2009             (return (values nchars i))
2010             (setq i nexti nchars (1+ nchars))))))))
2011  :length-of-memory-encoding-function
2012  (nfunction
2013   utf-16-length-of-memory-encoding
2014   (lambda (pointer noctets start)
2015     (declare (fixnum noctets start))
2016     (when (oddp noctets)
2017       (setq noctets (1- noctets)))
2018     (let* ((origin start)
2019            (swap (when (>= noctets 2)
2020                    (case (%get-unsigned-word pointer (+ start start))
2021                      (#.byte-order-mark-char-code
2022                       (incf start 2)
2023                       nil)
2024                      (#.swapped-byte-order-mark-char-code
2025                       (incf start 2)
2026                       t)
2027                      (t #+little-endian-target t)))))
2028       (declare (fixnum origin))
2029       (do* ((i start)
2030             (j (+ i 2) (+ i 2))
2031             (end (+ origin noctets))
2032             (nchars 0 (1+ nchars)))
2033            ((> j end) (values nchars (- i origin)))
2034         (declare (fixnum i j end nchars))
2035         (let* ((code (%get-unsigned-word pointer i)))
2036           (declare (type (unsigned-byte 16) code))
2037           (if swap (setq code (%swap-u16 code)))
2038           (let* ((nexti (+ i (if (or (< code #xd800)
2039                                      (>= code #xdc00))
2040                                2
2041                                4))))
2042             (declare (fixnum nexti))
2043             (if (> nexti end)
2044               (return (values nchars (- i origin)))
2045               (setq i nexti))))))))
2046  :decode-literal-code-unit-limit #xd800
2047  :encode-literal-char-code-limit #x10000 
2048  :use-byte-order-mark
2049  #+big-endian-target :utf-16le
2050  #+little-endian-target :utf-16be
2051  :bom-encoding #+big-endian-target #(#xfe #xff) #+little-endian-target #(#xff #xfe)
2052  :nul-encoding #(0 0)
2053  :character-size-in-octets-function 'utf-16-character-size-in-octets 
2054  )
2055
2056
2057(defun two-octets-per-character (c)
2058  (declare (ignore c))
2059  2)
2060
2061(defun ucs-2-stream-encode (char write-function stream)
2062  (let* ((code (char-code char)))
2063    (declare (type (mod #x110000) code))
2064    (if (>= code #x10000)
2065      (setq code (note-encoding-problem char stream :ucs-2 (char-code #\Replacement_Character))))
2066    (funcall write-function stream code)
2067    1))
2068
2069(defun ucs-2-stream-decode (1st-unit next-unit-function stream)
2070  (declare (type (unsigned-byte 16) 1st-unit)
2071           (ignore next-unit-function))
2072  ;; CODE-CHAR returns NIL on either half of a surrogate pair.
2073  (or (code-char 1st-unit)
2074      (note-stream-decoding-problem stream)))
2075
2076
2077(defun ucs-2-octets-in-string (string start end)
2078  (declare (ignore string))
2079  (if (>= end start)
2080    (* 2 (- end start))
2081    0))
2082
2083(defun ucs-2-length-of-vector-encoding (vector start end)
2084  (declare (ignore vector))
2085  (let* ((noctets (max (- end start) 0)))
2086    (values (ash noctets -1) (+ start (logandc2 noctets 1)))))
2087
2088(defun ucs-2-length-of-memory-encoding (pointer noctets start)
2089  (declare (ignore pointer start))
2090  (values (ash noctets -1) (logandc2 noctets 1)))
2091
2092
2093
2094;;; UCS-2, native byte order
2095(define-character-encoding #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le
2096  #+big-endian-target
2097  "A 16-bit, fixed-length encoding in which characters with
2098CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
2099big-endian word. The encoded data is implicitly big-endian;
2100byte-order-mark characters are not interpreted on input or prepended
2101to output."
2102  #+little-endian-target
2103  "A 16-bit, fixed-length encoding in which characters with
2104CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
2105little-endian word. The encoded data is implicitly little-endian;
2106byte-order-mark characters are not interpreted on input or prepended
2107to output."
2108  :max-units-per-char 1
2109  :code-unit-size 16
2110  :native-endianness t
2111  :stream-encode-function
2112  #'ucs-2-stream-encode
2113  :stream-decode-function
2114  #'ucs-2-stream-decode
2115  :vector-encode-function
2116  (nfunction
2117   native-ucs-2-vector-encode
2118   (lambda (string vector idx start end)
2119     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2120              (fixnum idx))
2121     (do* ((i start (1+ i)))
2122          ((>= i end) idx)
2123       (let* ((char (schar string i))
2124              (code (char-code char)))
2125         (declare (type (mod #x110000) code))
2126         (when (>= code #x10000)
2127           (setq code (note-encoding-problem char vector #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le (char-code #\Replacement_Character))))
2128         (setf (%native-u8-ref-u16 vector idx) code)
2129         (incf idx 2)))))
2130  :vector-decode-function
2131  (nfunction
2132   native-ucs-2-vector-decode
2133   (lambda (vector idx noctets string)
2134     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2135              (type index idx))
2136     (do* ((i 0 (1+ i))
2137           (end (+ idx noctets))
2138           (index idx (+ 2 index)))
2139          ((>= index end) index)
2140       (declare (fixnum i end index))
2141       (setf (schar string i)
2142             (or (code-char (%native-u8-ref-u16 vector index))
2143                 (note-vector-decoding-problem vector index  #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le))))))
2144  :memory-encode-function
2145  (nfunction
2146   native-ucs-2-memory-encode
2147   (lambda (string pointer idx start end)
2148     (declare (fixnum idx))
2149     (do* ((i start (1+ i)))
2150          ((>= i end) idx)
2151       (let* ((char (schar string i))
2152              (code (char-code char)))
2153         (declare (type (mod #x110000) code))
2154         (setf (%get-unsigned-word pointer idx)
2155                      (if (>= code #x10000)
2156                        (note-encoding-problem char pointer #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le (char-code #\Replacement_Character))
2157                        code))
2158         (incf idx 2)))))
2159  :memory-decode-function
2160  (nfunction
2161   native-ucs-2-memory-decode
2162   (lambda (pointer noctets idx string)
2163     (declare (fixnum noctets idx))
2164     (do* ((i 0 (1+ i))
2165           (index idx (+ index 2)))
2166          ((>= i noctets) index)
2167       (declare (fixnum i index))
2168       (let* ((1st-unit (%get-unsigned-word pointer index)))
2169         (declare (type (unsigned-byte 16) 1st-unit))
2170         (setf (schar string i) (or (char-code 1st-unit) (note-vector-decoding-problem pointer index  #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le)))))))
2171  :octets-in-string-function
2172  #'ucs-2-octets-in-string
2173  :length-of-vector-encoding-function
2174  #'ucs-2-length-of-vector-encoding
2175  :length-of-memory-encoding-function
2176  #'ucs-2-length-of-memory-encoding
2177  :decode-literal-code-unit-limit #x10000
2178  :encode-literal-char-code-limit #x10000 
2179  :nul-encoding #(0 0)
2180  :character-size-in-octets-function 'two-octets-per-character
2181  )
2182
2183;;; UCS-2, reversed byte order
2184(define-character-encoding #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be
2185  #+little-endian-target
2186  "A 16-bit, fixed-length encoding in which characters with
2187CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
2188big-endian word. The encoded data is implicitly big-endian;
2189byte-order-mark characters are not interpreted on input or prepended
2190to output."
2191  #+big-endian-target
2192  "A 16-bit, fixed-length encoding in which characters with
2193CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
2194
2195little-endian word. The encoded data is implicitly little-endian;
2196byte-order-mark characters are not interpreted on input or prepended
2197to output."
2198  :max-units-per-char 1
2199  :code-unit-size 16
2200  :native-endianness nil
2201  :stream-encode-function
2202  #'ucs-2-stream-encode
2203  :stream-decode-function
2204  #'ucs-2-stream-decode
2205  :vector-encode-function
2206  (nfunction
2207   reversed-ucs-2-vector-encode
2208   (lambda (string vector idx start end)
2209     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2210              (fixnum idx))
2211     (do* ((i start (1+ i)))
2212          ((>= i end) idx)
2213       (let* ((char (schar string i))
2214              (code (char-code char)))
2215         (declare (type (mod #x110000) code))
2216         (when (>= code #x10000)
2217           (setq code (note-encoding-problem char vector #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be (char-code #\Replacement_Character))))
2218         (setf (%reversed-u8-ref-u16 vector idx) code)
2219         (incf idx 2)))))
2220  :vector-decode-function
2221  (nfunction
2222   reversed-ucs-2-vector-decode
2223   (lambda (vector idx noctets string)
2224     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2225              (type index idx))
2226     (do* ((i 0 (1+ i))
2227           (end (+ idx noctets))
2228           (index idx (+ 2 index)))
2229          ((>= index end) index)
2230       (declare (fixnum i end index))
2231       (setf (schar string i)
2232             (or (code-char (%reversed-u8-ref-u16 vector index))
2233                 (note-vector-decoding-problem vector index #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be))))))
2234  :memory-encode-function
2235  (nfunction
2236   reversed-ucs-2-memory-encode
2237   (lambda (string pointer idx start end)
2238     (declare (fixnum idx))
2239     (do* ((i start (1+ i)))
2240          ((>= i end) idx)
2241       (let* ((char (schar string i))
2242              (code (char-code char)))
2243         (declare (type (mod #x110000) code))
2244         (setf (%get-unsigned-word pointer idx)
2245               (if (>= code #x10000)
2246                 (%swap-u16 (note-encoding-problem char pointer #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be (char-code #\Replacement_Character)))
2247                 (%swap-u16 code)))
2248         (incf idx 2)))))
2249  :memory-decode-function
2250  (nfunction
2251   reversed-ucs-2-memory-decode
2252   (lambda (pointer noctets idx string)
2253     (declare (fixnum noctets idx))
2254     (do* ((i 0 (1+ i))
2255           (index idx (+ index 2)))
2256          ((>= i noctets) index)
2257       (declare (fixnum i index))
2258       (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index))))
2259         (declare (type (unsigned-byte 16) 1st-unit))
2260         (setf (schar string i) (or (code-char 1st-unit) (note-vector-decoding-problem pointer index #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be)))))))
2261  :octets-in-string-function
2262  #'ucs-2-octets-in-string
2263  :length-of-vector-encoding-function
2264  #'ucs-2-length-of-vector-encoding
2265  :length-of-memory-encoding-function
2266  #'ucs-2-length-of-memory-encoding
2267  :decode-literal-code-unit-limit #x10000
2268  :encode-literal-char-code-limit #x10000
2269  :nul-encoding #(0 0)
2270  :character-size-in-octets-function 'two-octets-per-character
2271  )
2272
2273(define-character-encoding :ucs-2
2274    "A 16-bit, fixed-length encoding in which characters with
2275CHAR-CODEs less than #x10000 can be encoded in a single 16-bit word.
2276The endianness of the encoded data is indicated by the endianness of a
2277byte-order-mark character (#\u+feff) prepended to the data; in the
2278absence of such a character on input, the data is assumed to be in
2279big-endian order."
2280  :max-units-per-char 1
2281  :code-unit-size 16
2282  :native-endianness t                  ;not necessarily true.
2283  :stream-encode-function
2284  #'ucs-2-stream-encode
2285  :stream-decode-function
2286  #'ucs-2-stream-decode
2287  :vector-encode-function
2288  (nfunction
2289   ucs-2-vector-encode
2290   (lambda (string vector idx start end)
2291     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2292              (fixnum idx))
2293     (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code)
2294     (incf idx 2)
2295     (do* ((i start (1+ i)))
2296          ((>= i end) idx)
2297       (let* ((char (schar string i))
2298              (code (char-code char)))
2299         (declare (type (mod #x110000) code))
2300         (when (>= code #x10000)
2301           (setq code (note-encoding-problem char vector :ucs-2 (char-code #\Replacement_Character))))
2302         (setf (%native-u8-ref-u16 vector idx) code)
2303         (incf idx 2)))))
2304  :vector-decode-function
2305  (nfunction
2306   ucs-2-vector-decode 
2307   (lambda (vector idx noctets string)
2308     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2309              (type index idx)
2310              (fixnum noctets))
2311     (let* ((swap (if (> noctets 1)
2312                    (case (%native-u8-ref-u16 vector idx)
2313                      (#.byte-order-mark-char-code
2314                       (incf idx 2) (decf noctets 2) nil)
2315                      (#.swapped-byte-order-mark-char-code
2316                       (incf idx 2) (decf noctets 2) t)
2317                       (t #+little-endian-target t)))))
2318
2319       (do* ((i 0 (1+ i))
2320             (end (+ idx noctets))
2321             (index idx (1+ index)))
2322            ((>= index end) index)
2323         (declare (fixnum i end index))
2324         (let* ((1st-unit (if swap
2325                            (%reversed-u8-ref-u16 vector index)
2326                            (%native-u8-ref-u16 vector index))))
2327             (declare (type (unsigned-byte 16) 1st-unit))
2328             (setf (schar string i) (or (code-char 1st-unit)
2329                                        (note-vector-decoding-problem vector index :ucs-2))))))))
2330  :memory-encode-function
2331  (nfunction
2332   ucs-2-memory-encode
2333   (lambda (string pointer idx start end)
2334     (declare (fixnum idx))
2335     (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code)
2336     (incf idx 2)
2337     (do* ((i start (1+ i)))
2338          ((>= i end) idx)
2339       (let* ((char (schar string i))
2340              (code (char-code char)))
2341         (declare (type (mod #x110000) code))
2342         (setf (%get-unsigned-word pointer idx)
2343                      (if (>= code #x10000)
2344                        (note-encoding-problem char pointer :ucs-2 (char-code #\Replacement_Character))
2345                        code))
2346         (incf idx 2)))))
2347  :memory-decode-function
2348  (nfunction
2349   ucs-2-memory-decode
2350   (lambda (pointer noctets idx string)
2351     (declare (fixnum noctets idx))
2352     (let* ((swap (when (> noctets 1)
2353                    (case (%get-unsigned-word pointer idx)
2354                      (#.byte-order-mark-char-code
2355                       (incf idx 2)
2356                       (decf noctets 2)
2357                       nil)
2358                      (#.swapped-byte-order-mark-char-code
2359                       (incf idx 2)
2360                       (decf noctets 2)
2361                       t)
2362                      (t #+little-endian-target t)))))
2363       (do* ((i 0 (1+ i))
2364           (index idx (+ index 2)))
2365          ((>= i noctets) index)
2366       (declare (fixnum i index))
2367       (let* ((1st-unit (%get-unsigned-word pointer index)))
2368         (declare (type (unsigned-byte 16) 1st-unit))
2369         (if swap (setq 1st-unit (%swap-u16 1st-unit)))
2370         (setf (schar string i) (or (code-char 1st-unit)
2371                                    (note-vector-decoding-problem pointer index :ucs-2))))))))
2372  :octets-in-string-function
2373  (nfunction
2374   ucs-2-bom-octets-in-string
2375   (lambda (string start end)
2376     (+ 2 (ucs-2-octets-in-string string start end))))
2377  :length-of-vector-encoding-function
2378  (nfunction
2379   ucs-2-length-of-vector-encoding
2380   (lambda (vector start end)
2381     (declare (fixnum start end))
2382     (when (>= end (+ start 2))
2383       (let* ((maybe-bom (%native-u8-ref-u16 vector start)))
2384         (declare (type (unsigned-byte 16) maybe-bom))
2385         (when (or (= maybe-bom byte-order-mark-char-code)
2386                   (= maybe-bom swapped-byte-order-mark-char-code))
2387           (incf start 2))))
2388     (do* ((i start j)
2389           (j (+ i 2) (+ j 2))
2390           (nchars 0 (1+ nchars)))
2391          ((> j end) (values nchars i)))))
2392  :length-of-memory-encoding-function
2393  (nfunction
2394   ucs-2-length-of-memory-encoding
2395   (lambda (pointer noctets start)
2396     (let* ((skip 
2397             (when (> noctets 1)
2398               (case (%get-unsigned-word pointer start)
2399                 (#.byte-order-mark-char-code
2400                  2)
2401                 (#.swapped-byte-order-mark-char-code
2402                  2)))))
2403     (values (ash (- noctets skip) -1) (logandc2 noctets 1)))))
2404  :decode-literal-code-unit-limit #x10000
2405  :encode-literal-char-code-limit #x10000 
2406  :use-byte-order-mark
2407  #+big-endian-target :ucs-2le
2408  #+little-endian-target :ucs-2be
2409  :nul-encoding #(0 0)
2410  :character-size-in-octets-function 'two-octets-per-character
2411  )
2412
2413
2414(defun four-octets-per-character (c)
2415  (declare (ignore c))
2416  4)
2417
2418(defun ucs-4-stream-encode (char write-function stream)
2419  (let* ((code (char-code char)))
2420    (declare (type (mod #x110000) code))
2421    (funcall write-function stream code)
2422    1))
2423
2424(defun ucs-4-stream-decode (1st-unit next-unit-function stream)
2425  (declare (type (unsigned-byte 16) 1st-unit)
2426           (ignore next-unit-function stream))
2427  (code-char 1st-unit))
2428
2429
2430(defun ucs-4-octets-in-string (string start end)
2431  (declare (ignore string))
2432  (if (>= end start)
2433    (* 4 (- end start))
2434    0))
2435
2436
2437(declaim (inline %big-endian-u8-ref-u32 %little-endian-u8-ref-u32))
2438(defun %big-endian-u8-ref-u32 (u8-vector idx)
2439  (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector)
2440           (fixnum idx))
2441  (logior (the (unsigned-byte 32) (ash (the (unsigned-byte 8) (aref u8-vector idx)) 24))
2442          (the (unsigned-byte 24)
2443            (logior
2444             (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx)))) 16)
2445             (the (unsigned-byte 16)
2446               (logior
2447                (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 2)))) 8)
2448                (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 3))))))))))
2449
2450(defun %little-endian-u8-ref-u32 (u8-vector idx)
2451  (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector)
2452           (fixnum idx))
2453  (logior (the (unsigned-byte 32) (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 3)))) 24))
2454          (the (unsigned-byte 24)
2455            (logior
2456             (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 2)))) 16)
2457             (the (unsigned-byte 16)
2458               (logior
2459                (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx)))) 8)
2460                (the (unsigned-byte 8) (aref u8-vector (the fixnum idx)))))))))
2461
2462#+big-endian-target
2463(progn
2464(defmacro %native-u8-ref-u32 (vector idx)
2465  `(%big-endian-u8-ref-u32 ,vector ,idx))
2466
2467(defmacro %reversed-u8-ref-u32 (vector idx)
2468  `(%little-endian-u8-ref-u32 ,vector ,idx))
2469)
2470
2471#+little-endian-target
2472(progn
2473(defmacro %native-u8-ref-u32 (vector idx)
2474  `(%little-endian-u8-ref-u32 ,vector ,idx))
2475
2476(defmacro %reversed-u8-ref-u32 (vector idx)
2477  `(%big-endian-u8-ref-u32 ,vector ,idx))
2478)
2479
2480
2481(declaim (inline (setf %big-endian-u8-ref-32) (setf %little-endian-u8-ref-u32)))
2482(defun (setf %big-endian-u8-ref-u32) (val u8-vector idx)
2483  (declare (type (unsigned-byte 32) val)
2484           (type (simple-array (unsigned-byte 8) (*)) u8-vector)
2485           (fixnum idx))
2486  (setf (aref u8-vector idx) (ldb (byte 8 24) val)
2487        (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 16) val)
2488        (aref u8-vector (the fixnum (+ idx 2))) (ldb (byte 8 8) val)
2489        (aref u8-vector (the fixnum (+ idx 3))) (ldb (byte 8 0) val))
2490  val)
2491
2492(defun (setf %little-endian-u8-ref-u32) (val u8-vector idx)
2493  (declare (type (unsigned-byte 32) val)
2494           (type (simple-array (unsigned-byte 8) (*)) u8-vector)
2495           (fixnum idx))
2496  (setf (aref u8-vector idx) (ldb (byte 8 0) val)
2497        (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 8) val)
2498        (aref u8-vector (the fixnum (+ idx 2))) (ldb (byte 8 16) val)
2499        (aref u8-vector (the fixnum (+ idx 3))) (ldb (byte 8 24) val))
2500  val)
2501
2502
2503;;; UTF-32/UCS-4, native byte order
2504(define-character-encoding #+big-endian-target :utf-32be #-big-endian-target :utf-32le
2505  #+big-endian-target
2506  "A 32-bit, fixed-length encoding in which all Unicode characters
2507encoded in a single 32-bit word. The encoded data is implicitly big-endian;
2508byte-order-mark characters are not interpreted on input or prepended
2509to output."
2510  #+little-endian-target
2511  "A 32-bit, fixed-length encoding in which all Unicode characters can
2512encoded in a single 32-bit word. The encoded data is implicitly
2513little-endian; byte-order-mark characters are not interpreted on input
2514or prepended to output."
2515  :aliases #+big-endian-target '(:ucs-4be) #+little-endian-target '(:ucs-4le)
2516  :max-units-per-char 1
2517  :code-unit-size 32
2518  :native-endianness t
2519  :stream-encode-function
2520  #'ucs-4-stream-encode
2521  :Stream-decode-function
2522  #'ucs-4-stream-decode
2523  :vector-encode-function
2524  (nfunction
2525   native-ucs-4-vector-encode
2526   (lambda (string vector idx start end)
2527     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2528              (fixnum idx))
2529     (do* ((i start (1+ i)))
2530          ((>= i end) idx)
2531       (let* ((char (schar string i))
2532              (code (char-code char)))
2533         (declare (type (mod #x110000) code))
2534         (setf (%native-u8-ref-u32 vector idx) code)
2535         (incf idx 4)))))
2536  :vector-decode-function
2537  (nfunction
2538   native-ucs-4-vector-decode
2539   (lambda (vector idx noctets string)
2540     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2541              (type index idx))
2542     (do* ((i 0 (1+ i))
2543           (end (+ idx noctets))
2544           (index idx (+ 4 index)))
2545          ((>= index end) index)
2546       (declare (fixnum i end index))
2547       (let* ((code (%native-u8-ref-u32 vector index)))
2548         (declare (type (unsigned-byte 32) code))
2549         (setf (schar string i)
2550               (or (if (< code char-code-limit)
2551                      (code-char code))
2552                   (note-vector-decoding-problem vector index #+big-endian-target :utf-32be #-big-endian-target :utf-32le)))))))
2553  :memory-encode-function
2554  (nfunction
2555   native-ucs-4-memory-encode
2556   (lambda (string pointer idx start end)
2557     (declare (fixnum idx))
2558     (do* ((i start (1+ i)))
2559          ((>= i end) idx)
2560       (let* ((code (char-code (schar string i))))
2561         (declare (type (mod #x110000) code))
2562         (setf (%get-unsigned-long pointer idx) code)
2563         (incf idx 4)))))
2564  :memory-decode-function
2565  (nfunction
2566   native-ucs-4-memory-decode
2567   (lambda (pointer noctets idx string)
2568     (declare (fixnum noctets idx))
2569     (do* ((i 0 (1+ i))
2570           (index idx (+ index 4)))
2571          ((>= i noctets) index)
2572       (declare (fixnum i index))
2573       (let* ((1st-unit (%get-unsigned-long pointer index)))
2574         (declare (type (unsigned-byte 32) 1st-unit))
2575         (setf (schar string i) (or (if (< 1st-unit char-code-limit)
2576                                      (code-char 1st-unit))
2577                                    (note-vector-decoding-problem
2578                                     pointer index #+big-endian-target :utf-32be #-big-endian-target :utf-32le)))))))
2579  :octets-in-string-function
2580  #'ucs-4-octets-in-string
2581  :length-of-vector-encoding-function
2582  (nfunction
2583   native-ucs-4-length-of-vector-encoding
2584   (lambda (vector start end)
2585     (declare (ignore vector))
2586     (do* ((i start j)
2587           (j (+ i 4) (+ j 4))
2588           (nchars 0 (1+ nchars)))
2589          ((> j end) (values nchars i)))))
2590  :length-of-memory-encoding-function
2591  (nfunction
2592   native-ucs-4-length-of-memory-encoding
2593   (lambda (pointer noctets start)
2594     (declare (ignore pointer))
2595     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
2596  :decode-literal-code-unit-limit #x110000
2597  :encode-literal-char-code-limit #x110000
2598  :nul-encoding #(0 0 0 0)
2599  :character-size-in-octets-function 'four-octets-per-character
2600  )
2601
2602;;; UTF-32/UCS-4, reversed byte order
2603(define-character-encoding #+big-endian-target :utf-32le #-big-endian-target :utf-32be
2604  #+little-endian-target
2605  "A 32-bit, fixed-length encoding in which all Unicode characters
2606encoded in a single 32-bit word. The encoded data is implicitly big-endian;
2607byte-order-mark characters are not interpreted on input or prepended
2608to output."
2609  #+big-endian-target
2610  "A 32-bit, fixed-length encoding in which all Unicode characters can
2611encoded in a single 32-bit word. The encoded data is implicitly
2612little-endian; byte-order-mark characters are not interpreted on input
2613or prepended to output."
2614  :aliases #+big-endian-target '(:ucs-4le) #+little-endian-target '(:ucs-4be)
2615  :max-units-per-char 1
2616  :code-unit-size 32
2617  :native-endianness nil
2618  :stream-encode-function
2619  #'ucs-4-stream-encode
2620  :Stream-decode-function
2621  #'ucs-4-stream-decode
2622  :vector-encode-function
2623  (nfunction
2624   native-ucs-4-vector-encode
2625   (lambda (string vector idx start end)
2626     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2627              (fixnum idx))
2628     (do* ((i start (1+ i)))
2629          ((>= i end) idx)
2630       (let* ((char (schar string i))
2631              (code (char-code char)))
2632         (declare (type (mod #x110000) code))
2633         (setf (%reversed-u8-ref-u32 vector idx) code)
2634         (incf idx 4)))))
2635  :vector-decode-function
2636  (nfunction
2637   native-ucs-4-vector-decode
2638   (lambda (vector idx noctets string)
2639     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2640              (type index idx))
2641     (do* ((i 0 (1+ i))
2642           (end (+ idx noctets))
2643           (index idx (+ 4 index)))
2644          ((>= index end) index)
2645       (declare (fixnum i end index))
2646       (let* ((code (%reversed-u8-ref-u32 vector index)))
2647         (declare (type (unsigned-byte 32) code))
2648         (setf (schar string i)
2649               (or (if (< code char-code-limit)
2650                     (code-char code))
2651                   (note-vector-decoding-problem vector index #+big-endian-target :utf-32le #-big-endian-target :utf-32be)))))))
2652  :memory-encode-function
2653  (nfunction
2654   native-ucs-4-memory-encode
2655   (lambda (string pointer idx start end)
2656     (declare (fixnum idx))
2657     (do* ((i start (1+ i)))
2658          ((>= i end) idx)
2659       (let* ((code (char-code (schar string i))))
2660         (declare (type (mod #x110000) code))
2661         (setf (%get-unsigned-long pointer idx) (%swap-u32 code))
2662         (incf idx 4)))))
2663  :memory-decode-function
2664  (nfunction
2665   reversed-ucs-4-memory-decode
2666   (lambda (pointer noctets idx string)
2667     (declare (fixnum noctets idx))
2668     (do* ((i 0 (1+ i))
2669           (index idx (+ index 4)))
2670          ((>= i noctets) index)
2671       (declare (fixnum i index))
2672       (let* ((1st-unit (%swap-u32 (%get-unsigned-long pointer index))))
2673         (declare (type (unsigned-byte 32) 1st-unit))
2674         (setf (schar string i) (or (if (< 1st-unit char-code-limit)
2675                                      (code-char 1st-unit))
2676                                    (note-vector-decoding-problem pointer index #+big-endian-target :utf-32le #-big-endian-target :utf-32be)))))))
2677
2678  :octets-in-string-function
2679  #'ucs-4-octets-in-string
2680  :length-of-vector-encoding-function
2681  (nfunction
2682   reversed-ucs-4-length-of-vector-encoding
2683   (lambda (vector start end)
2684     (declare (ignore vector))
2685     (do* ((i start j)
2686           (j (+ i 4) (+ j 4))
2687           (nchars 0 (1+ nchars)))
2688          ((> j end) (values nchars i)))))
2689  :length-of-memory-encoding-function
2690  (nfunction
2691   reversed-ucs-4-length-of-memory-encoding
2692   (lambda (pointer noctets start)
2693     (declare (ignore pointer))
2694     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
2695  :decode-literal-code-unit-limit #x110000
2696  :encode-literal-char-code-limit #x110000
2697  :nul-encoding #(0 0 0 0) 
2698  :character-size-in-octets-function 'four-octets-per-character
2699  )
2700
2701(define-character-encoding :utf-32
2702    "A 32-bit, fixed-length encoding in which all Unicode characters
2703can be encoded in a single 32-bit word.  The endianness of the encoded
2704data is indicated by the endianness of a byte-order-mark
2705character (#\u+feff) prepended to the data; in the absence of such a
2706character on input, input data is assumed to be in big-endian order.
2707Output is written in native byte order with a leading byte-order
2708mark."
2709   
2710  :aliases '(:ucs-4)
2711  :max-units-per-char 1
2712  :code-unit-size 32
2713  :native-endianness t                  ;not necessarily true.
2714  :stream-encode-function
2715  #'ucs-4-stream-encode
2716  :stream-decode-function
2717  #'ucs-4-stream-decode
2718  :vector-encode-function
2719  (nfunction
2720   utf-32-vector-encode
2721   (lambda (string vector idx start end)
2722     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2723              (fixnum idx))
2724     (setf (%native-u8-ref-u32 vector idx) byte-order-mark-char-code)
2725     (incf idx 4)
2726     (do* ((i start (1+ i)))
2727          ((>= i end) idx)
2728       (let* ((char (schar string i))
2729              (code (char-code char)))
2730         (declare (type (mod #x110000) code))
2731         (setf (%native-u8-ref-u32 vector idx) code)
2732         (incf idx 4)))))
2733  :vector-decode-function
2734  (nfunction
2735   utf-32-vector-decode 
2736   (lambda (vector idx noctets string)
2737     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2738              (type index idx)
2739              (fixnum noctets))
2740     (let* ((swap (if (> noctets 3)
2741                    (case (%native-u8-ref-u32 vector idx)
2742                      (#.byte-order-mark-char-code
2743                       (incf idx 4) (decf noctets 4) nil)
2744                      (#.swapped-byte-order-mark-char-code
2745                       (incf idx 4) (decf noctets 4) t)
2746                       (t #+little-endian-target t)))))
2747
2748       (do* ((i 0 (1+ i))
2749             (end (+ idx noctets))
2750             (index idx (1+ index)))
2751            ((>= index end) index)
2752         (declare (fixnum i end index))
2753         (let* ((1st-unit (if swap
2754                            (%reversed-u8-ref-u32 vector index)
2755                            (%native-u8-ref-u32 vector index))))
2756             (declare (type (unsigned-byte 32) 1st-unit))
2757             (setf (schar string i) (or (if (< 1st-unit char-code-limit)
2758                                          (code-char 1st-unit))
2759                                        (note-vector-decoding-problem
2760                                         vector index :utf-32))))))))
2761  :memory-encode-function
2762  (nfunction
2763   utf-32-memory-encode
2764   (lambda (string pointer idx start end)
2765     (declare (fixnum idx))
2766     (setf (%get-unsigned-long pointer idx) byte-order-mark-char-code)
2767     (incf idx 4)
2768     (do* ((i start (1+ i)))
2769          ((>= i end) idx)
2770       (let* ((code (char-code (schar string i))))
2771         (declare (type (mod #x110000) code))
2772         (setf (%get-unsigned-long pointer idx) code)
2773         (incf idx 4)))))
2774  :memory-decode-function
2775  (nfunction
2776   utf-32-memory-decode
2777   (lambda (pointer noctets idx string)
2778     (declare (fixnum noctets idx))
2779     (let* ((swap (when (> noctets 3)
2780                    (case (%get-unsigned-long pointer idx)
2781                      (#.byte-order-mark-char-code
2782                       (incf idx 4)
2783                       (decf noctets 4)
2784                       nil)
2785                      (#.swapped-byte-order-mark-char-code
2786                       (incf idx 4)
2787                       (decf noctets 4)
2788                       t)
2789                      (t #+little-endian-target t)))))
2790       (do* ((i 0 (1+ i))
2791           (index idx (+ index 2)))
2792          ((>= i noctets) index)
2793       (declare (fixnum i index))
2794       (let* ((1st-unit (%get-unsigned-long pointer index)))
2795         (declare (type (unsigned-byte 32) 1st-unit))
2796         (if swap (setq 1st-unit (%swap-u32 1st-unit)))
2797         (setf (schar string i) (or (if (< 1st-unit char-code-limit)
2798                                      (code-char 1st-unit))
2799                                    (note-vector-decoding-problem
2800                                     pointer index :utf-32))))))))
2801  :octets-in-string-function
2802  (nfunction
2803   utf-32-bom-octets-in-string
2804   (lambda (string start end)
2805     (+ 4 (ucs-4-octets-in-string string start end))))
2806  :length-of-vector-encoding-function
2807  (nfunction
2808   utf-32-length-of-vector-encoding
2809   (lambda (vector start end)
2810     (when (>= end (+ start 4))
2811       (let* ((maybe-bom (%native-u8-ref-u32 vector start)))
2812         (declare (type (unsigned-byte 32) maybe-bom))
2813         (when (or (= maybe-bom byte-order-mark-char-code)
2814                   (= maybe-bom swapped-byte-order-mark-char-code))
2815           (incf start 4))))
2816     (do* ((i start j)
2817           (j (+ i 4) (+ J 4))
2818           (nchars 0 (1+ nchars)))
2819          ((> j end) (values nchars i)))))
2820  :length-of-memory-encoding-function
2821  (nfunction
2822   utf-32-length-of-memory-encoding
2823   (lambda (pointer noctets start)
2824     (when (> noctets 3)
2825       (case (%get-unsigned-long pointer )
2826         (#.byte-order-mark-char-code
2827          (incf start 4)
2828          (decf noctets 4))
2829         (#.swapped-byte-order-mark-char-code
2830          (incf start 4)
2831          (decf noctets 4))))
2832     (values (ash noctets -2) (+ start (logandc2 noctets 3)))))
2833  :decode-literal-code-unit-limit #x110000
2834  :encode-literal-char-code-limit #x110000 
2835  :use-byte-order-mark
2836  #+big-endian-target :utf-32le
2837  #+little-endian-target :utf-32be
2838  :bom-encoding #+big-endian-target #(#x00 #x00 #xfe #xff) #+little-endian-target #(#xff #xfe #x00 #x00)
2839  :nul-encoding #(0 0 0 0) 
2840  :character-size-in-octets-function 'four-octets-per-character
2841  )
2842
2843(defun list-character-encodings (&key include-aliases)
2844  "Return a list of the names of supported character encodings."
2845  (let ((names nil))
2846    (maphash #'(lambda (name enc)
2847                 (if (eq name (character-encoding-name enc))
2848                   (push name names)
2849                   (when include-aliases
2850                     (push name names))))
2851             *character-encodings*)
2852    names))
2853
2854(defun describe-character-encoding (name)
2855  (let* ((enc (lookup-character-encoding name)))
2856    (when enc
2857      (let* ((name (character-encoding-name enc))
2858             (doc (character-encoding-documentation enc))
2859             (aliases (character-encoding-aliases enc)))
2860        (format t "~&~s" name)
2861        (when (null (car aliases))
2862          (pop aliases))
2863        (when aliases
2864          (format t " [Aliases:~{ ~s~}]" aliases))
2865        (format t "~&~a~%~%"  doc)
2866        (values)))))
2867     
2868(defun describe-character-encodings ()
2869  (let* ((names (list-character-encodings)))
2870    (dolist (name (sort names #'string<) (values))
2871      (describe-character-encoding name))))
2872
2873(defmethod make-load-form ((c character-encoding) &optional environment)
2874  (declare (ignore environment))
2875  `(get-character-encoding ,(character-encoding-name c)))
2876
2877(defvar *native-newline-string* (make-string 1 :initial-element #\Newline))
2878(defvar *unicode-newline-string* (make-string 1 :initial-element #\Line_Separator))
2879(defvar *cr-newline-string* (make-string 1 :initial-element #\Return))
2880(defvar *crlf-newline-string* (make-array 2 :element-type 'character :initial-contents '(#\Return #\Linefeed)))
2881(defvar *nul-string* (make-string 1 :initial-element #\Nul))
2882
2883(defun string-size-in-octets (string &key
2884                                     (start 0)
2885                                     end
2886                                     (external-format :default)
2887                                     use-byte-order-mark)
2888  (setq end (check-sequence-bounds string start end))
2889  (let* ((ef (normalize-external-format t external-format)))
2890    (%string-size-in-octets string
2891                            start
2892                            end
2893                            (get-character-encoding
2894                             (external-format-character-encoding ef))
2895                            (cdr (assoc (external-format-line-termination ef)
2896                                        *canonical-line-termination-conventions*))
2897                            use-byte-order-mark)))
2898 
2899
2900(defun %string-size-in-octets (string start end encoding line-termination use-byte-order-mark) 
2901    (declare (fixnum start end))
2902    (multiple-value-bind (simple-string offset)
2903        (array-data-and-offset string)
2904      (declare (fixnum offset) (simple-string simple-string))
2905      (incf start offset)
2906      (incf end offset)
2907      (let* ((n (if use-byte-order-mark
2908                  (length (character-encoding-bom-encoding encoding))
2909                  0))
2910             (f (character-encoding-octets-in-string-function encoding))
2911             (nlpos (if line-termination
2912                      (position #\Newline simple-string :start start :end end))))
2913        (if (not nlpos)
2914          (+ n (funcall f simple-string start end))
2915          (let* ((nlstring (case line-termination
2916                             (:cr *cr-newline-string*)
2917                             (:crlf *crlf-newline-string*)
2918                             (:unicode *unicode-newline-string*)))
2919                 (nlstring-length (if (eq line-termination :crlf) 2 1)))
2920            (do* ()
2921                 ((null nlpos) (+ n (funcall f simple-string start end)))
2922              (unless (eql nlpos start)
2923                (incf n (funcall f simple-string start nlpos)))
2924              (incf n (funcall f nlstring 0 nlstring-length))
2925              (setq start (1+ nlpos)
2926                    nlpos (position #\Newline simple-string :start start :end end))))))))
2927
2928(defun encode-string-to-octets (string &key
2929                                       (start 0)
2930                                       end
2931                                       (external-format :default)
2932                                       use-byte-order-mark
2933                                       (vector nil vector-p)
2934                                       (vector-offset 0))
2935  (setq end (check-sequence-bounds string start end))
2936  (let* ((ef (normalize-external-format t external-format)) 
2937         (encoding (get-character-encoding
2938                    (external-format-character-encoding ef)))
2939         (line-termination (cdr (assoc (external-format-line-termination ef)
2940                                       *canonical-line-termination-conventions*)))
2941         (n (%string-size-in-octets string start end encoding line-termination use-byte-order-mark)))
2942    (declare (fixnum start end n))
2943    (unless (and (typep vector-offset 'fixnum)
2944                 (or (not vector-p)
2945                     (< vector-offset (length vector))))
2946      (error "Invalid vector offset ~s" vector-offset))
2947    (if (not vector-p)
2948      (setq vector (make-array (+ n vector-offset)
2949                               :element-type '(unsigned-byte 8)))
2950      (progn
2951        (unless (= (typecode vector) target::subtag-u8-vector)
2952          (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
2953        (unless (>= (length vector) (+ vector-offset n))
2954          (error "Can't encode ~s into supplied vector ~s; ~&~d octets are needed, but only ~d are available" string vector n (- (length vector) vector-offset)))))
2955    (when use-byte-order-mark
2956      (let* ((bom (character-encoding-bom-encoding encoding)))
2957        (dotimes (i (length bom))
2958          (setf (aref vector vector-offset)
2959                (aref bom i))
2960          (incf vector-offset))))
2961    (multiple-value-bind (simple-string offset) (array-data-and-offset string)
2962      (incf start offset)
2963      (incf end offset)
2964      (let* ((f (character-encoding-vector-encode-function encoding))
2965             (nlpos (if line-termination
2966                      (position #\Newline simple-string :start start :end end))))
2967        (if (null nlpos)
2968          (setq vector-offset
2969                (funcall f simple-string vector vector-offset start end))
2970          (let* ((nlstring (case line-termination
2971                             (:cr *cr-newline-string*)
2972                             (:crlf *crlf-newline-string*)
2973                             (:unicode *unicode-newline-string*)))
2974                 (nlstring-length (if (eq line-termination :crlf) 2 1)))
2975            (do* ()
2976                 ((null nlpos)
2977                  (setq vector-offset
2978                        (funcall f simple-string vector vector-offset start end)))
2979              (unless (eql nlpos start)
2980                (setq vector-offset (funcall f simple-string vector vector-offset start nlpos)))
2981              (setq vector-offset (funcall f nlstring vector vector-offset 0 nlstring-length))
2982              (setq start (1+ nlpos)
2983                    nlpos (position #\Newline simple-string :start start :end end)))))
2984        (values vector vector-offset)))))
2985
2986
2987
2988(defun count-characters-in-octet-vector (vector &key
2989                                                (start 0)
2990                                                end
2991                                                (external-format :default))
2992  (setq end (check-sequence-bounds vector start end))
2993  (%count-characters-in-octet-vector
2994   vector
2995   start
2996   end
2997   (get-character-encoding (external-format-character-encoding (normalize-external-format t external-format)))))
2998
2999(defun %count-characters-in-octet-vector (vector start end encoding)
3000  (unless (= (typecode vector) target::subtag-u8-vector)
3001    (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
3002  (funcall (character-encoding-length-of-vector-encoding-function encoding)
3003           vector
3004           start
3005           end))
3006                                         
3007
3008(defun decode-string-from-octets (vector &key
3009                                         (start 0)
3010                                         end
3011                                         (external-format :default)
3012                                         (string nil string-p))
3013  (setq end (check-sequence-bounds vector start end))
3014  (unless (= (typecode vector) target::subtag-u8-vector)
3015    (multiple-value-bind (array offset)
3016        (array-data-and-offset vector)
3017      (unless (= (typecode array) target::subtag-u8-vector)
3018        (report-bad-arg vector '(array (unsigned-byte 8) (*))))
3019      (setq vector array
3020            start (+ start offset)
3021            end (+ end offset))))
3022  (let* ((encoding (get-character-encoding
3023                    (external-format-character-encoding
3024                     (normalize-external-format t external-format)))))
3025    (multiple-value-bind (nchars last-octet)
3026        (%count-characters-in-octet-vector vector start end encoding)
3027      (if (not string-p)
3028        (setq string (make-string nchars))
3029        (progn
3030          (unless (= (typecode string) target::subtag-simple-base-string)
3031            (report-bad-arg string 'simple-string))
3032          (unless (>= (length string) nchars)
3033            (error "String ~s is too small; ~d characters are needed."
3034                   string nchars))))
3035      (funcall (character-encoding-vector-decode-function encoding)
3036               vector
3037               start
3038               (- last-octet start)
3039               string)
3040      (values string last-octet))))
3041     
3042                             
3043(defun string-encoded-length-in-bytes (encoding string start end)
3044  (if (typep string 'simple-base-string)
3045    (funcall (character-encoding-octets-in-string-function encoding)
3046             string
3047             (or start 0)
3048             (or end (length string)))
3049    (let* ((s (string string)))
3050      (multiple-value-bind (data offset) (array-data-and-offset s)
3051        (funcall (character-encoding-octets-in-string-function encoding)
3052                 data
3053                 (+ offset (or start 0))
3054                 (+ offset (or end (length s))))))))
3055
3056;;; Same as above, but add the length of a trailing 0 code-unit.
3057(defun cstring-encoded-length-in-bytes (encoding string start end)
3058  (+ (ash (character-encoding-code-unit-size encoding) -3) ; NUL terminator
3059     (string-encoded-length-in-bytes encoding string start end)))
3060
3061                   
3062
3063(defun encode-string-to-memory (encoding pointer offset string start end)
3064  (if (typep string 'simple-base-string)
3065    (funcall (character-encoding-memory-encode-function encoding)
3066             string pointer offset (or start 0) (or end (length string)))
3067    (let* ((s (string string)))
3068      (multiple-value-bind (data data-offset)
3069          (array-data-and-offset s)
3070        (funcall (character-encoding-memory-encode-function encoding)
3071                 data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s))))))))
3072
3073(defun get-encoded-string (encoding-name pointer noctets)
3074  (let* ((encoding (ensure-character-encoding encoding-name)))
3075    (multiple-value-bind (nchars nused)
3076        (funcall (character-encoding-length-of-memory-encoding-function encoding)
3077                 pointer
3078                 noctets
3079                 0)
3080      (let* ((string (make-string nchars)))
3081        (funcall (character-encoding-memory-decode-function encoding)
3082                 pointer
3083                 nused
3084                 0
3085                 string)
3086        string))))
3087
3088
3089(defun get-encoded-cstring (encoding-name pointer)
3090  (let* ((encoding (ensure-character-encoding encoding-name)))
3091    (get-encoded-string
3092     encoding
3093     pointer
3094     (ecase (character-encoding-code-unit-size encoding)
3095       (8 (%cstrlen pointer))
3096       (16 (do* ((i 0 (+ i 2)))
3097                ((= 0 (%get-unsigned-word pointer i))
3098                 (return i))
3099             (declare (fixnum i))))
3100       (32 (do* ((i 0 (+ i 4)))
3101                ((= 0 (%get-unsigned-long pointer i))
3102                 (return i))
3103             (declare (fixnum i))))))))
3104   
3105
3106     
3107
3108
3109
3110
3111;;; This is an array of 256 integers, that (sparsely) encodes 64K bits.
3112;;; (There might be as many as 256 significant bits in some of entries
3113;;; in this table.)
3114(defstatic *bmp-combining-bitmap*
3115    #(
3116        #x00
3117        #x00
3118        #x00
3119        #xFFFF0000FFFFFFFFFFFFFFFFFFFF
3120        #x37800000000000000000000000000000000
3121        #x16BBFFFFFBFFFE000000000000000000000000000000000000
3122        #x3D9FFFC00000000000000000000000010000003FF8000000000000000000
3123        #x1FFC00000000000000000000007FFFFFF000000020000
3124       
3125        #x00
3126        #xC0080399FD00000000000000E0000000C001E3FFFD00000000000000E
3127        #x3BBFD00000000000000E0003000000003987D000000000000004
3128        #x803DC7C0000000000000040000000000C0398FD00000000000000E
3129        #x603DDFC00000000000000C0000000000603DDFC00000000000000E
3130        #xC0000FF5F8400000000000000000C0000000000803DCFC00000000000000C
3131        #x3F001BF20000000000000000000000007F8007F2000000000000
3132        #x401FFFFFFFFEFF00DFFFFE000000000000C2A0000003000000
3133       
3134        #x3C0000003C7F00000000000
3135        #x7FFFFFF0000000000003FFFFE000000000000000000000000
3136        #x00
3137        #x00
3138        #x00
3139        #x00
3140        #x00
3141        #xFFFFFFFF0000000000000000C0000000C0000001C0000001C0000       
3142       
3143        #x2000000000000000000000000000000000000003800
3144        #x00
3145        #x00
3146        #x00
3147        #x00
3148        #x00
3149        #x00
3150        #x00
3151       
3152        #x7FFFFFF0000000000000000000000000000000000000000000000000000
3153        #x00
3154        #x00
3155        #x00
3156        #x00
3157        #x00
3158        #x00
3159        #x00
3160       
3161        #x00
3162        #x00
3163        #x00
3164        #x00
3165        #x00
3166        #x00
3167        #x00
3168        #x00
3169       
3170        #x600000000000000000000000000FC0000000000
3171        #x00
3172        #x00
3173        #x00
3174        #x00
3175        #x00
3176        #x00
3177        #x00
3178       
3179        #x00
3180        #x00
3181        #x00
3182        #x00
3183        #x00
3184        #x00
3185        #x00
3186        #x00
3187       
3188        #x00
3189        #x00
3190        #x00
3191        #x00
3192        #x00
3193        #x00
3194        #x00
3195        #x00
3196       
3197        #x00
3198        #x00
3199        #x00
3200        #x00
3201        #x00
3202        #x00
3203        #x00
3204        #x00
3205       
3206        #x00
3207        #x00
3208        #x00
3209        #x00
3210        #x00
3211        #x00
3212        #x00
3213        #x00
3214       
3215        #x00
3216        #x00
3217        #x00
3218        #x00
3219        #x00
3220        #x00
3221        #x00
3222        #x00
3223       
3224        #x00
3225        #x00
3226        #x00
3227        #x00
3228        #x00
3229        #x00
3230        #x00
3231        #x00
3232       
3233        #x00
3234        #x00
3235        #x00
3236        #x00
3237        #x00
3238        #x00
3239        #x00
3240        #x00
3241       
3242        #x00
3243        #x00
3244        #x00
3245        #x00
3246        #x00
3247        #x00
3248        #x00
3249        #x00
3250       
3251        #x00
3252        #x00
3253        #x00
3254        #x00
3255        #x00
3256        #x00
3257        #x00
3258        #x00
3259       
3260        #x00
3261        #x00
3262        #x00
3263        #x00
3264        #x00
3265        #x00
3266        #x00
3267        #x00
3268       
3269        #x00
3270        #x00
3271        #x00
3272        #x00
3273        #x00
3274        #x00
3275        #x00
3276        #x00
3277       
3278        #x00
3279        #x00
3280        #x00
3281        #x00
3282        #x00
3283        #x00
3284        #x00
3285        #x00
3286       
3287        #x00
3288        #x00
3289        #x00
3290        #x00
3291        #x00
3292        #x00
3293        #x00
3294        #x00
3295       
3296        #x00
3297        #x00
3298        #x00
3299        #x00
3300        #x00
3301        #x00
3302        #x00
3303        #x00
3304       
3305        #x00
3306        #x00
3307        #x00
3308        #x00
3309        #x00
3310        #x00
3311        #x00
3312        #x00
3313       
3314        #x00
3315        #x00
3316        #x00
3317        #x00
3318        #x00
3319        #x00
3320        #x00
3321        #x00
3322       
3323        #x00
3324        #x00
3325        #x00
3326        #x00
3327        #x00
3328        #x00
3329        #x00
3330        #x00
3331       
3332        #x00
3333        #x00
3334        #x00
3335        #x00
3336        #x00
3337        #x00
3338        #x00
3339        #x00
3340       
3341        #x00
3342        #x00
3343        #x00
3344        #x00
3345        #x00
3346        #x00
3347        #x00
3348        #x00
3349       
3350        #x00
3351        #x00
3352        #x00
3353        #x00
3354        #x00
3355        #x00
3356        #x00
3357        #x00
3358       
3359        #x00
3360        #x00
3361        #x00
3362        #x00
3363        #x00
3364        #x00
3365        #x00
3366        #x00
3367       
3368        #x00
3369        #x00
3370        #x00
3371        #x00
3372        #x00
3373        #x00
3374        #x00
3375        #x00
3376       
3377        #x00
3378        #x00
3379        #x00
3380        #x00
3381        #x00
3382        #x00
3383        #x00
3384        #x00
3385       
3386        #x00
3387        #x00
3388        #x00
3389        #x00
3390        #x00
3391        #x00
3392        #x00
3393        #x00
3394       
3395        #x00
3396        #x00
3397        #x00
3398        #x40000000
3399        #x00
3400        #x00
3401        #xF0000FFFF
3402        #x00))
3403
3404(defun is-combinable (char)
3405  (let* ((code (char-code char)))
3406    (declare (type (mod #x110000) code))
3407    (when (< code #x1000)
3408      (logbitp (ldb (byte 8 0) code)
3409               (svref *bmp-combining-bitmap* (ldb (byte 8 8) code))))))
3410
3411(defstatic *bmp-combining-chars*
3412  #(#\Combining_Grave_Accent 
3413    #\Combining_Acute_Accent 
3414    #\Combining_Circumflex_Accent 
3415    #\Combining_Tilde 
3416    #\Combining_Macron 
3417    #\Combining_Breve 
3418    #\Combining_Dot_Above 
3419    #\Combining_Diaeresis 
3420    #\Combining_Hook_Above 
3421    #\Combining_Ring_Above 
3422    #\Combining_Double_Acute_Accent 
3423    #\Combining_Caron 
3424    #\Combining_Double_Grave_Accent 
3425    #\Combining_Inverted_Breve 
3426    #\Combining_Comma_Above 
3427    #\Combining_Reversed_Comma_Above 
3428    #\Combining_Horn 
3429    #\Combining_Dot_Below 
3430    #\Combining_Diaeresis_Below 
3431    #\Combining_Ring_Below 
3432    #\Combining_Comma_Below 
3433    #\Combining_Cedilla 
3434    #\Combining_Ogonek 
3435    #\Combining_Circumflex_Accent_Below 
3436    #\Combining_Breve_Below 
3437    #\Combining_Tilde_Below 
3438    #\Combining_Macron_Below 
3439    #\Combining_Long_Solidus_Overlay 
3440    #\Combining_Greek_Perispomeni 
3441    #\Combining_Greek_Ypogegrammeni 
3442    #\Arabic_Maddah_Above 
3443    #\Arabic_Hamza_Above 
3444    #\Arabic_Hamza_Below 
3445    #\U+093C 
3446    #\U+09BE 
3447    #\U+09D7 
3448    #\U+0B3E 
3449    #\U+0B56 
3450    #\U+0B57 
3451    #\U+0BBE 
3452    #\U+0BD7 
3453    #\U+0C56 
3454    #\U+0CC2 
3455    #\U+0CD5 
3456    #\U+0CD6 
3457    #\U+0D3E 
3458    #\U+0D57 
3459    #\U+0DCA 
3460    #\U+0DCF 
3461    #\U+0DDF 
3462    #\U+102E 
3463    #\U+3099 
3464    #\U+309A))
3465
3466(defstatic *bmp-combining-base-chars*
3467  #(
3468    ;; #\Combining_Grave_Accent
3469
3470    #(#\A #\E #\I #\N #\O #\U #\W #\Y #\a #\e #\i #\n #\o #\u #\w #\y
3471      #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex
3472      #\Latin_Capital_Letter_E_With_Circumflex
3473      #\Latin_Capital_Letter_O_With_Circumflex
3474      #\Latin_Capital_Letter_U_With_Diaeresis
3475      #\Latin_Small_Letter_A_With_Circumflex
3476      #\Latin_Small_Letter_E_With_Circumflex
3477      #\Latin_Small_Letter_O_With_Circumflex
3478      #\Latin_Small_Letter_U_With_Diaeresis
3479      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
3480      #\Latin_Capital_Letter_E_With_Macron
3481      #\Latin_Small_Letter_E_With_Macron
3482      #\Latin_Capital_Letter_O_With_Macron
3483      #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_O_With_Horn
3484      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
3485      #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha
3486      #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta
3487      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron
3488      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
3489      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
3490      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
3491      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon
3492      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
3493      #\Greek_Small_Letter_Upsilon_With_Dialytika
3494      #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_I
3495      #\Cyrillic_Small_Letter_Ie #\Cyrillic_Small_Letter_I #\U+1F00 #\U+1F01
3496      #\U+1F08 #\U+1F09 #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20
3497      #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39
3498      #\U+1F40 #\U+1F41 #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59
3499      #\U+1F60 #\U+1F61 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
3500
3501
3502    ;; #\Combining_Acute_Accent
3503
3504    #(#\A #\C #\E #\G #\I #\K #\L #\M #\N #\O #\P #\R #\S #\U #\W #\Y #\Z
3505      #\a #\c #\e #\g #\i #\k #\l #\m #\n #\o #\p #\r #\s #\u #\w #\y #\z
3506      #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex
3507      #\Latin_Capital_Letter_A_With_Ring_Above #\Latin_Capital_Letter_Ae
3508      #\Latin_Capital_Letter_C_With_Cedilla
3509      #\Latin_Capital_Letter_E_With_Circumflex
3510      #\Latin_Capital_Letter_I_With_Diaeresis
3511      #\Latin_Capital_Letter_O_With_Circumflex
3512      #\Latin_Capital_Letter_O_With_Tilde
3513      #\Latin_Capital_Letter_O_With_Stroke
3514      #\Latin_Capital_Letter_U_With_Diaeresis
3515      #\Latin_Small_Letter_A_With_Circumflex
3516      #\Latin_Small_Letter_A_With_Ring_Above #\Latin_Small_Letter_Ae
3517      #\Latin_Small_Letter_C_With_Cedilla
3518      #\Latin_Small_Letter_E_With_Circumflex
3519      #\Latin_Small_Letter_I_With_Diaeresis
3520      #\Latin_Small_Letter_O_With_Circumflex
3521      #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_O_With_Stroke
3522      #\Latin_Small_Letter_U_With_Diaeresis
3523      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
3524      #\Latin_Capital_Letter_E_With_Macron
3525      #\Latin_Small_Letter_E_With_Macron
3526      #\Latin_Capital_Letter_O_With_Macron
3527      #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_U_With_Tilde
3528      #\Latin_Small_Letter_U_With_Tilde #\Latin_Capital_Letter_O_With_Horn
3529      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
3530      #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha
3531      #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta
3532      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron
3533      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
3534      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
3535      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
3536      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon
3537      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
3538      #\Greek_Small_Letter_Upsilon_With_Dialytika
3539      #\Greek_Upsilon_With_Hook_Symbol #\Cyrillic_Capital_Letter_Ghe
3540      #\Cyrillic_Capital_Letter_Ka #\Cyrillic_Small_Letter_Ghe
3541      #\Cyrillic_Small_Letter_Ka #\U+1F00 #\U+1F01 #\U+1F08 #\U+1F09
3542      #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 #\U+1F21 #\U+1F28
3543      #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 #\U+1F40 #\U+1F41
3544      #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61
3545      #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
3546
3547
3548    ;; #\Combining_Circumflex_Accent
3549
3550    #(#\A #\C #\E #\G #\H #\I #\J #\O #\S #\U #\W #\Y #\Z #\a #\c #\e #\g
3551      #\h #\i #\j #\o #\s #\u #\w #\y #\z #\U+1EA0 #\U+1EA1 #\U+1EB8
3552      #\U+1EB9 #\U+1ECC #\U+1ECD)
3553
3554
3555    ;; #\Combining_Tilde
3556
3557    #(#\A #\E #\I #\N #\O #\U #\V #\Y #\a #\e #\i #\n #\o #\u #\v #\y
3558      #\Latin_Capital_Letter_A_With_Circumflex
3559      #\Latin_Capital_Letter_E_With_Circumflex
3560      #\Latin_Capital_Letter_O_With_Circumflex
3561      #\Latin_Small_Letter_A_With_Circumflex
3562      #\Latin_Small_Letter_E_With_Circumflex
3563      #\Latin_Small_Letter_O_With_Circumflex
3564      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
3565      #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn
3566      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn)
3567
3568
3569    ;; #\Combining_Macron
3570
3571    #(#\A #\E #\G #\I #\O #\U #\Y #\a #\e #\g #\i #\o #\u #\y
3572      #\Latin_Capital_Letter_A_With_Diaeresis #\Latin_Capital_Letter_Ae
3573      #\Latin_Capital_Letter_O_With_Tilde
3574      #\Latin_Capital_Letter_O_With_Diaeresis
3575      #\Latin_Capital_Letter_U_With_Diaeresis
3576      #\Latin_Small_Letter_A_With_Diaeresis #\Latin_Small_Letter_Ae
3577      #\Latin_Small_Letter_O_With_Tilde
3578      #\Latin_Small_Letter_O_With_Diaeresis
3579      #\Latin_Small_Letter_U_With_Diaeresis
3580      #\Latin_Capital_Letter_O_With_Ogonek
3581      #\Latin_Small_Letter_O_With_Ogonek
3582      #\Latin_Capital_Letter_A_With_Dot_Above
3583      #\Latin_Small_Letter_A_With_Dot_Above
3584      #\Latin_Capital_Letter_O_With_Dot_Above
3585      #\Latin_Small_Letter_O_With_Dot_Above #\Greek_Capital_Letter_Alpha
3586      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon
3587      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota
3588      #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_I
3589      #\Cyrillic_Capital_Letter_U #\Cyrillic_Small_Letter_I
3590      #\Cyrillic_Small_Letter_U #\U+1E36 #\U+1E37 #\U+1E5A #\U+1E5B)
3591
3592
3593    ;; #\Combining_Breve
3594
3595    #(#\A #\E #\G #\I #\O #\U #\a #\e #\g #\i #\o #\u
3596      #\Latin_Capital_Letter_E_With_Cedilla
3597      #\Latin_Small_Letter_E_With_Cedilla #\Greek_Capital_Letter_Alpha
3598      #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon
3599      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota
3600      #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_A
3601      #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_Zhe
3602      #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_U
3603      #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie
3604      #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_I
3605      #\Cyrillic_Small_Letter_U #\U+1EA0 #\U+1EA1)
3606
3607
3608    ;; #\Combining_Dot_Above
3609
3610    #(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\M #\N #\O #\P #\R #\S #\T #\W
3611      #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\m #\n #\o #\p #\r #\s
3612      #\t #\w #\x #\y #\z #\Latin_Capital_Letter_S_With_Acute
3613      #\Latin_Small_Letter_S_With_Acute #\Latin_Capital_Letter_S_With_Caron
3614      #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_Long_S #\U+1E62
3615      #\U+1E63)
3616
3617
3618    ;; #\Combining_Diaeresis
3619
3620    #(#\A #\E #\H #\I #\O #\U #\W #\X #\Y #\a #\e #\h #\i #\o #\t #\u #\w
3621      #\x #\y #\Latin_Capital_Letter_O_With_Tilde
3622      #\Latin_Small_Letter_O_With_Tilde #\Latin_Capital_Letter_U_With_Macron
3623      #\Latin_Small_Letter_U_With_Macron #\Greek_Capital_Letter_Iota
3624      #\Greek_Capital_Letter_Upsilon #\Greek_Small_Letter_Iota
3625      #\Greek_Small_Letter_Upsilon #\Greek_Upsilon_With_Hook_Symbol
3626      #\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I
3627      #\Cyrillic_Capital_Letter_A #\Cyrillic_Capital_Letter_Ie
3628      #\Cyrillic_Capital_Letter_Zhe #\Cyrillic_Capital_Letter_Ze
3629      #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_O
3630      #\Cyrillic_Capital_Letter_U #\Cyrillic_Capital_Letter_Che
3631      #\Cyrillic_Capital_Letter_Yeru #\Cyrillic_Capital_Letter_E
3632      #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie
3633      #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_Ze
3634      #\Cyrillic_Small_Letter_I #\Cyrillic_Small_Letter_O
3635      #\Cyrillic_Small_Letter_U #\Cyrillic_Small_Letter_Che
3636      #\Cyrillic_Small_Letter_Yeru #\Cyrillic_Small_Letter_E
3637      #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I
3638      #\Cyrillic_Capital_Letter_Schwa #\Cyrillic_Small_Letter_Schwa
3639      #\Cyrillic_Capital_Letter_Barred_O #\Cyrillic_Small_Letter_Barred_O)
3640
3641
3642    ;; #\Combining_Hook_Above
3643
3644    #(#\A #\E #\I #\O #\U #\Y #\a #\e #\i #\o #\u #\y
3645      #\Latin_Capital_Letter_A_With_Circumflex
3646      #\Latin_Capital_Letter_E_With_Circumflex
3647      #\Latin_Capital_Letter_O_With_Circumflex
3648      #\Latin_Small_Letter_A_With_Circumflex
3649      #\Latin_Small_Letter_E_With_Circumflex
3650      #\Latin_Small_Letter_O_With_Circumflex
3651      #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve
3652      #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn
3653      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn)
3654
3655
3656    ;; #\Combining_Ring_Above
3657
3658    #(#\A #\U #\a #\u #\w #\y)
3659
3660
3661    ;; #\Combining_Double_Acute_Accent
3662
3663    #(#\O #\U #\o #\u #\Cyrillic_Capital_Letter_U
3664      #\Cyrillic_Small_Letter_U)
3665
3666
3667    ;; #\Combining_Caron
3668
3669    #(#\A #\C #\D #\E #\G #\H #\I #\K #\L #\N #\O #\R #\S #\T #\U #\Z #\a
3670      #\c #\d #\e #\g #\h #\i #\j #\k #\l #\n #\o #\r #\s #\t #\u #\z
3671      #\Latin_Capital_Letter_U_With_Diaeresis
3672      #\Latin_Small_Letter_U_With_Diaeresis #\Latin_Capital_Letter_Ezh
3673      #\Latin_Small_Letter_Ezh)
3674
3675
3676    ;; #\Combining_Double_Grave_Accent
3677
3678    #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u
3679      #\Cyrillic_Capital_Letter_Izhitsa #\Cyrillic_Small_Letter_Izhitsa)
3680
3681
3682    ;; #\Combining_Inverted_Breve
3683
3684    #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u)
3685
3686
3687    ;; #\Combining_Comma_Above
3688
3689    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon
3690      #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota
3691      #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Omega
3692      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
3693      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
3694      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho
3695      #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega)
3696
3697
3698    ;; #\Combining_Reversed_Comma_Above
3699
3700    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon
3701      #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota
3702      #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Rho
3703      #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega
3704      #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon
3705      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota
3706      #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho
3707      #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega)
3708
3709
3710    ;; #\Combining_Horn
3711
3712    #(#\O #\U #\o #\u)
3713
3714
3715    ;; #\Combining_Dot_Below
3716
3717    #(#\A #\B #\D #\E #\H #\I #\K #\L #\M #\N #\O #\R #\S #\T #\U #\V #\W
3718      #\Y #\Z #\a #\b #\d #\e #\h #\i #\k #\l #\m #\n #\o #\r #\s #\t #\u
3719      #\v #\w #\y #\z #\Latin_Capital_Letter_O_With_Horn
3720      #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn
3721      #\Latin_Small_Letter_U_With_Horn)
3722
3723
3724    ;; #\Combining_Diaeresis_Below
3725
3726    #(#\U #\u)
3727
3728
3729    ;; #\Combining_Ring_Below
3730
3731    #(#\A #\a)
3732
3733
3734    ;; #\Combining_Comma_Below
3735
3736    #(#\S #\T #\s #\t)
3737
3738
3739    ;; #\Combining_Cedilla
3740
3741    #(#\C #\D #\E #\G #\H #\K #\L #\N #\R #\S #\T #\c #\d #\e #\g #\h #\k
3742      #\l #\n #\r #\s #\t)
3743
3744
3745    ;; #\Combining_Ogonek
3746
3747    #(#\A #\E #\I #\O #\U #\a #\e #\i #\o #\u)
3748
3749
3750    ;; #\Combining_Circumflex_Accent_Below
3751
3752    #(#\D #\E #\L #\N #\T #\U #\d #\e #\l #\n #\t #\u)
3753
3754
3755    ;; #\Combining_Breve_Below
3756
3757    #(#\H #\h)
3758
3759
3760    ;; #\Combining_Tilde_Below
3761
3762    #(#\E #\I #\U #\e #\i #\u)
3763
3764
3765    ;; #\Combining_Macron_Below
3766
3767    #(#\B #\D #\K #\L #\N #\R #\T #\Z #\b #\d #\h #\k #\l #\n #\r #\t #\z)
3768
3769
3770    ;; #\Combining_Long_Solidus_Overlay
3771
3772    #(#\< #\= #\> #\U+2190 #\U+2192 #\U+2194 #\U+21D0 #\U+21D2 #\U+21D4
3773      #\U+2203 #\U+2208 #\U+220B #\U+2223 #\U+2225 #\U+223C #\U+2243
3774      #\U+2245 #\U+2248 #\U+224D #\U+2261 #\U+2264 #\U+2265 #\U+2272
3775      #\U+2273 #\U+2276 #\U+2277 #\U+227A #\U+227B #\U+227C #\U+227D
3776      #\U+2282 #\U+2283 #\U+2286 #\U+2287 #\U+2291 #\U+2292 #\U+22A2
3777      #\U+22A8 #\U+22A9 #\U+22AB #\U+22B2 #\U+22B3 #\U+22B4 #\U+22B5)
3778
3779
3780    ;; #\Combining_Greek_Perispomeni
3781
3782    #(#\Diaeresis #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Eta
3783      #\Greek_Small_Letter_Iota #\Greek_Small_Letter_Upsilon
3784      #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika
3785      #\Greek_Small_Letter_Upsilon_With_Dialytika #\U+1F00 #\U+1F01 #\U+1F08
3786      #\U+1F09 #\U+1F20 #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31
3787      #\U+1F38 #\U+1F39 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61
3788      #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE)
3789
3790
3791    ;; #\Combining_Greek_Ypogegrammeni
3792
3793    #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Eta
3794      #\Greek_Capital_Letter_Omega #\Greek_Small_Letter_Alpha_With_Tonos
3795      #\Greek_Small_Letter_Eta_With_Tonos #\Greek_Small_Letter_Alpha
3796      #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Omega
3797      #\Greek_Small_Letter_Omega_With_Tonos #\U+1F00 #\U+1F01 #\U+1F02
3798      #\U+1F03 #\U+1F04 #\U+1F05 #\U+1F06 #\U+1F07 #\U+1F08 #\U+1F09
3799      #\U+1F0A #\U+1F0B #\U+1F0C #\U+1F0D #\U+1F0E #\U+1F0F #\U+1F20
3800      #\U+1F21 #\U+1F22 #\U+1F23 #\U+1F24 #\U+1F25 #\U+1F26 #\U+1F27
3801      #\U+1F28 #\U+1F29 #\U+1F2A #\U+1F2B #\U+1F2C #\U+1F2D #\U+1F2E
3802      #\U+1F2F #\U+1F60 #\U+1F61 #\U+1F62 #\U+1F63 #\U+1F64 #\U+1F65
3803      #\U+1F66 #\U+1F67 #\U+1F68 #\U+1F69 #\U+1F6A #\U+1F6B #\U+1F6C
3804      #\U+1F6D #\U+1F6E #\U+1F6F #\U+1F70 #\U+1F74 #\U+1F7C #\U+1FB6
3805      #\U+1FC6 #\U+1FF6)
3806
3807
3808    ;; #\Arabic_Maddah_Above
3809
3810    #(#\Arabic_Letter_Alef)
3811
3812
3813    ;; #\Arabic_Hamza_Above
3814
3815    #(#\Arabic_Letter_Alef #\Arabic_Letter_Waw #\Arabic_Letter_Yeh
3816      #\Arabic_Letter_Heh_Goal #\Arabic_Letter_Yeh_Barree
3817      #\Arabic_Letter_Ae)
3818
3819
3820    ;; #\Arabic_Hamza_Below
3821
3822    #(#\Arabic_Letter_Alef)
3823
3824
3825    ;; #\U+093C
3826
3827    #(#\U+0928 #\U+0930 #\U+0933)
3828
3829
3830    ;; #\U+09BE
3831
3832    #(#\U+09C7)
3833
3834
3835    ;; #\U+09D7
3836
3837    #(#\U+09C7)
3838
3839
3840    ;; #\U+0B3E
3841
3842    #(#\U+0B47)
3843
3844
3845    ;; #\U+0B56
3846
3847    #(#\U+0B47)
3848
3849
3850    ;; #\U+0B57
3851
3852    #(#\U+0B47)
3853
3854
3855    ;; #\U+0BBE
3856
3857    #(#\U+0BC6 #\U+0BC7)
3858
3859
3860    ;; #\U+0BD7
3861
3862    #(#\U+0B92 #\U+0BC6)
3863
3864
3865    ;; #\U+0C56
3866
3867    #(#\U+0C46)
3868
3869
3870    ;; #\U+0CC2
3871
3872    #(#\U+0CC6)
3873
3874
3875    ;; #\U+0CD5
3876
3877    #(#\U+0CBF #\U+0CC6 #\U+0CCA)
3878
3879
3880    ;; #\U+0CD6
3881
3882    #(#\U+0CC6)
3883
3884
3885    ;; #\U+0D3E
3886
3887    #(#\U+0D46 #\U+0D47)
3888
3889
3890    ;; #\U+0D57
3891
3892    #(#\U+0D46)
3893
3894
3895    ;; #\U+0DCA
3896
3897    #(#\U+0DD9 #\U+0DDC)
3898
3899
3900    ;; #\U+0DCF
3901
3902    #(#\U+0DD9)
3903
3904
3905    ;; #\U+0DDF
3906
3907    #(#\U+0DD9)
3908
3909
3910    ;; #\U+102E
3911
3912    #(#\U+1025)
3913
3914
3915    ;; #\U+3099
3916
3917    #(#\U+3046 #\U+304B #\U+304D #\U+304F #\U+3051 #\U+3053 #\U+3055
3918      #\U+3057 #\U+3059 #\U+305B #\U+305D #\U+305F #\U+3061 #\U+3064
3919      #\U+3066 #\U+3068 #\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B
3920      #\U+309D #\U+30A6 #\U+30AB #\U+30AD #\U+30AF #\U+30B1 #\U+30B3
3921      #\U+30B5 #\U+30B7 #\U+30B9 #\U+30BB #\U+30BD #\U+30BF #\U+30C1
3922      #\U+30C4 #\U+30C6 #\U+30C8 #\U+30CF #\U+30D2 #\U+30D5 #\U+30D8
3923      #\U+30DB #\U+30EF #\U+30F0 #\U+30F1 #\U+30F2 #\U+30FD)
3924
3925
3926    ;; #\U+309A
3927
3928    #(#\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B #\U+30CF #\U+30D2
3929      #\U+30D5 #\U+30D8 #\U+30DB)
3930    ))
3931
3932(defstatic *bmp-precombined-chars*
3933  #(
3934
3935    ;; #\Combining_Grave_Accent
3936
3937    #(#\Latin_Capital_Letter_A_With_Grave
3938      #\Latin_Capital_Letter_E_With_Grave
3939      #\Latin_Capital_Letter_I_With_Grave
3940      #\Latin_Capital_Letter_N_With_Grave
3941      #\Latin_Capital_Letter_O_With_Grave
3942      #\Latin_Capital_Letter_U_With_Grave #\U+1E80 #\U+1EF2
3943      #\Latin_Small_Letter_A_With_Grave #\Latin_Small_Letter_E_With_Grave
3944      #\Latin_Small_Letter_I_With_Grave #\Latin_Small_Letter_N_With_Grave
3945      #\Latin_Small_Letter_O_With_Grave #\Latin_Small_Letter_U_With_Grave
3946      #\U+1E81 #\U+1EF3 #\U+1FED #\U+1EA6 #\U+1EC0 #\U+1ED2
3947      #\Latin_Capital_Letter_U_With_Diaeresis_And_Grave #\U+1EA7 #\U+1EC1
3948      #\U+1ED3 #\Latin_Small_Letter_U_With_Diaeresis_And_Grave #\U+1EB0
3949      #\U+1EB1 #\U+1E14 #\U+1E15 #\U+1E50 #\U+1E51 #\U+1EDC #\U+1EDD
3950      #\U+1EEA #\U+1EEB #\U+1FBA #\U+1FC8 #\U+1FCA #\U+1FDA #\U+1FF8
3951      #\U+1FEA #\U+1FFA #\U+1F70 #\U+1F72 #\U+1F74 #\U+1F76 #\U+1F78
3952      #\U+1F7A #\U+1F7C #\U+1FD2 #\U+1FE2
3953      #\Cyrillic_Capital_Letter_Ie_With_Grave
3954      #\Cyrillic_Capital_Letter_I_With_Grave
3955      #\Cyrillic_Small_Letter_Ie_With_Grave
3956      #\Cyrillic_Small_Letter_I_With_Grave #\U+1F02 #\U+1F03 #\U+1F0A
3957      #\U+1F0B #\U+1F12 #\U+1F13 #\U+1F1A #\U+1F1B #\U+1F22 #\U+1F23
3958      #\U+1F2A #\U+1F2B #\U+1F32 #\U+1F33 #\U+1F3A #\U+1F3B #\U+1F42
3959      #\U+1F43 #\U+1F4A #\U+1F4B #\U+1F52 #\U+1F53 #\U+1F5B #\U+1F62
3960      #\U+1F63 #\U+1F6A #\U+1F6B #\U+1FCD #\U+1FDD)
3961
3962
3963    ;; #\Combining_Acute_Accent
3964
3965    #(#\Latin_Capital_Letter_A_With_Acute
3966      #\Latin_Capital_Letter_C_With_Acute
3967      #\Latin_Capital_Letter_E_With_Acute
3968      #\Latin_Capital_Letter_G_With_Acute
3969      #\Latin_Capital_Letter_I_With_Acute #\U+1E30
3970      #\Latin_Capital_Letter_L_With_Acute #\U+1E3E
3971      #\Latin_Capital_Letter_N_With_Acute
3972      #\Latin_Capital_Letter_O_With_Acute #\U+1E54
3973      #\Latin_Capital_Letter_R_With_Acute
3974      #\Latin_Capital_Letter_S_With_Acute
3975      #\Latin_Capital_Letter_U_With_Acute #\U+1E82
3976      #\Latin_Capital_Letter_Y_With_Acute
3977      #\Latin_Capital_Letter_Z_With_Acute #\Latin_Small_Letter_A_With_Acute
3978      #\Latin_Small_Letter_C_With_Acute #\Latin_Small_Letter_E_With_Acute
3979      #\Latin_Small_Letter_G_With_Acute #\Latin_Small_Letter_I_With_Acute
3980      #\U+1E31 #\Latin_Small_Letter_L_With_Acute #\U+1E3F
3981      #\Latin_Small_Letter_N_With_Acute #\Latin_Small_Letter_O_With_Acute
3982      #\U+1E55 #\Latin_Small_Letter_R_With_Acute
3983      #\Latin_Small_Letter_S_With_Acute #\Latin_Small_Letter_U_With_Acute
3984      #\U+1E83 #\Latin_Small_Letter_Y_With_Acute
3985      #\Latin_Small_Letter_Z_With_Acute #\Greek_Dialytika_Tonos #\U+1EA4
3986      #\Latin_Capital_Letter_A_With_Ring_Above_And_Acute
3987      #\Latin_Capital_Letter_Ae_With_Acute #\U+1E08 #\U+1EBE #\U+1E2E
3988      #\U+1ED0 #\U+1E4C #\Latin_Capital_Letter_O_With_Stroke_And_Acute
3989      #\Latin_Capital_Letter_U_With_Diaeresis_And_Acute #\U+1EA5
3990      #\Latin_Small_Letter_A_With_Ring_Above_And_Acute
3991      #\Latin_Small_Letter_Ae_With_Acute #\U+1E09 #\U+1EBF #\U+1E2F #\U+1ED1
3992      #\U+1E4D #\Latin_Small_Letter_O_With_Stroke_And_Acute
3993      #\Latin_Small_Letter_U_With_Diaeresis_And_Acute #\U+1EAE #\U+1EAF
3994      #\U+1E16 #\U+1E17 #\U+1E52 #\U+1E53 #\U+1E78 #\U+1E79 #\U+1EDA
3995      #\U+1EDB #\U+1EE8 #\U+1EE9 #\Greek_Capital_Letter_Alpha_With_Tonos
3996      #\Greek_Capital_Letter_Epsilon_With_Tonos
3997      #\Greek_Capital_Letter_Eta_With_Tonos
3998      #\Greek_Capital_Letter_Iota_With_Tonos
3999      #\Greek_Capital_Letter_Omicron_With_Tonos
4000      #\Greek_Capital_Letter_Upsilon_With_Tonos
4001      #\Greek_Capital_Letter_Omega_With_Tonos
4002      #\Greek_Small_Letter_Alpha_With_Tonos
4003      #\Greek_Small_Letter_Epsilon_With_Tonos
4004      #\Greek_Small_Letter_Eta_With_Tonos
4005      #\Greek_Small_Letter_Iota_With_Tonos
4006      #\Greek_Small_Letter_Omicron_With_Tonos
4007      #\Greek_Small_Letter_Upsilon_With_Tonos
4008      #\Greek_Small_Letter_Omega_With_Tonos
4009      #\Greek_Small_Letter_Iota_With_Dialytika_And_Tonos
4010      #\Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos
4011      #\Greek_Upsilon_With_Acute_And_Hook_Symbol
4012      #\Cyrillic_Capital_Letter_Gje #\Cyrillic_Capital_Letter_Kje
4013      #\Cyrillic_Small_Letter_Gje #\Cyrillic_Small_Letter_Kje #\U+1F04
4014      #\U+1F05 #\U+1F0C #\U+1F0D #\U+1F14 #\U+1F15 #\U+1F1C #\U+1F1D
4015      #\U+1F24 #\U+1F25 #\U+1F2C #\U+1F2D #\U+1F34 #\U+1F35 #\U+1F3C
4016      #\U+1F3D #\U+1F44 #\U+1F45 #\U+1F4C #\U+1F4D #\U+1F54 #\U+1F55
4017      #\U+1F5D #\U+1F64 #\U+1F65 #\U+1F6C #\U+1F6D #\U+1FCE #\U+1FDE)
4018
4019
4020    ;; #\Combining_Circumflex_Accent
4021
4022    #(#\Latin_Capital_Letter_A_With_Circumflex
4023      #\Latin_Capital_Letter_C_With_Circumflex
4024      #\Latin_Capital_Letter_E_With_Circumflex
4025      #\Latin_Capital_Letter_G_With_Circumflex
4026      #\Latin_Capital_Letter_H_With_Circumflex
4027      #\Latin_Capital_Letter_I_With_Circumflex
4028      #\Latin_Capital_Letter_J_With_Circumflex
4029      #\Latin_Capital_Letter_O_With_Circumflex
4030      #\Latin_Capital_Letter_S_With_Circumflex
4031      #\Latin_Capital_Letter_U_With_Circumflex
4032      #\Latin_Capital_Letter_W_With_Circumflex
4033      #\Latin_Capital_Letter_Y_With_Circumflex #\U+1E90
4034      #\Latin_Small_Letter_A_With_Circumflex
4035      #\Latin_Small_Letter_C_With_Circumflex
4036      #\Latin_Small_Letter_E_With_Circumflex
4037      #\Latin_Small_Letter_G_With_Circumflex
4038      #\Latin_Small_Letter_H_With_Circumflex
4039      #\Latin_Small_Letter_I_With_Circumflex
4040      #\Latin_Small_Letter_J_With_Circumflex
4041      #\Latin_Small_Letter_O_With_Circumflex
4042      #\Latin_Small_Letter_S_With_Circumflex
4043      #\Latin_Small_Letter_U_With_Circumflex
4044      #\Latin_Small_Letter_W_With_Circumflex
4045      #\Latin_Small_Letter_Y_With_Circumflex #\U+1E91 #\U+1EAC #\U+1EAD
4046      #\U+1EC6 #\U+1EC7 #\U+1ED8 #\U+1ED9)
4047
4048
4049    ;; #\Combining_Tilde
4050
4051    #(#\Latin_Capital_Letter_A_With_Tilde #\U+1EBC
4052      #\Latin_Capital_Letter_I_With_Tilde
4053      #\Latin_Capital_Letter_N_With_Tilde
4054      #\Latin_Capital_Letter_O_With_Tilde
4055      #\Latin_Capital_Letter_U_With_Tilde #\U+1E7C #\U+1EF8
4056      #\Latin_Small_Letter_A_With_Tilde #\U+1EBD
4057      #\Latin_Small_Letter_I_With_Tilde #\Latin_Small_Letter_N_With_Tilde
4058      #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_U_With_Tilde
4059      #\U+1E7D #\U+1EF9 #\U+1EAA #\U+1EC4 #\U+1ED6 #\U+1EAB #\U+1EC5
4060      #\U+1ED7 #\U+1EB4 #\U+1EB5 #\U+1EE0 #\U+1EE1 #\U+1EEE #\U+1EEF)
4061
4062
4063    ;; #\Combining_Macron
4064
4065    #(#\Latin_Capital_Letter_A_With_Macron
4066      #\Latin_Capital_Letter_E_With_Macron #\U+1E20
4067      #\Latin_Capital_Letter_I_With_Macron
4068      #\Latin_Capital_Letter_O_With_Macron
4069      #\Latin_Capital_Letter_U_With_Macron
4070      #\Latin_Capital_Letter_Y_With_Macron
4071      #\Latin_Small_Letter_A_With_Macron #\Latin_Small_Letter_E_With_Macron
4072      #\U+1E21 #\Latin_Small_Letter_I_With_Macron
4073      #\Latin_Small_Letter_O_With_Macron #\Latin_Small_Letter_U_With_Macron
4074      #\Latin_Small_Letter_Y_With_Macron
4075      #\Latin_Capital_Letter_A_With_Diaeresis_And_Macron
4076      #\Latin_Capital_Letter_Ae_With_Macron
4077      #\Latin_Capital_Letter_O_With_Tilde_And_Macron
4078      #\Latin_Capital_Letter_O_With_Diaeresis_And_Macron
4079      #\Latin_Capital_Letter_U_With_Diaeresis_And_Macron
4080      #\Latin_Small_Letter_A_With_Diaeresis_And_Macron
4081      #\Latin_Small_Letter_Ae_With_Macron
4082      #\Latin_Small_Letter_O_With_Tilde_And_Macron
4083      #\Latin_Small_Letter_O_With_Diaeresis_And_Macron
4084      #\Latin_Small_Letter_U_With_Diaeresis_And_Macron
4085      #\Latin_Capital_Letter_O_With_Ogonek_And_Macron
4086      #\Latin_Small_Letter_O_With_Ogonek_And_Macron
4087      #\Latin_Capital_Letter_A_With_Dot_Above_And_Macron
4088      #\Latin_Small_Letter_A_With_Dot_Above_And_Macron
4089      #\Latin_Capital_Letter_O_With_Dot_Above_And_Macron
4090      #\Latin_Small_Letter_O_With_Dot_Above_And_Macron #\U+1FB9 #\U+1FD9
4091      #\U+1FE9 #\U+1FB1 #\U+1FD1 #\U+1FE1
4092      #\Cyrillic_Capital_Letter_I_With_Macron
4093      #\Cyrillic_Capital_Letter_U_With_Macron
4094      #\Cyrillic_Small_Letter_I_With_Macron
4095      #\Cyrillic_Small_Letter_U_With_Macron #\U+1E38 #\U+1E39 #\U+1E5C
4096      #\U+1E5D)
4097
4098
4099    ;; #\Combining_Breve
4100
4101    #(#\Latin_Capital_Letter_A_With_Breve
4102      #\Latin_Capital_Letter_E_With_Breve
4103      #\Latin_Capital_Letter_G_With_Breve
4104      #\Latin_Capital_Letter_I_With_Breve
4105      #\Latin_Capital_Letter_O_With_Breve
4106      #\Latin_Capital_Letter_U_With_Breve #\Latin_Small_Letter_A_With_Breve
4107      #\Latin_Small_Letter_E_With_Breve #\Latin_Small_Letter_G_With_Breve
4108      #\Latin_Small_Letter_I_With_Breve #\Latin_Small_Letter_O_With_Breve
4109      #\Latin_Small_Letter_U_With_Breve #\U+1E1C #\U+1E1D #\U+1FB8 #\U+1FD8
4110      #\U+1FE8 #\U+1FB0 #\U+1FD0 #\U+1FE0
4111      #\Cyrillic_Capital_Letter_A_With_Breve
4112      #\Cyrillic_Capital_Letter_Ie_With_Breve
4113      #\Cyrillic_Capital_Letter_Zhe_With_Breve
4114      #\Cyrillic_Capital_Letter_Short_I #\Cyrillic_Capital_Letter_Short_U
4115      #\Cyrillic_Small_Letter_A_With_Breve
4116      #\Cyrillic_Small_Letter_Ie_With_Breve
4117      #\Cyrillic_Small_Letter_Zhe_With_Breve #\Cyrillic_Small_Letter_Short_I
4118      #\Cyrillic_Small_Letter_Short_U #\U+1EB6 #\U+1EB7)
4119
4120
4121    ;; #\Combining_Dot_Above
4122
4123    #(#\Latin_Capital_Letter_A_With_Dot_Above #\U+1E02
4124      #\Latin_Capital_Letter_C_With_Dot_Above #\U+1E0A
4125      #\Latin_Capital_Letter_E_With_Dot_Above #\U+1E1E
4126      #\Latin_Capital_Letter_G_With_Dot_Above #\U+1E22
4127      #\Latin_Capital_Letter_I_With_Dot_Above #\U+1E40 #\U+1E44
4128      #\Latin_Capital_Letter_O_With_Dot_Above #\U+1E56 #\U+1E58 #\U+1E60
4129      #\U+1E6A #\U+1E86 #\U+1E8A #\U+1E8E
4130      #\Latin_Capital_Letter_Z_With_Dot_Above
4131      #\Latin_Small_Letter_A_With_Dot_Above #\U+1E03
4132      #\Latin_Small_Letter_C_With_Dot_Above #\U+1E0B
4133      #\Latin_Small_Letter_E_With_Dot_Above #\U+1E1F
4134      #\Latin_Small_Letter_G_With_Dot_Above #\U+1E23 #\U+1E41 #\U+1E45
4135      #\Latin_Small_Letter_O_With_Dot_Above #\U+1E57 #\U+1E59 #\U+1E61
4136      #\U+1E6B #\U+1E87 #\U+1E8B #\U+1E8F
4137      #\Latin_Small_Letter_Z_With_Dot_Above #\U+1E64 #\U+1E65 #\U+1E66
4138      #\U+1E67 #\U+1E9B #\U+1E68 #\U+1E69)
4139
4140
4141    ;; #\Combining_Diaeresis
4142
4143    #(#\Latin_Capital_Letter_A_With_Diaeresis
4144      #\Latin_Capital_Letter_E_With_Diaeresis #\U+1E26
4145      #\Latin_Capital_Letter_I_With_Diaeresis
4146      #\Latin_Capital_Letter_O_With_Diaeresis
4147      #\Latin_Capital_Letter_U_With_Diaeresis #\U+1E84 #\U+1E8C
4148      #\Latin_Capital_Letter_Y_With_Diaeresis
4149      #\Latin_Small_Letter_A_With_Diaeresis
4150      #\Latin_Small_Letter_E_With_Diaeresis #\U+1E27
4151      #\Latin_Small_Letter_I_With_Diaeresis
4152      #\Latin_Small_Letter_O_With_Diaeresis #\U+1E97
4153      #\Latin_Small_Letter_U_With_Diaeresis #\U+1E85 #\U+1E8D
4154      #\Latin_Small_Letter_Y_With_Diaeresis #\U+1E4E #\U+1E4F #\U+1E7A
4155      #\U+1E7B #\Greek_Capital_Letter_Iota_With_Dialytika
4156      #\Greek_Capital_Letter_Upsilon_With_Dialytika
4157      #\Greek_Small_Letter_Iota_With_Dialytika
4158      #\Greek_Small_Letter_Upsilon_With_Dialytika
4159      #\Greek_Upsilon_With_Diaeresis_And_Hook_Symbol
4160      #\Cyrillic_Capital_Letter_Yi
4161      #\Cyrillic_Capital_Letter_A_With_Diaeresis
4162      #\Cyrillic_Capital_Letter_Io
4163      #\Cyrillic_Capital_Letter_Zhe_With_Diaeresis
4164      #\Cyrillic_Capital_Letter_Ze_With_Diaeresis
4165      #\Cyrillic_Capital_Letter_I_With_Diaeresis
4166      #\Cyrillic_Capital_Letter_O_With_Diaeresis
4167      #\Cyrillic_Capital_Letter_U_With_Diaeresis
4168      #\Cyrillic_Capital_Letter_Che_With_Diaeresis
4169      #\Cyrillic_Capital_Letter_Yeru_With_Diaeresis
4170      #\Cyrillic_Capital_Letter_E_With_Diaeresis
4171      #\Cyrillic_Small_Letter_A_With_Diaeresis #\Cyrillic_Small_Letter_Io
4172      #\Cyrillic_Small_Letter_Zhe_With_Diaeresis
4173      #\Cyrillic_Small_Letter_Ze_With_Diaeresis
4174      #\Cyrillic_Small_Letter_I_With_Diaeresis
4175      #\Cyrillic_Small_Letter_O_With_Diaeresis
4176      #\Cyrillic_Small_Letter_U_With_Diaeresis
4177      #\Cyrillic_Small_Letter_Che_With_Diaeresis
4178      #\Cyrillic_Small_Letter_Yeru_With_Diaeresis
4179      #\Cyrillic_Small_Letter_E_With_Diaeresis #\Cyrillic_Small_Letter_Yi
4180      #\Cyrillic_Capital_Letter_Schwa_With_Diaeresis
4181      #\Cyrillic_Small_Letter_Schwa_With_Diaeresis
4182      #\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis
4183      #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis)
4184
4185
4186    ;; #\Combining_Hook_Above
4187
4188    #(#\U+1EA2 #\U+1EBA #\U+1EC8 #\U+1ECE #\U+1EE6 #\U+1EF6 #\U+1EA3
4189      #\U+1EBB #\U+1EC9 #\U+1ECF #\U+1EE7 #\U+1EF7 #\U+1EA8 #\U+1EC2
4190      #\U+1ED4 #\U+1EA9 #\U+1EC3 #\U+1ED5 #\U+1EB2 #\U+1EB3 #\U+1EDE
4191      #\U+1EDF #\U+1EEC #\U+1EED)
4192
4193
4194    ;; #\Combining_Ring_Above
4195
4196    #(#\Latin_Capital_Letter_A_With_Ring_Above
4197      #\Latin_Capital_Letter_U_With_Ring_Above
4198      #\Latin_Small_Letter_A_With_Ring_Above
4199      #\Latin_Small_Letter_U_With_Ring_Above #\U+1E98 #\U+1E99)
4200
4201
4202    ;; #\Combining_Double_Acute_Accent
4203
4204    #(#\Latin_Capital_Letter_O_With_Double_Acute
4205      #\Latin_Capital_Letter_U_With_Double_Acute
4206      #\Latin_Small_Letter_O_With_Double_Acute
4207      #\Latin_Small_Letter_U_With_Double_Acute
4208      #\Cyrillic_Capital_Letter_U_With_Double_Acute
4209      #\Cyrillic_Small_Letter_U_With_Double_Acute)
4210
4211
4212    ;; #\Combining_Caron
4213
4214    #(#\Latin_Capital_Letter_A_With_Caron
4215      #\Latin_Capital_Letter_C_With_Caron
4216      #\Latin_Capital_Letter_D_With_Caron
4217      #\Latin_Capital_Letter_E_With_Caron
4218      #\Latin_Capital_Letter_G_With_Caron
4219      #\Latin_Capital_Letter_H_With_Caron
4220      #\Latin_Capital_Letter_I_With_Caron
4221      #\Latin_Capital_Letter_K_With_Caron
4222      #\Latin_Capital_Letter_L_With_Caron
4223      #\Latin_Capital_Letter_N_With_Caron
4224      #\Latin_Capital_Letter_O_With_Caron
4225      #\Latin_Capital_Letter_R_With_Caron
4226      #\Latin_Capital_Letter_S_With_Caron
4227      #\Latin_Capital_Letter_T_With_Caron
4228      #\Latin_Capital_Letter_U_With_Caron
4229      #\Latin_Capital_Letter_Z_With_Caron #\Latin_Small_Letter_A_With_Caron
4230      #\Latin_Small_Letter_C_With_Caron #\Latin_Small_Letter_D_With_Caron
4231      #\Latin_Small_Letter_E_With_Caron #\Latin_Small_Letter_G_With_Caron
4232      #\Latin_Small_Letter_H_With_Caron #\Latin_Small_Letter_I_With_Caron
4233      #\Latin_Small_Letter_J_With_Caron #\Latin_Small_Letter_K_With_Caron
4234      #\Latin_Small_Letter_L_With_Caron #\Latin_Small_Letter_N_With_Caron
4235      #\Latin_Small_Letter_O_With_Caron #\Latin_Small_Letter_R_With_Caron
4236      #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_T_With_Caron
4237      #\Latin_Small_Letter_U_With_Caron #\Latin_Small_Letter_Z_With_Caron
4238      #\Latin_Capital_Letter_U_With_Diaeresis_And_Caron
4239      #\Latin_Small_Letter_U_With_Diaeresis_And_Caron
4240      #\Latin_Capital_Letter_Ezh_With_Caron
4241      #\Latin_Small_Letter_Ezh_With_Caron)
4242
4243
4244    ;; #\Combining_Double_Grave_Accent
4245
4246    #(#\Latin_Capital_Letter_A_With_Double_Grave
4247      #\Latin_Capital_Letter_E_With_Double_Grave
4248      #\Latin_Capital_Letter_I_With_Double_Grave
4249      #\Latin_Capital_Letter_O_With_Double_Grave
4250      #\Latin_Capital_Letter_R_With_Double_Grave
4251      #\Latin_Capital_Letter_U_With_Double_Grave
4252      #\Latin_Small_Letter_A_With_Double_Grave
4253      #\Latin_Small_Letter_E_With_Double_Grave
4254      #\Latin_Small_Letter_I_With_Double_Grave
4255      #\Latin_Small_Letter_O_With_Double_Grave
4256      #\Latin_Small_Letter_R_With_Double_Grave
4257      #\Latin_Small_Letter_U_With_Double_Grave
4258      #\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent
4259      #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent)
4260
4261
4262    ;; #\Combining_Inverted_Breve
4263
4264    #(#\Latin_Capital_Letter_A_With_Inverted_Breve
4265      #\Latin_Capital_Letter_E_With_Inverted_Breve
4266      #\Latin_Capital_Letter_I_With_Inverted_Breve
4267      #\Latin_Capital_Letter_O_With_Inverted_Breve
4268      #\Latin_Capital_Letter_R_With_Inverted_Breve
4269      #\Latin_Capital_Letter_U_With_Inverted_Breve
4270      #\Latin_Small_Letter_A_With_Inverted_Breve
4271      #\Latin_Small_Letter_E_With_Inverted_Breve
4272      #\Latin_Small_Letter_I_With_Inverted_Breve
4273      #\Latin_Small_Letter_O_With_Inverted_Breve
4274      #\Latin_Small_Letter_R_With_Inverted_Breve
4275      #\Latin_Small_Letter_U_With_Inverted_Breve)
4276
4277
4278    ;; #\Combining_Comma_Above
4279
4280    #(#\U+1F08 #\U+1F18 #\U+1F28 #\U+1F38 #\U+1F48 #\U+1F68 #\U+1F00
4281      #\U+1F10 #\U+1F20 #\U+1F30 #\U+1F40 #\U+1FE4 #\U+1F50 #\U+1F60)
4282
4283
4284    ;; #\Combining_Reversed_Comma_Above
4285
4286    #(#\U+1F09 #\U+1F19 #\U+1F29 #\U+1F39 #\U+1F49 #\U+1FEC #\U+1F59
4287      #\U+1F69 #\U+1F01 #\U+1F11 #\U+1F21 #\U+1F31 #\U+1F41 #\U+1FE5
4288      #\U+1F51 #\U+1F61)
4289
4290
4291    ;; #\Combining_Horn
4292
4293    #(#\Latin_Capital_Letter_O_With_Horn
4294      #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_O_With_Horn
4295      #\Latin_Small_Letter_U_With_Horn)
4296
4297
4298    ;; #\Combining_Dot_Below
4299
4300    #(#\U+1EA0 #\U+1E04 #\U+1E0C #\U+1EB8 #\U+1E24 #\U+1ECA #\U+1E32
4301      #\U+1E36 #\U+1E42 #\U+1E46 #\U+1ECC #\U+1E5A #\U+1E62 #\U+1E6C
4302      #\U+1EE4 #\U+1E7E #\U+1E88 #\U+1EF4 #\U+1E92 #\U+1EA1 #\U+1E05
4303      #\U+1E0D #\U+1EB9 #\U+1E25 #\U+1ECB #\U+1E33 #\U+1E37 #\U+1E43
4304      #\U+1E47 #\U+1ECD #\U+1E5B #\U+1E63 #\U+1E6D #\U+1EE5 #\U+1E7F
4305      #\U+1E89 #\U+1EF5 #\U+1E93 #\U+1EE2 #\U+1EE3 #\U+1EF0 #\U+1EF1)
4306
4307
4308    ;; #\Combining_Diaeresis_Below
4309
4310    #(#\U+1E72 #\U+1E73)
4311
4312
4313    ;; #\Combining_Ring_Below
4314
4315    #(#\U+1E00 #\U+1E01)
4316
4317
4318    ;; #\Combining_Comma_Below
4319
4320    #(#\Latin_Capital_Letter_S_With_Comma_Below
4321      #\Latin_Capital_Letter_T_With_Comma_Below
4322      #\Latin_Small_Letter_S_With_Comma_Below
4323      #\Latin_Small_Letter_T_With_Comma_Below)
4324
4325
4326    ;; #\Combining_Cedilla
4327
4328    #(#\Latin_Capital_Letter_C_With_Cedilla #\U+1E10
4329      #\Latin_Capital_Letter_E_With_Cedilla
4330      #\Latin_Capital_Letter_G_With_Cedilla #\U+1E28
4331      #\Latin_Capital_Letter_K_With_Cedilla
4332      #\Latin_Capital_Letter_L_With_Cedilla
4333      #\Latin_Capital_Letter_N_With_Cedilla
4334      #\Latin_Capital_Letter_R_With_Cedilla
4335      #\Latin_Capital_Letter_S_With_Cedilla
4336      #\Latin_Capital_Letter_T_With_Cedilla
4337      #\Latin_Small_Letter_C_With_Cedilla #\U+1E11
4338      #\Latin_Small_Letter_E_With_Cedilla
4339      #\Latin_Small_Letter_G_With_Cedilla #\U+1E29
4340      #\Latin_Small_Letter_K_With_Cedilla
4341      #\Latin_Small_Letter_L_With_Cedilla
4342      #\Latin_Small_Letter_N_With_Cedilla
4343      #\Latin_Small_Letter_R_With_Cedilla
4344      #\Latin_Small_Letter_S_With_Cedilla
4345      #\Latin_Small_Letter_T_With_Cedilla)
4346
4347
4348    ;; #\Combining_Ogonek
4349
4350    #(#\Latin_Capital_Letter_A_With_Ogonek
4351      #\Latin_Capital_Letter_E_With_Ogonek
4352      #\Latin_Capital_Letter_I_With_Ogonek
4353      #\Latin_Capital_Letter_O_With_Ogonek
4354      #\Latin_Capital_Letter_U_With_Ogonek
4355      #\Latin_Small_Letter_A_With_Ogonek #\Latin_Small_Letter_E_With_Ogonek
4356      #\Latin_Small_Letter_I_With_Ogonek #\Latin_Small_Letter_O_With_Ogonek
4357      #\Latin_Small_Letter_U_With_Ogonek)
4358
4359
4360    ;; #\Combining_Circumflex_Accent_Below
4361
4362    #(#\U+1E12 #\U+1E18 #\U+1E3C #\U+1E4A #\U+1E70 #\U+1E76 #\U+1E13
4363      #\U+1E19 #\U+1E3D #\U+1E4B #\U+1E71 #\U+1E77)
4364
4365
4366    ;; #\Combining_Breve_Below
4367
4368    #(#\U+1E2A #\U+1E2B)
4369
4370
4371    ;; #\Combining_Tilde_Below
4372
4373    #(#\U+1E1A #\U+1E2C #\U+1E74 #\U+1E1B #\U+1E2D #\U+1E75)
4374
4375
4376    ;; #\Combining_Macron_Below
4377
4378    #(#\U+1E06 #\U+1E0E #\U+1E34 #\U+1E3A #\U+1E48 #\U+1E5E #\U+1E6E
4379      #\U+1E94 #\U+1E07 #\U+1E0F #\U+1E96 #\U+1E35 #\U+1E3B #\U+1E49
4380      #\U+1E5F #\U+1E6F #\U+1E95)
4381
4382
4383    ;; #\Combining_Long_Solidus_Overlay
4384
4385    #(#\U+226E #\U+2260 #\U+226F #\U+219A #\U+219B #\U+21AE #\U+21CD
4386      #\U+21CF #\U+21CE #\U+2204 #\U+2209 #\U+220C #\U+2224 #\U+2226
4387      #\U+2241 #\U+2244 #\U+2247 #\U+2249 #\U+226D #\U+2262 #\U+2270
4388      #\U+2271 #\U+2274 #\U+2275 #\U+2278 #\U+2279 #\U+2280 #\U+2281
4389      #\U+22E0 #\U+22E1 #\U+2284 #\U+2285 #\U+2288 #\U+2289 #\U+22E2
4390      #\U+22E3 #\U+22AC #\U+22AD #\U+22AE #\U+22AF #\U+22EA #\U+22EB
4391      #\U+22EC #\U+22ED)
4392
4393
4394    ;; #\Combining_Greek_Perispomeni
4395
4396    #(#\U+1FC1 #\U+1FB6 #\U+1FC6 #\U+1FD6 #\U+1FE6 #\U+1FF6 #\U+1FD7
4397      #\U+1FE7 #\U+1F06 #\U+1F07 #\U+1F0E #\U+1F0F #\U+1F26 #\U+1F27
4398      #\U+1F2E #\U+1F2F #\U+1F36 #\U+1F37 #\U+1F3E #\U+1F3F #\U+1F56
4399      #\U+1F57 #\U+1F5F #\U+1F66 #\U+1F67 #\U+1F6E #\U+1F6F #\U+1FCF
4400      #\U+1FDF)
4401
4402
4403    ;; #\Combining_Greek_Ypogegrammeni
4404
4405    #(#\U+1FBC #\U+1FCC #\U+1FFC #\U+1FB4 #\U+1FC4 #\U+1FB3 #\U+1FC3
4406      #\U+1FF3 #\U+1FF4 #\U+1F80 #\U+1F81 #\U+1F82 #\U+1F83 #\U+1F84
4407      #\U+1F85 #\U+1F86 #\U+1F87 #\U+1F88 #\U+1F89 #\U+1F8A #\U+1F8B
4408      #\U+1F8C #\U+1F8D #\U+1F8E #\U+1F8F #\U+1F90 #\U+1F91 #\U+1F92
4409      #\U+1F93 #\U+1F94 #\U+1F95 #\U+1F96 #\U+1F97 #\U+1F98 #\U+1F99
4410      #\U+1F9A #\U+1F9B #\U+1F9C #\U+1F9D #\U+1F9E #\U+1F9F #\U+1FA0
4411      #\U+1FA1 #\U+1FA2 #\U+1FA3 #\U+1FA4 #\U+1FA5 #\U+1FA6 #\U+1FA7
4412      #\U+1FA8 #\U+1FA9 #\U+1FAA #\U+1FAB #\U+1FAC #\U+1FAD #\U+1FAE
4413      #\U+1FAF #\U+1FB2 #\U+1FC2 #\U+1FF2 #\U+1FB7 #\U+1FC7 #\U+1FF7)
4414
4415
4416    ;; #\Arabic_Maddah_Above
4417
4418    #(#\Arabic_Letter_Alef_With_Madda_Above)
4419
4420
4421    ;; #\Arabic_Hamza_Above
4422
4423    #(#\Arabic_Letter_Alef_With_Hamza_Above
4424      #\Arabic_Letter_Waw_With_Hamza_Above
4425      #\Arabic_Letter_Yeh_With_Hamza_Above
4426      #\Arabic_Letter_Heh_Goal_With_Hamza_Above
4427      #\Arabic_Letter_Yeh_Barree_With_Hamza_Above
4428      #\Arabic_Letter_Heh_With_Yeh_Above)
4429
4430
4431    ;; #\Arabic_Hamza_Below
4432
4433    #(#\Arabic_Letter_Alef_With_Hamza_Below)
4434
4435
4436    ;; #\U+093C
4437
4438    #(#\U+0929 #\U+0931 #\U+0934)
4439
4440
4441    ;; #\U+09BE
4442
4443    #(#\U+09CB)
4444
4445
4446    ;; #\U+09D7
4447
4448    #(#\U+09CC)
4449
4450
4451    ;; #\U+0B3E
4452
4453    #(#\U+0B4B)
4454
4455
4456    ;; #\U+0B56
4457
4458    #(#\U+0B48)
4459
4460
4461    ;; #\U+0B57
4462
4463    #(#\U+0B4C)
4464
4465
4466    ;; #\U+0BBE
4467
4468    #(#\U+0BCA #\U+0BCB)
4469
4470
4471    ;; #\U+0BD7
4472
4473    #(#\U+0B94 #\U+0BCC)
4474
4475
4476    ;; #\U+0C56
4477
4478    #(#\U+0C48)
4479
4480
4481    ;; #\U+0CC2
4482
4483    #(#\U+0CCA)
4484
4485
4486    ;; #\U+0CD5
4487
4488    #(#\U+0CC0 #\U+0CC7 #\U+0CCB)
4489
4490
4491    ;; #\U+0CD6
4492
4493    #(#\U+0CC8)
4494
4495
4496    ;; #\U+0D3E
4497
4498    #(#\U+0D4A #\U+0D4B)
4499
4500
4501    ;; #\U+0D57
4502
4503    #(#\U+0D4C)
4504
4505
4506    ;; #\U+0DCA
4507
4508    #(#\U+0DDA #\U+0DDD)
4509
4510
4511    ;; #\U+0DCF
4512
4513    #(#\U+0DDC)
4514
4515
4516    ;; #\U+0DDF
4517
4518    #(#\U+0DDE)
4519
4520
4521    ;; #\U+102E
4522
4523    #(#\U+1026)
4524
4525
4526    ;; #\U+3099
4527
4528    #(#\U+3094 #\U+304C #\U+304E #\U+3050 #\U+3052 #\U+3054 #\U+3056
4529      #\U+3058 #\U+305A #\U+305C #\U+305E #\U+3060 #\U+3062 #\U+3065
4530      #\U+3067 #\U+3069 #\U+3070 #\U+3073 #\U+3076 #\U+3079 #\U+307C
4531      #\U+309E #\U+30F4 #\U+30AC #\U+30AE #\U+30B0 #\U+30B2 #\U+30B4
4532      #\U+30B6 #\U+30B8 #\U+30BA #\U+30BC #\U+30BE #\U+30C0 #\U+30C2
4533      #\U+30C5 #\U+30C7 #\U+30C9 #\U+30D0 #\U+30D3 #\U+30D6 #\U+30D9
4534      #\U+30DC #\U+30F7 #\U+30F8 #\U+30F9 #\U+30FA #\U+30FE)
4535
4536
4537    ;; #\U+309A
4538
4539    #(#\U+3071 #\U+3074 #\U+3077 #\U+307A #\U+307D #\U+30D1 #\U+30D4
4540      #\U+30D7 #\U+30DA #\U+30DD)
4541    ))
4542
4543(defun search-char-vector (vector char)
4544  ;; vector is a SIMPLE-VECTOR of chars sorted by char-code.
4545  ;; return the index of char in vector or NIL if not found
4546  (let* ((left 0)
4547         (right (1- (length vector))))
4548    (declare (fixnum left right))
4549    (if (and (char>= char (svref vector left))
4550             (char<= char (svref vector right)))
4551      (do* ()
4552           ((> left right))
4553        (let* ((mid (ash (the fixnum (+ left right)) -1))
4554               (midch (svref vector mid)))
4555          (declare (fixnum mid))
4556          (if (eql char midch)
4557            (return mid)
4558            (if (char< char midch)
4559              (setq right (1- mid))
4560              (setq left (1+ mid)))))))))
4561
4562
4563(defconstant HANGUL-SBASE #xAC00)
4564(defconstant HANGUL-LBASE #x1100)
4565(defconstant HANGUL-VBASE #x1161)
4566(defconstant HANGUL-TBASE #x11A7)
4567
4568(defconstant HANGUL-SCOUNT 11172)
4569(defconstant HANGUL-LCOUNT 19)
4570(defconstant HANGUL-VCOUNT 21)
4571(defconstant HANGUL-TCOUNT 28)
4572(defconstant HANGUL-NCOUNT (* HANGUL-VCOUNT HANGUL-TCOUNT))
4573
4574(defun combine-bmp-chars (base combiner)
4575  (if (and (char>= combiner (code-char hangul-vbase))
4576           (char< combiner (code-char (+ hangul-tbase hangul-tcount))))
4577    (if (and (char< combiner (code-char (+ hangul-vbase hangul-vcount)))
4578             (char>= base (code-char hangul-lbase))
4579             (char< base (code-char (+ hangul-lbase hangul-lcount))))
4580      (return-from combine-bmp-chars
4581        (code-char (+ hangul-lbase
4582                      (* hangul-ncount (- (char-code base) hangul-lbase))
4583                      (* hangul-tcount (- (char-code combiner) hangul-vbase))))))
4584    (if (and (char> combiner (code-char hangul-tbase))
4585             (char>= base (code-char hangul-sbase))
4586             (char< base (code-char (+ hangul-sbase hangul-scount))))
4587      (if (not (zerop (the fixnum (mod (- (char-code base) hangul-sbase) hangul-tcount))))
4588        (return-from combine-bmp-chars nil)
4589        (return-from combine-bmp-chars
4590          (code-char (+ (char-code base) (- (char-code combiner) hangul-tbase)))))))
4591   
4592  (let* ((idx (search-char-vector *bmp-combining-chars* combiner))
4593         (base-table (if idx (svref *bmp-combining-base-chars* idx))))
4594    (if base-table
4595      (let* ((combined-idx (search-char-vector base-table base)))
4596        (if combined-idx
4597          (svref (svref *bmp-precombined-chars* idx) combined-idx))))))
4598
4599(defun precompose-simple-string (s)
4600  (let* ((n (length s)))
4601    (or (dotimes (i n s)
4602          (when (is-combinable (schar s i))
4603            (return nil)))
4604        (let* ((new (make-string n)))
4605          (declare (dynamic-extent new))
4606          (do* ((i 0 (1+ i))
4607                (nout -1)
4608                (lastch nil))
4609               ((= i n) (subseq new 0 (1+ nout)))
4610            (declare (fixnum nout i))
4611            (let* ((ch (schar s i)))
4612              (if (or (not lastch)
4613                      (not (is-combinable ch)))
4614                (setf lastch ch
4615                      (schar new (incf nout)) ch)
4616                (let* ((combined (combine-bmp-chars lastch ch)))
4617                  (if combined
4618                    (setf (schar new nout) (setq lastch combined))
4619                    (setf lastch ch
4620                      (schar new (incf nout)) ch))))))))))
4621
4622;;; Parse the string LINE (an Emacs-style file-attributes line)
4623;;; into a plist with Emacs variable names as keywords and values
4624;;; as strings (or list of strings).  Quietly return NIL on error.
4625(defun parse-file-options-line (line)
4626  (let* ((start (search "-*-" line))
4627         (start+3 (when start (+ start 3)))
4628         (end (and start+3 (search "-*-" line :start2 start+3))))
4629    (when end
4630      (setq line (subseq line start+3 end))
4631      (let* ((plist ()))
4632        (loop
4633          ;; The line between -*- pairs should be of the form
4634          ;; {varname: value;}*.  Emacs and Hemlock both seem
4635          ;; able to deal with the case where the last pair is
4636          ;; missing a trailing semicolon.
4637          (let* ((colon (position #\: line))
4638                 (semi (and colon (position #\; line :start (1+ colon)))))
4639            (unless colon
4640              (return plist))
4641            (let* ((key (intern (nstring-upcase (string-trim "  " (subseq line 0 colon))) "KEYWORD"))
4642                   (val (string-trim '(#\space #\tab) (subseq line (1+ colon) (or semi (length line))))))
4643              (setq line (if semi (subseq line (1+ semi)) ""))
4644              (unless (eq key :eval)
4645                (let* ((already (getf plist key)))
4646                  (if already
4647                    (setf (getf plist key) (nconc (if (atom already)
4648                                                    (list already)
4649                                                    already)
4650                                                  (list val)))
4651                    (setq plist (nconc plist (list key val)))))))))))))
4652
4653(defun process-file-coding-option (emacs-name line-termination)
4654  (when emacs-name
4655      (let* ((len (length emacs-name)))
4656        (cond ((and (> len 5) (string-equal "-unix" emacs-name :start2 (- len 5)))
4657               (setq emacs-name (subseq emacs-name 0 (- len 5))))
4658              ((and (> len 4) (or
4659                               (when (string-equal "-dos" emacs-name :start2 (- len 4))
4660                                 (setq line-termination :crlf))
4661                               (when (string-equal "-mac" emacs-name :start2 (- len 4))
4662                                 (setq line-termination :cr))))
4663                               
4664               (setq emacs-name (subseq emacs-name 0 (- len 4))))))
4665        (let* ((key (intern (string-upcase emacs-name) "KEYWORD"))
4666               (encoding (lookup-character-encoding key)))
4667          (if encoding
4668            (make-external-format :character-encoding (character-encoding-name encoding)
4669                                  :line-termination line-termination)
4670            (warn "file CODING option ~s isn't recognized as the name of a character encoding.~&Consider using ~S to define ~S as an alias for a supported encoding." key 'define-character-encoding-alias key)))))
4671 
4672(defun external-format-from-file-options (line)
4673  (process-file-coding-option (getf (parse-file-options-line line) :coding)
4674                              :unix))
4675
4676(defun external-format-from-octet-buffer (buf count)
4677  (declare (fixnum count))
4678  (dotimes (i count)
4679    (let* ((octet (%get-unsigned-byte buf i)))
4680      (cond ((or (eql octet (char-code #\linefeed))
4681                 (eql octet (char-code #\return)))
4682             (return (external-format-from-file-options (%str-from-ptr buf i))))))))
4683
Note: See TracBrowser for help on using the repository browser.