lisp/international/mule.el

   1 ;;; mule.el --- basic commands for mulitilingual environment
   2
   3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
   4 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   5 ;; Licensed to the Free Software Foundation.
   6
   7 ;; Keywords: mule, multilingual, character set, coding system
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (defconst mule-version "5.0 (SAKAKI)" "\
  31 Version number and name of this version of MULE (multilingual environment).")
  32
  33 (defconst mule-version-date "1999.12.7" "\
  34 Distribution date of this version of MULE (multilingual environment).")
  35
  36 (defun load-with-code-conversion (fullname file &optional noerror nomessage)
  37   "Execute a file of Lisp code named FILE whose absolute name is FULLNAME.
  38 The file contents are decoded before evaluation if necessary.
  39 If optional second arg NOERROR is non-nil,
  40  report no error if FILE doesn't exist.
  41 Print messages at start and end of loading unless
  42  optional third arg NOMESSAGE is non-nil.
  43 Return t if file exists."
  44   (if (null (file-readable-p fullname))
  45       (and (null noerror)
  46            (signal 'file-error (list "Cannot open load file" file)))
  47     ;; Read file with code conversion, and then eval.
  48     (let* ((buffer
  49             ;; To avoid any autoloading, set default-major-mode to
  50             ;; fundamental-mode.
  51             ;; So that we don't get completely screwed if the
  52             ;; file is encoded in some complicated character set,
  53             ;; read it with real decoding, as a multibyte buffer,
  54             ;; even if this is a --unibyte Emacs session.
  55             (let ((default-major-mode 'fundamental-mode)
  56                   (default-enable-multibyte-characters t))
  57               ;; We can't use `generate-new-buffer' because files.el
  58               ;; is not yet loaded.
  59               (get-buffer-create (generate-new-buffer-name " *load*"))))
  60            (load-in-progress t)
  61            (source (save-match-data (string-match "\\.el\\'" fullname))))
  62       (unless nomessage
  63         (if source
  64             (message "Loading %s (source)..." file)
  65           (message "Loading %s..." file)))
  66       (when purify-flag
  67         (setq preloaded-file-list (cons file preloaded-file-list)))
  68       (unwind-protect
  69           (let ((load-file-name fullname)
  70                 (set-auto-coding-for-load t)
  71                 (inhibit-file-name-operation nil))
  72             (save-excursion
  73               (set-buffer buffer)
  74               (insert-file-contents fullname)
  75               ;; If the loaded file was inserted with no-conversion or
  76               ;; raw-text coding system, make the buffer unibyte.
  77               ;; Otherwise, eval-buffer might try to interpret random
  78               ;; binary junk as multibyte characters.
  79               (if (and enable-multibyte-characters
  80                        (or (eq (coding-system-type last-coding-system-used) 5)
  81                            (eq last-coding-system-used 'no-conversion)))
  82                   (set-buffer-multibyte nil))
  83               ;; Make `kill-buffer' quiet.
  84               (set-buffer-modified-p nil))
  85             ;; Have the original buffer current while we eval.
  86             (eval-buffer buffer nil file
  87                          ;; If this Emacs is running with --unibyte,
  88                          ;; convert multibyte strings to unibyte
  89                          ;; after reading them.
  90 ;;                       (not default-enable-multibyte-characters)
  91                          nil t
  92                          ))
  93         (let (kill-buffer-hook kill-buffer-query-functions)
  94           (kill-buffer buffer)))
  95       (let ((hook (assoc file after-load-alist)))
  96         (when hook
  97           (mapcar (function eval) (cdr hook))))
  98       (unless (or nomessage noninteractive)
  99         (if source
 100             (message "Loading %s (source)...done" file)
 101           (message "Loading %s...done" file)))
 102       t)))
 103
 104 ;; API (Application Program Interface) for charsets.
 105
 106 (defsubst charset-quoted-standard-p (obj)
 107   "Return t if OBJ is a quoted symbol, and is the name of a standard charset."
 108   (and (listp obj) (eq (car obj) 'quote)
 109        (symbolp (car-safe (cdr obj)))
 110        (let ((vector (get (car-safe (cdr obj)) 'charset)))
 111          (and (vectorp vector)
 112               (< (aref vector 0) 160)))))
 113
 114 (defsubst charsetp (object)
 115   "T if OBJECT is a charset."
 116   (and (symbolp object) (vectorp (get object 'charset))))
 117
 118 (defsubst charset-info (charset)
 119   "Return a vector of information of CHARSET.
 120 The elements of the vector are:
 121         CHARSET-ID, BYTES, DIMENSION, CHARS, WIDTH, DIRECTION,
 122         LEADING-CODE-BASE, LEADING-CODE-EXT,
 123         ISO-FINAL-CHAR, ISO-GRAPHIC-PLANE,
 124         REVERSE-CHARSET, SHORT-NAME, LONG-NAME, DESCRIPTION,
 125         PLIST,
 126 where
 127 CHARSET-ID (integer) is the identification number of the charset.
 128 BYTES (integer) is the length of multi-byte form of a character in
 129   the charset: one of 1, 2, 3, and 4.
 130 DIMENSION (integer) is the number of bytes to represent a character of
 131 the charset: 1 or 2.
 132 CHARS (integer) is the number of characters in a dimension: 94 or 96.
 133 WIDTH (integer) is the number of columns a character in the charset
 134   occupies on the screen: one of 0, 1, and 2.
 135 DIRECTION (integer) is the rendering direction of characters in the
 136   charset when rendering.  If 0, render from left to right, else
 137   render from right to left.
 138 LEADING-CODE-BASE (integer) is the base leading-code for the
 139   charset.
 140 LEADING-CODE-EXT (integer) is the extended leading-code for the
 141   charset.  All charsets of less than 0xA0 has the value 0.
 142 ISO-FINAL-CHAR (character) is the final character of the
 143   corresponding ISO 2022 charset.  If the charset is not assigned
 144   any final character, the value is -1.
 145 ISO-GRAPHIC-PLANE (integer) is the graphic plane to be invoked
 146   while encoding to variants of ISO 2022 coding system, one of the
 147   following: 0/graphic-plane-left(GL), 1/graphic-plane-right(GR).
 148   If the charset is not assigned any final character, the value is -1.
 149 REVERSE-CHARSET (integer) is the charset which differs only in
 150   LEFT-TO-RIGHT value from the charset.  If there's no such a
 151   charset, the value is -1.
 152 SHORT-NAME (string) is the short name to refer to the charset.
 153 LONG-NAME (string) is the long name to refer to the charset
 154 DESCRIPTION (string) is the description string of the charset.
 155 PLIST (property list) may contain any type of information a user
 156   want to put and get by functions `put-charset-property' and
 157   `get-charset-property' respectively."
 158   (get charset 'charset))
 159
 160 ;; It is better not to use backquote in this file,
 161 ;; because that makes a bootstrapping problem
 162 ;; if you need to recompile all the Lisp files using interpreted code.
 163
 164 (defmacro charset-id (charset)
 165   "Return charset identification number of CHARSET."
 166   (if (charset-quoted-standard-p charset)
 167       (aref (charset-info (nth 1 charset)) 0)
 168     (list 'aref (list 'charset-info charset) 0)))
 169
 170 (defmacro charset-bytes (charset)
 171   "Return bytes of CHARSET.
 172 See the function `charset-info' for more detail."
 173   (if (charset-quoted-standard-p charset)
 174       (aref (charset-info (nth 1 charset)) 1)
 175     (list 'aref (list 'charset-info charset) 1)))
 176
 177 (defmacro charset-dimension (charset)
 178   "Return dimension of CHARSET.
 179 See the function `charset-info' for more detail."
 180   (if (charset-quoted-standard-p charset)
 181       (aref (charset-info (nth 1 charset)) 2)
 182     (list 'aref (list 'charset-info charset) 2)))
 183
 184 (defmacro charset-chars (charset)
 185   "Return character numbers contained in a dimension of CHARSET.
 186 See the function `charset-info' for more detail."
 187   (if (charset-quoted-standard-p charset)
 188       (aref (charset-info (nth 1 charset)) 3)
 189     (list 'aref (list 'charset-info charset) 3)))
 190
 191 (defmacro charset-width (charset)
 192   "Return width (how many column occupied on a screen) of CHARSET.
 193 See the function `charset-info' for more detail."
 194   (if (charset-quoted-standard-p charset)
 195       (aref (charset-info (nth 1 charset)) 4)
 196     (list 'aref (list 'charset-info charset) 4)))
 197
 198 (defmacro charset-direction (charset)
 199   "Return direction of CHARSET.
 200 See the function `charset-info' for more detail."
 201   (if (charset-quoted-standard-p charset)
 202       (aref (charset-info (nth 1 charset)) 5)
 203     (list 'aref (list 'charset-info charset) 5)))
 204
 205 (defmacro charset-iso-final-char (charset)
 206   "Return final char of CHARSET.
 207 See the function `charset-info' for more detail."
 208   (if (charset-quoted-standard-p charset)
 209       (aref (charset-info (nth 1 charset)) 8)
 210     (list 'aref (list 'charset-info charset) 8)))
 211
 212 (defmacro charset-iso-graphic-plane (charset)
 213   "Return graphic plane of CHARSET.
 214 See the function `charset-info' for more detail."
 215   (if (charset-quoted-standard-p charset)
 216       (aref (charset-info (nth 1 charset)) 9)
 217     (list 'aref (list 'charset-info charset) 9)))
 218
 219 (defmacro charset-reverse-charset (charset)
 220   "Return reverse charset of CHARSET.
 221 See the function `charset-info' for more detail."
 222   (if (charset-quoted-standard-p charset)
 223       (aref (charset-info (nth 1 charset)) 10)
 224     (list 'aref (list 'charset-info charset) 10)))
 225
 226 (defmacro charset-short-name (charset)
 227   "Return short name of CHARSET.
 228 See the function `charset-info' for more detail."
 229   (if (charset-quoted-standard-p charset)
 230       (aref (charset-info (nth 1 charset)) 11)
 231     (list 'aref (list 'charset-info charset) 11)))
 232
 233 (defmacro charset-long-name (charset)
 234   "Return long name of CHARSET.
 235 See the function `charset-info' for more detail."
 236   (if (charset-quoted-standard-p charset)
 237       (aref (charset-info (nth 1 charset)) 12)
 238     (list 'aref (list 'charset-info charset) 12)))
 239
 240 (defmacro charset-description (charset)
 241   "Return description of CHARSET.
 242 See the function `charset-info' for more detail."
 243   (if (charset-quoted-standard-p charset)
 244       (aref (charset-info (nth 1 charset)) 13)
 245     (list 'aref (list 'charset-info charset) 13)))
 246
 247 (defmacro charset-plist (charset)
 248   "Return list charset property of CHARSET.
 249 See the function `charset-info' for more detail."
 250   (list 'aref
 251         (if (charset-quoted-standard-p charset)
 252             (charset-info (nth 1 charset))
 253           (list 'charset-info charset))
 254         14))
 255
 256 (defun set-charset-plist (charset plist)
 257   "Set CHARSET's property list to PLIST, and return PLIST."
 258   (aset (charset-info  charset) 14 plist))
 259
 260 (defun make-char (charset &optional code1 code2)
 261   "Return a character of CHARSET whose position codes are CODE1 and CODE2.
 262 CODE1 and CODE2 are optional, but if you don't supply
 263 sufficient position codes, return a generic character which stands for
 264 all characters or group of characters in the character set.
 265 A generic character can be used to index a char table (e.g. syntax-table).
 266
 267 Such character sets as ascii, eight-bit-control, and eight-bit-graphic
 268 don't have corresponding generic characters.  If CHARSET is one of
 269 them and you don't supply CODE1, return the character of the smallest
 270 code in CHARSET.
 271
 272 If CODE1 or CODE2 are invalid (out of range), this function signals an error."
 273   (make-char-internal (charset-id charset) code1 code2))
 274
 275 (put 'make-char 'byte-compile
 276      (function
 277       (lambda (form)
 278         (let ((charset (nth 1 form)))
 279           (if (charset-quoted-standard-p charset)
 280               (byte-compile-normal-call
 281                (cons 'make-char-internal
 282                      (cons (charset-id (nth 1 charset)) (nthcdr 2 form))))
 283             (byte-compile-normal-call
 284              (cons 'make-char-internal
 285                    (cons (list 'charset-id charset) (nthcdr 2 form)))))))))
 286
 287 (defun charset-list ()
 288   "Return list of charsets ever defined.
 289
 290 This function is provided for backward compatibility.
 291 Now we have the variable `charset-list'."
 292   charset-list)
 293
 294 (defsubst generic-char-p (char)
 295   "Return t if and only if CHAR is a generic character.
 296 See also the documentation of `make-char'."
 297   (and (>= char 0400)
 298        (let ((l (split-char char)))
 299          (and (or (= (nth 1 l) 0) (eq (nth 2 l) 0))
 300               (not (eq (car l) 'composition))))))
 301
 302 (defun decode-char (ccs code-point &optional restriction)
 303   "Return character specified by coded character set CCS and CODE-POINT in it.
 304 Return nil if such a character is not supported.
 305 Currently the only supported coded character set is `ucs' (ISO/IEC
 306 10646: Universal Multi-Octet Coded Character Set).
 307
 308 Optional argument RESTRICTION specifies a way to map the pair of CCS
 309 and CODE-POINT to a character.   Currently not supported and just ignored."
 310   (cond ((eq ccs 'ucs)
 311          (cond ((< code-point 160)
 312                 code-point)
 313                ((< code-point 256)
 314                 (make-char 'latin-iso8859-1 code-point))
 315                ((< code-point #x2500)
 316                 (setq code-point (- code-point #x0100))
 317                 (make-char 'mule-unicode-0100-24ff
 318                            (+ (/ code-point 96) 32) (+ (% code-point 96) 32)))
 319                ((< code-point #x3400)
 320                 (setq code-point (- code-point #x2500))
 321                 (make-char 'mule-unicode-2500-33ff
 322                            (+ (/ code-point 96) 32) (+ (% code-point 96) 32)))
 323                ((and (>= code-point #xe000) (< code-point #x10000))
 324                 (setq code-point (- code-point #xe000))
 325                 (make-char 'mule-unicode-e000-ffff
 326                            (+ (/ code-point 96) 32) (+ (% code-point 96) 32)))
 327                ))))
 328
 329 (defun encode-char (char ccs &optional restriction)
 330   "Return code-point in coded character set CCS that corresponds to CHAR.
 331 Return nil if CHAR is not included in CCS.
 332 Currently the only supported coded character set is `ucs' (ISO/IEC
 333 10646: Universal Multi-Octet Coded Character Set).
 334
 335 CHAR should be in one of these charsets:
 336   ascii, latin-iso8859-1, mule-unicode-0100-24ff, mule-unicode-2500-33ff,
 337   mule-unicode-e000-ffff, eight-bit-control
 338 Otherwise, return nil.
 339
 340 Optional argument RESTRICTION specifies a way to map CHAR to a
 341 code-point in CCS.  Currently not supported and just ignored."
 342   (let* ((split (split-char char))
 343          (charset (car split)))
 344     (cond ((eq ccs 'ucs)
 345            (cond ((eq charset 'ascii)
 346                   char)
 347                  ((eq charset 'latin-iso8859-1)
 348                   (+ (nth 1 split) 128))
 349                  ((eq charset 'mule-unicode-0100-24ff)
 350                   (+ #x0100 (+ (* (- (nth 1 split) 32) 96)
 351                                (- (nth 2 split) 32))))
 352                  ((eq charset 'mule-unicode-2500-33ff)
 353                   (+ #x2500 (+ (* (- (nth 1 split) 32) 96)
 354                                (- (nth 2 split) 32))))
 355                  ((eq charset 'mule-unicode-e000-ffff)
 356                   (+ #xe000 (+ (* (- (nth 1 split) 32) 96)
 357                                (- (nth 2 split) 32))))
 358                  ((eq charset 'eight-bit-control)
 359                   char))))))
 360
 361 \f
 362 ;; Coding system stuff
 363
 364 ;; Coding system is a symbol that has the property `coding-system'.
 365 ;;
 366 ;; The value of the property `coding-system' is a vector of the
 367 ;; following format:
 368 ;;      [TYPE MNEMONIC DOC-STRING PLIST FLAGS]
 369 ;; We call this vector as coding-spec.  See comments in src/coding.c
 370 ;; for more detail.
 371
 372 (defconst coding-spec-type-idx 0)
 373 (defconst coding-spec-mnemonic-idx 1)
 374 (defconst coding-spec-doc-string-idx 2)
 375 (defconst coding-spec-plist-idx 3)
 376 (defconst coding-spec-flags-idx 4)
 377
 378 ;; PLIST is a property list of a coding system.  To share PLIST among
 379 ;; alias coding systems, a coding system has PLIST in coding-spec
 380 ;; instead of having it in normal property list of Lisp symbol.
 381 ;; Here's a list of coding system properties currently being used.
 382 ;;
 383 ;; o coding-category
 384 ;;
 385 ;; The value is a coding category the coding system belongs to.  The
 386 ;; function `make-coding-system' sets this value automatically
 387 ;; unless its argument PROPERTIES specifies this property.
 388 ;;
 389 ;; o alias-coding-systems
 390 ;;
 391 ;; The value is a list of coding systems of the same alias group.  The
 392 ;; first element is the coding system made at first, which we call as
 393 ;; `base coding system'.  The function `make-coding-system' sets this
 394 ;; value automatically and `define-coding-system-alias' updates it.
 395 ;;
 396 ;; See the documentation of make-coding-system for the meanings of the
 397 ;; following properties.
 398 ;;
 399 ;; o post-read-conversion
 400 ;; o pre-write-conversion
 401 ;; o translation-table-for-decode
 402 ;; o translation-table-for-encode
 403 ;; o safe-chars
 404 ;; o safe-charsets
 405 ;; o mime-charset
 406 ;; o valid-codes (meaningful only for a coding system based on CCL)
 407
 408
 409 (defsubst coding-system-spec (coding-system)
 410   "Return coding-spec of CODING-SYSTEM."
 411   (get (check-coding-system coding-system) 'coding-system))
 412
 413 (defun coding-system-type (coding-system)
 414   "Return the coding type of CODING-SYSTEM.
 415 A coding type is an integer value indicating the encoding method
 416 of CODING-SYSTEM.  See the function `make-coding-system' for more detail."
 417   (aref (coding-system-spec coding-system) coding-spec-type-idx))
 418
 419 (defun coding-system-mnemonic (coding-system)
 420   "Return the mnemonic character of CODING-SYSTEM.
 421 The mnemonic character of a coding system is used in mode line
 422 to indicate the coding system.  If the arg is nil, return ?-."
 423   (let ((spec (coding-system-spec coding-system)))
 424     (if spec (aref spec coding-spec-mnemonic-idx) ?-)))
 425
 426 (defun coding-system-doc-string (coding-system)
 427   "Return the documentation string for CODING-SYSTEM."
 428   (aref (coding-system-spec coding-system) coding-spec-doc-string-idx))
 429
 430 (defun coding-system-plist (coding-system)
 431   "Return the property list of CODING-SYSTEM."
 432   (aref (coding-system-spec coding-system) coding-spec-plist-idx))
 433
 434 (defun coding-system-flags (coding-system)
 435   "Return `flags' of CODING-SYSTEM.
 436 A `flags' of a coding system is a vector of length 32 indicating detailed
 437 information of a coding system.  See the function `make-coding-system'
 438 for more detail."
 439   (aref (coding-system-spec coding-system) coding-spec-flags-idx))
 440
 441 (defun coding-system-get (coding-system prop)
 442   "Extract a value from CODING-SYSTEM's property list for property PROP."
 443   (plist-get (coding-system-plist coding-system) prop))
 444
 445 (defun coding-system-put (coding-system prop val)
 446   "Change value in CODING-SYSTEM's property list PROP to VAL."
 447   (let ((plist (coding-system-plist coding-system)))
 448     (if plist
 449         (plist-put plist prop val)
 450       (aset (coding-system-spec coding-system) coding-spec-plist-idx
 451             (list prop val)))))
 452
 453 (defun coding-system-category (coding-system)
 454   "Return the coding category of CODING-SYSTEM.
 455 See also `coding-category-list'."
 456   (coding-system-get coding-system 'coding-category))
 457
 458 (defun coding-system-base (coding-system)
 459   "Return the base coding system of CODING-SYSTEM.
 460 A base coding system is what made by `make-coding-system'.
 461 Any alias nor subsidiary coding systems are not base coding system."
 462   (car (coding-system-get coding-system 'alias-coding-systems)))
 463
 464 (defalias 'coding-system-parent 'coding-system-base)
 465 (make-obsolete 'coding-system-parent 'coding-system-base "20.3")
 466
 467 ;; Coding system also has a property `eol-type'.
 468 ;;
 469 ;; This property indicates how the coding system handles end-of-line
 470 ;; format.  The value is integer 0, 1, 2, or a vector of three coding
 471 ;; systems.  Each integer value 0, 1, and 2 indicates the format of
 472 ;; end-of-line LF, CRLF, and CR respectively.  A vector value
 473 ;; indicates that the format of end-of-line should be detected
 474 ;; automatically.  Nth element of the vector is the subsidiary coding
 475 ;; system whose `eol-type' property is N.
 476
 477 (defun coding-system-eol-type (coding-system)
 478   "Return eol-type of CODING-SYSTEM.
 479 An eol-type is integer 0, 1, 2, or a vector of coding systems.
 480
 481 Integer values 0, 1, and 2 indicate a format of end-of-line; LF,
 482 CRLF, and CR respectively.
 483
 484 A vector value indicates that a format of end-of-line should be
 485 detected automatically.  Nth element of the vector is the subsidiary
 486 coding system whose eol-type is N."
 487   (get coding-system 'eol-type))
 488
 489 (defun coding-system-lessp (x y)
 490   (cond ((eq x 'no-conversion) t)
 491         ((eq y 'no-conversion) nil)
 492         ((eq x 'emacs-mule) t)
 493         ((eq y 'emacs-mule) nil)
 494         ((eq x 'undecided) t)
 495         ((eq y 'undecided) nil)
 496         (t (let ((c1 (coding-system-mnemonic x))
 497                  (c2 (coding-system-mnemonic y)))
 498              (or (< (downcase c1) (downcase c2))
 499                  (and (not (> (downcase c1) (downcase c2)))
 500                       (< c1 c2)))))))
 501
 502 (defun add-to-coding-system-list (coding-system)
 503   "Add CODING-SYSTEM to `coding-system-list' while keeping it sorted."
 504   (if (or (null coding-system-list)
 505           (coding-system-lessp coding-system (car coding-system-list)))
 506       (setq coding-system-list (cons coding-system coding-system-list))
 507     (let ((len (length coding-system-list))
 508           mid (tem coding-system-list))
 509       (while (> len 1)
 510         (setq mid (nthcdr (/ len 2) tem))
 511         (if (coding-system-lessp (car mid) coding-system)
 512             (setq tem mid
 513                   len (- len (/ len 2)))
 514           (setq len (/ len 2))))
 515       (setcdr tem (cons coding-system (cdr tem))))))
 516
 517 (defun coding-system-list (&optional base-only)
 518   "Return a list of all existing non-subsidiary coding systems.
 519 If optional arg BASE-ONLY is non-nil, only base coding systems are listed.
 520 The value doesn't include subsidiary coding systems which are what
 521 made from bases and aliases automatically for various end-of-line
 522 formats (e.g. iso-latin-1-unix, koi8-r-dos)."
 523   (let* ((codings (copy-sequence coding-system-list))
 524          (tail (cons nil codings)))
 525     ;; Remove subsidiary coding systems (eol variants) and alias
 526     ;; coding systems (if necessary).
 527     (while (cdr tail)
 528       (let* ((coding (car (cdr tail)))
 529              (aliases (coding-system-get coding 'alias-coding-systems)))
 530         (if (or
 531              ;; CODING is an eol variant if not in ALIASES.
 532              (not (memq coding aliases))
 533              ;; CODING is an alias if it is not car of ALIASES.
 534              (and base-only (not (eq coding (car aliases)))))
 535             (setcdr tail (cdr (cdr tail)))
 536           (setq tail (cdr tail)))))
 537     codings))
 538
 539 (defun register-char-codings (coding-system safe-chars)
 540   (let ((general (char-table-extra-slot char-coding-system-table 0)))
 541     (if (eq safe-chars t)
 542         (or (memq coding-system general)
 543             (set-char-table-extra-slot char-coding-system-table 0
 544                                        (cons coding-system general)))
 545       (map-char-table
 546        (function
 547         (lambda (key val)
 548           (if (and (>= key 128) val)
 549               (let ((codings (aref char-coding-system-table key)))
 550                 (or (memq coding-system codings)
 551                     (aset char-coding-system-table key
 552                           (cons coding-system codings)))))))
 553        safe-chars))))
 554
 555
 556 (defun make-subsidiary-coding-system (coding-system)
 557   "Make subsidiary coding systems (eol-type variants) of CODING-SYSTEM."
 558   (let ((coding-spec (coding-system-spec coding-system))
 559         (subsidiaries (vector (intern (format "%s-unix" coding-system))
 560                               (intern (format "%s-dos" coding-system))
 561                               (intern (format "%s-mac" coding-system))))
 562         (i 0)
 563         temp)
 564     (while (< i 3)
 565       (put (aref subsidiaries i) 'coding-system coding-spec)
 566       (put (aref subsidiaries i) 'eol-type i)
 567       (add-to-coding-system-list (aref subsidiaries i))
 568       (setq coding-system-alist
 569             (cons (list (symbol-name (aref subsidiaries i)))
 570                   coding-system-alist))
 571       (setq i (1+ i)))
 572     subsidiaries))
 573
 574 (defun transform-make-coding-system-args (name type &optional doc-string props)
 575   "For internal use only.
 576 Transform XEmacs style args for `make-coding-system' to Emacs style.
 577 Value is a list of transformed arguments."
 578   (let ((mnemonic (string-to-char (or (plist-get props 'mnemonic) "?")))
 579         (eol-type (plist-get props 'eol-type))
 580         properties tmp)
 581     (cond
 582      ((eq eol-type 'lf) (setq eol-type 'unix))
 583      ((eq eol-type 'crlf) (setq eol-type 'dos))
 584      ((eq eol-type 'cr) (setq eol-type 'mac)))
 585     (if (setq tmp (plist-get props 'post-read-conversion))
 586         (setq properties (plist-put properties 'post-read-conversion tmp)))
 587     (if (setq tmp (plist-get props 'pre-write-conversion))
 588         (setq properties (plist-put properties 'pre-write-conversion tmp)))
 589     (cond
 590      ((eq type 'shift-jis)
 591       `(,name 1 ,mnemonic ,doc-string () ,properties ,eol-type))
 592      ((eq type 'iso2022) ; This is not perfect.
 593       (if (plist-get props 'escape-quoted)
 594           (error "escape-quoted is not supported: %S"
 595                  `(,name ,type ,doc-string ,props)))
 596       (let ((g0 (plist-get props 'charset-g0))
 597             (g1 (plist-get props 'charset-g1))
 598             (g2 (plist-get props 'charset-g2))
 599             (g3 (plist-get props 'charset-g3))
 600             (use-roman
 601              (and
 602               (eq (cadr (assoc 'latin-jisx0201
 603                                (plist-get props 'input-charset-conversion)))
 604                   'ascii)
 605               (eq (cadr (assoc 'ascii
 606                                (plist-get props 'output-charset-conversion)))
 607                   'latin-jisx0201)))
 608             (use-oldjis
 609              (and
 610               (eq (cadr (assoc 'japanese-jisx0208-1978
 611                                (plist-get props 'input-charset-conversion)))
 612                   'japanese-jisx0208)
 613               (eq (cadr (assoc 'japanese-jisx0208
 614                                (plist-get props 'output-charset-conversion)))
 615                   'japanese-jisx0208-1978))))
 616         (if (charsetp g0)
 617             (if (plist-get props 'force-g0-on-output)
 618                 (setq g0 `(nil ,g0))
 619               (setq g0 `(,g0 t))))
 620         (if (charsetp g1)
 621             (if (plist-get props 'force-g1-on-output)
 622                 (setq g1 `(nil ,g1))
 623               (setq g1 `(,g1 t))))
 624         (if (charsetp g2)
 625             (if (plist-get props 'force-g2-on-output)
 626                 (setq g2 `(nil ,g2))
 627               (setq g2 `(,g2 t))))
 628         (if (charsetp g3)
 629             (if (plist-get props 'force-g3-on-output)
 630                 (setq g3 `(nil ,g3))
 631               (setq g3 `(,g3 t))))
 632         `(,name 2 ,mnemonic ,doc-string
 633           (,g0 ,g1 ,g2 ,g3
 634            ,(plist-get props 'short)
 635            ,(not (plist-get props 'no-ascii-eol))
 636            ,(not (plist-get props 'no-ascii-cntl))
 637            ,(plist-get props 'seven)
 638            t
 639            ,(not (plist-get props 'lock-shift))
 640            ,use-roman
 641            ,use-oldjis
 642            ,(plist-get props 'no-iso6429)
 643            nil nil nil nil)
 644         ,properties ,eol-type)))
 645      ((eq type 'big5)
 646       `(,name 3 ,mnemonic ,doc-string () ,properties ,eol-type))
 647      ((eq type 'ccl)
 648       `(,name 4 ,mnemonic ,doc-string
 649               (,(plist-get props 'decode) . ,(plist-get props 'encode))
 650               ,properties ,eol-type))
 651      (t
 652       (error "unsupported XEmacs style make-coding-style arguments: %S"
 653              `(,name ,type ,doc-string ,props))))))
 654
 655 (defun make-coding-system (coding-system type mnemonic doc-string
 656                                          &optional
 657                                          flags
 658                                          properties
 659                                          eol-type)
 660   "Define a new coding system CODING-SYSTEM (symbol).
 661 Remaining arguments are TYPE, MNEMONIC, DOC-STRING, FLAGS (optional),
 662 and PROPERTIES (optional) which construct a coding-spec of CODING-SYSTEM
 663 in the following format:
 664         [TYPE MNEMONIC DOC-STRING PLIST FLAGS]
 665
 666 TYPE is an integer value indicating the type of the coding system as follows:
 667   0: Emacs internal format,
 668   1: Shift-JIS (or MS-Kanji) used mainly on Japanese PC,
 669   2: ISO-2022 including many variants,
 670   3: Big5 used mainly on Chinese PC,
 671   4: private, CCL programs provide encoding/decoding algorithm,
 672   5: Raw-text, which means that text contains random 8-bit codes.
 673
 674 MNEMONIC is a character to be displayed on mode line for the coding system.
 675
 676 DOC-STRING is a documentation string for the coding system.
 677
 678 FLAGS specifies more detailed information of the coding system as follows:
 679
 680   If TYPE is 2 (ISO-2022), FLAGS is a list of these elements:
 681       CHARSET0, CHARSET1, CHARSET2, CHARSET3, SHORT-FORM,
 682       ASCII-EOL, ASCII-CNTL, SEVEN, LOCKING-SHIFT, SINGLE-SHIFT,
 683       USE-ROMAN, USE-OLDJIS, NO-ISO6429, INIT-BOL, DESIGNATION-BOL,
 684       SAFE, ACCEPT-LATIN-EXTRA-CODE.
 685     CHARSETn are character sets initially designated to Gn graphic registers.
 686       If CHARSETn is nil, Gn is never used.
 687       If CHARSETn is t, Gn can be used but nothing designated initially.
 688       If CHARSETn is a list of character sets, those character sets are
 689         designated to Gn on output, but nothing designated to Gn initially.
 690         But, character set `ascii' can be designated only to G0.
 691     SHORT-FORM non-nil means use short designation sequence on output.
 692     ASCII-EOL non-nil means designate ASCII to g0 at end of line on output.
 693     ASCII-CNTL non-nil means designate ASCII to g0 before control codes and
 694       SPACE on output.
 695     SEVEN non-nil means use 7-bit code only on output.
 696     LOCKING-SHIFT non-nil means use locking-shift.
 697     SINGLE-SHIFT non-nil means use single-shift.
 698     USE-ROMAN non-nil means designate JIS0201-1976-Roman instead of ASCII.
 699     USE-OLDJIS non-nil means designate JIS0208-1976 instead of JIS0208-1983.
 700     NO-ISO6429 non-nil means not use ISO6429's direction specification.
 701     INIT-BOL non-nil means any designation state is assumed to be reset
 702       to initial at each beginning of line on output.
 703     DESIGNATION-BOL non-nil means designation sequences should be placed
 704       at beginning of line on output.
 705     SAFE non-nil means convert unsafe characters to `?' on output.
 706       Characters not specified in the property `safe-charsets' nor
 707       `safe-chars' are unsafe.
 708     ACCEPT-LATIN-EXTRA-CODE non-nil means code-detection routine accepts
 709       a code specified in `latin-extra-code-table' (which see) as a valid
 710       code of the coding system.
 711
 712   If TYPE is 4 (private), FLAGS should be a cons of CCL programs, for
 713     decoding and encoding.  CCL programs should be specified by their
 714     symbols.
 715
 716 PROPERTIES is an alist of properties vs the corresponding values.  The
 717 following properties are recognized:
 718
 719   o post-read-conversion
 720
 721   The value is a function to call after some text is inserted and
 722   decoded by the coding system itself and before any functions in
 723   `after-insert-functions' are called.  The argument of this
 724   function is the same as for a function in
 725   `after-insert-file-functions', i.e. LENGTH of the text inserted,
 726   with point at the head of the text to be decoded.
 727
 728   o pre-write-conversion
 729
 730   The value is a function to call after all functions in
 731   `write-region-annotate-functions' and `buffer-file-format' are
 732   called, and before the text is encoded by the coding system itself.
 733   The arguments to this function are the same as those of a function
 734   in `write-region-annotate-functions', i.e. FROM and TO, specifying
 735   a region of text.
 736
 737   o translation-table-for-decode
 738
 739   The value is a translation table to be applied on decoding.  See
 740   the function `make-translation-table' for the format of translation
 741   table.  This is not applicable to type 4 (CCL-based) coding systems.
 742
 743   o translation-table-for-encode
 744
 745   The value is a translation table to be applied on encoding.  This is
 746   not applicable to type 4 (CCL-based) coding systems.
 747
 748   o safe-chars
 749
 750   The value is a char table.  If a character has non-nil value in it,
 751   the character is safely supported by the coding system.  This
 752   overrides the specification of safe-charsets.
 753
 754   o safe-charsets
 755
 756   The value is a list of charsets safely supported by the coding
 757   system.  The value t means that all charsets Emacs handles are
 758   supported.  Even if some charset is not in this list, it doesn't
 759   mean that the charset can't be encoded in the coding system;
 760   it just means that some other receiver of text encoded
 761   in the coding system won't be able to handle that charset.
 762
 763   o mime-charset
 764
 765   The value is a symbol of which name is `MIME-charset' parameter of
 766   the coding system.
 767
 768   o valid-codes (meaningful only for a coding system based on CCL)
 769
 770   The value is a list to indicate valid byte ranges of the encoded
 771   file.  Each element of the list is an integer or a cons of integer.
 772   In the former case, the integer value is a valid byte code.  In the
 773   latter case, the integers specifies the range of valid byte codes.
 774
 775 These properties are set in PLIST, a property list.  This function
 776 also sets properties `coding-category' and `alias-coding-systems'
 777 automatically.
 778
 779 EOL-TYPE specifies the EOL type of the coding-system in one of the
 780 following formats:
 781
 782   o symbol (unix, dos, or mac)
 783
 784         The symbol `unix' means Unix-like EOL (LF), `dos' means
 785         DOS-like EOL (CRLF), and `mac' means MAC-like EOL (CR).
 786
 787   o number (0, 1, or 2)
 788
 789         The number 0, 1, and 2 mean UNIX, DOS, and MAC-like EOL
 790         respectively.
 791
 792   o vector of coding-systems of length 3
 793
 794         The EOL type is detected automatically for the coding system.
 795         And, according to the detected EOL type, one of the coding
 796         systems in the vector is selected.  Elements of the vector
 797         corresponds to Unix-like EOL, DOS-like EOL, and Mac-like EOL
 798         in this order.
 799
 800 Kludgy features for backward compatibility:
 801
 802 1. If TYPE is 4 and car or cdr of FLAGS is a vector, the vector is
 803 treated as a compiled CCL code.
 804
 805 2. If PROPERTIES is just a list of character sets, the list is set as
 806 a value of `safe-charsets' in PLIST."
 807
 808   ;; For compatiblity with XEmacs, we check the type of TYPE.  If it
 809   ;; is a symbol, perhaps, this function is called with XEmacs-style
 810   ;; arguments.  Here, try to transform that kind of arguments to
 811   ;; Emacs style.
 812   (if (symbolp type)
 813       (let ((args (transform-make-coding-system-args coding-system type
 814                                                      mnemonic doc-string)))
 815         (setq coding-system (car args)
 816               type (nth 1 args)
 817               mnemonic (nth 2 args)
 818               doc-string (nth 3 args)
 819               flags (nth 4 args)
 820               properties (nth 5 args)
 821               eol-type (nth 6 args))))
 822
 823   ;; Set a value of `coding-system' property.
 824   (let ((coding-spec (make-vector 5 nil))
 825         (no-initial-designation t)
 826         (no-alternative-designation t)
 827         (accept-latin-extra-code nil)
 828         coding-category)
 829     (if (or (not (integerp type)) (< type 0) (> type 5))
 830         (error "TYPE argument must be 0..5"))
 831     (if (or (not (integerp mnemonic)) (<= mnemonic ? ) (> mnemonic 127))
 832         (error "MNEMONIC argument must be an ASCII printable character"))
 833     (aset coding-spec coding-spec-type-idx type)
 834     (aset coding-spec coding-spec-mnemonic-idx mnemonic)
 835     (aset coding-spec coding-spec-doc-string-idx
 836           (purecopy (if (stringp doc-string) doc-string "")))
 837     (cond ((= type 0)
 838            (setq coding-category 'coding-category-emacs-mule))
 839           ((= type 1)
 840            (setq coding-category 'coding-category-sjis))
 841           ((= type 2)                   ; ISO2022
 842            (let ((i 0)
 843                  (vec (make-vector 32 nil))
 844                  (g1-designation nil)
 845                  (fl flags))
 846              (while (< i 4)
 847                (let ((charset (car fl)))
 848                  (if (and no-initial-designation
 849                           (> i 0)
 850                           (or (charsetp charset)
 851                               (and (consp charset)
 852                                    (charsetp (car charset)))))
 853                      (setq no-initial-designation nil))
 854                  (if (charsetp charset)
 855                      (if (= i 1) (setq g1-designation charset))
 856                    (if (consp charset)
 857                        (let ((tail charset)
 858                              elt)
 859                          (while tail
 860                            (setq elt (car tail))
 861                            (if (eq elt t)
 862                                (setq no-alternative-designation nil)
 863                              (if (and elt (not (charsetp elt)))
 864                                  (error "Invalid charset: %s" elt)))
 865                            (setq tail (cdr tail)))
 866                          (setq g1-designation (car charset)))
 867                      (if charset
 868                          (if (eq charset t)
 869                              (setq no-alternative-designation nil)
 870                            (error "Invalid charset: %s" charset)))))
 871                  (aset vec i charset))
 872                (setq fl (cdr fl) i (1+ i)))
 873              (while (and (< i 32) fl)
 874                (aset vec i (car fl))
 875                (if (and (= i 16)        ; ACCEPT-LATIN-EXTRA-CODE
 876                         (car fl))
 877                    (setq accept-latin-extra-code t))
 878                (setq fl (cdr fl) i (1+ i)))
 879              (aset coding-spec 4 vec)
 880              (setq coding-category
 881                    (if (aref vec 8)     ; Use locking-shift.
 882                        (or (and (aref vec 7) 'coding-category-iso-7-else)
 883                            'coding-category-iso-8-else)
 884                      (if (aref vec 7)   ; 7-bit only.
 885                          (if (aref vec 9) ; Use single-shift.
 886                              'coding-category-iso-7-else
 887                            (if no-alternative-designation
 888                                'coding-category-iso-7-tight
 889                              'coding-category-iso-7))
 890                        (if (or no-initial-designation
 891                                (not no-alternative-designation))
 892                            'coding-category-iso-8-else
 893                          (if (and (charsetp g1-designation)
 894                                   (= (charset-dimension g1-designation) 2))
 895                              'coding-category-iso-8-2
 896                            'coding-category-iso-8-1)))))))
 897           ((= type 3)
 898            (setq coding-category 'coding-category-big5))
 899           ((= type 4)                   ; private
 900            (setq coding-category 'coding-category-ccl)
 901            (if (not (consp flags))
 902                (error "Invalid FLAGS argument for TYPE 4 (CCL)")
 903              (let ((decoder (check-ccl-program
 904                              (car flags)
 905                              (intern (format "%s-decoder" coding-system))))
 906                    (encoder (check-ccl-program
 907                              (cdr flags)
 908                              (intern (format "%s-encoder" coding-system)))))
 909                (if (and decoder encoder)
 910                    (aset coding-spec 4 (cons decoder encoder))
 911                  (error "Invalid FLAGS argument for TYPE 4 (CCL)")))))
 912           (t                            ; i.e. (= type 5)
 913            (setq coding-category 'coding-category-raw-text)))
 914
 915     (let ((plist (list 'coding-category coding-category
 916                        'alias-coding-systems (list coding-system))))
 917       (if no-initial-designation
 918           (plist-put plist 'no-initial-designation t))
 919       (if (and properties
 920                (or (eq properties t)
 921                    (not (consp (car properties)))))
 922           ;; In the old version, the arg PROPERTIES is a list to be
 923           ;; set in PLIST as a value of property `safe-charsets'.
 924           (setq properties (list (cons 'safe-charsets properties))))
 925       ;; In the current version PROPERTIES is a property list.
 926       ;; Reflect it into PLIST one by one while handling safe-chars
 927       ;; specially.
 928       (let ((safe-charsets (cdr (assq 'safe-charsets properties)))
 929             (safe-chars (cdr (assq 'safe-chars properties)))
 930             (l properties)
 931             prop val)
 932         ;; If only safe-charsets is specified, make a char-table from
 933         ;; it, and store that char-table as the value of `safe-chars'.
 934         (if (and (not safe-chars) safe-charsets)
 935             (let (charset)
 936               (if (eq safe-charsets t)
 937                   (setq safe-chars t)
 938                 (setq safe-chars (make-char-table 'safe-chars))
 939                 (while safe-charsets
 940                   (setq charset (car safe-charsets)
 941                         safe-charsets (cdr safe-charsets))
 942                   (cond ((eq charset 'ascii)) ; just ignore
 943                         ((eq charset 'eight-bit-control)
 944                          (let ((i 128))
 945                            (while (< i 160)
 946                              (aset safe-chars i t)
 947                              (setq i (1+ i)))))
 948                         ((eq charset 'eight-bit-graphic)
 949                          (let ((i 160))
 950                            (while (< i 256)
 951                              (aset safe-chars i t)
 952                              (setq i (1+ i)))))
 953                         (t
 954                          (aset safe-chars (make-char charset) t))))
 955                 (if accept-latin-extra-code
 956                     (let ((i 128))
 957                       (while (< i 160)
 958                         (if (aref latin-extra-code-table i)
 959                             (aset safe-chars i t))
 960                         (setq i (1+ i))))))
 961               (setq l (cons (cons 'safe-chars safe-chars) l))))
 962         (while l
 963           (setq prop (car (car l)) val (cdr (car l)) l (cdr l))
 964           (if (eq prop 'safe-chars)
 965               (progn
 966                 (if (and (symbolp val)
 967                          (get val 'translation-table))
 968                     (setq safe-chars (get val 'translation-table)))
 969                 (register-char-codings coding-system safe-chars)
 970                 (setq val safe-chars)))
 971           (plist-put plist prop val)))
 972       ;; The property `coding-category' may have been set differently
 973       ;; through PROPERTIES.
 974       (setq coding-category (plist-get plist 'coding-category))
 975       (aset coding-spec coding-spec-plist-idx plist))
 976     (put coding-system 'coding-system coding-spec)
 977     (put coding-category 'coding-systems
 978          (cons coding-system (get coding-category 'coding-systems))))
 979
 980   ;; Next, set a value of `eol-type' property.
 981   (if (not eol-type)
 982       ;; If EOL-TYPE is nil, set a vector of subsidiary coding
 983       ;; systems, each corresponds to a coding system for the detected
 984       ;; EOL format.
 985       (setq eol-type (make-subsidiary-coding-system coding-system)))
 986   (setq eol-type
 987         (cond ((or (eq eol-type 'unix) (null eol-type))
 988                0)
 989               ((eq eol-type 'dos)
 990                1)
 991               ((eq eol-type 'mac)
 992                2)
 993               ((or (and (vectorp eol-type)
 994                         (= (length eol-type) 3))
 995                    (and (numberp eol-type)
 996                         (and (>= eol-type 0)
 997                              (<= eol-type 2))))
 998                eol-type)
 999               (t
1000                (error "Invalid EOL-TYPE spec:%S" eol-type))))
1001   (put coding-system 'eol-type eol-type)
1002
1003   ;; At last, register CODING-SYSTEM in `coding-system-list' and
1004   ;; `coding-system-alist'.
1005   (add-to-coding-system-list coding-system)
1006   (setq coding-system-alist (cons (list (symbol-name coding-system))
1007                                   coding-system-alist))
1008
1009   ;; For a coding system of cateogory iso-8-1 and iso-8-2, create
1010   ;; XXX-with-esc variants.
1011   (let ((coding-category (coding-system-category coding-system)))
1012     (if (or (eq coding-category 'coding-category-iso-8-1)
1013             (eq coding-category 'coding-category-iso-8-2))
1014         (let ((esc (intern (concat (symbol-name coding-system) "-with-esc")))
1015               (doc (format "Same as %s but can handle any charsets by ISO's escape sequences." coding-system))
1016               (safe-charsets (assq 'safe-charsets properties))
1017               (mime-charset (assq 'mime-charset properties)))
1018           (if safe-charsets
1019               (setcdr safe-charsets t)
1020             (setq properties (cons (cons 'safe-charsets t) properties)))
1021           (if mime-charset
1022               (setcdr mime-charset nil))
1023           (make-coding-system esc type mnemonic doc
1024                               (if (listp (car flags))
1025                                   (cons (append (car flags) '(t)) (cdr flags))
1026                                 (cons (list (car flags) t) (cdr flags)))
1027                               properties))))
1028
1029   coding-system)
1030
1031 (defun define-coding-system-alias (alias coding-system)
1032   "Define ALIAS as an alias for coding system CODING-SYSTEM."
1033   (put alias 'coding-system (coding-system-spec coding-system))
1034   (nconc (coding-system-get alias 'alias-coding-systems) (list alias))
1035   (add-to-coding-system-list alias)
1036   (setq coding-system-alist (cons (list (symbol-name alias))
1037                                   coding-system-alist))
1038   (let ((eol-type (coding-system-eol-type coding-system)))
1039     (if (vectorp eol-type)
1040         (put alias 'eol-type (make-subsidiary-coding-system alias))
1041       (put alias 'eol-type eol-type))))
1042
1043 (defun set-buffer-file-coding-system (coding-system &optional force)
1044   "Set the file coding-system of the current buffer to CODING-SYSTEM.
1045 This means that when you save the buffer, it will be converted
1046 according to CODING-SYSTEM.  For a list of possible values of CODING-SYSTEM,
1047 use \\[list-coding-systems].
1048
1049 If the buffer's previous file coding-system value specifies end-of-line
1050 conversion, and CODING-SYSTEM does not specify one, CODING-SYSTEM is
1051 merged with the already-specified end-of-line conversion.
1052
1053 If the buffer's previous file coding-system value specifies text
1054 conversion, and CODING-SYSTEM does not specify one, CODING-SYSTEM is
1055 merged with the already-specified text conversion.
1056
1057 However, if the optional prefix argument FORCE is non-nil, then
1058 CODING-SYSTEM is used exactly as specified.
1059
1060 This marks the buffer modified so that the succeeding \\[save-buffer]
1061 surely saves the buffer with CODING-SYSTEM.  From a program, if you
1062 don't want to mark the buffer modified, just set the variable
1063 `buffer-file-coding-system' directly."
1064   (interactive "zCoding system for visited file (default, nil): \nP")
1065   (check-coding-system coding-system)
1066   (if (and coding-system buffer-file-coding-system (null force))
1067       (let ((base (coding-system-base buffer-file-coding-system))
1068             (eol (coding-system-eol-type buffer-file-coding-system)))
1069         ;; If CODING-SYSTEM doesn't specify text conversion, merge
1070         ;; with that of buffer-file-coding-system.
1071         (if (eq (coding-system-base coding-system) 'undecided)
1072             (setq coding-system (coding-system-change-text-conversion
1073                                  coding-system base)))
1074         ;; If CODING-SYSTEM doesn't specify eol conversion, merge with
1075         ;; that of buffer-file-coding-system.
1076         (if (and (vectorp (coding-system-eol-type coding-system))
1077                  (numberp eol) (>= eol 0) (<= eol 2))
1078             (setq coding-system (coding-system-change-eol-conversion
1079                                  coding-system eol)))))
1080   (setq buffer-file-coding-system coding-system)
1081   (set-buffer-modified-p t)
1082   (force-mode-line-update))
1083
1084 (defvar default-terminal-coding-system nil
1085   "Default value for the terminal coding system.
1086 This is normally set according to the selected language environment.
1087 See also the command `set-terminal-coding-system'.")
1088
1089 (defun set-terminal-coding-system (coding-system)
1090   "Set coding system of your terminal to CODING-SYSTEM.
1091 All text output to the terminal will be encoded
1092 with the specified coding system.
1093 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems].
1094 The default is determined by the selected language environment
1095 or by the previous use of this command."
1096   (interactive
1097    (list (let ((default (if (and (not (terminal-coding-system))
1098                                  default-terminal-coding-system)
1099                             default-terminal-coding-system)))
1100            (read-coding-system
1101             (format "Coding system for terminal display (default, %s): "
1102                     default)
1103             default))))
1104   (if (and (not coding-system)
1105            (not (terminal-coding-system)))
1106       (setq coding-system default-terminal-coding-system))
1107   (if coding-system
1108       (setq default-terminal-coding-system coding-system))
1109   (set-terminal-coding-system-internal coding-system)
1110   (redraw-frame (selected-frame)))
1111
1112 (defvar default-keyboard-coding-system nil
1113   "Default value of the keyboard coding system.
1114 This is normally set according to the selected language environment.
1115 See also the command `set-keyboard-coding-system'.")
1116
1117 (defun set-keyboard-coding-system (coding-system)
1118   "Set coding system for keyboard input to CODING-SYSTEM.
1119 In addition, this command enables Encoded-kbd minor mode.
1120 \(If CODING-SYSTEM is nil, Encoded-kbd mode is turned off -- see
1121 `encoded-kbd-mode'.)
1122 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems].
1123 The default is determined by the selected language environment
1124 or by the previous use of this command."
1125   (interactive
1126    (list (let ((default (if (and (not (keyboard-coding-system))
1127                                  default-keyboard-coding-system)
1128                             default-keyboard-coding-system)))
1129            (read-coding-system
1130             (format "Coding system for keyboard input (default, %s): "
1131                     default)
1132             default))))
1133   (if (and (not coding-system)
1134            (not (keyboard-coding-system)))
1135       (setq coding-system default-keyboard-coding-system))
1136   (if coding-system
1137       (setq default-keyboard-coding-system coding-system))
1138   (set-keyboard-coding-system-internal coding-system)
1139   (encoded-kbd-mode (if coding-system 1 0)))
1140
1141 (defcustom keyboard-coding-system nil
1142   "Specify coding system for keyboard input.
1143 If you set this on a terminal which can't distinguish Meta keys from
1144 8-bit characters, you will have to use ESC to type Meta characters.
1145 See Info node `Specify Coding' and Info node `Single-Byte Character Support'.
1146
1147 Setting this variable directly does not take effect;
1148 use either M-x customize or \\[set-keyboard-coding-system]."
1149   :type '(coding-system :tag "Coding system")
1150   :link '(info-link "(emacs)Specify Coding")
1151   :link '(info-link "(emacs)Single-Byte Character Support")
1152   :set (lambda (symbol value)
1153          ;; Don't load encoded-kbd-mode unnecessarily.
1154          (if (or value (boundp 'encoded-kbd-mode))
1155              (set-keyboard-coding-system value)
1156            (set-default 'keyboard-coding-system nil))) ; must initialize
1157   :version "21.1"
1158   :group 'keyboard
1159   :group 'mule)
1160
1161 (defun set-buffer-process-coding-system (decoding encoding)
1162   "Set coding systems for the process associated with the current buffer.
1163 DECODING is the coding system to be used to decode input from the process,
1164 ENCODING is the coding system to be used to encode output to the process.
1165
1166 For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]."
1167   (interactive
1168    "zCoding-system for output from the process: \nzCoding-system for input to the process: ")
1169   (let ((proc (get-buffer-process (current-buffer))))
1170     (if (null proc)
1171         (error "No process")
1172       (check-coding-system decoding)
1173       (check-coding-system encoding)
1174       (set-process-coding-system proc decoding encoding)))
1175   (force-mode-line-update))
1176
1177 (defalias 'set-clipboard-coding-system 'set-selection-coding-system)
1178
1179 (defun set-selection-coding-system (coding-system)
1180   "Make CODING-SYSTEM used for communicating with other X clients .
1181 When sending or receiving text via cut_buffer, selection, and clipboard,
1182 the text is encoded or decoded by CODING-SYSTEM."
1183   (interactive "zCoding system for X selection: ")
1184   (check-coding-system coding-system)
1185   (setq selection-coding-system coding-system))
1186
1187 ;; Coding system lastly specified by the command
1188 ;; set-next-selection-coding-system.
1189 (defvar last-next-selection-coding-system nil)
1190
1191 (defun set-next-selection-coding-system (coding-system)
1192   "Make CODING-SYSTEM used for the next communication with other X clients.
1193 This setting is effective for the next communication only."
1194   (interactive
1195    (list (read-coding-system
1196           (if last-next-selection-coding-system
1197               (format "Coding system for the next X selection (default, %S): "
1198                       last-next-selection-coding-system)
1199             "Coding system for the next X selection: ")
1200           last-next-selection-coding-system)))
1201   (if coding-system
1202       (setq last-next-selection-coding-system coding-system)
1203     (setq coding-system last-next-selection-coding-system))
1204   (check-coding-system coding-system)
1205
1206   (setq next-selection-coding-system coding-system))
1207
1208 (defun set-coding-priority (arg)
1209   "Set priority of coding categories according to ARG.
1210 ARG is a list of coding categories ordered by priority."
1211   (let ((l arg)
1212         (current-list (copy-sequence coding-category-list)))
1213     ;; Check the validity of ARG while deleting coding categories in
1214     ;; ARG from CURRENT-LIST.  We assume that CODING-CATEGORY-LIST
1215     ;; contains all coding categories.
1216     (while l
1217       (if (or (null (get (car l) 'coding-category-index))
1218               (null (memq (car l) current-list)))
1219           (error "Invalid or duplicated element in argument: %s" arg))
1220       (setq current-list (delq (car l) current-list))
1221       (setq l (cdr l)))
1222     ;; Update `coding-category-list' and return it.
1223     (setq coding-category-list (append arg current-list))
1224     (set-coding-priority-internal)))
1225
1226 ;;; FILE I/O
1227
1228 (defcustom auto-coding-alist
1229   '(("\\.\\(arc\\|zip\\|lzh\\|zoo\\|jar\\|tar\\|tgz\\)\\'" . no-conversion)
1230     ("\\.\\(gz\\|Z\\|bz\\|bz2\\|gpg\\)\\'" . no-conversion))
1231   "Alist of filename patterns vs corresponding coding systems.
1232 Each element looks like (REGEXP . CODING-SYSTEM).
1233 A file whose name matches REGEXP is decoded by CODING-SYSTEM on reading.
1234
1235 The settings in this alist take priority over `coding:' tags
1236 in the file (see the function `set-auto-coding')
1237 and the contents of `file-coding-system-alist'."
1238   :group 'files
1239   :group 'mule
1240   :type '(repeat (cons (regexp :tag "File name regexp")
1241                        (symbol :tag "Coding system"))))
1242
1243 (defcustom auto-coding-regexp-alist
1244   '(("^BABYL OPTIONS:[ \t]*-\\*-[ \t]*rmail[ \t]*-\\*-" . no-conversion))
1245   "Alist of patterns vs corresponding coding systems.
1246 Each element looks like (REGEXP . CODING-SYSTEM).
1247 A file whose first bytes match REGEXP is decoded by CODING-SYSTEM on reading.
1248
1249 The settings in this alist take priority over `coding:' tags
1250 in the file (see the function `set-auto-coding')
1251 and the contents of `file-coding-system-alist'."
1252   :group 'files
1253   :group 'mule
1254   :type '(repeat (cons (regexp :tag "Regexp")
1255                        (symbol :tag "Coding system"))))
1256
1257 (defvar set-auto-coding-for-load nil
1258   "Non-nil means look for `load-coding' property instead of `coding'.
1259 This is used for loading and byte-compiling Emacs Lisp files.")
1260
1261 (defun auto-coding-alist-lookup (filename)
1262   "Return the coding system specified by `auto-coding-alist' for FILENAME."
1263   (let ((alist auto-coding-alist)
1264         (case-fold-search (memq system-type '(vax-vms windows-nt ms-dos)))
1265         coding-system)
1266     (while (and alist (not coding-system))
1267       (if (string-match (car (car alist)) filename)
1268           (setq coding-system (cdr (car alist)))
1269         (setq alist (cdr alist))))
1270     coding-system))
1271
1272
1273 (defun auto-coding-from-file-contents (size)
1274   "Determine a coding system from the contents of the current buffer.
1275 The current buffer contains SIZE bytes starting at point.
1276 Value is either a coding system or nil."
1277   (save-excursion
1278     (let ((alist auto-coding-regexp-alist)
1279           coding-system)
1280       (while (and alist (not coding-system))
1281         (let ((regexp (car (car alist))))
1282           (when (re-search-forward regexp (+ (point) size) t)
1283             (setq coding-system (cdr (car alist)))))
1284         (setq alist (cdr alist)))
1285       coding-system)))
1286
1287
1288 (defun set-auto-coding (filename size)
1289   "Return coding system for a file FILENAME of which SIZE bytes follow point.
1290 These bytes should include at least the first 1k of the file
1291 and the last 3k of the file, but the middle may be omitted.
1292
1293 It checks FILENAME against the variable `auto-coding-alist'.  If
1294 FILENAME doesn't match any entries in the variable, it checks the
1295 contents of the current buffer following point against
1296 `auto-coding-regexp-alist'.  If no match is found, it checks for a
1297 `coding:' tag in the first one or two lines following point.  If no
1298 `coding:' tag is found, it checks for local variables list in the last
1299 3K bytes out of the SIZE bytes.
1300
1301 The return value is the specified coding system,
1302 or nil if nothing specified.
1303
1304 The variable `set-auto-coding-function' (which see) is set to this
1305 function by default."
1306   (or (auto-coding-alist-lookup filename)
1307       (auto-coding-from-file-contents size)
1308       (let* ((case-fold-search t)
1309              (head-start (point))
1310              (head-end (+ head-start (min size 1024)))
1311              (tail-start (+ head-start (max (- size 3072) 0)))
1312              (tail-end (+ head-start size))
1313              coding-system head-found tail-found pos)
1314         ;; Try a short cut by searching for the string "coding:"
1315         ;; and for "unibyte:" at the head and tail of SIZE bytes.
1316         (setq head-found (or (search-forward "coding:" head-end t)
1317                              (search-forward "unibyte:" head-end t)))
1318         (if (and head-found (> head-found tail-start))
1319             ;; Head and tail are overlapped.
1320             (setq tail-found head-found)
1321           (goto-char tail-start)
1322           (setq tail-found (or (search-forward "coding:" tail-end t)
1323                                (search-forward "unibyte:" tail-end t))))
1324
1325         ;; At first check the head.
1326         (when head-found
1327           (goto-char head-start)
1328           (setq pos (re-search-forward "[\n\r]" head-end t))
1329           (if (and pos
1330                    (= (char-after head-start) ?#)
1331                    (= (char-after (1+ head-start)) ?!))
1332              ;; If the file begins with "#!" (exec interpreter magic),
1333           ;; look for coding frobs in the first two lines.  You cannot
1334               ;; necessarily put them in the first line of such a file
1335               ;; without screwing up the interpreter invocation.
1336               (setq pos (search-forward "\n" head-end t)))
1337           (if pos (setq head-end pos))
1338           (when (< head-found head-end)
1339             (goto-char head-start)
1340             (when (and set-auto-coding-for-load
1341                        (re-search-forward
1342                         "-\\*-\\(.*;\\)?[ \t]*unibyte:[ \t]*\\([^ ;]+\\)"
1343                         head-end t))
1344               (setq coding-system 'raw-text))
1345             (when (and (not coding-system)
1346                        (re-search-forward
1347                         "-\\*-\\(.*;\\)?[ \t]*coding:[ \t]*\\([^ ;]+\\)"
1348                         head-end t))
1349               (setq coding-system (intern (match-string 2)))
1350               (or (coding-system-p coding-system)
1351                   (setq coding-system nil)))))
1352
1353         ;; If no coding: tag in the head, check the tail.
1354         (when (and tail-found (not coding-system))
1355           (goto-char tail-start)
1356           (search-forward "\n\^L" nil t)
1357           (if (re-search-forward
1358                "^\\(.*\\)[ \t]*Local Variables:[ \t]*\\(.*\\)$" tail-end t)
1359           ;; The prefix is what comes before "local variables:" in its
1360            ;; line.  The suffix is what comes after "local variables:"
1361               ;; in its line.
1362               (let* ((prefix (regexp-quote (match-string 1)))
1363                      (suffix (regexp-quote (match-string 2)))
1364                      (re-coding
1365                       (concat
1366                        "^" prefix
1367                        "[ \t]*coding[ \t]*:[ \t]*\\([^ \t]+\\)[ \t]*"
1368                        suffix "$"))
1369                      (re-unibyte
1370                       (concat
1371                        "^" prefix
1372                        "[ \t]*unibyte[ \t]*:[ \t]*\\([^ \t]+\\)[ \t]*"
1373                        suffix "$"))
1374                      (re-end
1375                       (concat "^" prefix "[ \t]*end *:[ \t]*" suffix "$"))
1376                      (pos (point)))
1377                 (re-search-forward re-end tail-end 'move)
1378                 (setq tail-end (point))
1379                 (goto-char pos)
1380                 (when (and set-auto-coding-for-load
1381                            (re-search-forward re-unibyte tail-end t))
1382                   (setq coding-system 'raw-text))
1383                 (when (and (not coding-system)
1384                            (re-search-forward re-coding tail-end t))
1385                   (setq coding-system (intern (match-string 1)))
1386                   (or (coding-system-p coding-system)
1387                       (setq coding-system nil))))))
1388         coding-system)))
1389
1390 (setq set-auto-coding-function 'set-auto-coding)
1391
1392 (defun after-insert-file-set-buffer-file-coding-system (inserted)
1393   "Set `buffer-file-coding-system' of current buffer after text is inserted."
1394   (if last-coding-system-used
1395       (let ((coding-system
1396              (find-new-buffer-file-coding-system last-coding-system-used))
1397             (modified-p (buffer-modified-p)))
1398         (when coding-system
1399           (set-buffer-file-coding-system coding-system t)
1400           (if (and enable-multibyte-characters
1401                    (or (eq coding-system 'no-conversion)
1402                        (eq (coding-system-type coding-system) 5))
1403                    ;; If buffer was unmodified and the size is the
1404                    ;; same as INSERTED, we must be visiting it.
1405                    (not modified-p)
1406                    (= (buffer-size) inserted))
1407               ;; For coding systems no-conversion and raw-text...,
1408               ;; edit the buffer as unibyte.
1409               (let ((pos-byte (position-bytes (+ (point) inserted))))
1410                 (set-buffer-multibyte nil)
1411                 (setq inserted (- pos-byte (position-bytes (point))))))
1412           (set-buffer-modified-p modified-p))))
1413   inserted)
1414
1415 (add-hook 'after-insert-file-functions
1416           'after-insert-file-set-buffer-file-coding-system)
1417
1418 ;; The coding-spec and eol-type of coding-system returned is decided
1419 ;; independently in the following order.
1420 ;;      1. That of buffer-file-coding-system locally bound.
1421 ;;      2. That of CODING.
1422
1423 (defun find-new-buffer-file-coding-system (coding)
1424   "Return a coding system for a buffer when a file of CODING is inserted.
1425 The local variable `buffer-file-coding-system' of the current buffer
1426 is set to the returned value.
1427 Return nil if there's no need to set `buffer-file-coding-system'."
1428   (let (local-coding local-eol
1429         found-coding found-eol
1430         new-coding new-eol)
1431     (if (null coding)
1432         ;; Nothing found about coding.
1433         nil
1434
1435       ;; Get information of `buffer-file-coding-system' in LOCAL-EOL
1436       ;; and LOCAL-CODING.
1437       (setq local-eol (coding-system-eol-type buffer-file-coding-system))
1438       (if (null (numberp local-eol))
1439           ;; But eol-type is not yet set.
1440           (setq local-eol nil))
1441       (if (and buffer-file-coding-system
1442                (not (eq (coding-system-type buffer-file-coding-system) t)))
1443           ;; This is not `undecided'.
1444           (setq local-coding (coding-system-base buffer-file-coding-system)))
1445
1446       (if (and (local-variable-p 'buffer-file-coding-system)
1447                local-eol local-coding)
1448           ;; The current buffer has already set full coding-system, we
1449           ;; had better not change it.
1450           nil
1451
1452         (setq found-eol (coding-system-eol-type coding))
1453         (if (null (numberp found-eol))
1454             ;; But eol-type is not found.
1455             ;; If EOL conversions are inhibited, force unix eol-type.
1456             (setq found-eol (if inhibit-eol-conversion 0)))
1457         (if (eq (coding-system-type coding) t)
1458             (setq found-coding 'undecided)
1459           (setq found-coding (coding-system-base coding)))
1460
1461         (if (and (not found-eol) (eq found-coding 'undecided))
1462             ;; No valid coding information found.
1463             nil
1464
1465           ;; Some coding information (eol or text) found.
1466
1467           ;; The local setting takes precedence over the found one.
1468           (setq new-coding (if (local-variable-p 'buffer-file-coding-system)
1469                                (or local-coding found-coding)
1470                              (or found-coding local-coding)))
1471           (setq new-eol (if (local-variable-p 'buffer-file-coding-system)
1472                             (or local-eol found-eol)
1473                           (or found-eol local-eol)))
1474
1475           (let ((eol-type (coding-system-eol-type new-coding)))
1476             (if (and (numberp new-eol) (vectorp eol-type))
1477                 (aref eol-type new-eol)
1478               new-coding)))))))
1479
1480 (defun modify-coding-system-alist (target-type regexp coding-system)
1481   "Modify one of look up tables for finding a coding system on I/O operation.
1482 There are three of such tables, `file-coding-system-alist',
1483 `process-coding-system-alist', and `network-coding-system-alist'.
1484
1485 TARGET-TYPE specifies which of them to modify.
1486 If it is `file', it affects `file-coding-system-alist' (which see).
1487 If it is `process', it affects `process-coding-system-alist' (which see).
1488 If it is `network', it affects `network-coding-system-alist' (which see).
1489
1490 REGEXP is a regular expression matching a target of I/O operation.
1491 The target is a file name if TARGET-TYPE is `file', a program name if
1492 TARGET-TYPE is `process', or a network service name or a port number
1493 to connect to if TARGET-TYPE is `network'.
1494
1495 CODING-SYSTEM is a coding system to perform code conversion on the I/O
1496 operation, or a cons cell (DECODING . ENCODING) specifying the coding systems
1497 for decoding and encoding respectively,
1498 or a function symbol which, when called, returns such a cons cell."
1499   (or (memq target-type '(file process network))
1500       (error "Invalid target type: %s" target-type))
1501   (or (stringp regexp)
1502       (and (eq target-type 'network) (integerp regexp))
1503       (error "Invalid regular expression: %s" regexp))
1504   (if (symbolp coding-system)
1505       (if (not (fboundp coding-system))
1506           (progn
1507             (check-coding-system coding-system)
1508             (setq coding-system (cons coding-system coding-system))))
1509     (check-coding-system (car coding-system))
1510     (check-coding-system (cdr coding-system)))
1511   (cond ((eq target-type 'file)
1512          (let ((slot (assoc regexp file-coding-system-alist)))
1513            (if slot
1514                (setcdr slot coding-system)
1515              (setq file-coding-system-alist
1516                    (cons (cons regexp coding-system)
1517                          file-coding-system-alist)))))
1518         ((eq target-type 'process)
1519          (let ((slot (assoc regexp process-coding-system-alist)))
1520            (if slot
1521                (setcdr slot coding-system)
1522              (setq process-coding-system-alist
1523                    (cons (cons regexp coding-system)
1524                          process-coding-system-alist)))))
1525         (t
1526          (let ((slot (assoc regexp network-coding-system-alist)))
1527            (if slot
1528                (setcdr slot coding-system)
1529              (setq network-coding-system-alist
1530                    (cons (cons regexp coding-system)
1531                          network-coding-system-alist)))))))
1532
1533 (defun make-translation-table (&rest args)
1534   "Make a translation table from arguments.
1535 A translation table is a char table intended for for character
1536 translation in CCL programs.
1537
1538 Each argument is a list of elemnts of the form (FROM . TO), where FROM
1539 is a character to be translated to TO.
1540
1541 FROM can be a generic character (see `make-char').  In this case, TO is
1542 a generic character containing the same number of characters, or a
1543 ordinary character.  If FROM and TO are both generic characters, all
1544 characters belonging to FROM are translated to characters belonging to TO
1545 without changing their position code(s).
1546
1547 The arguments and forms in each argument are processed in the given
1548 order, and if a previous form already translates TO to some other
1549 character, say TO-ALT, FROM is also translated to TO-ALT."
1550   (let ((table (make-char-table 'translation-table))
1551         revlist)
1552     (while args
1553       (let ((elts (car args)))
1554         (while elts
1555           (let* ((from (car (car elts)))
1556                  (from-i 0)             ; degree of freedom of FROM
1557                  (from-rev (nreverse (split-char from)))
1558                  (to (cdr (car elts)))
1559                  (to-i 0)               ; degree of freedom of TO
1560                  (to-rev (nreverse (split-char to))))
1561             ;; Check numbers of heading 0s in FROM-REV and TO-REV.
1562             (while (eq (car from-rev) 0)
1563               (setq from-i (1+ from-i) from-rev (cdr from-rev)))
1564             (while (eq (car to-rev) 0)
1565               (setq to-i (1+ to-i) to-rev (cdr to-rev)))
1566             (if (and (/= from-i to-i) (/= to-i 0))
1567                 (error "Invalid character pair (%d . %d)" from to))
1568             ;; If we have already translated TO to TO-ALT, FROM should
1569             ;; also be translated to TO-ALT.  But, this is only if TO
1570             ;; is a generic character or TO-ALT is not a generic
1571             ;; character.
1572             (let ((to-alt (aref table to)))
1573               (if (and to-alt
1574                        (or (> to-i 0) (not (generic-char-p to-alt))))
1575                   (setq to to-alt)))
1576             (if (> from-i 0)
1577                 (set-char-table-default table from to)
1578               (aset table from to))
1579             ;; If we have already translated some chars to FROM, they
1580             ;; should also be translated to TO.
1581             (let ((l (assq from revlist)))
1582               (if l
1583                   (let ((ch (car l)))
1584                     (setcar l to)
1585                     (setq l (cdr l))
1586                     (while l
1587                       (aset table ch to)
1588                       (setq l (cdr l)) ))))
1589             ;; Now update REVLIST.
1590             (let ((l (assq to revlist)))
1591               (if l
1592                   (setcdr l (cons from (cdr l)))
1593                 (setq revlist (cons (list to from) revlist)))))
1594           (setq elts (cdr elts))))
1595       (setq args (cdr args)))
1596     ;; Return TABLE just created.
1597     table))
1598
1599 (defun make-translation-table-from-vector (vec)
1600   "Make translation table from decoding vector VEC.
1601 VEC is an array of 256 elements to map unibyte codes to multibyte characters.
1602 See also the variable `nonascii-translation-table'."
1603   (let ((table (make-char-table 'translation-table))
1604         (rev-table (make-char-table 'translation-table))
1605         (i 0)
1606         ch)
1607     (while (< i 256)
1608       (setq ch (aref vec i))
1609       (aset table i ch)
1610       (if (>= ch 256)
1611           (aset rev-table ch i))
1612       (setq i (1+ i)))
1613     (set-char-table-extra-slot table 0 rev-table)
1614     table))
1615
1616 (defun define-translation-table (symbol &rest args)
1617   "Define SYMBOL as the name of translation table made by ARGS.
1618 This sets up information so that the table can be used for
1619 translations in a CCL program.
1620
1621 If the first element of ARGS is a char-table whose purpose is
1622 `translation-table', just define SYMBOL to name it.  (Note that this
1623 function does not bind SYMBOL.)
1624
1625 Any other ARGS should be suitable as arguments of the function
1626 `make-translation-table' (which see).
1627
1628 This function sets properties `translation-table' and
1629 `translation-table-id' of SYMBOL to the created table itself and the
1630 identification number of the table respectively.  It also registers
1631 the table in `translation-table-vector'."
1632   (let ((table (if (and (char-table-p (car args))
1633                         (eq (char-table-subtype (car args))
1634                             'translation-table))
1635                    (car args)
1636                  (apply 'make-translation-table args)))
1637         (len (length translation-table-vector))
1638         (id 0)
1639         (done nil))
1640     (put symbol 'translation-table table)
1641     (while (not done)
1642       (if (>= id len)
1643           (setq translation-table-vector
1644                 (vconcat translation-table-vector (make-vector len nil))))
1645       (let ((slot (aref translation-table-vector id)))
1646         (if (or (not slot)
1647                 (eq (car slot) symbol))
1648             (progn
1649               (aset translation-table-vector id (cons symbol table))
1650               (setq done t))
1651           (setq id (1+ id)))))
1652     (put symbol 'translation-table-id id)
1653     id))
1654
1655 (put 'with-category-table 'lisp-indent-function 1)
1656
1657 (defmacro with-category-table (category-table &rest body)
1658   `(let ((current-category-table (category-table)))
1659      (set-category-table ,category-table)
1660      (unwind-protect
1661          (progn ,@body)
1662        (set-category-table current-category-table))))
1663
1664 ;;; Initialize some variables.
1665
1666 (put 'use-default-ascent 'char-table-extra-slots 0)
1667 (setq use-default-ascent (make-char-table 'use-default-ascent))
1668 (put 'ignore-relative-composition 'char-table-extra-slots 0)
1669 (setq ignore-relative-composition
1670       (make-char-table 'ignore-relative-composition))
1671
1672 ;;;
1673 (provide 'mule)
1674
1675 ;;; mule.el ends here