enc-win.lisp

开源跨平台Lisp编译器

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

(define-unibyte-mapper cp1256->code-mapper code->cp1256-mapper
  (#x80 #x20AC) ; EURO SIGN
  (#x81 #x067E) ; ARABIC LETTER PEH
  (#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 nil)
  (#x8B #x2039) ; SINGLE LEFT-POINTING ANGLE QUOTATION MARK
  (#x8C #x0152) ; LATIN CAPITAL LIGATURE OE
  (#x8D #x0686) ; ARABIC LETTER TCHEH
  (#x8E #x0698) ; ARABIC LETTER JEH
  (#x8F nil)
  (#x90 #x06AF) ; ARABIC LETTER GAF
  (#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 nil)
  (#x9B #x203A) ; SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
  (#x9C #x0153) ; LATIN SMALL LIGATURE OE
  (#x9D #x200C) ; ZERO WIDTH NON-JOINER
  (#x9E #x200D) ; ZERO WIDTH JOINER
  (#x9F nil)
  (#xA1 #x060C) ; ARABIC COMMA
  (#xAA nil)
  (#xBA #x061B) ; ARABIC SEMICOLON
  (#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
  (#xD8 #x0637) ; ARABIC LETTER TAH
  (#xD9 #x0638) ; ARABIC LETTER ZAH
  (#xDA #x0639) ; ARABIC LETTER AIN
  (#xDB #x063A) ; ARABIC LETTER GHAIN
  (#xDC #x0640) ; ARABIC TATWEEL
  (#xDD #x0641) ; ARABIC LETTER FEH
  (#xDE #x0642) ; ARABIC LETTER QAF
  (#xDF #x0643) ; ARABIC LETTER KAF
  (#xE1 #x0644) ; ARABIC LETTER LAM
  (#xE3 #x0645) ; ARABIC LETTER MEEM
  (#xE4 #x0646) ; ARABIC LETTER NOON
  (#xE5 #x0647) ; ARABIC LETTER HEH
  (#xE6 #x0648) ; ARABIC LETTER WAW
  (#xEC #x0649) ; ARABIC LETTER ALEF MAKSURA
  (#xED #x064A) ; ARABIC LETTER YEH
  (#xF0 #x064B) ; ARABIC FATHATAN
  (#xF1 #x064C) ; ARABIC DAMMATAN
  (#xF2 #x064D) ; ARABIC KASRATAN
  (#xF3 #x064E) ; ARABIC FATHA
  (#xF5 #x064F) ; ARABIC DAMMA
  (#xF6 #x0650) ; ARABIC KASRA
  (#xF8 #x0651) ; ARABIC SHADDA
  (#xFA #x0652) ; ARABIC SUKUN
  (#xFD #x200E) ; LEFT-TO-RIGHT MARK
  (#xFE #x200F) ; RIGHT-TO-LEFT MARK
  (#xFF nil)
)

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

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

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

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

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

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

(add-external-format-funs '(:cp1256 :|cp1256| :windows-1256 :|windows-1256|)
                          '(cp1256->string-aref string->cp1256))

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

(define-unibyte-mapper cp1257->code-mapper code->cp1257-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 nil)
  (#x8B #x2039) ; SINGLE LEFT-POINTING ANGLE QUOTATION MARK
  (#x8C nil)
  (#x8D #x00A8) ; DIAERESIS
  (#x8E #x02C7) ; CARON
  (#x8F #x00B8) ; CEDILLA
  (#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 nil)
  (#x9B #x203A) ; SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
  (#x9C nil)
  (#x9D #x00AF) ; MACRON
  (#x9E #x02DB) ; OGONEK
  (#x9F nil)
  (#xA1 nil)
  (#xA5 nil)
  (#xA8 #x00D8) ; LATIN CAPITAL LETTER O WITH STROKE
  (#xAA #x0156) ; LATIN CAPITAL LETTER R WITH CEDILLA
  (#xAF #x00C6) ; LATIN CAPITAL LETTER AE
  (#xB8 #x00F8) ; LATIN SMALL LETTER O WITH STROKE
  (#xBA #x0157) ; LATIN SMALL LETTER R WITH CEDILLA
  (#xBF #x00E6) ; LATIN SMALL LETTER AE
  (#xC0 #x0104) ; LATIN CAPITAL LETTER A WITH OGONEK
  (#xC1 #x012E) ; LATIN CAPITAL LETTER I WITH OGONEK
  (#xC2 #x0100) ; LATIN CAPITAL LETTER A WITH MACRON
  (#xC3 #x0106) ; LATIN CAPITAL LETTER C WITH ACUTE
  (#xC6 #x0118) ; LATIN CAPITAL LETTER E WITH OGONEK
  (#xC7 #x0112) ; LATIN CAPITAL LETTER E WITH MACRON
  (#xC8 #x010C) ; LATIN CAPITAL LETTER C WITH CARON
  (#xCA #x0179) ; LATIN CAPITAL LETTER Z WITH ACUTE
  (#xCB #x0116) ; LATIN CAPITAL LETTER E WITH DOT ABOVE
  (#xCC #x0122) ; LATIN CAPITAL LETTER G WITH CEDILLA
  (#xCD #x0136) ; LATIN CAPITAL LETTER K WITH CEDILLA
  (#xCE #x012A) ; LATIN CAPITAL LETTER I WITH MACRON
  (#xCF #x013B) ; LATIN CAPITAL LETTER L WITH CEDILLA
  (#xD0 #x0160) ; LATIN CAPITAL LETTER S WITH CARON
  (#xD1 #x0143) ; LATIN CAPITAL LETTER N WITH ACUTE
  (#xD2 #x0145) ; LATIN CAPITAL LETTER N WITH CEDILLA
  (#xD4 #x014C) ; LATIN CAPITAL LETTER O WITH MACRON
  (#xD8 #x0172) ; LATIN CAPITAL LETTER U WITH OGONEK
  (#xD9 #x0141) ; LATIN CAPITAL LETTER L WITH STROKE
  (#xDA #x015A) ; LATIN CAPITAL LETTER S WITH ACUTE
  (#xDB #x016A) ; LATIN CAPITAL LETTER U WITH MACRON
  (#xDD #x017B) ; LATIN CAPITAL LETTER Z WITH DOT ABOVE
  (#xDE #x017D) ; LATIN CAPITAL LETTER Z WITH CARON
  (#xE0 #x0105) ; LATIN SMALL LETTER A WITH OGONEK
  (#xE1 #x012F) ; LATIN SMALL LETTER I WITH OGONEK
  (#xE2 #x0101) ; LATIN SMALL LETTER A WITH MACRON
  (#xE3 #x0107) ; LATIN SMALL LETTER C WITH ACUTE
  (#xE6 #x0119) ; LATIN SMALL LETTER E WITH OGONEK
  (#xE7 #x0113) ; LATIN SMALL LETTER E WITH MACRON
  (#xE8 #x010D) ; LATIN SMALL LETTER C WITH CARON
  (#xEA #x017A) ; LATIN SMALL LETTER Z WITH ACUTE
  (#xEB #x0117) ; LATIN SMALL LETTER E WITH DOT ABOVE
  (#xEC #x0123) ; LATIN SMALL LETTER G WITH CEDILLA
  (#xED #x0137) ; LATIN SMALL LETTER K WITH CEDILLA
  (#xEE #x012B) ; LATIN SMALL LETTER I WITH MACRON
  (#xEF #x013C) ; LATIN SMALL LETTER L WITH CEDILLA
  (#xF0 #x0161) ; LATIN SMALL LETTER S WITH CARON
  (#xF1 #x0144) ; LATIN SMALL LETTER N WITH ACUTE
  (#xF2 #x0146) ; LATIN SMALL LETTER N WITH CEDILLA
  (#xF4 #x014D) ; LATIN SMALL LETTER O WITH MACRON
  (#xF8 #x0173) ; LATIN SMALL LETTER U WITH OGONEK
  (#xF9 #x0142) ; LATIN SMALL LETTER L WITH STROKE
  (#xFA #x015B) ; LATIN SMALL LETTER S WITH ACUTE
  (#xFB #x016B) ; LATIN SMALL LETTER U WITH MACRON
  (#xFD #x017C) ; LATIN SMALL LETTER Z WITH DOT ABOVE
  (#xFE #x017E) ; LATIN SMALL LETTER Z WITH CARON
  (#xFF #x02D9) ; DOT ABOVE
)

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

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

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

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

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

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

(add-external-format-funs '(:cp1257 :|cp1257| :windows-1257 :|windows-1257|)
                          '(cp1257->string-aref string->cp1257))

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

(define-unibyte-mapper cp1258->code-mapper code->cp1258-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 nil)
  (#x8B #x2039) ; SINGLE LEFT-POINTING ANGLE QUOTATION MARK
  (#x8C #x0152) ; LATIN CAPITAL LIGATURE OE
  (#x8D nil)
  (#x8E nil)
  (#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 nil)
  (#x9B #x203A) ; SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
  (#x9C #x0153) ; LATIN SMALL LIGATURE OE
  (#x9D nil)
  (#x9E nil)
  (#x9F #x0178) ; LATIN CAPITAL LETTER Y WITH DIAERESIS
  (#xC3 #x0102) ; LATIN CAPITAL LETTER A WITH BREVE
  (#xCC #x0300) ; COMBINING GRAVE ACCENT
  (#xD0 #x0110) ; LATIN CAPITAL LETTER D WITH STROKE
  (#xD2 #x0309) ; COMBINING HOOK ABOVE
  (#xD5 #x01A0) ; LATIN CAPITAL LETTER O WITH HORN
  (#xDD #x01AF) ; LATIN CAPITAL LETTER U WITH HORN
  (#xDE #x0303) ; COMBINING TILDE
  (#xE3 #x0103) ; LATIN SMALL LETTER A WITH BREVE
  (#xEC #x0301) ; COMBINING ACUTE ACCENT
  (#xF0 #x0111) ; LATIN SMALL LETTER D WITH STROKE
  (#xF2 #x0323) ; COMBINING DOT BELOW
  (#xF5 #x01A1) ; LATIN SMALL LETTER O WITH HORN
  (#xFD #x01B0) ; LATIN SMALL LETTER U WITH HORN
  (#xFE #x20AB) ; DONG SIGN
)

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

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

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

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

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

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

(add-external-format-funs '(:cp1258 :|cp1258| :windows-1258 :|windows-1258|)
                          '(cp1258->string-aref string->cp1258))

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