source: branches/objc-gf/ccl/level-1/l1-unicode.lisp @ 6128

Last change on this file since 6128 was 6128, checked in by gb, 13 years ago

add BOM-ENCODING; encoded-c-string stuff.

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