enc-win.lisp

开源跨平台Lisp编译器

(in-package "SB!IMPL")

(define-unibyte-mapper cp1250->code-mapper code->cp1250-mapper
  (#x80 #x20AC) ; EURO SIGN
  (#x81 nil)
  (#x82 #x201A) ; SINGLE LOW-9 QUOTATION MARK
  (#x83 nil)
  (#x84 #x201E) ; DOUBLE LOW-9 QUOTATION MARK
  (#x85 #x2026) ; HORIZONTAL ELLIPSIS
  (#x86 #x2020) ; DAGGER
  (#x87 #x2021) ; DOUBLE DAGGER
  (#x88 nil)
  (#x89 #x2030) ; PER MILLE SIGN
  (#x8A #x0160) ; LATIN CAPITAL LETTER S WITH CARON
  (#x8B #x2039) ; SINGLE LEFT-POINTING ANGLE QUOTATION MARK
  (#x8C #x015A) ; LATIN CAPITAL LETTER S WITH ACUTE
  (#x8D #x0164) ; LATIN CAPITAL LETTER T WITH CARON
  (#x8E #x017D) ; LATIN CAPITAL LETTER Z WITH CARON
  (#x8F #x0179) ; LATIN CAPITAL LETTER Z WITH ACUTE
  (#x90 nil)
  (#x91 #x2018) ; LEFT SINGLE QUOTATION MARK
  (#x92 #x2019) ; RIGHT SINGLE QUOTATION MARK
  (#x93 #x201C) ; LEFT DOUBLE QUOTATION MARK
  (#x94 #x201D) ; RIGHT DOUBLE QUOTATION MARK
  (#x95 #x2022) ; BULLET
  (#x96 #x2013) ; EN DASH
  (#x97 #x2014) ; EM DASH
  (#x98 nil)
  (#x99 #x2122) ; TRADE MARK SIGN
  (#x9A #x0161) ; LATIN SMALL LETTER S WITH CARON
  (#x9B #x203A) ; SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
  (#x9C #x015B) ; LATIN SMALL LETTER S WITH ACUTE
  (#x9D #x0165) ; LATIN SMALL LETTER T WITH CARON
  (#x9E #x017E) ; LATIN SMALL LETTER Z WITH CARON
  (#x9F #x017A) ; LATIN SMALL LETTER Z WITH ACUTE
  (#xA1 #x02C7) ; CARON
  (#xA2 #x02D8) ; BREVE
  (#xA3 #x0141) ; LATIN CAPITAL LETTER L WITH STROKE
  (#xA5 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK
  (#xAA #x015E) ; LATIN CAPITAL LETTER S WITH CEDILLA
  (#xAF #x017B) ; LATIN CAPITAL LETTER Z WITH DOT ABOVE
  (#xB2 #x02DB) ; OGONEK
  (#xB3 #x0142) ; LATIN SMALL LETTER L WITH STROKE
  (#xB9 #x0105) ; LATIN SMALL LETTER A WITH OGONEK
  (#xBA #x015F) ; LATIN SMALL LETTER S WITH CEDILLA
  (#xBC #x013D) ; LATIN CAPITAL LETTER L WITH CARON
  (#xBD #x02DD) ; DOUBLE ACUTE ACCENT
  (#xBE #x013E) ; LATIN SMALL LETTER L 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-cp1250-bytes))
(defun get-cp1250-bytes (string pos)
  (declare (optimize speed (safety 0))
           (type simple-string string)
           (type array-range pos))
  (get-latin-bytes #'code->cp1250-mapper :cp1250 string pos))

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

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

(instantiate-octets-definition define-cp1250->string*)

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

(instantiate-octets-definition define-cp1250->string)

(add-external-format-funs '(:cp1250 :|cp1250| :windows-1250 :|windows-1250|)
                          '(cp1250->string-aref string->cp1250))

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

(define-unibyte-mapper cp1251->code-mapper code->cp1251-mapper
  (#x80 #x0402) ; CYRILLIC CAPITAL LETTER DJE
  (#x81 #x0403) ; CYRILLIC CAPITAL LETTER GJE
  (#x82 #x201A) ; SINGLE LOW-9 QUOTATION MARK
  (#x83 #x0453) ; CYRILLIC SMALL LETTER GJE
  (#x84 #x201E) ; DOUBLE LOW-9 QUOTATION MARK
  (#x85 #x2026) ; HORIZONTAL ELLIPSIS
  (#x86 #x2020) ; DAGGER
  (#x87 #x2021) ; DOUBLE DAGGER
  (#x88 nil)
  (#x89 #x2030) ; PER MILLE SIGN
  (#x8A #x0409) ; CYRILLIC CAPITAL LETTER LJE
  (#x8B #x2039) ; SINGLE LEFT-POINTING ANGLE QUOTATION MARK
  (#x8C #x040A) ; CYRILLIC CAPITAL LETTER NJE
  (#x8D #x040C) ; CYRILLIC CAPITAL LETTER KJE
  (#x8E #x040B) ; CYRILLIC CAPITAL LETTER TSHE
  (#x8F #x040F) ; CYRILLIC CAPITAL LETTER DZHE
  (#x90 #x0452) ; CYRILLIC SMALL LETTER DJE
  (#x91 #x2018) ; LEFT SINGLE QUOTATION MARK
  (#x92 #x2019) ; RIGHT SINGLE QUOTATION MARK
  (#x93 #x201C) ; LEFT DOUBLE QUOTATION MARK
  (#x94 #x201D) ; RIGHT DOUBLE QUOTATION MARK
  (#x95 #x2022) ; BULLET
  (#x96 #x2013) ; EN DASH
  (#x97 #x2014) ; EM DASH
  (#x98 nil)
  (#x99 #x2122) ; TRADE MARK SIGN
  (#x9A #x0459) ; CYRILLIC SMALL LETTER LJE
  (#x9B #x203A) ; SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
  (#x9C #x045A) ; CYRILLIC SMALL LETTER NJE
  (#x9D #x045C) ; CYRILLIC SMALL LETTER KJE
  (#x9E #x045B) ; CYRILLIC SMALL LETTER TSHE
  (#x9F #x045F) ; CYRILLIC SMALL LETTER DZHE
  (#xA1 #x040E) ; CYRILLIC CAPITAL LETTER SHORT U
  (#xA2 #x045E) ; CYRILLIC SMALL LETTER SHORT U
  (#xA3 #x0408) ; CYRILLIC CAPITAL LETTER JE
  (#xA5 #x0490) ; CYRILLIC CAPITAL LETTER GHE WITH UPTURN
  (#xA8 #x0401) ; CYRILLIC CAPITAL LETTER IO
  (#xAA #x0404) ; CYRILLIC CAPITAL LETTER UKRAINIAN IE
  (#xAF #x0407) ; CYRILLIC CAPITAL LETTER YI
  (#xB2 #x0406) ; CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I
  (#xB3 #x0456) ; CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I
  (#xB4 #x0491) ; CYRILLIC SMALL LETTER GHE WITH UPTURN
  (#xB8 #x0451) ; CYRILLIC SMALL LETTER IO
  (#xB9 #x2116) ; NUMERO SIGN
  (#xBA #x0454) ; CYRILLIC SMALL LETTER UKRAINIAN IE
  (#xBC #x0458) ; CYRILLIC SMALL LETTER JE
  (#xBD #x0405) ; CYRILLIC CAPITAL LETTER DZE
  (#xBE #x0455) ; CYRILLIC SMALL LETTER DZE
  (#xBF #x0457) ; CYRILLIC SMALL LETTER YI
  (#xC0 #x0410) ; CYRILLIC CAPITAL LETTER A
  (#xC1 #x0411) ; CYRILLIC CAPITAL LETTER BE
  (#xC2 #x0412) ; CYRILLIC CAPITAL LETTER VE
  (#xC3 #x0413) ; CYRILLIC CAPITAL LETTER GHE
  (#xC4 #x0414) ; CYRILLIC CAPITAL LETTER DE
  (#xC5 #x0415) ; CYRILLIC CAPITAL LETTER IE
  (#xC6 #x0416) ; CYRILLIC CAPITAL LETTER ZHE
  (#xC7 #x0417) ; CYRILLIC CAPITAL LETTER ZE
  (#xC8 #x0418) ; CYRILLIC CAPITAL LETTER I
  (#xC9 #x0419) ; CYRILLIC CAPITAL LETTER SHORT I
  (#xCA #x041A) ; CYRILLIC CAPITAL LETTER KA
  (#xCB #x041B) ; CYRILLIC CAPITAL LETTER EL
  (#xCC #x041C) ; CYRILLIC CAPITAL LETTER EM
  (#xCD #x041D) ; CYRILLIC CAPITAL LETTER EN
  (#xCE #x041E) ; CYRILLIC CAPITAL LETTER O
  (#xCF #x041F) ; CYRILLIC CAPITAL LETTER PE
  (#xD0 #x0420) ; CYRILLIC CAPITAL LETTER ER
  (#xD1 #x0421) ; CYRILLIC CAPITAL LETTER ES
  (#xD2 #x0422) ; CYRILLIC CAPITAL LETTER TE
  (#xD3 #x0423) ; CYRILLIC CAPITAL LETTER U
  (#xD4 #x0424) ; CYRILLIC CAPITAL LETTER EF
  (#xD5 #x0425) ; CYRILLIC CAPITAL LETTER HA
  (#xD6 #x0426) ; CYRILLIC CAPITAL LETTER TSE
  (#xD7 #x0427) ; CYRILLIC CAPITAL LETTER CHE
  (#xD8 #x0428) ; CYRILLIC CAPITAL LETTER SHA
  (#xD9 #x0429) ; CYRILLIC CAPITAL LETTER SHCHA
  (#xDA #x042A) ; CYRILLIC CAPITAL LETTER HARD SIGN
  (#xDB #x042B) ; CYRILLIC CAPITAL LETTER YERU
  (#xDC #x042C) ; CYRILLIC CAPITAL LETTER SOFT SIGN
  (#xDD #x042D) ; CYRILLIC CAPITAL LETTER E
  (#xDE #x042E) ; CYRILLIC CAPITAL LETTER YU
  (#xDF #x042F) ; CYRILLIC CAPITAL LETTER YA
  (#xE0 #x0430) ; CYRILLIC SMALL LETTER A
  (#xE1 #x0431) ; CYRILLIC SMALL LETTER BE
  (#xE2 #x0432) ; CYRILLIC SMALL LETTER VE
  (#xE3 #x0433) ; CYRILLIC SMALL LETTER GHE
  (#xE4 #x0434) ; CYRILLIC SMALL LETTER DE
  (#xE5 #x0435) ; CYRILLIC SMALL LETTER IE
  (#xE6 #x0436) ; CYRILLIC SMALL LETTER ZHE
  (#xE7 #x0437) ; CYRILLIC SMALL LETTER ZE
  (#xE8 #x0438) ; CYRILLIC SMALL LETTER I
  (#xE9 #x0439) ; CYRILLIC SMALL LETTER SHORT I
  (#xEA #x043A) ; CYRILLIC SMALL LETTER KA
  (#xEB #x043B) ; CYRILLIC SMALL LETTER EL
  (#xEC #x043C) ; CYRILLIC SMALL LETTER EM
  (#xED #x043D) ; CYRILLIC SMALL LETTER EN
  (#xEE #x043E) ; CYRILLIC SMALL LETTER O
  (#xEF #x043F) ; CYRILLIC SMALL LETTER PE
  (#xF0 #x0440) ; CYRILLIC SMALL LETTER ER
  (#xF1 #x0441) ; CYRILLIC SMALL LETTER ES
  (#xF2 #x0442) ; CYRILLIC SMALL LETTER TE
  (#xF3 #x0443) ; CYRILLIC SMALL LETTER U
  (#xF4 #x0444) ; CYRILLIC SMALL LETTER EF
  (#xF5 #x0445) ; CYRILLIC SMALL LETTER HA
  (#xF6 #x0446) ; CYRILLIC SMALL LETTER TSE
  (#xF7 #x0447) ; CYRILLIC SMALL LETTER CHE
  (#xF8 #x0448) ; CYRILLIC SMALL LETTER SHA
  (#xF9 #x0449) ; CYRILLIC SMALL LETTER SHCHA
  (#xFA #x044A) ; CYRILLIC SMALL LETTER HARD SIGN
  (#xFB #x044B) ; CYRILLIC SMALL LETTER YERU
  (#xFC #x044C) ; CYRILLIC SMALL LETTER SOFT SIGN
  (#xFD #x044D) ; CYRILLIC SMALL LETTER E
  (#xFE #x044E) ; CYRILLIC SMALL LETTER YU
  (#xFF #x044F) ; CYRILLIC SMALL LETTER YA
)

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

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

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

(instantiate-octets-definition define-cp1251->string*)

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

(instantiate-octets-definition define-cp1251->string)

(add-external-format-funs '(:cp1251 :|cp1251|  :windows-1251 :|windows-1251|)
                          '(cp1251->string-aref string->cp1251))

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

(define-unibyte-mapper cp1252->code-mapper code->cp1252-mapper
  (#x80 #x20AC) ; EURO SIGN
  (#x81 nil)
  (#x82 #x201A) ; SINGLE LOW-9 QUOTATION MARK
  (#x83 #x0192) ; LATIN SMALL LETTER F WITH HOOK
  (#x84 #x201E) ; DOUBLE LOW-9 QUOTATION MARK
  (#x85 #x2026) ; HORIZONTAL ELLIPSIS
  (#x86 #x2020) ; DAGGER
  (#x87 #x2021) ; DOUBLE DAGGER
  (#x88 #x02C6) ; MODIFIER LETTER CIRCUMFLEX ACCENT
  (#x89 #x2030) ; PER MILLE SIGN
  (#x8A #x0160) ; LATIN CAPITAL LETTER S WITH CARON
  (#x8B #x2039) ; SINGLE LEFT-POINTING ANGLE QUOTATION MARK
  (#x8C #x0152) ; LATIN CAPITAL LIGATURE OE
  (#x8D nil)
  (#x8E #x017D) ; LATIN CAPITAL LETTER Z WITH CARON
  (#x8F nil)
  (#x90 nil)
  (#x91 #x2018) ; LEFT SINGLE QUOTATION MARK
  (#x92 #x2019) ; RIGHT SINGLE QUOTATION MARK
  (#x93 #x201C) ; LEFT DOUBLE QUOTATION MARK
  (#x94 #x201D) ; RIGHT DOUBLE QUOTATION MARK
  (#x95 #x2022) ; BULLET
  (#x96 #x2013) ; EN DASH
  (#x97 #x2014) ; EM DASH
  (#x98 #x02DC) ; SMALL TILDE
  (#x99 #x2122) ; TRADE MARK SIGN
  (#x9A #x0161) ; LATIN SMALL LETTER S WITH CARON
  (#x9B #x203A) ; SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
  (#x9C #x0153) ; LATIN SMALL LIGATURE OE
  (#x9D nil)
  (#x9E #x017E) ; LATIN SMALL LETTER Z WITH CARON
  (#x9F #x0178) ; LATIN CAPITAL LETTER Y WITH DIAERESIS
)

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

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

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

(instantiate-octets-definition define-cp1252->string*)

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

(instantiate-octets-definition define-cp1252->string)

(add-external-format-funs '(:cp1252 :|cp1252| :windows-1252 :|windows-1252|)
                          '(cp1252->string-aref string->cp1252))

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

(define-unibyte-mapper cp1253->code-mapper code->cp1253-mapper
  (#x80 #x20AC) ; EURO SIGN
  (#x81 nil)
  (#x82 #x201A) ; SINGLE LOW-9 QUOTATION MARK