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

Last change on this file since 8573 was 8573, checked in by gb, 12 years ago

8-bit-fixed-witdh-length-of-vector-encoding: second return value when
indices valid should be end, not length.
%COUNT-CHARACTERS-IN-OCTET-VECTOR: last arg should be end index, not
length. Fixes reported cases in ticket:249, but there may be other
inconsistencies in other encodings.

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