enc-dos.lisp

开源跨平台Lisp编译器

(in-package "SB!IMPL")

(define-unibyte-mapper cp437->code-mapper code->cp437-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 #x00EC) ; LATIN SMALL LETTER I WITH GRAVE
  (#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 #x00FF) ; LATIN SMALL LETTER Y WITH DIAERESIS
  (#x99 #x00D6) ; LATIN CAPITAL LETTER O WITH DIAERESIS
  (#x9A #x00DC) ; LATIN CAPITAL LETTER U WITH DIAERESIS
  (#x9B #x00A2) ; CENT SIGN
  (#x9C #x00A3) ; POUND SIGN
  (#x9D #x00A5) ; YEN SIGN
  (#x9E #x20A7) ; PESETA SIGN
  (#x9F #x0192) ; LATIN SMALL LETTER F WITH HOOK
  (#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 #x00AA) ; FEMININE ORDINAL INDICATOR
  (#xA7 #x00BA) ; MASCULINE ORDINAL INDICATOR
  (#xA8 #x00BF) ; INVERTED QUESTION MARK
  (#xA9 #x2310) ; REVERSED NOT 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 #x2561) ; BOX DRAWINGS VERTICAL SINGLE AND LEFT DOUBLE
  (#xB6 #x2562) ; BOX DRAWINGS VERTICAL DOUBLE AND LEFT SINGLE
  (#xB7 #x2556) ; BOX DRAWINGS DOWN DOUBLE AND LEFT SINGLE
  (#xB8 #x2555) ; BOX DRAWINGS DOWN SINGLE AND LEFT DOUBLE
  (#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 #x255C) ; BOX DRAWINGS UP DOUBLE AND LEFT SINGLE
  (#xBE #x255B) ; BOX DRAWINGS UP SINGLE AND LEFT DOUBLE
  (#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 #x255E) ; BOX DRAWINGS VERTICAL SINGLE AND RIGHT DOUBLE
  (#xC7 #x255F) ; BOX DRAWINGS VERTICAL DOUBLE AND RIGHT SINGLE
  (#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 #x2567) ; BOX DRAWINGS UP SINGLE AND HORIZONTAL DOUBLE
  (#xD0 #x2568) ; BOX DRAWINGS UP DOUBLE AND HORIZONTAL SINGLE
  (#xD1 #x2564) ; BOX DRAWINGS DOWN SINGLE AND HORIZONTAL DOUBLE
  (#xD2 #x2565) ; BOX DRAWINGS DOWN DOUBLE AND HORIZONTAL SINGLE
  (#xD3 #x2559) ; BOX DRAWINGS UP DOUBLE AND RIGHT SINGLE
  (#xD4 #x2558) ; BOX DRAWINGS UP SINGLE AND RIGHT DOUBLE
  (#xD5 #x2552) ; BOX DRAWINGS DOWN SINGLE AND RIGHT DOUBLE
  (#xD6 #x2553) ; BOX DRAWINGS DOWN DOUBLE AND RIGHT SINGLE
  (#xD7 #x256B) ; BOX DRAWINGS VERTICAL DOUBLE AND HORIZONTAL SINGLE
  (#xD8 #x256A) ; BOX DRAWINGS VERTICAL SINGLE AND HORIZONTAL DOUBLE
  (#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 #x258C) ; LEFT HALF BLOCK
  (#xDE #x2590) ; RIGHT HALF BLOCK
  (#xDF #x2580) ; UPPER HALF BLOCK
  (#xE0 #x03B1) ; GREEK SMALL LETTER ALPHA
  (#xE1 #x00DF) ; LATIN SMALL LETTER SHARP S
  (#xE2 #x0393) ; GREEK CAPITAL LETTER GAMMA
  (#xE3 #x03C0) ; GREEK SMALL LETTER PI
  (#xE4 #x03A3) ; GREEK CAPITAL LETTER SIGMA
  (#xE5 #x03C3) ; GREEK SMALL LETTER SIGMA
  (#xE6 #x00B5) ; MICRO SIGN
  (#xE7 #x03C4) ; GREEK SMALL LETTER TAU
  (#xE8 #x03A6) ; GREEK CAPITAL LETTER PHI
  (#xE9 #x0398) ; GREEK CAPITAL LETTER THETA
  (#xEA #x03A9) ; GREEK CAPITAL LETTER OMEGA
  (#xEB #x03B4) ; GREEK SMALL LETTER DELTA
  (#xEC #x221E) ; INFINITY
  (#xED #x03C6) ; GREEK SMALL LETTER PHI
  (#xEE #x03B5) ; GREEK SMALL LETTER EPSILON
  (#xEF #x2229) ; INTERSECTION
  (#xF0 #x2261) ; IDENTICAL TO
  (#xF1 #x00B1) ; PLUS-MINUS SIGN
  (#xF2 #x2265) ; GREATER-THAN OR EQUAL TO
  (#xF3 #x2264) ; LESS-THAN OR EQUAL TO
  (#xF4 #x2320) ; TOP HALF INTEGRAL
  (#xF5 #x2321) ; BOTTOM HALF INTEGRAL
  (#xF6 #x00F7) ; DIVISION SIGN
  (#xF7 #x2248) ; ALMOST EQUAL TO
  (#xF8 #x00B0) ; DEGREE SIGN
  (#xF9 #x2219) ; BULLET OPERATOR
  (#xFA #x00B7) ; MIDDLE DOT
  (#xFB #x221A) ; SQUARE ROOT
  (#xFC #x207F) ; SUPERSCRIPT LATIN SMALL LETTER N
  (#xFD #x00B2) ; SUPERSCRIPT TWO
  (#xFE #x25A0) ; BLACK SQUARE
  (#xFF #x00A0) ; NO-BREAK SPACE
)

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

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

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

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

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

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

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

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

(define-unibyte-mapper cp850->code-mapper code->cp850-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 #x00EC) ; LATIN SMALL LETTER I WITH GRAVE
  (#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 #x00FF) ; LATIN SMALL LETTER Y WITH DIAERESIS
  (#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 #x00D7) ; MULTIPLICATION SIGN
  (#x9F #x0192) ; LATIN SMALL LETTER F WITH HOOK
  (#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 #x00AA) ; FEMININE ORDINAL INDICATOR
  (#xA7 #x00BA) ; MASCULINE ORDINAL INDICATOR
  (#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 #x00F0) ; LATIN SMALL LETTER ETH
  (#xD1 #x00D0) ; LATIN CAPITAL LETTER ETH
  (#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 #x0131) ; LATIN SMALL LETTER DOTLESS I
  (#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 #x00FE) ; LATIN SMALL LETTER THORN
  (#xE8 #x00DE) ; LATIN CAPITAL LETTER THORN
  (#xE9 #x00DA) ; LATIN CAPITAL LETTER U WITH ACUTE
  (#xEA #x00DB) ; LATIN CAPITAL LETTER U WITH CIRCUMFLEX
  (#xEB #x00D9) ; LATIN CAPITAL LETTER U WITH GRAVE
  (#xEC #x00FD) ; LATIN SMALL LETTER Y WITH ACUTE
  (#xED #x00DD) ; LATIN CAPITAL LETTER Y WITH ACUTE
  (#xEE #x00AF) ; MACRON
  (#xEF #x00B4) ; ACUTE ACCENT
  (#xF0 #x00AD) ; SOFT HYPHEN
  (#xF1 #x00B1) ; PLUS-MINUS SIGN
  (#xF2 #x2017) ; DOUBLE LOW LINE
  (#xF3 #x00BE) ; VULGAR FRACTION THREE QUARTERS
  (#xF4 #x00B6) ; PILCROW SIGN
  (#xF5 #x00A7) ; SECTION SIGN