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

Last change on this file since 5571 was 5571, checked in by gb, 14 years ago

Memory/vector encode functions: don't write BOM, leave that up to
higher-level code.

Start to write some higher-level code.

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