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

Last change on this file since 13563 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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