enc-iso.lisp

开源跨平台Lisp编译器

  (#xF8 #x03C8) ; GREEK SMALL LETTER PSI
  (#xF9 #x03C9) ; GREEK SMALL LETTER OMEGA
  (#xFA #x03CA) ; GREEK SMALL LETTER IOTA WITH DIALYTIKA
  (#xFB #x03CB) ; GREEK SMALL LETTER UPSILON WITH DIALYTIKA
  (#xFC #x03CC) ; GREEK SMALL LETTER OMICRON WITH TONOS
  (#xFD #x03CD) ; GREEK SMALL LETTER UPSILON WITH TONOS
  (#xFE #x03CE) ; GREEK SMALL LETTER OMEGA WITH TONOS
  (#xFF nil)
)

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

(defun string->iso-8859-7 (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-7-bytes null-padding)))

(defmacro define-iso-8859-7->string* (accessor type)
  (declare (ignore type))
  (let ((name (make-od-name 'iso-8859-7->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-7->code-mapper)))))

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

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

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

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

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

(define-unibyte-mapper iso-8859-8->code-mapper code->iso-8859-8-mapper
  (#xA1 nil)
  (#xAA #x00D7) ; MULTIPLICATION SIGN
  (#xAF #x203E) ; OVERLINE
  (#xBA #x00F7) ; DIVISION SIGN
  (#xBF nil)
  (#xC0 nil)
  (#xC1 nil)
  (#xC2 nil)
  (#xC3 nil)
  (#xC4 nil)
  (#xC5 nil)
  (#xC6 nil)
  (#xC7 nil)
  (#xC8 nil)
  (#xC9 nil)
  (#xCA nil)
  (#xCB nil)
  (#xCC nil)
  (#xCD nil)
  (#xCE nil)
  (#xCF nil)
  (#xD0 nil)
  (#xD1 nil)
  (#xD2 nil)
  (#xD3 nil)
  (#xD4 nil)
  (#xD5 nil)
  (#xD6 nil)
  (#xD7 nil)
  (#xD8 nil)
  (#xD9 nil)
  (#xDA nil)
  (#xDB nil)
  (#xDC nil)
  (#xDD nil)
  (#xDE nil)
  (#xDF #x2017) ; DOUBLE LOW LINE
  (#xE0 #x05D0) ; HEBREW LETTER ALEF
  (#xE1 #x05D1) ; HEBREW LETTER BET
  (#xE2 #x05D2) ; HEBREW LETTER GIMEL
  (#xE3 #x05D3) ; HEBREW LETTER DALET
  (#xE4 #x05D4) ; HEBREW LETTER HE
  (#xE5 #x05D5) ; HEBREW LETTER VAV
  (#xE6 #x05D6) ; HEBREW LETTER ZAYIN
  (#xE7 #x05D7) ; HEBREW LETTER HET
  (#xE8 #x05D8) ; HEBREW LETTER TET
  (#xE9 #x05D9) ; HEBREW LETTER YOD
  (#xEA #x05DA) ; HEBREW LETTER FINAL KAF
  (#xEB #x05DB) ; HEBREW LETTER KAF
  (#xEC #x05DC) ; HEBREW LETTER LAMED
  (#xED #x05DD) ; HEBREW LETTER FINAL MEM
  (#xEE #x05DE) ; HEBREW LETTER MEM
  (#xEF #x05DF) ; HEBREW LETTER FINAL NUN
  (#xF0 #x05E0) ; HEBREW LETTER NUN
  (#xF1 #x05E1) ; HEBREW LETTER SAMEKH
  (#xF2 #x05E2) ; HEBREW LETTER AYIN
  (#xF3 #x05E3) ; HEBREW LETTER FINAL PE
  (#xF4 #x05E4) ; HEBREW LETTER PE
  (#xF5 #x05E5) ; HEBREW LETTER FINAL TSADI
  (#xF6 #x05E6) ; HEBREW LETTER TSADI
  (#xF7 #x05E7) ; HEBREW LETTER QOF
  (#xF8 #x05E8) ; HEBREW LETTER RESH
  (#xF9 #x05E9) ; HEBREW LETTER SHIN
  (#xFA #x05EA) ; HEBREW LETTER TAV
  (#xFB nil)
  (#xFC nil)
  (#xFD nil)
  (#xFE nil)
  (#xFF nil)
)

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

(defun string->iso-8859-8 (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-8-bytes null-padding)))

(defmacro define-iso-8859-8->string* (accessor type)
  (declare (ignore type))
  (let ((name (make-od-name 'iso-8859-8->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-8->code-mapper)))))

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

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

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

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

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

(define-unibyte-mapper iso-8859-9->code-mapper code->iso-8859-9-mapper
  (#xD0 #x011E) ; LATIN CAPITAL LETTER G WITH BREVE
  (#xDD #x0130) ; LATIN CAPITAL LETTER I WITH DOT ABOVE
  (#xDE #x015E) ; LATIN CAPITAL LETTER S WITH CEDILLA
  (#xF0 #x011F) ; LATIN SMALL LETTER G WITH BREVE
  (#xFD #x0131) ; LATIN SMALL LETTER DOTLESS I
  (#xFE #x015F) ; LATIN SMALL LETTER S WITH CEDILLA
)

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

(defun string->iso-8859-9 (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-9-bytes null-padding)))

(defmacro define-iso-8859-9->string* (accessor type)
  (declare (ignore type))
  (let ((name (make-od-name 'iso-8859-9->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-9->code-mapper)))))

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

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

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

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

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

(define-unibyte-mapper iso-8859-10->code-mapper code->iso-8859-10-mapper
  (#xA1 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK
  (#xA2 #x0112) ; LATIN CAPITAL LETTER E WITH MACRON
  (#xA3 #x0122) ; LATIN CAPITAL LETTER G WITH CEDILLA
  (#xA4 #x012A) ; LATIN CAPITAL LETTER I WITH MACRON
  (#xA5 #x0128) ; LATIN CAPITAL LETTER I WITH TILDE
  (#xA6 #x0136) ; LATIN CAPITAL LETTER K WITH CEDILLA
  (#xA8 #x013B) ; LATIN CAPITAL LETTER L WITH CEDILLA
  (#xA9 #x0110) ; LATIN CAPITAL LETTER D WITH STROKE
  (#xAA #x0160) ; LATIN CAPITAL LETTER S WITH CARON
  (#xAB #x0166) ; LATIN CAPITAL LETTER T WITH STROKE
  (#xAC #x017D) ; LATIN CAPITAL LETTER Z WITH CARON
  (#xAE #x016A) ; LATIN CAPITAL LETTER U WITH MACRON
  (#xAF #x014A) ; LATIN CAPITAL LETTER ENG
  (#xB1 #x0105) ; LATIN SMALL LETTER A WITH OGONEK
  (#xB2 #x0113) ; LATIN SMALL LETTER E WITH MACRON
  (#xB3 #x0123) ; LATIN SMALL LETTER G WITH CEDILLA
  (#xB4 #x012B) ; LATIN SMALL LETTER I WITH MACRON
  (#xB5 #x0129) ; LATIN SMALL LETTER I WITH TILDE
  (#xB6 #x0137) ; LATIN SMALL LETTER K WITH CEDILLA
  (#xB8 #x013C) ; LATIN SMALL LETTER L WITH CEDILLA
  (#xB9 #x0111) ; LATIN SMALL LETTER D WITH STROKE
  (#xBA #x0161) ; LATIN SMALL LETTER S WITH CARON
  (#xBB #x0167) ; LATIN SMALL LETTER T WITH STROKE
  (#xBC #x017E) ; LATIN SMALL LETTER Z WITH CARON
  (#xBD #x2015) ; HORIZONTAL BAR
  (#xBE #x016B) ; LATIN SMALL LETTER U WITH MACRON
  (#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
  (#xD1 #x0145) ; LATIN CAPITAL LETTER N WITH CEDILLA
  (#xD2 #x014C) ; LATIN CAPITAL LETTER O WITH MACRON
  (#xD7 #x0168) ; LATIN CAPITAL LETTER U WITH TILDE
  (#xD9 #x0172) ; LATIN CAPITAL LETTER U WITH OGONEK
  (#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
  (#xF1 #x0146) ; LATIN SMALL LETTER N WITH CEDILLA
  (#xF2 #x014D) ; LATIN SMALL LETTER O WITH MACRON
  (#xF7 #x0169) ; LATIN SMALL LETTER U WITH TILDE
  (#xF9 #x0173) ; LATIN SMALL LETTER U WITH OGONEK
  (#xFF #x0138) ; LATIN SMALL LETTER KRA
)

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

(defun string->iso-8859-10 (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-10-bytes null-padding)))

(defmacro define-iso-8859-10->string* (accessor type)
  (declare (ignore type))
  (let ((name (make-od-name 'iso-8859-10->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-10->code-mapper)))))

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

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

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

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

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

(define-unibyte-mapper iso-8859-11->code-mapper code->iso-8859-11-mapper
  (#xA1 #x0E01) ; THAI CHARACTER KO KAI
  (#xA2 #x0E02) ; THAI CHARACTER KHO KHAI
  (#xA3 #x0E03) ; THAI CHARACTER KHO KHUAT
  (#xA4 #x0E04) ; THAI CHARACTER KHO KHWAI