enc-dos.lisp

开源跨平台Lisp编译器

  (#xC1 #x2534) ; BOX DRAWINGS LIGHT UP AND HORIZONTAL
  (#xC2 #x252C) ; BOX DRAWINGS LIGHT DOWN AND HORIZONTAL
  (#xC3 #x251C) ; BOX DRAWINGS LIGHT VERTICAL AND RIGHT
  (#xC4 #x2500) ; BOX DRAWINGS LIGHT HORIZONTAL
  (#xC5 #x253C) ; BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL
  (#xC6 #x043A) ; CYRILLIC SMALL LETTER KA
  (#xC7 #x041A) ; CYRILLIC CAPITAL LETTER KA
  (#xC8 #x255A) ; BOX DRAWINGS DOUBLE UP AND RIGHT
  (#xC9 #x2554) ; BOX DRAWINGS DOUBLE DOWN AND RIGHT
  (#xCA #x2569) ; BOX DRAWINGS DOUBLE UP AND HORIZONTAL
  (#xCB #x2566) ; BOX DRAWINGS DOUBLE DOWN AND HORIZONTAL
  (#xCC #x2560) ; BOX DRAWINGS DOUBLE VERTICAL AND RIGHT
  (#xCD #x2550) ; BOX DRAWINGS DOUBLE HORIZONTAL
  (#xCE #x256C) ; BOX DRAWINGS DOUBLE VERTICAL AND HORIZONTAL
  (#xCF #x00A4) ; CURRENCY SIGN
  (#xD0 #x043B) ; CYRILLIC SMALL LETTER EL
  (#xD1 #x041B) ; CYRILLIC CAPITAL LETTER EL
  (#xD2 #x043C) ; CYRILLIC SMALL LETTER EM
  (#xD3 #x041C) ; CYRILLIC CAPITAL LETTER EM
  (#xD4 #x043D) ; CYRILLIC SMALL LETTER EN
  (#xD5 #x041D) ; CYRILLIC CAPITAL LETTER EN
  (#xD6 #x043E) ; CYRILLIC SMALL LETTER O
  (#xD7 #x041E) ; CYRILLIC CAPITAL LETTER O
  (#xD8 #x043F) ; CYRILLIC SMALL LETTER PE
  (#xD9 #x2518) ; BOX DRAWINGS LIGHT UP AND LEFT
  (#xDA #x250C) ; BOX DRAWINGS LIGHT DOWN AND RIGHT
  (#xDB #x2588) ; FULL BLOCK
  (#xDC #x2584) ; LOWER HALF BLOCK
  (#xDD #x041F) ; CYRILLIC CAPITAL LETTER PE
  (#xDE #x044F) ; CYRILLIC SMALL LETTER YA
  (#xDF #x2580) ; UPPER HALF BLOCK
  (#xE0 #x042F) ; CYRILLIC CAPITAL LETTER YA
  (#xE1 #x0440) ; CYRILLIC SMALL LETTER ER
  (#xE2 #x0420) ; CYRILLIC CAPITAL LETTER ER
  (#xE3 #x0441) ; CYRILLIC SMALL LETTER ES
  (#xE4 #x0421) ; CYRILLIC CAPITAL LETTER ES
  (#xE5 #x0442) ; CYRILLIC SMALL LETTER TE
  (#xE6 #x0422) ; CYRILLIC CAPITAL LETTER TE
  (#xE7 #x0443) ; CYRILLIC SMALL LETTER U
  (#xE8 #x0423) ; CYRILLIC CAPITAL LETTER U
  (#xE9 #x0436) ; CYRILLIC SMALL LETTER ZHE
  (#xEA #x0416) ; CYRILLIC CAPITAL LETTER ZHE
  (#xEB #x0432) ; CYRILLIC SMALL LETTER VE
  (#xEC #x0412) ; CYRILLIC CAPITAL LETTER VE
  (#xED #x044C) ; CYRILLIC SMALL LETTER SOFT SIGN
  (#xEE #x042C) ; CYRILLIC CAPITAL LETTER SOFT SIGN
  (#xEF #x2116) ; NUMERO SIGN
  (#xF0 #x00AD) ; SOFT HYPHEN
  (#xF1 #x044B) ; CYRILLIC SMALL LETTER YERU
  (#xF2 #x042B) ; CYRILLIC CAPITAL LETTER YERU
  (#xF3 #x0437) ; CYRILLIC SMALL LETTER ZE
  (#xF4 #x0417) ; CYRILLIC CAPITAL LETTER ZE
  (#xF5 #x0448) ; CYRILLIC SMALL LETTER SHA
  (#xF6 #x0428) ; CYRILLIC CAPITAL LETTER SHA
  (#xF7 #x044D) ; CYRILLIC SMALL LETTER E
  (#xF8 #x042D) ; CYRILLIC CAPITAL LETTER E
  (#xF9 #x0449) ; CYRILLIC SMALL LETTER SHCHA
  (#xFA #x0429) ; CYRILLIC CAPITAL LETTER SHCHA
  (#xFB #x0447) ; CYRILLIC SMALL LETTER CHE
  (#xFC #x0427) ; CYRILLIC CAPITAL LETTER CHE
  (#xFD #x00A7) ; SECTION SIGN
  (#xFE #x25A0) ; BLACK SQUARE
  (#xFF #x00A0) ; NO-BREAK SPACE
)

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

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

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

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

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

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

(add-external-format-funs '(:cp855 :|cp855|)
                          '(cp855->string-aref string->cp855))

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

(define-unibyte-mapper cp857->code-mapper code->cp857-mapper
  (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
  (#x81 #x00FC) ; LATIN SMALL LETTER U WITH DIAERESIS
  (#x82 #x00E9) ; LATIN SMALL LETTER E WITH ACUTE
  (#x83 #x00E2) ; LATIN SMALL LETTER A WITH CIRCUMFLEX
  (#x84 #x00E4) ; LATIN SMALL LETTER A WITH DIAERESIS
  (#x85 #x00E0) ; LATIN SMALL LETTER A WITH GRAVE
  (#x86 #x00E5) ; LATIN SMALL LETTER A WITH RING ABOVE
  (#x87 #x00E7) ; LATIN SMALL LETTER C WITH CEDILLA
  (#x88 #x00EA) ; LATIN SMALL LETTER E WITH CIRCUMFLEX
  (#x89 #x00EB) ; LATIN SMALL LETTER E WITH DIAERESIS
  (#x8A #x00E8) ; LATIN SMALL LETTER E WITH GRAVE
  (#x8B #x00EF) ; LATIN SMALL LETTER I WITH DIAERESIS
  (#x8C #x00EE) ; LATIN SMALL LETTER I WITH CIRCUMFLEX
  (#x8D #x0131) ; LATIN SMALL LETTER DOTLESS I
  (#x8E #x00C4) ; LATIN CAPITAL LETTER A WITH DIAERESIS
  (#x8F #x00C5) ; LATIN CAPITAL LETTER A WITH RING ABOVE
  (#x90 #x00C9) ; LATIN CAPITAL LETTER E WITH ACUTE
  (#x91 #x00E6) ; LATIN SMALL LIGATURE AE
  (#x92 #x00C6) ; LATIN CAPITAL LIGATURE AE
  (#x93 #x00F4) ; LATIN SMALL LETTER O WITH CIRCUMFLEX
  (#x94 #x00F6) ; LATIN SMALL LETTER O WITH DIAERESIS
  (#x95 #x00F2) ; LATIN SMALL LETTER O WITH GRAVE
  (#x96 #x00FB) ; LATIN SMALL LETTER U WITH CIRCUMFLEX
  (#x97 #x00F9) ; LATIN SMALL LETTER U WITH GRAVE
  (#x98 #x0130) ; LATIN CAPITAL LETTER I WITH DOT ABOVE
  (#x99 #x00D6) ; LATIN CAPITAL LETTER O WITH DIAERESIS
  (#x9A #x00DC) ; LATIN CAPITAL LETTER U WITH DIAERESIS
  (#x9B #x00F8) ; LATIN SMALL LETTER O WITH STROKE
  (#x9C #x00A3) ; POUND SIGN
  (#x9D #x00D8) ; LATIN CAPITAL LETTER O WITH STROKE
  (#x9E #x015E) ; LATIN CAPITAL LETTER S WITH CEDILLA
  (#x9F #x015F) ; LATIN SMALL LETTER S WITH CEDILLA
  (#xA0 #x00E1) ; LATIN SMALL LETTER A WITH ACUTE
  (#xA1 #x00ED) ; LATIN SMALL LETTER I WITH ACUTE
  (#xA2 #x00F3) ; LATIN SMALL LETTER O WITH ACUTE
  (#xA3 #x00FA) ; LATIN SMALL LETTER U WITH ACUTE
  (#xA4 #x00F1) ; LATIN SMALL LETTER N WITH TILDE
  (#xA5 #x00D1) ; LATIN CAPITAL LETTER N WITH TILDE
  (#xA6 #x011E) ; LATIN CAPITAL LETTER G WITH BREVE
  (#xA7 #x011F) ; LATIN SMALL LETTER G WITH BREVE
  (#xA8 #x00BF) ; INVERTED QUESTION MARK
  (#xA9 #x00AE) ; REGISTERED SIGN
  (#xAA #x00AC) ; NOT SIGN
  (#xAB #x00BD) ; VULGAR FRACTION ONE HALF
  (#xAC #x00BC) ; VULGAR FRACTION ONE QUARTER
  (#xAD #x00A1) ; INVERTED EXCLAMATION MARK
  (#xAE #x00AB) ; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
  (#xAF #x00BB) ; RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
  (#xB0 #x2591) ; LIGHT SHADE
  (#xB1 #x2592) ; MEDIUM SHADE
  (#xB2 #x2593) ; DARK SHADE
  (#xB3 #x2502) ; BOX DRAWINGS LIGHT VERTICAL
  (#xB4 #x2524) ; BOX DRAWINGS LIGHT VERTICAL AND LEFT
  (#xB5 #x00C1) ; LATIN CAPITAL LETTER A WITH ACUTE
  (#xB6 #x00C2) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX
  (#xB7 #x00C0) ; LATIN CAPITAL LETTER A WITH GRAVE
  (#xB8 #x00A9) ; COPYRIGHT SIGN
  (#xB9 #x2563) ; BOX DRAWINGS DOUBLE VERTICAL AND LEFT
  (#xBA #x2551) ; BOX DRAWINGS DOUBLE VERTICAL
  (#xBB #x2557) ; BOX DRAWINGS DOUBLE DOWN AND LEFT
  (#xBC #x255D) ; BOX DRAWINGS DOUBLE UP AND LEFT
  (#xBD #x00A2) ; CENT SIGN
  (#xBE #x00A5) ; YEN SIGN
  (#xBF #x2510) ; BOX DRAWINGS LIGHT DOWN AND LEFT
  (#xC0 #x2514) ; BOX DRAWINGS LIGHT UP AND RIGHT
  (#xC1 #x2534) ; BOX DRAWINGS LIGHT UP AND HORIZONTAL
  (#xC2 #x252C) ; BOX DRAWINGS LIGHT DOWN AND HORIZONTAL
  (#xC3 #x251C) ; BOX DRAWINGS LIGHT VERTICAL AND RIGHT
  (#xC4 #x2500) ; BOX DRAWINGS LIGHT HORIZONTAL
  (#xC5 #x253C) ; BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL
  (#xC6 #x00E3) ; LATIN SMALL LETTER A WITH TILDE
  (#xC7 #x00C3) ; LATIN CAPITAL LETTER A WITH TILDE
  (#xC8 #x255A) ; BOX DRAWINGS DOUBLE UP AND RIGHT
  (#xC9 #x2554) ; BOX DRAWINGS DOUBLE DOWN AND RIGHT
  (#xCA #x2569) ; BOX DRAWINGS DOUBLE UP AND HORIZONTAL
  (#xCB #x2566) ; BOX DRAWINGS DOUBLE DOWN AND HORIZONTAL
  (#xCC #x2560) ; BOX DRAWINGS DOUBLE VERTICAL AND RIGHT
  (#xCD #x2550) ; BOX DRAWINGS DOUBLE HORIZONTAL
  (#xCE #x256C) ; BOX DRAWINGS DOUBLE VERTICAL AND HORIZONTAL
  (#xCF #x00A4) ; CURRENCY SIGN
  (#xD0 #x00BA) ; MASCULINE ORDINAL INDICATOR
  (#xD1 #x00AA) ; FEMININE ORDINAL INDICATOR
  (#xD2 #x00CA) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX
  (#xD3 #x00CB) ; LATIN CAPITAL LETTER E WITH DIAERESIS
  (#xD4 #x00C8) ; LATIN CAPITAL LETTER E WITH GRAVE
  (#xD5 nil)
  (#xD6 #x00CD) ; LATIN CAPITAL LETTER I WITH ACUTE
  (#xD7 #x00CE) ; LATIN CAPITAL LETTER I WITH CIRCUMFLEX
  (#xD8 #x00CF) ; LATIN CAPITAL LETTER I WITH DIAERESIS
  (#xD9 #x2518) ; BOX DRAWINGS LIGHT UP AND LEFT
  (#xDA #x250C) ; BOX DRAWINGS LIGHT DOWN AND RIGHT
  (#xDB #x2588) ; FULL BLOCK
  (#xDC #x2584) ; LOWER HALF BLOCK
  (#xDD #x00A6) ; BROKEN BAR
  (#xDE #x00CC) ; LATIN CAPITAL LETTER I WITH GRAVE
  (#xDF #x2580) ; UPPER HALF BLOCK
  (#xE0 #x00D3) ; LATIN CAPITAL LETTER O WITH ACUTE
  (#xE1 #x00DF) ; LATIN SMALL LETTER SHARP S
  (#xE2 #x00D4) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX
  (#xE3 #x00D2) ; LATIN CAPITAL LETTER O WITH GRAVE
  (#xE4 #x00F5) ; LATIN SMALL LETTER O WITH TILDE
  (#xE5 #x00D5) ; LATIN CAPITAL LETTER O WITH TILDE
  (#xE6 #x00B5) ; MICRO SIGN
  (#xE7 nil)
  (#xE8 #x00D7) ; MULTIPLICATION SIGN
  (#xE9 #x00DA) ; LATIN CAPITAL LETTER U WITH ACUTE
  (#xEA #x00DB) ; LATIN CAPITAL LETTER U WITH CIRCUMFLEX
  (#xEB #x00D9) ; LATIN CAPITAL LETTER U WITH GRAVE
  (#xED #x00FF) ; LATIN SMALL LETTER Y WITH DIAERESIS
  (#xEE #x00AF) ; MACRON
  (#xEF #x00B4) ; ACUTE ACCENT
  (#xF0 #x00AD) ; SOFT HYPHEN
  (#xF1 #x00B1) ; PLUS-MINUS SIGN
  (#xF2 nil)
  (#xF3 #x00BE) ; VULGAR FRACTION THREE QUARTERS
  (#xF4 #x00B6) ; PILCROW SIGN
  (#xF5 #x00A7) ; SECTION SIGN
  (#xF6 #x00F7) ; DIVISION SIGN
  (#xF7 #x00B8) ; CEDILLA
  (#xF8 #x00B0) ; DEGREE SIGN
  (#xF9 #x00A8) ; DIAERESIS
  (#xFA #x00B7) ; MIDDLE DOT
  (#xFB #x00B9) ; SUPERSCRIPT ONE
  (#xFC #x00B3) ; SUPERSCRIPT THREE
  (#xFD #x00B2) ; SUPERSCRIPT TWO
  (#xFE #x25A0) ; BLACK SQUARE
  (#xFF #x00A0) ; NO-BREAK SPACE
)

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

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

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

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

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

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

(add-external-format-funs '(:cp857 :|cp857|)
                          '(cp857->string-aref string->cp857))

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

(define-unibyte-mapper cp860->code-mapper code->cp860-mapper
  (#x80 #x00C7) ; LATIN CAPITAL LETTER C WITH CEDILLA
  (#x81 #x00FC) ; LATIN SMALL LETTER U WITH DIAERESIS
  (#x82 #x00E9) ; LATIN SMALL LETTER E WITH ACUTE
  (#x83 #x00E2) ; LATIN SMALL LETTER A WITH CIRCUMFLEX
  (#x84 #x00E3) ; LATIN SMALL LETTER A WITH TILDE
  (#x85 #x00E0) ; LATIN SMALL LETTER A WITH GRAVE
  (#x86 #x00C1) ; LATIN CAPITAL LETTER A WITH ACUTE
  (#x87 #x00E7) ; LATIN SMALL LETTER C WITH CEDILLA
  (#x88 #x00EA) ; LATIN SMALL LETTER E WITH CIRCUMFLEX
  (#x89 #x00CA) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX
  (#x8A #x00E8) ; LATIN SMALL LETTER E WITH GRAVE
  (#x8B #x00CD) ; LATIN CAPITAL LETTER I WITH ACUTE
  (#x8C #x00D4) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX