source: release/1.9/source/level-1/l1-unicode.lisp @ 15706

Last change on this file since 15706 was 15546, checked in by rme, 7 years ago

Add missing format argument.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 258.6 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2006-2009 Clozure Associates and contributors.
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
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 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
124(defmethod default-character-encoding ((domain t))
125  (character-encoding-name (get-character-encoding nil)))
126
127(defun decode-character-encoded-vector (encoding vector start-index noctets string)
128  (setq encoding (ensure-character-encoding encoding))
129  (unless (= (the (unsigned-byte 8) (typecode vector))
130             target::subtag-u8-vector)
131    (report-bad-arg vector '(simple-array (unsigned-byte 8) (*))))
132  (unless (= (the (unsigned-byte 8) (typecode string))
133             target::subtag-simple-base-string)
134    (report-bad-arg vector 'simple-string))
135  (let* ((len (length vector)))
136    (declare (type index len))
137    (unless (and (typep start-index 'fixnum)
138                 (>= (the fixnum start-index) 0)
139                 (< (the fixnum start-index) len))
140      (error "~s is an invalid start index for ~s" start-index vector))
141    (unless (and (typep noctets 'fixnum)
142                 (>= (the fixnum noctets) 0)
143                 (<= (+ (the fixnum start-index) (the fixnum noctets)) len))
144      (error "~S is an invalid octet count for ~s at ~s" noctets vector start-index))
145    (funcall (character-encoding-vector-decode-function encoding)
146             vector
147             start-index
148             noctets
149             string)))
150
151
152(defmethod print-object ((ce character-encoding) stream)
153  (print-unreadable-object (ce stream :type t :identity t)
154    (format stream "~a" (character-encoding-name ce))))
155
156(defun note-stream-decoding-problem (stream)
157  (let* ((source (if (typep stream 'ioblock)
158                   (ioblock-stream stream)
159                   stream))
160         (position (stream-position source))
161         (encoding-name
162          (character-encoding-name
163           (lookup-character-encoding (external-format-character-encoding (stream-external-format source))))))
164    (signal (make-condition 'decoding-problem
165                            :source source
166                            :position position
167                            :encoding-name encoding-name))
168    #\Replacement_Character))
169
170(defun note-vector-decoding-problem (vector index encoding)
171  (signal (make-condition 'decoding-problem
172                          :source vector
173                          :position index
174                          :encoding-name (let* ((enc (if (typep encoding 'character-encoding)
175                                                       encoding
176                                                       (lookup-character-encoding encoding))))
177                                           (if enc (character-encoding-name enc) encoding))))
178  #\Replacement_Character)
179
180(defun note-encoding-problem (char destination encoding code)
181  (signal (make-condition 'encoding-problem
182                          :character char
183                          :destination (if (typep destination 'ioblock)
184                                         (ioblock-stream destination)
185                                         destination)
186                          :encoding-name (let* ((enc (if (typep encoding 'character-encoding)
187                                                       encoding
188                                                       (lookup-character-encoding encoding))))
189                                           (if enc (character-encoding-name enc) encoding))))
190  code)
191
192
193(defun remove-character-encoding-alias (alias)
194  "(REMOVE-CHARACTER-ENCODING-ALIAS alias)
195alias - a keyword which is an alias for a defined character encoding.
196Makes the keyword cease to be an alias for that encoding and returns T."
197  (let* ((encoding (get-character-encoding alias))
198         (aliases (character-encoding-aliases encoding)))
199    (if (not (member alias aliases))
200      (error "~S is not an alias for ~s." alias encoding)
201      (progn
202        (setf (character-encoding-aliases encoding)
203              (remove alias aliases))
204        (remhash alias *character-encodings*)
205        t))))
206             
207 
208(defun define-character-encoding-alias (alias existing)
209  "(DEFINE-CHARACTER-ENCODING-ALIAS alias existing)
210alias - a keyword
211existing - a defined character encoding or a keyword that names one.
212Tries to make alias an alias for the existing encoding and returns
213that encoding."
214  (check-type alias keyword)
215  (let* ((canonical-encoding (ensure-character-encoding existing))
216         (current (lookup-character-encoding alias)))
217    (unless (eq current canonical-encoding)
218      (if (and current
219               (eq alias (character-encoding-name current)))
220        (error "Can't make ~s an alias for ~s, since it already names ~s."
221               alias existing current)
222        (progn
223          (when current
224            (setf (character-encoding-aliases current)
225                  (remove alias (character-encoding-aliases current))))
226          (pushnew alias (character-encoding-aliases canonical-encoding))
227          (setf (get-character-encoding alias) canonical-encoding))))
228    canonical-encoding))
229
230                         
231;;; N.B.  (ccl:nfunction <name> (lambda (...) ...)) is just  like
232;;;       (cl:function (lambda (...) ...)), except that the resulting
233;;; function will have "name" <name> (this is often helpful when debugging.)
234
235(defmacro define-character-encoding (name doc &rest args &key &allow-other-keys)
236  (setq name (intern (string name) "KEYWORD"))
237  (let* ((encoding (gensym))
238         (alias (gensym)))
239  `(let* ((,encoding (make-character-encoding :name ,name :documentation ,doc ,@args)))
240    (setf (get-character-encoding ,name) ,encoding)
241    (dolist (,alias (character-encoding-aliases ,encoding))
242      (setf (get-character-encoding ,alias) ,encoding))
243    ',name)))
244
245(defun encoding-name (encoding)
246  (character-encoding-name (or encoding (get-character-encoding nil))))
247
248;;; ISO-8859-1 is trivial, though of course it can't really encode characters
249;;; whose CHAR-CODE is >= 256
250
251(defun 8-bit-fixed-width-octets-in-string (string start end)
252  (declare (ignore string))
253  (if (>= end start)
254    (- end start)
255    0))
256
257(defun 8-bit-fixed-width-length-of-vector-encoding (vector start end)
258  (declare (ignore vector))
259  (if (>= end start)
260    (values (- end start) end)
261    (values 0 start)))
262
263(defun 8-bit-fixed-width-length-of-memory-encoding (pointer noctets start)
264  (declare (ignore pointer start))
265  (values noctets noctets))
266
267(define-character-encoding :iso-8859-1
268  "An 8-bit, fixed-width character encoding in which all character
269codes map to their Unicode equivalents. Intended to support most
270characters used in most Western European languages."
271
272  ;; The NIL alias is used internally to mean that ISO-8859-1 is
273  ;; the "null" 8-bit encoding
274  :aliases '(nil :iso_8859-1 :latin1 :l1 :ibm819 :cp819 :csISOLatin1)
275  :stream-encode-function
276  (nfunction
277   iso-8859-1-stream-encode
278   (lambda (char write-function stream)
279     (let* ((code (char-code char)))
280       (declare (type (mod #x110000) code))
281       (if (>= code 256)
282         (setq code (note-encoding-problem char stream :iso-8859-1 (char-code #\Sub))))
283       (funcall write-function stream code)
284       1)))
285  :stream-decode-function
286  (nfunction
287   iso-8859-1-stream-decode
288   (lambda (1st-unit next-unit-function stream)
289     (declare (ignore next-unit-function stream)
290              (type (unsigned-byte 8) 1st-unit))
291     (code-char 1st-unit)))
292  :vector-encode-function
293  (nfunction
294   iso-8859-1-vector-encode
295   (lambda (string vector idx start end)
296     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
297              (fixnum idx))
298     (do* ((i start (1+ i)))
299          ((>= i end) idx)
300       (let* ((char (schar string i))
301              (code (char-code char)))
302         (declare (type (mod #x110000) code))
303         (if (>= code 256)
304           (setq code (note-encoding-problem char vector :iso-8859-1 (char-code #\Sub))))
305         (progn
306           (setf (aref vector idx) code)
307           (incf idx))))))
308  :vector-decode-function
309  (nfunction
310   iso-8859-1-vector-decode
311   (lambda (vector idx noctets string)
312     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
313     (do* ((i 0 (1+ i))
314           (index idx (1+ index)))
315          ((>= i noctets) index)
316       (setf (schar string i) (code-char (the (unsigned-byte 8)
317                                             (aref vector index)))))))
318  :memory-encode-function
319  (nfunction
320   iso-8859-1-memory-encode
321   (lambda (string pointer idx start end)
322     (do* ((i start (1+ i)))
323          ((>= i end) idx)
324       (let* ((char (schar string i))
325              (code (char-code char)))
326         (declare (type (mod #x110000) code))
327         (if (>= code 256)
328           (setq code (note-encoding-problem char pointer :iso-8859-1 (char-code #\Sub))))
329         (setf (%get-unsigned-byte pointer idx) code)
330         (incf idx)))))
331  :memory-decode-function
332  (nfunction
333   iso-8859-1-memory-decode
334   (lambda (pointer noctets idx string)
335     (do* ((i 0 (1+ i))
336           (index idx (1+ index)))
337          ((>= i noctets) index)
338         (setf (schar string i) (code-char (the (unsigned-byte 8)
339                                             (%get-unsigned-byte pointer index)))))))
340  :octets-in-string-function
341  #'8-bit-fixed-width-octets-in-string
342  :length-of-vector-encoding-function
343  #'8-bit-fixed-width-length-of-vector-encoding
344  :length-of-memory-encoding-function 
345  #'8-bit-fixed-width-length-of-memory-encoding
346  :decode-literal-code-unit-limit 256
347  :encode-literal-char-code-limit 256
348
349  )
350
351(define-character-encoding :us-ascii
352  "A 7-bit, fixed-width character encoding in which all character
353codes map to their Unicode equivalents."
354
355  :aliases '(:csASCII :cp637 :IBM637 :us :ISO646-US :ascii :ISO-ir-6)
356  :stream-encode-function
357  (nfunction
358   ascii-stream-encode
359   (lambda (char write-function stream)
360     (let* ((code (char-code char)))
361       (declare (type (mod #x110000) code))
362       (when (>= code 128)
363         (setq code (note-encoding-problem char stream :us-ascii (char-code #\Sub))))
364       (funcall write-function stream code)
365       1)))
366  :stream-decode-function
367  (nfunction
368   ascii-stream-decode
369   (lambda (1st-unit next-unit-function stream)
370     (declare (ignore next-unit-function)
371              (type (unsigned-byte 8) 1st-unit))
372     (if (< 1st-unit 128)
373       (code-char 1st-unit)
374       (note-stream-decoding-problem stream))))
375  :vector-encode-function
376  (nfunction
377   ascii-vector-encode
378   (lambda (string vector idx start end)
379     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
380              (fixnum idx))
381     (do* ((i start (1+ i)))
382          ((>= i end) idx)
383       (let* ((char (schar string i))
384              (code (char-code char)))
385         (declare (type (mod #x110000) code))
386         (if (>= code 128)
387           (setq code (note-encoding-problem char vector :us-ascii (char-code #\Sub))))
388         (setf (aref vector idx) code)
389         (incf idx)))))
390  :vector-decode-function
391  (nfunction
392   ascii-vector-decode
393   (lambda (vector idx noctets string)
394     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
395     (do* ((i 0 (1+ i))
396           (index idx (1+ index)))
397          ((>= i noctets) index)
398       (let* ((code (aref vector index)))
399         (declare (type (unsigned-byte 8) code))
400         (setf (schar string i) (if (< code 128)
401                                  (code-char code)
402                                  (note-vector-decoding-problem vector index :us-ascii)))))))
403  :memory-encode-function
404  (nfunction
405   ascii-memory-encode
406   (lambda (string pointer idx start end)
407     (do* ((i start (1+ i)))
408          ((>= i end) idx)
409       (let* ((char (schar string i))
410              (code (char-code char)))
411         (declare (type (mod #x110000) code))
412         (if (>= code 128)
413           (setq code (note-encoding-problem char pointer :us-ascii (char-code #\Sub))))
414         (setf (%get-unsigned-byte pointer idx) code)
415         (incf idx)))))
416  :memory-decode-function
417  (nfunction
418   ascii-memory-decode
419   (lambda (pointer noctets idx string)
420     (do* ((i 0 (1+ i))
421           (index idx (1+ index)))
422          ((>= i noctets) index)
423       (let* ((code (%get-unsigned-byte pointer index)))
424         (declare (type (unsigned-byte 8) code))
425         (if (>= code 128)
426           (setf (schar string i) (note-vector-decoding-problem pointer index :us-ascii))
427           (setf (schar string i) (code-char code)))))))
428  :octets-in-string-function
429  #'8-bit-fixed-width-octets-in-string
430  :length-of-vector-encoding-function
431  #'8-bit-fixed-width-length-of-vector-encoding
432  :length-of-memory-encoding-function 
433  #'8-bit-fixed-width-length-of-memory-encoding
434  :decode-literal-code-unit-limit 128
435  :encode-literal-char-code-limit 128
436  )
437
438
439
440;;; Other 1-byte, fixed-width encodings.  Typically, codes in the range
441;;; #x00-#x9f maps straight through, while codes #xa0-#xff select arbitrary
442;;; Unicode characters that are commonly used in some locale.  (Sometimes
443;;; the break is at #x80 instead of #xa0).
444
445(defstatic *iso-8859-2-to-unicode*
446  #(
447  ;; #xa0
448  #\u+00a0 #\u+0104 #\u+02d8 #\u+0141 #\u+00a4 #\u+013d #\u+015a #\u+00a7
449  #\u+00a8 #\u+0160 #\u+015e #\u+0164 #\u+0179 #\u+00ad #\u+017d #\u+017b
450  ;; #xb0
451  #\u+00b0 #\u+0105 #\u+02db #\u+0142 #\u+00b4 #\u+013e #\u+015b #\u+02c7
452  #\u+00b8 #\u+0161 #\u+015f #\u+0165 #\u+017a #\u+02dd #\u+017e #\u+017c
453  ;; #xc0
454  #\u+0154 #\u+00c1 #\u+00c2 #\u+0102 #\u+00c4 #\u+0139 #\u+0106 #\u+00c7
455  #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+011a #\u+00cd #\u+00ce #\u+010e
456  ;; #xd0
457  #\u+0110 #\u+0143 #\u+0147 #\u+00d3 #\u+00d4 #\u+0150 #\u+00d6 #\u+00d7
458  #\u+0158 #\u+016e #\u+00da #\u+0170 #\u+00dc #\u+00dd #\u+0162 #\u+00df
459  ;; #xe0
460  #\u+0155 #\u+00e1 #\u+00e2 #\u+0103 #\u+00e4 #\u+013a #\u+0107 #\u+00e7
461  #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+011b #\u+00ed #\u+00ee #\u+010f
462  ;; #xf0
463  #\u+0111 #\u+0144 #\u+0148 #\u+00f3 #\u+00f4 #\u+0151 #\u+00f6 #\u+00f7
464  #\u+0159 #\u+016f #\u+00fa #\u+0171 #\u+00fc #\u+00fd #\u+0163 #\u+02d9
465))
466
467(defstatic *unicode-00a0-0180-to-iso-8859-2*
468  #(
469    #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7
470    #xa8 nil nil nil nil #xad nil nil ; #xa8-#xaf
471    #xb0 nil nil nil #xb4 nil nil nil ; #xb0-#xb7
472    #xb8 nil nil nil nil nil nil nil  ; #xb8-#xbf
473    nil #xc1 #xc2 nil #xc4 nil nil #xc7 ; #xc0-#xc7
474    nil #xc9 nil #xcb nil #xcd #xce nil ; #xc8-#xcf
475    nil nil nil #xd3 #xd4 nil #xd6 #xd7 ; #xd0-#xd7
476    nil nil #xda nil #xdc #xdd nil #xdf ; #xd8-#xdf
477    nil #xe1 #xe2 nil #xe4 nil nil #xe7 ; #xe0-#xe7
478    nil #xe9 nil #xeb nil #xed #xee nil ; #xe8-#xef
479    nil nil nil #xf3 #xf4 nil #xf6 #xf7 ; #xf0-#xf7
480    nil nil #xfa nil #xfc #xfd nil nil ; #xf8-#xff
481    ;; #x0100
482    nil nil #xc3 #xe3 #xa1 #xb1 #xc6 #xe6 ; #x100-#x107
483    nil nil nil nil #xc8 #xe8 #xcf #xef ; #x108-#x10f
484    #xd0 #xf0 nil nil nil nil nil nil ; #x110-#x117
485    #xca #xea #xcc #xec nil nil nil nil ; #x118-#x11f
486    nil nil nil nil nil nil nil nil     ; #x120-#x127
487    nil nil nil nil nil nil nil nil     ; #x128-#x12f
488    nil nil nil nil nil nil nil nil     ; #x130-#x137
489    nil #xc5 #xe5 nil nil #xa5 #xb5 nil ; #x138-#x13f
490    nil #xa3 #xb3 #xd1 #xf1 nil nil #xd2 ; #x140-#x147
491    #xf2 nil nil nil nil nil nil nil  ; #x148-#x14f
492    #xd5 #xf5 nil nil #xc0 #xe0 nil nil ; #x150-#x157
493    #xd8 #xf8 #xa6 #xb6 nil nil #xaa #xba ; #x158-#x15f
494    #xa9 #xb9 #xde #xfe #xab #xbb nil nil ; #x160-#x167
495    nil nil nil nil nil nil #xd9 #xf9 ; #x168-#x16f
496    #xdb #xfb nil nil nil nil nil nil ; #x170-#x177
497    nil #xac #xbc #xaf #xbf #xae #xbe nil ; #x178-#x17f
498    ))
499
500(defstatic *unicode-00c0-00e0-to-iso-8859-2*
501  #(
502    nil nil nil nil nil nil nil #xb7  ; #xc0-#xc7
503    nil nil nil nil nil nil nil nil     ; #xc8-#xcf
504    nil nil nil nil nil nil nil nil     ; #xd0-#xd7
505    #xa2 #xff nil #xb2 nil #xbd nil nil ; #xd8-#xdf
506    ))
507
508(define-character-encoding :iso-8859-2
509  "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
510map to their Unicode equivalents and other codes map to other Unicode
511character values.  Intended to provide most characters found in most
512languages used in Central/Eastern Europe."
513  :aliases '(:iso_8859-2 :latin2 :l2 :csISOLatin2)
514  :stream-encode-function
515  (nfunction
516   iso-8859-2-stream-encode
517   (lambda (char write-function stream)
518     (let* ((code (char-code char))
519            (c2 (cond ((< code #xa0) code)
520                      ((< code #x180)
521                       (svref *unicode-00a0-0180-to-iso-8859-2*
522                              (the fixnum (- code #xa0))))
523                      ((and (>= code #x2c0) (< code #x2e0))
524                       (svref *unicode-00c0-00e0-to-iso-8859-2*
525                                      (the fixnum (- code #x2c0)))))))
526                     
527       (declare (type (mod #x110000) code))
528       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-2 (char-code #\Sub))))
529       1)))
530  :stream-decode-function
531  (nfunction
532   iso-8859-2-stream-decode
533   (lambda (1st-unit next-unit-function stream)
534     (declare (ignore next-unit-function stream)
535              (type (unsigned-byte 8) 1st-unit))
536     (if (< 1st-unit #xa0)
537       (code-char 1st-unit)
538       (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0))))))
539  :vector-encode-function
540  (nfunction
541   iso-8859-2-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 (cond ((< code #xa0) code)
550                          ((< code #x180)
551                           (svref *unicode-00a0-0180-to-iso-8859-2*
552                                  (the fixnum (- code #xa0))))
553                          ((and (>= code #x2c0) (< code #x2e0))
554                           (svref *unicode-00c0-00e0-to-iso-8859-2*
555                                  (the fixnum (- code #x2c0)))))))
556         (declare (type (mod #x110000) code))
557         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-2 (char-code #\Sub))))
558         (incf idx)))))
559  :vector-decode-function
560  (nfunction
561   iso-8859-2-vector-decode
562   (lambda (vector idx noctets string)
563     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
564     (do* ((i 0 (1+ i))
565           (index idx (1+ index)))
566          ((>= i noctets) index)
567       (let* ((1st-unit (aref vector index)))
568           (declare (type (unsigned-byte 8) 1st-unit))
569           (setf (schar string i)
570            (if (< 1st-unit #xa0)
571              (code-char 1st-unit)
572              (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
573  :memory-encode-function
574  (nfunction
575   iso-8859-2-memory-encode
576   (lambda (string pointer idx start end)
577     (do* ((i start (1+ i)))
578          ((>= i end) idx)
579       (let* ((char (schar string i))
580              (code (char-code char))
581              (c2 (cond ((< code #xa0) code)
582                        ((< code #x180)
583                         (svref *unicode-00a0-0180-to-iso-8859-2*
584                                (the fixnum (- code #xa0))))
585                        ((and (>= code #x2c0) (< code #x2e0))
586                         (svref *unicode-00c0-00e0-to-iso-8859-2*
587                                (the fixnum (- code #x2c0)))))))
588       (declare (type (mod #x110000) code))
589       (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-2 (char-code #\Sub))))
590       (1+ idx)))))
591  :memory-decode-function
592  (nfunction
593   iso-8859-2-memory-decode
594   (lambda (pointer noctets idx string)
595     (do* ((i 0 (1+ i))
596           (index idx (1+ index)))
597          ((>= i noctets) index)
598       (let* ((1st-unit (%get-unsigned-byte pointer index)))
599         (declare (type (unsigned-byte 8) 1st-unit))
600         (setf (schar string i)
601               (if (< 1st-unit #xa0)
602                 (code-char 1st-unit)
603                 (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
604  :octets-in-string-function
605  #'8-bit-fixed-width-octets-in-string
606  :length-of-vector-encoding-function
607  #'8-bit-fixed-width-length-of-vector-encoding
608  :length-of-memory-encoding-function 
609  #'8-bit-fixed-width-length-of-memory-encoding
610  :decode-literal-code-unit-limit #xa0
611  :encode-literal-char-code-limit #xa0
612  )
613
614(defstatic *iso-8859-3-to-unicode*
615  #(
616    ;; #xa0
617    #\u+00a0 #\u+0126 #\u+02d8 #\u+00a3 #\u+00a4 #\u+fffd #\u+0124 #\u+00a7
618    #\u+00a8 #\u+0130 #\u+015e #\u+011e #\u+0134 #\u+00ad #\u+fffd #\u+017b
619    ;; #xb0
620    #\u+00b0 #\u+0127 #\u+00b2 #\u+00b3 #\u+00b4 #\u+00b5 #\u+0125 #\u+00b7
621    #\u+00b8 #\u+0131 #\u+015f #\u+011f #\u+0135 #\u+00bd #\u+fffd #\u+017c
622    ;; #xc0
623    #\u+00c0 #\u+00c1 #\u+00c2 #\u+fffd #\u+00c4 #\u+010a #\u+0108 #\u+00c7
624    #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf
625    ;; #xd0
626    #\u+fffd #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+0120 #\u+00d6 #\u+00d7
627    #\u+011c #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+016c #\u+015c #\u+00df
628    ;; #xe0
629    #\u+00e0 #\u+00e1 #\u+00e2 #\u+fffd #\u+00e4 #\u+010b #\u+0109 #\u+00e7
630    #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef
631    ;; #xf0
632    #\u+fffd #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+0121 #\u+00f6 #\u+00f7
633    #\u+011d #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+016d #\u+015d #\u+02d9
634    ))
635
636(defstatic *unicode-a0-100-to-iso-8859-3*
637  #(
638    #xa0 nil nil #xa3 #xa4 nil nil #xa7 ; #xa0-#xa7
639    #xa8 nil nil nil nil #xad nil nil   ; #xa8-#xaf
640    #xb0 nil #xb2 #xb3 #xb4 #xb5 nil #xb7 ; #xb0-#xb7
641    #xb8 nil nil nil nil #xbd nil nil   ; #xb8-#xbf
642    #xc0 #xc1 #xc2 nil #xc4 nil nil #xc7 ; #xc0-#xc7
643    #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf
644    nil #xd1 #xd2 #xd3 #xd4 nil #xd6 #xd7 ; #xd0-#xd7
645    nil #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf
646    #xe0 #xe1 #xe2 nil #xe4 nil nil #xe7 ; #xe0-#xe7
647    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef
648    nil #xf1 #xf2 #xf3 #xf4 nil #xf6 #xf7 ; #xf0-#xf7
649    nil #xf9 #xfa #xfb #xfc nil nil nil ; #xf8-#xff
650    ))
651
652(defstatic *unicode-108-180-to-iso-8859-3*
653  #(
654    #xc6 #xe6 #xc5 #xe5 #x00 #x00 #x00 #x00 ; #x108-#x10f
655    nil nil nil nil nil nil nil nil     ; #x110-#x117
656    nil nil nil nil #xd8 #xf8 #xab #xbb ; #x118-#x11f
657    #xd5 #xf5 nil nil #xa6 #xb6 #xa1 #xb1 ; #x120-#x127
658    nil nil nil nil nil nil nil nil     ; #x128-#x12f
659    #xa9 #xb9 nil nil #xac #xbc nil nil ; #x130-#x137
660    nil nil nil nil nil nil nil nil     ; #x138-#x13f
661    nil nil nil nil nil nil nil nil     ; #x140-#x147
662    nil nil nil nil nil nil nil nil     ; #x148-#x14f
663    nil nil nil nil nil nil nil nil     ; #x150-#x157
664    nil nil nil nil #xde #xfe #xaa #xba ; #x158-#x15f
665    nil nil nil nil nil nil nil nil     ; #x160-#x167
666    nil nil nil nil #xdd #xfd nil nil   ; #x168-#x16f
667    nil nil nil nil nil nil nil nil     ; #x170-#x177
668    nil nil nil #xaf #xbf nil nil nil   ; #x178-#x17f
669    ))
670
671(defstatic *unicode-2d8-2e0-to-iso-8859-3*
672  #(
673    #xa2 #xff nil nil nil nil nil nil   ; #x2d8-#x2df
674    ))
675
676
677   
678(define-character-encoding :iso-8859-3
679  "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
680map to their Unicode equivalents and other codes map to other Unicode
681character values.  Intended to provide most characters found in most
682languages used in Southern Europe."
683
684  :aliases '(:iso_8859-3 :latin3 :l3 :csisolatin3)
685  :stream-encode-function
686  (nfunction
687   iso-8859-3-stream-encode
688   (lambda (char write-function stream)
689     (let* ((code (char-code char))
690            (c2 (cond ((< code #xa0) code)
691                      ((< code #x100)
692                       (svref *unicode-a0-100-to-iso-8859-3*
693                              (the fixnum (- code #xa0))))
694                      ((and (>= code #x108) (< code #x180))
695                       (svref *unicode-108-180-to-iso-8859-3*
696                              (the fixnum (- code #x108))))
697                      ((and (>= code #x2d8) (< code #x2e0))
698                       (svref *unicode-2d8-2e0-to-iso-8859-3*
699                              (the fixnum (- code #x2d8)))))))
700       (declare (type (mod #x110000) code))
701       (funcall write-function stream (or c2
702                                          (note-encoding-problem
703                                           char stream :iso-8859-3 (char-code #\Sub))))
704       1)))
705  :stream-decode-function
706  (nfunction
707   iso-8859-3-stream-decode
708   (lambda (1st-unit next-unit-function stream)
709     (declare (ignore next-unit-function stream)
710              (type (unsigned-byte 8) 1st-unit))
711     (if (< 1st-unit #xa0)
712       (code-char 1st-unit)
713       (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0))))))
714  :vector-encode-function
715  (nfunction
716   iso-8859-3-vector-encode
717   (lambda (string vector idx start end)
718     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
719              (fixnum idx))
720     (do* ((i start (1+ i)))
721          ((>= i end) idx)
722       (let* ((char (schar string i))
723              (code (char-code char))
724              (c2 (cond ((< code #xa0) code)
725                        ((< code #x100)
726                         (svref *unicode-a0-100-to-iso-8859-3*
727                                (the fixnum (- code #xa0))))
728                        ((and (>= code #x108) (< code #x180))
729                         (svref *unicode-108-180-to-iso-8859-3*
730                                (the fixnum (- code #x108))))
731                        ((and (>= code #x2d8) (< code #x2e0))
732                         (svref *unicode-2d8-2e0-to-iso-8859-3*
733                 
734               (the fixnum (- code #x2d8)))))))
735         (declare (type (mod #x110000) code))
736         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-3 (char-code #\Sub))))
737         (incf idx)))))
738  :vector-decode-function
739  (nfunction
740   iso-8859-3-vector-decode
741   (lambda (vector idx noctets string)
742     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
743     (do* ((i 0 (1+ i))
744           (index idx (1+ index)))
745          ((>= i noctets) index)
746         (let* ((1st-unit (aref vector index)))
747           (declare (type (unsigned-byte 8) 1st-unit))
748           (setf (schar string i)
749                 (if (< 1st-unit #xa0)
750                   (code-char 1st-unit)
751                   (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
752  :memory-encode-function
753  (nfunction
754   iso-8859-3-memory-encode
755   (lambda (string pointer idx start end)
756     (do* ((i start (1+ i)))
757          ((>= i end) idx)
758       (let* ((char (schar string i))
759              (code (char-code char))
760              (c2 (cond ((< code #xa0) code)
761                        ((< code #x100)
762                         (svref *unicode-a0-100-to-iso-8859-3*
763                                (the fixnum (- code #xa0))))
764                        ((and (>= code #x108) (< code #x180))
765                         (svref *unicode-108-180-to-iso-8859-3*
766                                (the fixnum (- code #x108))))
767                        ((and (>= code #x2d8) (< code #x2e0))
768                         (svref *unicode-2d8-2e0-to-iso-8859-3*
769                                (the fixnum (- code #x2d8)))))))
770         (declare (type (mod #x110000) code))
771         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-3 (char-code #\Sub))))
772         (incf idx)))))
773  :memory-decode-function
774  (nfunction
775   iso-8859-3-memory-decode
776   (lambda (pointer noctets idx string)
777     (do* ((i 0 (1+ i))
778           (index idx (1+ index)))
779          ((>= i noctets) index)
780       (let* ((1st-unit (%get-unsigned-byte pointer index)))
781         (declare (type (unsigned-byte 8) 1st-unit))
782         (setf (schar string i)
783               (if (< 1st-unit #xa0)
784                 (code-char 1st-unit)
785                 (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
786  :octets-in-string-function
787  #'8-bit-fixed-width-octets-in-string
788  :length-of-vector-encoding-function
789  #'8-bit-fixed-width-length-of-vector-encoding
790  :length-of-memory-encoding-function 
791  #'8-bit-fixed-width-length-of-memory-encoding
792  :decode-literal-code-unit-limit #xa0
793  :encode-literal-char-code-limit #xa0 
794  )
795
796
797(defstatic *iso-8859-4-to-unicode*
798  #(
799    ;; #xa0
800    #\u+00a0 #\u+0104 #\u+0138 #\u+0156 #\u+00a4 #\u+0128 #\u+013b #\u+00a7
801    #\u+00a8 #\u+0160 #\u+0112 #\u+0122 #\u+0166 #\u+00ad #\u+017d #\u+00af
802    ;; #xb0
803    #\u+00b0 #\u+0105 #\u+02db #\u+0157 #\u+00b4 #\u+0129 #\u+013c #\u+02c7
804    #\u+00b8 #\u+0161 #\u+0113 #\u+0123 #\u+0167 #\u+014a #\u+017e #\u+014b
805    ;; #xc0
806    #\u+0100 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+012e
807    #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+0116 #\u+00cd #\u+00ce #\u+012a
808    ;; #xd0
809    #\u+0110 #\u+0145 #\u+014c #\u+0136 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7
810    #\u+00d8 #\u+0172 #\u+00da #\u+00db #\u+00dc #\u+0168 #\u+016a #\u+00df
811    ;; #xe0
812    #\u+0101 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+012f
813    #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+0117 #\u+00ed #\u+00ee #\u+012b
814    ;; #xf0
815    #\u+0111 #\u+0146 #\u+014d #\u+0137 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7
816    #\u+00f8 #\u+0173 #\u+00fa #\u+00fb #\u+00fc #\u+0169 #\u+016b #\u+02d9
817    ))
818
819
820(defstatic *unicode-a0-180-to-iso-8859-4*
821  #(
822    #xa0 nil nil nil #xa4 nil nil #xa7  ; #xa0-#xa7
823    #xa8 nil nil nil nil #xad nil #xaf  ; #xa8-#xaf
824    #xb0 nil nil nil #xb4 nil nil nil   ; #xb0-#xb7
825    #xb8 nil nil nil nil nil nil nil    ; #xb8-#xbf
826    nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 nil ; #xc0-#xc7
827    nil #xc9 nil #xcb nil #xcd #xce nil ; #xc8-#xcf
828    nil nil nil nil #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7
829    #xd8 nil #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf
830    nil #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 nil ; #xe0-#xe7
831    nil #xe9 nil #xeb nil #xed #xee nil ; #xe8-#xef
832    nil nil nil nil #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7
833    #xf8 nil #xfa #xfb #xfc nil nil nil ; #xf8-#xff
834    #xc0 #xe0 nil nil #xa1 #xb1 nil nil ; #x100-#x107
835    nil nil nil nil #xc8 #xe8 nil nil   ; #x108-#x10f
836    #xd0 #xf0 #xaa #xba nil nil #xcc #xec ; #x110-#x117
837    #xca #xea nil nil nil nil nil nil   ; #x118-#x11f
838    nil nil #xab #xbb nil nil nil nil   ; #x120-#x127
839    #xa5 #xb5 #xcf #xef nil nil #xc7 #xe7 ; #x128-#x12f
840    nil nil nil nil nil nil #xd3 #xf3   ; #x130-#x137
841    #xa2 nil nil #xa6 #xb6 nil nil nil  ; #x138-#x13f
842    nil nil nil nil nil #xd1 #xf1 nil   ; #x140-#x147
843    nil nil #xbd #xbf #xd2 #xf2 nil nil ; #x148-#x14f
844    nil nil nil nil nil nil #xa3 #xb3   ; #x150-#x157
845    nil nil nil nil nil nil nil nil     ; #x158-#x15f
846    #xa9 #xb9 nil nil nil nil #xac #xbc ; #x160-#x167
847    #xdd #xfd #xde #xfe nil nil nil nil ; #x168-#x16f
848    nil nil #xd9 #xf9 nil nil nil nil   ; #x170-#x177
849    nil nil nil nil nil #xae #xbe nil   ; #x178-#x17f
850    ))
851
852(defstatic *unicode-2c0-2e0-to-iso-8859-4*
853  #(
854    nil nil nil nil nil nil nil #xb7    ; #x2c0-#x2c7
855    nil nil nil nil nil nil nil nil     ; #x2c8-#x2cf
856    nil nil nil nil nil nil nil nil     ; #x2d0-#x2d7
857    nil #xff nil #xb2 nil nil nil nil   ; #x2d8-#x2df
858    ))
859
860
861
862(define-character-encoding :iso-8859-4
863  "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
864map to their Unicode equivalents and other codes map to other Unicode
865character values.  Intended to provide most characters found in most
866languages used in Northern Europe."
867
868  :aliases '(:iso_8859-4 :latin4 :l4 :csisolatin4)
869  :stream-encode-function
870  (nfunction
871   iso-8859-4-stream-encode
872   (lambda (char write-function stream)
873     (let* ((code (char-code char))
874            (c2 (cond ((< code #xa0) code)
875                      ((< code #x180)
876                       (svref *unicode-a0-180-to-iso-8859-4*
877                              (the fixnum (- code #xa0))))
878                      ((and (>= code #x2d8) (< code #x2e0))
879                       (svref *unicode-2c0-2e0-to-iso-8859-4*
880                              (the fixnum (- code #x2c0)))))))
881                     
882       (declare (type (mod #x110000) code))
883       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-4 (char-code #\Sub))))
884       1)))
885  :stream-decode-function
886  (nfunction
887   iso-8859-4-stream-decode
888   (lambda (1st-unit next-unit-function stream)
889     (declare (ignore next-unit-function stream)
890              (type (unsigned-byte 8) 1st-unit))
891     (if (< 1st-unit #xa0)
892       (code-char 1st-unit)
893       (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0))))))
894  :vector-encode-function
895  (nfunction
896   iso-8859-4-vector-encode
897   (lambda (string vector idx start end)
898     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
899              (fixnum idx))
900     (do* ((i start (1+ i)))
901          ((>= i end) idx)
902       (let* ((char (schar string i))
903              (code (char-code char))
904              (c2 (cond ((< code #xa0) code)
905                        ((< code #x180)
906                         (svref *unicode-a0-180-to-iso-8859-4*
907                                (the fixnum (- code #xa0))))
908                        ((and (>= code #x2d8) (< code #x2e0))
909                         (svref *unicode-2c0-2e0-to-iso-8859-4*
910                                (the fixnum (- code #x2c0)))))))
911         (declare (type (mod #x110000) code))
912         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-4 (char-code #\Sub))))
913         (incf idx)))))
914  :vector-decode-function
915  (nfunction
916   iso-8859-4-vector-decode
917   (lambda (vector idx noctets string)
918     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
919     (do* ((i 0 (1+ i))
920           (index idx (1+ index)))
921          ((>= i noctets) index)
922       (let* ((1st-unit (aref vector index)))
923         (declare (type (unsigned-byte 8) 1st-unit))
924         (setf (schar string i)
925               (if (< 1st-unit #xa0)
926                 (code-char 1st-unit)
927                 (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
928  :memory-encode-function
929  (nfunction
930   iso-8859-4-memory-encode
931   (lambda (string pointer idx start end)
932     (do* ((i start (1+ i)))
933          ((>= i end) idx)
934       (let* ((char (schar string i))
935              (code (char-code char))
936              (c2 (cond ((< code #xa0) code)
937                        ((< code #x180)
938                         (svref *unicode-a0-180-to-iso-8859-4*
939                                (the fixnum (- code #xa0))))
940                        ((and (>= code #x2d8) (< code #x2e0))
941                         (svref *unicode-2c0-2e0-to-iso-8859-4*
942                                (the fixnum (- code #x2c0)))))))
943         (declare (type (mod #x110000) code))
944         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-4 (char-code #\Sub))))
945         (incf idx)))))
946  :memory-decode-function
947  (nfunction
948   iso-8859-4-memory-decode
949   (lambda (pointer noctets idx string)
950     (do* ((i 0 (1+ i))
951           (index idx (1+ index)))
952          ((>= i noctets) index)
953       (let* ((1st-unit (%get-unsigned-byte pointer index)))
954         (declare (type (unsigned-byte 8) 1st-unit))
955         (setf (schar string i)
956               (if (< 1st-unit #xa0)
957                 (code-char 1st-unit)
958                 (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
959  :octets-in-string-function
960  #'8-bit-fixed-width-octets-in-string
961  :length-of-vector-encoding-function
962  #'8-bit-fixed-width-length-of-vector-encoding
963  :length-of-memory-encoding-function 
964  #'8-bit-fixed-width-length-of-memory-encoding
965  :decode-literal-code-unit-limit #xa0
966  :encode-literal-char-code-limit #xa0 
967  )
968
969(defstatic *iso-8859-5-to-unicode*
970  #(
971    ;; #xa0
972    #\u+00a0 #\u+0401 #\u+0402 #\u+0403 #\u+0404 #\u+0405 #\u+0406 #\u+0407
973    #\u+0408 #\u+0409 #\u+040a #\u+040b #\u+040c #\u+00ad #\u+040e #\u+040f
974    ;; #xb0
975    #\u+0410 #\u+0411 #\u+0412 #\u+0413 #\u+0414 #\u+0415 #\u+0416 #\u+0417
976    #\u+0418 #\u+0419 #\u+041a #\u+041b #\u+041c #\u+041d #\u+041e #\u+041f
977    ;; #xc0
978    #\u+0420 #\u+0421 #\u+0422 #\u+0423 #\u+0424 #\u+0425 #\u+0426 #\u+0427
979    #\u+0428 #\u+0429 #\u+042a #\u+042b #\u+042c #\u+042d #\u+042e #\u+042f
980    ;; #xd0
981    #\u+0430 #\u+0431 #\u+0432 #\u+0433 #\u+0434 #\u+0435 #\u+0436 #\u+0437
982    #\u+0438 #\u+0439 #\u+043a #\u+043b #\u+043c #\u+043d #\u+043e #\u+043f
983    ;; #xe0
984    #\u+0440 #\u+0441 #\u+0442 #\u+0443 #\u+0444 #\u+0445 #\u+0446 #\u+0447
985    #\u+0448 #\u+0449 #\u+044a #\u+044b #\u+044c #\u+044d #\u+044e #\u+044f
986    ;; #xf0
987    #\u+2116 #\u+0451 #\u+0452 #\u+0453 #\u+0454 #\u+0455 #\u+0456 #\u+0457
988    #\u+0458 #\u+0459 #\u+045a #\u+045b #\u+045c #\u+00a7 #\u+045e #\u+045f
989    ))
990
991
992(defstatic *unicode-a0-b0-to-iso-8859-5*
993  #(
994    #xa0 nil nil nil nil nil nil #xfd   ; #xa0-#xa7
995    nil nil nil nil nil #xad nil nil    ; #xa8-#xaf
996    ))
997
998(defstatic *unicode-400-460-to-iso-8859-5*
999  #(
1000    nil #xa1 #xa2 #xa3 #xa4 #xa5 #xa6 #xa7 ; #x400-#x407
1001    #xa8 #xa9 #xaa #xab #xac nil #xae #xaf ; #x408-#x40f
1002    #xb0 #xb1 #xb2 #xb3 #xb4 #xb5 #xb6 #xb7 ; #x410-#x417
1003    #xb8 #xb9 #xba #xbb #xbc #xbd #xbe #xbf ; #x418-#x41f
1004    #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x420-#x427
1005    #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x428-#x42f
1006    #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #x430-#x437
1007    #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #x438-#x43f
1008    #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x440-#x447
1009    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x448-#x44f
1010    nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x450-#x457
1011    #xf8 #xf9 #xfa #xfb #xfc nil #xfe #xff ; #x458-#x45f
1012    ))
1013
1014
1015(define-character-encoding :iso-8859-5
1016  "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
1017map to their Unicode equivalents and other codes map to other Unicode
1018character values.  Intended to provide most characters found in the
1019Cyrillic alphabet."
1020
1021  :aliases '(:iso_8859-5 :cyrillic :csISOLatinCyrillic :iso-ir-144)
1022  :stream-encode-function
1023  (nfunction
1024   iso-8859-5-stream-encode
1025   (lambda (char write-function stream)
1026     (let* ((code (char-code char))
1027            (c2 (cond ((< code #xa0) code)
1028                      ((< code #xb0)
1029                       (svref *unicode-a0-b0-to-iso-8859-5*
1030                              (the fixnum (- code #xa0))))
1031                      ((and (>= code #x400) (< code #x460))
1032                       (svref *unicode-400-460-to-iso-8859-5*
1033                              (the fixnum (- code #x400)))))))
1034                     
1035       (declare (type (mod #x110000) code))
1036       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-5 (char-code #\Sub))))
1037       1)))
1038  :stream-decode-function
1039  (nfunction
1040   iso-8859-5-stream-decode
1041   (lambda (1st-unit next-unit-function stream)
1042     (declare (ignore next-unit-function stream)
1043              (type (unsigned-byte 8) 1st-unit))
1044     (if (< 1st-unit #xa0)
1045       (code-char 1st-unit)
1046       (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0))))))
1047  :vector-encode-function
1048  (nfunction
1049   iso-8859-5-vector-encode
1050   (lambda (string vector idx start end)
1051     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1052              (fixnum idx))
1053     (do* ((i start (1+ i)))
1054          ((>= i end) idx)
1055       (let* ((char (schar string i))
1056              (code (char-code char))
1057              (c2 (cond ((< code #xa0) code)
1058                        ((< code #xb0)
1059                         (svref *unicode-a0-b0-to-iso-8859-5*
1060                                (the fixnum (- code #xa0))))
1061                        ((and (>= code #x400) (< code #x460))
1062                         (svref *unicode-400-460-to-iso-8859-5*
1063                                (the fixnum (- code #x400)))))))
1064         (declare (type (mod #x110000) code))
1065         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-5 (char-code #\Sub))))
1066         (incf idx)))))
1067  :vector-decode-function
1068  (nfunction
1069   iso-8859-5-vector-decode
1070   (lambda (vector idx noctets string)
1071     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1072     (do* ((i 0 (1+ i))
1073           (index idx (1+ index)))
1074          ((>= i noctets) index)
1075       (let* ((1st-unit (aref vector index)))
1076         (declare (type (unsigned-byte 8) 1st-unit))
1077         (setf (schar string i)
1078               (if (< 1st-unit #xa0)
1079                 (code-char 1st-unit)
1080                 (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1081  :memory-encode-function
1082  (nfunction
1083   iso-8859-5-memory-encode
1084   (lambda (string pointer idx start end)
1085     (do* ((i start (1+ i)))
1086          ((>= i end) idx)
1087       (let* ((char (schar string i))
1088              (code (char-code char))
1089              (c2 (cond ((< code #xa0) code)
1090                        ((< code #xb0)
1091                         (svref *unicode-a0-b0-to-iso-8859-5*
1092                                (the fixnum (- code #xa0))))
1093                        ((and (>= code #x400) (< code #x460))
1094                         (svref *unicode-400-460-to-iso-8859-5*
1095                                (the fixnum (- code #x400)))))))
1096         (declare (type (mod #x110000) code))
1097         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-5 (char-code #\Sub))))
1098         (incf idx)))))
1099  :memory-decode-function
1100  (nfunction
1101   iso-8859-5-memory-decode
1102   (lambda (pointer noctets idx string)
1103     (do* ((i 0 (1+ i))
1104           (index idx (1+ index)))
1105          ((>= i noctets) index)
1106       (let* ((1st-unit (%get-unsigned-byte pointer index)))
1107         (declare (type (unsigned-byte 8) 1st-unit))
1108         (setf (schar string i)
1109               (if (< 1st-unit #xa0)
1110                 (code-char 1st-unit)
1111                 (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1112  :octets-in-string-function
1113  #'8-bit-fixed-width-octets-in-string
1114  :length-of-vector-encoding-function
1115  #'8-bit-fixed-width-length-of-vector-encoding
1116  :length-of-memory-encoding-function 
1117  #'8-bit-fixed-width-length-of-memory-encoding
1118  :decode-literal-code-unit-limit #xa0
1119  :encode-literal-char-code-limit #xa0
1120  )
1121
1122(defstatic *iso-8859-6-to-unicode*
1123  #(
1124    ;; #xa0
1125    #\u+00a0 #\u+fffd #\u+fffd #\u+fffd #\u+00a4 #\u+fffd #\u+fffd #\u+fffd
1126    #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+060c #\u+00ad #\u+fffd #\u+fffd
1127    ;; #xb0
1128    #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd
1129    #\u+fffd #\u+fffd #\u+fffd #\u+061b #\u+fffd #\u+fffd #\u+fffd #\u+061f
1130    ;; #xc0
1131    #\u+fffd #\u+0621 #\u+0622 #\u+0623 #\u+0624 #\u+0625 #\u+0626 #\u+0627
1132    #\u+0628 #\u+0629 #\u+062a #\u+062b #\u+062c #\u+062d #\u+062e #\u+062f
1133    ;; #xd0
1134    #\u+0630 #\u+0631 #\u+0632 #\u+0633 #\u+0634 #\u+0635 #\u+0636 #\u+0637
1135    #\u+0638 #\u+0639 #\u+063a #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd
1136    ;; #xe0
1137    #\u+0640 #\u+0641 #\u+0642 #\u+0643 #\u+0644 #\u+0645 #\u+0646 #\u+0647
1138    #\u+0648 #\u+0649 #\u+064a #\u+064b #\u+064c #\u+064d #\u+064e #\u+064f
1139    ;; #xf0
1140    #\u+0650 #\u+0651 #\u+0652 #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd
1141    #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd
1142    ))
1143
1144(defstatic *unicode-a0-b0-to-iso-8859-6*
1145  #(
1146    0xa0 nil nil nil 0xa4 nil nil nil   ; #xa0-#xa7
1147    nil nil nil nil nil #xad nil nil    ; #xa8-#xaf
1148    ))
1149
1150
1151(defstatic *unicode-608-658-to-iso-8859-6*
1152  #(
1153    nil nil nil nil #xac nil nil nil    ; #x608-#x60f
1154    nil nil nil nil nil nil nil nil     ; #x610-#x617
1155    nil nil nil #xbb nil nil nil #xbf   ; #x618-#x61f
1156    nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x620-#x627
1157    #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x628-#x62f
1158    #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #x630-#x637
1159    #xd8 #xd9 #xda nil nil nil nil nil  ; #x638-#x63f
1160    #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x640-#x647
1161    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x648-#x64f
1162    #xf0 #xf1 #xf2 nil nil nil nil nil  ; #x650-#x657
1163    ))
1164
1165(define-character-encoding :iso-8859-6
1166    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
1167map to their Unicode equivalents and other codes map to other Unicode
1168character values.  Intended to provide most characters found in the
1169Arabic alphabet."
1170
1171  :aliases '(:iso_8859-6 :arabic :csISOLatinArabic :iso-ir-127)
1172  :stream-encode-function
1173  (nfunction
1174   iso-8859-6-stream-encode
1175   (lambda (char write-function stream)
1176     (let* ((code (char-code char))
1177            (c2 (cond ((< code #xa0) code)
1178                      ((< code #xb0)
1179                       (svref *unicode-a0-b0-to-iso-8859-6*
1180                              (the fixnum (- code #xa0))))
1181                      ((and (>= code #x608) (< code #x658))
1182                       (svref *unicode-608-658-to-iso-8859-6*
1183                              (the fixnum (- code #x608)))))))
1184                     
1185       (declare (type (mod #x110000) code))
1186       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-6 (char-code #\Sub))))
1187       1)))
1188  :stream-decode-function
1189  (nfunction
1190   iso-8859-6-stream-decode
1191   (lambda (1st-unit next-unit-function stream)
1192     (declare (ignore next-unit-function stream)
1193              (type (unsigned-byte 8) 1st-unit))
1194     (if (< 1st-unit #xa0)
1195       (code-char 1st-unit)
1196       (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0))))))
1197  :vector-encode-function
1198  (nfunction
1199   iso-8859-6-vector-encode
1200   (lambda (string vector idx start end)
1201     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1202              (fixnum idx))
1203     (do* ((i start (1+ i)))
1204          ((>= i end) idx)
1205       (let* ((char (schar string i))
1206              (code (char-code char))
1207              (c2 (cond ((< code #xa0) code)
1208                        ((< code #xb0)
1209                         (svref *unicode-a0-b0-to-iso-8859-6*
1210                                (the fixnum (- code #xa0))))
1211                        ((and (>= code #x608) (< code #x658))
1212                         (svref *unicode-608-658-to-iso-8859-6*
1213                                (the fixnum (- code #x608)))))))
1214         (declare (type (mod #x110000) code))
1215         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-6 (char-code #\Sub))))
1216         (incf idx)))))
1217  :vector-decode-function
1218  (nfunction
1219   iso-8859-6-vector-decode
1220   (lambda (vector idx noctets string)
1221     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1222     (do* ((i 0 (1+ i))
1223           (index idx (1+ index)))
1224          ((>= i noctets) index)
1225       (let* ((1st-unit (aref vector index)))
1226         (declare (type (unsigned-byte 8) 1st-unit))
1227         (setf (schar string i)
1228               (if (< 1st-unit #xa0)
1229                 (code-char 1st-unit)
1230                 (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1231  :memory-encode-function
1232  (nfunction
1233   iso-8859-6-memory-encode
1234   (lambda (string pointer idx start end)
1235     (do* ((i start (1+ i)))
1236          ((>= i end) idx)
1237       (let* ((char (schar string i))
1238              (code (char-code char))
1239              (c2 (cond ((< code #xa0) code)
1240                        ((< code #xb0)
1241                         (svref *unicode-a0-b0-to-iso-8859-6*
1242                                (the fixnum (- code #xa0))))
1243                        ((and (>= code #x608) (< code #x658))
1244                         (svref *unicode-608-658-to-iso-8859-6*
1245                                (the fixnum (- code #x608)))))))
1246         (declare (type (mod #x110000) code))
1247         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-6 (char-code #\Sub))))
1248         (incf idx)))))
1249  :memory-decode-function
1250  (nfunction
1251   iso-8859-6-memory-decode
1252   (lambda (pointer noctets idx string)
1253     (do* ((i 0 (1+ i))
1254           (index idx (1+ index)))
1255          ((>= i noctets) index)
1256       (let* ((1st-unit (%get-unsigned-byte pointer index)))
1257         (declare (type (unsigned-byte 8) 1st-unit))
1258         (setf (schar string i)
1259               (if (< 1st-unit #xa0)
1260                 (code-char 1st-unit)
1261                 (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1262  :octets-in-string-function
1263  #'8-bit-fixed-width-octets-in-string
1264  :length-of-vector-encoding-function
1265  #'8-bit-fixed-width-length-of-vector-encoding
1266  :length-of-memory-encoding-function 
1267  #'8-bit-fixed-width-length-of-memory-encoding
1268  :decode-literal-code-unit-limit #xa0
1269  :encode-literal-char-code-limit #xa0 
1270  )
1271
1272(defstatic *iso-8859-7-to-unicode*
1273  #(
1274    ;; #xa0
1275    #\u+00a0 #\u+2018 #\u+2019 #\u+00a3 #\u+20ac #\u+20af #\u+00a6 #\u+00a7
1276    #\u+00a8 #\u+00a9 #\u+037a #\u+00ab #\u+00ac #\u+00ad #\u+fffd #\u+2015
1277    ;; #xb0
1278    #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+0384 #\u+0385 #\u+0386 #\u+00b7
1279    #\u+0388 #\u+0389 #\u+038a #\u+00bb #\u+038c #\u+00bd #\u+038e #\u+038f
1280    ;; #xc0
1281    #\u+0390 #\u+0391 #\u+0392 #\u+0393 #\u+0394 #\u+0395 #\u+0396 #\u+0397
1282    #\u+0398 #\u+0399 #\u+039a #\u+039b #\u+039c #\u+039d #\u+039e #\u+039f
1283    ;; #xd0
1284    #\u+03a0 #\u+03a1 #\u+fffd #\u+03a3 #\u+03a4 #\u+03a5 #\u+03a6 #\u+03a7
1285    #\u+03a8 #\u+03a9 #\u+03aa #\u+03ab #\u+03ac #\u+03ad #\u+03ae #\u+03af
1286    ;; #xe0
1287    #\u+03b0 #\u+03b1 #\u+03b2 #\u+03b3 #\u+03b4 #\u+03b5 #\u+03b6 #\u+03b7
1288    #\u+03b8 #\u+03b9 #\u+03ba #\u+03bb #\u+03bc #\u+03bd #\u+03be #\u+03bf
1289    ;; #xf0
1290    #\u+03c0 #\u+03c1 #\u+03c2 #\u+03c3 #\u+03c4 #\u+03c5 #\u+03c6 #\u+03c7
1291    #\u+03c8 #\u+03c9 #\u+03ca #\u+03cb #\u+03cc #\u+03cd #\u+03ce #\u+fffd
1292    ))
1293
1294(defstatic *unicode-a0-c0-to-iso-8859-7*
1295  #(
1296    #xa0 nil nil #xa3 nil nil #xa6 #xa7 ; #xa0-#xa7
1297    #xa8 #xa9 nil #xab #xac #xad nil nil ; #xa8-#xaf
1298    #xb0 #xb1 #xb2 #xb3 nil nil nil #xb7 ; #xb0-#xb7
1299    nil nil nil #xbb nil #xbd nil nil   ; #xb8-#xbf
1300    ))
1301
1302(defstatic *unicode-378-3d0-to-iso-8859-7*
1303  #(
1304    nil nil #xaa nil nil nil nil nil    ; #x378-#x37f
1305    nil nil nil nil #xb4 #xb5 #xb6 nil  ; #x380-#x387
1306    #xb8 #xb9 #xba nil #xbc nil #xbe #xbf ; #x388-#x38f
1307    #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x390-#x397
1308    #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x398-#x39f
1309    #xd0 #xd1 nil #xd3 #xd4 #xd5 #xd6 #xd7 ; #x3a0-#x3a7
1310    #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #x3a8-#x3af
1311    #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x3b0-#x3b7
1312    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x3b8-#x3bf
1313    #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x3c0-#x3c7
1314    #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe nil ; #x3c8-#x3cf
1315    ))
1316
1317(defstatic *unicode-2010-2020-to-iso-8859-7*
1318  #(
1319    nil nil nil nil nil #xaf nil nil    ; #x2010-#x2017
1320    #xa1 #xa2 nil nil nil nil nil nil   ; #x2018-#x201f
1321    ))
1322
1323(defstatic *unicode-20ac-20b0-to-iso-8859-7*
1324  #(
1325    #xa4 nil nil #xa5
1326    ))
1327
1328(define-character-encoding :iso-8859-7
1329    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
1330map to their Unicode equivalents and other codes map to other Unicode
1331character values.  Intended to provide most characters found in the
1332Greek alphabet."
1333
1334  :aliases '(:iso_8859-7 :greek  :greek8 :csISOLatinGreek :iso-ir-126 :ELOT_928 :ecma-118)
1335  :stream-encode-function
1336  (nfunction
1337   iso-8859-7-stream-encode
1338   (lambda (char write-function stream)
1339     (let* ((code (char-code char))
1340            (c2 (cond ((< code #xa0) code)
1341                      ((< code #xc0)
1342                       (svref *unicode-a0-c0-to-iso-8859-7*
1343                              (the fixnum (- code #xa0))))
1344                      ((and (>= code #x378) (< code #x3d0))
1345                       (svref *unicode-378-3d0-to-iso-8859-7*
1346                              (the fixnum (- code #x378))))
1347                      ((and (>= code #x2010) (< code #x2020))
1348                       (svref *unicode-2010-2020-to-iso-8859-7*
1349                              (the fixnum (- code #x2010))))
1350                      ((and (>= code #x20ac) (< code #x20b0))
1351                       (svref *unicode-20ac-20b0-to-iso-8859-7*
1352                              (the fixnum (- code #x20ac)))))))
1353             
1354       (declare (type (mod #x110000) code))
1355       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-7 (char-code #\Sub))))
1356       1)))
1357  :stream-decode-function
1358  (nfunction
1359   iso-8859-7-stream-decode
1360   (lambda (1st-unit next-unit-function stream)
1361     (declare (ignore next-unit-function stream)
1362              (type (unsigned-byte 8) 1st-unit))
1363     (if (< 1st-unit #xa0)
1364       (code-char 1st-unit)
1365       (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0))))))
1366  :vector-encode-function
1367  (nfunction
1368   iso-8859-7-vector-encode
1369   (lambda (string vector idx start end)
1370     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1371              (fixnum idx))
1372     (do* ((i start (1+ i)))
1373          ((>= i end) idx)
1374       (let* ((char (schar string i))
1375              (code (char-code char))
1376              (c2 (cond ((< code #xa0) code)
1377                      ((< code #xc0)
1378                       (svref *unicode-a0-c0-to-iso-8859-7*
1379                              (the fixnum (- code #xa0))))
1380                      ((and (>= code #x378) (< code #x3d0))
1381                       (svref *unicode-378-3d0-to-iso-8859-7*
1382                              (the fixnum (- code #x378))))
1383                      ((and (>= code #x2010) (< code #x2020))
1384                       (svref *unicode-2010-2020-to-iso-8859-7*
1385                              (the fixnum (- code #x2010))))
1386                      ((and (>= code #x20ac) (< code #x20b0))
1387                       (svref *unicode-20ac-20b0-to-iso-8859-7*
1388                              (the fixnum (- code #x20ac)))))))
1389         (declare (type (mod #x110000) code))
1390         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-7 (char-code #\Sub))))
1391         (incf idx)))))
1392  :vector-decode-function
1393  (nfunction
1394   iso-8859-7-vector-decode
1395   (lambda (vector idx noctets string)
1396     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1397     (do* ((i 0 (1+ i))
1398           (index idx (1+ index)))
1399          ((>= i noctets) index)
1400       (let* ((1st-unit (aref vector index)))
1401         (declare (type (unsigned-byte 8) 1st-unit))
1402         (setf (schar string i)
1403               (if (< 1st-unit #xa0)
1404                 (code-char 1st-unit)
1405                 (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1406  :memory-encode-function
1407  (nfunction
1408   iso-8859-7-memory-encode
1409   (lambda (string pointer idx start end)
1410     (do* ((i start (1+ i)))
1411          ((>= i end) idx)
1412       (let* ((char (schar string i))
1413              (code (char-code char))
1414              (c2 (cond ((< code #xa0) code)
1415                      ((< code #xc0)
1416                       (svref *unicode-a0-c0-to-iso-8859-7*
1417                              (the fixnum (- code #xa0))))
1418                      ((and (>= code #x378) (< code #x3d0))
1419                       (svref *unicode-378-3d0-to-iso-8859-7*
1420                              (the fixnum (- code #x378))))
1421                      ((and (>= code #x2010) (< code #x2020))
1422                       (svref *unicode-2010-2020-to-iso-8859-7*
1423                              (the fixnum (- code #x2010))))
1424                      ((and (>= code #x20ac) (< code #x20b0))
1425                       (svref *unicode-20ac-20b0-to-iso-8859-7*
1426                              (the fixnum (- code #x20ac)))))))
1427         (declare (type (mod #x110000) code))
1428         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-7 (char-code #\Sub))))
1429         (incf idx)))))
1430  :memory-decode-function
1431  (nfunction
1432   iso-8859-7-memory-decode
1433   (lambda (pointer noctets idx string)
1434     (do* ((i 0 (1+ i))
1435           (index idx (1+ index)))
1436          ((>= i noctets) index)
1437       (let* ((1st-unit (%get-unsigned-byte pointer index)))
1438         (declare (type (unsigned-byte 8) 1st-unit))
1439         (setf (schar string i)
1440               (if (< 1st-unit #xa0)
1441                 (code-char 1st-unit)
1442                 (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1443  :octets-in-string-function
1444  #'8-bit-fixed-width-octets-in-string
1445  :length-of-vector-encoding-function
1446  #'8-bit-fixed-width-length-of-vector-encoding
1447  :length-of-memory-encoding-function 
1448  #'8-bit-fixed-width-length-of-memory-encoding
1449  :decode-literal-code-unit-limit #xa0
1450  :encode-literal-char-code-limit #xa0 
1451  )
1452
1453(defstatic *iso-8859-8-to-unicode*
1454  #(
1455    ;; #xa0
1456    #\u+00a0 #\u+fffd #\u+00a2 #\u+00a3 #\u+00a4 #\u+00a5 #\u+00a6 #\u+00a7
1457    #\u+00a8 #\u+00a9 #\u+00d7 #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00af
1458    ;; #xb0
1459    #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+00b4 #\u+00b5 #\u+00b6 #\u+00b7
1460    #\u+00b8 #\u+00b9 #\u+00f7 #\u+00bb #\u+00bc #\u+00bd #\u+00be #\u+fffd
1461    ;; #xc0
1462    #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd
1463    #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd
1464    ;; #xd0
1465    #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd
1466    #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+2017
1467    ;; #xe0
1468    #\u+05d0 #\u+05d1 #\u+05d2 #\u+05d3 #\u+05d4 #\u+05d5 #\u+05d6 #\u+05d7
1469    #\u+05d8 #\u+05d9 #\u+05da #\u+05db #\u+05dc #\u+05dd #\u+05de #\u+05df
1470    ;; #xf0
1471    #\u+05e0 #\u+05e1 #\u+05e2 #\u+05e3 #\u+05e4 #\u+05e5 #\u+05e6 #\u+05e7
1472    #\u+05e8 #\u+05e9 #\u+05ea #\u+fffd #\u+fffd #\u+200e #\u+200f #\u+fffd
1473    ))
1474
1475(defstatic *unicode-a0-f8-to-iso-8859-8*
1476  #(
1477    #xa0 nil #xa2 #xa3 #xa4 #xa5 #xa6 #xa7 ; #xa0-#xa7
1478    #xa8 #xa9 nil #xab #xac #xad #xae #xaf ; #xa8-#xaf
1479    #xb0 #xb1 #xb2 #xb3 #xb4 #xb5 #xb6 #xb7 ; #xb0-#xb7
1480    #xb8 #xb9 nil #xbb #xbc #xbd #xbe nil ; #xb8-#xbf
1481    nil nil nil nil nil nil nil nil     ; #xc0-#xc7
1482    nil nil nil nil nil nil nil nil     ; #xc8-#xcf
1483    nil nil nil nil nil nil nil #xaa    ; #xd0-#xd7
1484    nil nil nil nil nil nil nil nil     ; #xd8-#xdf
1485    nil nil nil nil nil nil nil nil     ; #xe0-#xe7
1486    nil nil nil nil nil nil nil nil     ; #xe8-#xef
1487    nil nil nil nil nil nil nil #xba    ; #xf0-#xf7
1488    ))
1489
1490(defstatic *unicode-5d0-5f0-to-iso-8859-8*
1491  #(
1492    #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x5d0-#x5d7
1493    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x5d8-#x5df
1494    #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x5e0-#x5e7
1495    #xf8 #xf9 #xfa nil nil nil nil nil  ; #x5e8-#x5ef
1496    ))
1497
1498(defstatic *unicode-2008-2018-to-iso-8859-8*
1499  #(
1500    nil nil nil nil nil nil #xfd #xfe   ; #x2008-#x200f
1501    nil nil nil nil nil nil nil #xdf    ; #x2010-#x2017
1502    ))   
1503
1504(define-character-encoding :iso-8859-8
1505    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
1506map to their Unicode equivalents and other codes map to other Unicode
1507character values.  Intended to provide most characters found in the
1508Hebrew alphabet."
1509
1510  :aliases '(:iso_8859-8 :hebrew :csISOLatinHebrew :iso-ir-138)
1511  :stream-encode-function
1512  (nfunction
1513   iso-8859-8-stream-encode
1514   (lambda (char write-function stream)
1515     (let* ((code (char-code char))
1516            (c2 (cond ((< code #xa0) code)
1517                      ((< code #xf8)
1518                       (svref *unicode-a0-f8-to-iso-8859-8*
1519                              (the fixnum (- code #xa0))))
1520                      ((and (>= code #x5d0) (< code #x5f0))
1521                       (svref *unicode-5d0-5f0-to-iso-8859-8*
1522                              (the fixnum (- code #x5d0))))
1523                      ((and (>= code #x2008) (< code #x2018))
1524                       (svref *unicode-2008-2018-to-iso-8859-8*
1525                              (the fixnum (- code #x2008)))))))
1526             
1527       (declare (type (mod #x110000) code))
1528       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-8 (char-code #\Sub))))
1529       1)))
1530  :stream-decode-function
1531  (nfunction
1532   iso-8859-8-stream-decode
1533   (lambda (1st-unit next-unit-function stream)
1534     (declare (ignore next-unit-function stream)
1535              (type (unsigned-byte 8) 1st-unit))
1536     (if (< 1st-unit #xa0)
1537       (code-char 1st-unit)
1538       (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0))))))
1539  :vector-encode-function
1540  (nfunction
1541   iso-8859-8-vector-encode
1542   (lambda (string vector idx start end)
1543     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1544              (fixnum idx))
1545     (do* ((i start (1+ i)))
1546          ((>= i end) idx)
1547       (let* ((char (schar string i))
1548              (code (char-code char))
1549              (c2 (cond ((< code #xa0) code)
1550                      ((< code #xf8)
1551                       (svref *unicode-a0-f8-to-iso-8859-8*
1552                              (the fixnum (- code #xa0))))
1553                      ((and (>= code #x5d0) (< code #x5f0))
1554                       (svref *unicode-5d0-5f0-to-iso-8859-8*
1555                              (the fixnum (- code #x5d0))))
1556                      ((and (>= code #x2008) (< code #x2018))
1557                       (svref *unicode-2008-2018-to-iso-8859-8*
1558                              (the fixnum (- code #x2008)))))))
1559         (declare (type (mod #x110000) code))
1560         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-8 (char-code #\Sub))))
1561         (incf idx)))))
1562  :vector-decode-function
1563  (nfunction
1564   iso-8859-8-vector-decode
1565   (lambda (vector idx noctets string)
1566     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1567     (do* ((i 0 (1+ i))
1568           (index idx (1+ index)))
1569          ((>= i noctets) index)
1570       (let* ((1st-unit (aref vector index)))
1571         (declare (type (unsigned-byte 8) 1st-unit))
1572         (setf (schar string i)
1573               (if (< 1st-unit #xa0)
1574                 (code-char 1st-unit)
1575                 (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1576  :memory-encode-function
1577  (nfunction
1578   iso-8859-8-memory-encode
1579   (lambda (string pointer idx start end)
1580     (do* ((i start (1+ i)))
1581          ((>= i end) idx)
1582       (let* ((char (schar string i))
1583              (code (char-code char))
1584              (c2 (cond ((< code #xa0) code)
1585                      ((< code #xf8)
1586                       (svref *unicode-a0-f8-to-iso-8859-8*
1587                              (the fixnum (- code #xa0))))
1588                      ((and (>= code #x5d0) (< code #x5f0))
1589                       (svref *unicode-5d0-5f0-to-iso-8859-8*
1590                              (the fixnum (- code #x5d0))))
1591                      ((and (>= code #x2008) (< code #x2018))
1592                       (svref *unicode-2008-2018-to-iso-8859-8*
1593                              (the fixnum (- code #x2008)))))))
1594         (declare (type (mod #x110000) code))
1595         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-8 (char-code #\Sub))))
1596         (incf idx)))))
1597  :memory-decode-function
1598  (nfunction
1599   iso-8859-8-memory-decode
1600   (lambda (pointer noctets idx string)
1601     (do* ((i 0 (1+ i))
1602           (index idx (1+ index)))
1603          ((>= i noctets) index)
1604       (let* ((1st-unit (%get-unsigned-byte pointer index)))
1605         (declare (type (unsigned-byte 8) 1st-unit))
1606         (setf (schar string i)
1607               (if (< 1st-unit #xa0)
1608                 (code-char 1st-unit)
1609                 (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1610  :octets-in-string-function
1611  #'8-bit-fixed-width-octets-in-string
1612  :length-of-vector-encoding-function
1613  #'8-bit-fixed-width-length-of-vector-encoding
1614  :length-of-memory-encoding-function 
1615  #'8-bit-fixed-width-length-of-memory-encoding
1616  :decode-literal-code-unit-limit #xa0
1617  :encode-literal-char-code-limit #xa0 
1618  )
1619
1620(defstatic *iso-8859-9-to-unicode*
1621  #(
1622    ;; #xd0
1623    #\u+011e #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7
1624    #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+0130 #\u+015e #\u+00df
1625    ;; #xe0
1626    #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7
1627    #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef
1628    ;; #xf0
1629    #\u+011f #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7
1630    #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+0131 #\u+015f #\u+00ff
1631    ))
1632
1633(defstatic *unicode-d0-100-to-iso-8859-9*
1634  #(
1635    nil #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7
1636    #xd8 #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf
1637    #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7
1638    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef
1639    nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7
1640    #xf8 #xf9 #xfa #xfb #xfc nil nil #xff ; #xf8-#xff
1641    ))
1642
1643(defstatic *unicode-118-160-to-iso-8859-9*
1644  #(
1645    nil nil nil nil nil nil #xd0 #xf0   ; #x118-#x11f
1646    nil nil nil nil nil nil nil nil     ; #x120-#x127
1647    nil nil nil nil nil nil nil nil     ; #x128-#x12f
1648    #xdd #xfd nil nil nil nil nil nil   ; #x130-#x137
1649    nil nil nil nil nil nil nil nil     ; #x138-#x13f
1650    nil nil nil nil nil nil nil nil     ; #x140-#x147
1651    nil nil nil nil nil nil nil nil     ; #x148-#x14f
1652    nil nil nil nil nil nil nil nil     ; #x150-#x157
1653    nil nil nil nil nil nil #xde #xfe   ; #x158-#x15f
1654    ))
1655
1656
1657(define-character-encoding :iso-8859-9
1658    "An 8-bit, fixed-width character encoding in which codes #x00-#xcf
1659map to their Unicode equivalents and other codes map to other Unicode
1660character values.  Intended to provide most characters found in the
1661Turkish alphabet."
1662
1663  :aliases '(:iso_8859-9 :latin5 :csISOLatin5 :iso-ir-148)
1664  :stream-encode-function
1665  (nfunction
1666   iso-8859-9-stream-encode
1667   (lambda (char write-function stream)
1668     (let* ((code (char-code char))
1669            (c2 (cond ((< code #xd0) code)
1670                      ((< code #x100)
1671                       (svref *unicode-d0-100-to-iso-8859-9*
1672                              (the fixnum (- code #xd0))))
1673                      ((and (>= code #x118) (< code #x160))
1674                       (svref *unicode-118-160-to-iso-8859-9*
1675                              (the fixnum (- code #x118)))))))
1676             
1677       (declare (type (mod #x110000) code))
1678       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-9 (char-code #\Sub))))
1679       1)))
1680  :stream-decode-function
1681  (nfunction
1682   iso-8859-9-stream-decode
1683   (lambda (1st-unit next-unit-function stream)
1684     (declare (ignore next-unit-function stream)
1685              (type (unsigned-byte 8) 1st-unit))
1686     (if (< 1st-unit #xa0)
1687       (code-char 1st-unit)
1688       (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0))))))
1689  :vector-encode-function
1690  (nfunction
1691   iso-8859-9-vector-encode
1692   (lambda (string vector idx start end)
1693     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1694              (fixnum idx))
1695     (do* ((i start (1+ i)))
1696          ((>= i end) idx)
1697       (let* ((char (schar string i))
1698              (code (char-code char))
1699              (c2 (cond ((< code #xd0) code)
1700                      ((< code #x100)
1701                       (svref *unicode-d0-100-to-iso-8859-9*
1702                              (the fixnum (- code #xd0))))
1703                      ((and (>= code #x118) (< code #x160))
1704                       (svref *unicode-118-160-to-iso-8859-9*
1705                              (the fixnum (- code #x118)))))))
1706         (declare (type (mod #x110000) code))
1707         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-9 (char-code #\Sub))))
1708         (incf idx)))))
1709  :vector-decode-function
1710  (nfunction
1711   iso-8859-9-vector-decode
1712   (lambda (vector idx noctets string)
1713     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1714     (do* ((i 0 (1+ i))
1715           (index idx (1+ index)))
1716          ((>= i noctets) index)
1717       (let* ((1st-unit (aref vector index)))
1718         (declare (type (unsigned-byte 8) 1st-unit))
1719         (setf (schar string i)
1720               (if (< 1st-unit #xa0)
1721                 (code-char 1st-unit)
1722                 (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1723  :memory-encode-function
1724  (nfunction
1725   iso-8859-9-memory-encode
1726   (lambda (string pointer idx start end)
1727     (do* ((i start (1+ i)))
1728          ((>= i end) idx)
1729       (let* ((char (schar string i))
1730              (code (char-code char))
1731              (c2 (cond ((< code #xd0) code)
1732                      ((< code #x100)
1733                       (svref *unicode-d0-100-to-iso-8859-9*
1734                              (the fixnum (- code #xd0))))
1735                      ((and (>= code #x118) (< code #x160))
1736                       (svref *unicode-118-160-to-iso-8859-9*
1737                              (the fixnum (- code #x118)))))))
1738         (declare (type (mod #x110000) code))
1739         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-9 (char-code #\Sub))))
1740         (incf idx)))))
1741  :memory-decode-function
1742  (nfunction
1743   iso-8859-9-memory-decode
1744   (lambda (pointer noctets idx string)
1745     (do* ((i 0 (1+ i))
1746           (index idx (1+ index)))
1747          ((>= i noctets) index)
1748       (let* ((1st-unit (%get-unsigned-byte pointer index)))
1749         (declare (type (unsigned-byte 8) 1st-unit))
1750         (setf (schar string i)
1751               (if (< 1st-unit #xa0)
1752                 (code-char 1st-unit)
1753                 (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1754  :octets-in-string-function
1755  #'8-bit-fixed-width-octets-in-string
1756  :length-of-vector-encoding-function
1757  #'8-bit-fixed-width-length-of-vector-encoding
1758  :length-of-memory-encoding-function 
1759  #'8-bit-fixed-width-length-of-memory-encoding
1760  :decode-literal-code-unit-limit #xd0
1761  :encode-literal-char-code-limit #xa0
1762  )
1763
1764(defstatic *iso-8859-10-to-unicode*
1765  #(
1766    ;; #xa0
1767    #\u+00a0 #\u+0104 #\u+0112 #\u+0122 #\u+012a #\u+0128 #\u+0136 #\u+00a7
1768    #\u+013b #\u+0110 #\u+0160 #\u+0166 #\u+017d #\u+00ad #\u+016a #\u+014a
1769    ;; #xb0
1770    #\u+00b0 #\u+0105 #\u+0113 #\u+0123 #\u+012b #\u+0129 #\u+0137 #\u+00b7
1771    #\u+013c #\u+0111 #\u+0161 #\u+0167 #\u+017e #\u+2015 #\u+016b #\u+014b
1772    ;; #xc0
1773    #\u+0100 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+012e
1774    #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+0116 #\u+00cd #\u+00ce #\u+00cf
1775    ;; #xd0
1776    #\u+00d0 #\u+0145 #\u+014c #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+0168
1777    #\u+00d8 #\u+0172 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+00de #\u+00df
1778    ;; #xe0
1779    #\u+0101 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+012f
1780    #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+0117 #\u+00ed #\u+00ee #\u+00ef
1781    ;; #xf0
1782    #\u+00f0 #\u+0146 #\u+014d #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+0169
1783    #\u+00f8 #\u+0173 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+00fe #\u+0138
1784    ))
1785
1786(defstatic *unicode-a0-180-to-iso-8859-10*
1787  #(
1788    #xa0 nil nil nil nil nil nil #xa7   ; #xa0-#xa7
1789    nil nil nil nil nil #xad nil nil    ; #xa8-#xaf
1790    #xb0 nil nil nil nil nil nil #xb7   ; #xb0-#xb7
1791    nil nil nil nil nil nil nil nil     ; #xb8-#xbf
1792    nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 nil ; #xc0-#xc7
1793    nil #xc9 nil #xcb nil #xcd #xce #xcf ; #xc8-#xcf
1794    #xd0 nil nil #xd3 #xd4 #xd5 #xd6 nil ; #xd0-#xd7
1795    #xd8 nil #xda #xdb #xdc #xdd #xde #xdf ; #xd8-#xdf
1796    nil #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 nil ; #xe0-#xe7
1797    nil #xe9 nil #xeb nil #xed #xee #xef ; #xe8-#xef
1798    #xf0 nil nil #xf3 #xf4 #xf5 #xf6 nil ; #xf0-#xf7
1799    #xf8 nil #xfa #xfb #xfc #xfd #xfe nil ; #xf8-#xff
1800    #xc0 #xe0 nil nil #xa1 #xb1 nil nil ; #x100-#x107
1801    nil nil nil nil #xc8 #xe8 nil nil   ; #x108-#x10f
1802    #xa9 #xb9 #xa2 #xb2 nil nil #xcc #xec ; #x110-#x117
1803    #xca #xea nil nil nil nil nil nil   ; #x118-#x11f
1804    nil nil #xa3 #xb3 nil nil nil nil   ; #x120-#x127
1805    #xa5 #xb5 #xa4 #xb4 nil nil #xc7 #xe7 ; #x128-#x12f
1806    nil nil nil nil nil nil #xa6 #xb6   ; #x130-#x137
1807    #xff nil nil #xa8 #xb8 nil nil nil  ; #x138-#x13f
1808    nil nil nil nil nil #xd1 #xf1 nil   ; #x140-#x147
1809    nil nil #xaf #xbf #xd2 #xf2 nil nil ; #x148-#x14f
1810    nil nil nil nil nil nil nil nil     ; #x150-#x157
1811    nil nil nil nil nil nil nil nil     ; #x158-#x15f
1812    #xaa #xba nil nil nil nil #xab #xbb ; #x160-#x167
1813    #xd7 #xf7 #xae #xbe nil nil nil nil ; #x168-#x16f
1814    nil nil #xd9 #xf9 nil nil nil nil   ; #x170-#x177
1815    nil nil nil nil nil #xac #xbc nil   ; #x178-#x17f
1816    ))
1817
1818(define-character-encoding :iso-8859-10
1819    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
1820map to their Unicode equivalents and other codes map to other Unicode
1821character values.  Intended to provide most characters found in Nordic
1822alphabets."
1823
1824  :aliases '(:iso_8859-10 :latin6 :csISOLatin6 :iso-ir-157)
1825  :stream-encode-function
1826  (nfunction
1827   iso-8859-10-stream-encode
1828   (lambda (char write-function stream)
1829     (let* ((code (char-code char))
1830            (c2 (cond ((< code #xa0) code)
1831                      ((< code #x180)
1832                       (svref *unicode-a0-180-to-iso-8859-10*
1833                              (the fixnum (- code #xa0)))))))
1834       (declare (type (mod #x110000) code))
1835       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-10 (char-code #\Sub))))
1836       1)))
1837  :stream-decode-function
1838  (nfunction
1839   iso-8859-10-stream-decode
1840   (lambda (1st-unit next-unit-function stream)
1841     (declare (ignore next-unit-function stream)
1842              (type (unsigned-byte 8) 1st-unit))
1843     (if (< 1st-unit #xa0)
1844       (code-char 1st-unit)
1845       (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0))))))
1846  :vector-encode-function
1847  (nfunction
1848   iso-8859-10-vector-encode
1849   (lambda (string vector idx start end)
1850     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1851              (fixnum idx))
1852     (do* ((i start (1+ i)))
1853          ((>= i end) idx)
1854       (let* ((char (schar string i))
1855              (code (char-code char))
1856              (c2 (cond ((< code #xa0) code)
1857                      ((< code #x180)
1858                       (svref *unicode-a0-180-to-iso-8859-10*
1859                              (the fixnum (- code #xa0)))))))
1860         (declare (type (mod #x110000) code))
1861         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-10 (char-code #\Sub))))
1862         (incf idx)))))
1863  :vector-decode-function
1864  (nfunction
1865   iso-8859-10-vector-decode
1866   (lambda (vector idx noctets string)
1867     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1868     (do* ((i 0 (1+ i))
1869           (index idx (1+ index)))
1870          ((>= i noctets) index)
1871       (let* ((1st-unit (aref vector index)))
1872         (declare (type (unsigned-byte 8) 1st-unit))
1873         (setf (schar string i)
1874               (if (< 1st-unit #xa0)
1875                 (code-char 1st-unit)
1876                 (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1877  :memory-encode-function
1878  (nfunction
1879   iso-8859-10-memory-encode
1880   (lambda (string pointer idx start end)
1881     (do* ((i start (1+ i)))
1882          ((>= i end) idx)
1883       (let* ((char (schar string i))
1884              (code (char-code char))
1885              (c2 (cond ((< code #xa0) code)
1886                      ((< code #x180)
1887                       (svref *unicode-a0-180-to-iso-8859-10*
1888                              (the fixnum (- code #xa0)))))))
1889         (declare (type (mod #x110000) code))
1890         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-10 (char-code #\Sub))))
1891         (incf idx)))))
1892  :memory-decode-function
1893  (nfunction
1894   iso-8859-10-memory-decode
1895   (lambda (pointer noctets idx string)
1896     (do* ((i 0 (1+ i))
1897           (index idx (1+ index)))
1898          ((>= i noctets) index)
1899       (let* ((1st-unit (%get-unsigned-byte pointer index)))
1900         (declare (type (unsigned-byte 8) 1st-unit))
1901         (setf (schar string i)
1902               (if (< 1st-unit #xa0)
1903                 (code-char 1st-unit)
1904                 (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
1905  :octets-in-string-function
1906  #'8-bit-fixed-width-octets-in-string
1907  :length-of-vector-encoding-function
1908  #'8-bit-fixed-width-length-of-vector-encoding
1909  :length-of-memory-encoding-function 
1910  #'8-bit-fixed-width-length-of-memory-encoding
1911  :decode-literal-code-unit-limit #xa0
1912  :encode-literal-char-code-limit #xa0 
1913  )
1914
1915(define-character-encoding :iso-8859-11
1916    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
1917map to their Unicode equivalents and other codes map to other Unicode
1918character values.  Intended to provide most characters found the  Thai
1919alphabet."
1920  :aliases '()
1921  :stream-encode-function
1922  (nfunction
1923   iso-8859-11-stream-encode
1924   (lambda (char write-function stream)
1925     (let* ((code (char-code char))
1926            (c2 (cond ((< code #xa1) code)
1927                      ((and (<= code #xfb)
1928                            (not (and (>= code #xdb) (<= code #xde))))
1929                       (+ code #x0d60)))))
1930       (declare (type (mod #x110000) code))
1931       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-11 (char-code #\Sub))))
1932       1)))
1933  :stream-decode-function
1934  (nfunction
1935   iso-8859-11-stream-decode
1936   (lambda (1st-unit next-unit-function stream)
1937     (declare (ignore next-unit-function)
1938              (type (unsigned-byte 8) 1st-unit))
1939     (if (< 1st-unit #xa1)
1940       (code-char 1st-unit)
1941       (if (and (>= 1st-unit #xe01)
1942                (<= 1st-unit #xe5b)
1943                (not (and (>= 1st-unit #xe3b)
1944                          (<= 1st-unit #xe3e))))
1945         (code-char (- 1st-unit #xd60))
1946         (note-stream-decoding-problem stream)))))
1947  :vector-encode-function
1948  (nfunction
1949   iso-8859-11-vector-encode
1950   (lambda (string vector idx start end)
1951     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
1952              (fixnum idx))
1953     (do* ((i start (1+ i)))
1954          ((>= i end) idx)
1955       (let* ((char (schar string i))
1956              (code (char-code char))
1957              (c2 (cond ((< code #xa1) code)
1958                      ((and (<= code #xfb)
1959                            (not (and (>= code #xdb) (<= code #xde))))
1960                       (+ code #x0d60)))))
1961         (declare (type (mod #x110000) code))
1962         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-11 (char-code #\Sub))))
1963         (incf idx)))))
1964  :vector-decode-function
1965  (nfunction
1966   iso-8859-11-vector-decode
1967   (lambda (vector idx noctets string)
1968     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
1969     (do* ((i 0 (1+ i))
1970           (index idx (1+ index)))
1971          ((>= i noctets) index)
1972       (let* ((1st-unit (aref vector index)))
1973         (declare (type (unsigned-byte 8) 1st-unit))
1974         (setf (schar string i)
1975               (if (< 1st-unit #xa1)
1976                 (code-char 1st-unit)
1977                 (if (and (>= 1st-unit #xe01)
1978                          (<= 1st-unit #xe5b)
1979                          (not (and (>= 1st-unit #xe3b)
1980                                    (<= 1st-unit #xe3e))))
1981                   (code-char (- 1st-unit #xd60))
1982                   (note-vector-decoding-problem vector index :iso-8859-11))))))))
1983  :memory-encode-function
1984  (nfunction
1985   iso-8859-11-memory-encode
1986   (lambda (string pointer idx start end)
1987     (do* ((i start (1+ i)))
1988          ((>= i end) idx)
1989       (let* ((char (schar string i))
1990              (code (char-code char))
1991              (c2 (cond ((< code #xa1) code)
1992                      ((and (<= code #xfb)
1993                            (not (and (>= code #xdb) (<= code #xde))))
1994                       (+ code #x0d60)))))
1995         (declare (type (mod #x110000) code))
1996         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-11 (char-code #\Sub))))
1997         (incf idx)))))
1998  :memory-decode-function
1999  (nfunction
2000   iso-8859-11-memory-decode
2001   (lambda (pointer noctets idx string)
2002     (do* ((i 0 (1+ i))
2003           (index idx (1+ index)))
2004          ((>= i noctets) index)
2005       (let* ((1st-unit (%get-unsigned-byte pointer index)))
2006         (declare (type (unsigned-byte 8) 1st-unit))
2007         (setf (schar string i)
2008               (if (< 1st-unit #xa1)
2009                 (code-char 1st-unit)
2010                 (if (and (>= 1st-unit #xe01)
2011                          (<= 1st-unit #xe5b)
2012                          (not (and (>= 1st-unit #xe3b)
2013                                    (<= 1st-unit #xe3e))))
2014                   (code-char (- 1st-unit #xd60))
2015                   (note-vector-decoding-problem pointer index :iso-8859-11))))))))
2016  :octets-in-string-function
2017  #'8-bit-fixed-width-octets-in-string
2018  :length-of-vector-encoding-function
2019  #'8-bit-fixed-width-length-of-vector-encoding
2020  :length-of-memory-encoding-function 
2021  #'8-bit-fixed-width-length-of-memory-encoding
2022  :decode-literal-code-unit-limit #xa0
2023  :encode-literal-char-code-limit #xa0 
2024  )
2025
2026;;; There is no iso-8859-12 encoding.
2027
2028(defstatic *iso-8859-13-to-unicode*
2029  #(
2030    ;; #xa0
2031    #\u+00a0 #\u+201d #\u+00a2 #\u+00a3 #\u+00a4 #\u+201e #\u+00a6 #\u+00a7
2032    #\u+00d8 #\u+00a9 #\u+0156 #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00c6
2033    ;; #xb0
2034    #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+201c #\u+00b5 #\u+00b6 #\u+00b7
2035    #\u+00f8 #\u+00b9 #\u+0157 #\u+00bb #\u+00bc #\u+00bd #\u+00be #\u+00e6
2036    ;; #xc0
2037    #\u+0104 #\u+012e #\u+0100 #\u+0106 #\u+00c4 #\u+00c5 #\u+0118 #\u+0112
2038    #\u+010c #\u+00c9 #\u+0179 #\u+0116 #\u+0122 #\u+0136 #\u+012a #\u+013b
2039    ;; #xd0
2040    #\u+0160 #\u+0143 #\u+0145 #\u+00d3 #\u+014c #\u+00d5 #\u+00d6 #\u+00d7
2041    #\u+0172 #\u+0141 #\u+015a #\u+016a #\u+00dc #\u+017b #\u+017d #\u+00df
2042    ;; #xe0
2043    #\u+0105 #\u+012f #\u+0101 #\u+0107 #\u+00e4 #\u+00e5 #\u+0119 #\u+0113
2044    #\u+010d #\u+00e9 #\u+017a #\u+0117 #\u+0123 #\u+0137 #\u+012b #\u+013c
2045    ;; #xf0
2046    #\u+0161 #\u+0144 #\u+0146 #\u+00f3 #\u+014d #\u+00f5 #\u+00f6 #\u+00f7
2047    #\u+0173 #\u+0142 #\u+015b #\u+016b #\u+00fc #\u+017c #\u+017e #\u+2019
2048    ))
2049
2050(defstatic *unicode-a0-180-to-iso-8859-13*
2051  #(
2052    #xa0 nil #xa2 #xa3 #xa4 nil #xa6 #xa7 ; #xa0-#xa7
2053    nil #xa9 nil #xab #xac #xad #xae nil ; #xa8-#xaf
2054    #xb0 #xb1 #xb2 #xb3 nil #xb5 #xb6 #xb7 ; #xb0-#xb7
2055    nil #xb9 nil #xbb #xbc #xbd #xbe nil ; #xb8-#xbf
2056    nil nil nil nil #xc4 #xc5 #xaf nil ; #xc0-#xc7
2057    nil #xc9 nil nil nil nil nil nil ; #xc8-#xcf
2058    nil nil nil #xd3 nil #xd5 #xd6 #xd7 ; #xd0-#xd7
2059    #xa8 nil nil nil #xdc nil nil #xdf ; #xd8-#xdf
2060    nil nil nil nil #xe4 #xe5 #xbf nil ; #xe0-#xe7
2061    nil #xe9 nil nil nil nil nil nil ; #xe8-#xef
2062    nil nil nil #xf3 nil #xf5 #xf6 #xf7 ; #xf0-#xf7
2063    #xb8 nil nil nil #xfc nil nil nil ; #xf8-#xff
2064    #xc2 #xe2 nil nil #xc0 #xe0 #xc3 #xe3 ; #x100-#x107
2065    nil nil nil nil #xc8 #xe8 nil nil ; #x108-#x10f
2066    nil nil #xc7 #xe7 nil nil #xcb #xeb ; #x110-#x117
2067    #xc6 #xe6 nil nil nil nil nil nil ; #x118-#x11f
2068    nil nil #xcc #xec nil nil nil nil ; #x120-#x127
2069    nil nil #xce #xee nil nil #xc1 #xe1 ; #x128-#x12f
2070    nil nil nil nil nil nil #xcd #xed ; #x130-#x137
2071    nil nil nil #xcf #xef nil nil nil ; #x138-#x13f
2072    nil #xd9 #xf9 #xd1 #xf1 #xd2 #xf2 nil ; #x140-#x147
2073    nil nil nil nil #xd4 #xf4 nil nil ; #x148-#x14f
2074    nil nil nil nil nil nil #xaa #xba ; #x150-#x157
2075    nil nil #xda #xfa nil nil nil nil ; #x158-#x15f
2076    #xd0 #xf0 nil nil nil nil nil nil ; #x160-#x167
2077    nil nil #xdb #xfb nil nil nil nil ; #x168-#x16f
2078    nil nil #xd8 #xf8 nil nil nil nil ; #x170-#x177
2079    nil #xca #xea #xdd #xfd #xde #xfe nil ; #x178-#x17f
2080    ))
2081
2082(defstatic *unicode-2018-2020-to-iso-8859-13*
2083  #(
2084    nil #xff nil nil #xb4 #xa1 #xa5 nil ; #x2018-#x201f */
2085    ))
2086
2087
2088(define-character-encoding :iso-8859-13
2089    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
2090map to their Unicode equivalents and other codes map to other Unicode
2091character values.  Intended to provide most characters found in Baltic
2092alphabets."
2093
2094  :aliases '()
2095  :stream-encode-function
2096  (nfunction
2097   iso-8859-13-stream-encode
2098   (lambda (char write-function stream)
2099     (let* ((code (char-code char))
2100            (c2 (cond ((< code #xa0) code)
2101                      ((< code #x180)
2102                       (svref *unicode-a0-180-to-iso-8859-13*
2103                              (the fixnum (- code #xa0))))
2104                      ((and (>= code #x2018)
2105                            (< code #x2020))
2106                       (svref *unicode-2018-2020-to-iso-8859-13*
2107                              (the fixnum (- code #x2018)))))))
2108       (declare (type (mod #x110000) code))
2109       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-13 (char-code #\Sub))))
2110       1)))
2111  :stream-decode-function
2112  (nfunction
2113   iso-8859-13-stream-decode
2114   (lambda (1st-unit next-unit-function stream)
2115     (declare (ignore next-unit-function stream)
2116              (type (unsigned-byte 8) 1st-unit))
2117     (if (< 1st-unit #xa0)
2118       (code-char 1st-unit)
2119       (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0))))))
2120  :vector-encode-function
2121  (nfunction
2122   iso-8859-13-vector-encode
2123   (lambda (string vector idx start end)
2124     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2125              (fixnum idx))
2126     (do* ((i start (1+ i)))
2127          ((>= i end) idx)
2128       (let* ((char (schar string i))
2129              (code (char-code char))
2130              (c2 (cond ((< code #xa0) code)
2131                      ((< code #x180)
2132                       (svref *unicode-a0-180-to-iso-8859-13*
2133                              (the fixnum (- code #xa0))))
2134                      ((and (>= code #x2018)
2135                            (< code #x2020))
2136                       (svref *unicode-2018-2020-to-iso-8859-13*
2137                              (the fixnum (- code #x2018)))))))
2138         (declare (type (mod #x110000) code))
2139         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-13 (char-code #\Sub))))
2140         (incf idx)))))
2141  :vector-decode-function
2142  (nfunction
2143   iso-8859-13-vector-decode
2144   (lambda (vector idx noctets string)
2145     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
2146     (do* ((i 0 (1+ i))
2147           (index idx (1+ index)))
2148          ((>= i noctets) index)
2149       (let* ((1st-unit (aref vector index)))
2150         (declare (type (unsigned-byte 8) 1st-unit))
2151         (setf (schar string i)
2152               (if (< 1st-unit #xa0)
2153                 (code-char 1st-unit)
2154                 (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
2155  :memory-encode-function
2156  (nfunction
2157   iso-8859-13-memory-encode
2158   (lambda (string pointer idx start end)
2159     (do* ((i start (1+ i)))
2160          ((>= i end) idx)
2161       (let* ((char (schar string i))
2162              (code (char-code char))
2163              (c2 (cond ((< code #xa0) code)
2164                      ((< code #x180)
2165                       (svref *unicode-a0-180-to-iso-8859-13*
2166                              (the fixnum (- code #xa0))))
2167                      ((and (>= code #x2018)
2168                            (< code #x2020))
2169                       (svref *unicode-2018-2020-to-iso-8859-13*
2170                              (the fixnum (- code #x2018)))))))
2171         (declare (type (mod #x110000) code))
2172         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-13 (char-code #\Sub))))
2173         (incf idx)))))
2174  :memory-decode-function
2175  (nfunction
2176   iso-8859-13-memory-decode
2177   (lambda (pointer noctets idx string)
2178     (do* ((i 0 (1+ i))
2179           (index idx (1+ index)))
2180          ((>= i noctets) index)
2181       (let* ((1st-unit (%get-unsigned-byte pointer index)))
2182         (declare (type (unsigned-byte 8) 1st-unit))
2183         (setf (schar string i)
2184               (if (< 1st-unit #xa0)
2185                 (code-char 1st-unit)
2186                 (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
2187  :octets-in-string-function
2188  #'8-bit-fixed-width-octets-in-string
2189  :length-of-vector-encoding-function
2190  #'8-bit-fixed-width-length-of-vector-encoding
2191  :length-of-memory-encoding-function 
2192  #'8-bit-fixed-width-length-of-memory-encoding
2193  :decode-literal-code-unit-limit #xa0
2194  :encode-literal-char-code-limit #xa0 
2195  )
2196
2197(defstatic *iso-8859-14-to-unicode*
2198  #(
2199    ;; #xa0
2200    #\u+00a0 #\u+1e02 #\u+1e03 #\u+00a3 #\u+010a #\u+010b #\u+1e0a #\u+00a7
2201    #\u+1e80 #\u+00a9 #\u+1e82 #\u+1e0b #\u+1ef2 #\u+00ad #\u+00ae #\u+0178
2202    ;; #xb0
2203    #\u+1e1e #\u+1e1f #\u+0120 #\u+0121 #\u+1e40 #\u+1e41 #\u+00b6 #\u+1e56
2204    #\u+1e81 #\u+1e57 #\u+1e83 #\u+1e60 #\u+1ef3 #\u+1e84 #\u+1e85 #\u+1e61
2205    ;; #xc0
2206    #\u+00c0 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+00c7
2207    #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf
2208    ;; #xd0
2209    #\u+0174 #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+1e6a
2210    #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+0176 #\u+00df
2211    ;; #xe0
2212    #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7
2213    #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef
2214    ;; #xf0
2215    #\u+0175 #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+1e6b
2216    #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+0177 #\u+00ff
2217    ))
2218
2219(defstatic *unicode-a0-100-to-iso-8859-14*
2220  #(
2221    #xa0 nil nil #xa3 nil nil nil #xa7  ; #xa0-#xa7
2222    nil #xa9 nil nil nil #xad #xae nil  ; #xa8-#xaf
2223    nil nil nil nil nil nil #xb6 nil    ; #xb0-#xb7
2224    nil nil nil nil nil nil nil nil     ; #xb8-#xbf
2225    #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #xc0-#xc7
2226    #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf
2227    nil #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 nil ; #xd0-#xd7
2228    #xd8 #xd9 #xda #xdb #xdc #xdd nil #xdf ; #xd8-#xdf
2229    #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7
2230    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef
2231    nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 nil ; #xf0-#xf7
2232    #xf8 #xf9 #xfa #xfb #xfc #xfd nil #xff ; #xf8-#xff
2233    ))
2234
2235(defstatic *unicode-108-128-to-iso-8859-14*
2236  #(
2237    nil nil #xa4 #xa5 nil nil nil nil   ; #x108-#x10f
2238    nil nil nil nil nil nil nil nil     ; #x110-#x117
2239    nil nil nil nil nil nil nil nil     ; #x118-#x11f
2240    #xb2 #xb3 nil nil nil nil nil nil   ; #x120-#x127
2241    ))
2242
2243(defstatic *unicode-170-180-to-iso-8859-14*
2244  #(
2245    nil nil nil nil #xd0 #xf0 #xde #xfe ; #x170-#x177
2246    #xaf nil nil nil nil nil nil nil    ; #x178-#x17f
2247    ))   
2248
2249(defstatic *unicode-1e00-1e88-to-iso-8859-14*
2250  #(
2251    nil nil #xa1 #xa2 nil nil nil nil   ; #x1e00-#x1e07
2252    nil nil #xa6 #xab nil nil nil nil   ; #x1e08-#x1e0f
2253    nil nil nil nil nil nil nil nil     ; #x1e10-#x1e17
2254    nil nil nil nil nil nil #xb0 #xb1   ; #x1e18-#x1e1f
2255    nil nil nil nil nil nil nil nil     ; #x1e20-#x1e27
2256    nil nil nil nil nil nil nil nil     ; #x1e28-#x1e2f
2257    nil nil nil nil nil nil nil nil     ; #x1e30-#x1e37
2258    nil nil nil nil nil nil nil nil     ; #x1e38-#x1e3f
2259    #xb4 #xb5 nil nil nil nil nil nil   ; #x1e40-#x1e47
2260    nil nil nil nil nil nil nil nil     ; #x1e48-#x1e4f
2261    nil nil nil nil nil nil #xb7 #xb9   ; #x1e50-#x1e57
2262    nil nil nil nil nil nil nil nil     ; #x1e58-#x1e5f
2263    #xbb #xbf nil nil nil nil nil nil   ; #x1e60-#x1e67
2264    nil nil #xd7 #xf7 nil nil nil nil   ; #x1e68-#x1e6f
2265    nil nil nil nil nil nil nil nil     ; #x1e70-#x1e77
2266    nil nil nil nil nil nil nil nil     ; #x1e78-#x1e7f
2267    #xa8 #xb8 #xaa #xba #xbd #xbe nil nil ; #x1e80-#x1e87
2268    ))
2269
2270(defstatic *unicode-1ef0-1ef8-to-iso-8859-14*
2271  #(
2272    nil nil #xac #xbc nil nil nil nil   ; #x1ef0-#x1ef7
2273    ))
2274
2275(define-character-encoding :iso-8859-14
2276    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
2277map to their Unicode equivalents and other codes map to other Unicode
2278character values.  Intended to provide most characters found in Celtic
2279languages."
2280  :aliases '(:iso_8859-14 :iso-ir-199 :latin8 :l8 :iso-celtic)
2281  :stream-encode-function
2282  (nfunction
2283   iso-8859-14-stream-encode
2284   (lambda (char write-function stream)
2285     (let* ((code (char-code char))
2286            (c2 (cond ((< code #xa0) code)
2287                      ((< code #x100)
2288                       (svref *unicode-a0-100-to-iso-8859-14*
2289                              (the fixnum (- code #xa0))))
2290                      ((and (>= code #x108) (< code #x128))
2291                       (svref *unicode-108-128-to-iso-8859-14*
2292                              (the fixnum (- code #x108))))
2293                      ((and (>= code #x170) (< code #x180))
2294                       (svref *unicode-170-180-to-iso-8859-14*
2295                              (the fixnum (- code #x170))))
2296                      ((and (>= code #x1e00) (< code #x1e88))
2297                       (svref *unicode-1e00-1e88-to-iso-8859-14*
2298                              (the fixnum (- code #x1e00))))
2299                      ((and (>= code #x1ef0) (< code #x1ef8))
2300                       (svref *unicode-1ef0-1ef8-to-iso-8859-14*
2301                              (the fixnum (- code #x1ef0)))))))
2302       (declare (type (mod #x110000) code))
2303       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-14 (char-code #\Sub))))
2304       1)))
2305  :stream-decode-function
2306  (nfunction
2307   iso-8859-14-stream-decode
2308   (lambda (1st-unit next-unit-function stream)
2309     (declare (ignore next-unit-function stream)
2310              (type (unsigned-byte 8) 1st-unit))
2311     (if (< 1st-unit #xa0)
2312       (code-char 1st-unit)
2313       (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0))))))
2314  :vector-encode-function
2315  (nfunction
2316   iso-8859-14-vector-encode
2317   (lambda (string vector idx start end)
2318     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2319              (fixnum idx))
2320     (do* ((i start (1+ i)))
2321          ((>= i end) idx)
2322       (let* ((char (schar string i))
2323              (code (char-code char))
2324              (c2 (cond ((< code #xa0) code)
2325                      ((< code #x100)
2326                       (svref *unicode-a0-100-to-iso-8859-14*
2327                              (the fixnum (- code #xa0))))
2328                      ((and (>= code #x108) (< code #x128))
2329                       (svref *unicode-108-128-to-iso-8859-14*
2330                              (the fixnum (- code #x108))))
2331                      ((and (>= code #x170) (< code #x180))
2332                       (svref *unicode-170-180-to-iso-8859-14*
2333                              (the fixnum (- code #x170))))
2334                      ((and (>= code #x1e00) (< code #x1e88))
2335                       (svref *unicode-1e00-1e88-to-iso-8859-14*
2336                              (the fixnum (- code #x1e00))))
2337                      ((and (>= code #x1ef0) (< code #x1ef8))
2338                       (svref *unicode-1ef0-1ef8-to-iso-8859-14*
2339                              (the fixnum (- code #x1ef0)))))))
2340         (declare (type (mod #x110000) code))
2341         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-14 (char-code #\Sub))))
2342         (incf idx)))))
2343  :vector-decode-function
2344  (nfunction
2345   iso-8859-14-vector-decode
2346   (lambda (vector idx noctets string)
2347     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
2348     (do* ((i 0 (1+ i))
2349           (index idx (1+ index)))
2350          ((>= i noctets) index)
2351       (let* ((1st-unit (aref vector index)))
2352         (declare (type (unsigned-byte 8) 1st-unit))
2353         (setf (schar string i)
2354               (if (< 1st-unit #xa0)
2355                 (code-char 1st-unit)
2356                 (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
2357  :memory-encode-function
2358  (nfunction
2359   iso-8859-14-memory-encode
2360   (lambda (string pointer idx start end)
2361     (do* ((i start (1+ i)))
2362          ((>= i end) idx)
2363       (let* ((char (schar string i))
2364              (code (char-code char))
2365              (c2 (cond ((< code #xa0) code)
2366                      ((< code #x100)
2367                       (svref *unicode-a0-100-to-iso-8859-14*
2368                              (the fixnum (- code #xa0))))
2369                      ((and (>= code #x108) (< code #x128))
2370                       (svref *unicode-108-128-to-iso-8859-14*
2371                              (the fixnum (- code #x108))))
2372                      ((and (>= code #x170) (< code #x180))
2373                       (svref *unicode-170-180-to-iso-8859-14*
2374                              (the fixnum (- code #x170))))
2375                      ((and (>= code #x1e00) (< code #x1e88))
2376                       (svref *unicode-1e00-1e88-to-iso-8859-14*
2377                              (the fixnum (- code #x1e00))))
2378                      ((and (>= code #x1ef0) (< code #x1ef8))
2379                       (svref *unicode-1ef0-1ef8-to-iso-8859-14*
2380                              (the fixnum (- code #x1ef0)))))))
2381         (declare (type (mod #x110000) code))
2382         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-14 (char-code #\Sub))))
2383         (incf idx)))))
2384  :memory-decode-function
2385  (nfunction
2386   iso-8859-14-memory-decode
2387   (lambda (pointer noctets idx string)
2388     (do* ((i 0 (1+ i))
2389           (index idx (1+ index)))
2390          ((>= i noctets) index)
2391       (let* ((1st-unit (%get-unsigned-byte pointer index)))
2392         (declare (type (unsigned-byte 8) 1st-unit))
2393         (setf (schar string i)
2394               (if (< 1st-unit #xa0)
2395                 (code-char 1st-unit)
2396                 (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
2397  :octets-in-string-function
2398  #'8-bit-fixed-width-octets-in-string
2399  :length-of-vector-encoding-function
2400  #'8-bit-fixed-width-length-of-vector-encoding
2401  :length-of-memory-encoding-function 
2402  #'8-bit-fixed-width-length-of-memory-encoding
2403  :decode-literal-code-unit-limit #xa0
2404  :encode-literal-char-code-limit #xa0 
2405  )
2406
2407(defstatic *iso-8859-15-to-unicode*
2408  #(
2409    ;; #xa0
2410    #\u+00a0 #\u+00a1 #\u+00a2 #\u+00a3 #\u+20ac #\u+00a5 #\u+0160 #\u+00a7
2411    #\u+0161 #\u+00a9 #\u+00aa #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00af
2412    ;; #xb0
2413    #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+017d #\u+00b5 #\u+00b6 #\u+00b7
2414    #\u+017e #\u+00b9 #\u+00ba #\u+00bb #\u+0152 #\u+0153 #\u+0178 #\u+00bf
2415    ;; #xc0
2416    #\u+00c0 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+00c7 
2417    ;; #xc8
2418    #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf 
2419    ;; #xd0
2420    #\u+00d0 #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7 
2421    ;; #xd8
2422    #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+00de #\u+00df 
2423    ;; #xe0
2424    #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7 
2425    ;; #xe8
2426    #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef 
2427    ;; #xf0
2428    #\u+00f0 #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7 
2429    ;; #xf8
2430    #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+00fe #\u+00ff 
2431    ))
2432
2433(defstatic *unicode-a0-100-to-iso-8859-15*
2434  #(
2435    #xa0 #xa1 #xa2 #xa3 nil #xa5 nil #xa7 ; #xa0-#xa7
2436    nil #xa9 #xaa #xab #xac #xad #xae #xaf ; #xa8-#xaf
2437    #xb0 #xb1 #xb2 #xb3 nil #xb5 #xb6 #xb7 ; #xb0-#xb7
2438    nil #xb9 #xba #xbb nil nil nil #xbf ; #xb8-0xbf
2439    #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #xc0-#xc7
2440    #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf
2441    #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7
2442    #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #xd8-#xdf
2443    #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7
2444    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef
2445    #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7
2446    #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff ; #xf8-#xff
2447    ))
2448
2449(defstatic *unicode-150-180-to-iso-8859-15*
2450  #(
2451    nil nil #xbc #xbd nil nil nil nil   ; #x150-#x157
2452    nil nil nil nil nil nil nil nil     ; #x158-#x15f
2453    #xa6 #xa8 nil nil nil nil nil nil   ; #x160-#x167
2454    nil nil nil nil nil nil nil nil     ; #x168-#x16f
2455    nil nil nil nil nil nil nil nil     ; #x170-#x177
2456    #xbe nil nil nil nil #xb4 #xb8 nil  ; #x178-#x17f
2457    ))
2458
2459(define-character-encoding :iso-8859-15
2460    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
2461map to their Unicode equivalents and other codes map to other Unicode
2462character values.  Intended to provide most characters found in Western
2463European languages (including the Euro sign and some other characters
2464missing from ISO-8859-1."
2465  :aliases '(:iso_8859-15 :latin9)
2466  :stream-encode-function
2467  (nfunction
2468   iso-8859-15-stream-encode
2469   (lambda (char write-function stream)
2470     (let* ((code (char-code char))
2471            (c2 (cond ((< code #xa0) code)
2472                      ((< code #x100)
2473                       (svref *unicode-a0-100-to-iso-8859-15*
2474                              (the fixnum (- code #xa0))))
2475                      ((and (>= code #x150) (< code #x180))
2476                       (svref *unicode-150-180-to-iso-8859-15*
2477                              (the fixnum (- code #x150))))
2478                      ((= code #x20ac) #xa4))))
2479       (declare (type (mod #x110000) code))
2480       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-15 (char-code #\Sub))))
2481       1)))
2482  :stream-decode-function
2483  (nfunction
2484   iso-8859-15-stream-decode
2485   (lambda (1st-unit next-unit-function stream)
2486     (declare (ignore next-unit-function stream)
2487              (type (unsigned-byte 8) 1st-unit))
2488     (if (< 1st-unit #xa0)
2489       (code-char 1st-unit)
2490       (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0))))))
2491  :vector-encode-function
2492  (nfunction
2493   iso-8859-15-vector-encode
2494   (lambda (string vector idx start end)
2495     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2496              (fixnum idx))
2497     (do* ((i start (1+ i)))
2498          ((>= i end) idx)
2499       (let* ((char (schar string i))
2500              (code (char-code char))
2501              (c2 (cond ((< code #xa0) code)
2502                      ((< code #x100)
2503                       (svref *unicode-a0-100-to-iso-8859-15*
2504                              (the fixnum (- code #xa0))))
2505                      ((and (>= code #x150) (< code #x180))
2506                       (svref *unicode-150-180-to-iso-8859-15*
2507                              (the fixnum (- code #x150))))
2508                      ((= code #x20ac) #xa4))))
2509         (declare (type (mod #x110000) code))
2510         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-15 (char-code #\Sub))))
2511         (incf idx)))))
2512  :vector-decode-function
2513  (nfunction
2514   iso-8859-15-vector-decode
2515   (lambda (vector idx noctets string)
2516     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
2517     (do* ((i 0 (1+ i))
2518           (index idx (1+ index)))
2519          ((>= i noctets) index)
2520       (let* ((1st-unit (aref vector index)))
2521         (declare (type (unsigned-byte 8) 1st-unit))
2522         (setf (schar string i)
2523               (if (< 1st-unit #xa0)
2524                 (code-char 1st-unit)
2525                 (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
2526  :memory-encode-function
2527  (nfunction
2528   iso-8859-15-memory-encode
2529   (lambda (string pointer idx start end)
2530     (do* ((i start (1+ i)))
2531          ((>= i end) idx)
2532       (let* ((char (schar string i))
2533              (code (char-code char))
2534              (c2 (cond ((< code #xa0) code)
2535                      ((< code #x100)
2536                       (svref *unicode-a0-100-to-iso-8859-15*
2537                              (the fixnum (- code #xa0))))
2538                      ((and (>= code #x150) (< code #x180))
2539                       (svref *unicode-150-180-to-iso-8859-15*
2540                              (the fixnum (- code #x150))))
2541                      ((= code #x20ac) #xa4))))
2542         (declare (type (mod #x110000) code))
2543         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-15 (char-code #\Sub))))
2544         (incf idx)))))
2545  :memory-decode-function
2546  (nfunction
2547   iso-8859-15-memory-decode
2548   (lambda (pointer noctets idx string)
2549     (do* ((i 0 (1+ i))
2550           (index idx (1+ index)))
2551          ((>= i noctets) index)
2552       (let* ((1st-unit (%get-unsigned-byte pointer index)))
2553         (declare (type (unsigned-byte 8) 1st-unit))
2554         (setf (schar string i)
2555               (if (< 1st-unit #xa0)
2556                 (code-char 1st-unit)
2557                 (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
2558  :octets-in-string-function
2559  #'8-bit-fixed-width-octets-in-string
2560  :length-of-vector-encoding-function
2561  #'8-bit-fixed-width-length-of-vector-encoding
2562  :length-of-memory-encoding-function 
2563  #'8-bit-fixed-width-length-of-memory-encoding
2564  :decode-literal-code-unit-limit #xa0
2565  :encode-literal-char-code-limit #xa0 
2566  )
2567
2568(defstatic *iso-8859-16-to-unicode*
2569  #(
2570    ;; #xa0
2571    #\u+00a0 #\u+0104 #\u+0105 #\u+0141 #\u+20ac #\u+201e #\u+0160 #\u+00a7
2572    #\u+0161 #\u+00a9 #\u+0218 #\u+00ab #\u+0179 #\u+00ad #\u+017a #\u+017b
2573    ;; #xb0
2574    #\u+00b0 #\u+00b1 #\u+010c #\u+0142 #\u+017d #\u+201d #\u+00b6 #\u+00b7
2575    #\u+017e #\u+010d #\u+0219 #\u+00bb #\u+0152 #\u+0153 #\u+0178 #\u+017c
2576    ;; #xc0
2577    #\u+00c0 #\u+00c1 #\u+00c2 #\u+0102 #\u+00c4 #\u+0106 #\u+00c6 #\u+00c7
2578    #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf
2579    ;; #xd0
2580    #\u+0110 #\u+0143 #\u+00d2 #\u+00d3 #\u+00d4 #\u+0150 #\u+00d6 #\u+015a
2581    #\u+0170 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+0118 #\u+021a #\u+00df
2582    ;; #xe0
2583    #\u+00e0 #\u+00e1 #\u+00e2 #\u+0103 #\u+00e4 #\u+0107 #\u+00e6 #\u+00e7
2584    #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef
2585    ;; #xf0
2586    #\u+0111 #\u+0144 #\u+00f2 #\u+00f3 #\u+00f4 #\u+0151 #\u+00f6 #\u+015b
2587    #\u+0171 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+0119 #\u+021b #\u+00ff
2588    ))
2589
2590(defstatic *unicode-a0-180-to-iso-8859-16*
2591  #(
2592    #xa0 nil nil nil nil nil nil #xa7   ; #xa0-#xa7
2593    nil #xa9 nil #xab nil #xad nil nil  ; #xa8-#xaf
2594    #xb0 #xb1 nil nil nil nil #xb6 #xb7 ; #xb0-#xb7
2595    nil nil nil #xbb nil nil nil nil    ; #xb8-#xbf
2596    #xc0 #xc1 #xc2 nil #xc4 nil #xc6 #xc7 ; #xc0-#xc7
2597    #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf
2598    nil nil #xd2 #xd3 #xd4 nil #xd6 nil ; #xd0-#xd7
2599    nil #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf
2600    #xe0 #xe1 #xe2 nil #xe4 nil #xe6 #xe7 ; #xe0-#xe7
2601    #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef
2602    nil nil #xf2 #xf3 #xf4 nil #xf6 nil ; #xf0-#xf7
2603    nil #xf9 #xfa #xfb #xfc nil nil #xff ; #xf8-#xff
2604    nil nil #xc3 #xe3 #xa1 #xa2 #xc5 #xe5 ; #x100-#x107
2605    nil nil nil nil #xb2 #xb9 nil nil   ; #x108-#x10f
2606    #xd0 #xf0 nil nil nil nil nil nil   ; #x110-#x117
2607    #xdd #xfd nil nil nil nil nil nil   ; #x118-#x11f
2608    nil nil nil nil nil nil nil nil     ; #x120-#x127
2609    nil nil nil nil nil nil nil nil     ; #x128-#x12f
2610    nil nil nil nil nil nil nil nil     ; #x130-#x137
2611    nil nil nil nil nil nil nil nil     ; #x138-#x13f
2612    nil #xa3 #xb3 #xd1 #xf1 nil nil nil ; #x140-#x147
2613    nil nil nil nil nil nil nil nil     ; #x148-#x14f
2614    #xd5 #xf5 #xbc #xbd nil nil nil nil ; #x150-#x157
2615    nil nil #xd7 #xf7 nil nil nil nil   ; #x158-#x15f
2616    #xa6 #xa8 nil nil nil nil nil nil   ; #x160-#x167
2617    nil nil nil nil nil nil nil nil     ; #x168-#x16f
2618    #xd8 #xf8 nil nil nil nil nil nil   ; #x170-#x177
2619    #xbe #xac #xae #xaf #xbf #xb4 #xb8 nil ; #x178-#x17f
2620    ))
2621
2622(defstatic *unicode-218-220-to-iso-8859-16*
2623  #(
2624    #xaa #xba #xde #xfe nil nil nil nil ; #x218-#x21f
2625    ))
2626
2627(defstatic *unicode-2018-2020-to-iso-8859-16*
2628  #(
2629    nil nil nil nil nil #xb5 #xa5 nil   ; #x2018-#x201f
2630    ))
2631 
2632
2633(define-character-encoding :iso-8859-16
2634    "An 8-bit, fixed-width character encoding in which codes #x00-#x9f
2635map to their Unicode equivalents and other codes map to other Unicode
2636character values.  Intended to provide most characters found in Southeast
2637European languages."
2638  :aliases '(:iso_8859-16 :latin10 :l1 :iso-ir-226)
2639  :stream-encode-function
2640  (nfunction
2641   iso-8859-16-stream-encode
2642   (lambda (char write-function stream)
2643     (let* ((code (char-code char))
2644            (c2 (cond ((< code #xa0) code)
2645                      ((< code #x180)
2646                       (svref *unicode-a0-180-to-iso-8859-16*
2647                              (the fixnum (- code #xa0))))
2648                      ((and (>= code #x218) (< code #x220))
2649                       (svref *unicode-218-220-to-iso-8859-16*
2650                              (the fixnum (- code #x218))))
2651                      ((and (>= code #x2018) (< code #x2020))
2652                       (svref *unicode-2018-2020-to-iso-8859-16*
2653                              (the fixnum (- code #x2018))))
2654                      ((= code #x20ac) #xa4))))
2655       (declare (type (mod #x110000) code))
2656       (funcall write-function stream (or c2 (note-encoding-problem char stream :iso-8859-16 (char-code #\Sub))))
2657       1)))
2658  :stream-decode-function
2659  (nfunction
2660   iso-8859-16-stream-decode
2661   (lambda (1st-unit next-unit-function stream)
2662     (declare (ignore next-unit-function stream)
2663              (type (unsigned-byte 8) 1st-unit))
2664     (if (< 1st-unit #xa0)
2665       (code-char 1st-unit)
2666       (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0))))))
2667  :vector-encode-function
2668  (nfunction
2669   iso-8859-16-vector-encode
2670   (lambda (string vector idx start end)
2671     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2672              (fixnum idx))
2673     (do* ((i start (1+ i)))
2674          ((>= i end) idx)
2675       (let* ((char (schar string i))
2676              (code (char-code char))
2677              (c2 (cond ((< code #xa0) code)
2678                      ((< code #x180)
2679                       (svref *unicode-a0-180-to-iso-8859-16*
2680                              (the fixnum (- code #xa0))))
2681                      ((and (>= code #x218) (< code #x220))
2682                       (svref *unicode-218-220-to-iso-8859-16*
2683                              (the fixnum (- code #x218))))
2684                      ((and (>= code #x2018) (< code #x2020))
2685                       (svref *unicode-2018-2020-to-iso-8859-16*
2686                              (the fixnum (- code #x2018))))
2687                      ((= code #x20ac) #xa4))))
2688         (declare (type (mod #x110000) code))
2689         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :iso-8859-16 (char-code #\Sub))))
2690         (incf idx)))))
2691  :vector-decode-function
2692  (nfunction
2693   iso-8859-16-vector-decode
2694   (lambda (vector idx noctets string)
2695     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
2696     (do* ((i 0 (1+ i))
2697           (index idx (1+ index)))
2698          ((>= i noctets) index)
2699       (let* ((1st-unit (aref vector index)))
2700         (declare (type (unsigned-byte 8) 1st-unit))
2701         (setf (schar string i)
2702               (if (< 1st-unit #xa0)
2703                 (code-char 1st-unit)
2704                 (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
2705  :memory-encode-function
2706  (nfunction
2707   iso-8859-16-memory-encode
2708   (lambda (string pointer idx start end)
2709     (do* ((i start (1+ i)))
2710          ((>= i end) idx)
2711       (let* ((char (schar string i))
2712              (code (char-code char))
2713              (c2 (cond ((< code #xa0) code)
2714                      ((< code #x180)
2715                       (svref *unicode-a0-180-to-iso-8859-16*
2716                              (the fixnum (- code #xa0))))
2717                      ((and (>= code #x218) (< code #x220))
2718                       (svref *unicode-218-220-to-iso-8859-16*
2719                              (the fixnum (- code #x218))))
2720                      ((and (>= code #x2018) (< code #x2020))
2721                       (svref *unicode-2018-2020-to-iso-8859-16*
2722                              (the fixnum (- code #x2018))))
2723                      ((= code #x20ac) #xa4))))
2724         (declare (type (mod #x110000) code))
2725         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :iso-8859-16 (char-code #\Sub))))
2726         (incf idx)))))
2727  :memory-decode-function
2728  (nfunction
2729   iso-8859-16-memory-decode
2730   (lambda (pointer noctets idx string)
2731     (do* ((i 0 (1+ i))
2732           (index idx (1+ index)))
2733          ((>= i noctets) index)
2734       (let* ((1st-unit (%get-unsigned-byte pointer index)))
2735         (declare (type (unsigned-byte 8) 1st-unit))
2736         (setf (schar string i)
2737               (if (< 1st-unit #xa0)
2738                 (code-char 1st-unit)
2739                 (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
2740  :octets-in-string-function
2741  #'8-bit-fixed-width-octets-in-string
2742  :length-of-vector-encoding-function
2743  #'8-bit-fixed-width-length-of-vector-encoding
2744  :length-of-memory-encoding-function 
2745  #'8-bit-fixed-width-length-of-memory-encoding
2746  :decode-literal-code-unit-limit #xa0
2747  :encode-literal-char-code-limit #xa0 
2748  )
2749
2750(defstatic *macintosh-to-unicode*
2751  #(
2752    ;; #x80
2753    #\u+00c4 #\u+00c5 #\u+00c7 #\u+00c9 #\u+00d1 #\u+00d6 #\u+00dc #\u+00e1
2754    #\u+00e0 #\u+00e2 #\u+00e4 #\u+00e3 #\u+00e5 #\u+00e7 #\u+00e9 #\u+00e8
2755    ;; #x90
2756    #\u+00ea #\u+00eb #\u+00ed #\u+00ec #\u+00ee #\u+00ef #\u+00f1 #\u+00f3
2757    #\u+00f2 #\u+00f4 #\u+00f6 #\u+00f5 #\u+00fa #\u+00f9 #\u+00fb #\u+00fc
2758    ;; #xa0
2759    #\u+2020 #\u+00b0 #\u+00a2 #\u+00a3 #\u+00a7 #\u+2022 #\u+00b6 #\u+00df
2760    #\u+00ae #\u+00a9 #\u+2122 #\u+00b4 #\u+00a8 #\u+2260 #\u+00c6 #\u+00d8
2761    ;; #xb0
2762    #\u+221e #\u+00b1 #\u+2264 #\u+2265 #\u+00a5 #\u+00b5 #\u+2202 #\u+2211
2763    #\u+220f #\u+03c0 #\u+222b #\u+00aa #\u+00ba #\u+2126 #\u+00e6 #\u+00f8
2764    ;; #xc0
2765    #\u+00bf #\u+00a1 #\u+00ac #\u+221a #\u+0192 #\u+2248 #\u+2206 #\u+00ab
2766    #\u+00bb #\u+2026 #\u+00a0 #\u+00c0 #\u+00c3 #\u+00d5 #\u+0152 #\u+0153
2767    ;; #xd0
2768    #\u+2013 #\u+2014 #\u+201c #\u+201d #\u+2018 #\u+2019 #\u+00f7 #\u+25ca
2769    #\u+00ff #\u+0178 #\u+2044 #\u+00a4 #\u+2039 #\u+203a #\u+fb01 #\u+fb02
2770    ;; #xe0
2771    #\u+2021 #\u+00b7 #\u+201a #\u+201e #\u+2030 #\u+00c2 #\u+00ca #\u+00c1
2772    #\u+00cb #\u+00c8 #\u+00cd #\u+00ce #\u+00cf #\u+00cc #\u+00d3 #\u+00d4
2773    ;; #xf0
2774    #\u+f8ff #\u+00d2 #\u+00da #\u+00db #\u+00d9 #\u+0131 #\u+02c6 #\u+02dc
2775    #\u+00af #\u+02d8 #\u+02d9 #\u+02da #\u+00b8 #\u+02dd #\u+02db #\u+02c7
2776    ))
2777
2778
2779(defstatic *unicode-a0-100-to-macintosh*
2780  #(
2781    #xca #xc1 #xa2 #xa3 #xdb #xb4 nil #xa4 ; #xa0-#xa7
2782    #xac #xa9 #xbb #xc7 #xc2 nil #xa8 #xf8 ; #xa8-#xaf
2783    #xa1 #xb1 nil nil #xab #xb5 #xa6 #xe1 ; #xb0-#xb7
2784    #xfc nil #xbc #xc8 nil nil nil #xc0 ; #xb8-#xbf
2785    #xcb #xe7 #xe5 #xcc #x80 #x81 #xae #x82 ; #xc0-#xc7
2786    #xe9 #x83 #xe6 #xe8 #xed #xea #xeb #xec ; #xc8-#xcf
2787    nil #x84 #xf1 #xee #xef #xcd #x85 nil ; #xd0-#xd7
2788    #xaf #xf4 #xf2 #xf3 #x86 nil nil #xa7 ; #xd8-#xdf
2789    #x88 #x87 #x89 #x8b #x8a #x8c #xbe #x8d ; #xe0-#xe7
2790    #x8f #x8e #x90 #x91 #x93 #x92 #x94 #x95 ; #xe8-#xef
2791    nil #x96 #x98 #x97 #x99 #x9b #x9a #xd6 ; #xf0-#xf7
2792    #xbf #x9d #x9c #x9e #x9f nil nil #xd8 ; #xf8-#xff
2793    ))
2794
2795(defstatic *unicode-130-198-to-macintosh*
2796  #(
2797    nil #xf5 nil nil nil nil nil nil ; #x130-#x137
2798    nil nil nil nil nil nil nil nil ; #x138-#x13f
2799    nil nil nil nil nil nil nil nil ; #x140-#x147
2800    nil nil nil nil nil nil nil nil ; #x148-#x14f
2801    nil nil #xce #xcf nil nil nil nil ; #x150-#x157
2802    nil nil nil nil nil nil nil nil ; #x158-#x15f
2803    nil nil nil nil nil nil nil nil ; #x160-#x167
2804    nil nil nil nil nil nil nil nil ; #x168-#x16f
2805    nil nil nil nil nil nil nil nil ; #x170-#x177
2806    #xd9 nil nil nil nil nil nil nil ; #x178-#x17f
2807    nil nil nil nil nil nil nil nil ; #x180-#x187
2808    nil nil nil nil nil nil nil nil ; #x188-#x18f
2809    nil nil #xc4 nil nil nil nil nil ; #x190-#x197
2810    ))
2811
2812(defstatic *unicode-2c0-2e0-to-macintosh*
2813  #(
2814    nil nil nil nil nil nil #xf6 #xff   ; #x2c0-#x2c7
2815    nil nil nil nil nil nil nil nil     ; #x2c8-#x2cf
2816    nil nil nil nil nil nil nil nil     ; #x2d0-#x2d7
2817    #xf9 #xfa #xfb #xfe #xf7 #xfd nil nil ; #x2d8-#x2df
2818    ))
2819
2820(defstatic *unicode-2010-2048-to-macintosh*
2821  #(
2822  nil nil nil #xd0 #xd1 nil nil nil ; #x2010-#x2017
2823  #xd4 #xd5 #xe2 nil #xd2 #xd3 #xe3 nil ; #x2018-#x201f
2824  #xa0 #xe0 #xa5 nil nil nil #xc9 nil ; #x2020-#x2027
2825  nil nil nil nil nil nil nil nil ; #x2028-#x202f
2826  #xe4 nil nil nil nil nil nil nil ; #x2030-#x2037
2827  nil #xdc #xdd nil nil nil nil nil ; #x2038-#x203f
2828  nil nil nil nil #xda nil nil nil ; #x2040-#x2047
2829    ))
2830
2831(defstatic *unicode-2120-2128-to-macintosh*
2832  #(
2833    nil nil #xaa nil nil nil #xbd nil   ; #x2120-#x2127
2834    ))
2835
2836(defstatic *unicode-2200-2268-to-macintosh*
2837  #(
2838    nil nil #xb6 nil nil nil #xc6 nil   ; #x2200-#x2207
2839    nil nil nil nil nil nil nil #xb8    ; #x2208-#x220f
2840    nil #xb7 nil nil nil nil nil nil    ; #x2210-#x2217
2841    nil nil #xc3 nil nil nil #xb0 nil   ; #x2218-#x221f
2842    nil nil nil nil nil nil nil nil     ; #x2220-#x2227
2843    nil nil nil #xba nil nil nil nil    ; #x2228-#x222f
2844    nil nil nil nil nil nil nil nil     ; #x2230-#x2237
2845    nil nil nil nil nil nil nil nil     ; #x2238-#x223f
2846    nil nil nil nil nil nil nil nil     ; #x2240-#x2247
2847    #xc5 nil nil nil nil nil nil nil    ; #x2248-#x224f
2848    nil nil nil nil nil nil nil nil     ; #x2250-#x2257
2849    nil nil nil nil nil nil nil nil     ; #x2258-#x225f
2850    #xad nil nil nil #xb2 #xb3 nil nil  ; #x2260-#x2267
2851    ))
2852
2853(defstatic *unicode-fb00-fb08-to-macintosh*
2854  #(
2855    nil #xde #xdf nil nil nil nil nil ; #xfb00-#xfb07
2856    ))
2857
2858(define-character-encoding :macintosh
2859    "An 8-bit, fixed-width character encoding in which codes #x00-#x7f
2860map to their Unicode equivalents and other codes map to other Unicode
2861character values.  Traditionally used on Classic MacOS to encode characters
2862used in western languages."
2863  :aliases '(:macos-roman :macosroman :mac-roman :macroman)
2864
2865  :stream-encode-function
2866  (nfunction
2867   macintosh-stream-encode
2868   (lambda (char write-function stream)
2869     (let* ((code (char-code char))
2870            (c2 (cond ((< code #x80) code)
2871                      ((and (>= code #xa0) (< code #x100)
2872                       (svref *unicode-a0-100-to-macintosh*
2873                              (the fixnum (- code #xa0)))))
2874                      ((and (>= code #x130) (< code #x198))
2875                       (svref *unicode-130-198-to-macintosh*
2876                              (the fixnum (- code #x130))))
2877                      ((and (>= code #x2c0) (< code #x2e0))
2878                       (svref *unicode-2c0-2e0-to-macintosh*
2879                              (the fixnum (- code #x2c0))))
2880                      ((= code #x3c0) #xb9)
2881                      ((and (>= code #x2010) (< code #x2048))
2882                       (svref *unicode-2010-2048-to-macintosh*
2883                              (the fixnum (- code #x2010))))
2884                      ((and (>= code #x2120) (< code #x2128))
2885                       (svref *unicode-2120-2128-to-macintosh*
2886                              (the fixnum (- code #x2120))))
2887                      ((and (>= code #x2200) (< code #x2268))
2888                       (svref *unicode-2200-2268-to-macintosh*
2889                              (the fixnum (- code #x2200))))
2890                      ((= code #x25ca) #xd7)
2891                      ((and (>= code #xfb00) (< code #xfb08))
2892                       (svref *unicode-fb00-fb08-to-macintosh*
2893                              (the fixnum (- code #xfb00))))
2894                      ((= code #xf8ff) #xf0))))
2895       (declare (type (mod #x110000) code))
2896       (funcall write-function stream (or c2 (note-encoding-problem char stream :macintosh (char-code #\Sub))))
2897       1)))
2898  :stream-decode-function
2899  (nfunction
2900   macintosh-stream-decode
2901   (lambda (1st-unit next-unit-function stream)
2902     (declare (ignore next-unit-function stream)
2903              (type (unsigned-byte 8) 1st-unit))
2904     (if (< 1st-unit #x80)
2905       (code-char 1st-unit)
2906       (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #x80))))))
2907  :vector-encode-function
2908  (nfunction
2909   macintosh-vector-encode
2910   (lambda (string vector idx start end)
2911     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2912              (fixnum idx))
2913     (do* ((i start (1+ i)))
2914          ((>= i end) idx)
2915       (let* ((char (schar string i))
2916              (code (char-code char))
2917            (c2 (cond ((< code #x80) code)
2918                      ((and (>= code #xa0) (< code #x100)
2919                       (svref *unicode-a0-100-to-macintosh*
2920                              (the fixnum (- code #xa0)))))
2921                      ((and (>= code #x130) (< code #x198))
2922                       (svref *unicode-130-198-to-macintosh*
2923                              (the fixnum (- code #x130))))
2924                      ((and (>= code #x2c0) (< code #x2e0))
2925                       (svref *unicode-2c0-2e0-to-macintosh*
2926                              (the fixnum (- code #x2c0))))
2927                      ((= code #x3c0) #xb9)
2928                      ((and (>= code #x2010) (< code #x2048))
2929                       (svref *unicode-2010-2048-to-macintosh*
2930                              (the fixnum (- code #x2010))))
2931                      ((and (>= code #x2120) (< code #x2128))
2932                       (svref *unicode-2120-2128-to-macintosh*
2933                              (the fixnum (- code #x2120))))
2934                      ((and (>= code #x2200) (< code #x2268))
2935                       (svref *unicode-2200-2268-to-macintosh*
2936                              (the fixnum (- code #x2200))))
2937                      ((= code #x25ca) #xd7)
2938                      ((and (>= code #xfb00) (< code #xfb08))
2939                       (svref *unicode-fb00-fb08-to-macintosh*
2940                              (the fixnum (- code #xfb00))))
2941                      ((= code #xf8ff) #xf0))))
2942         (declare (type (mod #x110000) code))
2943         (setf (aref vector idx) (or c2 (note-encoding-problem char vector :macintosh (char-code #\Sub))))
2944         (incf idx)))))
2945  :vector-decode-function
2946  (nfunction
2947   macintosh-vector-decode
2948   (lambda (vector idx noctets string)
2949     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
2950     (do* ((i 0 (1+ i))
2951           (index idx (1+ index)))
2952          ((>= i noctets) index)
2953       (let* ((1st-unit (aref vector index)))
2954         (declare (type (unsigned-byte 8) 1st-unit))
2955         (setf (schar string i)
2956               (if (< 1st-unit #x80)
2957                 (code-char 1st-unit)
2958                 (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #x80)))))))))
2959  :memory-encode-function
2960  (nfunction
2961   macintosh-memory-encode
2962   (lambda (string pointer idx start end)
2963     (do* ((i start (1+ i)))
2964          ((>= i end) idx)
2965       (let* ((char (schar string i))
2966              (code (char-code char))
2967              (c2 (cond ((< code #x80) code)
2968                      ((and (>= code #xa0) (< code #x100)
2969                       (svref *unicode-a0-100-to-macintosh*
2970                              (the fixnum (- code #xa0)))))
2971                      ((and (>= code #x130) (< code #x198))
2972                       (svref *unicode-130-198-to-macintosh*
2973                              (the fixnum (- code #x130))))
2974                      ((and (>= code #x2c0) (< code #x2e0))
2975                       (svref *unicode-2c0-2e0-to-macintosh*
2976                              (the fixnum (- code #x2c0))))
2977                      ((= code #x3c0) #xb9)
2978                      ((and (>= code #x2010) (< code #x2048))
2979                       (svref *unicode-2010-2048-to-macintosh*
2980                              (the fixnum (- code #x2010))))
2981                      ((and (>= code #x2120) (< code #x2128))
2982                       (svref *unicode-2120-2128-to-macintosh*
2983                              (the fixnum (- code #x2120))))
2984                      ((and (>= code #x2200) (< code #x2268))
2985                       (svref *unicode-2200-2268-to-macintosh*
2986                              (the fixnum (- code #x2200))))
2987                      ((= code #x25ca) #xd7)
2988                      ((and (>= code #xfb00) (< code #xfb08))
2989                       (svref *unicode-fb00-fb08-to-macintosh*
2990                              (the fixnum (- code #xfb00))))
2991                      ((= code #xf8ff) #xf0))))
2992         (declare (type (mod #x110000) code))
2993         (setf (%get-unsigned-byte pointer idx) (or c2 (note-encoding-problem char pointer :macintosh (char-code #\Sub))))
2994         (incf idx)))))
2995  :memory-decode-function
2996  (nfunction
2997   macintosh-memory-decode
2998   (lambda (pointer noctets idx string)
2999     (do* ((i 0 (1+ i))
3000           (index idx (1+ index)))
3001          ((>= i noctets) index)
3002       (let* ((1st-unit (%get-unsigned-byte pointer index)))
3003         (declare (type (unsigned-byte 8) 1st-unit))
3004         (setf (schar string i)
3005               (if (< 1st-unit #x80)
3006                 (code-char 1st-unit)
3007                 (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #xa0)))))))))
3008  :octets-in-string-function
3009  #'8-bit-fixed-width-octets-in-string
3010  :length-of-vector-encoding-function
3011  #'8-bit-fixed-width-length-of-vector-encoding
3012  :length-of-memory-encoding-function 
3013  #'8-bit-fixed-width-length-of-memory-encoding
3014  :decode-literal-code-unit-limit #x80
3015  :encode-literal-char-code-limit #x80 
3016  )
3017
3018
3019;;; UTF-8.  Decoding checks for malformed sequences; it might be faster (and
3020;;; would certainly be simpler) if it didn't.
3021(define-character-encoding :utf-8
3022    "An 8-bit, variable-length character encoding in which characters
3023with CHAR-CODEs in the range #x00-#x7f can be encoded in a single
3024octet; characters with larger code values can be encoded in 2 to 4
3025bytes."
3026    :max-units-per-char 4
3027    :stream-encode-function
3028    (nfunction
3029     utf-8-stream-encode
3030     (lambda (char write-function stream)
3031       (let* ((code (char-code char)))
3032         (declare (type (mod #x110000) code))
3033         (cond ((< code #x80)
3034                (funcall write-function stream code)
3035                1)
3036               ((< code #x800)
3037                (let* ((y (ldb (byte 5 6) code))
3038                       (z (ldb (byte 6 0) code)))
3039                  (declare (fixnum y z))
3040                  (funcall write-function stream (logior #xc0 y))
3041                  (funcall write-function stream (logior #x80 z))
3042                  2))
3043               ((< code #x10000)
3044                (let* ((x (ldb (byte 4 12) code))
3045                       (y (ldb (byte 6 6) code))
3046                       (z (ldb (byte 6 0) code)))
3047                  (declare (fixnum x y z))
3048                  (funcall write-function stream (logior #xe0 x))
3049                  (funcall write-function stream (logior #x80 y))
3050                  (funcall write-function stream (logior #x80 z))
3051                  3))
3052               (t
3053                (let* ((w (ldb (byte 3 18) code))
3054                       (x (ldb (byte 6 12) code))
3055                       (y (ldb (byte 6 6) code))
3056                       (z (ldb (byte 6 0) code)))
3057                  (declare (fixnum w x y z))
3058                  (funcall write-function stream (logior #xf0 w))
3059                  (funcall write-function stream (logior #x80 x))
3060                  (funcall write-function stream (logior #x80 y))
3061                  (funcall write-function stream (logior #x80 z))
3062                  4))))))
3063    :stream-decode-function
3064    (nfunction
3065     utf-8-stream-decode
3066     (lambda (1st-unit next-unit-function stream)
3067       (declare (type (unsigned-byte 8) 1st-unit))
3068       (if (< 1st-unit #x80)
3069         (code-char 1st-unit)
3070         (if (>= 1st-unit #xc2)
3071           (let* ((s1 (funcall next-unit-function stream)))
3072             (if (eq s1 :eof)
3073               s1
3074               (locally
3075                   (declare (type (unsigned-byte 8) s1))
3076                 (if (< 1st-unit #xe0)
3077                   (if (< (the fixnum (logxor s1 #x80)) #x40)
3078                     (code-char
3079                      (logior
3080                       (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
3081                       (the fixnum (logxor s1 #x80))))
3082                     (note-stream-decoding-problem stream))
3083                   (let* ((s2 (funcall next-unit-function stream)))
3084                     (if (eq s2 :eof)
3085                       s2
3086                       (locally
3087                           (declare (type (unsigned-byte 8) s2))
3088                         (if (< 1st-unit #xf0)
3089                           (if (and (< (the fixnum (logxor s1 #x80)) #x40)
3090                                    (< (the fixnum (logxor s2 #x80)) #x40)
3091                                    (or (>= 1st-unit #xe1)
3092                                        (>= s1 #xa0)))
3093                             (or (code-char (the fixnum
3094                                          (logior (the fixnum
3095                                                    (ash (the fixnum (logand 1st-unit #xf))
3096                                                         12))
3097                                                  (the fixnum
3098                                                    (logior
3099                                                     (the fixnum
3100                                                       (ash (the fixnum (logand s1 #x3f))
3101                                                            6))
3102                                                     (the fixnum (logand s2 #x3f)))))))
3103                                 (note-stream-decoding-problem stream))
3104                             (note-stream-decoding-problem stream))
3105                           (if (< 1st-unit #xf8)
3106                             (let* ((s3 (funcall next-unit-function stream)))
3107                               (if (eq s3 :eof)
3108                                 s3
3109                                 (locally
3110                                     (declare (type (unsigned-byte 8) s3))
3111                                   (if (and (< (the fixnum (logxor s1 #x80)) #x40)
3112                                            (< (the fixnum (logxor s2 #x80)) #x40)
3113                                            (< (the fixnum (logxor s3 #x80)) #x40)
3114                                            (or (>= 1st-unit #xf1)
3115                                                (>= s1 #x90)))
3116                                     (code-char
3117                                      (logior
3118                                       (the fixnum
3119                                         (logior
3120                                          (the fixnum
3121                                            (ash (the fixnum (logand 1st-unit 7)) 18))
3122                                          (the fixnum
3123                                            (ash (the fixnum (logxor s1 #x80)) 12))))
3124                                       (the fixnum
3125                                         (logior
3126                                          (the fixnum
3127                                            (ash (the fixnum (logxor s2 #x80)) 6))
3128                                          (the fixnum (logxor s3 #x80))))))
3129
3130
3131                                     (note-stream-decoding-problem stream)))))
3132                             (note-stream-decoding-problem stream))))))))))
3133           (note-stream-decoding-problem stream)))))
3134    :vector-encode-function
3135    (nfunction
3136     utf-8-vector-encode
3137     (lambda (string vector idx start end)
3138       (declare (type (simple-array (unsigned-byte 8) (*)) vector)
3139                (fixnum idx))
3140       (do* ((i start (1+ i)))
3141            ((>= i end) idx)
3142         (let* ((char (schar string i))
3143                (code (char-code char)))
3144           (declare (type (mod #x110000) code))
3145           (cond ((< code #x80)
3146                  (setf (aref vector idx) code)
3147                  (incf idx))
3148                 ((< code #x800)
3149                  (setf (aref vector idx)
3150                        (logior #xc0 (the fixnum (ash code -6))))
3151                  (setf (aref vector (the fixnum (1+ idx)))
3152                        (logior #x80 (the fixnum (logand code #x3f))))
3153                  (incf idx 2))
3154                 ((< code #x10000)
3155                  (setf (aref vector idx)
3156                        (logior #xe0 (the fixnum (ash code -12))))
3157                  (setf (aref vector (the fixnum (1+ idx)))
3158                        (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
3159                  (setf (aref vector (the fixnum (+ idx 2)))
3160                        (logior #x80 (the fixnum (logand code #x3f))))
3161                  (incf idx 3))
3162                 (t
3163                   (setf (aref vector idx)
3164                         (logior #xf0
3165                                 (the fixnum (logand #x7 (the fixnum (ash code -18))))))
3166                   (setf (aref vector (the fixnum (1+ idx)))
3167                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
3168                   (setf (aref vector (the fixnum (+ idx 2)))
3169                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
3170                   (setf (aref vector (the fixnum (+ idx 3)))
3171                         (logior #x80 (logand #x3f code)))
3172                   (incf idx 4)))))))
3173    :vector-decode-function
3174    (nfunction
3175     utf-8-vector-decode
3176     (lambda (vector idx noctets string)
3177       (declare (type (simple-array (unsigned-byte 8) (*)) vector)
3178                (type index idx))
3179       (do* ((i 0 (1+ i))
3180             (end (+ idx noctets))
3181             (index idx (1+ index)))
3182            ((= index end) index)
3183           (let* ((1st-unit (aref vector index)))
3184             (declare (type (unsigned-byte 8) 1st-unit))
3185             (let* ((char 
3186                     (if (< 1st-unit #x80)
3187                       (code-char 1st-unit)
3188                       (if (>= 1st-unit #xc2)
3189                           (let* ((2nd-unit (aref vector (incf index))))
3190                             (declare (type (unsigned-byte 8) 2nd-unit))
3191                             (if (< 1st-unit #xe0)
3192                               (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
3193                                 (code-char
3194                                  (logior
3195                                   (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
3196                                   (the fixnum (logxor 2nd-unit #x80)))))
3197                               (let* ((3rd-unit (aref vector (incf index))))
3198                                 (declare (type (unsigned-byte 8) 3rd-unit))
3199                                 (if (< 1st-unit #xf0)
3200                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
3201                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
3202                                            (or (>= 1st-unit #xe1)
3203                                                (>= 2nd-unit #xa0)))
3204                                     (code-char (the fixnum
3205                                                  (logior (the fixnum
3206                                                            (ash (the fixnum (logand 1st-unit #xf))
3207                                                                 12))
3208                                                          (the fixnum
3209                                                            (logior
3210                                                             (the fixnum
3211                                                               (ash (the fixnum (logand 2nd-unit #x3f))
3212                                                                    6))
3213                                                             (the fixnum (logand 3rd-unit #x3f))))))))
3214                                   (let* ((4th-unit (aref vector (incf index))))
3215                                     (declare (type (unsigned-byte 8) 4th-unit))
3216                                     (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
3217                                              (< (the fixnum (logxor 3rd-unit #x80)) #x40)
3218                                              (< (the fixnum (logxor 4th-unit #x80)) #x40)
3219                                              (or (>= 1st-unit #xf1)
3220                                                  (>= 2nd-unit #x90)))
3221                                       (code-char
3222                                        (logior
3223                                         (the fixnum
3224                                           (logior
3225                                            (the fixnum
3226                                              (ash (the fixnum (logand 1st-unit 7)) 18))
3227                                            (the fixnum
3228                                              (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
3229                                         (the fixnum
3230                                           (logior
3231                                            (the fixnum
3232                                              (ash (the fixnum (logxor 3rd-unit #x80)) 6))
3233                                            (the fixnum (logxor 4th-unit #x80))))))))))))))))
3234               (setf (schar string i) (or char (note-vector-decoding-problem vector index :utf-8))))))))
3235    :memory-encode-function
3236    #'utf-8-memory-encode
3237    :memory-decode-function
3238    #'utf-8-memory-decode
3239    :octets-in-string-function
3240    #'utf-8-octets-in-string
3241    :length-of-vector-encoding-function
3242    (nfunction
3243     utf-8-length-of-vector-encoding
3244     (lambda (vector start end)
3245       (declare (type (simple-array (unsigned-byte 8) (*)) vector))
3246       (do* ((i start)
3247             (nchars 0))
3248            ((>= i end)
3249             (values nchars i))
3250         (declare (fixnum i))
3251         (let* ((code (aref vector i))
3252                (nexti (+ i (cond ((< code #xc2) 1)
3253                                  ((< code #xe0) 2)
3254                                  ((< code #xf0) 3)
3255                                  ((< code #xf8) 4)
3256                                  (t 1)))))
3257           (declare (type (unsigned-byte 8) code))
3258           (if (> nexti end)
3259             (return (values nchars i))
3260             (setq nchars (1+ nchars) i nexti))))))
3261    :length-of-memory-encoding-function
3262    #'utf-8-length-of-memory-encoding
3263    :decode-literal-code-unit-limit #x80
3264    :encode-literal-char-code-limit #x80   
3265    :bom-encoding #(#xef #xbb #xbf)
3266    :character-size-in-octets-function  (lambda (c)
3267                                          (let* ((code (char-code c)))
3268                                            (declare (type (mod #x110000) code))
3269                                            (if (< code #x80)
3270                                              1
3271                                              (if (< code #x800)
3272                                                2
3273                                                (if (< code #x10000)
3274                                                  3
3275                                                  4)))))
3276     
3277    )
3278
3279
3280;;; For a code-unit-size greater than 8: the stream-encode function's write-function
3281;;; accepts a code-unit in native byte order and swaps it if necessary and the
3282;;; stream-decode function receives a first-unit in native byte order and its
3283;;; next-unit-function returns a unit in native byte order.  The memory/vector
3284;;; functions have to do their own byte swapping.
3285
3286
3287(defmacro utf-16-combine-surrogate-pairs (a b)
3288  `(code-char
3289    (the (unsigned-byte 21)
3290      (+ #x10000
3291         (the (unsigned-byte 20)
3292           (logior
3293            (the (unsigned-byte 20) (ash (the (unsigned-byte 10)
3294                                           (- ,a #xd800))
3295                                         10))
3296            (the (unsigned-byte 10) (- ,b #xdc00))))))))
3297   
3298(defun utf-16-stream-encode (char write-function stream)
3299  (let* ((code (char-code char))
3300         (highbits (- code #x10000)))
3301    (declare (type (mod #x110000) code)
3302             (fixnum highbits))
3303    (if (< highbits 0)
3304      (progn
3305        (funcall write-function stream code)
3306        1)
3307      (progn
3308        (funcall write-function stream (logior #xd800 (the fixnum (ash highbits -10))))
3309        (funcall write-function stream (logior #xdc00 (the fixnum (logand highbits #x3ff))))
3310        2))))
3311
3312(defun utf-16-stream-decode (1st-unit next-unit-function stream)
3313  (declare (type (unsigned-byte 16) 1st-unit))
3314  (if (or (< 1st-unit #xd800)
3315          (>= 1st-unit #xe000))
3316    (code-char 1st-unit)
3317    (if (< 1st-unit #xdc00)
3318      (let* ((2nd-unit (funcall next-unit-function stream)))
3319        (if (eq 2nd-unit :eof)
3320          2nd-unit
3321          (locally (declare (type (unsigned-byte 16) 2nd-unit))
3322            (if (and (>= 2nd-unit #xdc00)
3323                     (< 2nd-unit #xe000))
3324              (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)
3325              (note-stream-decoding-problem stream)))))
3326      (note-stream-decoding-problem stream))))
3327
3328
3329
3330(declaim (inline %big-endian-u8-ref-u16 %little-endian-u8-ref-u16))
3331(defun %big-endian-u8-ref-u16 (u8-vector idx)
3332  (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector)
3333           (fixnum idx))
3334  (logior (the (unsigned-byte 16) (ash (the (unsigned-byte 8) (aref u8-vector idx)) 8))
3335          (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx))))))
3336
3337(defun %little-endian-u8-ref-u16 (u8-vector idx)
3338  (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector)
3339           (fixnum idx))
3340  (logior (the (unsigned-byte 16) (ash (the (unsigned-byte 8)
3341                                         (aref u8-vector (the fixnum (1+ idx)))) 8))
3342          (the (unsigned-byte 8) (aref u8-vector idx))))
3343
3344#+big-endian-target
3345(progn
3346(defmacro %native-u8-ref-u16 (vector idx)
3347  `(%big-endian-u8-ref-u16 ,vector ,idx))
3348
3349(defmacro %reversed-u8-ref-u16 (vector idx)
3350  `(%little-endian-u8-ref-u16 ,vector ,idx))
3351)
3352
3353#+little-endian-target
3354(progn
3355(defmacro %native-u8-ref-u16 (vector idx)
3356  `(%little-endian-u8-ref-u16 ,vector ,idx))
3357
3358(defmacro %reversed-u8-ref-u16 (vector idx)
3359  `(%big-endian-u8-ref-u16 ,vector ,idx))
3360)
3361
3362
3363(declaim (inline (setf %big-endian-u8-ref-u16) (setf %little-endian-u8-ref-u16)))
3364(defun (setf %big-endian-u8-ref-u16) (val u8-vector idx)
3365  (declare (type (unsigned-byte 16) val)
3366           (type (simple-array (unsigned-byte 8) (*)) u8-vector)
3367           (fixnum idx))
3368  (setf (aref u8-vector idx) (ldb (byte 8 8) val)
3369        (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 0) val))
3370  val)
3371
3372(defun (setf %little-endian-u8-ref-u16) (val u8-vector idx)
3373  (declare (type (unsigned-byte 16) val)
3374           (type (simple-array (unsigned-byte 8) (*)) u8-vector)
3375           (fixnum idx))
3376  (setf (aref u8-vector idx) (ldb (byte 8 0) val)
3377        (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 8) val))
3378  val)
3379
3380(defun utf-16-character-size-in-octets (c)
3381  (let* ((code (char-code c)))
3382    (declare (type (mod #x110000) code))
3383    (if (< code #x10000)
3384      2
3385      4)))
3386
3387;;; utf-16, native byte order.
3388(define-character-encoding #+big-endian-target :utf-16be #-big-endian-target :utf-16le
3389    #+big-endian-target
3390    "A 16-bit, variable-length encoding in which characters with
3391CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
3392big-endian word and characters with larger codes can be encoded in a
3393pair of 16-bit big-endian words.  The endianness of the encoded data
3394is implicit in the encoding; byte-order-mark characters are not
3395interpreted on input or prepended to output."
3396    #+little-endian-target
3397    "A 16-bit, variable-length encoding in which characters with
3398CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
3399little-endian word and characters with larger codes can be encoded in
3400a pair of 16-bit little-endian words.  The endianness of the encoded
3401data is implicit in the encoding; byte-order-mark characters are not
3402interpreted on input or prepended to output."
3403    :max-units-per-char 2
3404    :code-unit-size 16
3405    :native-endianness t
3406    :stream-encode-function
3407    #'utf-16-stream-encode
3408    :stream-decode-function
3409    #'utf-16-stream-decode
3410    :vector-encode-function
3411    (nfunction
3412     native-utf-16-vector-encode
3413     (lambda (string vector idx start end)
3414       (declare (type (simple-array (unsigned-byte 8) (*)) vector)
3415                (fixnum idx start end))
3416       (do* ((i start (1+ i)))
3417            ((>= i end) idx)
3418         (declare (fixnum i))
3419         (let* ((char (schar string i))
3420                (code (char-code char))
3421                (highbits (- code #x10000)))
3422           (declare (type (mod #x110000) code)
3423                    (fixnum highbits))
3424           (cond ((< highbits 0)
3425                  (setf (%native-u8-ref-u16 vector idx) code)
3426                  (incf idx 2))
3427                 (t
3428                  (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10))))
3429                         (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
3430                    (declare (type (unsigned-byte 16) firstword secondword))
3431                    (setf (%native-u8-ref-u16 vector idx) firstword
3432                          (%native-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword)
3433                    (incf idx 4))))))))
3434    :vector-decode-function
3435    (nfunction
3436     native-utf-16-vector-decode
3437     (lambda (vector idx noctets string)
3438       (declare (type (simple-array (unsigned-byte 8) (*)) vector)
3439                (type index idx))
3440       (do* ((i 0 (1+ i))
3441             (end (+ idx noctets))
3442             (index idx))
3443            ((= index end) index)
3444         (declare (fixnum i end index))
3445         (let* ((1st-unit (%native-u8-ref-u16 vector index)))
3446           (declare (type (unsigned-byte 16) 1st-unit))
3447           (incf index 2)
3448           (let* ((char
3449                   (if (or (< 1st-unit #xd800)
3450                           (>= 1st-unit #xe000))
3451                     (code-char 1st-unit)
3452                     (if (< 1st-unit #xdc00)
3453                       (let* ((2nd-unit (%native-u8-ref-u16 vector index)))
3454                         (declare (type (unsigned-byte 16) 2nd-unit))
3455                         (incf index 2)
3456                         (if (and (>= 2nd-unit #xdc00)
3457                                  (< 2nd-unit #xe000))
3458                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
3459             (setf (schar string i) (or char (note-vector-decoding-problem vector index #+big-endian-target :utf-16be #-big-endian-target :utf-16le))))))))
3460    :memory-encode-function
3461    (nfunction
3462     native-utf-16-memory-encode
3463     (lambda (string pointer idx start end)
3464       (declare (fixnum idx))
3465       (do* ((i start (1+ i)))
3466            ((>= i end) idx)
3467         (let* ((code (char-code (schar string i)))
3468                (highbits (- code #x10000)))
3469           (declare (type (mod #x110000) code)
3470                  (fixnum  highbits))
3471         (cond ((< highbits 0)
3472                (setf (%get-unsigned-word pointer idx) code)
3473                (incf idx 2))
3474               (t
3475                (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10))))
3476                (incf idx 2)
3477                (setf (%get-unsigned-word pointer idx) (logior #xdc00 (the fixnum (logand highbits #x3ff))))
3478                (incf idx 2)))))))
3479    :memory-decode-function
3480    (nfunction
3481     native-utf-16-memory-decode
3482     (lambda (pointer noctets idx string)
3483       (declare (fixnum noctets idx))
3484       (do* ((i 0 (1+ i))
3485             (end (+ idx noctets))
3486             (index idx))
3487            ((>= index end) index)
3488         (declare (fixnum i index end))
3489         (let* ((1st-unit (%get-unsigned-word pointer index)))
3490           (declare (type (unsigned-byte 16) 1st-unit))
3491           (incf index 2)
3492           (let* ((char
3493                   (if (or (< 1st-unit #xd800)
3494                           (>= 1st-unit #xe000))
3495                     (code-char 1st-unit)
3496                     (if (< 1st-unit #xdc00)
3497                       (let* ((2nd-unit (%get-unsigned-word pointer index)))
3498                           (declare (type (unsigned-byte 16) 2nd-unit))
3499                           (incf index)
3500                           (if (and (>= 2nd-unit #xdc00)
3501                                    (< 2nd-unit #xe000))
3502                             (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
3503            (setf (schar string i) (or char (note-vector-decoding-problem pointer index #+big-endian-target :utf-16be #-big-endian-target :utf-16le))))))))
3504    :octets-in-string-function
3505    #'utf-16-octets-in-string
3506    :length-of-vector-encoding-function
3507    (nfunction
3508     native-utf-16-length-of-vector-encoding
3509     (lambda (vector start end)
3510       (declare (type (simple-array (unsigned-byte 8) (*)) vector))
3511       (declare (fixnum start end))
3512       (do* ((i start)
3513             (j (+ 2 i) (+ 2 i))
3514             (nchars 0))
3515            ((> j end) (values nchars i))
3516         (declare (fixnum i j nchars))
3517         (let* ((code (%native-u8-ref-u16 vector i))
3518                (nexti (+ i (if (or (< code #xd800)
3519                                    (>= code #xdc00))
3520                              2
3521                              4))))
3522           (declare (type (unsigned-byte 16) code)
3523                    (fixnum nexti))
3524           (if (> nexti end)
3525             (return (values nchars i))
3526             (setq i nexti nchars (1+ nchars)))))))
3527    :length-of-memory-encoding-function
3528    (nfunction
3529     native-utf-16-length-of-memory-encoding
3530     (lambda (pointer noctets start)
3531       (do* ((i start)
3532             (j (+ i 2) (+ i 2))
3533             (end (+ start noctets))
3534             (nchars 0))
3535            ((> j end) (values nchars i))
3536         (let* ((code (%get-unsigned-word pointer i))
3537                (nexti (+ i (if (or (< code #xd800)
3538                                    (>= code #xdc00))
3539                              2
3540                              4))))
3541           (declare (type (unsigned-byte 16) code)
3542                    (fixnum nexti))
3543           (if (> nexti end)
3544             (return (values nchars i))
3545             (setq i nexti nchars (1+ nchars)))))))
3546    :decode-literal-code-unit-limit #xd800 
3547    :encode-literal-char-code-limit #x10000
3548    :nul-encoding #(0 0)
3549    :character-size-in-octets-function 'utf-16-character-size-in-octets
3550    )
3551
3552;;; utf-16, reversed byte order
3553(define-character-encoding #+big-endian-target :utf-16le #-big-endian-target :utf-16be
3554   #+little-endian-target
3555   "A 16-bit, variable-length encoding in which characters with
3556CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
3557big-endian word and characters with larger codes can be encoded in a
3558pair of 16-bit big-endian words.  The endianness of the encoded data
3559is implicit in the encoding; byte-order-mark characters are not
3560interpreted on input or prepended to output."
3561  #+big-endian-target
3562  "A 16-bit, variable-length encoding in which characters with
3563CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
3564little-endian word and characters with larger codes can be encoded in
3565a pair of 16-bit little-endian words.  The endianness of the encoded
3566data is implicit in the encoding; byte-order-mark characters are not
3567interpreted on input or prepended to output."
3568  :max-units-per-char 2
3569  :code-unit-size 16
3570  :native-endianness nil
3571  :stream-encode-function
3572  #'utf-16-stream-encode
3573  :stream-decode-function
3574  #'utf-16-stream-decode
3575  :vector-encode-function
3576  (nfunction
3577   reversed-utf-16-vector-encode
3578   (lambda (string vector idx start end)
3579     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
3580              (fixnum idx start end))
3581     (do* ((i start (1+ i)))
3582          ((>= i end) idx)
3583       (declare (fixnum i))
3584       (let* ((char (schar string i))
3585              (code (char-code char))
3586              (highbits (- code #x10000)))
3587         (declare (type (mod #x110000) code)
3588                  (fixnum highbits))
3589         (cond ((< highbits 0)
3590                (setf (%reversed-u8-ref-u16 vector idx) code)
3591                (incf idx 2))
3592               (t
3593                (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10))))
3594                       (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
3595                  (declare (type (unsigned-byte 16) firstword secondword))
3596                  (setf (%reversed-u8-ref-u16 vector idx) firstword
3597                        (%reversed-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword)
3598                  (incf idx 4))))))))
3599  :vector-decode-function
3600  (nfunction
3601   reversed-utf-16-vector-decode
3602   (lambda (vector idx noctets string)
3603     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
3604              (type index idx))
3605     (do* ((i 0 (1+ i))
3606           (end (+ idx noctets))
3607           (index idx))
3608          ((= index end) index)
3609       (declare (fixnum i end index))
3610       (let* ((1st-unit (%reversed-u8-ref-u16 vector index)))
3611         (declare (type (unsigned-byte 16) 1st-unit))
3612         (incf index 2)
3613         (let* ((char
3614                 (if (or (< 1st-unit #xd800)
3615                         (>= 1st-unit #xe000))
3616                   (code-char 1st-unit)
3617                   (if (< 1st-unit #xdc00)
3618                     (let* ((2nd-unit (%reversed-u8-ref-u16 vector index)))
3619                       (declare (type (unsigned-byte 16) 2nd-unit))
3620                       (incf index 2)
3621                       (if (and (>= 2nd-unit #xdc00)
3622                                (< 2nd-unit #xe000))
3623                         (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
3624           (setf (schar string i) (or char (note-vector-decoding-problem vector index #+big-endian-target :utf-16le #-big-endian-target :utf-16be))))))))
3625  :memory-encode-function
3626  (nfunction
3627   reversed-utf-16-memory-encode
3628   (lambda (string pointer idx start end)
3629     (declare (fixnum idx))
3630     (do* ((i start (1+ i)))
3631          ((>= i end) idx)
3632       (let* ((code (char-code (schar string i)))
3633              (highbits (- code #x10000)))
3634         (declare (type (mod #x110000) code)
3635                  (fixnum  highbits))
3636         (cond ((< highbits 0)
3637                (setf (%get-unsigned-word pointer idx) (%swap-u16 code))
3638                (incf idx 2))
3639               (t
3640                (setf (%get-unsigned-word pointer idx) (%swap-u16 (logior #xd800 (the fixnum (ash highbits -10)))))
3641                (incf idx 2)
3642                (setf (%get-unsigned-word pointer idx) (%swap-u16 (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
3643                (incf idx 2)))))))
3644  :memory-decode-function
3645  (nfunction
3646   reversed-utf-16-memory-decode
3647   (lambda (pointer noctets idx string)
3648     (declare (fixnum noctets idx))
3649     (do* ((i 0 (1+ i))
3650           (end (+ idx noctets))
3651           (index idx))
3652          ((>= index end) index)
3653       (declare (fixnum i index end))
3654       (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index))))
3655         (declare (type (unsigned-byte 16) 1st-unit))
3656         (incf index 2)
3657         (let* ((char
3658                 (if (or (< 1st-unit #xd800)
3659                         (>= 1st-unit #xe000))
3660                   (code-char 1st-unit)
3661                   (if (< 1st-unit #xdc00)
3662                     (let* ((2nd-unit (%swap-u16 (%get-unsigned-word pointer index))))
3663                       (declare (type (unsigned-byte 16) 2nd-unit))
3664                       (incf index)
3665                       (if (and (>= 2nd-unit #xdc00)
3666                                (< 2nd-unit #xe000))
3667                         (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
3668           (setf (schar string i) (or char (note-vector-decoding-problem pointer index #+big-endian-target :utf-16le #-big-endian-target :utf-16be))))))))
3669  :octets-in-string-function
3670  #'utf-16-octets-in-string
3671  :length-of-vector-encoding-function
3672  (nfunction
3673   reversed-utf-16-length-of-vector-encoding
3674   (lambda (vector start end)
3675     (declare (type (simple-array (unsigned-byte 8) (*)) vector))
3676     (declare (fixnum start end))
3677     (do* ((i start)
3678           (j (+ 2 i) (+ 2 i))
3679           (nchars 0))
3680          ((> j end) (values nchars i))
3681       (declare (fixnum i j nchars))
3682       (let* ((code (%reversed-u8-ref-u16 vector i))
3683              (nexti (+ i (if (or (< code #xd800)
3684                                  (>= code #xdc00))
3685                            2
3686                            4))))
3687         (declare (type (unsigned-byte 16) code)
3688                  (fixnum nexti))
3689         (if (> nexti end)
3690           (return (values nchars i))
3691           (setq i nexti nchars (1+ nchars)))))))
3692  :length-of-memory-encoding-function
3693  (nfunction
3694   reversed-utf-16-length-of-memory-encoding
3695   (lambda (pointer noctets start)
3696     (do* ((i start)
3697           (j (+ i 2) (+ i 2))
3698           (end (+ start noctets))
3699           (nchars 0))
3700          ((> j end) (values nchars i))
3701       (let* ((code (%swap-u16 (%get-unsigned-word pointer i)))
3702              (nexti (+ i (if (or (< code #xd800)
3703                                  (>= code #xdc00))
3704                            2
3705                            4))))
3706         (declare (type (unsigned-byte 16) code)
3707                  (fixnum nexti))
3708         (if (> nexti end)
3709           (return (values nchars i))
3710           (setq i nexti nchars (1+ nchars)))))))
3711  :decode-literal-code-unit-limit #xd800
3712  :encode-literal-char-code-limit #x10000
3713  :nul-encoding #(0 0)
3714  :character-size-in-octets-function 'utf-16-character-size-in-octets
3715  )
3716
3717;;; UTF-16.  Memory and vector functions determine endianness of
3718;;; input by the presence of a byte-order mark (or swapped BOM)
3719;;; at the beginning of input, and assume big-endian order
3720;;; if this mark is missing; on output, a BOM is prepended and
3721;;; things are written in native byte order.
3722;;; The endianness of stream-io operations is determined by
3723;;; stream content; new output streams are written in native
3724;;; endianness with a BOM character prepended.  Input streams
3725;;; are read in native byte order if the initial character is
3726;;; a BOM, in reversed byte order if the initial character is
3727;;; a swapped BOM, and in big-endian order (per RFC 2781) if
3728;;; there is no BOM.
3729
3730(define-character-encoding :utf-16
3731    "A 16-bit, variable-length encoding in which characters with
3732CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
3733word and characters with larger codes can be encoded in a
3734pair of 16-bit words.  The endianness of the encoded data is
3735indicated by the endianness of a byte-order-mark character (#\u+feff)
3736prepended to the data; in the absence of such a character on input,
3737the data is assumed to be in big-endian order. Output is written
3738in native byte-order with a leading byte-order mark."   
3739  :max-units-per-char 2
3740  :code-unit-size 16
3741  :native-endianness t                  ;not necessarily true.
3742  :stream-encode-function
3743  #'utf-16-stream-encode
3744  :stream-decode-function
3745  #'utf-16-stream-decode
3746  :vector-encode-function
3747  (nfunction
3748   utf-16-vector-encode
3749   (lambda (string vector idx start end)
3750     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
3751              (fixnum idx))
3752     (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code)
3753     (incf idx 2)
3754     (do* ((i start (1+ i)))
3755            ((>= i end) idx)
3756         (declare (fixnum i))
3757         (let* ((char (schar string i))
3758                (code (char-code char))
3759                (highbits (- code #x10000)))
3760           (declare (type (mod #x110000) code)
3761                    (fixnum highbits))
3762           (cond ((< highbits 0)
3763                  (setf (%native-u8-ref-u16 vector idx) code)
3764                  (incf idx 2))
3765                 (t
3766                  (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10))))
3767                         (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff)))))
3768                    (declare (type (unsigned-byte 16) firstword secondword))
3769                    (setf (%native-u8-ref-u16 vector idx) firstword
3770                          (%native-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword)
3771                    (incf idx 4))))))))
3772  :vector-decode-function
3773  (nfunction
3774   utf-16-vector-decode 
3775   (lambda (vector idx noctets string)
3776     (declare (type (simple-array (unsigned-byte 16) (*)) vector)
3777              (type index idx))
3778     (let* ((origin idx)
3779            (swap (if (>= noctets 2)
3780                    (case (%native-u8-ref-u16 vector idx)
3781                      (#.byte-order-mark-char-code
3782                       (incf idx 2) nil)
3783                      (#.swapped-byte-order-mark-char-code
3784                       (incf idx 2) t)
3785                      (t #+little-endian-target t)))))
3786       (do* ((i 0 (1+ i))
3787             (end (+ origin noctets))
3788             (index idx))
3789            ((= index end) index)
3790         (declare (fixnum i end index))
3791         (let* ((1st-unit (if swap
3792                            (%reversed-u8-ref-u16 vector index)
3793                            (%native-u8-ref-u16 vector index))))
3794           (declare (type (unsigned-byte 16) 1st-unit))
3795           (incf index 2)
3796           (let* ((char
3797                   (if (or (< 1st-unit #xd800)
3798                           (>= 1st-unit #xe000))
3799                     (code-char 1st-unit)
3800                     (if (< 1st-unit #xdc00)
3801                       (let* ((2nd-unit (if swap
3802                                          (%reversed-u8-ref-u16 vector index)
3803                                          (%native-u8-ref-u16 vector index))))
3804                         (declare (type (unsigned-byte 16) 2nd-unit))
3805                         (incf index 2)
3806                         (if (and (>= 2nd-unit #xdc00)
3807                                  (< 2nd-unit #xe000))
3808                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
3809             (setf (schar string i) (or char (note-vector-decoding-problem vector index :utf-16)))))))))
3810  :memory-encode-function
3811  (nfunction
3812   utf-16-memory-encode
3813   (lambda (string pointer idx start end)
3814     (declare (fixnum idx))
3815     ;; Output a BOM.
3816     (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code)
3817     (incf idx 2)
3818     (do* ((i start (1+ i)))
3819          ((>= i end) idx)
3820       (let* ((code (char-code (schar string i)))
3821              (highbits (- code #x10000)))
3822         (declare (type (mod #x110000) code)
3823                  (fixnum highbits))
3824         (cond ((< highbits 0)
3825                (setf (%get-unsigned-word pointer idx) code)
3826                (incf idx 2))
3827               (t
3828                (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10))))
3829                (setf (%get-unsigned-word pointer (the fixnum (+ idx 2)))
3830                      (logior #xdc00 (the fixnum (logand highbits #x3ff))))
3831                (incf idx 4)))))))
3832  :memory-decode-function
3833  (nfunction
3834   utf-16-memory-decode
3835   (lambda (pointer noctets idx string)
3836     (declare (fixnum noctets idx))
3837     (let* ((swap (when (> noctets 1)
3838                    (case (%get-unsigned-word pointer idx)
3839                      (#.byte-order-mark-char-code
3840                       (incf idx 2)
3841                       (decf noctets 2)
3842                       nil)
3843                      (#.swapped-byte-order-mark-char-code
3844                       (incf idx 2)
3845                       (decf noctets 2)
3846                       t)
3847                      (t #+little-endian-target t)))))
3848       (do* ((i 0 (1+ i))
3849             (end (+ idx noctets))
3850             (index idx ))
3851            ((>= index end) index)
3852         (declare (fixnum i index end))
3853         (let* ((1st-unit (%get-unsigned-word pointer index)))
3854           (declare (type (unsigned-byte 16) 1st-unit))
3855           (incf index 2)
3856           (if swap (setq 1st-unit (%swap-u16 1st-unit)))
3857           (let* ((char
3858                   (if (or (< 1st-unit #xd800)
3859                           (>= 1st-unit #xe000))
3860                     (code-char 1st-unit)
3861                     (if (< 1st-unit #xdc00)
3862                       (let* ((2nd-unit (%get-unsigned-byte pointer index)))
3863                         (declare (type (unsigned-byte 16) 2nd-unit))
3864                         (if swap (setq 2nd-unit (%swap-u16 2nd-unit)))
3865                         (incf index 2)
3866                         (if (and (>= 2nd-unit #xdc00)
3867                                  (< 2nd-unit #xe000))
3868                           (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit)))))))
3869             (setf (schar string i) (or char (note-vector-decoding-problem pointer index :utf-16)))))))))
3870  :octets-in-string-function
3871  (nfunction
3872   utf-16-bom-octets-in-string
3873   (lambda (string start end)
3874     (+ 2 (utf-16-octets-in-string string start end))))
3875  :length-of-vector-encoding-function
3876  (nfunction
3877   utf-16-length-of-vector-encoding
3878   (lambda (vector start end)
3879     (declare (type (simple-array (unsigned-byte 16) (*)) vector))
3880     (let* ((swap (when (>= end (+ start 2))
3881                    (case (%native-u8-ref-u16 vector start)
3882                      (#.byte-order-mark-char-code
3883                       (incf start 2)
3884                       nil)
3885                      (#.swapped-byte-order-mark-char-code
3886                       (incf start 2)
3887                       t)
3888                      (t #+little-endian-target t)))))
3889       (do* ((i start)
3890             (j (+ 2 i) (+ 2 j))
3891             (nchars 0))
3892            ((> j end)
3893             (values nchars i))
3894         (let* ((code (if swap
3895                        (%reversed-u8-ref-u16 vector i)
3896                        (%native-u8-ref-u16 vector i)))
3897                (nexti (+ i (if (or (< code #xd800)
3898                                    (>= code #xdc00))
3899                              2
3900                              4))))
3901           (declare (type (unsigned-byte 16) code)
3902                    (fixnum nexti))
3903           (if (> nexti end)
3904             (return (values nchars i))
3905             (setq i nexti nchars (1+ nchars))))))))
3906  :length-of-memory-encoding-function
3907  (nfunction
3908   utf-16-length-of-memory-encoding
3909   (lambda (pointer noctets start)
3910     (declare (fixnum noctets start))
3911     (when (oddp noctets)
3912       (setq noctets (1- noctets)))
3913     (let* ((origin start)
3914            (swap (when (>= noctets 2)
3915                    (case (%get-unsigned-word pointer (+ start start))
3916                      (#.byte-order-mark-char-code
3917                       (incf start 2)
3918                       nil)
3919                      (#.swapped-byte-order-mark-char-code
3920                       (incf start 2)
3921                       t)
3922                      (t #+little-endian-target t)))))
3923       (declare (fixnum origin))
3924       (do* ((i start)
3925             (j (+ i 2) (+ i 2))
3926             (end (+ origin noctets))
3927             (nchars 0 (1+ nchars)))
3928            ((> j end) (values nchars (- i origin)))
3929         (declare (fixnum i j end nchars))
3930         (let* ((code (%get-unsigned-word pointer i)))
3931           (declare (type (unsigned-byte 16) code))
3932           (if swap (setq code (%swap-u16 code)))
3933           (let* ((nexti (+ i (if (or (< code #xd800)
3934                                      (>= code #xdc00))
3935                                2
3936                                4))))
3937             (declare (fixnum nexti))
3938             (if (> nexti end)
3939               (return (values nchars (- i origin)))
3940               (setq i nexti))))))))
3941  :decode-literal-code-unit-limit #xd800
3942  :encode-literal-char-code-limit #x10000 
3943  :use-byte-order-mark
3944  #+big-endian-target :utf-16le
3945  #+little-endian-target :utf-16be
3946  :bom-encoding #+big-endian-target #(#xfe #xff) #+little-endian-target #(#xff #xfe)
3947  :nul-encoding #(0 0)
3948  :character-size-in-octets-function 'utf-16-character-size-in-octets 
3949  )
3950
3951
3952(defun two-octets-per-character (c)
3953  (declare (ignore c))
3954  2)
3955
3956(defun ucs-2-stream-encode (char write-function stream)
3957  (let* ((code (char-code char)))
3958    (declare (type (mod #x110000) code))
3959    (if (>= code #x10000)
3960      (setq code (note-encoding-problem char stream :ucs-2 (char-code #\Replacement_Character))))
3961    (funcall write-function stream code)
3962    1))
3963
3964(defun ucs-2-stream-decode (1st-unit next-unit-function stream)
3965  (declare (type (unsigned-byte 16) 1st-unit)
3966           (ignore next-unit-function))
3967  ;; CODE-CHAR returns NIL on either half of a surrogate pair.
3968  (or (code-char 1st-unit)
3969      (note-stream-decoding-problem stream)))
3970
3971
3972(defun ucs-2-octets-in-string (string start end)
3973  (declare (ignore string))
3974  (if (>= end start)
3975    (* 2 (- end start))
3976    0))
3977
3978(defun ucs-2-length-of-vector-encoding (vector start end)
3979  (declare (ignore vector))
3980  (let* ((noctets (max (- end start) 0)))
3981    (values (ash noctets -1) (+ start (logandc2 noctets 1)))))
3982
3983(defun ucs-2-length-of-memory-encoding (pointer noctets start)
3984  (declare (ignore pointer start))
3985  (values (ash noctets -1) (logandc2 noctets 1)))
3986
3987
3988
3989;;; UCS-2, native byte order
3990(define-character-encoding #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le
3991  #+big-endian-target
3992  "A 16-bit, fixed-length encoding in which characters with
3993CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
3994big-endian word. The encoded data is implicitly big-endian;
3995byte-order-mark characters are not interpreted on input or prepended
3996to output."
3997  #+little-endian-target
3998  "A 16-bit, fixed-length encoding in which characters with
3999CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
4000little-endian word. The encoded data is implicitly little-endian;
4001byte-order-mark characters are not interpreted on input or prepended
4002to output."
4003  :max-units-per-char 1
4004  :code-unit-size 16
4005  :native-endianness t
4006  :stream-encode-function
4007  #'ucs-2-stream-encode
4008  :stream-decode-function
4009  #'ucs-2-stream-decode
4010  :vector-encode-function
4011  (nfunction
4012   native-ucs-2-vector-encode
4013   (lambda (string vector idx start end)
4014     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
4015              (fixnum idx))
4016     (do* ((i start (1+ i)))
4017          ((>= i end) idx)
4018       (let* ((char (schar string i))
4019              (code (char-code char)))
4020         (declare (type (mod #x110000) code))
4021         (when (>= code #x10000)
4022           (setq code (note-encoding-problem char vector #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le (char-code #\Replacement_Character))))
4023         (setf (%native-u8-ref-u16 vector idx) code)
4024         (incf idx 2)))))
4025  :vector-decode-function
4026  (nfunction
4027   native-ucs-2-vector-decode
4028   (lambda (vector idx noctets string)
4029     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
4030              (type index idx))
4031     (do* ((i 0 (1+ i))
4032           (end (+ idx noctets))
4033           (index idx (+ 2 index)))
4034          ((>= index end) index)
4035       (declare (fixnum i end index))
4036       (setf (schar string i)
4037             (or (code-char (%native-u8-ref-u16 vector index))
4038                 (note-vector-decoding-problem vector index  #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le))))))
4039  :memory-encode-function
4040  (nfunction
4041   native-ucs-2-memory-encode
4042   (lambda (string pointer idx start end)
4043     (declare (fixnum idx))
4044     (do* ((i start (1+ i)))
4045          ((>= i end) idx)
4046       (let* ((char (schar string i))
4047              (code (char-code char)))
4048         (declare (type (mod #x110000) code))
4049         (setf (%get-unsigned-word pointer idx)
4050                      (if (>= code #x10000)
4051                        (note-encoding-problem char pointer #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le (char-code #\Replacement_Character))
4052                        code))
4053         (incf idx 2)))))
4054  :memory-decode-function
4055  (nfunction
4056   native-ucs-2-memory-decode
4057   (lambda (pointer noctets idx string)
4058     (declare (fixnum noctets idx))
4059     (do* ((i 0 (1+ i))
4060           (index idx (+ index 2)))
4061          ((>= i noctets) index)
4062       (declare (fixnum i index))
4063       (let* ((1st-unit (%get-unsigned-word pointer index)))
4064         (declare (type (unsigned-byte 16) 1st-unit))
4065         (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)))))))
4066  :octets-in-string-function
4067  #'ucs-2-octets-in-string
4068  :length-of-vector-encoding-function
4069  #'ucs-2-length-of-vector-encoding
4070  :length-of-memory-encoding-function
4071  #'ucs-2-length-of-memory-encoding
4072  :decode-literal-code-unit-limit #x10000
4073  :encode-literal-char-code-limit #x10000 
4074  :nul-encoding #(0 0)
4075  :character-size-in-octets-function 'two-octets-per-character
4076  )
4077
4078;;; UCS-2, reversed byte order
4079(define-character-encoding #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be
4080  #+little-endian-target
4081  "A 16-bit, fixed-length encoding in which characters with
4082CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
4083big-endian word. The encoded data is implicitly big-endian;
4084byte-order-mark characters are not interpreted on input or prepended
4085to output."
4086  #+big-endian-target
4087  "A 16-bit, fixed-length encoding in which characters with
4088CHAR-CODEs less than #x10000 can be encoded in a single 16-bit
4089
4090little-endian word. The encoded data is implicitly little-endian;
4091byte-order-mark characters are not interpreted on input or prepended
4092to output."
4093  :max-units-per-char 1
4094  :code-unit-size 16
4095  :native-endianness nil
4096  :stream-encode-function
4097  #'ucs-2-stream-encode
4098  :stream-decode-function
4099  #'ucs-2-stream-decode
4100  :vector-encode-function
4101  (nfunction
4102   reversed-ucs-2-vector-encode
4103   (lambda (string vector idx start end)
4104     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
4105              (fixnum idx))
4106     (do* ((i start (1+ i)))
4107          ((>= i end) idx)
4108       (let* ((char (schar string i))
4109              (code (char-code char)))
4110         (declare (type (mod #x110000) code))
4111         (when (>= code #x10000)
4112           (setq code (note-encoding-problem char vector #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be (char-code #\Replacement_Character))))
4113         (setf (%reversed-u8-ref-u16 vector idx) code)
4114         (incf idx 2)))))
4115  :vector-decode-function
4116  (nfunction
4117   reversed-ucs-2-vector-decode
4118   (lambda (vector idx noctets string)
4119     (declare (type (simple-array (unsigned-byte 8) (*)) vector)
4120              (type index idx))
4121     (do* ((i 0 (1+ i))
4122           (end (+ idx noctets))
4123           (index idx (+ 2 index)))
4124          ((>= index end) index)
4125       (declare (fixnum i end index))
4126       (setf (schar string i)
4127             (or (code-char (%reversed-u8-ref-u16 vector index))
4128                 (note-vector-decoding-problem vector index #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be))))))
4129  :memory-encode-function
4130  (nfunction
4131   reversed-ucs-2-memory-encode
4132   (lambda (string pointer idx start end)
4133     (declare (fixnum idx))
4134     (do* ((i start (1+ i)))
4135          ((>= i end) idx)
4136       (let* ((char (schar string i))
4137              (code (char-code char)))
4138         (declare (type (mod #x110000) code))
4139         (setf (%get-unsigned-word pointer idx)
4140               (if (>= code #x10000)
4141                 (%swap-u16 (note-encoding-problem char pointer #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be (char-code #\Replacement_Character)))
4142                 (%swap-u16 code)))
4143         (incf idx 2)))))
4144  :memory-decode-function
4145  (nfunction
4146   reversed-ucs-2-memory-decode
4147   (lambda (pointer noctets idx string)
4148     (declare (fixnum noctets idx))
4149     (do* ((i 0 (1+ i))
4150           (index idx (+ index 2)))
4151          ((>= i noctets) index)
4152       (declare (fixnum i index))
4153       (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index))))
4154         (declare (type (unsigned-byte 16) 1st-unit))
4155         (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)))))))
4156  :octets-in-string-function
4157  #'ucs-2-octets-in-string
4158  :length-of-vector-encoding-function
4159  #'ucs-2-length-of-vector-encoding
4160  :length-of-memory-encoding-function
4161  #'ucs-2-length-of-memory-encoding
4162  :decode-literal-code-unit-limit #x10000
4163  :encode-literal-char-code-limit #x10000
4164  :nul-encoding #(0 0)
4165  :character-size-in-octets-function 'two-octets-per-character
4166  )
4167
4168(define-character-encoding :ucs-2
4169    "A 16-bit, fixed-length encoding in which characters with