enc-iso.lisp

开源跨平台Lisp编译器

(in-package "SB!IMPL")

(define-unibyte-mapper iso-8859-2->code-mapper code->iso-8859-2-mapper
  (#xA1 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK
  (#xA2 #x02D8) ; BREVE
  (#xA3 #x0141) ; LATIN CAPITAL LETTER L WITH STROKE
  (#xA5 #x013D) ; LATIN CAPITAL LETTER L WITH CARON
  (#xA6 #x015A) ; LATIN CAPITAL LETTER S WITH ACUTE
  (#xA9 #x0160) ; LATIN CAPITAL LETTER S WITH CARON
  (#xAA #x015E) ; LATIN CAPITAL LETTER S WITH CEDILLA
  (#xAB #x0164) ; LATIN CAPITAL LETTER T WITH CARON
  (#xAC #x0179) ; LATIN CAPITAL LETTER Z WITH ACUTE
  (#xAE #x017D) ; LATIN CAPITAL LETTER Z WITH CARON
  (#xAF #x017B) ; LATIN CAPITAL LETTER Z WITH DOT ABOVE
  (#xB1 #x0105) ; LATIN SMALL LETTER A WITH OGONEK
  (#xB2 #x02DB) ; OGONEK
  (#xB3 #x0142) ; LATIN SMALL LETTER L WITH STROKE
  (#xB5 #x013E) ; LATIN SMALL LETTER L WITH CARON
  (#xB6 #x015B) ; LATIN SMALL LETTER S WITH ACUTE
  (#xB7 #x02C7) ; CARON
  (#xB9 #x0161) ; LATIN SMALL LETTER S WITH CARON
  (#xBA #x015F) ; LATIN SMALL LETTER S WITH CEDILLA
  (#xBB #x0165) ; LATIN SMALL LETTER T WITH CARON
  (#xBC #x017A) ; LATIN SMALL LETTER Z WITH ACUTE
  (#xBD #x02DD) ; DOUBLE ACUTE ACCENT
  (#xBE #x017E) ; LATIN SMALL LETTER Z WITH CARON
  (#xBF #x017C) ; LATIN SMALL LETTER Z WITH DOT ABOVE
  (#xC0 #x0154) ; LATIN CAPITAL LETTER R WITH ACUTE
  (#xC3 #x0102) ; LATIN CAPITAL LETTER A WITH BREVE
  (#xC5 #x0139) ; LATIN CAPITAL LETTER L WITH ACUTE
  (#xC6 #x0106) ; LATIN CAPITAL LETTER C WITH ACUTE
  (#xC8 #x010C) ; LATIN CAPITAL LETTER C WITH CARON
  (#xCA #x0118) ; LATIN CAPITAL LETTER E WITH OGONEK
  (#xCC #x011A) ; LATIN CAPITAL LETTER E WITH CARON
  (#xCF #x010E) ; LATIN CAPITAL LETTER D WITH CARON
  (#xD0 #x0110) ; LATIN CAPITAL LETTER D WITH STROKE
  (#xD1 #x0143) ; LATIN CAPITAL LETTER N WITH ACUTE
  (#xD2 #x0147) ; LATIN CAPITAL LETTER N WITH CARON
  (#xD5 #x0150) ; LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
  (#xD8 #x0158) ; LATIN CAPITAL LETTER R WITH CARON
  (#xD9 #x016E) ; LATIN CAPITAL LETTER U WITH RING ABOVE
  (#xDB #x0170) ; LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
  (#xDE #x0162) ; LATIN CAPITAL LETTER T WITH CEDILLA
  (#xE0 #x0155) ; LATIN SMALL LETTER R WITH ACUTE
  (#xE3 #x0103) ; LATIN SMALL LETTER A WITH BREVE
  (#xE5 #x013A) ; LATIN SMALL LETTER L WITH ACUTE
  (#xE6 #x0107) ; LATIN SMALL LETTER C WITH ACUTE
  (#xE8 #x010D) ; LATIN SMALL LETTER C WITH CARON
  (#xEA #x0119) ; LATIN SMALL LETTER E WITH OGONEK
  (#xEC #x011B) ; LATIN SMALL LETTER E WITH CARON
  (#xEF #x010F) ; LATIN SMALL LETTER D WITH CARON
  (#xF0 #x0111) ; LATIN SMALL LETTER D WITH STROKE
  (#xF1 #x0144) ; LATIN SMALL LETTER N WITH ACUTE
  (#xF2 #x0148) ; LATIN SMALL LETTER N WITH CARON
  (#xF5 #x0151) ; LATIN SMALL LETTER O WITH DOUBLE ACUTE
  (#xF8 #x0159) ; LATIN SMALL LETTER R WITH CARON
  (#xF9 #x016F) ; LATIN SMALL LETTER U WITH RING ABOVE
  (#xFB #x0171) ; LATIN SMALL LETTER U WITH DOUBLE ACUTE
  (#xFE #x0163) ; LATIN SMALL LETTER T WITH CEDILLA
  (#xFF #x02D9) ; DOT ABOVE
)

(declaim (inline get-iso-8859-2-bytes))
(defun get-iso-8859-2-bytes (string pos)
  (declare (optimize speed (safety 0))
           (type simple-string string)
           (type array-range pos))
  (get-latin-bytes #'code->iso-8859-2-mapper :iso-8859-2 string pos))

(defun string->iso-8859-2 (string sstart send null-padding)
  (declare (optimize speed (safety 0))
           (type simple-string string)
           (type array-range sstart send))
  (values (string->latin% string sstart send #'get-iso-8859-2-bytes null-padding)))

(defmacro define-iso-8859-2->string* (accessor type)
  (declare (ignore type))
  (let ((name (make-od-name 'iso-8859-2->string* accessor)))
    `(progn
      (defun ,name (string sstart send array astart aend)
        (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'iso-8859-2->code-mapper)))))

(instantiate-octets-definition define-iso-8859-2->string*)

(defmacro define-iso-8859-2->string (accessor type)
  (declare (ignore type))
  `(defun ,(make-od-name 'iso-8859-2->string accessor) (array astart aend)
    (,(make-od-name 'latin->string accessor) array astart aend #'iso-8859-2->code-mapper)))

(instantiate-octets-definition define-iso-8859-2->string)

(add-external-format-funs '(:iso-8859-2 :|iso-8859-2| :latin-2 :|latin-2|)
                          '(iso-8859-2->string-aref string->iso-8859-2))

(define-external-format (:iso-8859-2 :|iso-8859-2| :latin-2 :|latin-2|)
    1 t
    (let ((iso-8859-2-byte (code->iso-8859-2-mapper bits)))
      (if iso-8859-2-byte
          (setf (sap-ref-8 sap tail) iso-8859-2-byte)
          (external-format-encoding-error stream bits)))
    (let ((code (iso-8859-2->code-mapper byte)))
      (if code
          (code-char code)
          (external-format-decoding-error stream byte)))) ;; TODO -- error check

(define-unibyte-mapper iso-8859-3->code-mapper code->iso-8859-3-mapper
  (#xA1 #x0126) ; LATIN CAPITAL LETTER H WITH STROKE
  (#xA2 #x02D8) ; BREVE
  (#xA5 nil)
  (#xA6 #x0124) ; LATIN CAPITAL LETTER H WITH CIRCUMFLEX
  (#xA9 #x0130) ; LATIN CAPITAL LETTER I WITH DOT ABOVE
  (#xAA #x015E) ; LATIN CAPITAL LETTER S WITH CEDILLA
  (#xAB #x011E) ; LATIN CAPITAL LETTER G WITH BREVE
  (#xAC #x0134) ; LATIN CAPITAL LETTER J WITH CIRCUMFLEX
  (#xAE nil)
  (#xAF #x017B) ; LATIN CAPITAL LETTER Z WITH DOT ABOVE
  (#xB1 #x0127) ; LATIN SMALL LETTER H WITH STROKE
  (#xB6 #x0125) ; LATIN SMALL LETTER H WITH CIRCUMFLEX
  (#xB9 #x0131) ; LATIN SMALL LETTER DOTLESS I
  (#xBA #x015F) ; LATIN SMALL LETTER S WITH CEDILLA
  (#xBB #x011F) ; LATIN SMALL LETTER G WITH BREVE
  (#xBC #x0135) ; LATIN SMALL LETTER J WITH CIRCUMFLEX
  (#xBE nil)
  (#xBF #x017C) ; LATIN SMALL LETTER Z WITH DOT ABOVE
  (#xC3 nil)
  (#xC5 #x010A) ; LATIN CAPITAL LETTER C WITH DOT ABOVE
  (#xC6 #x0108) ; LATIN CAPITAL LETTER C WITH CIRCUMFLEX
  (#xD0 nil)
  (#xD5 #x0120) ; LATIN CAPITAL LETTER G WITH DOT ABOVE
  (#xD8 #x011C) ; LATIN CAPITAL LETTER G WITH CIRCUMFLEX
  (#xDD #x016C) ; LATIN CAPITAL LETTER U WITH BREVE
  (#xDE #x015C) ; LATIN CAPITAL LETTER S WITH CIRCUMFLEX
  (#xE3 nil)
  (#xE5 #x010B) ; LATIN SMALL LETTER C WITH DOT ABOVE
  (#xE6 #x0109) ; LATIN SMALL LETTER C WITH CIRCUMFLEX
  (#xF0 nil)
  (#xF5 #x0121) ; LATIN SMALL LETTER G WITH DOT ABOVE
  (#xF8 #x011D) ; LATIN SMALL LETTER G WITH CIRCUMFLEX
  (#xFD #x016D) ; LATIN SMALL LETTER U WITH BREVE
  (#xFE #x015D) ; LATIN SMALL LETTER S WITH CIRCUMFLEX
  (#xFF #x02D9) ; DOT ABOVE
)

(declaim (inline get-iso-8859-3-bytes))
(defun get-iso-8859-3-bytes (string pos)
  (declare (optimize speed (safety 0))
           (type simple-string string)
           (type array-range pos))
  (get-latin-bytes #'code->iso-8859-3-mapper :iso-8859-3 string pos))

(defun string->iso-8859-3 (string sstart send null-padding)
  (declare (optimize speed (safety 0))
           (type simple-string string)
           (type array-range sstart send))
  (values (string->latin% string sstart send #'get-iso-8859-3-bytes null-padding)))

(defmacro define-iso-8859-3->string* (accessor type)
  (declare (ignore type))
  (let ((name (make-od-name 'iso-8859-3->string* accessor)))
    `(progn
      (defun ,name (string sstart send array astart aend)
        (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'iso-8859-3->code-mapper)))))

(instantiate-octets-definition define-iso-8859-3->string*)

(defmacro define-iso-8859-3->string (accessor type)
  (declare (ignore type))
  `(defun ,(make-od-name 'iso-8859-3->string accessor) (array astart aend)
    (,(make-od-name 'latin->string accessor) array astart aend #'iso-8859-3->code-mapper)))

(instantiate-octets-definition define-iso-8859-3->string)

(add-external-format-funs '(:iso-8859-3 :|iso-8859-3| :latin-3 :|latin-3|)
                          '(iso-8859-3->string-aref string->iso-8859-3))

(define-external-format (:iso-8859-3 :|iso-8859-3| :latin-3 :|latin-3|)
    1 t
    (let ((iso-8859-3-byte (code->iso-8859-3-mapper bits)))
      (if iso-8859-3-byte
          (setf (sap-ref-8 sap tail) iso-8859-3-byte)
          (external-format-encoding-error stream bits)))
    (let ((code (iso-8859-3->code-mapper byte)))
      (if code
          (code-char code)
          (external-format-decoding-error stream byte)))) ;; TODO -- error check

(define-unibyte-mapper iso-8859-4->code-mapper code->iso-8859-4-mapper
  (#xA1 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK
  (#xA2 #x0138) ; LATIN SMALL LETTER KRA
  (#xA3 #x0156) ; LATIN CAPITAL LETTER R WITH CEDILLA
  (#xA5 #x0128) ; LATIN CAPITAL LETTER I WITH TILDE
  (#xA6 #x013B) ; LATIN CAPITAL LETTER L WITH CEDILLA
  (#xA9 #x0160) ; LATIN CAPITAL LETTER S WITH CARON
  (#xAA #x0112) ; LATIN CAPITAL LETTER E WITH MACRON
  (#xAB #x0122) ; LATIN CAPITAL LETTER G WITH CEDILLA
  (#xAC #x0166) ; LATIN CAPITAL LETTER T WITH STROKE
  (#xAE #x017D) ; LATIN CAPITAL LETTER Z WITH CARON
  (#xB1 #x0105) ; LATIN SMALL LETTER A WITH OGONEK
  (#xB2 #x02DB) ; OGONEK
  (#xB3 #x0157) ; LATIN SMALL LETTER R WITH CEDILLA
  (#xB5 #x0129) ; LATIN SMALL LETTER I WITH TILDE
  (#xB6 #x013C) ; LATIN SMALL LETTER L WITH CEDILLA
  (#xB7 #x02C7) ; CARON
  (#xB9 #x0161) ; LATIN SMALL LETTER S WITH CARON
  (#xBA #x0113) ; LATIN SMALL LETTER E WITH MACRON
  (#xBB #x0123) ; LATIN SMALL LETTER G WITH CEDILLA
  (#xBC #x0167) ; LATIN SMALL LETTER T WITH STROKE
  (#xBD #x014A) ; LATIN CAPITAL LETTER ENG
  (#xBE #x017E) ; LATIN SMALL LETTER Z WITH CARON
  (#xBF #x014B) ; LATIN SMALL LETTER ENG
  (#xC0 #x0100) ; LATIN CAPITAL LETTER A WITH MACRON
  (#xC7 #x012E) ; LATIN CAPITAL LETTER I WITH OGONEK
  (#xC8 #x010C) ; LATIN CAPITAL LETTER C WITH CARON
  (#xCA #x0118) ; LATIN CAPITAL LETTER E WITH OGONEK
  (#xCC #x0116) ; LATIN CAPITAL LETTER E WITH DOT ABOVE
  (#xCF #x012A) ; LATIN CAPITAL LETTER I WITH MACRON
  (#xD0 #x0110) ; LATIN CAPITAL LETTER D WITH STROKE
  (#xD1 #x0145) ; LATIN CAPITAL LETTER N WITH CEDILLA
  (#xD2 #x014C) ; LATIN CAPITAL LETTER O WITH MACRON
  (#xD3 #x0136) ; LATIN CAPITAL LETTER K WITH CEDILLA
  (#xD9 #x0172) ; LATIN CAPITAL LETTER U WITH OGONEK
  (#xDD #x0168) ; LATIN CAPITAL LETTER U WITH TILDE
  (#xDE #x016A) ; LATIN CAPITAL LETTER U WITH MACRON
  (#xE0 #x0101) ; LATIN SMALL LETTER A WITH MACRON
  (#xE7 #x012F) ; LATIN SMALL LETTER I WITH OGONEK
  (#xE8 #x010D) ; LATIN SMALL LETTER C WITH CARON
  (#xEA #x0119) ; LATIN SMALL LETTER E WITH OGONEK
  (#xEC #x0117) ; LATIN SMALL LETTER E WITH DOT ABOVE
  (#xEF #x012B) ; LATIN SMALL LETTER I WITH MACRON
  (#xF0 #x0111) ; LATIN SMALL LETTER D WITH STROKE
  (#xF1 #x0146) ; LATIN SMALL LETTER N WITH CEDILLA
  (#xF2 #x014D) ; LATIN SMALL LETTER O WITH MACRON
  (#xF3 #x0137) ; LATIN SMALL LETTER K WITH CEDILLA
  (#xF9 #x0173) ; LATIN SMALL LETTER U WITH OGONEK
  (#xFD #x0169) ; LATIN SMALL LETTER U WITH TILDE
  (#xFE #x016B) ; LATIN SMALL LETTER U WITH MACRON
  (#xFF #x02D9) ; DOT ABOVE
)

(declaim (inline get-iso-8859-4-bytes))
(defun get-iso-8859-4-bytes (string pos)
  (declare (optimize speed (safety 0))
           (type simple-string string)
           (type array-range pos))
  (get-latin-bytes #'code->iso-8859-4-mapper :iso-8859-4 string pos))

(defun string->iso-8859-4 (string sstart send null-padding)
  (declare (optimize speed (safety 0))
           (type simple-string string)
           (type array-range sstart send))
  (values (string->latin% string sstart send #'get-iso-8859-4-bytes null-padding)))

(defmacro define-iso-8859-4->string* (accessor type)
  (declare (ignore type))
  (let ((name (make-od-name 'iso-8859-4->string* accessor)))
    `(progn
      (defun ,name (string sstart send array astart aend)
        (,(make-od-name 'latin->string* accessor) string sstart send array astart aend #'iso-8859-4->code-mapper)))))

(instantiate-octets-definition define-iso-8859-4->string*)

(defmacro define-iso-8859-4->string (accessor type)
  (declare (ignore type))
  `(defun ,(make-od-name 'iso-8859-4->string accessor) (array astart aend)
    (,(make-od-name 'latin->string accessor) array astart aend #'iso-8859-4->code-mapper)))

(instantiate-octets-definition define-iso-8859-4->string)

(add-external-format-funs '(:iso-8859-4 :|iso-8859-4| :latin-4 :|latin-4|)
                          '(iso-8859-4->string-aref string->iso-8859-4))

(define-external-format (:iso-8859-4 :|iso-8859-4| :latin-4 :|latin-4|)
    1 t
    (let ((iso-8859-4-byte (code->iso-8859-4-mapper bits)))
      (if iso-8859-4-byte
          (setf (sap-ref-8 sap tail) iso-8859-4-byte)
          (external-format-encoding-error stream bits)))
    (let ((code (iso-8859-4->code-mapper byte)))
      (if code
          (code-char code)
          (external-format-decoding-error stream byte)))) ;; TODO -- error check

(define-unibyte-mapper iso-8859-5->code-mapper code->iso-8859-5-mapper
  (#xA1 #x0401) ; CYRILLIC CAPITAL LETTER IO
  (#xA2 #x0402) ; CYRILLIC CAPITAL LETTER DJE
  (#xA3 #x0403) ; CYRILLIC CAPITAL LETTER GJE
  (#xA4 #x0404) ; CYRILLIC CAPITAL LETTER UKRAINIAN IE
  (#xA5 #x0405) ; CYRILLIC CAPITAL LETTER DZE
  (#xA6 #x0406) ; CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I
  (#xA7 #x0407) ; CYRILLIC CAPITAL LETTER YI
  (#xA8 #x0408) ; CYRILLIC CAPITAL LETTER JE
  (#xA9 #x0409) ; CYRILLIC CAPITAL LETTER LJE
  (#xAA #x040A) ; CYRILLIC CAPITAL LETTER NJE
  (#xAB #x040B) ; CYRILLIC CAPITAL LETTER TSHE
  (#xAC #x040C) ; CYRILLIC CAPITAL LETTER KJE
  (#xAE #x040E) ; CYRILLIC CAPITAL LETTER SHORT U
  (#xAF #x040F) ; CYRILLIC CAPITAL LETTER DZHE
  (#xB0 #x0410) ; CYRILLIC CAPITAL LETTER A
  (#xB1 #x0411) ; CYRILLIC CAPITAL LETTER BE
  (#xB2 #x0412) ; CYRILLIC CAPITAL LETTER VE
  (#xB3 #x0413) ; CYRILLIC CAPITAL LETTER GHE
  (#xB4 #x0414) ; CYRILLIC CAPITAL LETTER DE
  (#xB5 #x0415) ; CYRILLIC CAPITAL LETTER IE
  (#xB6 #x0416) ; CYRILLIC CAPITAL LETTER ZHE
  (#xB7 #x0417) ; CYRILLIC CAPITAL LETTER ZE
  (#xB8 #x0418) ; CYRILLIC CAPITAL LETTER I
  (#xB9 #x0419) ; CYRILLIC CAPITAL LETTER SHORT I
  (#xBA #x041A) ; CYRILLIC CAPITAL LETTER KA
  (#xBB #x041B) ; CYRILLIC CAPITAL LETTER EL
  (#xBC #x041C) ; CYRILLIC CAPITAL LETTER EM
  (#xBD #x041D) ; CYRILLIC CAPITAL LETTER EN
  (#xBE #x041E) ; CYRILLIC CAPITAL LETTER O
  (#xBF #x041F) ; CYRILLIC CAPITAL LETTER PE
  (#xC0 #x0420) ; CYRILLIC CAPITAL LETTER ER
  (#xC1 #x0421) ; CYRILLIC CAPITAL LETTER ES
  (#xC2 #x0422) ; CYRILLIC CAPITAL LETTER TE
  (#xC3 #x0423) ; CYRILLIC CAPITAL LETTER U