enc-dos.lisp

开源跨平台Lisp编译器

           (type array-range pos))
  (get-latin-bytes #'code->cp861-mapper :cp861 string pos))

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

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

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

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

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

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

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

(define-unibyte-mapper cp862->code-mapper code->cp862-mapper
  (#x80 #x05D0) ; HEBREW LETTER ALEF
  (#x81 #x05D1) ; HEBREW LETTER BET
  (#x82 #x05D2) ; HEBREW LETTER GIMEL
  (#x83 #x05D3) ; HEBREW LETTER DALET
  (#x84 #x05D4) ; HEBREW LETTER HE
  (#x85 #x05D5) ; HEBREW LETTER VAV
  (#x86 #x05D6) ; HEBREW LETTER ZAYIN
  (#x87 #x05D7) ; HEBREW LETTER HET
  (#x88 #x05D8) ; HEBREW LETTER TET
  (#x89 #x05D9) ; HEBREW LETTER YOD
  (#x8A #x05DA) ; HEBREW LETTER FINAL KAF
  (#x8B #x05DB) ; HEBREW LETTER KAF
  (#x8C #x05DC) ; HEBREW LETTER LAMED
  (#x8D #x05DD) ; HEBREW LETTER FINAL MEM
  (#x8E #x05DE) ; HEBREW LETTER MEM
  (#x8F #x05DF) ; HEBREW LETTER FINAL NUN
  (#x90 #x05E0) ; HEBREW LETTER NUN
  (#x91 #x05E1) ; HEBREW LETTER SAMEKH
  (#x92 #x05E2) ; HEBREW LETTER AYIN
  (#x93 #x05E3) ; HEBREW LETTER FINAL PE
  (#x94 #x05E4) ; HEBREW LETTER PE
  (#x95 #x05E5) ; HEBREW LETTER FINAL TSADI
  (#x96 #x05E6) ; HEBREW LETTER TSADI
  (#x97 #x05E7) ; HEBREW LETTER QOF
  (#x98 #x05E8) ; HEBREW LETTER RESH
  (#x99 #x05E9) ; HEBREW LETTER SHIN
  (#x9A #x05EA) ; HEBREW LETTER TAV
  (#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 (GERMAN)
  (#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-cp862-bytes))
(defun get-cp862-bytes (string pos)
  (declare (optimize speed (safety 0))
           (type simple-string string)
           (type array-range pos))
  (get-latin-bytes #'code->cp862-mapper :cp862 string pos))

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

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

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

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

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

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

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

(define-unibyte-mapper cp863->code-mapper code->cp863-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 #x00C2) ; LATIN CAPITAL LETTER A WITH CIRCUMFLEX
  (#x85 #x00E0) ; LATIN SMALL LETTER A WITH GRAVE
  (#x86 #x00B6) ; PILCROW SIGN
  (#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 #x2017) ; DOUBLE LOW LINE
  (#x8E #x00C0) ; LATIN CAPITAL LETTER A WITH GRAVE
  (#x8F #x00A7) ; SECTION SIGN
  (#x90 #x00C9) ; LATIN CAPITAL LETTER E WITH ACUTE
  (#x91 #x00C8) ; LATIN CAPITAL LETTER E WITH GRAVE
  (#x92 #x00CA) ; LATIN CAPITAL LETTER E WITH CIRCUMFLEX
  (#x93 #x00F4) ; LATIN SMALL LETTER O WITH CIRCUMFLEX
  (#x94 #x00CB) ; LATIN CAPITAL LETTER E WITH DIAERESIS
  (#x95 #x00CF) ; LATIN CAPITAL LETTER I WITH DIAERESIS
  (#x96 #x00FB) ; LATIN SMALL LETTER U WITH CIRCUMFLEX
  (#x97 #x00F9) ; LATIN SMALL LETTER U WITH GRAVE
  (#x98 #x00A4) ; CURRENCY SIGN
  (#x99 #x00D4) ; LATIN CAPITAL LETTER O WITH CIRCUMFLEX
  (#x9A #x00DC) ; LATIN CAPITAL LETTER U WITH DIAERESIS
  (#x9B #x00A2) ; CENT SIGN
  (#x9C #x00A3) ; POUND SIGN
  (#x9D #x00D9) ; LATIN CAPITAL LETTER U WITH GRAVE
  (#x9E #x00DB) ; LATIN CAPITAL LETTER U WITH CIRCUMFLEX
  (#x9F #x0192) ; LATIN SMALL LETTER F WITH HOOK
  (#xA0 #x00A6) ; BROKEN BAR
  (#xA1 #x00B4) ; ACUTE ACCENT
  (#xA2 #x00F3) ; LATIN SMALL LETTER O WITH ACUTE
  (#xA3 #x00FA) ; LATIN SMALL LETTER U WITH ACUTE
  (#xA4 #x00A8) ; DIAERESIS
  (#xA5 #x00B8) ; CEDILLA
  (#xA6 #x00B3) ; SUPERSCRIPT THREE
  (#xA7 #x00AF) ; MACRON
  (#xA8 #x00CE) ; LATIN CAPITAL LETTER I WITH CIRCUMFLEX
  (#xA9 #x2310) ; REVERSED NOT SIGN
  (#xAA #x00AC) ; NOT SIGN
  (#xAB #x00BD) ; VULGAR FRACTION ONE HALF
  (#xAC #x00BC) ; VULGAR FRACTION ONE QUARTER
  (#xAD #x00BE) ; VULGAR FRACTION THREE QUARTERS
  (#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 DRA