ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Tmux etc

Browse source
This commit is contained in:
Ian Keane 2020-02-18 14:21:14 -05:00
parent 276853ba84
commit 1cb167b597
361 changed files with 77302 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

43
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-ascii.lisp Normal file
View file

@ -0,0 +1,43 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-ascii.lisp --- Implementation of the ASCII character encoding.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :ascii
"A 7-bit, fixed-width character encoding in which all
character codes map to their Unicode equivalents."
:aliases '(:us-ascii)
:literal-char-code-limit 128)
(define-unibyte-encoder :ascii (code)
(if (>= code 128)
(handle-error)
code))
(define-unibyte-decoder :ascii (octet)
(if (>= octet 128)
(handle-error)
octet))

119
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-cp1251.lisp Normal file
View file

@ -0,0 +1,119 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-cp1251.lisp --- Implementation of the CP1251 character encoding.
;;;
;;; Copyright (C) 2009, Andrey Moskvitin
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :cp1251
"An 8-bit, fixed-width character Russian encoding from Windows."
:aliases '(:windows-1251)
:literal-char-code-limit #x80)
(define-constant +cp1251-to-unicode+
#(;; #x80
#x0402 #x0403 #x201a #x0453 #x201e #x2026 #x2020 #x2021
#x20ac #x2030 #x0409 #x2039 #x040a #x040c #x040b #x040f
;; #x90
#x0452 #x2018 #x2019 #x201c #x201d #x2022 #x2013 #x2014
#xfffd #x2122 #x0459 #x203a #x045a #x045c #x045b #x045f
;; #xa0
#x00a0 #x040e #x045e #x0408 #x00a4 #x0490 #x00a6 #x00a7
#x0401 #x00a9 #x0404 #x00ab #x00ac #x00ad #x00ae #x0407
;; #xb0
#x00b0 #x00b1 #x0406 #x0456 #x0491 #x00b5 #x00b6 #x00b7
#x0451 #x2116 #x0454 #x00bb #x0458 #x0405 #x0455 #x0457
;; #xc0
#x0410 #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417
#x0418 #x0419 #x041a #x041b #x041c #x041d #x041e #x041f
;; #xd0
#x0420 #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427
#x0428 #x0429 #x042a #x042b #x042c #x042d #x042e #x042f
;; #xe0
#x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437
#x0438 #x0439 #x043a #x043b #x043c #x043d #x043e #x043f
;; #xf0
#x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447
#x0448 #x0449 #x044a #x044b #x044c #x044d #x044e #x044f)
:test #'equalp)
(define-unibyte-decoder :cp1251 (octet)
(if (< octet #x80)
octet
(svref +cp1251-to-unicode+ (the ub8 (- octet #x80)))))
(define-constant +unicode-a0-bf-to-cp1251+
#(#xa0 #x00 #x00 #x00 #xa4 #x00 #xa6 #xa7 ; #xa0-#xa7
#x00 #xa9 #x00 #xab #xac #xad #xae #x00 ; #xa8-#xaf
#xb0 #xb1 #x00 #x00 #x00 #xb5 #xb6 #xb7 ; #xb0-#xb7
#x00 #x00 #x00 #xbb #x00 #x00 #x00 #x00) ; #xb8-#xbf
:test #'equalp)
(define-constant +unicode-0-97-to-cp1251+
#(#x00 #xa8 #x80 #x81 #xaa #xbd #xb2 #xaf ; #x00-#x07
#xa3 #x8a #x8c #x8e #x8d #x00 #xa1 #x8f ; #x08-#x0f
#xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x10-#x17
#xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x18-#x1f
#xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #x20-#x27
#xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #x28-#x2f
#xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x30-#x37
#xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x38-#x3f
#xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x40-#x47
#xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff ; #x48-#x4f
#x00 #xb8 #x90 #x83 #xba #xbe #xb3 #xbf ; #x50-#x57
#xbc #x9a #x9c #x9e #x9d #x00 #xa2 #x9f ; #x58-#x5f
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x60-#x67
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x68-#x6f
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x70-#x77
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x78-#x7f
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x80-#x87
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x88-#x8f
#xa5 #xb4 #x00 #x00 #x00 #x00 #x00 #x00) ; #x90-#x97
:test #'equalp)
(define-constant +unicode-10-3f-to-cp1251+
#(#x00 #x00 #x00 #x96 #x97 #x00 #x00 #x00 ; #x10-#x17
#x91 #x92 #x82 #x00 #x93 #x94 #x84 #x00 ; #x18-#x1f
#x86 #x87 #x95 #x00 #x00 #x00 #x85 #x00 ; #x20-#x27
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x28-#x2f
#x89 #x00 #x00 #x00 #x00 #x00 #x00 #x00 ; #x30-#x37
#x00 #x8b #x9b #x00 #x00 #x00 #x00 #x00) ; #x38-#x3f
:test #'equalp)
(define-unibyte-encoder :cp1251 (code)
(cond
((< code #x80) code)
((and (>= code #xa0) (< code #xc0))
(svref +unicode-a0-bf-to-cp1251+
(the ub8 (- code #xa0))))
((and (>= code #x400) (< code #x498))
(svref +unicode-0-97-to-cp1251+
(the ub8 (- code #x400))))
((and (>= code #x2010) (< code #x2040))
(svref +unicode-10-3f-to-cp1251+
(the ub8 (- code #x2010))))
((= code #x20ac) #x88)
((= code #x2116) #xb9)
((= code #x2122) #x99)
(t (handle-error))))

81
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-cp1252.lisp Normal file
View file

@ -0,0 +1,81 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-cp1252.lisp --- Implementation of the CP1252 character encoding.
;;;
;;; Copyright (C) 2011, Nicolas Martyanoff
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :cp1252
"A 8-bit, fixed-width character encoding used by Windows for Western
European languages."
:aliases '(:windows-1252)
:literal-char-code-limit 256)
(define-constant +cp1252-to-unicode+
#(#x20ac nil #x201a #x0192 #x201e #x2026 #x2020 #x2021
#x02c6 #x2030 #x0160 #x2039 #x0152 nil #x017d nil
nil #x2018 #x2019 #x201c #x201d #x2022 #x2013 #x2014
#x02dc #x2122 #x0161 #x203a #x0153 nil #x017e #x0178)
:test #'equalp)
(define-unibyte-decoder :cp1252 (octet)
(if (and (>= octet #x80) (<= octet #x9f))
(svref +cp1252-to-unicode+
(the ub8 (- octet #x80)))
octet))
(define-constant +unicode-0152-017e-cp1252+
#(#x8c #x9c #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x8a #x9a
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x9f #x00
#x00 #x00 #x00 #x8e #x9e)
:test #'equalp)
(define-constant +unicode-2013-203a-cp1252+
#(#x96 #x97 #x00 #x00 #x00 #x91 #x92 #x82
#x00 #x93 #x94 #x84 #x00 #x86 #x87 #x95
#x00 #x00 #x00 #x85 #x00 #x00 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x89 #x00 #x00
#x00 #x00 #x00 #x00 #x00 #x00 #x8b #x9b)
:test #'equalp)
(define-unibyte-encoder :cp1252 (code)
(cond
((or (< code #x80)
(and (> code #xa0) (<= code #xff)))
code)
((and (>= code #x0152) (<= code #x017e))
(svref +unicode-0152-017e-cp1252+
(the ub8 (- code #x0152))))
((= code #x0192) #x83)
((= code #x02c6) #x88)
((= code #x02dc) #x89)
((and (>= code #x2013) (<= code #x203a))
(svref +unicode-2013-203a-cp1252+
(the ub8 (- code #x2013))))
((= code #x20ac) #x80)
((= code #x2122) #x99)
(t (handle-error))))

49
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-ebcdic-int.lisp Normal file
View file

@ -0,0 +1,49 @@
(in-package #:babel-encodings)
(define-character-encoding :ebcdic-international
"An 8-bit, fixed-width character encoding from IBM.")
(defparameter +ebcdic-int-to-unicode+
#(0 1 2 3 156 9 134 127 151 141 142 11 12 13 14 15 16 17 18 19 157 133 8 135
24 25 146 143 28 29 30 31 128 129 130 65535 132 10 23 27 65535 65535 138 139
65535 5 6 7 65535 65535 22 65535 148 149 150 4 65535 65535 65535 155 20 21
65535 26 32 65535 65535 65535 65535 65535 65535 65535 65535 65535 91 46 60
40 43 33 38 65535 65535 65535 65535 65535 65535 65535 65535 65535 93 164 42
41 59 172 45 47 65535 65535 65535 65535 65535 65535 65535 65535 124 44 37 95
62 63 65535 65535 65535 65535 65535 65535 1102 1072 1073 96 58 35 64 39 61
34 1094 97 98 99 100 101 102 103 104 105 1076 1077 1092 1075 1093 1080 1081
106 107 108 109 110 111 112 113 114 1082 1083 1084 1085 1086 1087 1103 126
115 116 117 118 119 120 121 122 1088 1089 1090 1091 1078 1074 1100 1099 1079
1096 1101 1097 1095 1098 1070 1040 1041 1062 1044 1045 1060 1043 123 65 66
67 68 69 70 71 72 73 1061 1048 1049 1050 1051 1052 125 74 75 76 77 78 79 80
81 82 1053 1054 1055 1071 1056 1057 92 65535 83 84 85 86 87 88 89 90 1058
1059 1046 1042 1068 1067 48 49 50 51 52 53 54 55 56 57 1047 1064 1069 1065
1063 159))
(defparameter +unicode-upto-ac-ebcdic-int+
#(0 1 2 3 55 45 46 47 22 5 37 11 12 13 14 15 16 17 18 19 60 61 50 38 24 25 63
39 28 29 30 31 64 79 127 123 0 108 80 125 77 93 92 78 107 96 75 97 240 241
242 243 244 245 246 247 248 249 122 94 76 126 110 111 124 193 194 195 196
197 198 199 200 201 209 210 211 212 213 214 215 216 217 226 227 228 229 230
231 232 233 74 224 90 0 109 121 129 130 131 132 133 134 135 136 137 145 146
147 148 149 150 151 152 153 162 163 164 165 166 167 168 169 192 106 208 161
7 32 33 34 0 36 21 6 23 0 0 42 43 0 9 10 27 0 0 26 0 52 53 54 8 0 0 0 59 4
20 0 255 0 0 0 0 91 0 0 0 0 0 0 0 95))
(defparameter +unicode-0410-0450-ebcdic-int+
#(185 186 237 191 188 189 236 250 203 204 205 206 207 218 219 220 222 223 234
235 190 202 187 254 251 253 0 239 238 252 184 221 119 120 175 141 138 139
174 178 143 144 154 155 156 157 158 159 170 171 172 173 140 142 128 182 179
181 183 177 176 180 118 160))
(define-unibyte-decoder :ebcdic-international (octet)
(svref +ebcdic-int-to-unicode+ (the ub8 octet)))
(define-unibyte-encoder :ebcdic-international (code)
(let ((result (cond
((<= code 172) (svref +unicode-upto-ac-ebcdic-int+ code))
((<= #x0410 code #x0450) (svref +unicode-0410-0450-ebcdic-int+
(- code #x0410))))))
(prog1 result
(when (and (zerop result) (plusp code))
(handle-error)))))

71
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-ebcdic.lisp Normal file
View file

@ -0,0 +1,71 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-ebcdic.lisp --- EBCDIC encodings.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :ebcdic-us
"An alleged character set used on IBM dinosaurs."
:aliases '(:ibm-037))
(define-constant +ebcdic-decode-table+
(make-array
256 :element-type 'ub8 :initial-contents
'(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d
#x0e #x0f #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f
#x1c #x1d #x1e #x1f #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89
#x8a #x8b #x8c #x05 #x06 #x07 #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04
#x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a #x20 #xa0 #xe2 #xe4 #xe0 #xe1
#xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c #x26 #xe9 #xea #xeb
#xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac #x2d #x2f
#xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
#xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27
#x3d #x22 #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb
#xf0 #xfd #xfe #xb1 #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72
#xaa #xba #xe6 #xb8 #xc6 #xa4 #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78
#x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae #x5e #xa3 #xa5 #xb7 #xa9 #xa7
#xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7 #x7b #x41 #x42 #x43
#x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5 #x7d #x4a
#x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
#x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2
#xd3 #xd5 #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb
#xdc #xd9 #xda #x9f))
:test #'equalp)
(define-constant +ebcdic-encode-table+
(loop with rt = (make-array 256 :element-type 'ub8 :initial-element 0)
for code across +ebcdic-decode-table+ for i from 0 do
(assert (= 0 (aref rt code)))
(setf (aref rt code) i)
finally (return rt))
:test #'equalp)
(define-unibyte-encoder :ebcdic-us (code)
(if (>= code 256)
(handle-error)
(aref +ebcdic-encode-table+ code)))
(define-unibyte-decoder :ebcdic-us (octet)
(aref +ebcdic-decode-table+ octet))

184
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-gbk.lisp Normal file
View file

@ -0,0 +1,184 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-gbk.lisp --- GBK encodings.
;;;
;;; Copyright (C) 2011, Li Wenpeng <levin108@gmail.com>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
;; populated in gbk-map.lisp
(defvar *gbk-unicode-mapping*)
(defconstant +gbk2-offset+ 0)
(defconstant +gbk3-offset+ 6763)
(defconstant +gbk4-offset+ (+ 6763 6080))
(defconstant +gbk1-offset+ 20902)
(defconstant +gbk5-offset+ (+ 20902 846))
(define-character-encoding :gbk
"GBK is an extension of the GB2312 character set for simplified
Chinese characters, used in the People's Republic of China."
:max-units-per-char 4
:literal-char-code-limit #x80)
(define-condition invalid-gbk-byte (character-decoding-error)
()
(:documentation "Signalled when an invalid GBK byte is found."))
(define-condition invalid-gbk-character (character-encoding-error)
()
(:documentation "Signalled when an invalid GBK character is found."))
(define-octet-counter :gbk (getter type)
`(lambda (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(let ((noctets 0))
(loop for i from start below end
for u1 of-type code-point = (,getter seq i)
do (cond ((< u1 #x80) (incf noctets))
(t (incf noctets 2)))
(when (and (plusp max) (= noctets max))
(return (values noctets i)))
finally (return (values noctets i))))))
(define-code-point-counter :gbk (getter type)
`(lambda (seq start end max)
(declare (type ,type seq))
(let (u1 (noctets 0))
(loop with i = start
while (< i end)
do (setf u1 (,getter seq i))
(cond
((eq 0 (logand u1 #x80)) (incf i))
(t (incf i 2)))
(incf noctets)
(when (and (plusp max) (= noctets max))
(return (values noctets i)))
finally (return (values noctets i))))))
(define-encoder :gbk (getter src-type setter dest-type)
`(lambda (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(macrolet
((do-encoding (index)
`(let ((u1 0) (u2 0))
(cond
((<= +gbk2-offset+ ,index (- +gbk3-offset+ 1)) ; gbk/2
(setf u1 (+ #xB0 (truncate (/ ,index 94))))
(setf u2 (+ #xA1 (mod ,index 94))))
((<= +gbk3-offset+ ,index (- +gbk4-offset+ 1)) ; gbk/3
(setf index (- ,index +gbk3-offset+))
(setf u1 (+ #x81 (truncate (/ ,index 190))))
(setf u2 (+ #x40 (mod ,index 190)))
(if (>= u2 #x7F) (incf u2)))
((<= +gbk4-offset+ ,index (- +gbk1-offset+ 1)) ; gbk/4
(setf index (- ,index +gbk4-offset+))
(setf u1 (+ #xAA (truncate (/ ,index 96))))
(setf u2 (+ #x40 (mod ,index 96)))
(if (>= u2 #x7F) (incf u2)))
((<= +gbk1-offset+ ,index (- +gbk5-offset+ 1)) ; gbk/1
(setf index (- ,index +gbk1-offset+))
(setf u1 (+ #xA1 (truncate (/ ,index 94))))
(setf u2 (+ #xA1 (mod ,index 94))))
((<= +gbk5-offset+ ,index (length *gbk-unicode-mapping*)) ; gbk/5
(setf index (- ,index +gbk5-offset+))
(setf u1 (+ #xA8 (truncate (/ ,index 96))))
(setf u2 (+ #x40 (mod ,index 96)))
(if (>= u2 #x7F) (incf u2))))
(values u1 u2))))
(let ((c 0) index (noctets 0))
(loop for i from start below end
for code of-type code-point = (,getter src i)
do (macrolet
((handle-error (&optional (c 'character-encoding-error))
`(encoding-error code :gbk src i +repl+ ',c)))
(setf c (code-char code))
(cond
((< code #x80) ; ascii
(,setter code dest noctets)
(incf noctets))
(t ; gbk
(setf index
(position c *gbk-unicode-mapping*))
(if (not index)
(handle-error invalid-gbk-character))
(multiple-value-bind (uh ul) (do-encoding index)
(,setter uh dest noctets)
(,setter ul dest (+ 1 noctets))
(incf noctets 2)))))
finally (return (the fixnum (- noctets d-start))))))))
(define-decoder :gbk (getter src-type setter dest-type)
`(lambda (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest))
(let ((u1 0) (u2 0) (index 0) (tmp 0) (noctets 0))
(loop with i = start
while (< i end)
do (macrolet
((handle-error (&optional (c 'character-decoding-error))
`(decoding-error #(u1 u2) :gbk src i +repl+ ',c)))
(setf u1 (,getter src i))
(incf i)
(cond
((eq 0 (logand u1 #x80))
(,setter u1 dest noctets))
(t
(setf u2 (,getter src i))
(incf i)
(setf index
(block setter-block
(cond
((and (<= #xB0 u1 #xF7) (<= #xA1 u2 #xFE))
(+ +gbk2-offset+ (+ (* 94 (- u1 #xB0)) (- u2 #xA1))))
((and (<= #x81 u1 #xA0) (<= #x40 u2 #xFE))
(cond ((> u2 #x7F) (setf tmp 1))
(t (setf tmp 0)))
(+ +gbk3-offset+ (* 190 (- u1 #x81)) (- u2 #x40 tmp)))
((and (<= #xAA u1 #xFE) (<= #x40 #xA0))
(cond ((> u2 #x7F) (setf tmp 1))
(t (setf tmp 0)))
(+ +gbk4-offset+ (* 96 (- u1 #xAA)) (- u2 #x40 tmp)))
((and (<= #xA1 u1 #xA9) (<= #xA1 u2 #xFE))
(+ +gbk1-offset+ (* 94 (- u1 #xA1)) (- u2 #xA1)))
((and (<= #xA8 u1 #xA9) (<= #x40 #xA0))
(cond ((> u2 #x7F) (setf tmp 1))
(t (setf tmp 0)))
(+ +gbk5-offset+ (* 96 (- u1 #xA8)) (- u2 #x40 tmp)))
(t
(handle-error invalid-gbk-byte)))))
(when (>= index (length *gbk-unicode-mapping*))
(handle-error invalid-gbk-byte))
(,setter (char-code
(elt *gbk-unicode-mapping* index))
dest noctets)))
(incf noctets))
finally (return (the fixnum (- noctets d-start)))))))

1087
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-iso-8859.lisp Normal file
View file

File diff suppressed because it is too large Load diff

767
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-jpn.lisp Normal file
View file

@ -0,0 +1,767 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-jpn.lisp --- Japanese encodings.
;;;
(in-package #:babel-encodings)
;;;; helper functions
(defvar *eucjp-to-ucs-hash* (make-hash-table))
(defvar *ucs-to-eucjp-hash* (make-hash-table))
(defvar *cp932-to-ucs-hash* (make-hash-table))
(defvar *ucs-to-cp932-hash* (make-hash-table))
(dolist (i `((,*cp932-only*
,*cp932-to-ucs-hash*
,*ucs-to-cp932-hash*)
(,*eucjp-only*
,*eucjp-to-ucs-hash*
,*ucs-to-eucjp-hash*)
(,*eucjp*
,*eucjp-to-ucs-hash*
,*ucs-to-eucjp-hash*)))
(dolist (j (first i))
(setf (gethash (car j) (second i)) (cadr j))
(setf (gethash (cadr j) (third i)) (car j))))
(flet ((euc-cp932 (x)
(let ((high (ash x -16))
(mid (logand (ash x -8) 255))
(low (logand x 255)))
(cond ((not (zerop high))
nil)
((= mid #x8e)
(logand x 255))
((zerop mid)
x)
((decf mid #xa1)
(decf low #x80)
(incf low (if (zerop (logand mid 1)) #x1f #x7e))
(incf low (if (<= #x7f low #x9d) 1 0))
(setq mid (ash mid -1))
(incf mid (if (<= mid #x1e) #x81 #xc1))
(+ (ash mid 8) low))))))
(dolist (i *eucjp*)
(let ((cp932 (euc-cp932 (first i))))
(when cp932
(setf (gethash cp932 *cp932-to-ucs-hash*) (second i))
(setf (gethash (second i) *ucs-to-cp932-hash*) cp932)))))
;ascii
(loop for i from #x00 to #x7f do
(setf (gethash i *cp932-to-ucs-hash*) i)
(setf (gethash i *eucjp-to-ucs-hash*) i)
(setf (gethash i *ucs-to-eucjp-hash*) i)
(setf (gethash i *ucs-to-cp932-hash*) i))
;half-width katakana
(loop for i from #xa1 to #xdf do
(setf (gethash i *cp932-to-ucs-hash*) (+ #xff61 #x-a1 i))
(setf (gethash (+ #xff61 #x-a1 i) *ucs-to-cp932-hash*) i)
(setf (gethash (+ #x8e00 i) *eucjp-to-ucs-hash*) (+ #xff61 #x-a1 i))
(setf (gethash (+ #xff61 #x-a1 i) *ucs-to-eucjp-hash*) (+ #x8e00 i)))
;; This is quoted from https://support.microsoft.com/en-us/kb/170559/en-us
(let ((kb170559 "0x8790 -> U+2252 -> 0x81e0 Approximately Equal To Or The Image Of
0x8791 -> U+2261 -> 0x81df Identical To
0x8792 -> U+222b -> 0x81e7 Integral
0x8795 -> U+221a -> 0x81e3 Square Root
0x8796 -> U+22a5 -> 0x81db Up Tack
0x8797 -> U+2220 -> 0x81da Angle
0x879a -> U+2235 -> 0x81e6 Because
0x879b -> U+2229 -> 0x81bf Intersection
0x879c -> U+222a -> 0x81be Union
0xed40 -> U+7e8a -> 0xfa5c CJK Unified Ideograph
0xed41 -> U+891c -> 0xfa5d CJK Unified Ideograph
0xed42 -> U+9348 -> 0xfa5e CJK Unified Ideograph
0xed43 -> U+9288 -> 0xfa5f CJK Unified Ideograph
0xed44 -> U+84dc -> 0xfa60 CJK Unified Ideograph
0xed45 -> U+4fc9 -> 0xfa61 CJK Unified Ideograph
0xed46 -> U+70bb -> 0xfa62 CJK Unified Ideograph
0xed47 -> U+6631 -> 0xfa63 CJK Unified Ideograph
0xed48 -> U+68c8 -> 0xfa64 CJK Unified Ideograph
0xed49 -> U+92f9 -> 0xfa65 CJK Unified Ideograph
0xed4a -> U+66fb -> 0xfa66 CJK Unified Ideograph
0xed4b -> U+5f45 -> 0xfa67 CJK Unified Ideograph
0xed4c -> U+4e28 -> 0xfa68 CJK Unified Ideograph
0xed4d -> U+4ee1 -> 0xfa69 CJK Unified Ideograph
0xed4e -> U+4efc -> 0xfa6a CJK Unified Ideograph
0xed4f -> U+4f00 -> 0xfa6b CJK Unified Ideograph
0xed50 -> U+4f03 -> 0xfa6c CJK Unified Ideograph
0xed51 -> U+4f39 -> 0xfa6d CJK Unified Ideograph
0xed52 -> U+4f56 -> 0xfa6e CJK Unified Ideograph
0xed53 -> U+4f92 -> 0xfa6f CJK Unified Ideograph
0xed54 -> U+4f8a -> 0xfa70 CJK Unified Ideograph
0xed55 -> U+4f9a -> 0xfa71 CJK Unified Ideograph
0xed56 -> U+4f94 -> 0xfa72 CJK Unified Ideograph
0xed57 -> U+4fcd -> 0xfa73 CJK Unified Ideograph
0xed58 -> U+5040 -> 0xfa74 CJK Unified Ideograph
0xed59 -> U+5022 -> 0xfa75 CJK Unified Ideograph
0xed5a -> U+4fff -> 0xfa76 CJK Unified Ideograph
0xed5b -> U+501e -> 0xfa77 CJK Unified Ideograph
0xed5c -> U+5046 -> 0xfa78 CJK Unified Ideograph
0xed5d -> U+5070 -> 0xfa79 CJK Unified Ideograph
0xed5e -> U+5042 -> 0xfa7a CJK Unified Ideograph
0xed5f -> U+5094 -> 0xfa7b CJK Unified Ideograph
0xed60 -> U+50f4 -> 0xfa7c CJK Unified Ideograph
0xed61 -> U+50d8 -> 0xfa7d CJK Unified Ideograph
0xed62 -> U+514a -> 0xfa7e CJK Unified Ideograph
0xed63 -> U+5164 -> 0xfa80 CJK Unified Ideograph
0xed64 -> U+519d -> 0xfa81 CJK Unified Ideograph
0xed65 -> U+51be -> 0xfa82 CJK Unified Ideograph
0xed66 -> U+51ec -> 0xfa83 CJK Unified Ideograph
0xed67 -> U+5215 -> 0xfa84 CJK Unified Ideograph
0xed68 -> U+529c -> 0xfa85 CJK Unified Ideograph
0xed69 -> U+52a6 -> 0xfa86 CJK Unified Ideograph
0xed6a -> U+52c0 -> 0xfa87 CJK Unified Ideograph
0xed6b -> U+52db -> 0xfa88 CJK Unified Ideograph
0xed6c -> U+5300 -> 0xfa89 CJK Unified Ideograph
0xed6d -> U+5307 -> 0xfa8a CJK Unified Ideograph
0xed6e -> U+5324 -> 0xfa8b CJK Unified Ideograph
0xed6f -> U+5372 -> 0xfa8c CJK Unified Ideograph
0xed70 -> U+5393 -> 0xfa8d CJK Unified Ideograph
0xed71 -> U+53b2 -> 0xfa8e CJK Unified Ideograph
0xed72 -> U+53dd -> 0xfa8f CJK Unified Ideograph
0xed73 -> U+fa0e -> 0xfa90 CJK compatibility Ideograph
0xed74 -> U+549c -> 0xfa91 CJK Unified Ideograph
0xed75 -> U+548a -> 0xfa92 CJK Unified Ideograph
0xed76 -> U+54a9 -> 0xfa93 CJK Unified Ideograph
0xed77 -> U+54ff -> 0xfa94 CJK Unified Ideograph
0xed78 -> U+5586 -> 0xfa95 CJK Unified Ideograph
0xed79 -> U+5759 -> 0xfa96 CJK Unified Ideograph
0xed7a -> U+5765 -> 0xfa97 CJK Unified Ideograph
0xed7b -> U+57ac -> 0xfa98 CJK Unified Ideograph
0xed7c -> U+57c8 -> 0xfa99 CJK Unified Ideograph
0xed7d -> U+57c7 -> 0xfa9a CJK Unified Ideograph
0xed7e -> U+fa0f -> 0xfa9b CJK compatibility Ideograph
0xed80 -> U+fa10 -> 0xfa9c CJK compatibility Ideograph
0xed81 -> U+589e -> 0xfa9d CJK Unified Ideograph
0xed82 -> U+58b2 -> 0xfa9e CJK Unified Ideograph
0xed83 -> U+590b -> 0xfa9f CJK Unified Ideograph
0xed84 -> U+5953 -> 0xfaa0 CJK Unified Ideograph
0xed85 -> U+595b -> 0xfaa1 CJK Unified Ideograph
0xed86 -> U+595d -> 0xfaa2 CJK Unified Ideograph
0xed87 -> U+5963 -> 0xfaa3 CJK Unified Ideograph
0xed88 -> U+59a4 -> 0xfaa4 CJK Unified Ideograph
0xed89 -> U+59ba -> 0xfaa5 CJK Unified Ideograph
0xed8a -> U+5b56 -> 0xfaa6 CJK Unified Ideograph
0xed8b -> U+5bc0 -> 0xfaa7 CJK Unified Ideograph
0xed8c -> U+752f -> 0xfaa8 CJK Unified Ideograph
0xed8d -> U+5bd8 -> 0xfaa9 CJK Unified Ideograph
0xed8e -> U+5bec -> 0xfaaa CJK Unified Ideograph
0xed8f -> U+5c1e -> 0xfaab CJK Unified Ideograph
0xed90 -> U+5ca6 -> 0xfaac CJK Unified Ideograph
0xed91 -> U+5cba -> 0xfaad CJK Unified Ideograph
0xed92 -> U+5cf5 -> 0xfaae CJK Unified Ideograph
0xed93 -> U+5d27 -> 0xfaaf CJK Unified Ideograph
0xed94 -> U+5d53 -> 0xfab0 CJK Unified Ideograph
0xed95 -> U+fa11 -> 0xfab1 CJK compatibility Ideograph
0xed96 -> U+5d42 -> 0xfab2 CJK Unified Ideograph
0xed97 -> U+5d6d -> 0xfab3 CJK Unified Ideograph
0xed98 -> U+5db8 -> 0xfab4 CJK Unified Ideograph
0xed99 -> U+5db9 -> 0xfab5 CJK Unified Ideograph
0xed9a -> U+5dd0 -> 0xfab6 CJK Unified Ideograph
0xed9b -> U+5f21 -> 0xfab7 CJK Unified Ideograph
0xed9c -> U+5f34 -> 0xfab8 CJK Unified Ideograph
0xed9d -> U+5f67 -> 0xfab9 CJK Unified Ideograph
0xed9e -> U+5fb7 -> 0xfaba CJK Unified Ideograph
0xed9f -> U+5fde -> 0xfabb CJK Unified Ideograph
0xeda0 -> U+605d -> 0xfabc CJK Unified Ideograph
0xeda1 -> U+6085 -> 0xfabd CJK Unified Ideograph
0xeda2 -> U+608a -> 0xfabe CJK Unified Ideograph
0xeda3 -> U+60de -> 0xfabf CJK Unified Ideograph
0xeda4 -> U+60d5 -> 0xfac0 CJK Unified Ideograph
0xeda5 -> U+6120 -> 0xfac1 CJK Unified Ideograph
0xeda6 -> U+60f2 -> 0xfac2 CJK Unified Ideograph
0xeda7 -> U+6111 -> 0xfac3 CJK Unified Ideograph
0xeda8 -> U+6137 -> 0xfac4 CJK Unified Ideograph
0xeda9 -> U+6130 -> 0xfac5 CJK Unified Ideograph
0xedaa -> U+6198 -> 0xfac6 CJK Unified Ideograph
0xedab -> U+6213 -> 0xfac7 CJK Unified Ideograph
0xedac -> U+62a6 -> 0xfac8 CJK Unified Ideograph
0xedad -> U+63f5 -> 0xfac9 CJK Unified Ideograph
0xedae -> U+6460 -> 0xfaca CJK Unified Ideograph
0xedaf -> U+649d -> 0xfacb CJK Unified Ideograph
0xedb0 -> U+64ce -> 0xfacc CJK Unified Ideograph
0xedb1 -> U+654e -> 0xfacd CJK Unified Ideograph
0xedb2 -> U+6600 -> 0xface CJK Unified Ideograph
0xedb3 -> U+6615 -> 0xfacf CJK Unified Ideograph
0xedb4 -> U+663b -> 0xfad0 CJK Unified Ideograph
0xedb5 -> U+6609 -> 0xfad1 CJK Unified Ideograph
0xedb6 -> U+662e -> 0xfad2 CJK Unified Ideograph
0xedb7 -> U+661e -> 0xfad3 CJK Unified Ideograph
0xedb8 -> U+6624 -> 0xfad4 CJK Unified Ideograph
0xedb9 -> U+6665 -> 0xfad5 CJK Unified Ideograph
0xedba -> U+6657 -> 0xfad6 CJK Unified Ideograph
0xedbb -> U+6659 -> 0xfad7 CJK Unified Ideograph
0xedbc -> U+fa12 -> 0xfad8 CJK compatibility Ideograph
0xedbd -> U+6673 -> 0xfad9 CJK Unified Ideograph
0xedbe -> U+6699 -> 0xfada CJK Unified Ideograph
0xedbf -> U+66a0 -> 0xfadb CJK Unified Ideograph
0xedc0 -> U+66b2 -> 0xfadc CJK Unified Ideograph
0xedc1 -> U+66bf -> 0xfadd CJK Unified Ideograph
0xedc2 -> U+66fa -> 0xfade CJK Unified Ideograph
0xedc3 -> U+670e -> 0xfadf CJK Unified Ideograph
0xedc4 -> U+f929 -> 0xfae0 CJK compatibility Ideograph
0xedc5 -> U+6766 -> 0xfae1 CJK Unified Ideograph
0xedc6 -> U+67bb -> 0xfae2 CJK Unified Ideograph
0xedc7 -> U+6852 -> 0xfae3 CJK Unified Ideograph
0xedc8 -> U+67c0 -> 0xfae4 CJK Unified Ideograph
0xedc9 -> U+6801 -> 0xfae5 CJK Unified Ideograph
0xedca -> U+6844 -> 0xfae6 CJK Unified Ideograph
0xedcb -> U+68cf -> 0xfae7 CJK Unified Ideograph
0xedcc -> U+fa13 -> 0xfae8 CJK compatibility Ideograph
0xedcd -> U+6968 -> 0xfae9 CJK Unified Ideograph
0xedce -> U+fa14 -> 0xfaea CJK compatibility Ideograph
0xedcf -> U+6998 -> 0xfaeb CJK Unified Ideograph
0xedd0 -> U+69e2 -> 0xfaec CJK Unified Ideograph
0xedd1 -> U+6a30 -> 0xfaed CJK Unified Ideograph
0xedd2 -> U+6a6b -> 0xfaee CJK Unified Ideograph
0xedd3 -> U+6a46 -> 0xfaef CJK Unified Ideograph
0xedd4 -> U+6a73 -> 0xfaf0 CJK Unified Ideograph
0xedd5 -> U+6a7e -> 0xfaf1 CJK Unified Ideograph
0xedd6 -> U+6ae2 -> 0xfaf2 CJK Unified Ideograph
0xedd7 -> U+6ae4 -> 0xfaf3 CJK Unified Ideograph
0xedd8 -> U+6bd6 -> 0xfaf4 CJK Unified Ideograph
0xedd9 -> U+6c3f -> 0xfaf5 CJK Unified Ideograph
0xedda -> U+6c5c -> 0xfaf6 CJK Unified Ideograph
0xeddb -> U+6c86 -> 0xfaf7 CJK Unified Ideograph
0xeddc -> U+6c6f -> 0xfaf8 CJK Unified Ideograph
0xeddd -> U+6cda -> 0xfaf9 CJK Unified Ideograph
0xedde -> U+6d04 -> 0xfafa CJK Unified Ideograph
0xeddf -> U+6d87 -> 0xfafb CJK Unified Ideograph
0xede0 -> U+6d6f -> 0xfafc CJK Unified Ideograph
0xede1 -> U+6d96 -> 0xfb40 CJK Unified Ideograph
0xede2 -> U+6dac -> 0xfb41 CJK Unified Ideograph
0xede3 -> U+6dcf -> 0xfb42 CJK Unified Ideograph
0xede4 -> U+6df8 -> 0xfb43 CJK Unified Ideograph
0xede5 -> U+6df2 -> 0xfb44 CJK Unified Ideograph
0xede6 -> U+6dfc -> 0xfb45 CJK Unified Ideograph
0xede7 -> U+6e39 -> 0xfb46 CJK Unified Ideograph
0xede8 -> U+6e5c -> 0xfb47 CJK Unified Ideograph
0xede9 -> U+6e27 -> 0xfb48 CJK Unified Ideograph
0xedea -> U+6e3c -> 0xfb49 CJK Unified Ideograph
0xedeb -> U+6ebf -> 0xfb4a CJK Unified Ideograph
0xedec -> U+6f88 -> 0xfb4b CJK Unified Ideograph
0xeded -> U+6fb5 -> 0xfb4c CJK Unified Ideograph
0xedee -> U+6ff5 -> 0xfb4d CJK Unified Ideograph
0xedef -> U+7005 -> 0xfb4e CJK Unified Ideograph
0xedf0 -> U+7007 -> 0xfb4f CJK Unified Ideograph
0xedf1 -> U+7028 -> 0xfb50 CJK Unified Ideograph
0xedf2 -> U+7085 -> 0xfb51 CJK Unified Ideograph
0xedf3 -> U+70ab -> 0xfb52 CJK Unified Ideograph
0xedf4 -> U+710f -> 0xfb53 CJK Unified Ideograph
0xedf5 -> U+7104 -> 0xfb54 CJK Unified Ideograph
0xedf6 -> U+715c -> 0xfb55 CJK Unified Ideograph
0xedf7 -> U+7146 -> 0xfb56 CJK Unified Ideograph
0xedf8 -> U+7147 -> 0xfb57 CJK Unified Ideograph
0xedf9 -> U+fa15 -> 0xfb58 CJK compatibility Ideograph
0xedfa -> U+71c1 -> 0xfb59 CJK Unified Ideograph
0xedfb -> U+71fe -> 0xfb5a CJK Unified Ideograph
0xedfc -> U+72b1 -> 0xfb5b CJK Unified Ideograph
0xee40 -> U+72be -> 0xfb5c CJK Unified Ideograph
0xee41 -> U+7324 -> 0xfb5d CJK Unified Ideograph
0xee42 -> U+fa16 -> 0xfb5e CJK compatibility Ideograph
0xee43 -> U+7377 -> 0xfb5f CJK Unified Ideograph
0xee44 -> U+73bd -> 0xfb60 CJK Unified Ideograph
0xee45 -> U+73c9 -> 0xfb61 CJK Unified Ideograph
0xee46 -> U+73d6 -> 0xfb62 CJK Unified Ideograph
0xee47 -> U+73e3 -> 0xfb63 CJK Unified Ideograph
0xee48 -> U+73d2 -> 0xfb64 CJK Unified Ideograph
0xee49 -> U+7407 -> 0xfb65 CJK Unified Ideograph
0xee4a -> U+73f5 -> 0xfb66 CJK Unified Ideograph
0xee4b -> U+7426 -> 0xfb67 CJK Unified Ideograph
0xee4c -> U+742a -> 0xfb68 CJK Unified Ideograph
0xee4d -> U+7429 -> 0xfb69 CJK Unified Ideograph
0xee4e -> U+742e -> 0xfb6a CJK Unified Ideograph
0xee4f -> U+7462 -> 0xfb6b CJK Unified Ideograph
0xee50 -> U+7489 -> 0xfb6c CJK Unified Ideograph
0xee51 -> U+749f -> 0xfb6d CJK Unified Ideograph
0xee52 -> U+7501 -> 0xfb6e CJK Unified Ideograph
0xee53 -> U+756f -> 0xfb6f CJK Unified Ideograph
0xee54 -> U+7682 -> 0xfb70 CJK Unified Ideograph
0xee55 -> U+769c -> 0xfb71 CJK Unified Ideograph
0xee56 -> U+769e -> 0xfb72 CJK Unified Ideograph
0xee57 -> U+769b -> 0xfb73 CJK Unified Ideograph
0xee58 -> U+76a6 -> 0xfb74 CJK Unified Ideograph
0xee59 -> U+fa17 -> 0xfb75 CJK compatibility Ideograph
0xee5a -> U+7746 -> 0xfb76 CJK Unified Ideograph
0xee5b -> U+52af -> 0xfb77 CJK Unified Ideograph
0xee5c -> U+7821 -> 0xfb78 CJK Unified Ideograph
0xee5d -> U+784e -> 0xfb79 CJK Unified Ideograph
0xee5e -> U+7864 -> 0xfb7a CJK Unified Ideograph
0xee5f -> U+787a -> 0xfb7b CJK Unified Ideograph
0xee60 -> U+7930 -> 0xfb7c CJK Unified Ideograph
0xee61 -> U+fa18 -> 0xfb7d CJK compatibility Ideograph
0xee62 -> U+fa19 -> 0xfb7e CJK compatibility Ideograph
0xee63 -> U+fa1a -> 0xfb80 CJK compatibility Ideograph
0xee64 -> U+7994 -> 0xfb81 CJK Unified Ideograph
0xee65 -> U+fa1b -> 0xfb82 CJK compatibility Ideograph
0xee66 -> U+799b -> 0xfb83 CJK Unified Ideograph
0xee67 -> U+7ad1 -> 0xfb84 CJK Unified Ideograph
0xee68 -> U+7ae7 -> 0xfb85 CJK Unified Ideograph
0xee69 -> U+fa1c -> 0xfb86 CJK compatibility Ideograph
0xee6a -> U+7aeb -> 0xfb87 CJK Unified Ideograph
0xee6b -> U+7b9e -> 0xfb88 CJK Unified Ideograph
0xee6c -> U+fa1d -> 0xfb89 CJK compatibility Ideograph
0xee6d -> U+7d48 -> 0xfb8a CJK Unified Ideograph
0xee6e -> U+7d5c -> 0xfb8b CJK Unified Ideograph
0xee6f -> U+7db7 -> 0xfb8c CJK Unified Ideograph
0xee70 -> U+7da0 -> 0xfb8d CJK Unified Ideograph
0xee71 -> U+7dd6 -> 0xfb8e CJK Unified Ideograph
0xee72 -> U+7e52 -> 0xfb8f CJK Unified Ideograph
0xee73 -> U+7f47 -> 0xfb90 CJK Unified Ideograph
0xee74 -> U+7fa1 -> 0xfb91 CJK Unified Ideograph
0xee75 -> U+fa1e -> 0xfb92 CJK compatibility Ideograph
0xee76 -> U+8301 -> 0xfb93 CJK Unified Ideograph
0xee77 -> U+8362 -> 0xfb94 CJK Unified Ideograph
0xee78 -> U+837f -> 0xfb95 CJK Unified Ideograph
0xee79 -> U+83c7 -> 0xfb96 CJK Unified Ideograph
0xee7a -> U+83f6 -> 0xfb97 CJK Unified Ideograph
0xee7b -> U+8448 -> 0xfb98 CJK Unified Ideograph
0xee7c -> U+84b4 -> 0xfb99 CJK Unified Ideograph
0xee7d -> U+8553 -> 0xfb9a CJK Unified Ideograph
0xee7e -> U+8559 -> 0xfb9b CJK Unified Ideograph
0xee80 -> U+856b -> 0xfb9c CJK Unified Ideograph
0xee81 -> U+fa1f -> 0xfb9d CJK compatibility Ideograph
0xee82 -> U+85b0 -> 0xfb9e CJK Unified Ideograph
0xee83 -> U+fa20 -> 0xfb9f CJK compatibility Ideograph
0xee84 -> U+fa21 -> 0xfba0 CJK compatibility Ideograph
0xee85 -> U+8807 -> 0xfba1 CJK Unified Ideograph
0xee86 -> U+88f5 -> 0xfba2 CJK Unified Ideograph
0xee87 -> U+8a12 -> 0xfba3 CJK Unified Ideograph
0xee88 -> U+8a37 -> 0xfba4 CJK Unified Ideograph
0xee89 -> U+8a79 -> 0xfba5 CJK Unified Ideograph
0xee8a -> U+8aa7 -> 0xfba6 CJK Unified Ideograph
0xee8b -> U+8abe -> 0xfba7 CJK Unified Ideograph
0xee8c -> U+8adf -> 0xfba8 CJK Unified Ideograph
0xee8d -> U+fa22 -> 0xfba9 CJK compatibility Ideograph
0xee8e -> U+8af6 -> 0xfbaa CJK Unified Ideograph
0xee8f -> U+8b53 -> 0xfbab CJK Unified Ideograph
0xee90 -> U+8b7f -> 0xfbac CJK Unified Ideograph
0xee91 -> U+8cf0 -> 0xfbad CJK Unified Ideograph
0xee92 -> U+8cf4 -> 0xfbae CJK Unified Ideograph
0xee93 -> U+8d12 -> 0xfbaf CJK Unified Ideograph
0xee94 -> U+8d76 -> 0xfbb0 CJK Unified Ideograph
0xee95 -> U+fa23 -> 0xfbb1 CJK compatibility Ideograph
0xee96 -> U+8ecf -> 0xfbb2 CJK Unified Ideograph
0xee97 -> U+fa24 -> 0xfbb3 CJK compatibility Ideograph
0xee98 -> U+fa25 -> 0xfbb4 CJK compatibility Ideograph
0xee99 -> U+9067 -> 0xfbb5 CJK Unified Ideograph
0xee9a -> U+90de -> 0xfbb6 CJK Unified Ideograph
0xee9b -> U+fa26 -> 0xfbb7 CJK compatibility Ideograph
0xee9c -> U+9115 -> 0xfbb8 CJK Unified Ideograph
0xee9d -> U+9127 -> 0xfbb9 CJK Unified Ideograph
0xee9e -> U+91da -> 0xfbba CJK Unified Ideograph
0xee9f -> U+91d7 -> 0xfbbb CJK Unified Ideograph
0xeea0 -> U+91de -> 0xfbbc CJK Unified Ideograph
0xeea1 -> U+91ed -> 0xfbbd CJK Unified Ideograph
0xeea2 -> U+91ee -> 0xfbbe CJK Unified Ideograph
0xeea3 -> U+91e4 -> 0xfbbf CJK Unified Ideograph
0xeea4 -> U+91e5 -> 0xfbc0 CJK Unified Ideograph
0xeea5 -> U+9206 -> 0xfbc1 CJK Unified Ideograph
0xeea6 -> U+9210 -> 0xfbc2 CJK Unified Ideograph
0xeea7 -> U+920a -> 0xfbc3 CJK Unified Ideograph
0xeea8 -> U+923a -> 0xfbc4 CJK Unified Ideograph
0xeea9 -> U+9240 -> 0xfbc5 CJK Unified Ideograph
0xeeaa -> U+923c -> 0xfbc6 CJK Unified Ideograph
0xeeab -> U+924e -> 0xfbc7 CJK Unified Ideograph
0xeeac -> U+9259 -> 0xfbc8 CJK Unified Ideograph
0xeead -> U+9251 -> 0xfbc9 CJK Unified Ideograph
0xeeae -> U+9239 -> 0xfbca CJK Unified Ideograph
0xeeaf -> U+9267 -> 0xfbcb CJK Unified Ideograph
0xeeb0 -> U+92a7 -> 0xfbcc CJK Unified Ideograph
0xeeb1 -> U+9277 -> 0xfbcd CJK Unified Ideograph
0xeeb2 -> U+9278 -> 0xfbce CJK Unified Ideograph
0xeeb3 -> U+92e7 -> 0xfbcf CJK Unified Ideograph
0xeeb4 -> U+92d7 -> 0xfbd0 CJK Unified Ideograph
0xeeb5 -> U+92d9 -> 0xfbd1 CJK Unified Ideograph
0xeeb6 -> U+92d0 -> 0xfbd2 CJK Unified Ideograph
0xeeb7 -> U+fa27 -> 0xfbd3 CJK compatibility Ideograph
0xeeb8 -> U+92d5 -> 0xfbd4 CJK Unified Ideograph
0xeeb9 -> U+92e0 -> 0xfbd5 CJK Unified Ideograph
0xeeba -> U+92d3 -> 0xfbd6 CJK Unified Ideograph
0xeebb -> U+9325 -> 0xfbd7 CJK Unified Ideograph
0xeebc -> U+9321 -> 0xfbd8 CJK Unified Ideograph
0xeebd -> U+92fb -> 0xfbd9 CJK Unified Ideograph
0xeebe -> U+fa28 -> 0xfbda CJK compatibility Ideograph
0xeebf -> U+931e -> 0xfbdb CJK Unified Ideograph
0xeec0 -> U+92ff -> 0xfbdc CJK Unified Ideograph
0xeec1 -> U+931d -> 0xfbdd CJK Unified Ideograph
0xeec2 -> U+9302 -> 0xfbde CJK Unified Ideograph
0xeec3 -> U+9370 -> 0xfbdf CJK Unified Ideograph
0xeec4 -> U+9357 -> 0xfbe0 CJK Unified Ideograph
0xeec5 -> U+93a4 -> 0xfbe1 CJK Unified Ideograph
0xeec6 -> U+93c6 -> 0xfbe2 CJK Unified Ideograph
0xeec7 -> U+93de -> 0xfbe3 CJK Unified Ideograph
0xeec8 -> U+93f8 -> 0xfbe4 CJK Unified Ideograph
0xeec9 -> U+9431 -> 0xfbe5 CJK Unified Ideograph
0xeeca -> U+9445 -> 0xfbe6 CJK Unified Ideograph
0xeecb -> U+9448 -> 0xfbe7 CJK Unified Ideograph
0xeecc -> U+9592 -> 0xfbe8 CJK Unified Ideograph
0xeecd -> U+f9dc -> 0xfbe9 CJK compatibility Ideograph
0xeece -> U+fa29 -> 0xfbea CJK compatibility Ideograph
0xeecf -> U+969d -> 0xfbeb CJK Unified Ideograph
0xeed0 -> U+96af -> 0xfbec CJK Unified Ideograph
0xeed1 -> U+9733 -> 0xfbed CJK Unified Ideograph
0xeed2 -> U+973b -> 0xfbee CJK Unified Ideograph
0xeed3 -> U+9743 -> 0xfbef CJK Unified Ideograph
0xeed4 -> U+974d -> 0xfbf0 CJK Unified Ideograph
0xeed5 -> U+974f -> 0xfbf1 CJK Unified Ideograph
0xeed6 -> U+9751 -> 0xfbf2 CJK Unified Ideograph
0xeed7 -> U+9755 -> 0xfbf3 CJK Unified Ideograph
0xeed8 -> U+9857 -> 0xfbf4 CJK Unified Ideograph
0xeed9 -> U+9865 -> 0xfbf5 CJK Unified Ideograph
0xeeda -> U+fa2a -> 0xfbf6 CJK compatibility Ideograph
0xeedb -> U+fa2b -> 0xfbf7 CJK compatibility Ideograph
0xeedc -> U+9927 -> 0xfbf8 CJK Unified Ideograph
0xeedd -> U+fa2c -> 0xfbf9 CJK compatibility Ideograph
0xeede -> U+999e -> 0xfbfa CJK Unified Ideograph
0xeedf -> U+9a4e -> 0xfbfb CJK Unified Ideograph
0xeee0 -> U+9ad9 -> 0xfbfc CJK Unified Ideograph
0xeee1 -> U+9adc -> 0xfc40 CJK Unified Ideograph
0xeee2 -> U+9b75 -> 0xfc41 CJK Unified Ideograph
0xeee3 -> U+9b72 -> 0xfc42 CJK Unified Ideograph
0xeee4 -> U+9b8f -> 0xfc43 CJK Unified Ideograph
0xeee5 -> U+9bb1 -> 0xfc44 CJK Unified Ideograph
0xeee6 -> U+9bbb -> 0xfc45 CJK Unified Ideograph
0xeee7 -> U+9c00 -> 0xfc46 CJK Unified Ideograph
0xeee8 -> U+9d70 -> 0xfc47 CJK Unified Ideograph
0xeee9 -> U+9d6b -> 0xfc48 CJK Unified Ideograph
0xeeea -> U+fa2d -> 0xfc49 CJK compatibility Ideograph
0xeeeb -> U+9e19 -> 0xfc4a CJK Unified Ideograph
0xeeec -> U+9ed1 -> 0xfc4b CJK Unified Ideograph
0xeeef -> U+2170 -> 0xfa40 Small Roman Numeral One
0xeef0 -> U+2171 -> 0xfa41 Small Roman Numeral Two
0xeef1 -> U+2172 -> 0xfa42 Small Roman Numeral Three
0xeef2 -> U+2173 -> 0xfa43 Small Roman Numeral Four
0xeef3 -> U+2174 -> 0xfa44 Small Roman Numeral Five
0xeef4 -> U+2175 -> 0xfa45 Small Roman Numeral Six
0xeef5 -> U+2176 -> 0xfa46 Small Roman Numeral Seven
0xeef6 -> U+2177 -> 0xfa47 Small Roman Numeral Eight
0xeef7 -> U+2178 -> 0xfa48 Small Roman Numeral Nine
0xeef8 -> U+2179 -> 0xfa49 Small Roman Numeral Ten
0xeef9 -> U+ffe2 -> 0x81ca Fullwidth Not Sign
0xeefa -> U+ffe4 -> 0xfa55 Fullwidth Broken Bar
0xeefb -> U+ff07 -> 0xfa56 Fullwidth Apostrophe
0xeefc -> U+ff02 -> 0xfa57 Fullwidth Quotation Mark
0xfa4a -> U+2160 -> 0x8754 Roman Numeral One
0xfa4b -> U+2161 -> 0x8755 Roman Numeral Two
0xfa4c -> U+2162 -> 0x8756 Roman Numeral Three
0xfa4d -> U+2163 -> 0x8757 Roman Numeral Four
0xfa4e -> U+2164 -> 0x8758 Roman Numeral Five
0xfa4f -> U+2165 -> 0x8759 Roman Numeral Six
0xfa50 -> U+2166 -> 0x875a Roman Numeral Seven
0xfa51 -> U+2167 -> 0x875b Roman Numeral Eight
0xfa52 -> U+2168 -> 0x875c Roman Numeral Nine
0xfa53 -> U+2169 -> 0x875d Roman Numeral Ten
0xfa54 -> U+ffe2 -> 0x81ca Fullwidth Not Sign
0xfa58 -> U+3231 -> 0x878a Parenthesized Ideograph Stock
0xfa59 -> U+2116 -> 0x8782 Numero Sign
0xfa5a -> U+2121 -> 0x8784 Telephone Sign
0xfa5b -> U+2235 -> 0x81e6 Because"))
(with-input-from-string (s kb170559)
(loop for line = (read-line s nil) until (null line)
do (let ((ucs (parse-integer (subseq line 14 18) :radix 16))
(cp932 (parse-integer (subseq line 26 30) :radix 16)))
(setf (gethash ucs *ucs-to-cp932-hash*) cp932)))))
(defun eucjp-to-ucs (code)
(values (gethash code *eucjp-to-ucs-hash*)))
(defun ucs-to-eucjp (code)
(values (gethash code *ucs-to-eucjp-hash*)))
(defun cp932-to-ucs (code)
(values (gethash code *cp932-to-ucs-hash*)))
(defun ucs-to-cp932 (code)
(values (gethash code *ucs-to-cp932-hash*)))
;;;; EUC-JP
(define-character-encoding :eucjp
"An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 to 3 bytes."
:max-units-per-char 3
:literal-char-code-limit #x80)
(define-octet-counter :eucjp (getter type)
`(named-lambda eucjp-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i)
do (let* ((c (ucs-to-eucjp code))
(new (+ (cond ((< #xffff c) 3)
((< #xff c) 2)
(t 1))
noctets)))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(define-code-point-counter :eucjp (getter type)
`(named-lambda eucjp-code-point-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with nchars fixnum = 0
with i fixnum = start
while (< i end) do
(let* ((octet (,getter seq i))
(next-i (+ i (cond ((= #x8f octet) 3)
((or (< #xa0 octet #xff)
(= #x8e octet)) 2)
(t 1)))))
(declare (type ub8 octet) (fixnum next-i))
(cond ((> next-i end)
;; Should we add restarts to this error, we'll have
;; to figure out a way to communicate with the
;; decoder since we probably want to do something
;; about it right here when we have a chance to
;; change the count or something. (Like an
;; alternative replacement character or perhaps the
;; existence of this error so that the decoder
;; doesn't have to check for it on every iteration
;; like we do.)
;;
;; FIXME: The data for this error is not right.
(decoding-error (vector octet) :eucjp seq i
nil 'end-of-input-in-character)
(return (values (1+ nchars) end)))
(t
(setq nchars (1+ nchars)
i next-i)
(when (and (plusp max) (= nchars max))
(return (values nchars i))))))
finally (progn (assert (= i end))
(return (values nchars i))))))
(define-encoder :eucjp (getter src-type setter dest-type)
`(named-lambda eucjp-encoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i)
for eucjp of-type code-point
= (ucs-to-eucjp code) do
(macrolet ((set-octet (offset value)
`(,',setter ,value dest (the fixnum (+ di ,offset)))))
(cond
;; 1 octet
((< eucjp #x100)
(set-octet 0 eucjp)
(incf di))
;; 2 octets
((< eucjp #x10000)
(set-octet 0 (f-logand #xff (f-ash eucjp -8)))
(set-octet 1 (logand eucjp #xff))
(incf di 2))
;; 3 octets
(t
(set-octet 0 (f-logand #xff (f-ash eucjp -16)))
(set-octet 1 (f-logand #xff (f-ash eucjp -8)))
(set-octet 2 (logand eucjp #xff))
(incf di 3))
))
finally (return (the fixnum (- di d-start))))))
(define-decoder :eucjp (getter src-type setter dest-type)
`(named-lambda eucjp-decoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((u2 0))
(declare (type ub8 u2))
(loop for di fixnum from d-start
for i fixnum from start below end
for u1 of-type ub8 = (,getter src i) do
;; Note: CONSUME-OCTET doesn't check if I is being
;; incremented past END. We're assuming that END has
;; been calculated with the CODE-POINT-POINTER above that
;; checks this.
(macrolet
((consume-octet ()
`(let ((next-i (incf i)))
(if (= next-i end)
;; FIXME: data for this error is incomplete.
;; and signalling this error twice
(return-from setter-block
(decoding-error nil :eucjp src i +repl+
'end-of-input-in-character))
(,',getter src next-i))))
(handle-error (n &optional (c 'character-decoding-error))
`(decoding-error
(vector ,@(subseq '(u1 u2) 0 n))
:eucjp src (1+ (- i ,n)) +repl+ ',c))
(handle-error-if-icb (var n)
`(when (not (< #x7f ,var #xc0))
(decf i)
(return-from setter-block
(handle-error ,n invalid-utf8-continuation-byte)))))
(,setter
(block setter-block
(cond
;; 3 octets
((= u1 #x8f)
(setq u2 (consume-octet))
(eucjp-to-ucs (logior #x8f0000
(f-ash u2 8)
(consume-octet))))
;; 2 octets
((or (= u1 #x8e)
(< #xa0 u1 #xff))
(eucjp-to-ucs (logior (f-ash u1 8)
(consume-octet))))
;; 1 octet
(t
(eucjp-to-ucs u1))))
dest di))
finally (return (the fixnum (- di d-start)))))))
;;;; CP932
(define-character-encoding :cp932
"An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 bytes."
:max-units-per-char 2
:literal-char-code-limit #x80)
(define-octet-counter :cp932 (getter type)
`(named-lambda cp932-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i)
do (let* ((c (ucs-to-cp932 code))
(new (+ (cond ((< #xff c) 2)
(t 1))
noctets)))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(define-code-point-counter :cp932 (getter type)
`(named-lambda cp932-code-point-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with nchars fixnum = 0
with i fixnum = start
while (< i end) do
(let* ((octet (,getter seq i))
(next-i (+ i (cond ((or (<= #x81 octet #x9f)
(<= #xe0 octet #xfc))
2)
(t 1)))))
(declare (type ub8 octet) (fixnum next-i))
(cond ((> next-i end)
;; Should we add restarts to this error, we'll have
;; to figure out a way to communicate with the
;; decoder since we probably want to do something
;; about it right here when we have a chance to
;; change the count or something. (Like an
;; alternative replacement character or perhaps the
;; existence of this error so that the decoder
;; doesn't have to check for it on every iteration
;; like we do.)
;;
;; FIXME: The data for this error is not right.
(decoding-error (vector octet) :cp932 seq i
nil 'end-of-input-in-character)
(return (values (1+ nchars) end)))
(t
(setq nchars (1+ nchars)
i next-i)
(when (and (plusp max) (= nchars max))
(return (values nchars i))))))
finally (progn (assert (= i end))
(return (values nchars i))))))
(define-encoder :cp932 (getter src-type setter dest-type)
`(named-lambda cp932-encoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i)
for cp932 of-type code-point
= (ucs-to-cp932 code) do
(macrolet ((set-octet (offset value)
`(,',setter ,value dest (the fixnum (+ di ,offset)))))
(cond
;; 1 octet
((< cp932 #x100)
(set-octet 0 cp932)
(incf di))
;; 2 octets
((< cp932 #x10000)
(set-octet 0 (f-logand #xff (f-ash cp932 -8)))
(set-octet 1 (logand cp932 #xff))
(incf di 2))
;; 3 octets
(t
(set-octet 0 (f-logand #xff (f-ash cp932 -16)))
(set-octet 1 (f-logand #xff (f-ash cp932 -8)))
(set-octet 2 (logand cp932 #xff))
(incf di 3))
))
finally (return (the fixnum (- di d-start))))))
(define-decoder :cp932 (getter src-type setter dest-type)
`(named-lambda cp932-decoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((u2 0))
(declare (type ub8 u2))
(loop for di fixnum from d-start
for i fixnum from start below end
for u1 of-type ub8 = (,getter src i) do
;; Note: CONSUME-OCTET doesn't check if I is being
;; incremented past END. We're assuming that END has
;; been calculated with the CODE-POINT-POINTER above that
;; checks this.
(macrolet
((consume-octet ()
`(let ((next-i (incf i)))
(if (= next-i end)
;; FIXME: data for this error is incomplete.
;; and signalling this error twice
(return-from setter-block
(decoding-error nil :cp932 src i +repl+
'end-of-input-in-character))
(,',getter src next-i))))
(handle-error (n &optional (c 'character-decoding-error))
`(decoding-error
(vector ,@(subseq '(u1 u2) 0 n))
:cp932 src (1+ (- i ,n)) +repl+ ',c))
(handle-error-if-icb (var n)
`(when (not (< #x7f ,var #xc0))
(decf i)
(return-from setter-block
(handle-error ,n invalid-utf8-continuation-byte)))))
(,setter
(block setter-block
(cond
;; 2 octets
((or (<= #x81 u1 #x9f)
(<= #xe0 u1 #xfc))
(setq u2 (consume-octet))
(cp932-to-ucs (logior (f-ash u1 8)
u2)))
;; 1 octet
(t
(cp932-to-ucs u1))))
dest di))
finally (return (the fixnum (- di d-start)))))))

577
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-koi8.lisp Normal file
View file

@ -0,0 +1,577 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-cp1251.lisp --- Implementation of the CP1251 character encoding.
;;;
;;; Copyright (C) 2009, Andrey Moskvitin
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
(define-character-encoding :koi8-ru
"An 8-bit, fixed-width character Russian encoding."
:literal-char-code-limit #x80)
(define-constant +koi8-ru-to-unicode+
#(#x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
#x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
#x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
#x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
#x2550 #x2551 #x2552 #x0451 #x0454 #x2554 #x0456 #x0457
#x2557 #x2558 #x2559 #x255A #x255B #x0491 #x045E #x255E
#x255F #x2560 #x2561 #x0401 #x0404 #x2563 #x0406 #x0407
#x2566 #x2567 #x2568 #x2569 #x256A #x0490 #x040E #x00A9
#x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
#x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
#x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
#x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
#x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
#x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
#x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
#x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A)
:test #'equalp)
(define-unibyte-decoder :koi8-ru (octet)
(if (< octet #x80)
octet
(svref +koi8-ru-to-unicode+ (the ub8 (- octet #x80)))))
(define-constant +unicode-04->koi8-ru+
#(#x7f #x79 #x78 #x7c #x60 #x71 #x41 #x42 #x57 #x47 #x44 #x45 #x56 #x5a
#x49 #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x52 #x53 #x54 #x55 #x46 #x48
#x43 #x5e #x5b #x5d #x5f #x59 #x58 #x5c #x40 #x51 nil #x23 nil nil #x24
nil #x26 #x27 nil nil nil nil nil nil #x2e nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil #x3d #x2d)
:test 'equalp)
(define-unibyte-encoder :koi8-ru (code)
(or (and (< code #x80) code)
(let ((hi (ldb (byte 8 8) code))
(lo (ldb (byte 8 0) code)))
(case hi
(#x4
(case lo
(#x1 #xb3)
(#x4 #xb4)
(#x6 #xb6)
(#x7 #xb7)
(#xe #xbe)
(#x10 #xe1)
(#x11 #xe2)
(#x12 #xf7)
(#x13 #xe7)
(#x14 #xe4)
(#x15 #xe5)
(#x16 #xf6)
(#x17 #xfa)
(#x18 #xe9)
(#x19 #xea)
(#x1a #xeb)
(#x1b #xec)
(#x1c #xed)
(#x1d #xee)
(#x1e #xef)
(#x1f #xf0)
(#x20 #xf2)
(#x21 #xf3)
(#x22 #xf4)
(#x23 #xf5)
(#x24 #xe6)
(#x25 #xe8)
(#x26 #xe3)
(#x27 #xfe)
(#x28 #xfb)
(#x29 #xfd)
(#x2a #xff)
(#x2b #xf9)
(#x2c #xf8)
(#x2d #xfc)
(#x2e #xe0)
(#x2f #xf1)
(#x30 #xc1)
(#x31 #xc2)
(#x32 #xd7)
(#x33 #xc7)
(#x34 #xc4)
(#x35 #xc5)
(#x36 #xd6)
(#x37 #xda)
(#x38 #xc9)
(#x39 #xca)
(#x3a #xcb)
(#x3b #xcc)
(#x3c #xcd)
(#x3d #xce)
(#x3e #xcf)
(#x3f #xd0)
(#x40 #xd2)
(#x41 #xd3)
(#x42 #xd4)
(#x43 #xd5)
(#x44 #xc6)
(#x45 #xc8)
(#x46 #xc3)
(#x47 #xde)
(#x48 #xdb)
(#x49 #xdd)
(#x4a #xdf)
(#x4b #xd9)
(#x4c #xd8)
(#x4d #xdc)
(#x4e #xc0)
(#x4f #xd1)
(#x51 #xa3)
(#x54 #xa4)
(#x56 #xa6)
(#x57 #xa7)
(#x5e #xae)
(#x90 #xbd)
(#x91 #xad)))
(#x0
(case lo
(#xa0 #x9a)
(#xa9 #xbf)
(#xb0 #x9c)
(#xb2 #x9d)
(#xb7 #x9e)
(#xf7 #x9f)))
(#x22 (case lo (#x19 #x95) (#x1a #x96) (#x48 #x97) (#x64 #x98) (#x65 #x99)))
(#x23 (case lo (#x20 #x93) (#x21 #x9b)))
(#x25
(case lo
(#x0 #x80)
(#x2 #x81)
(#xc #x82)
(#x10 #x83)
(#x14 #x84)
(#x18 #x85)
(#x1c #x86)
(#x24 #x87)
(#x2c #x88)
(#x34 #x89)
(#x3c #x8a)
(#x50 #xa0)
(#x51 #xa1)
(#x52 #xa2)
(#x54 #xa5)
(#x57 #xa8)
(#x58 #xa9)
(#x59 #xaa)
(#x5a #xab)
(#x5b #xac)
(#x5e #xaf)
(#x5f #xb0)
(#x60 #xb1)
(#x61 #xb2)
(#x63 #xb5)
(#x66 #xb8)
(#x67 #xb9)
(#x68 #xba)
(#x69 #xbb)
(#x6a #xbc)
(#x80 #x8b)
(#x84 #x8c)
(#x88 #x8d)
(#x8c #x8e)
(#x90 #x8f)
(#x91 #x90)
(#x92 #x91)
(#x93 #x92)
(#xa0 #x94)))))
(handle-error)))
(define-character-encoding :koi8-r
"An 8-bit, fixed-width character Russian encoding."
:literal-char-code-limit #x80)
(define-constant +koi8-r-to-unicode+
#(#x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
#x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
#x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
#x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
#x2550 #x2551 #x2552 #x0451 #x2553 #x2554 #x2555 #x2556
#x2557 #x2558 #x2559 #x255A #x255B #x255C #x255D #x255E
#x255F #x2560 #x2561 #x0401 #x2562 #x2563 #x2564 #x2565
#x2566 #x2567 #x2568 #x2569 #x256A #x256B #x256C #x00A9
#x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
#x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
#x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
#x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
#x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
#x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
#x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
#x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A)
:test #'equalp)
(define-unibyte-decoder :koi8-r (octet)
(if (< octet #x80)
octet
(svref +koi8-r-to-unicode+ (the ub8 (- octet #x80)))))
(define-constant +unicode-x04->koi8-r+
#(nil #x33 nil nil nil nil nil nil nil nil nil nil nil nil nil nil #x61
#x62 #x77 #x67 #x64 #x65 #x76 #x7a #x69 #x6a #x6b #x6c #x6d #x6e #x6f
#x70 #x72 #x73 #x74 #x75 #x66 #x68 #x63 #x7e #x7b #x7d #x7f #x79 #x78
#x7c #x60 #x71 #x41 #x42 #x57 #x47 #x44 #x45 #x56 #x5a #x49 #x4a #x4b
#x4c #x4d #x4e #x4f #x50 #x52 #x53 #x54 #x55 #x46 #x48 #x43 #x5e #x5b
#x5d #x5f #x59 #x58 #x5c #x40 #x51 nil #x23)
:test 'equalp)
(define-constant +unicode-x25->koi8-r+
#(#x0 nil #x1 nil nil nil nil nil nil nil nil nil #x2 nil nil nil #x3 nil
nil nil #x4 nil nil nil #x5 nil nil nil #x6 nil nil nil nil nil nil nil
#x7 nil nil nil nil nil nil nil #x8 nil nil nil nil nil nil nil #x9 nil
nil nil nil nil nil nil #xa nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil #x20 #x21 #x22 #x24 #x25 #x26 #x27 #x28
#x29 #x2a #x2b #x2c #x2d #x2e #x2f #x30 #x31 #x32 #x34 #x35 #x36 #x37
#x38 #x39 #x3a #x3b #x3c #x3d #x3e nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil #xb nil nil nil #xc nil nil nil
#xd nil nil nil #xe nil nil nil #xf #x10 #x11 #x12 nil nil nil nil nil
nil nil nil nil nil nil nil #x14)
:test 'equalp)
(define-unibyte-encoder :koi8-r (code)
(or (and (< code #x80) code)
(let ((hi (ldb (byte 8 8) code))
(lo (ldb (byte 8 0) code)))
(case hi
(#x4
(case lo
(#x1 #xb3)
(#x10 #xe1)
(#x11 #xe2)
(#x12 #xf7)
(#x13 #xe7)
(#x14 #xe4)
(#x15 #xe5)
(#x16 #xf6)
(#x17 #xfa)
(#x18 #xe9)
(#x19 #xea)
(#x1a #xeb)
(#x1b #xec)
(#x1c #xed)
(#x1d #xee)
(#x1e #xef)
(#x1f #xf0)
(#x20 #xf2)
(#x21 #xf3)
(#x22 #xf4)
(#x23 #xf5)
(#x24 #xe6)
(#x25 #xe8)
(#x26 #xe3)
(#x27 #xfe)
(#x28 #xfb)
(#x29 #xfd)
(#x2a #xff)
(#x2b #xf9)
(#x2c #xf8)
(#x2d #xfc)
(#x2e #xe0)
(#x2f #xf1)
(#x30 #xc1)
(#x31 #xc2)
(#x32 #xd7)
(#x33 #xc7)
(#x34 #xc4)
(#x35 #xc5)
(#x36 #xd6)
(#x37 #xda)
(#x38 #xc9)
(#x39 #xca)
(#x3a #xcb)
(#x3b #xcc)
(#x3c #xcd)
(#x3d #xce)
(#x3e #xcf)
(#x3f #xd0)
(#x40 #xd2)
(#x41 #xd3)
(#x42 #xd4)
(#x43 #xd5)
(#x44 #xc6)
(#x45 #xc8)
(#x46 #xc3)
(#x47 #xde)
(#x48 #xdb)
(#x49 #xdd)
(#x4a #xdf)
(#x4b #xd9)
(#x4c #xd8)
(#x4d #xdc)
(#x4e #xc0)
(#x4f #xd1)
(#x51 #xa3)))
(#x0
(case lo
(#xa0 #x9a)
(#xa9 #xbf)
(#xb0 #x9c)
(#xb2 #x9d)
(#xb7 #x9e)
(#xf7 #x9f)))
(#x22 (case lo (#x19 #x95) (#x1a #x96) (#x48 #x97) (#x64 #x98) (#x65 #x99)))
(#x23 (case lo (#x20 #x93) (#x21 #x9b)))
(#x25
(case lo
(#x0 #x80)
(#x2 #x81)
(#xc #x82)
(#x10 #x83)
(#x14 #x84)
(#x18 #x85)
(#x1c #x86)
(#x24 #x87)
(#x2c #x88)
(#x34 #x89)
(#x3c #x8a)
(#x50 #xa0)
(#x51 #xa1)
(#x52 #xa2)
(#x53 #xa4)
(#x54 #xa5)
(#x55 #xa6)
(#x56 #xa7)
(#x57 #xa8)
(#x58 #xa9)
(#x59 #xaa)
(#x5a #xab)
(#x5b #xac)
(#x5c #xad)
(#x5d #xae)
(#x5e #xaf)
(#x5f #xb0)
(#x60 #xb1)
(#x61 #xb2)
(#x62 #xb4)
(#x63 #xb5)
(#x64 #xb6)
(#x65 #xb7)
(#x66 #xb8)
(#x67 #xb9)
(#x68 #xba)
(#x69 #xbb)
(#x6a #xbc)
(#x6b #xbd)
(#x6c #xbe)
(#x80 #x8b)
(#x84 #x8c)
(#x88 #x8d)
(#x8c #x8e)
(#x90 #x8f)
(#x91 #x90)
(#x92 #x91)
(#x93 #x92)
(#xa0 #x94)))))
(handle-error)))
(define-character-encoding :koi8-u
"An 8-bit, fixed-width character Ukranian encoding."
:literal-char-code-limit #x80)
(define-constant +koi8-u-to-unicode+
#(#x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
#x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
#x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
#x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
#x2550 #x2551 #x2552 #x0451 #x0454 #x2554 #x0456 #x0457
#x2557 #x2558 #x2559 #x255A #x255B #x0491 #x255D #x255E
#x255F #x2560 #x2561 #x0401 #x0404 #x2563 #x0406 #x0407
#x2566 #x2567 #x2568 #x2569 #x256A #x0490 #x256C #x00A9
#x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
#x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
#x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
#x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
#x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
#x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
#x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
#x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A )
:test #'equalp)
(define-unibyte-decoder :koi8-u (octet)
(if (< octet #x80)
octet
(svref +koi8-u-to-unicode+ (the ub8 (- octet #x80)))))
(define-constant +unicode-x04->koi8-u+
#(nil #x33 nil nil #x34 nil #x36 #x37 nil nil nil nil nil nil nil nil #x61
#x62 #x77 #x67 #x64 #x65 #x76 #x7a #x69 #x6a #x6b #x6c #x6d #x6e #x6f
#x70 #x72 #x73 #x74 #x75 #x66 #x68 #x63 #x7e #x7b #x7d #x7f #x79 #x78
#x7c #x60 #x71 #x41 #x42 #x57 #x47 #x44 #x45 #x56 #x5a #x49 #x4a #x4b
#x4c #x4d #x4e #x4f #x50 #x52 #x53 #x54 #x55 #x46 #x48 #x43 #x5e #x5b
#x5d #x5f #x59 #x58 #x5c #x40 #x51 nil #x23 nil nil #x24 nil #x26 #x27
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil #x3d #x2d)
:test 'equalp)
(define-constant +unicode-x25->koi8-u+
#(#x0 nil #x1 nil nil nil nil nil nil nil nil nil #x2 nil nil nil #x3 nil
nil nil #x4 nil nil nil #x5 nil nil nil #x6 nil nil nil nil nil nil nil
#x7 nil nil nil nil nil nil nil #x8 nil nil nil nil nil nil nil #x9 nil
nil nil nil nil nil nil #xa nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil #x20 #x21 #x22 nil #x25 nil nil #x28
#x29 #x2a #x2b #x2c nil #x2e #x2f #x30 #x31 #x32 nil #x35 nil nil #x38
#x39 #x3a #x3b #x3c nil #x3e nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil #xb nil nil nil #xc nil nil nil #xd nil
nil nil #xe nil nil nil #xf #x10 #x11 #x12 nil nil nil nil nil nil nil
nil nil nil nil nil #x14)
:test 'equalp)
(define-unibyte-encoder :koi8-u (code)
(or (and (< code #x80) code)
(let ((hi (ldb (byte 8 8) code))
(lo (ldb (byte 8 0) code)))
(case hi
(#x4
(case lo
(#x1 #xb3)
(#x4 #xb4)
(#x6 #xb6)
(#x7 #xb7)
(#x10 #xe1)
(#x11 #xe2)
(#x12 #xf7)
(#x13 #xe7)
(#x14 #xe4)
(#x15 #xe5)
(#x16 #xf6)
(#x17 #xfa)
(#x18 #xe9)
(#x19 #xea)
(#x1a #xeb)
(#x1b #xec)
(#x1c #xed)
(#x1d #xee)
(#x1e #xef)
(#x1f #xf0)
(#x20 #xf2)
(#x21 #xf3)
(#x22 #xf4)
(#x23 #xf5)
(#x24 #xe6)
(#x25 #xe8)
(#x26 #xe3)
(#x27 #xfe)
(#x28 #xfb)
(#x29 #xfd)
(#x2a #xff)
(#x2b #xf9)
(#x2c #xf8)
(#x2d #xfc)
(#x2e #xe0)
(#x2f #xf1)
(#x30 #xc1)
(#x31 #xc2)
(#x32 #xd7)
(#x33 #xc7)
(#x34 #xc4)
(#x35 #xc5)
(#x36 #xd6)
(#x37 #xda)
(#x38 #xc9)
(#x39 #xca)
(#x3a #xcb)
(#x3b #xcc)
(#x3c #xcd)
(#x3d #xce)
(#x3e #xcf)
(#x3f #xd0)
(#x40 #xd2)
(#x41 #xd3)
(#x42 #xd4)
(#x43 #xd5)
(#x44 #xc6)
(#x45 #xc8)
(#x46 #xc3)
(#x47 #xde)
(#x48 #xdb)
(#x49 #xdd)
(#x4a #xdf)
(#x4b #xd9)
(#x4c #xd8)
(#x4d #xdc)
(#x4e #xc0)
(#x4f #xd1)
(#x51 #xa3)
(#x54 #xa4)
(#x56 #xa6)
(#x57 #xa7)
(#x90 #xbd)
(#x91 #xad)))
(#x0
(case lo
(#xa0 #x9a)
(#xa9 #xbf)
(#xb0 #x9c)
(#xb2 #x9d)
(#xb7 #x9e)
(#xf7 #x9f)))
(#x22 (case lo (#x19 #x95) (#x1a #x96) (#x48 #x97) (#x64 #x98) (#x65 #x99)))
(#x23 (case lo (#x20 #x93) (#x21 #x9b)))
(#x25
(case lo
(#x0 #x80)
(#x2 #x81)
(#xc #x82)
(#x10 #x83)
(#x14 #x84)
(#x18 #x85)
(#x1c #x86)
(#x24 #x87)
(#x2c #x88)
(#x34 #x89)
(#x3c #x8a)
(#x50 #xa0)
(#x51 #xa1)
(#x52 #xa2)
(#x54 #xa5)
(#x57 #xa8)
(#x58 #xa9)
(#x59 #xaa)
(#x5a #xab)
(#x5b #xac)
(#x5d #xae)
(#x5e #xaf)
(#x5f #xb0)
(#x60 #xb1)
(#x61 #xb2)
(#x63 #xb5)
(#x66 #xb8)
(#x67 #xb9)
(#x68 #xba)
(#x69 #xbb)
(#x6a #xbc)
(#x6c #xbe)
(#x80 #x8b)
(#x84 #x8c)
(#x88 #x8d)
(#x8c #x8e)
(#x90 #x8f)
(#x91 #x90)
(#x92 #x91)
(#x93 #x92)
(#xa0 #x94)))))
(handle-error)))

881
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/enc-unicode.lisp Normal file
View file

@ -0,0 +1,881 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enc-unicode.lisp --- Unicode encodings.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;; This implementation is largely based on OpenMCL's l1-unicode.lisp
;;; Copyright (C) 2006 Clozure Associates and contributors.
(in-package #:babel-encodings)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +repl+ #xfffd "Unicode replacement character code point.")
(defconstant +byte-order-mark-code+ #xfeff)
(defconstant +swapped-byte-order-mark-code+ #xfffe)
(defconstant +swapped-byte-order-mark-code-32+ #xfffe0000))
;;; Some convenience macros adding FIXNUM declarations.
(defmacro f-ash (integer count) `(the fixnum (ash ,integer ,count)))
(defmacro f-logior (&rest integers) `(the fixnum (logior ,@integers)))
(defmacro f-logand (&rest integers) `(the fixnum (logand ,@integers)))
(defmacro f-logxor (&rest integers) `(the fixnum (logxor ,@integers)))
;;;; UTF-8
(define-character-encoding :utf-8
"An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 to 4 bytes."
:max-units-per-char 4
:literal-char-code-limit #x80
:bom-encoding #(#xef #xbb #xbf)
:default-replacement #xfffd)
(define-condition invalid-utf8-starter-byte (character-decoding-error)
()
(:documentation "Signalled when an invalid UTF-8 starter byte is found."))
(define-condition invalid-utf8-continuation-byte (character-decoding-error)
()
(:documentation
"Signalled when an invalid UTF-8 continuation byte is found."))
(define-condition overlong-utf8-sequence (character-decoding-error)
()
(:documentation "Signalled upon overlong UTF-8 sequences."))
(define-octet-counter :utf-8 (getter type)
`(named-lambda utf-8-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i) do
(let ((new (+ (cond ((< code #x80) 1)
((< code #x800) 2)
((< code #x10000) 3)
(t 4))
noctets)))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(define-code-point-counter :utf-8 (getter type)
`(named-lambda utf-8-code-point-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with nchars fixnum = 0
with i fixnum = start
while (< i end) do
;; check for invalid continuation bytes
(macrolet ((invalid-cb-p (n)
`(and (< (+ i ,n) end)
(not (< #x7f (,',getter seq (+ i ,n)) #xc0)))))
;; wrote this code with LET instead of FOR because CLISP's
;; LOOP doesn't like WHILE clauses before FOR clauses.
(let* ((octet (,getter seq i))
(next-i (+ i (cond ((or (< octet #xc0) (invalid-cb-p 1)) 1)
((or (< octet #xe0) (invalid-cb-p 2)) 2)
((or (< octet #xf0) (invalid-cb-p 3)) 3)
((or (< octet #xf8) (invalid-cb-p 4)) 4)
((or (< octet #xfc) (invalid-cb-p 5)) 5)
(t 6)))))
(declare (type ub8 octet) (fixnum next-i))
(cond
((> next-i end)
;; Should we add restarts to this error, we'll have
;; to figure out a way to communicate with the
;; decoder since we probably want to do something
;; about it right here when we have a chance to
;; change the count or something. (Like an
;; alternative replacement character or perhaps the
;; existence of this error so that the decoder
;; doesn't have to check for it on every iteration
;; like we do.)
;;
;; FIXME: The data for this error is not right.
(decoding-error (vector octet) :utf-8 seq i
nil 'end-of-input-in-character)
(return (values (1+ nchars) end)))
(t
(setq nchars (1+ nchars)
i next-i)
(when (and (plusp max) (= nchars max))
(return (values nchars i)))))))
finally (progn
(assert (= i end))
(return (values nchars i))))))
(define-encoder :utf-8 (getter src-type setter dest-type)
`(named-lambda utf-8-encoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i) do
(macrolet ((set-octet (offset value)
`(,',setter ,value dest (the fixnum (+ di ,offset)))))
(cond
;; 1 octet
((< code #x80)
(set-octet 0 code)
(incf di))
;; 2 octets
((< code #x800)
(set-octet 0 (logior #xc0 (f-ash code -6)))
(set-octet 1 (logior #x80 (f-logand code #x3f)))
(incf di 2))
;; 3 octets
((< code #x10000)
(set-octet 0 (logior #xe0 (f-ash code -12)))
(set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -6))))
(set-octet 2 (logior #x80 (f-logand code #x3f)))
(incf di 3))
;; 4 octets
(t
(set-octet 0 (logior #xf0 (f-logand #x07 (f-ash code -18))))
(set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -12))))
(set-octet 2 (logior #x80 (f-logand #x3f (f-ash code -6))))
(set-octet 3 (logior #x80 (logand code #x3f)))
(incf di 4))))
finally (return (the fixnum (- di d-start))))))
(define-decoder :utf-8 (getter src-type setter dest-type)
`(named-lambda utf-8-decoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((u2 0) (u3 0) (u4 0) (u5 0) (u6 0))
(declare (type ub8 u2 u3 u4 u5 u6))
(loop for di fixnum from d-start
for i fixnum from start below end
for u1 of-type ub8 = (,getter src i) do
;; Note: CONSUME-OCTET doesn't check if I is being
;; incremented past END. We're assuming that END has
;; been calculated with the CODE-POINT-POINTER above that
;; checks this.
(macrolet
((consume-octet ()
`(let ((next-i (incf i)))
(if (= next-i end)
;; FIXME: data for this error is incomplete.
;; and signalling this error twice
(return-from setter-block
(decoding-error nil :utf-8 src i +repl+
'end-of-input-in-character))
(,',getter src next-i))))
(handle-error (n &optional (c 'character-decoding-error))
`(decoding-error
(vector ,@(subseq '(u1 u2 u3 u4 u5 u6) 0 n))
:utf-8 src (1+ (- i ,n)) +repl+ ',c))
(handle-error-if-icb (var n)
`(when (not (< #x7f ,var #xc0))
(decf i)
(return-from setter-block
(handle-error ,n invalid-utf8-continuation-byte)))))
(,setter
(block setter-block
(cond
((< u1 #x80) u1) ; 1 octet
((< u1 #xc0)
(handle-error 1 invalid-utf8-starter-byte))
(t
(setq u2 (consume-octet))
(handle-error-if-icb u2 1)
(cond
((< u1 #xc2)
(handle-error 2 overlong-utf8-sequence))
((< u1 #xe0) ; 2 octets
(logior (f-ash (f-logand #x1f u1) 6)
(f-logxor u2 #x80)))
(t
(setq u3 (consume-octet))
(handle-error-if-icb u3 2)
(cond
((and (= u1 #xe0) (< u2 #xa0))
(handle-error 3 overlong-utf8-sequence))
((< u1 #xf0) ; 3 octets
(let ((start (f-logior (f-ash (f-logand u1 #x0f) 12)
(f-ash (f-logand u2 #x3f) 6))))
(if (<= #xd800 start #xdfc0)
(handle-error 3 character-out-of-range)
(logior start (f-logand u3 #x3f)))))
(t ; 4 octets
(setq u4 (consume-octet))
(handle-error-if-icb u4 3)
(cond
((and (= u1 #xf0) (< u2 #x90))
(handle-error 4 overlong-utf8-sequence))
((< u1 #xf8)
(if (or (> u1 #xf4) (and (= u1 #xf4) (> u2 #x8f)))
(handle-error 4 character-out-of-range)
(f-logior (f-ash (f-logand u1 7) 18)
(f-ash (f-logxor u2 #x80) 12)
(f-ash (f-logxor u3 #x80) 6)
(f-logxor u4 #x80))))
;; from here on we'll be getting either
;; invalid continuation bytes or overlong
;; 5-byte or 6-byte sequences.
(t
(setq u5 (consume-octet))
(handle-error-if-icb u5 4)
(cond
((and (= u1 #xf8) (< u2 #x88))
(handle-error 5 overlong-utf8-sequence))
((< u1 #xfc)
(handle-error 5 character-out-of-range))
(t
(setq u6 (consume-octet))
(handle-error-if-icb u6 5)
(cond
((and (= u1 #xfc) (< u2 #x84))
(handle-error 6 overlong-utf8-sequence))
(t
(handle-error 6 character-out-of-range)
)))))))))))))
dest di))
finally (return (the fixnum (- di d-start)))))))
;;;; UTF-8B
;;; The following excerpt from a linux-utf8 message by Markus Kuhn is
;;; the closest thing to a UTF-8B specification:
;;;
;;; <http://mail.nl.linux.org/linux-utf8/2000-07/msg00040.html>
;;;
;;; "D) Emit a malformed UTF-16 sequence for every byte in a malformed
;;; UTF-8 sequence
;;;
;;; All the previous options for converting malformed UTF-8 sequences
;;; to UTF-16 destroy information. This can be highly undesirable in
;;; applications such as text file editors, where guaranteed binary
;;; transparency is a desireable feature. (E.g., I frequently edit
;;; executable code or graphic files with the Emacs text editor and I
;;; hate the idea that my editor might automatically make U+FFFD
;;; substitutions at locations that I haven't even edited when I save
;;; the file again.)
;;;
;;; I therefore suggested 1999-11-02 on the unicode@xxxxxxxxxxx
;;; mailing list the following approach. Instead of using U+FFFD,
;;; simply encode malformed UTF-8 sequences as malformed UTF-16
;;; sequences. Malformed UTF-8 sequences consist excludively of the
;;; bytes 0x80 - 0xff, and each of these bytes can be represented
;;; using a 16-bit value from the UTF-16 low-half surrogate zone
;;; U+DC80 to U+DCFF. Thus, the overlong "K" (U+004B) 0xc1 0x8b from
;;; the above example would be represented in UTF-16 as U+DCC1
;;; U+DC8B. If we simply make sure that every UTF-8 encoded surrogate
;;; character is also treated like a malformed sequence, then there
;;; is no way that a single high-half surrogate could precede the
;;; encoded malformed sequence and cause a valid UTF-16 sequence to
;;; emerge.
;;;
;;; This way 100% binary transparent UTF-8 -> UTF-16 -> UTF-8
;;; round-trip compatibility can be achieved quite easily.
;;;
;;; On an output device, a lonely low-half surrogate character should
;;; be treated just like a character outside the adopted subset of
;;; representable characters, that is for the end user, the display
;;; would look exactly like with semantics B), i.e. one symbol per
;;; byte of a malformed sequence. However in contrast to semantics
;;; B), no information is thrown away, and a cut&paste in an editor
;;; or terminal emulator will be guaranteed to reconstruct the
;;; original byte sequence. This should greatly reduce the incidence
;;; of accidental corruption of binary data by UTF-8 -> UTF-16 ->
;;; UTF-8 conversion round trips."
(define-character-encoding :utf-8b
"An 8-bit, variable-length character encoding in which
character code points in the range #x00-#x7f can be encoded in a
single octet; characters with larger code values can be encoded
in 2 to 4 bytes. Invalid UTF-8 sequences are encoded with #xDCXX
code points for each invalid byte."
:max-units-per-char 4
:literal-char-code-limit #x80
:bom-encoding #(#xef #xbb #xbf)
:default-replacement nil)
;;; TODO: reuse the :UTF-8 octet counter through a simple macro.
(define-octet-counter :utf-8b (getter type)
`(named-lambda utf-8b-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i) do
(let ((new (+ (cond ((< code #x80) 1)
((< code #x800) 2)
((<= #xdc80 code #xdcff) 1)
((< code #x10000) 3)
(t 4))
noctets)))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(define-code-point-counter :utf-8b (getter type)
`(named-lambda utf-8b-code-point-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with nchars fixnum = 0
with i fixnum = start
while (< i end) do
;; wrote this code with LET instead of FOR because CLISP's
;; LOOP doesn't like WHILE clauses before FOR clauses.
(let* ((octet (,getter seq i))
(noctets (cond ((< octet #x80) 1)
((< octet #xe0) 2)
((< octet #xf0) 3)
(t 4))))
(declare (type ub8 octet) (fixnum noctets))
(cond
((> (+ i noctets) end)
;; If this error is suppressed these last few bytes
;; will be encoded as raw bytes later.
(decoding-error (vector octet) :utf-8 seq i
nil 'end-of-input-in-character)
(return (values (+ nchars (- end i)) end)))
(t
;; FIXME: clean this mess up.
(let* ((u1 octet)
(u2 (if (>= noctets 2) (,getter seq (1+ i)) 0))
(u3 (if (>= noctets 3) (,getter seq (+ i 2)) 0))
(u4 (if (= noctets 4) (,getter seq (+ i 3)) 0))
(inc (or (and (> noctets 1)
(< u1 #xc2))
(and (= noctets 2)
(not (logior u2 #x40)))
(and (= noctets 3)
(not (and (< (f-logxor u2 #x80) #x40)
(< (f-logxor u3 #x80) #x40)
(or (>= u1 #xe1) (>= u2 #xa0))
(or (/= u1 #xed) (< u2 #xa0) (> u2 #xbf)))))
(and (= noctets 4)
(not
(and (< (f-logxor u2 #x80) #x40)
(< (f-logxor u3 #x80) #x40)
(< (f-logxor u4 #x80) #x40)
(or (>= u1 #xf1) (>= u2 #x90))))))))
(let ((new-nchars (if inc (+ nchars noctets) (1+ nchars))))
(when (and (plusp max) (> new-nchars max))
(return (values nchars i)))
(incf i noctets)
(setq nchars new-nchars))))))
finally (progn
(assert (= i end))
(return (values nchars i))))))
;;; TODO: reuse the :UTF-8 encoder with through a simple macro.
(define-encoder :utf-8b (getter src-type setter dest-type)
`(named-lambda utf-8b-encoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i) do
(macrolet ((set-octet (offset value)
`(,',setter ,value dest (the fixnum (+ di ,offset)))))
(cond
;; 1 octet
((< code #x80)
(set-octet 0 code)
(incf di))
;; 2 octets
((< code #x800)
(set-octet 0 (logior #xc0 (f-ash code -6)))
(set-octet 1 (logior #x80 (f-logand code #x3f)))
(incf di 2))
;; 1 octet (invalid octet)
((<= #xdc80 code #xdcff)
(set-octet 0 (f-logand code #xff))
(incf di))
;; 3 octets
((< code #x10000)
(set-octet 0 (logior #xe0 (f-ash code -12)))
(set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -6))))
(set-octet 2 (logior #x80 (f-logand code #x3f)))
(incf di 3))
;; 4 octets
(t
(set-octet 0 (logior #xf0 (f-logand #x07 (f-ash code -18))))
(set-octet 1 (logior #x80 (f-logand #x3f (f-ash code -12))))
(set-octet 2 (logior #x80 (f-logand #x3f (f-ash code -6))))
(set-octet 3 (logand #x3f code))
(incf di 4))))
finally (return (the fixnum (- di d-start))))))
(define-decoder :utf-8b (getter src-type setter dest-type)
`(named-lambda utf-8b-decoder (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((u2 0) (u3 0) (u4 0))
(declare (type ub8 u2 u3 u4))
(loop for di fixnum from d-start
for i fixnum from start below end
for u1 of-type ub8 = (,getter src i) do
;; Unlike the UTF-8 version, this version of
;; CONSUME-OCTET needs to check if I is being incremented
;; past END because we might have trailing binary
;; garbage.
(macrolet
((consume-octet (n)
`(if (= i (1- end))
(encode-raw-octets ,n)
(,',getter src (incf i))))
(encode-raw-octets (n)
`(progn
,@(loop for i below n and var in '(u1 u2 u3 u4)
collect `(,',setter (logior #xdc00 ,var) dest di)
unless (= i (1- n))
collect '(incf di))
(return-from set-body))))
(block set-body
(,setter (cond
((< u1 #x80) ; 1 octet
u1)
((>= u1 #xc2)
(setq u2 (consume-octet 1))
(cond
((< u1 #xe0) ; 2 octets
(if (< (f-logxor u2 #x80) #x40)
(logior (f-ash (f-logand #x1f u1) 6)
(f-logxor u2 #x80))
(encode-raw-octets 2)))
(t
(setq u3 (consume-octet 2))
(cond
((< u1 #xf0) ; 3 octets
(if (and (< (f-logxor u2 #x80) #x40)
(< (f-logxor u3 #x80) #x40)
(or (>= u1 #xe1) (>= u2 #xa0)))
(let ((start (f-logior (f-ash (f-logand u1 #x0f) 12)
(f-ash (f-logand u2 #x3f) 6))))
(if (<= #xd800 start #xdfc0)
(encode-raw-octets 3)
(logior start (f-logand u3 #x3f))))
(encode-raw-octets 3)))
(t ; 4 octets
(setq u4 (consume-octet 3))
(if (and (< (f-logxor u2 #x80) #x40)
(< (f-logxor u3 #x80) #x40)
(< (f-logxor u4 #x80) #x40)
(or (>= u1 #xf1) (>= u2 #x90)))
(logior
(f-logior (f-ash (f-logand u1 7) 18)
(f-ash (f-logxor u2 #x80) 12))
(f-logior (f-ash (f-logxor u3 #x80) 6)
(f-logxor u4 #x80)))
(encode-raw-octets 4)))))))
(t (encode-raw-octets 1)))
dest di)))
finally (return (the fixnum (- di d-start)))))))
;;;; UTF-16
;;; TODO: add a way to pass some info at compile-time telling us that,
;;; for example, the maximum code-point will always be < #x10000 in
;;; which case we could simply return (* 2 (- end start)).
(defmacro utf16-octet-counter (getter type)
`(named-lambda utf-16-octet-counter (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(loop with noctets fixnum = 0
for i fixnum from start below end
for code of-type code-point = (,getter seq i)
do (let ((new (the fixnum (+ (if (< code #x10000) 2 4) noctets))))
(if (and (plusp max) (> new max))
(loop-finish)
(setq noctets new)))
finally (return (values noctets i)))))
(defmacro utf-16-combine-surrogate-pairs (u1 u2)
`(the (unsigned-byte 21)
(+ #x10000
(the (unsigned-byte 20)
(logior
(the (unsigned-byte 20)
(ash (the (unsigned-byte 10) (- ,u1 #xd800)) 10))
(the (unsigned-byte 10)
(- ,u2 #xdc00)))))))
(defmacro define-utf-16 (name &optional endianness)
(check-type endianness (or null (eql :be) (eql :le)))
(check-type name keyword)
(let ((swap-var (gensym "SWAP"))
(code-point-counter-name
(format-symbol t '#:~a-code-point-counter (string name)))
(encoder-name (format-symbol t '#:~a-encoder (string name)))
(decoder-name (format-symbol t '#:~a-decoder (string name))))
(labels ((make-bom-check-form (end start getter seq)
(if (null endianness)
``((,',swap-var
(when (> ,,end ,,start)
(case (,,getter ,,seq ,,start 2 :ne)
(#.+byte-order-mark-code+ (incf ,,start 2) nil)
(#.+swapped-byte-order-mark-code+ (incf ,,start 2) t)
(t #+little-endian t)))))
'()))
(make-getter-form (getter src i)
(case endianness
(:le ``(,,getter ,,src ,,i 2 :le))
(:be ``(,,getter ,,src ,,i 2 :be))
(t ``(if ,',swap-var
(,,getter ,,src ,,i 2 :re)
(,,getter ,,src ,,i 2 :ne)))))
(make-setter-form (setter code dest di)
(case endianness
(:be ``(,,setter ,,code ,,dest ,,di 2 :be))
(:le ``(,,setter ,,code ,,dest ,,di 2 :le))
(t ``(,,setter ,,code ,,dest ,,di 2 :ne)))))
`(progn
(define-octet-counter ,name (getter type)
`(utf16-octet-counter ,getter ,type))
(define-code-point-counter ,name (getter type)
`(named-lambda ,',code-point-counter-name (seq start end max)
(declare (type ,type seq) (fixnum start end max))
(let* ,,(make-bom-check-form ''end ''start 'getter ''seq)
(loop with count fixnum = 0
with i fixnum = start
while (<= i (- end 2)) do
(let* ((code ,,(make-getter-form 'getter ''seq ''i))
(next-i (+ i (if (or (< code #xd800) (>= code #xdc00))
2
4))))
(declare (type (unsigned-byte 16) code) (fixnum next-i))
(cond
((> next-i end)
(decoding-error
(vector (,getter seq i) (,getter seq (1+ i)))
,',name seq i nil 'end-of-input-in-character)
(return (values count i)))
(t
(setq i next-i
count (1+ count))
(when (and (plusp max) (= count max))
(return (values count i))))))
finally (progn
(assert (= i end))
(return (values count i)))))))
(define-encoder ,name (getter src-type setter dest-type)
`(named-lambda ,',encoder-name (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop with di fixnum = d-start
for i fixnum from start below end
for code of-type code-point = (,getter src i)
for high-bits fixnum = (- code #x10000) do
(cond ((< high-bits 0)
,,(make-setter-form 'setter ''code ''dest ''di)
(incf di 2))
(t
,,(make-setter-form
'setter ''(logior #xd800 (f-ash high-bits -10))
''dest ''di)
,,(make-setter-form
'setter ''(logior #xdc00 (f-logand high-bits #x3ff))
''dest ''(+ di 2))
(incf di 4)))
finally (return (the fixnum (- di d-start))))))
(define-decoder ,name (getter src-type setter dest-type)
`(named-lambda ,',decoder-name (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ,,(make-bom-check-form ''end ''start 'getter ''src)
(loop with i fixnum = start
for di fixnum from d-start
until (= i end) do
(let ((u1 ,,(make-getter-form 'getter ''src ''i)))
(declare (type (unsigned-byte 16) u1))
(incf i 2)
(,setter (cond
((or (< u1 #xd800) (>= u1 #xe000)) ; 2 octets
u1)
((< u1 #xdc00) ; 4 octets
(let ((u2 ,,(make-getter-form 'getter ''src ''i)))
(declare (type (unsigned-byte 16) u2))
(incf i 2)
(if (and (>= u2 #xdc00) (< u2 #xe000))
(utf-16-combine-surrogate-pairs u1 u2)
(decoding-error
(vector (,getter src (- i 4))
(,getter src (- i 3))
(,getter src (- i 2))
(,getter src (- i 1)))
,',name src i +repl+))))
(t
(decoding-error (vector (,getter src (- i 2))
(,getter src (- i 1)))
,',name src i +repl+)))
dest di))
finally (return (the fixnum (- di d-start)))))))
',name))))
(define-character-encoding :utf-16
"A 16-bit, variable-length encoding in which characters with
code points less than #x10000 can be encoded in a single 16-bit
word and characters with larger codes can be encoded in a pair of
16-bit words. The endianness of the encoded data is indicated by
the endianness of a byte-order-mark character (#\u+feff)
prepended to the data; in the absence of such a character on
input, the data is assumed to be in big-endian order. Output is
written in native byte-order with a leading byte-order mark."
:max-units-per-char 2
:code-unit-size 16
:native-endianness t ; not necessarily true when decoding
:decode-literal-code-unit-limit #xd800
:encode-literal-code-unit-limit #x10000
:use-bom #+big-endian :utf-16be #+little-endian :utf-16le
:bom-encoding #+big-endian #(#xfe #xff) #+little-endian #(#xff #xfe)
:nul-encoding #(0 0)
:default-replacement #xfffd
:ambiguous #+little-endian t #+big-endian nil)
(define-utf-16 :utf-16)
(define-character-encoding :utf-16le
"A 16-bit, variable-length encoding in which characters with
code points less than #x10000 can be encoded in a single 16-bit
word and characters with larger codes can be encoded in a pair of
16-bit words. The data is assumed to be in little-endian order. Output is
written in little-endian byte-order without a leading byte-order mark."
:aliases '(:utf-16/le)
:max-units-per-char 2
:code-unit-size 16
:native-endianness #+little-endian t #+big-endian nil
:decode-literal-code-unit-limit #xd800
:encode-literal-code-unit-limit #x10000
:nul-encoding #(0 0)
:default-replacement #xfffd)
(define-utf-16 :utf-16le :le)
(define-character-encoding :utf-16be
"A 16-bit, variable-length encoding in which characters with
code points less than #x10000 can be encoded in a single 16-bit
word and characters with larger codes can be encoded in a pair of
16-bit words. The data is assumed to be in big-endian order. Output is
written in big-endian byte-order without a leading byte-order mark."
:aliases '(:utf-16/be)
:max-units-per-char 2
:code-unit-size 16
:native-endianness #+little-endian nil #+big-endian t
:decode-literal-code-unit-limit #xd800
:encode-literal-code-unit-limit #x10000
:nul-encoding #(0 0)
:default-replacement #xfffd)
(define-utf-16 :utf-16be :be)
(defmacro define-ucs (name bytes &optional endianness (limit #x110000))
(check-type name keyword)
(check-type bytes (or (eql 2) (eql 4)))
(check-type endianness (or null (eql :le) (eql :be)))
(let ((swap-var (gensym "SWAP"))
(code-point-counter-name
(format-symbol t '#:~a-code-point-counter (string name)))
(encoder-name
(format-symbol t '#:~a-encoder (string name)))
(decoder-name
(format-symbol t '#:~a-decoder (string name))))
(labels ((make-bom-check-form (end start getter src)
(if (null endianness)
``(when (not (zerop (- ,,end ,,start)))
(case (,,getter ,,src 0 ,',bytes :ne)
(#.+byte-order-mark-code+
(incf ,,start ,',bytes) nil)
(#.+swapped-byte-order-mark-code-32+
(incf ,,start ,',bytes) t)
(t #+little-endian t)))
'()))
(make-setter-form (setter code dest di)
``(,,setter ,,code ,,dest ,,di ,',bytes
,',(or endianness :ne)))
(make-getter-form (getter src i)
(if (null endianness)
``(if ,',swap-var
(,,getter ,,src ,,i ,',bytes :re)
(,,getter ,,src ,,i ,',bytes :ne))
``(,,getter ,,src ,,i ,',bytes ,',endianness))))
`(progn
(define-code-point-counter ,name (getter type)
`(named-lambda ,',code-point-counter-name (seq start end max)
(declare (type ,type seq) (fixnum start end max))
;; check for bom
,,(make-bom-check-form ''end ''start 'getter ''seq)
(multiple-value-bind (count rem)
(floor (- end start) ,',bytes)
(cond
((and (plusp max) (> count max))
(values max (the fixnum (+ start (* ,',bytes max)))))
(t
;; check for incomplete last character
(unless (zerop rem)
(let ((vector (make-array ,',bytes :fill-pointer 0)))
(dotimes (i rem)
(vector-push (,getter seq (+ i (- end rem))) vector))
(decoding-error vector ,',name seq (the fixnum (- end rem)) nil
'end-of-input-in-character)
(decf end rem)))
(values count end))))))
(define-encoder ,name (getter src-type setter dest-type)
`(named-lambda ,',encoder-name (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(loop for i fixnum from start below end
and di fixnum from d-start by ,',bytes
for code of-type code-point = (,getter src i)
do (if (>= code ,',limit)
(encoding-error code ,',name src i +repl+)
,,(make-setter-form 'setter ''code ''dest ''di))
finally (return (the fixnum (- di d-start))))))
(define-decoder ,name (getter src-type setter dest-type)
`(named-lambda ,',decoder-name (src start end dest d-start)
(declare (type ,src-type src)
(type ,dest-type dest)
(fixnum start end d-start))
(let ((,',swap-var ,,(make-bom-check-form ''end ''start 'getter ''src)))
(declare (ignorable ,',swap-var))
(loop for i fixnum from start below end by ,',bytes
and di from d-start
do (,setter (let ((unit ,,(make-getter-form 'getter ''src ''i)))
(if (>= unit ,',limit)
(decoding-error
(vector (,getter src i)
(,getter src (+ i 1))
,@,(if (= bytes 4)
``((,getter src (+ i 2))
(,getter src (+ i 3)))))
,',name src i +repl+
'character-out-of-range)
unit))
dest di)
finally (return (the fixnum (- di d-start)))))))
',name))))
;;;; UTF-32
(define-character-encoding :utf-32
"A 32-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 32-bit word. The
endianness of the encoded data is indicated by the endianness of
a byte-order-mark character (#\u+feff) prepended to the data; in
the absence of such a character on input, input data is assumed
to be in big-endian order. Output is written in native byte
order with a leading byte-order mark."
:aliases '(:ucs-4)
:max-units-per-char 1
:code-unit-size 32
:native-endianness t ; not necessarily true when decoding
:literal-char-code-limit #x110000
:use-bom #+little-endian :utf-32le #+big-endian :utf-32be
:bom-encoding
#+big-endian #(#x00 #x00 #xfe #xff)
#+little-endian #(#xff #xfe #x00 #x00)
:nul-encoding #(0 0 0 0)
:ambiguous #+little-endian t #+big-endian nil)
(define-ucs :utf-32 4)
(define-character-encoding :utf-32le
"A 32-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 32-bit word. Input data is assumed
to be in little-endian order. Output is also written in little-endian byte
order without a leading byte-order mark."
:max-units-per-char 1
:code-unit-size 32
:aliases '(:utf-32/le :ucs-4le :ucs-4/le)
:native-endianness #+little-endian t #+big-endian nil
:literal-char-code-limit #x110000
:nul-encoding #(0 0 0 0))
(define-ucs :utf-32le 4 :le)
(define-character-encoding :utf-32be
"A 32-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 32-bit word. Input data is assumed
to be in big-endian order. Output is also written in big-endian byte
order without a leading byte-order mark."
:max-units-per-char 1
:code-unit-size 32
:aliases '(:utf-32/be :ucs-4be :ucs-4/be)
:native-endianness #+little-endian nil #+big-endian t
:literal-char-code-limit #x110000
:nul-encoding #(0 0 0 0))
(define-ucs :utf-32be 4 :be)
;; UCS-2
(define-character-encoding :ucs-2
"A 16-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 16-bit word. The
endianness of the encoded data is indicated by the endianness of
a byte-order-mark character (#\u+feff) prepended to the data; in
the absence of such a character on input, input data is assumed
to be in big-endian order. Output is written in native byte
order with a leading byte-order mark."
:aliases '(:ucs-2)
:max-units-per-char 1
:code-unit-size 16
:native-endianness t ; not necessarily true when decoding
:literal-char-code-limit #x10000
:use-bom #+little-endian :ucs-2le #+big-endian :ucs-2be
:bom-encoding
#+big-endian #(#xfe #xff)
#+little-endian #(#xff #xfe)
:nul-encoding #(0 0)
:ambiguous #+little-endian t #+big-endian nil)
(define-ucs :ucs-2 2 nil #x10000)
(define-character-encoding :ucs-2le
"A 16-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 16-bit word. Input data is assumed
to be in little-endian order. Output is also written in little-endian byte
order without a leading byte-order mark."
:max-units-per-char 1
:code-unit-size 16
:aliases '(:ucs-2/le)
:native-endianness #+little-endian t #+big-endian nil
:literal-char-code-limit #x10000
:nul-encoding #(0 0))
(define-ucs :ucs-2le 2 :le #x10000)
(define-character-encoding :ucs-2be
"A 16-bit, fixed-length encoding in which all Unicode
characters can be encoded in a single 16-bit word. Input data is assumed
to be in big-endian order. Output is also written in big-endian byte
order without a leading byte-order mark."
:max-units-per-char 1
:code-unit-size 16
:aliases '(:ucs-2/be)
:native-endianness #+little-endian nil #+big-endian t
:literal-char-code-limit #x10000
:nul-encoding #(0 0))
(define-ucs :ucs-2be 2 :be #x10000)

503
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/encodings.lisp Normal file
View file

@ -0,0 +1,503 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; encodings.lisp --- Character encodings and mappings.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel-encodings)
;;;; Character Encodings
(defclass character-encoding ()
((name :initarg :name :reader enc-name
:initform (error "Must specify a NAME for this character encoding."))
;; Most of these documentation strings are taken from OpenMCL.
(documentation
:initarg :documentation :reader enc-documentation :initform nil)
;; A non-exhaustive list of aliases for the encoding.
(aliases :initarg :aliases :initform nil :reader enc-aliases)
;; Specified in bits. Usually 8, 16 or 32.
(code-unit-size
:initarg :code-unit-size :reader enc-code-unit-size :initform 8)
(max-units-per-char
:initarg :max-units-per-char :reader enc-max-units-per-char :initform 1)
;; If NIL, it is necessary to swap 16- and 32-bit units.
(native-endianness
:initarg :native-endianness :reader enc-native-endianness :initform t)
;; Code units less than this value map to themselves on input.
(decode-literal-code-unit-limit
:initarg :decode-literal-code-unit-limit :initform 0
:reader enc-decode-literal-code-unit-limit)
;; Code points less than this value map to themselves on output.
(encode-literal-code-unit-limit
:initarg :encode-literal-code-unit-limit :initform 0
:reader enc-encode-literal-code-unit-limit)
;; Defines whether it is necessary to prepend a byte-order-mark to
;; determine the endianness.
(use-bom :initarg :use-bom :initform nil :reader enc-use-bom)
;; How the byte-order-mark should be encoded, specified as a
;; sequence of octets. NIL if it cannot be encoded.
(bom-encoding
:initarg :bom-encoding :reader enc-bom-encoding :initform nil)
;; How should NUL be encoded, specified as sequence of octets.
(nul-encoding
:initarg :nul-encoding :reader enc-nul-encoding :initform #(0))
;; Preferred replacement character code point.
(default-replacement
:initarg :default-replacement :reader enc-default-replacement
:initform #x1a)
;; Does VALID-STRING => OCTETS => STRING2 guarantee a valid
;; STRING2? UTF-{16,32} on little-endian plaforms don't because
;; they assume different endianness on each direction.
(ambiguous
:initarg :ambiguous :reader ambiguous-encoding-p :initform nil)))
;;; I'm too lazy to write all the identical limits twice.
(defmethod initialize-instance :after ((enc character-encoding)
&key literal-char-code-limit)
(when literal-char-code-limit
(setf (slot-value enc 'encode-literal-code-unit-limit)
literal-char-code-limit)
(setf (slot-value enc 'decode-literal-code-unit-limit)
literal-char-code-limit)))
#-(and)
(defmethod describe-object ((enc character-encoding) s)
"Prints out the name, aliases and documentation slots of a
character encoding object."
(with-slots (name aliases documentation) enc
(format s "~&~S" name)
(when aliases
(format s " [Aliases:~{ ~S~}]" aliases))
(format s "~&~A~%~%" documentation))
(call-next-method))
(defvar *supported-character-encodings* nil)
(defun list-character-encodings ()
"List of keyword symbols denoting supported character
encodings. This list does not include aliases."
*supported-character-encodings*)
(defvar *character-encodings* (make-hash-table :test 'eq))
(defvar *default-character-encoding* :utf-8
"Special variable used to determine the default character
encoding.")
(defun get-character-encoding (name)
"Lookups the character encoding denoted by the keyword symbol
NAME. Signals an error if one is not found. If NAME is already
a CHARACTER-ENCONDING object, it is returned unmodified."
(when (typep name 'character-encoding)
(return-from get-character-encoding name))
(when (eq name :default)
(setq name *default-character-encoding*))
(or (gethash name *character-encodings*)
(error "Unknown character encoding: ~S" name)))
(defmethod ambiguous-encoding-p ((encoding symbol))
(ambiguous-encoding-p (get-character-encoding encoding)))
(defun notice-character-encoding (enc)
(pushnew (enc-name enc) *supported-character-encodings*)
(dolist (kw (cons (enc-name enc) (enc-aliases enc)))
(setf (gethash kw *character-encodings*) enc))
(enc-name enc))
(defmacro define-character-encoding (name docstring &body options)
`(notice-character-encoding
(make-instance 'character-encoding :name ,name ,@options
:documentation ,docstring)))
;;;; Mappings
;;; TODO: describe what mappings are
(defun make-fixed-width-counter (getter type &optional (unit-size-in-bits 8))
(declare (ignore getter type))
(check-type unit-size-in-bits positive-fixnum)
(let ((unit-size-in-bytes (/ unit-size-in-bits 8)))
`(named-lambda fixed-width-counter (seq start end max)
(declare (ignore seq) (fixnum start end max))
;; XXX: the result can be bigger than a fixnum when (> unit-size
;; 1) and we don't want that to happen. Possible solution: signal
;; a warning (hmm, make that an actual error) and truncate.
(if (plusp max)
(let ((count (the fixnum (min (floor max ,unit-size-in-bytes)
(the fixnum (- end start))))))
(values (the fixnum (* count ,unit-size-in-bytes))
(the fixnum (+ start count))))
(values (the fixnum (* (the fixnum (- end start))
,unit-size-in-bytes))
(the fixnum end))))))
;;; Useful to develop new encodings incrementally starting with octet
;;; and code-unit counters.
(defun make-dummy-coder (sg st ds dt)
(declare (ignore sg st ds dt))
`(named-lambda dummy-coder (src s e dest i)
(declare (ignore src s e dest i))
(error "this encoder/decoder hasn't been implemented yet")))
;;; TODO: document here
;;;
;;; ENCODER -- (lambda (src-getter src-type dest-setter dest-type) ...)
;;; DECODER -- (lambda (src-getter src-type dest-setter dest-type) ...)
;;;
;;; OCTET-COUNTER -- (lambda (getter type) ...)
;;; CODE-POINT-COUNTER -- (lambda (getter type) ...)
(defclass abstract-mapping ()
((encoder-factory :accessor encoder-factory :initform 'make-dummy-coder)
(decoder-factory :accessor decoder-factory :initform 'make-dummy-coder)
(octet-counter-factory :accessor octet-counter-factory
:initform 'make-fixed-width-counter)
(code-point-counter-factory :accessor code-point-counter-factory
:initform 'make-fixed-width-counter)))
;;; TODO: document these
;;;
;;; ENCODER -- (lambda (src start end dest d-start) ...)
;;; DECODER -- (lambda (src start end dest d-start) ...)
;;;
;;; OCTET-COUNTER -- (lambda (seq start end max-octets) ...)
;;; CODE-POINT-COUNTER -- (lambda (seq start end max-chars) ...)
;;; => N-CHARS NEW-END
;;; (important: describe NEW-END)
(defclass concrete-mapping ()
((encoder :accessor encoder)
(decoder :accessor decoder)
(octet-counter :accessor octet-counter)
(code-point-counter :accessor code-point-counter)))
(defparameter *abstract-mappings* (make-hash-table :test 'eq))
(defun get-abstract-mapping (encoding)
(gethash encoding *abstract-mappings*))
(defun (setf get-abstract-mapping) (value encoding)
(setf (gethash encoding *abstract-mappings*) value))
(defun %register-mapping-part (encoding slot-name fn)
(let ((mapping (get-abstract-mapping encoding)))
(unless mapping
(setq mapping (make-instance 'abstract-mapping))
(setf (get-abstract-mapping encoding) mapping))
(setf (slot-value mapping slot-name) fn)))
;;; See enc-*.lisp for example usages of these 4 macros.
(defmacro define-encoder (encoding (sa st da dt) &body body)
`(%register-mapping-part ,encoding 'encoder-factory
(named-lambda encoder (,sa ,st ,da ,dt)
,@body)))
(defmacro define-decoder (encoding (sa st da dt) &body body)
`(%register-mapping-part ,encoding 'decoder-factory
(named-lambda decoder (,sa ,st ,da ,dt)
,@body)))
(defmacro define-octet-counter (encoding (acc type) &body body)
`(%register-mapping-part ,encoding 'octet-counter-factory
(named-lambda octet-counter-factory (,acc ,type)
,@body)))
(defmacro define-code-point-counter (encoding (acc type) &body body)
`(%register-mapping-part ,encoding 'code-point-counter-factory
(named-lambda code-point-counter (,acc ,type)
,@body)))
(defun instantiate-encoder (encoding am octet-seq-getter octet-seq-type
code-point-seq-setter code-point-seq-type)
(declare (ignore encoding))
(funcall (encoder-factory am)
octet-seq-getter
octet-seq-type
code-point-seq-setter
code-point-seq-type))
(defun instantiate-decoder (encoding am octet-seq-getter octet-seq-type
code-point-seq-setter code-point-seq-type)
(declare (ignore encoding))
(funcall (decoder-factory am)
octet-seq-getter
octet-seq-type
code-point-seq-setter
code-point-seq-type))
(defun instantiate-code-point-counter (encoding am octet-seq-getter
octet-seq-type)
(declare (ignore encoding))
(funcall (code-point-counter-factory am)
octet-seq-getter
octet-seq-type))
(defun instantiate-octet-counter (encoding am code-point-seq-getter
code-point-seq-type)
(if (= 1 (enc-max-units-per-char encoding))
(make-fixed-width-counter code-point-seq-getter code-point-seq-type
(enc-code-unit-size encoding))
(funcall (octet-counter-factory am)
code-point-seq-getter
code-point-seq-type)))
;;; Expands into code generated by the available abstract mappings
;;; that will be compiled into concrete mappings. This is used in
;;; e.g. strings.lisp to define mappings between strings and
;;; (unsigned-byte 8) vectors.
;;;
;;; For each encoding funcall the abstract mappings at macro-expansion
;;; time with the src/dest accessors and types to generate the
;;; appropriate code for the concrete mappings. These functions are
;;; then saved in their respective slots of the CONCRETE-MAPPING
;;; object.
(defmacro instantiate-concrete-mappings
(&key (encodings (hash-table-keys *abstract-mappings*))
(optimize '((speed 3) (debug 0) (compilation-speed 0)))
octet-seq-getter octet-seq-setter octet-seq-type
code-point-seq-getter code-point-seq-setter code-point-seq-type
(instantiate-decoders t))
`(let ((ht (make-hash-table :test 'eq)))
(declare (optimize ,@optimize)
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
(flet ((notice-mapping (encoding-name cm)
(let* ((encoding (get-character-encoding encoding-name))
(aliases (enc-aliases encoding)))
(dolist (kw (cons (enc-name encoding) aliases))
(setf (gethash kw ht) cm)))))
,@(loop for encoding-name in encodings
for encoding = (get-character-encoding encoding-name)
for am = (gethash encoding-name *abstract-mappings*)
collect
`(let ((cm (make-instance 'concrete-mapping)))
(setf (encoder cm)
,(instantiate-encoder encoding am
code-point-seq-getter
code-point-seq-type
octet-seq-setter
octet-seq-type))
,(when instantiate-decoders
`(progn
(setf (decoder cm)
,(instantiate-decoder encoding am
octet-seq-getter
octet-seq-type
code-point-seq-setter
code-point-seq-type))
(setf (code-point-counter cm)
,(instantiate-code-point-counter
encoding am octet-seq-getter octet-seq-type))))
(setf (octet-counter cm)
,(instantiate-octet-counter encoding am
code-point-seq-getter
code-point-seq-type))
(notice-mapping ,encoding-name cm))))
ht))
;;; debugging stuff
#-(and)
(defun pprint-instantiate-concrete-mappings
(&key (encodings (hash-table-keys *abstract-mappings*))
(optimize '((debug 3) (safety 3)))
(octet-seq-setter 'ub-set) (octet-seq-getter 'ub-get)
(octet-seq-type '(simple-array (unsigned-byte 8) (*)))
(code-point-seq-setter 'string-set)
(code-point-seq-getter 'string-get)
(code-point-seq-type 'simple-unicode-string))
(let ((encodings (ensure-list encodings))
(*package* (find-package :babel-encodings))
(*print-case* :downcase))
(pprint
(macroexpand
`(instantiate-concrete-mappings
:encodings ,encodings
:optimize ,optimize
:octet-seq-getter ,octet-seq-getter
:octet-seq-setter ,octet-seq-setter
:octet-seq-type ,octet-seq-type
:code-point-seq-getter ,code-point-seq-getter
:code-point-seq-setter ,code-point-seq-setter
:code-point-seq-type ,code-point-seq-type))))
(values))
;;;; Utilities used in enc-*.lisp
(defconstant +default-substitution-code-point+ #x1a
"Default ASCII substitution character code point used in case of an encoding/decoding error.")
;;; We're converting between objects of the (UNSIGNED-BYTE 8) and
;;; (MOD #x110000) types which are aliased here to UB8 and CODE-POINT
;;; for convenience.
(deftype ub8 () '(unsigned-byte 8))
(deftype code-point () '(mod #x110000))
;;; Utility macro around DEFINE-ENCODER that takes care of most of the
;;; work need to deal with an 8-bit, fixed-width character encoding.
;;;
;;; BODY will be inside a loop and its return value will placed in the
;;; destination buffer. BODY will be surounded by lexical BLOCK which
;;; will have the ENCODING's name, usually a keyword. It handles all
;;; sorts of type declarations.
;;;
;;; See enc-ascii.lisp for a simple usage example.
(defmacro define-unibyte-encoder (encoding (code) &body body)
(with-unique-names (s-getter s-type d-setter d-type
src start end dest d-start i di)
`(define-encoder ,encoding (,s-getter ,s-type ,d-setter ,d-type)
`(named-lambda ,',(symbolicate encoding '#:-unibyte-encoder)
(,',src ,',start ,',end ,',dest ,',d-start)
(declare (type ,,s-type ,',src)
(type ,,d-type ,',dest)
(fixnum ,',start ,',end ,',d-start))
(loop for ,',i fixnum from ,',start below ,',end
and ,',di fixnum from ,',d-start do
(,,d-setter
(macrolet
;; this should probably be a function...
((handle-error (&optional (c ''character-encoding-error))
`(encoding-error
,',',code ,',',encoding ,',',src ,',',i
+default-substitution-code-point+ ,c)))
(let ((,',code (,,s-getter ,',src ,',i)))
(declare (type code-point ,',code))
(block ,',encoding ,@',body)))
,',dest ,',di)
finally (return (the fixnum (- ,',di ,',d-start))))))))
;;; The decoder version of the above macro.
(defmacro define-unibyte-decoder (encoding (octet) &body body)
(with-unique-names (s-getter s-type d-setter d-type
src start end dest d-start i di)
`(define-decoder ,encoding (,s-getter ,s-type ,d-setter ,d-type)
`(named-lambda ,',(symbolicate encoding '#:-unibyte-encoder)
(,',src ,',start ,',end ,',dest ,',d-start)
(declare (type ,,s-type ,',src)
(type ,,d-type ,',dest)
(fixnum ,',start ,',end ,',d-start))
(loop for ,',i fixnum from ,',start below ,',end
and ,',di fixnum from ,',d-start do
(,,d-setter
(macrolet
;; this should probably be a function...
((handle-error (&optional (c ''character-decoding-error))
`(decoding-error
(vector ,',',octet) ,',',encoding ,',',src ,',',i
+default-substitution-code-point+ ,c)))
(let ((,',octet (,,s-getter ,',src ,',i)))
(declare (type ub8 ,',octet))
(block ,',encoding ,@',body)))
,',dest ,',di)
finally (return (the fixnum (- ,',di ,',d-start))))))))
;;;; Error Conditions
;;;
;;; For now, we don't define any actual restarts. The only mechanism
;;; for "restarting" a coding error is the
;;; *SUPPRESS-CHARACTER-CODING-ERRORS* special variable which, when
;;; bound to T (the default), suppresses any error and uses a default
;;; replacement character instead.
;;;
;;; If it turns out that other more options are necessary, possible
;;; alternative approaches include:
;;;
;;; a) use a *REPLACEMENT-CHARACTER* special variable that lets us
;;; pick our own replacement character. The encoder must do
;;; additional work to check if this is character is encodable.
;;;
;;; b) offer a restart to pick a replacement character. Same
;;; problem as above.
;;;
;;; Both approaches pose encoding problems when dealing with a
;;; variable-width encodings because different replacement characters
;;; will need different numbers of octets. This is not a problem for
;;; UTF but will be a problem for the CJK charsets. Approach (a) is
;;; nevertheless easier since the replacement character is known in
;;; advance and therefore the octet-counter can account for it.
;;;
;;; For more complex restarts like SBCL's -- that'll let you specify
;;; _several_ replacement characters for a single character error --
;;; will probably need extra support code outside the encoder/decoder
;;; (i.e. in the string-to-octets function, for example) since the
;;; encoders/decoders deal with pre-allocated fixed-length buffers.
;;;
;;; SBCL has ASCII-specific (MALFORMED-ASCII) and UTF8-specific
;;; errors. Why? Do we want to add some of those too?
;;; FIXME: We used to deal with this with an extra ERRORP argument for
;;; encoders, decoders, etc... Still undecided on the best way to do
;;; it. We could also use a simple restart instead of this...
;;;
;;; In any case, this is not for the users to bind and it's not
;;; exported from the BABEL package.
(defvar *suppress-character-coding-errors* nil
"If non-NIL, encoding or decoding errors are suppressed and the
the current character encoding's default replacement character is
used.")
;;; All of Babel's error conditions are subtypes of
;;; CHARACTER-CODING-ERROR. This error hierarchy is based on SBCL's.
(define-condition character-coding-error (error)
((buffer :initarg :buffer :reader character-coding-error-buffer)
(position :initarg :position :reader character-coding-error-position)
(encoding :initarg :encoding :reader character-coding-error-encoding)))
(define-condition character-encoding-error (character-coding-error)
((code :initarg :code :reader character-encoding-error-code))
(:report (lambda (c s)
(format s "Unable to encode character code point ~A as ~S."
(character-encoding-error-code c)
(character-coding-error-encoding c)))))
(declaim (inline encoding-error))
(defun encoding-error (code enc buf pos &optional
(sub +default-substitution-code-point+)
(e 'character-encoding-error))
(unless *suppress-character-coding-errors*
(error e :encoding enc :buffer buf :position pos :code code))
sub)
(define-condition character-decoding-error (character-coding-error)
((octets :initarg :octets :reader character-decoding-error-octets))
(:report (lambda (c s)
(format s "Illegal ~S character starting at position ~D."
(character-coding-error-encoding c)
(character-coding-error-position c)))))
(define-condition end-of-input-in-character (character-decoding-error)
()
(:documentation "Signalled by DECODERs or CODE-POINT-COUNTERs
of variable-width character encodings."))
(define-condition character-out-of-range (character-decoding-error)
()
(:documentation
"Signalled when the character being decoded is out of range."))
(declaim (inline decoding-error))
(defun decoding-error (octets enc buf pos &optional
(sub +default-substitution-code-point+)
(e 'character-decoding-error))
(unless *suppress-character-coding-errors*
(error e :octets octets :encoding enc :buffer buf :position pos))
sub)

88
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/external-format.lisp Normal file
View file

@ -0,0 +1,88 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; external-format.lisp --- External format classes and functions.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel)
(defvar *default-eol-style*
#+windows :crlf
#-windows :lf
"The end-of-line style used by external formats if none is
explicitly given. Depends on the OS the code is compiled on.")
(deftype eol-style ()
"Possible end-of-line styles."
'(member :cr :lf :crlf))
(defclass external-format ()
((encoding :initarg :encoding :reader external-format-encoding
:type character-encoding)
(eol-style :initarg :eol-style :reader external-format-eol-style
:type eol-style :initform *default-eol-style*))
(:documentation
"An EXTERNAL-FORMAT consists in a combination of a Babel
CHARACTER-ENCODING and an end-of-line style."))
(defmethod print-object ((ef external-format) stream)
(print-unreadable-object (ef stream :type t :identity t)
(format stream "~A ~A"
(enc-name (external-format-encoding ef))
(external-format-eol-style ef))))
;;; This interface is still somewhat sketchy. The rest of Babel
;;; doesn't really understand external formats, for instance.
(defun make-external-format (encoding &key (eol-style *default-eol-style*))
(check-type eol-style eol-style)
(make-instance 'external-format
:encoding (get-character-encoding encoding)
:eol-style eol-style))
(defun ensure-external-format (thing)
(etypecase thing
(external-format thing)
(character-encoding (make-instance 'external-format :encoding thing))
(symbol (make-external-format thing))
(list (apply #'make-external-format thing))))
(defun external-format-equal (ef1 ef2)
(and (eq (external-format-encoding ef1) (external-format-encoding ef2))
(eq (external-format-eol-style ef1) (external-format-eol-style ef2))))
(declaim (inline lookup-mapping))
(defun lookup-mapping (ht encoding)
"HT should be an hashtable created by
INSTANTIATE-CONCRETE-MAPPINGS. ENCODING should be either an
external format, an encoding object or a keyword symbol
denoting a character encoding name or one of its aliases."
(or (etypecase encoding
(keyword
(gethash encoding ht))
(babel-encodings::concrete-mapping
encoding)
(character-encoding
(gethash (enc-name encoding) ht))
(external-format
(gethash (enc-name (external-format-encoding encoding)) ht)))
(error "~S is not a valid encoding designator" encoding)))

2226
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/gbk-map.lisp Normal file
View file

File diff suppressed because it is too large Load diff

17637
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/jpn-table.lisp Normal file
View file

File diff suppressed because it is too large Load diff

115
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/packages.lisp Normal file
View file

@ -0,0 +1,115 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; package.lisp --- Package definition for Babel
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:cl-user)
(defpackage #:babel-encodings
(:use #:common-lisp #:alexandria)
(:export
;; character encoding objects
#:list-character-encodings
#:character-encoding
#:*default-character-encoding*
#:get-character-encoding
#:enc-name
#:enc-aliases
#:enc-code-unit-size
#:enc-max-units-per-char
#:enc-native-endianness
#:enc-decode-literal-code-unit-limit
#:enc-encode-literal-code-unit-limit
#:enc-use-bom
#:enc-bom-encoding
#:enc-nul-encoding
#:enc-default-replacement
#:ambiguous-encoding-p
;; concrete mappings
#:instantiate-concrete-mappings
#:encoder
#:decoder
#:octet-counter
#:code-point-counter
#:lookup-mapping
#:with-simple-vector
#:with-checked-simple-vector
#:*suppress-character-coding-errors*
;; errors
#:character-coding-error
#:character-coding-error-encoding ; accessor
#:character-coding-error-buffer ; accessor
#:character-coding-error-position ; accessor
#:character-decoding-error
#:character-decoding-error-octets ; accessor
#:character-encoding-error
#:character-encoding-error-code ; accessor
#:end-of-input-in-character
#:character-out-of-range
#:invalid-utf8-starter-byte
#:invalid-utf8-continuation-byte
#:overlong-utf8-sequence))
(defpackage #:babel
(:use #:common-lisp #:babel-encodings #:alexandria)
(:import-from #:babel-encodings)
(:export
;; types
#:unicode-char
#:unicode-char-code-limit
#:unicode-string
#:simple-unicode-string
;; fixed sharp-backslash reader
#:enable-sharp-backslash-syntax
#:set-sharp-backslash-syntax-in-readtable
;; external formats
#:external-format
#:make-external-format
#:ensure-external-format
#:external-format-encoding
#:external-format-eol-style
#:external-format-equal
#:*default-eol-style*
;; general user API
#:*default-character-encoding*
#:list-character-encodings
#:string-to-octets
#:octets-to-string
#:concatenate-strings-to-octets
#:string-size-in-octets
#:vector-size-in-chars
;; errors
#:character-coding-error
#:character-coding-error-encoding ; accessor
#:character-coding-error-buffer ; accessor
#:character-coding-error-position ; accessor
#:character-decoding-error
#:character-decoding-error-octets ; accessor
#:character-encoding-error
#:character-encoding-error-code ; accessor
#:end-of-input-in-character
#:character-out-of-range
#:invalid-utf8-starter-byte
#:invalid-utf8-continuation-byte
#:overlong-utf8-sequence))

82
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/sharp-backslash.lisp Normal file
View file

@ -0,0 +1,82 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; sharp-backslash.lisp --- Alternative #\ dispatch code.
;;;
;;; Copyright (C) 2007-2009, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel)
#-allegro
(defun sharp-backslash-reader (original-reader stream char numarg)
(let ((1st-char (read-char stream)))
(if (and (char-equal 1st-char #\u)
;; because #\z is not a digit char...
(digit-char-p (peek-char nil stream nil #\z) 16))
;; something better than READ would be nice here
(let ((token (let ((*read-base* 16)) (read stream))))
(if (typep token 'babel-encodings::code-point)
(code-char token)
(if *read-suppress*
nil
(simple-reader-error
stream "Unrecognized character name: u~A" token))))
(funcall original-reader
(make-concatenated-stream (make-string-input-stream
(string 1st-char))
stream)
char
numarg))))
;;; Allegro's PEEK-CHAR seems broken in some situations, and the code
;;; above would generate an error about too many calls to UNREAD-CHAR.
;;; Then Allegro's original SHARP-BACKSLASH wants to UNREAD-CHAR
;;; twice, very weird. This is the best workaround I could think of.
;;; It sucks.
#+allegro
(defun sharp-backslash-reader (original-reader stream char numarg)
(let* ((1st-char (read-char stream))
(rest (ignore-errors (excl::read-extended-token stream)))
(code (when (and rest (char-equal 1st-char #\u))
(ignore-errors (parse-integer rest :radix 16)))))
(if code
(code-char code)
(with-input-from-string
(s (concatenate 'string "#\\" (string 1st-char) rest))
(read-char s)
(read-char s)
(funcall original-reader s char numarg)))))
(defun make-sharp-backslash-reader ()
(let ((original-sharp-backslash (get-dispatch-macro-character #\# #\\)))
(lambda (stream char numarg)
(sharp-backslash-reader original-sharp-backslash stream char numarg))))
(defmacro enable-sharp-backslash-syntax ()
`(eval-when (:compile-toplevel :execute)
(setf *readtable* (copy-readtable *readtable*))
(set-sharp-backslash-syntax-in-readtable)
(values)))
(defun set-sharp-backslash-syntax-in-readtable ()
(set-dispatch-macro-character #\# #\\ (make-sharp-backslash-reader))
(values))

436
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/streams.lisp Normal file
View file

@ -0,0 +1,436 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; streams.lisp --- Conversions between strings and UB8 vectors.
;;;
;;; Copyright (c) 2005-2007, Dr. Edmund Weitz. All rights reserved.
;;; Copyright (c) 2008, Attila Lendvai. All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; STATUS
;;;
;;; - in-memory output streams support binary/bivalent/character
;;; element-types and file-position
;;; TODO
;;;
;;; - filter-stream types/mixins that can wrap a binary stream and
;;; turn it into a bivalent/character stream
;;; - in-memory input streams with file-position similar to in-memory
;;; output streams
;;; - in-memory input/output streams?
(in-package #:babel)
(defpackage #:babel-streams
(:use #:common-lisp #:babel #:trivial-gray-streams #:alexandria)
(:export
#:in-memory-stream
#:vector-output-stream
#:vector-input-stream
#:make-in-memory-output-stream
#:make-in-memory-input-stream
#:get-output-stream-sequence
#:with-output-to-sequence
#:with-input-from-sequence))
(in-package :babel-streams)
(declaim (inline check-if-open check-if-accepts-octets
check-if-accepts-characters stream-accepts-characters?
stream-accepts-octets? vector-extend
extend-vector-output-stream-buffer))
(defgeneric get-output-stream-sequence (stream &key &allow-other-keys))
;;;; Some utilities (on top due to inlining)
(defun vector-extend (extension vector &key (start 0) (end (length extension)))
;; copied over from cl-quasi-quote
(declare (optimize speed)
(type vector extension vector)
(type array-index start end))
(let* ((original-length (length vector))
(extension-length (- end start))
(new-length (+ original-length extension-length))
(original-dimension (array-dimension vector 0)))
(when (< original-dimension new-length)
(setf vector
(adjust-array vector (max (* 2 original-dimension) new-length))))
(setf (fill-pointer vector) new-length)
(replace vector extension :start1 original-length :start2 start :end2 end)
vector))
(defclass in-memory-stream (trivial-gray-stream-mixin)
((element-type ; :default means bivalent
:initform :default :initarg :element-type :accessor element-type-of)
(external-format
:initform (ensure-external-format *default-character-encoding*)
:initarg :external-format :accessor external-format-of)
#+cmu
(open-p
:initform t :accessor in-memory-stream-open-p
:documentation "For CMUCL we have to keep track of this manually."))
(:documentation "An IN-MEMORY-STREAM is a binary stream that reads octets
from or writes octets to a sequence in RAM."))
(defmethod stream-element-type ((self in-memory-stream))
;; stream-element-type is a CL symbol, we may not install an accessor on it.
;; so, go through this extra step.
(element-type-of self))
(defun stream-accepts-octets? (stream)
(let ((element-type (element-type-of stream)))
(or (eq element-type :default)
(equal element-type '(unsigned-byte 8))
(subtypep element-type '(unsigned-byte 8)))))
(defun stream-accepts-characters? (stream)
(let ((element-type (element-type-of stream)))
(member element-type '(:default character base-char))))
(defclass in-memory-input-stream (in-memory-stream fundamental-binary-input-stream)
()
(:documentation "An IN-MEMORY-INPUT-STREAM is a binary stream that reads
octets from a sequence in RAM."))
#+cmu
(defmethod output-stream-p ((stream in-memory-input-stream))
"Explicitly states whether this is an output stream."
(declare (optimize speed))
nil)
(defclass in-memory-output-stream (in-memory-stream
fundamental-binary-output-stream)
()
(:documentation "An IN-MEMORY-OUTPUT-STREAM is a binary stream that
writes octets to a sequence in RAM."))
#+cmu
(defmethod input-stream-p ((stream in-memory-output-stream))
"Explicitly states whether this is an input stream."
(declare (optimize speed))
nil)
(defun make-in-memory-output-stream (&key (element-type :default)
external-format
initial-buffer-size)
"Returns a binary output stream which accepts objects of type
ELEMENT-TYPE \(a subtype of OCTET) and makes available a sequence that
contains the octes that were actually output."
(declare (optimize speed))
(unless external-format
(setf external-format *default-character-encoding*))
(when (eq element-type :bivalent)
(setf element-type :default))
(make-instance 'vector-output-stream
:vector (make-vector-stream-buffer
:element-type
(cond
((or (eq element-type :default)
(equal element-type '(unsigned-byte 8)))
'(unsigned-byte 8))
((eq element-type 'character)
'character)
((subtypep element-type '(unsigned-byte 8))
'(unsigned-byte 8))
(t (error "Illegal element-type ~S" element-type)))
:initial-size initial-buffer-size)
:element-type element-type
:external-format (ensure-external-format external-format)))
(defun make-in-memory-input-stream (data &key (element-type :default)
external-format)
"Returns a binary input stream which provides the elements of DATA when read."
(declare (optimize speed))
(unless external-format
(setf external-format *default-character-encoding*))
(when (eq element-type :bivalent)
(setf element-type :default))
(make-instance 'vector-input-stream
:vector data
:element-type element-type
:end (length data)
:external-format (ensure-external-format external-format)))
(defclass vector-stream ()
((vector
:initarg :vector :accessor vector-stream-vector
:documentation "The underlying vector of the stream which \(for output)
must always be adjustable and have a fill pointer.")
(index
:initform 0 :initarg :index :accessor vector-stream-index
:type (integer 0 #.array-dimension-limit)
:documentation "An index into the underlying vector denoting the
current position."))
(:documentation
"A VECTOR-STREAM is a mixin for IN-MEMORY streams where the underlying
sequence is a vector."))
(defclass vector-input-stream (vector-stream in-memory-input-stream)
((end
:initarg :end :accessor vector-stream-end
:type (integer 0 #.array-dimension-limit)
:documentation "An index into the underlying vector denoting the end
of the available data."))
(:documentation "A binary input stream that gets its data from an
associated vector of octets."))
(defclass vector-output-stream (vector-stream in-memory-output-stream)
()
(:documentation
"A binary output stream that writes its data to an associated vector."))
(define-condition in-memory-stream-error (stream-error)
()
(:documentation "Superclass for all errors related to IN-MEMORY streams."))
(define-condition in-memory-stream-closed-error (in-memory-stream-error)
()
(:report (lambda (condition stream)
(format stream "~S is closed."
(stream-error-stream condition))))
(:documentation "An error that is signalled when someone is trying to read
from or write to a closed IN-MEMORY stream."))
(define-condition wrong-element-type-stream-error (stream-error)
((expected-type :accessor expected-type-of :initarg :expected-type))
(:report (lambda (condition output)
(let ((stream (stream-error-stream condition)))
(format output "The element-type of ~S is ~S while expecting ~
a stream that accepts ~S."
stream (element-type-of stream)
(expected-type-of condition))))))
(defun wrong-element-type-stream-error (stream expected-type)
(error 'wrong-element-type-stream-error
:stream stream :expected-type expected-type))
#+cmu
(defmethod open-stream-p ((stream in-memory-stream))
"Returns a true value if STREAM is open. See ANSI standard."
(declare (optimize speed))
(in-memory-stream-open-p stream))
#+cmu
(defmethod close ((stream in-memory-stream) &key abort)
"Closes the stream STREAM. See ANSI standard."
(declare (ignore abort) (optimize speed))
(prog1
(in-memory-stream-open-p stream)
(setf (in-memory-stream-open-p stream) nil)))
(defun check-if-open (stream)
"Checks if STREAM is open and signals an error otherwise."
(declare (optimize speed))
(unless (open-stream-p stream)
(error 'in-memory-stream-closed-error :stream stream)))
(defun check-if-accepts-octets (stream)
(declare (optimize speed))
(unless (stream-accepts-octets? stream)
(wrong-element-type-stream-error stream '(unsigned-byte 8))))
(defun check-if-accepts-characters (stream)
(declare (optimize speed))
(unless (stream-accepts-characters? stream)
(wrong-element-type-stream-error stream 'character)))
(defmethod stream-read-byte ((stream vector-input-stream))
"Reads one byte and increments INDEX pointer unless we're beyond END pointer."
(declare (optimize speed))
(check-if-open stream)
(let ((index (vector-stream-index stream)))
(cond ((< index (vector-stream-end stream))
(incf (vector-stream-index stream))
(aref (vector-stream-vector stream) index))
(t :eof))))
#+#:ignore
(defmethod stream-read-char ((stream vector-input-stream))
;; TODO
)
(defmethod stream-listen ((stream vector-input-stream))
"Checking whether INDEX is beyond END."
(declare (optimize speed))
(check-if-open stream)
(< (vector-stream-index stream) (vector-stream-end stream)))
(defmethod stream-read-sequence ((stream vector-input-stream)
sequence start end &key)
(declare (optimize speed) (type array-index start end))
;; TODO check the sequence type, assert for the element-type and use
;; the external-format.
(loop with vector-end of-type array-index = (vector-stream-end stream)
with vector = (vector-stream-vector stream)
for index from start below end
for vector-index of-type array-index = (vector-stream-index stream)
while (< vector-index vector-end)
do (setf (elt sequence index)
(aref vector vector-index))
(incf (vector-stream-index stream))
finally (return index)))
(defmethod stream-write-byte ((stream vector-output-stream) byte)
"Writes a byte \(octet) by extending the underlying vector."
(declare (optimize speed))
(check-if-open stream)
(check-if-accepts-octets stream)
(vector-push-extend byte (vector-stream-vector stream))
(incf (vector-stream-index stream))
byte)
(defun extend-vector-output-stream-buffer (extension stream &key (start 0)
(end (length extension)))
(declare (optimize speed)
(type array-index start end)
(type vector extension))
(vector-extend extension (vector-stream-vector stream) :start start :end end)
(incf (vector-stream-index stream) (- end start))
(values))
(defmethod stream-write-char ((stream vector-output-stream) char)
(declare (optimize speed))
(check-if-open stream)
(check-if-accepts-characters stream)
;; TODO this is naiive here, there's room for optimization
(let ((octets (string-to-octets (string char)
:encoding (external-format-of stream))))
(extend-vector-output-stream-buffer octets stream))
char)
(defmethod stream-write-sequence ((stream vector-output-stream)
sequence start end &key)
"Just calls VECTOR-PUSH-EXTEND repeatedly."
(declare (optimize speed)
(type array-index start end))
(etypecase sequence
(string
(if (stream-accepts-octets? stream)
;; TODO this is naiive here, there's room for optimization
(let ((octets (string-to-octets sequence
:encoding (external-format-of stream)
:start start
:end end)))
(extend-vector-output-stream-buffer octets stream))
(progn
(assert (stream-accepts-characters? stream))
(extend-vector-output-stream-buffer sequence stream
:start start :end end))))
((vector (unsigned-byte 8))
;; specialized branch to help inlining
(check-if-accepts-octets stream)
(extend-vector-output-stream-buffer sequence stream :start start :end end))
(vector
(check-if-accepts-octets stream)
(extend-vector-output-stream-buffer sequence stream :start start :end end)))
sequence)
(defmethod stream-write-string ((stream vector-output-stream)
string &optional (start 0) (end (length string)))
(stream-write-sequence stream string start (or end (length string))))
(defmethod stream-line-column ((stream vector-output-stream))
"Dummy line-column method that always returns NIL. Needed for
character output streams."
nil)
(defmethod stream-file-position ((stream vector-stream))
"Simply returns the index into the underlying vector."
(declare (optimize speed))
(vector-stream-index stream))
(defun make-vector-stream-buffer (&key (element-type '(unsigned-byte 8))
initial-size)
"Creates and returns an array which can be used as the underlying vector
for a VECTOR-OUTPUT-STREAM."
(declare (optimize speed)
(type (or null array-index) initial-size))
(make-array (the array-index (or initial-size 32))
:adjustable t
:fill-pointer 0
:element-type element-type))
(defmethod get-output-stream-sequence ((stream in-memory-output-stream) &key (return-as 'vector))
"Returns a vector containing, in order, all the octets that have
been output to the IN-MEMORY stream STREAM. This operation clears any
octets on STREAM, so the vector contains only those octets which have
been output since the last call to GET-OUTPUT-STREAM-SEQUENCE or since
the creation of the stream, whichever occurred most recently. If
AS-LIST is true the return value is coerced to a list."
(declare (optimize speed))
(prog1
(ecase return-as
(vector (vector-stream-vector stream))
(string (octets-to-string (vector-stream-vector stream)
:encoding (external-format-of stream)))
(list (coerce (vector-stream-vector stream) 'list)))
(setf (vector-stream-vector stream) (make-vector-stream-buffer))))
(defmacro with-output-to-sequence
((var &key (return-as ''vector) (element-type '':default)
(external-format '*default-character-encoding*) initial-buffer-size)
&body body)
"Creates an IN-MEMORY output stream, binds VAR to this stream and
then executes the code in BODY. The stream stores data of type
ELEMENT-TYPE \(a subtype of OCTET). The stream is automatically closed
on exit from WITH-OUTPUT-TO-SEQUENCE, no matter whether the exit is
normal or abnormal. The return value of this macro is a vector \(or a
list if AS-LIST is true) containing the octets that were sent to the
stream within BODY."
(multiple-value-bind (body declarations) (parse-body body)
;; this is here to stop SBCL complaining about binding them to NIL
`(let ((,var (make-in-memory-output-stream
:element-type ,element-type
:external-format ,external-format
:initial-buffer-size ,initial-buffer-size)))
,@declarations
(unwind-protect
(progn
,@body
(get-output-stream-sequence ,var :return-as ,return-as))
(close ,var)))))
(defmacro with-input-from-sequence
((var data &key (element-type '':default)
(external-format '*default-character-encoding*))
&body body)
"Creates an IN-MEMORY input stream that will return the values
available in DATA, binds VAR to this stream and then executes the code
in BODY. The stream stores data of type ELEMENT-TYPE \(a subtype of
OCTET). The stream is automatically closed on exit from
WITH-INPUT-FROM-SEQUENCE, no matter whether the exit is normal or
abnormal. The return value of this macro is the return value of BODY."
(multiple-value-bind (body declarations) (parse-body body)
;; this is here to stop SBCL complaining about binding them to NIL
`(let ((,var (make-in-memory-input-stream
,data :element-type ,element-type
:external-format ,external-format)))
,@declarations
(unwind-protect
(progn
,@body)
(close ,var)))))

353
sbcl/.quicklisp/dists/quicklisp/software/babel-20191130-git/src/strings.lisp Normal file
View file

@ -0,0 +1,353 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; strings.lisp --- Conversions between strings and UB8 vectors.
;;;
;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(in-package #:babel)
;;; The usefulness of this string/octets interface of Babel's is very
;;; limited on Lisps with 8-bit characters which will in effect only
;;; support the latin-1 subset of Unicode. That is, all encodings are
;;; supported but we can only store the first 256 code points in Lisp
;;; strings. Support for using other 8-bit encodings for strings on
;;; these Lisps could be added with an extra encoding/decoding step.
;;; Supporting other encodings with larger code units would be silly
;;; (it would break expectations about common string operations) and
;;; better done with something like Closure's runes.
;;; Can we handle unicode fully?
(eval-when (:compile-toplevel :load-toplevel :execute)
;; The EVAL is just here to avoid warnings...
(case (eval char-code-limit)
(#x100 (pushnew '8-bit-chars *features*))
(#x10000 (pushnew 'ucs-2-chars *features*))
(#x110000 #| yay |#)
;; This is here mostly because if the CHAR-CODE-LIMIT is bigger
;; than #x11000, strange things might happen but we probably
;; shouldn't descriminate against other, smaller, values.
(t (error "Strange CHAR-CODE-LIMIT (#x~X), bailing out."
char-code-limit))))
;;; Adapted from Ironclad. TODO: check if it's worthwhile adding
;;; implementation-specific accessors such as SAP-REF-* for SBCL.
(defmacro ub-get (vector index &optional (bytes 1) (endianness :ne))
(let ((big-endian (member endianness
'(:be #+big-endian :ne #+little-endian :re))))
(once-only (vector index)
`(logand
,(1- (ash 1 (* 8 bytes)))
(logior
,@(loop for i from 0 below bytes
for offset = (if big-endian i (- bytes i 1))
for shift = (if big-endian
(* (- bytes i 1) 8)
(* offset 8))
collect `(ash (aref ,vector (+ ,index ,offset)) ,shift)))))))
(defmacro ub-set (value vector index &optional (bytes 1) (endianness :ne))
(let ((big-endian (member endianness
'(:be #+big-endian :ne #+little-endian :re))))
`(progn
,@(loop for i from 1 to bytes
for offset = (if big-endian (- bytes i) (1- i)) collect
`(setf (aref ,vector (+ ,index ,offset))
(ldb (byte 8 ,(* 8 (1- i))) ,value)))
(values))))
(defmacro string-get (string index)
`(char-code (schar ,string ,index)))
(defmacro string-set (code string index)
`(setf (schar ,string ,index) (code-char ,code)))
;;; SIMPLE-BASE-STRING would also be a subtype of SIMPLE-STRING so we
;;; don't use that because on SBCL BASE-CHARs can only hold ASCII.
;;; Also, with (> SPEED SAFETY) (setf (schar base-str n) big-char)
;;; will quietly work, sort of.
;;;
;;; XXX: test this on various lisps.
(defconstant unicode-char-code-limit
char-code-limit
"An alias for CL:CHAR-CODE-LIMIT which might be lower than
#x110000 on some Lisps.")
(deftype unicode-char ()
"This character type can hold any characters whose CHAR-CODEs
are less than UNICODE-CHAR-CODE-LIMIT."
#+lispworks 'lw:simple-char
#-lispworks 'character)
(deftype simple-unicode-string ()
"Alias for (SIMPLE-ARRAY UNICODE-CHAR (*))."
'(simple-array unicode-char (*)))
(deftype unicode-string ()
"Alias for (VECTOR UNICODE-CHAR *)."
'(vector unicode-char *))
(defparameter *string-vector-mappings*
(instantiate-concrete-mappings
;; :optimize ((speed 3) (safety 0) (debug 0) (compilation-speed 0))
:octet-seq-setter ub-set
:octet-seq-getter ub-get
:octet-seq-type (simple-array (unsigned-byte 8) (*))
:code-point-seq-setter string-set
:code-point-seq-getter string-get
:code-point-seq-type simple-unicode-string))
#+sbcl
(defparameter *simple-base-string-vector-mappings*
(instantiate-concrete-mappings
;; :optimize ((speed 3) (safety 0) (debug 0) (compilation-speed 0))
:instantiate-decoders nil
:octet-seq-setter ub-set
:octet-seq-getter ub-get
:octet-seq-type (simple-array (unsigned-byte 8) (*))
:code-point-seq-setter string-set
:code-point-seq-getter string-get
:code-point-seq-type simple-base-string))
;;; Do we want a more a specific error condition here?
(defun check-vector-bounds (vector start end)
(unless (<= 0 start end (length vector))
(error "Invalid start (~A) and end (~A) values for vector of length ~A."
start end (length vector))))
(defmacro with-simple-vector (((v vector) (s start) (e end)) &body body)
"If VECTOR is a displaced or adjustable array, binds V to the
underlying simple vector, adds an adequate offset to START and
END and binds those offset values to S and E. Otherwise, if
VECTOR is already a simple array, it's simply bound to V with no
further changes.
START and END are unchecked and assumed to be within bounds.
Note that in some Lisps, a slow copying implementation is
necessary to obtain a simple vector thus V will be bound to a
copy of VECTOR coerced to a simple-vector. Therefore, you
shouldn't attempt to modify V."
#+sbcl
`(sb-kernel:with-array-data ((,v ,vector) (,s ,start) (,e ,end))
,@body)
#+(or cmu scl)
`(lisp::with-array-data ((,v ,vector) (,s ,start) (,e ,end))
,@body)
#+openmcl
(with-unique-names (offset)
`(multiple-value-bind (,v ,offset)
(ccl::array-data-and-offset ,vector)
(let ((,s (+ ,start ,offset))
(,e (+ ,end ,offset)))
,@body)))
#+allegro
(with-unique-names (offset)
`(excl::with-underlying-simple-vector (,vector ,v ,offset)
(let ((,e (+ ,end ,offset))
(,s (+ ,start ,offset)))
,@body)))
;; slow, copying implementation
#-(or sbcl cmu scl openmcl allegro)
(once-only (vector)
`(funcall (if (adjustable-array-p ,vector)
#'call-with-array-data/copy
#'call-with-array-data/fast)
,vector ,start ,end
(lambda (,v ,s ,e) ,@body))))
#-(or sbcl cmu scl openmcl allegro)
(progn
;; Stolen from f2cl.
(defun array-data-and-offset (array)
(loop with offset = 0 do
(multiple-value-bind (displaced-to index-offset)
(array-displacement array)
(when (null displaced-to)
(return-from array-data-and-offset
(values array offset)))
(incf offset index-offset)
(setf array displaced-to))))
(defun call-with-array-data/fast (vector start end fn)
(multiple-value-bind (data offset)
(array-data-and-offset vector)
(funcall fn data (+ offset start) (+ offset end))))
(defun call-with-array-data/copy (vector start end fn)
(funcall fn (replace (make-array (- end start) :element-type
(array-element-type vector))
vector :start2 start :end2 end)
0 (- end start))))
(defmacro with-checked-simple-vector (((v vector) (s start) (e end)) &body body)
"Like WITH-SIMPLE-VECTOR but bound-checks START and END."
(once-only (vector start)
`(let ((,e (or ,end (length ,vector))))
(check-vector-bounds ,vector ,start ,e)
(with-simple-vector ((,v ,vector) (,s ,start) (,e ,e))
,@body))))
;;; Future features these functions should have:
;;;
;;; * null-terminate
;;; * specify target vector/string + offset
;;; * documentation :)
(declaim (inline octets-to-string string-to-octets string-size-in-octets
vector-size-in-chars concatenate-strings-to-octets
bom-vector))
(defun octets-to-string (vector &key (start 0) end
(errorp (not *suppress-character-coding-errors*))
(encoding *default-character-encoding*))
(check-type vector (vector (unsigned-byte 8)))
(with-checked-simple-vector ((vector vector) (start start) (end end))
(declare (type (simple-array (unsigned-byte 8) (*)) vector))
(let ((*suppress-character-coding-errors* (not errorp))
(mapping (lookup-mapping *string-vector-mappings* encoding)))
(multiple-value-bind (size new-end)
(funcall (code-point-counter mapping) vector start end -1)
;; TODO we could optimize ASCII here: the result should
;; be a simple-base-string filled using code-char...
(let ((string (make-string size :element-type 'unicode-char)))
(funcall (decoder mapping) vector start new-end string 0)
string)))))
(defun bom-vector (encoding use-bom)
(check-type use-bom (member :default t nil))
(the simple-vector
(if (null use-bom)
#()
(let ((enc (typecase encoding
(external-format (external-format-encoding encoding))
(t (get-character-encoding encoding)))))
(if (or (eq use-bom t)
(and (eq use-bom :default) (enc-use-bom enc)))
;; VALUES avoids a "type assertion too complex to check" note.
(values (enc-bom-encoding enc))
#())))))
(defun string-to-octets (string &key (encoding *default-character-encoding*)
(start 0) end (use-bom :default)
(errorp (not *suppress-character-coding-errors*)))
(declare (optimize (speed 3) (safety 2)))
(let ((*suppress-character-coding-errors* (not errorp)))
(etypecase string
;; On some lisps (e.g. clisp and ccl) all strings are BASE-STRING and all
;; characters are BASE-CHAR. So, only enable this optimization for
;; selected targets.
#+sbcl
(simple-base-string
(unless end
(setf end (length string)))
(check-vector-bounds string start end)
(let* ((mapping (lookup-mapping *simple-base-string-vector-mappings*
encoding))
(bom (bom-vector encoding use-bom))
(bom-length (length bom))
;; OPTIMIZE: we could use the (length string) information here
;; because it's a simple-base-string where each character <= 127
(result (make-array
(+ (the array-index
(funcall (the function (octet-counter mapping))
string start end -1))
bom-length)
:element-type '(unsigned-byte 8))))
(replace result bom)
(funcall (the function (encoder mapping))
string start end result bom-length)
result))
(string
;; FIXME: we shouldn't really need that coercion to UNICODE-STRING
;; but we kind of because it's declared all over. To avoid that,
;; we'd need different types for input and output strings. Or maybe
;; this is not a problem; figure that out.
(with-checked-simple-vector ((string (coerce string 'unicode-string))
(start start) (end end))
(declare (type simple-unicode-string string))
(let* ((mapping (lookup-mapping *string-vector-mappings* encoding))
(bom (bom-vector encoding use-bom))
(bom-length (length bom))
(result (make-array
(+ (the array-index
(funcall (the function (octet-counter mapping))
string start end -1))
bom-length)
:element-type '(unsigned-byte 8))))
(replace result bom)
(funcall (the function (encoder mapping))
string start end result bom-length)
result))))))
(defun concatenate-strings-to-octets (encoding &rest strings)
"Optimized equivalent of
\(string-to-octets \(apply #'concatenate 'string strings)
:encoding encoding)"
(declare (dynamic-extent strings))
(let* ((mapping (lookup-mapping *string-vector-mappings* encoding))
(octet-counter (octet-counter mapping))
(vector (make-array
(the array-index
(reduce #'+ strings
:key (lambda (string)
(funcall octet-counter
string 0 (length string) -1))))
:element-type '(unsigned-byte 8)))
(current-index 0))
(declare (type array-index current-index))
(dolist (string strings)
(check-type string string)
(with-checked-simple-vector ((string (coerce string 'unicode-string))
(start 0) (end (length string)))
(declare (type simple-unicode-string string))
(incf current-index
(funcall (encoder mapping)
string start end vector current-index))))
vector))
(defun string-size-in-octets (string &key (start 0) end (max -1 maxp)
(errorp (not *suppress-character-coding-errors*))
(encoding *default-character-encoding*))
(check-type string string)
(with-checked-simple-vector ((string (coerce string 'unicode-string))
(start start) (end end))
(declare (type simple-unicode-string string))
(let ((mapping (lookup-mapping *string-vector-mappings* encoding))
(*suppress-character-coding-errors* (not errorp)))
(when maxp (assert (plusp max)))
(funcall (octet-counter mapping) string start end max))))
(defun vector-size-in-chars (vector &key (start 0) end (max -1 maxp)
(errorp (not *suppress-character-coding-errors*))
(encoding *default-character-encoding*))
(check-type vector (vector (unsigned-byte 8)))
(with-checked-simple-vector ((vector vector) (start start) (end end))
(declare (type (simple-array (unsigned-byte 8) (*)) vector))
(let ((mapping (lookup-mapping *string-vector-mappings* encoding))
(*suppress-character-coding-errors* (not errorp)))
(when maxp (assert (plusp max)))
(funcall (code-point-counter mapping) vector start end max))))
(declaim (notinline octets-to-string string-to-octets string-size-in-octets
vector-size-in-chars concatenate-strings-to-octets))