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

Last change on this file since 15535 was 15535, checked in by gb, 7 years ago

Re-factor the options-line parsing stuff a little.

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