Mercurial > hg > xemacs-beta
comparison lisp/mule/mule-coding.el @ 4145:edb00a8b4eff
[xemacs-hg @ 2007-08-26 20:00:29 by aidan]
Generally make the language environments and coding systems a little more sane.
| author | aidan |
|---|---|
| date | Sun, 26 Aug 2007 20:00:42 +0000 |
| parents | b4f4e0cc90f1 |
| children | eded49463f9a |
comparison
equal
deleted
inserted
replaced
| 4144:4a08a9219456 | 4145:edb00a8b4eff |
|---|---|
| 195 "Define SYMBOL as the name of the hash translation TABLE for use in CCL. | 195 "Define SYMBOL as the name of the hash translation TABLE for use in CCL. |
| 196 | 196 |
| 197 Analogous to `define-translation-table', but updates | 197 Analogous to `define-translation-table', but updates |
| 198 `translation-hash-table-vector' and the table is for use in the CCL | 198 `translation-hash-table-vector' and the table is for use in the CCL |
| 199 `lookup-integer' and `lookup-character' functions." | 199 `lookup-integer' and `lookup-character' functions." |
| 200 (unless (and (symbolp symbol) | 200 (check-argument-type #'symbolp symbol) |
| 201 (hash-table-p table)) | 201 (check-argument-type #'hash-table-p table) |
| 202 (error "Bad args to define-translation-hash-table")) | |
| 203 (let ((len (length translation-hash-table-vector)) | 202 (let ((len (length translation-hash-table-vector)) |
| 204 (id 0) | 203 (id 0) |
| 205 done) | 204 done) |
| 206 (put symbol 'translation-hash-table table) | 205 (put symbol 'translation-hash-table table) |
| 207 (while (not done) | 206 (while (not done) |
| 227 | 226 |
| 228 (defun make-8-bit-generate-helper (decode-table encode-table | 227 (defun make-8-bit-generate-helper (decode-table encode-table |
| 229 encode-failure-octet) | 228 encode-failure-octet) |
| 230 "Helper function for `make-8-bit-generate-encode-program', which see. | 229 "Helper function for `make-8-bit-generate-encode-program', which see. |
| 231 | 230 |
| 232 Deals with the case where ASCII and another character set provide the | 231 Deals with the case where ASCII and another character set can both be |
| 233 can both be encoded unambiguously into the coding-system; if this is | 232 encoded unambiguously and completely into the coding-system; if this is so, |
| 234 so, returns a list corresponding to such a ccl-program. If not, it | 233 returns a list corresponding to such a ccl-program. If not, it returns nil. " |
| 235 returns nil. " | |
| 236 (let ((tentative-encode-program-parts | 234 (let ((tentative-encode-program-parts |
| 237 (eval-when-compile | 235 (eval-when-compile |
| 238 (let* ((compiled | 236 (let* ((compiled |
| 239 (append | 237 (append |
| 240 (ccl-compile | 238 (ccl-compile |
| 311 (setq charset-lower -1 | 309 (setq charset-lower -1 |
| 312 charset-upper -1 | 310 charset-upper -1 |
| 313 worth-trying nil))) | 311 worth-trying nil))) |
| 314 | 312 |
| 315 (when worth-trying | 313 (when worth-trying |
| 316 (setq other-charset-vector (make-vector 256 encode-failure-octet)) | 314 (setq other-charset-vector (make-vector 128 encode-failure-octet)) |
| 317 (loop for i from charset-lower to charset-upper | 315 (loop for i from charset-lower to charset-upper |
| 318 do (aset other-charset-vector i | 316 do (aset other-charset-vector i |
| 319 (gethash (encode-char (make-char worth-trying i) | 317 (gethash (encode-char (make-char worth-trying i) |
| 320 'ucs) encode-table))) | 318 'ucs) encode-table))) |
| 321 (setq encode-program | 319 (setq encode-program |
| 521 ;; by our eval-when-compile hangs around. | 519 ;; by our eval-when-compile hangs around. |
| 522 (copy-list (first decode-program-parts)) | 520 (copy-list (first decode-program-parts)) |
| 523 (append decode-table nil) | 521 (append decode-table nil) |
| 524 (second decode-program-parts)))) | 522 (second decode-program-parts)))) |
| 525 | 523 |
| 524 (defun make-8-bit-choose-category (decode-table) | |
| 525 "Given DECODE-TABLE, return an appropriate coding category. | |
| 526 DECODE-TABLE is a 256-entry vector describing the mapping from octets on | |
| 527 disk to XEmacs characters for some fixed-width 8-bit coding system. " | |
| 528 (check-argument-type #'vectorp decode-table) | |
| 529 (check-argument-range (length decode-table) #x100 #x100) | |
| 530 (block category | |
| 531 (loop | |
| 532 for i from #x80 to #xBF | |
| 533 do (unless (= i (aref decode-table i)) | |
| 534 (return-from category 'no-conversion))) | |
| 535 'iso-8-1)) | |
| 536 | |
| 526 ;;;###autoload | 537 ;;;###autoload |
| 527 (defun make-8-bit-coding-system (name unicode-map &optional description props) | 538 (defun make-8-bit-coding-system (name unicode-map &optional description props) |
| 528 "Make and return a fixed-width 8-bit CCL coding system named NAME. | 539 "Make and return a fixed-width 8-bit CCL coding system named NAME. |
| 529 NAME must be a symbol, and UNICODE-MAP a list. | 540 NAME must be a symbol, and UNICODE-MAP a list. |
| 530 | 541 |
| 598 (make-coding-system | 609 (make-coding-system |
| 599 name 'ccl | 610 name 'ccl |
| 600 description | 611 description |
| 601 (plist-put (plist-put props 'decode decode-program) | 612 (plist-put (plist-put props 'decode decode-program) |
| 602 'encode encode-program))) | 613 'encode encode-program))) |
| 603 (coding-system-put name 'category 'iso-8-1) | 614 (coding-system-put name 'category |
| 615 (make-8-bit-choose-category decode-table)) | |
| 604 (loop for alias in aliases | 616 (loop for alias in aliases |
| 605 do (define-coding-system-alias alias name)) | 617 do (define-coding-system-alias alias name)) |
| 606 result)) | 618 result)) |
| 607 | 619 |
| 608 ;;;###autoload | |
| 609 (define-compiler-macro make-8-bit-coding-system (&whole form name unicode-map | 620 (define-compiler-macro make-8-bit-coding-system (&whole form name unicode-map |
| 610 &optional description props) | 621 &optional description props) |
| 611 | 622 |
| 612 ;; We provide the compiler macro (= macro that is expanded only on | 623 ;; We provide the compiler macro (= macro that is expanded only on |
| 613 ;; compilation, and that can punt to a runtime version of the | 624 ;; compilation, and that can punt to a runtime version of the |
| 669 (nsublis | 680 (nsublis |
| 670 (list (cons | 681 (list (cons |
| 671 'encode-table-sym | 682 'encode-table-sym |
| 672 (symbol-value 'encode-table-sym))) | 683 (symbol-value 'encode-table-sym))) |
| 673 ',encode-program)))) | 684 ',encode-program)))) |
| 674 (coding-system-put ',name 'category 'iso-8-1) | 685 (coding-system-put ',name 'category ', |
| 686 (make-8-bit-choose-category decode-table)) | |
| 675 ,(macroexpand `(loop for alias in ',aliases | 687 ,(macroexpand `(loop for alias in ',aliases |
| 676 do (define-coding-system-alias alias | 688 do (define-coding-system-alias alias |
| 677 ',name))) | 689 ',name))) |
| 678 (find-coding-system ',name))))) | 690 (find-coding-system ',name))))) |