3rdparties/software/babel-20200218-git/src/enc-gbk.lisp (8297 bytes)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; enc-gbk.lisp --- GBK encodings. 4 ;;; 5 ;;; Copyright (C) 2011, Li Wenpeng <levin108@gmail.com> 6 ;;; 7 ;;; Permission is hereby granted, free of charge, to any person 8 ;;; obtaining a copy of this software and associated documentation 9 ;;; files (the "Software"), to deal in the Software without 10 ;;; restriction, including without limitation the rights to use, copy, 11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 12 ;;; of the Software, and to permit persons to whom the Software is 13 ;;; furnished to do so, subject to the following conditions: 14 ;;; 15 ;;; The above copyright notice and this permission notice shall be 16 ;;; included in all copies or substantial portions of the Software. 17 ;;; 18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 25 ;;; DEALINGS IN THE SOFTWARE. 26 27 (in-package #:babel-encodings) 28 29 ;; populated in gbk-map.lisp 30 (defvar *gbk-unicode-mapping*) 31 32 (defconstant +gbk2-offset+ 0) 33 (defconstant +gbk3-offset+ 6763) 34 (defconstant +gbk4-offset+ (+ 6763 6080)) 35 (defconstant +gbk1-offset+ 20902) 36 (defconstant +gbk5-offset+ (+ 20902 846)) 37 38 (define-character-encoding :gbk 39 "GBK is an extension of the GB2312 character set for simplified 40 Chinese characters, used in the People's Republic of China." 41 :max-units-per-char 4 42 :literal-char-code-limit #x80) 43 44 (define-condition invalid-gbk-byte (character-decoding-error) 45 () 46 (:documentation "Signalled when an invalid GBK byte is found.")) 47 48 (define-condition invalid-gbk-character (character-encoding-error) 49 () 50 (:documentation "Signalled when an invalid GBK character is found.")) 51 52 (define-octet-counter :gbk (getter type) 53 `(lambda (seq start end max) 54 (declare (type ,type seq) (fixnum start end max)) 55 (let ((noctets 0)) 56 (loop for i from start below end 57 for u1 of-type code-point = (,getter seq i) 58 do (cond ((< u1 #x80) (incf noctets)) 59 (t (incf noctets 2))) 60 (when (and (plusp max) (= noctets max)) 61 (return (values noctets i))) 62 finally (return (values noctets i)))))) 63 64 (define-code-point-counter :gbk (getter type) 65 `(lambda (seq start end max) 66 (declare (type ,type seq)) 67 (let (u1 (noctets 0)) 68 (loop with i = start 69 while (< i end) 70 do (setf u1 (,getter seq i)) 71 (cond 72 ((eq 0 (logand u1 #x80)) (incf i)) 73 (t (incf i 2))) 74 (incf noctets) 75 (when (and (plusp max) (= noctets max)) 76 (return (values noctets i))) 77 finally (return (values noctets i)))))) 78 79 (define-encoder :gbk (getter src-type setter dest-type) 80 `(lambda (src start end dest d-start) 81 (declare (type ,src-type src) 82 (type ,dest-type dest) 83 (fixnum start end d-start)) 84 (macrolet 85 ((do-encoding (index) 86 `(let ((u1 0) (u2 0)) 87 (cond 88 ((<= +gbk2-offset+ ,index (- +gbk3-offset+ 1)) ; gbk/2 89 (setf u1 (+ #xB0 (truncate (/ ,index 94)))) 90 (setf u2 (+ #xA1 (mod ,index 94)))) 91 ((<= +gbk3-offset+ ,index (- +gbk4-offset+ 1)) ; gbk/3 92 (setf index (- ,index +gbk3-offset+)) 93 (setf u1 (+ #x81 (truncate (/ ,index 190)))) 94 (setf u2 (+ #x40 (mod ,index 190))) 95 (if (>= u2 #x7F) (incf u2))) 96 ((<= +gbk4-offset+ ,index (- +gbk1-offset+ 1)) ; gbk/4 97 (setf index (- ,index +gbk4-offset+)) 98 (setf u1 (+ #xAA (truncate (/ ,index 96)))) 99 (setf u2 (+ #x40 (mod ,index 96))) 100 (if (>= u2 #x7F) (incf u2))) 101 ((<= +gbk1-offset+ ,index (- +gbk5-offset+ 1)) ; gbk/1 102 (setf index (- ,index +gbk1-offset+)) 103 (setf u1 (+ #xA1 (truncate (/ ,index 94)))) 104 (setf u2 (+ #xA1 (mod ,index 94)))) 105 ((<= +gbk5-offset+ ,index (length *gbk-unicode-mapping*)) ; gbk/5 106 (setf index (- ,index +gbk5-offset+)) 107 (setf u1 (+ #xA8 (truncate (/ ,index 96)))) 108 (setf u2 (+ #x40 (mod ,index 96))) 109 (if (>= u2 #x7F) (incf u2)))) 110 (values u1 u2)))) 111 (let ((c 0) index (noctets 0)) 112 (loop for i from start below end 113 for code of-type code-point = (,getter src i) 114 do (macrolet 115 ((handle-error (&optional (c 'character-encoding-error)) 116 `(encoding-error code :gbk src i +repl+ ',c))) 117 (setf c (code-char code)) 118 (cond 119 ((< code #x80) ; ascii 120 (,setter code dest noctets) 121 (incf noctets)) 122 (t ; gbk 123 (setf index 124 (position c *gbk-unicode-mapping*)) 125 126 (if (not index) 127 (handle-error invalid-gbk-character)) 128 (multiple-value-bind (uh ul) (do-encoding index) 129 (,setter uh dest noctets) 130 (,setter ul dest (+ 1 noctets)) 131 (incf noctets 2))))) 132 finally (return (the fixnum (- noctets d-start)))))))) 133 134 (define-decoder :gbk (getter src-type setter dest-type) 135 `(lambda (src start end dest d-start) 136 (declare (type ,src-type src) 137 (type ,dest-type dest)) 138 (let ((u1 0) (u2 0) (index 0) (tmp 0) (noctets 0)) 139 (loop with i = start 140 while (< i end) 141 do (macrolet 142 ((handle-error (&optional (c 'character-decoding-error)) 143 `(decoding-error #(u1 u2) :gbk src i +repl+ ',c))) 144 (setf u1 (,getter src i)) 145 (incf i) 146 (cond 147 ((eq 0 (logand u1 #x80)) 148 (,setter u1 dest noctets)) 149 (t 150 (setf u2 (,getter src i)) 151 (incf i) 152 (setf index 153 (block setter-block 154 (cond 155 ((and (<= #xB0 u1 #xF7) (<= #xA1 u2 #xFE)) 156 (+ +gbk2-offset+ (+ (* 94 (- u1 #xB0)) (- u2 #xA1)))) 157 158 ((and (<= #x81 u1 #xA0) (<= #x40 u2 #xFE)) 159 (cond ((> u2 #x7F) (setf tmp 1)) 160 (t (setf tmp 0))) 161 (+ +gbk3-offset+ (* 190 (- u1 #x81)) (- u2 #x40 tmp))) 162 163 ((and (<= #xAA u1 #xFE) (<= #x40 #xA0)) 164 (cond ((> u2 #x7F) (setf tmp 1)) 165 (t (setf tmp 0))) 166 (+ +gbk4-offset+ (* 96 (- u1 #xAA)) (- u2 #x40 tmp))) 167 168 ((and (<= #xA1 u1 #xA9) (<= #xA1 u2 #xFE)) 169 (+ +gbk1-offset+ (* 94 (- u1 #xA1)) (- u2 #xA1))) 170 171 ((and (<= #xA8 u1 #xA9) (<= #x40 #xA0)) 172 (cond ((> u2 #x7F) (setf tmp 1)) 173 (t (setf tmp 0))) 174 (+ +gbk5-offset+ (* 96 (- u1 #xA8)) (- u2 #x40 tmp))) 175 (t 176 (handle-error invalid-gbk-byte))))) 177 178 (when (>= index (length *gbk-unicode-mapping*)) 179 (handle-error invalid-gbk-byte)) 180 (,setter (char-code 181 (elt *gbk-unicode-mapping* index)) 182 dest noctets))) 183 (incf noctets)) 184 finally (return (the fixnum (- noctets d-start)))))))