enc-iso.lisp

开源跨平台Lisp编译器

  (#xC4 #x0424) ; CYRILLIC CAPITAL LETTER EF
  (#xC5 #x0425) ; CYRILLIC CAPITAL LETTER HA
  (#xC6 #x0426) ; CYRILLIC CAPITAL LETTER TSE
  (#xC7 #x0427) ; CYRILLIC CAPITAL LETTER CHE
  (#xC8 #x0428) ; CYRILLIC CAPITAL LETTER SHA
  (#xC9 #x0429) ; CYRILLIC CAPITAL LETTER SHCHA
  (#xCA #x042A) ; CYRILLIC CAPITAL LETTER HARD SIGN
  (#xCB #x042B) ; CYRILLIC CAPITAL LETTER YERU
  (#xCC #x042C) ; CYRILLIC CAPITAL LETTER SOFT SIGN
  (#xCD #x042D) ; CYRILLIC CAPITAL LETTER E
  (#xCE #x042E) ; CYRILLIC CAPITAL LETTER YU
  (#xCF #x042F) ; CYRILLIC CAPITAL LETTER YA
  (#xD0 #x0430) ; CYRILLIC SMALL LETTER A
  (#xD1 #x0431) ; CYRILLIC SMALL LETTER BE
  (#xD2 #x0432) ; CYRILLIC SMALL LETTER VE
  (#xD3 #x0433) ; CYRILLIC SMALL LETTER GHE
  (#xD4 #x0434) ; CYRILLIC SMALL LETTER DE
  (#xD5 #x0435) ; CYRILLIC SMALL LETTER IE
  (#xD6 #x0436) ; CYRILLIC SMALL LETTER ZHE
  (#xD7 #x0437) ; CYRILLIC SMALL LETTER ZE
  (#xD8 #x0438) ; CYRILLIC SMALL LETTER I
  (#xD9 #x0439) ; CYRILLIC SMALL LETTER SHORT I
  (#xDA #x043A) ; CYRILLIC SMALL LETTER KA
  (#xDB #x043B) ; CYRILLIC SMALL LETTER EL
  (#xDC #x043C) ; CYRILLIC SMALL LETTER EM
  (#xDD #x043D) ; CYRILLIC SMALL LETTER EN
  (#xDE #x043E) ; CYRILLIC SMALL LETTER O
  (#xDF #x043F) ; CYRILLIC SMALL LETTER PE
  (#xE0 #x0440) ; CYRILLIC SMALL LETTER ER
  (#xE1 #x0441) ; CYRILLIC SMALL LETTER ES
  (#xE2 #x0442) ; CYRILLIC SMALL LETTER TE
  (#xE3 #x0443) ; CYRILLIC SMALL LETTER U
  (#xE4 #x0444) ; CYRILLIC SMALL LETTER EF
  (#xE5 #x0445) ; CYRILLIC SMALL LETTER HA
  (#xE6 #x0446) ; CYRILLIC SMALL LETTER TSE
  (#xE7 #x0447) ; CYRILLIC SMALL LETTER CHE
  (#xE8 #x0448) ; CYRILLIC SMALL LETTER SHA
  (#xE9 #x0449) ; CYRILLIC SMALL LETTER SHCHA
  (#xEA #x044A) ; CYRILLIC SMALL LETTER HARD SIGN
  (#xEB #x044B) ; CYRILLIC SMALL LETTER YERU
  (#xEC #x044C) ; CYRILLIC SMALL LETTER SOFT SIGN
  (#xED #x044D) ; CYRILLIC SMALL LETTER E
  (#xEE #x044E) ; CYRILLIC SMALL LETTER YU
  (#xEF #x044F) ; CYRILLIC SMALL LETTER YA
  (#xF0 #x2116) ; NUMERO SIGN
  (#xF1 #x0451) ; CYRILLIC SMALL LETTER IO
  (#xF2 #x0452) ; CYRILLIC SMALL LETTER DJE
  (#xF3 #x0453) ; CYRILLIC SMALL LETTER GJE
  (#xF4 #x0454) ; CYRILLIC SMALL LETTER UKRAINIAN IE
  (#xF5 #x0455) ; CYRILLIC SMALL LETTER DZE
  (#xF6 #x0456) ; CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I
  (#xF7 #x0457) ; CYRILLIC SMALL LETTER YI
  (#xF8 #x0458) ; CYRILLIC SMALL LETTER JE
  (#xF9 #x0459) ; CYRILLIC SMALL LETTER LJE
  (#xFA #x045A) ; CYRILLIC SMALL LETTER NJE
  (#xFB #x045B) ; CYRILLIC SMALL LETTER TSHE
  (#xFC #x045C) ; CYRILLIC SMALL LETTER KJE
  (#xFD #x00A7) ; SECTION SIGN
  (#xFE #x045E) ; CYRILLIC SMALL LETTER SHORT U
  (#xFF #x045F) ; CYRILLIC SMALL LETTER DZHE
)

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

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

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

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

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

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

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

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

(define-unibyte-mapper iso-8859-6->code-mapper code->iso-8859-6-mapper
  (#xA1 nil)
  (#xA2 nil)
  (#xA3 nil)
  (#xA5 nil)
  (#xA6 nil)
  (#xA7 nil)
  (#xA8 nil)
  (#xA9 nil)
  (#xAA nil)
  (#xAB nil)
  (#xAC #x060C) ; ARABIC COMMA
  (#xAE nil)
  (#xAF nil)
  (#xB0 nil)
  (#xB1 nil)
  (#xB2 nil)
  (#xB3 nil)
  (#xB4 nil)
  (#xB5 nil)
  (#xB6 nil)
  (#xB7 nil)
  (#xB8 nil)
  (#xB9 nil)
  (#xBA nil)
  (#xBB #x061B) ; ARABIC SEMICOLON
  (#xBC nil)
  (#xBD nil)
  (#xBE nil)
  (#xBF #x061F) ; ARABIC QUESTION MARK
  (#xC0 nil)
  (#xC1 #x0621) ; ARABIC LETTER HAMZA
  (#xC2 #x0622) ; ARABIC LETTER ALEF WITH MADDA ABOVE
  (#xC3 #x0623) ; ARABIC LETTER ALEF WITH HAMZA ABOVE
  (#xC4 #x0624) ; ARABIC LETTER WAW WITH HAMZA ABOVE
  (#xC5 #x0625) ; ARABIC LETTER ALEF WITH HAMZA BELOW
  (#xC6 #x0626) ; ARABIC LETTER YEH WITH HAMZA ABOVE
  (#xC7 #x0627) ; ARABIC LETTER ALEF
  (#xC8 #x0628) ; ARABIC LETTER BEH
  (#xC9 #x0629) ; ARABIC LETTER TEH MARBUTA
  (#xCA #x062A) ; ARABIC LETTER TEH
  (#xCB #x062B) ; ARABIC LETTER THEH
  (#xCC #x062C) ; ARABIC LETTER JEEM
  (#xCD #x062D) ; ARABIC LETTER HAH
  (#xCE #x062E) ; ARABIC LETTER KHAH
  (#xCF #x062F) ; ARABIC LETTER DAL
  (#xD0 #x0630) ; ARABIC LETTER THAL
  (#xD1 #x0631) ; ARABIC LETTER REH
  (#xD2 #x0632) ; ARABIC LETTER ZAIN
  (#xD3 #x0633) ; ARABIC LETTER SEEN
  (#xD4 #x0634) ; ARABIC LETTER SHEEN
  (#xD5 #x0635) ; ARABIC LETTER SAD
  (#xD6 #x0636) ; ARABIC LETTER DAD
  (#xD7 #x0637) ; ARABIC LETTER TAH
  (#xD8 #x0638) ; ARABIC LETTER ZAH
  (#xD9 #x0639) ; ARABIC LETTER AIN
  (#xDA #x063A) ; ARABIC LETTER GHAIN
  (#xDB nil)
  (#xDC nil)
  (#xDD nil)
  (#xDE nil)
  (#xDF nil)
  (#xE0 #x0640) ; ARABIC TATWEEL
  (#xE1 #x0641) ; ARABIC LETTER FEH
  (#xE2 #x0642) ; ARABIC LETTER QAF
  (#xE3 #x0643) ; ARABIC LETTER KAF
  (#xE4 #x0644) ; ARABIC LETTER LAM
  (#xE5 #x0645) ; ARABIC LETTER MEEM
  (#xE6 #x0646) ; ARABIC LETTER NOON
  (#xE7 #x0647) ; ARABIC LETTER HEH
  (#xE8 #x0648) ; ARABIC LETTER WAW
  (#xE9 #x0649) ; ARABIC LETTER ALEF MAKSURA
  (#xEA #x064A) ; ARABIC LETTER YEH
  (#xEB #x064B) ; ARABIC FATHATAN
  (#xEC #x064C) ; ARABIC DAMMATAN
  (#xED #x064D) ; ARABIC KASRATAN
  (#xEE #x064E) ; ARABIC FATHA
  (#xEF #x064F) ; ARABIC DAMMA
  (#xF0 #x0650) ; ARABIC KASRA
  (#xF1 #x0651) ; ARABIC SHADDA
  (#xF2 #x0652) ; ARABIC SUKUN
  (#xF3 nil)
  (#xF4 nil)
  (#xF5 nil)
  (#xF6 nil)
  (#xF7 nil)
  (#xF8 nil)
  (#xF9 nil)
  (#xFA nil)
  (#xFB nil)
  (#xFC nil)
  (#xFD nil)
  (#xFE nil)
  (#xFF nil)
)

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

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

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

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

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

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

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

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

(define-unibyte-mapper iso-8859-7->code-mapper code->iso-8859-7-mapper
  (#xA1 #x02BD) ; MODIFIER LETTER REVERSED COMMA
  (#xA2 #x02BC) ; MODIFIER LETTER APOSTROPHE
  (#xA4 nil)
  (#xA5 nil)
  (#xAA nil)
  (#xAE nil)
  (#xAF #x2015) ; HORIZONTAL BAR
  (#xB4 #x0384) ; GREEK TONOS
  (#xB5 #x0385) ; GREEK DIALYTIKA TONOS
  (#xB6 #x0386) ; GREEK CAPITAL LETTER ALPHA WITH TONOS
  (#xB8 #x0388) ; GREEK CAPITAL LETTER EPSILON WITH TONOS
  (#xB9 #x0389) ; GREEK CAPITAL LETTER ETA WITH TONOS
  (#xBA #x038A) ; GREEK CAPITAL LETTER IOTA WITH TONOS
  (#xBC #x038C) ; GREEK CAPITAL LETTER OMICRON WITH TONOS
  (#xBE #x038E) ; GREEK CAPITAL LETTER UPSILON WITH TONOS
  (#xBF #x038F) ; GREEK CAPITAL LETTER OMEGA WITH TONOS
  (#xC0 #x0390) ; GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
  (#xC1 #x0391) ; GREEK CAPITAL LETTER ALPHA
  (#xC2 #x0392) ; GREEK CAPITAL LETTER BETA
  (#xC3 #x0393) ; GREEK CAPITAL LETTER GAMMA
  (#xC4 #x0394) ; GREEK CAPITAL LETTER DELTA
  (#xC5 #x0395) ; GREEK CAPITAL LETTER EPSILON
  (#xC6 #x0396) ; GREEK CAPITAL LETTER ZETA
  (#xC7 #x0397) ; GREEK CAPITAL LETTER ETA
  (#xC8 #x0398) ; GREEK CAPITAL LETTER THETA
  (#xC9 #x0399) ; GREEK CAPITAL LETTER IOTA
  (#xCA #x039A) ; GREEK CAPITAL LETTER KAPPA
  (#xCB #x039B) ; GREEK CAPITAL LETTER LAMDA
  (#xCC #x039C) ; GREEK CAPITAL LETTER MU
  (#xCD #x039D) ; GREEK CAPITAL LETTER NU
  (#xCE #x039E) ; GREEK CAPITAL LETTER XI
  (#xCF #x039F) ; GREEK CAPITAL LETTER OMICRON
  (#xD0 #x03A0) ; GREEK CAPITAL LETTER PI
  (#xD1 #x03A1) ; GREEK CAPITAL LETTER RHO
  (#xD2 nil)
  (#xD3 #x03A3) ; GREEK CAPITAL LETTER SIGMA
  (#xD4 #x03A4) ; GREEK CAPITAL LETTER TAU
  (#xD5 #x03A5) ; GREEK CAPITAL LETTER UPSILON
  (#xD6 #x03A6) ; GREEK CAPITAL LETTER PHI
  (#xD7 #x03A7) ; GREEK CAPITAL LETTER CHI
  (#xD8 #x03A8) ; GREEK CAPITAL LETTER PSI
  (#xD9 #x03A9) ; GREEK CAPITAL LETTER OMEGA
  (#xDA #x03AA) ; GREEK CAPITAL LETTER IOTA WITH DIALYTIKA
  (#xDB #x03AB) ; GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA
  (#xDC #x03AC) ; GREEK SMALL LETTER ALPHA WITH TONOS
  (#xDD #x03AD) ; GREEK SMALL LETTER EPSILON WITH TONOS
  (#xDE #x03AE) ; GREEK SMALL LETTER ETA WITH TONOS
  (#xDF #x03AF) ; GREEK SMALL LETTER IOTA WITH TONOS
  (#xE0 #x03B0) ; GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
  (#xE1 #x03B1) ; GREEK SMALL LETTER ALPHA
  (#xE2 #x03B2) ; GREEK SMALL LETTER BETA
  (#xE3 #x03B3) ; GREEK SMALL LETTER GAMMA
  (#xE4 #x03B4) ; GREEK SMALL LETTER DELTA
  (#xE5 #x03B5) ; GREEK SMALL LETTER EPSILON
  (#xE6 #x03B6) ; GREEK SMALL LETTER ZETA
  (#xE7 #x03B7) ; GREEK SMALL LETTER ETA
  (#xE8 #x03B8) ; GREEK SMALL LETTER THETA
  (#xE9 #x03B9) ; GREEK SMALL LETTER IOTA
  (#xEA #x03BA) ; GREEK SMALL LETTER KAPPA
  (#xEB #x03BB) ; GREEK SMALL LETTER LAMDA
  (#xEC #x03BC) ; GREEK SMALL LETTER MU
  (#xED #x03BD) ; GREEK SMALL LETTER NU
  (#xEE #x03BE) ; GREEK SMALL LETTER XI
  (#xEF #x03BF) ; GREEK SMALL LETTER OMICRON
  (#xF0 #x03C0) ; GREEK SMALL LETTER PI
  (#xF1 #x03C1) ; GREEK SMALL LETTER RHO
  (#xF2 #x03C2) ; GREEK SMALL LETTER FINAL SIGMA
  (#xF3 #x03C3) ; GREEK SMALL LETTER SIGMA
  (#xF4 #x03C4) ; GREEK SMALL LETTER TAU
  (#xF5 #x03C5) ; GREEK SMALL LETTER UPSILON
  (#xF6 #x03C6) ; GREEK SMALL LETTER PHI
  (#xF7 #x03C7) ; GREEK SMALL LETTER CHI