Mercurial > hg > xemacs-beta
annotate lisp/mule/mule-coding.el @ 4525:d64f1060cd65
Fix off-by-one error in ccl_driver. <87iqr7v7p0.fsf@uwakimon.sk.tsukuba.ac.jp>
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Sat, 01 Nov 2008 23:32:53 +0900 |
| parents | 04ec3340612e |
| children | d9fcb5442c95 |
| rev | line source |
|---|---|
| 502 | 1 ;;; mule-coding.el --- Coding-system functions for Mule. -*- coding: iso-2022-7bit; -*- |
| 333 | 2 |
| 3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. | |
| 4 ;; Licensed to the Free Software Foundation. | |
| 5 ;; Copyright (C) 1995 Amdahl Corporation. | |
| 6 ;; Copyright (C) 1995 Sun Microsystems. | |
| 7 ;; Copyright (C) 1997 MORIOKA Tomohiko | |
| 771 | 8 ;; Copyright (C) 2001 Ben Wing. |
| 333 | 9 |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
| 12 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 13 ;; under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 ;; any later version. | |
| 16 | |
| 17 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 20 ;; General Public License for more details. | |
| 21 | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 444 | 23 ;; along with XEmacs; see the file COPYING. If not, write to the |
| 333 | 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 25 ;; Boston, MA 02111-1307, USA. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;;; split off of mule.el and mostly moved to coding.el | |
| 30 | |
| 4072 | 31 ;; Needed for make-8-bit-coding-system. |
| 4080 | 32 (eval-when-compile (require 'ccl)) |
| 4072 | 33 |
| 333 | 34 ;;; Code: |
| 35 | |
| 36 (defun coding-system-force-on-output (coding-system register) | |
| 37 "Return the 'force-on-output property of CODING-SYSTEM for the specified REGISTER." | |
| 444 | 38 (check-type register integer) |
| 333 | 39 (coding-system-property |
| 40 coding-system | |
| 41 (case register | |
| 42 (0 'force-g0-on-output) | |
| 43 (1 'force-g1-on-output) | |
| 44 (2 'force-g2-on-output) | |
| 45 (3 'force-g3-on-output) | |
| 46 (t (signal 'args-out-of-range (list register 0 3)))))) | |
| 47 | |
| 48 (defun coding-system-short (coding-system) | |
| 49 "Return the 'short property of CODING-SYSTEM." | |
| 50 (coding-system-property coding-system 'short)) | |
| 51 | |
| 52 (defun coding-system-no-ascii-eol (coding-system) | |
| 53 "Return the 'no-ascii-eol property of CODING-SYSTEM." | |
| 54 (coding-system-property coding-system 'no-ascii-eol)) | |
| 55 | |
| 56 (defun coding-system-no-ascii-cntl (coding-system) | |
| 57 "Return the 'no-ascii-cntl property of CODING-SYSTEM." | |
| 58 (coding-system-property coding-system 'no-ascii-cntl)) | |
| 59 | |
| 60 (defun coding-system-seven (coding-system) | |
| 61 "Return the 'seven property of CODING-SYSTEM." | |
| 62 (coding-system-property coding-system 'seven)) | |
| 63 | |
| 64 (defun coding-system-lock-shift (coding-system) | |
| 65 "Return the 'lock-shift property of CODING-SYSTEM." | |
| 66 (coding-system-property coding-system 'lock-shift)) | |
| 67 | |
| 68 ;;(defun coding-system-use-japanese-jisx0201-roman (coding-system) | |
| 69 ;; "Return the 'use-japanese-jisx0201-roman property of CODING-SYSTEM." | |
| 70 ;; (coding-system-property coding-system 'use-japanese-jisx0201-roman)) | |
| 71 | |
| 72 ;;(defun coding-system-use-japanese-jisx0208-1978 (coding-system) | |
| 73 ;; "Return the 'use-japanese-jisx0208-1978 property of CODING-SYSTEM." | |
| 74 ;; (coding-system-property coding-system 'use-japanese-jisx0208-2978)) | |
| 75 | |
| 76 (defun coding-system-no-iso6429 (coding-system) | |
| 77 "Return the 'no-iso6429 property of CODING-SYSTEM." | |
| 78 (coding-system-property coding-system 'no-iso6429)) | |
| 79 | |
| 80 (defun coding-system-ccl-encode (coding-system) | |
| 81 "Return the CCL 'encode property of CODING-SYSTEM." | |
| 82 (coding-system-property coding-system 'encode)) | |
| 83 | |
| 84 (defun coding-system-ccl-decode (coding-system) | |
| 85 "Return the CCL 'decode property of CODING-SYSTEM." | |
| 86 (coding-system-property coding-system 'decode)) | |
| 87 | |
| 771 | 88 (defun coding-system-iso2022-charset (coding-system register) |
| 89 "Return the charset initially designated to REGISTER in CODING-SYSTEM. | |
| 90 The allowable range of REGISTER is 0 through 3." | |
| 91 (if (or (< register 0) (> register 3)) | |
| 92 (error 'args-out-of-range "coding-system-charset REGISTER" register 0 3)) | |
| 93 (coding-system-property coding-system (nth register '(charset-g0 | |
| 94 charset-g1 | |
| 95 charset-g2 | |
| 96 charset-g3)))) | |
| 97 | |
| 333 | 98 |
| 99 ;;;; Definitions of predefined coding systems | |
| 100 | |
| 101 (make-coding-system | |
| 102 'ctext 'iso2022 | |
| 771 | 103 "Compound Text" |
| 333 | 104 '(charset-g0 ascii |
| 105 charset-g1 latin-iso8859-1 | |
| 106 eol-type nil | |
| 107 mnemonic "CText")) | |
| 108 | |
| 109 (make-coding-system | |
| 110 'iso-2022-8bit-ss2 'iso2022 | |
| 771 | 111 "ISO-2022 8-bit w/SS2" |
| 333 | 112 '(charset-g0 ascii |
| 113 charset-g1 latin-iso8859-1 | |
| 114 charset-g2 t ;; unspecified but can be used later. | |
| 115 short t | |
| 116 mnemonic "ISO8/SS" | |
| 771 | 117 documentation "ISO 2022 based 8-bit encoding using SS2 for 96-charset" |
| 333 | 118 )) |
| 119 | |
| 120 (make-coding-system | |
| 121 'iso-2022-7bit-ss2 'iso2022 | |
| 771 | 122 "ISO-2022 7-bit w/SS2" |
| 333 | 123 '(charset-g0 ascii |
| 124 charset-g2 t ;; unspecified but can be used later. | |
| 125 seven t | |
| 126 short t | |
| 127 mnemonic "ISO7/SS" | |
| 771 | 128 documentation "ISO 2022 based 7-bit encoding using SS2 for 96-charset" |
| 333 | 129 eol-type nil)) |
| 130 | |
| 131 ;; (copy-coding-system 'iso-2022-7bit-ss2 'iso-2022-jp-2) | |
| 132 (make-coding-system | |
| 133 'iso-2022-jp-2 'iso2022 | |
| 771 | 134 "ISO-2022-JP-2" |
| 333 | 135 '(charset-g0 ascii |
| 136 charset-g2 t ;; unspecified but can be used later. | |
| 137 seven t | |
| 138 short t | |
| 139 mnemonic "ISO7/SS" | |
| 140 eol-type nil)) | |
| 141 | |
| 142 (make-coding-system | |
| 143 'iso-2022-7bit 'iso2022 | |
| 771 | 144 "ISO 2022 7-bit" |
| 333 | 145 '(charset-g0 ascii |
| 146 seven t | |
| 147 short t | |
| 771 | 148 mnemonic "ISO7" |
| 149 documentation "ISO-2022-based 7-bit encoding using only G0" | |
| 150 )) | |
| 333 | 151 |
| 152 ;; compatibility for old XEmacsen | |
| 771 | 153 (define-coding-system-alias 'iso-2022-7 'iso-2022-7bit) |
| 333 | 154 |
| 155 (make-coding-system | |
| 156 'iso-2022-8 'iso2022 | |
| 771 | 157 "ISO-2022 8-bit" |
| 333 | 158 '(charset-g0 ascii |
| 159 charset-g1 latin-iso8859-1 | |
| 160 short t | |
| 161 mnemonic "ISO8" | |
| 771 | 162 documentation "ISO-2022 eight-bit coding system. No single-shift or locking-shift." |
| 333 | 163 )) |
| 164 | |
| 165 (make-coding-system | |
| 166 'escape-quoted 'iso2022 | |
| 771 | 167 "Escape-Quoted (for .ELC files)" |
| 333 | 168 '(charset-g0 ascii |
| 169 charset-g1 latin-iso8859-1 | |
| 170 eol-type lf | |
| 171 escape-quoted t | |
| 172 mnemonic "ESC/Quot" | |
| 771 | 173 documentation "ISO-2022 eight-bit coding system with escape quoting; used for .ELC files." |
| 333 | 174 )) |
| 175 | |
| 176 (make-coding-system | |
| 177 'iso-2022-lock 'iso2022 | |
| 771 | 178 "ISO-2022 w/locking-shift" |
| 333 | 179 '(charset-g0 ascii |
| 180 charset-g1 t ;; unspecified but can be used later. | |
| 181 seven t | |
| 182 lock-shift t | |
| 183 mnemonic "ISO7/Lock" | |
| 771 | 184 documentation "ISO-2022 coding system using Locking-Shift for 96-charset." |
| 333 | 185 )) |
| 4072 | 186 |
| 333 | 187 |
| 4072 | 188 ;; This is used by people writing CCL programs, but is called at runtime. |
| 189 (defun define-translation-hash-table (symbol table) | |
| 190 "Define SYMBOL as the name of the hash translation TABLE for use in CCL. | |
| 191 | |
| 192 Analogous to `define-translation-table', but updates | |
| 193 `translation-hash-table-vector' and the table is for use in the CCL | |
| 194 `lookup-integer' and `lookup-character' functions." | |
| 4145 | 195 (check-argument-type #'symbolp symbol) |
| 196 (check-argument-type #'hash-table-p table) | |
| 4072 | 197 (let ((len (length translation-hash-table-vector)) |
| 198 (id 0) | |
| 199 done) | |
| 200 (put symbol 'translation-hash-table table) | |
| 201 (while (not done) | |
| 202 (if (>= id len) | |
| 203 (setq translation-hash-table-vector | |
| 204 (vconcat translation-hash-table-vector [nil]))) | |
| 205 (let ((slot (aref translation-hash-table-vector id))) | |
| 206 (if (or (not slot) | |
| 207 (eq (car slot) symbol)) | |
| 208 (progn | |
| 209 (aset translation-hash-table-vector id (cons symbol table)) | |
| 210 (setq done t)) | |
| 211 (setq id (1+ id))))) | |
| 212 (put symbol 'translation-hash-table-id id) | |
| 213 id)) | |
| 214 | |
| 215 (defvar make-8-bit-private-use-start (decode-char 'ucs #xE000) | |
| 216 "Start of a 256 code private use area for make-8-bit-coding-system. | |
| 217 | |
| 218 This is used to ensure that distinct octets on disk for a given coding | |
| 219 system map to distinct XEmacs characters, preventing a spurious changes when | |
| 220 a file is read, not changed, and then written. ") | |
| 221 | |
| 222 (defun make-8-bit-generate-helper (decode-table encode-table | |
| 223 encode-failure-octet) | |
| 224 "Helper function for `make-8-bit-generate-encode-program', which see. | |
| 225 | |
| 4145 | 226 Deals with the case where ASCII and another character set can both be |
| 227 encoded unambiguously and completely into the coding-system; if this is so, | |
| 228 returns a list corresponding to such a ccl-program. If not, it returns nil. " | |
| 4072 | 229 (let ((tentative-encode-program-parts |
| 230 (eval-when-compile | |
| 4295 | 231 (let* ((vec-len 128) |
| 232 (compiled | |
| 4072 | 233 (append |
| 234 (ccl-compile | |
| 235 `(1 | |
| 236 (loop | |
| 237 (read-multibyte-character r0 r1) | |
| 238 (if (r0 == ,(charset-id 'ascii)) | |
| 239 (write r1) | |
| 240 ((if (r0 == #xABAB) | |
| 241 ;; #xBFFE is a sentinel in the compiled | |
| 242 ;; program. | |
| 4295 | 243 ;; #xBFFE is a sentinel in the compiled |
| 244 ;; program. | |
| 245 ((r0 = r1 & #x7F) | |
| 246 (write r0 ,(make-vector vec-len #xBFFE))) | |
| 4072 | 247 ((mule-to-unicode r0 r1) |
| 248 (if (r0 == #xFFFD) | |
| 249 (write #xBEEF) | |
| 250 ((lookup-integer encode-table-sym r0 r3) | |
| 251 (if r7 | |
| 252 (write-multibyte-character r0 r3) | |
| 253 (write #xBEEF)))))))) | |
| 254 (repeat)))) nil)) | |
| 255 (first-part compiled) | |
| 256 (last-part | |
| 257 (member-if-not (lambda (entr) (eq #xBFFE entr)) | |
| 258 (member-if | |
| 259 (lambda (entr) (eq #xBFFE entr)) | |
| 260 first-part)))) | |
| 261 (while compiled | |
| 4295 | 262 (when (eq #xBFFE (cadr compiled)) |
| 263 (assert (= vec-len (search '(#xBFFE) (cdr compiled) | |
| 264 :test #'/=)) nil | |
| 265 "Strange ccl vector length") | |
| 266 (setcdr compiled nil)) | |
| 4072 | 267 (setq compiled (cdr compiled))) |
| 268 ;; Is the generated code as we expect it to be? | |
| 269 (assert (and (memq #xABAB first-part) | |
| 270 (memq #xBEEF14 last-part)) | |
| 271 nil | |
| 272 "This code assumes that the constant #xBEEF is #xBEEF14 in \ | |
| 273 compiled CCL code,\nand that the constant #xABAB is #xABAB. If that is | |
| 274 not the case, and it appears not to be--that's why you're getting this | |
| 275 message--it will not work. ") | |
| 4295 | 276 (list first-part last-part vec-len)))) |
| 4072 | 277 (charset-lower -1) |
| 278 (charset-upper -1) | |
| 279 worth-trying known-charsets encode-program | |
| 4295 | 280 other-charset-vector ucs args-out-of-range) |
| 4072 | 281 |
| 282 (loop for char across decode-table | |
| 283 do (pushnew (char-charset char) known-charsets)) | |
| 284 (setq known-charsets (delq 'ascii known-charsets)) | |
| 285 | |
| 286 (loop for known-charset in known-charsets | |
| 287 do | |
| 288 ;; This is not possible for two dimensional charsets. | |
| 289 (when (eq 1 (charset-dimension known-charset)) | |
| 290 (setq args-out-of-range t) | |
| 291 (if (eq 'control-1 known-charset) | |
| 292 (setq charset-lower 0 | |
| 293 charset-upper 31) | |
| 294 ;; There should be a nicer way to get the limits here. | |
| 295 (condition-case args-out-of-range | |
| 296 (make-char known-charset #x100) | |
| 297 (args-out-of-range | |
| 298 (setq charset-lower (third args-out-of-range) | |
| 299 charset-upper (fourth args-out-of-range))))) | |
| 300 (loop | |
| 301 for i from charset-lower to charset-upper | |
| 302 always (and (setq ucs | |
| 303 (encode-char (make-char known-charset i) 'ucs)) | |
| 304 (gethash ucs encode-table)) | |
| 305 finally (setq worth-trying known-charset)) | |
| 306 | |
| 307 ;; Only trying this for one charset at a time, the first find. | |
| 308 (when worth-trying (return)) | |
| 309 | |
| 310 ;; Okay, this charset is not worth trying, Try the next. | |
| 311 (setq charset-lower -1 | |
| 312 charset-upper -1 | |
| 313 worth-trying nil))) | |
| 314 | |
| 315 (when worth-trying | |
| 4295 | 316 (setq other-charset-vector |
| 317 (make-vector (third tentative-encode-program-parts) | |
| 318 encode-failure-octet)) | |
| 4072 | 319 (loop for i from charset-lower to charset-upper |
| 4090 | 320 do (aset other-charset-vector i |
| 4072 | 321 (gethash (encode-char (make-char worth-trying i) |
| 322 'ucs) encode-table))) | |
| 323 (setq encode-program | |
| 324 (nsublis | |
| 325 (list (cons #xABAB (charset-id worth-trying))) | |
| 326 (nconc | |
| 327 (copy-list (first | |
| 328 tentative-encode-program-parts)) | |
| 329 (append other-charset-vector nil) | |
| 330 (copy-tree (second | |
| 331 tentative-encode-program-parts)))))) | |
| 332 encode-program)) | |
| 333 | |
| 334 (defun make-8-bit-generate-encode-program (decode-table encode-table | |
| 335 encode-failure-octet) | |
| 336 "Generate a CCL program to decode a 8-bit fixed-width charset. | |
| 337 | |
| 338 DECODE-TABLE must have 256 non-cons entries, and will be regarded as | |
| 339 describing a map from the octet corresponding to an offset in the | |
| 340 table to the that entry in the table. ENCODE-TABLE is a hash table | |
| 341 map from unicode values to characters in the range [0,255]. | |
| 342 ENCODE-FAILURE-OCTET describes an integer between 0 and 255 | |
| 343 \(inclusive) to write in the event that a character cannot be encoded. " | |
| 344 (check-argument-type #'vectorp decode-table) | |
| 345 (check-argument-range (length decode-table) #x100 #x100) | |
| 346 (check-argument-type #'hash-table-p encode-table) | |
| 347 (check-argument-type #'integerp encode-failure-octet) | |
| 348 (check-argument-range encode-failure-octet #x00 #xFF) | |
| 349 (let ((encode-program nil) | |
| 350 (general-encode-program | |
| 351 (eval-when-compile | |
| 352 (let ((prog (append | |
| 353 (ccl-compile | |
| 354 `(1 | |
| 355 (loop | |
| 356 (read-multibyte-character r0 r1) | |
| 357 (mule-to-unicode r0 r1) | |
| 358 (if (r0 == #xFFFD) | |
| 359 (write #xBEEF) | |
| 360 ((lookup-integer encode-table-sym r0 r3) | |
| 361 (if r7 | |
| 362 (write-multibyte-character r0 r3) | |
| 363 (write #xBEEF)))) | |
| 364 (repeat)))) nil))) | |
| 365 (assert (memq #xBEEF14 prog) | |
| 366 nil | |
| 367 "This code assumes that the constant #xBEEF is #xBEEF14 \ | |
| 368 in compiled CCL code.\nIf that is not the case, and it appears not to | |
| 369 be--that's why you're getting this message--it will not work. ") | |
| 370 prog))) | |
| 371 (encode-program-with-ascii-optimisation | |
| 372 (eval-when-compile | |
| 373 (let ((prog (append | |
| 374 (ccl-compile | |
| 375 `(1 | |
| 376 (loop | |
| 377 (read-multibyte-character r0 r1) | |
| 378 (if (r0 == ,(charset-id 'ascii)) | |
| 379 (write r1) | |
| 380 ((mule-to-unicode r0 r1) | |
| 381 (if (r0 == #xFFFD) | |
| 382 (write #xBEEF) | |
| 383 ((lookup-integer encode-table-sym r0 r3) | |
| 384 (if r7 | |
| 385 (write-multibyte-character r0 r3) | |
| 386 (write #xBEEF)))))) | |
| 387 (repeat)))) nil))) | |
| 388 (assert (memq #xBEEF14 prog) | |
| 389 nil | |
| 390 "This code assumes that the constant #xBEEF is #xBEEF14 \ | |
| 391 in compiled CCL code.\nIf that is not the case, and it appears not to | |
| 392 be--that's why you're getting this message--it will not work. ") | |
| 393 prog))) | |
| 394 (ascii-encodes-as-itself nil)) | |
| 395 | |
| 396 ;; Is this coding system ASCII-compatible? If so, we can avoid the hash | |
| 397 ;; table lookup for those characters. | |
| 398 (loop | |
| 399 for i from #x00 to #x7f | |
| 400 always (eq (int-to-char i) (gethash i encode-table)) | |
| 401 finally (setq ascii-encodes-as-itself t)) | |
| 402 | |
| 403 ;; Note that this logic handles EBCDIC badly. For example, CP037, | |
| 404 ;; MIME name ebcdic-na, has the entire repertoire of ASCII and | |
| 405 ;; Latin 1, and thus a more optimal ccl encode program would check | |
| 406 ;; for those character sets and use tables. But for now, we do a | |
| 407 ;; hash table lookup for every character. | |
| 408 (if (null ascii-encodes-as-itself) | |
| 409 ;; General encode program. Pros; general and correct. Cons; | |
| 410 ;; slow, a hash table lookup + mule-unicode conversion is done | |
| 411 ;; for every character encoding. | |
| 412 (setq encode-program general-encode-program) | |
| 413 (setq encode-program | |
| 414 ;; Encode program with ascii-ascii mapping (based on a | |
| 415 ;; character's mule character set), and one other mule | |
| 416 ;; character set using table-based encoding, other | |
| 417 ;; character sets using hash table lookups. | |
| 418 ;; make-8-bit-non-ascii-completely-coveredp only returns | |
| 419 ;; such a mapping if some non-ASCII charset with | |
| 420 ;; characters in decode-table is entirely covered by | |
| 421 ;; encode-table. | |
| 422 (make-8-bit-generate-helper decode-table encode-table | |
| 423 encode-failure-octet)) | |
| 424 (unless encode-program | |
| 425 ;; If make-8-bit-non-ascii-completely-coveredp returned nil, | |
| 426 ;; but ASCII still encodes as itself, do one-to-one mapping | |
| 427 ;; for ASCII, and a hash table lookup for everything else. | |
| 428 (setq encode-program encode-program-with-ascii-optimisation))) | |
| 429 | |
| 430 (setq encode-program | |
| 431 (nsublis | |
| 432 (list (cons #xBEEF14 | |
| 433 (logior (lsh encode-failure-octet 8) | |
| 434 #x14))) | |
| 435 (copy-tree encode-program))) | |
| 436 encode-program)) | |
| 437 | |
| 438 (defun make-8-bit-create-decode-encode-tables (unicode-map) | |
| 439 "Return a list \(DECODE-TABLE ENCODE-TABLE) given UNICODE-MAP. | |
| 440 UNICODE-MAP should be an alist mapping from integer octet values to | |
| 441 characters with UCS code points; DECODE-TABLE will be a 256-element | |
| 442 vector, and ENCODE-TABLE will be a hash table mapping from 256 numbers | |
| 443 to 256 distinct characters. " | |
| 444 (check-argument-type #'listp unicode-map) | |
| 445 (let ((decode-table (make-vector 256 nil)) | |
| 446 (encode-table (make-hash-table :size 256)) | |
| 447 (private-use-start (encode-char make-8-bit-private-use-start 'ucs)) | |
| 448 desired-ucs) | |
| 449 | |
| 450 (loop for (external internal) | |
| 451 in unicode-map | |
| 452 do | |
| 453 (aset decode-table external internal) | |
| 454 (assert (not (eq (encode-char internal 'ucs) -1)) | |
| 455 nil | |
| 456 "Looks like you're calling make-8-bit-coding-system in a \ | |
| 457 dumped file, \nand you're either not providing a literal UNICODE-MAP | |
| 458 or PROPS. Don't do that; make-8-bit-coding-system relies on sensible | |
| 459 Unicode mappings being available, which they are at compile time for | |
| 460 dumped files (but this requires the mentioned literals), but not, for | |
| 461 most of them, at run time. ") | |
| 462 | |
| 463 (puthash (encode-char internal 'ucs) | |
| 464 ;; This is semantically an integer, but Dave Love's design | |
| 465 ;; for lookup-integer in CCL means we need to store it as a | |
| 466 ;; character. | |
| 467 (int-to-char external) | |
| 468 encode-table)) | |
| 469 | |
| 470 ;; Now, go through the decode table looking at the characters that | |
| 471 ;; remain nil. If the XEmacs character with that integer is already in | |
| 472 ;; the encode table, map the on-disk octet to a Unicode private use | |
| 473 ;; character. Otherwise map the on-disk octet to the XEmacs character | |
| 474 ;; with that numeric value, to make it clearer what it is. | |
| 475 (dotimes (i 256) | |
| 476 (when (null (aref decode-table i)) | |
| 477 ;; Find a free code point. | |
| 478 (setq desired-ucs i) | |
| 479 (while (gethash desired-ucs encode-table) | |
| 480 ;; In the normal case, the code point chosen will be U+E0XY, where | |
| 481 ;; XY is the hexadecimal octet on disk. In pathological cases | |
| 482 ;; it'll be something else. | |
| 483 (setq desired-ucs (+ private-use-start desired-ucs) | |
| 484 private-use-start (+ private-use-start 1))) | |
| 4085 | 485 (puthash desired-ucs (int-to-char i) encode-table) |
| 486 (setq desired-ucs (if (> desired-ucs #xFF) | |
| 487 (decode-char 'ucs desired-ucs) | |
| 488 ;; So we get Latin-1 when run at dump time, | |
| 489 ;; instead of JIT-allocated characters. | |
| 490 (int-to-char desired-ucs))) | |
| 491 (aset decode-table i desired-ucs))) | |
| 4072 | 492 (values decode-table encode-table))) |
| 493 | |
| 494 (defun make-8-bit-generate-decode-program (decode-table) | |
| 495 "Given DECODE-TABLE, generate a CCL program to decode an 8-bit charset. | |
| 496 DECODE-TABLE must have 256 non-cons entries, and will be regarded as | |
| 497 describing a map from the octet corresponding to an offset in the | |
| 498 table to the that entry in the table. " | |
| 499 (check-argument-type #'vectorp decode-table) | |
| 500 (check-argument-range (length decode-table) #x100 #x100) | |
| 501 (let ((decode-program-parts | |
| 502 (eval-when-compile | |
| 503 (let* ((compiled | |
| 504 (append | |
| 505 (ccl-compile | |
| 506 `(3 | |
| 507 ((read r0) | |
| 508 (loop | |
| 509 (write-read-repeat r0 ,(make-vector | |
| 510 256 'sentinel)))))) nil)) | |
| 511 (first-part compiled) | |
| 512 (last-part | |
| 513 (member-if-not #'symbolp | |
| 514 (member-if-not #'integerp first-part)))) | |
| 515 ;; Chop off the sentinel sentinel sentinel [..] part. | |
| 516 (while compiled | |
| 517 (if (symbolp (cadr compiled)) | |
| 518 (setcdr compiled nil)) | |
| 519 (setq compiled (cdr compiled))) | |
| 520 (list first-part last-part))))) | |
| 521 (nconc | |
| 522 ;; copy-list needed, because the structure of the literal provided | |
| 523 ;; by our eval-when-compile hangs around. | |
| 524 (copy-list (first decode-program-parts)) | |
| 525 (append decode-table nil) | |
| 526 (second decode-program-parts)))) | |
| 527 | |
| 4145 | 528 (defun make-8-bit-choose-category (decode-table) |
| 529 "Given DECODE-TABLE, return an appropriate coding category. | |
| 530 DECODE-TABLE is a 256-entry vector describing the mapping from octets on | |
| 531 disk to XEmacs characters for some fixed-width 8-bit coding system. " | |
| 532 (check-argument-type #'vectorp decode-table) | |
| 533 (check-argument-range (length decode-table) #x100 #x100) | |
| 534 (block category | |
| 535 (loop | |
|
4460
04ec3340612e
Correct coding-category determination for 8-bit-fixed coding systems.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4299
diff
changeset
|
536 for i from #x80 to #x9F |
| 4145 | 537 do (unless (= i (aref decode-table i)) |
| 538 (return-from category 'no-conversion))) | |
| 539 'iso-8-1)) | |
| 540 | |
| 4072 | 541 ;;;###autoload |
| 542 (defun make-8-bit-coding-system (name unicode-map &optional description props) | |
| 543 "Make and return a fixed-width 8-bit CCL coding system named NAME. | |
| 544 NAME must be a symbol, and UNICODE-MAP a list. | |
| 545 | |
| 546 UNICODE-MAP is a plist describing a map from octets in the coding | |
| 547 system NAME (as integers) to XEmacs characters. Those XEmacs | |
| 548 characters will be used explicitly on decoding, but for encoding (most | |
| 549 relevantly, on writing to disk) XEmacs characters that map to the same | |
| 550 Unicode code point will be unified. This means that the ISO-8859-? | |
| 551 characters that map to the same Unicode code point will not be | |
| 552 distinct when written to disk, which is normally what is intended; it | |
| 553 also means that East Asian Han characters from different XEmacs | |
| 554 character sets will not be distinct when written to disk, which is | |
| 555 less often what is intended. | |
| 556 | |
| 557 Any octets not mapped will be decoded into the ISO 8859-1 characters with | |
| 558 the corresponding numeric value; unless another octet maps to that | |
| 559 character, in which case the Unicode private use area will be used. This | |
| 560 avoids spurious changes to files on disk when they contain octets that would | |
| 561 be otherwise remapped to the canonical values for the corresponding | |
| 562 characters in the coding system. | |
| 563 | |
| 564 DESCRIPTION and PROPS are as in `make-coding-system', which see. This | |
| 565 function also accepts two additional (optional) properties in PROPS; | |
| 566 `aliases', giving a list of aliases to be initialized for this | |
| 567 coding-system, and `encode-failure-octet', an integer between 0 and 256 to | |
| 568 write in place of XEmacs characters that cannot be encoded, defaulting to | |
| 569 the code for tilde `~'. " | |
| 570 (check-argument-type #'symbolp name) | |
| 571 (check-argument-type #'listp unicode-map) | |
| 572 (check-argument-type #'stringp | |
| 573 (or description | |
| 574 (setq description | |
| 575 (format "Coding system used for %s." name)))) | |
| 576 (check-valid-plist props) | |
| 577 (let ((encode-failure-octet (or (plist-get props 'encode-failure-octet) | |
| 578 (char-to-int ?~))) | |
| 579 (aliases (plist-get props 'aliases)) | |
| 580 (hash-table-sym (gentemp (format "%s-encode-table" name))) | |
| 581 encode-program decode-program result decode-table encode-table) | |
| 582 | |
| 583 ;; Some more sanity checking. | |
| 584 (check-argument-range encode-failure-octet 0 #xFF) | |
| 585 (check-argument-type #'listp aliases) | |
| 586 | |
| 587 ;; Don't pass on our extra data to make-coding-system. | |
| 588 (setq props (plist-remprop props 'encode-failure-octet) | |
| 589 props (plist-remprop props 'aliases)) | |
| 590 | |
| 591 (multiple-value-setq | |
| 592 (decode-table encode-table) | |
| 593 (make-8-bit-create-decode-encode-tables unicode-map)) | |
| 594 | |
| 595 ;; Register the decode-table. | |
| 596 (define-translation-hash-table hash-table-sym encode-table) | |
| 597 | |
| 598 ;; Generate the programs. | |
| 599 (setq decode-program (make-8-bit-generate-decode-program decode-table) | |
| 600 encode-program (make-8-bit-generate-encode-program | |
| 601 decode-table encode-table encode-failure-octet)) | |
| 602 (unless (vectorp encode-program) | |
| 603 (setq encode-program | |
| 604 (apply #'vector | |
| 605 (nsublis (list (cons 'encode-table-sym hash-table-sym)) | |
| 606 (copy-tree encode-program))))) | |
| 607 (unless (vectorp decode-program) | |
| 608 (setq decode-program | |
| 609 (apply #'vector decode-program))) | |
| 610 | |
| 611 ;; And now generate the actual coding system. | |
| 612 (setq result | |
| 613 (make-coding-system | |
| 614 name 'ccl | |
| 615 description | |
| 616 (plist-put (plist-put props 'decode decode-program) | |
| 617 'encode encode-program))) | |
| 4295 | 618 (coding-system-put name '8-bit-fixed t) |
| 4145 | 619 (coding-system-put name 'category |
| 620 (make-8-bit-choose-category decode-table)) | |
| 4072 | 621 (loop for alias in aliases |
| 622 do (define-coding-system-alias alias name)) | |
| 623 result)) | |
| 624 | |
| 625 (define-compiler-macro make-8-bit-coding-system (&whole form name unicode-map | |
| 626 &optional description props) | |
| 627 | |
| 628 ;; We provide the compiler macro (= macro that is expanded only on | |
| 629 ;; compilation, and that can punt to a runtime version of the | |
| 630 ;; associate function if necessary) not for reasons of speed, though | |
| 631 ;; it does speed up things at runtime a little, but because the | |
| 632 ;; Unicode mappings are available at compile time in the dumped | |
| 633 ;; files, but they are not available at run time for the vast | |
| 634 ;; majority of them. | |
| 635 | |
| 636 (if (not (and (and (consp name) (eq (car name) 'quote)) | |
| 637 (and (consp unicode-map) (eq (car unicode-map) 'quote)) | |
| 638 (and (or (and (consp props) (eq (car props) 'quote)) | |
| 639 (null props))))) | |
| 640 ;; The call does not use literals; do it at runtime. | |
| 641 form | |
| 642 (setq name (cadr name) | |
| 643 unicode-map (cadr unicode-map) | |
| 644 props (if props (cadr props))) | |
| 645 (let ((encode-failure-octet | |
| 646 (or (plist-get props 'encode-failure-octet) (char-to-int ?~))) | |
| 647 (aliases (plist-get props 'aliases)) | |
| 648 encode-program decode-program | |
| 4103 | 649 decode-table encode-table) |
| 4072 | 650 |
| 651 ;; Some sanity checking. | |
| 652 (check-argument-range encode-failure-octet 0 #xFF) | |
| 653 (check-argument-type #'listp aliases) | |
| 654 | |
| 655 ;; Don't pass on our extra data to make-coding-system. | |
| 656 (setq props (plist-remprop props 'encode-failure-octet) | |
| 657 props (plist-remprop props 'aliases)) | |
| 658 | |
| 659 ;; Work out encode-table and decode-table. | |
| 660 (multiple-value-setq | |
| 661 (decode-table encode-table) | |
| 662 (make-8-bit-create-decode-encode-tables unicode-map)) | |
| 663 | |
| 664 ;; Generate the decode and encode programs. | |
| 665 (setq decode-program (make-8-bit-generate-decode-program decode-table) | |
| 666 encode-program (make-8-bit-generate-encode-program | |
| 667 decode-table encode-table encode-failure-octet)) | |
| 668 | |
| 669 ;; And return the generated code. | |
| 670 `(let ((encode-table-sym (gentemp (format "%s-encode-table" ',name))) | |
| 4103 | 671 ;; The case-fold-search bind shouldn't be necessary. If I take |
| 672 ;; it, out, though, I get: | |
| 673 ;; | |
| 674 ;; (invalid-read-syntax "Multiply defined symbol label" 1) | |
| 675 ;; | |
| 676 ;; when the file is byte compiled. | |
| 677 (case-fold-search t)) | |
| 4072 | 678 (define-translation-hash-table encode-table-sym ,encode-table) |
| 4103 | 679 (make-coding-system |
| 680 ',name 'ccl ,description | |
| 681 (plist-put (plist-put ',props 'decode | |
| 682 ,(apply #'vector decode-program)) | |
| 683 'encode | |
| 684 (apply #'vector | |
| 685 (nsublis | |
| 686 (list (cons | |
| 687 'encode-table-sym | |
| 688 (symbol-value 'encode-table-sym))) | |
| 689 ',encode-program)))) | |
| 4295 | 690 (coding-system-put ',name '8-bit-fixed t) |
| 4145 | 691 (coding-system-put ',name 'category ', |
| 692 (make-8-bit-choose-category decode-table)) | |
| 4072 | 693 ,(macroexpand `(loop for alias in ',aliases |
| 694 do (define-coding-system-alias alias | |
| 695 ',name))) | |
| 4103 | 696 (find-coding-system ',name))))) |
| 4299 | 697 |
| 698 ;; Ideally this would be in latin.el, but code-init.el uses it. | |
| 699 (make-8-bit-coding-system | |
| 700 'iso-8859-1 | |
| 701 '() ;; No differences from Latin 1. | |
| 702 "ISO-8859-1 (Latin-1)" | |
| 703 '(mnemonic "Latin 1" | |
| 704 documentation "The most used encoding of Western Europe and the Americas." | |
| 705 aliases (iso-latin-1 latin-1))) | |
| 706 |