code.delx.au - gnu-emacs/blob - lisp/international/mule.el

   1 ;;; mule.el --- basic commands for mulitilingual environment
   2
   3 ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
   4 ;; Licensed to the Free Software Foundation.
   5
   6 ;; Keywords: mule, multilingual, character set, coding system
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (defconst mule-version "3.0 (MOMIJINOGA)" "\
  28 Version number and name of this version of MULE (multilingual environment).")
  29
  30 (defconst mule-version-date "1998.1.1" "\
  31 Distribution date of this version of MULE (multilingual environment).")
  32
  33 (defun load-with-code-conversion (fullname file &optional noerror nomessage)
  34   "Execute a file of Lisp code named FILE whose absolute path is FULLNAME.
  35 The FILE is decoded before evaluation if necessary.
  36 If optional second arg NOERROR is non-nil,
  37  report no error if FILE doesn't exist.
  38 Print messages at start and end of loading unless
  39  optional third arg NOMESSAGE is non-nil.
  40 Return t if file exists."
  41   (if (null (file-readable-p fullname))
  42       (and (null noerror)
  43            (signal 'file-error (list "Cannot open load file" file)))
  44     ;; Read file with code conversion, and then eval.
  45     (let* ((buffer
  46             ;; To avoid any autoloading, set default-major-mode to
  47             ;; fundamental-mode.
  48             (let ((default-major-mode 'fundamental-mode))
  49               ;; We can't use `generate-new-buffer' because files.el
  50               ;; is not yet loaded.
  51               (get-buffer-create (generate-new-buffer-name " *load*"))))
  52            (load-in-progress t))
  53       (or nomessage (message "Loading %s..." file))
  54       (unwind-protect
  55           (progn
  56             (save-excursion
  57               (set-buffer buffer)
  58               (insert-file-contents fullname)
  59               ;; We must set `buffer-file-name' for `eval-buffer' and
  60               ;; `load-history'.
  61               (setq buffer-file-name file)
  62               ;; Make `kill-buffer' quiet.
  63               (set-buffer-modified-p nil))
  64             ;; Eval in the original buffer.
  65             (eval-buffer buffer))
  66         (let (kill-buffer-hook kill-buffer-query-functions)
  67           (kill-buffer buffer)))
  68       (let ((hook (assoc file after-load-alist)))
  69               (if hook
  70                   (mapcar (function eval) (cdr hook))))
  71       (or nomessage noninteractive
  72           (message "Loading %s...done" file))
  73       t)))
  74
  75 ;; API (Application Program Interface) for charsets.
  76
  77 ;; Return t if OBJ is a quoted symbol.
  78 (defsubst quoted-symbol-p (obj)
  79   (and (listp obj) (eq (car obj) 'quote)))
  80
  81 (defsubst charsetp (object)
  82   "T is OBJECT is a charset."
  83   (and (symbolp object) (vectorp (get object 'charset))))
  84
  85 (defsubst charset-info (charset)
  86   "Return a vector of information of CHARSET.
  87 The elements of the vector are:
  88         CHARSET-ID, BYTES, DIMENSION, CHARS, WIDTH, DIRECTION,
  89         LEADING-CODE-BASE, LEADING-CODE-EXT,
  90         ISO-FINAL-CHAR, ISO-GRAPHIC-PLANE,
  91         REVERSE-CHARSET, SHORT-NAME, LONG-NAME, DESCRIPTION,
  92         PLIST,
  93 where
  94 CHARSET-ID (integer) is the identification number of the charset.
  95 DIMENSION (integer) is the number of bytes to represent a character of
  96 the charset: 1 or 2.
  97 CHARS (integer) is the number of characters in a dimension: 94 or 96.
  98 BYTE (integer) is the length of multi-byte form of a character in
  99   the charset: one of 1, 2, 3, and 4.
 100 WIDTH (integer) is the number of columns a character in the charset
 101   occupies on the screen: one of 0, 1, and 2.
 102 DIRECTION (integer) is the rendering direction of characters in the
 103   charset when rendering.  If 0, render from right to left, else
 104   render from left to right.
 105 LEADING-CODE-BASE (integer) is the base leading-code for the
 106   charset.
 107 LEADING-CODE-EXT (integer) is the extended leading-code for the
 108   charset.  All charsets of less than 0xA0 has the value 0.
 109 ISO-FINAL-CHAR (character) is the final character of the
 110   corresponding ISO 2022 charset.
 111 ISO-GRAPHIC-PLANE (integer) is the graphic plane to be invoked
 112   while encoding to variants of ISO 2022 coding system, one of the
 113   following: 0/graphic-plane-left(GL), 1/graphic-plane-right(GR).
 114 REVERSE-CHARSET (integer) is the charset which differs only in
 115   LEFT-TO-RIGHT value from the charset.  If there's no such a
 116   charset, the value is -1.
 117 SHORT-NAME (string) is the short name to refer to the charset.
 118 LONG-NAME (string) is the long name to refer to the charset
 119 DESCRIPTION (string) is the description string of the charset.
 120 PLIST (property list) may contain any type of information a user
 121   want to put and get by functions `put-charset-property' and
 122   `get-charset-property' respectively."
 123   (get charset 'charset))
 124
 125 (defmacro charset-id (charset)
 126   "Return charset identification number of CHARSET."
 127   (if (and (listp charset) (eq (car charset) 'quote))
 128       (aref (charset-info (nth 1 charset)) 0)
 129     `(aref (charset-info ,charset) 0)))
 130
 131 (defmacro charset-bytes (charset)
 132   "Return bytes of CHARSET.
 133 See the function `charset-info' for more detail."
 134   (if (quoted-symbol-p charset)
 135       (aref (charset-info (nth 1 charset)) 1)
 136     `(aref (charset-info ,charset) 1)))
 137
 138 (defmacro charset-dimension (charset)
 139   "Return dimension of CHARSET.
 140 See the function `charset-info' for more detail."
 141   (if (quoted-symbol-p charset)
 142       (aref (charset-info (nth 1 charset)) 2)
 143     `(aref (charset-info ,charset) 2)))
 144
 145 (defmacro charset-chars (charset)
 146   "Return character numbers contained in a dimension of CHARSET.
 147 See the function `charset-info' for more detail."
 148   (if (quoted-symbol-p charset)
 149       (aref (charset-info (nth 1 charset)) 3)
 150     `(aref (charset-info ,charset) 3)))
 151
 152 (defmacro charset-width (charset)
 153   "Return width (how many column occupied on a screen) of CHARSET.
 154 See the function `charset-info' for more detail."
 155   (if (quoted-symbol-p charset)
 156       (aref (charset-info (nth 1 charset)) 4)
 157     `(aref (charset-info ,charset) 4)))
 158
 159 (defmacro charset-direction (charset)
 160   "Return direction of CHARSET.
 161 See the function `charset-info' for more detail."
 162   (if (quoted-symbol-p charset)
 163       (aref (charset-info (nth 1 charset)) 5)
 164     `(aref (charset-info ,charset) 5)))
 165
 166 (defmacro charset-iso-final-char (charset)
 167   "Return final char of CHARSET.
 168 See the function `charset-info' for more detail."
 169   (if (quoted-symbol-p charset)
 170       (aref (charset-info (nth 1 charset)) 8)
 171     `(aref (charset-info ,charset) 8)))
 172
 173 (defmacro charset-iso-graphic-plane (charset)
 174   "Return graphic plane of CHARSET.
 175 See the function `charset-info' for more detail."
 176   (if (quoted-symbol-p charset)
 177       (aref (charset-info (nth 1 charset)) 9)
 178     `(aref (charset-info ,charset) 9)))
 179
 180 (defmacro charset-reverse-charset (charset)
 181   "Return reverse charset of CHARSET.
 182 See the function `charset-info' for more detail."
 183   (if (quoted-symbol-p charset)
 184       (aref (charset-info (nth 1 charset)) 10)
 185     `(aref (charset-info ,charset) 10)))
 186
 187 (defmacro charset-short-name (charset)
 188   "Return short name of CHARSET.
 189 See the function `charset-info' for more detail."
 190   (if (quoted-symbol-p charset)
 191       (aref (charset-info (nth 1 charset)) 11)
 192     `(aref (charset-info ,charset) 11)))
 193
 194 (defmacro charset-long-name (charset)
 195   "Return long name of CHARSET.
 196 See the function `charset-info' for more detail."
 197   (if (quoted-symbol-p charset)
 198       (aref (charset-info (nth 1 charset)) 12)
 199     `(aref (charset-info ,charset) 12)))
 200
 201 (defmacro charset-description (charset)
 202   "Return descriptoin of CHARSET.
 203 See the function `charset-info' for more detail."
 204   (if (quoted-symbol-p charset)
 205       (aref (charset-info (nth 1 charset)) 13)
 206     `(aref (charset-info ,charset) 13)))
 207
 208 (defmacro charset-plist (charset)
 209   "Return list charset property of CHARSET.
 210 See the function `charset-info' for more detail."
 211   (if (quoted-symbol-p charset)
 212       `(aref ,(charset-info (nth 1 charset)) 14)
 213     `(aref (charset-info ,charset) 14)))
 214
 215 (defun set-charset-plist (charset plist)
 216   "Set CHARSET's property list to PLIST, and retrun PLIST."
 217   (aset (charset-info  charset) 14 plist))
 218
 219 (defmacro make-char (charset &optional c1 c2)
 220   "Return a character of CHARSET and position-codes CODE1 and CODE2.
 221 CODE1 and CODE2 are optional, but if you don't supply
 222 sufficient position-codes, return a generic character which stands for
 223 all characters or group of characters in the character sets.
 224 A generic character can be used to index a char table (e.g. syntax-table)."
 225   (if (quoted-symbol-p charset)
 226       `(make-char-internal ,(charset-id (nth 1 charset)) ,c1 ,c2)
 227     `(make-char-internal (charset-id ,charset) ,c1 ,c2)))
 228
 229 (defmacro charset-list ()
 230   "Return list of charsets ever defined.
 231
 232 This macro is provided for backward compatibility.
 233 Now we have the variable `charset-list'."
 234   'charset-list)
 235
 236 (defsubst generic-char-p (char)
 237   "Return t if and only if CHAR is a generic character.
 238 See also the documentation of make-char."
 239   (let ((l (split-char char)))
 240     (and (or (= (nth 1 l) 0) (eq (nth 2 l) 0))
 241          (not (eq (car l) 'composition)))))
 242
 243 ;; Coding system staffs
 244
 245 ;; Coding system is a symbol that has the property `coding-system'.
 246 ;;
 247 ;; The value of the property `coding-system' is a vector of the
 248 ;; following format:
 249 ;;      [TYPE MNEMONIC DOC-STRING NOT-USED-NOW FLAGS]
 250 ;; We call this vector as coding-spec.  See comments in src/coding.c
 251 ;; for more detail.  The property value may be another coding system,
 252 ;; in which case, the coding-spec should be taken from that
 253 ;; coding-system.  The 4th element NOT-USED-NOW is kept just for
 254 ;; backward compatibility with old version of Mule.
 255
 256 (defconst coding-spec-type-idx 0)
 257 (defconst coding-spec-mnemonic-idx 1)
 258 (defconst coding-spec-doc-string-idx 2)
 259 (defconst coding-spec-flags-idx 4)
 260
 261 ;; Coding system may have proerpty `eol-type'.  The value of the
 262 ;; property `eol-type' is integer 0..2 or a vector of three coding
 263 ;; systems.  The integer value 0, 1, and 2 indicate the format of
 264 ;; end-of-line LF, CRLF, and CR respectively.  The vector value
 265 ;; indicates that the format of end-of-line should be detected
 266 ;; automatically.  Nth element of the vector is the subsidiary coding
 267 ;; system whose `eol-type' property is N.
 268 ;;
 269 ;; Coding system may also have properties `post-read-conversion' and
 270 ;; `pre-write-conversion.  Values of these properties are functions.
 271 ;;
 272 ;; The function in `post-read-conversion' is called after some text is
 273 ;; inserted and decoded along the coding system and before any
 274 ;; functions in `after-insert-functions' are called.  The arguments to
 275 ;; this function is the same as those of a function in
 276 ;; `after-insert-functions', i.e. LENGTH of a text while putting point
 277 ;; at the head of the text to be decoded
 278 ;;
 279 ;; The function in `pre-write-conversion' is called after all
 280 ;; functions in `write-region-annotate-functions' and
 281 ;; `buffer-file-format' are called, and before the text is encoded by
 282 ;; the coding system.  The arguments to this function is the same as
 283 ;; those of a function in `write-region-annotate-functions', i.e. FROM
 284 ;; and TO specifying region of a text.
 285
 286 ;; Return Nth element of coding-spec of CODING-SYSTEM.
 287 (defun coding-system-spec-ref (coding-system n)
 288   (check-coding-system coding-system)
 289   (let ((vec (coding-system-spec coding-system)))
 290     (and vec (aref vec n))))
 291
 292 (defun coding-system-type (coding-system)
 293   "Return TYPE element in coding-spec of CODING-SYSTEM."
 294   (coding-system-spec-ref coding-system coding-spec-type-idx))
 295
 296 (defun coding-system-mnemonic (coding-system)
 297   "Return MNEMONIC element in coding-spec of CODING-SYSTEM."
 298   (or (coding-system-spec-ref coding-system coding-spec-mnemonic-idx)
 299       ?-))
 300
 301 (defun coding-system-doc-string (coding-system)
 302   "Return DOC-STRING element in coding-spec of CODING-SYSTEM."
 303   (coding-system-spec-ref coding-system coding-spec-doc-string-idx))
 304
 305 (defun coding-system-flags (coding-system)
 306   "Return FLAGS element in coding-spec of CODING-SYSTEM."
 307   (coding-system-spec-ref coding-system coding-spec-flags-idx))
 308
 309 (defun coding-system-eol-type (coding-system)
 310   "Return eol-type property of CODING-SYSTEM."
 311   (check-coding-system coding-system)
 312   (and coding-system
 313        (or (get coding-system 'eol-type)
 314            (coding-system-eol-type (get coding-system 'coding-system)))))
 315
 316 (defun coding-system-category (coding-system)
 317   "Return coding category of CODING-SYSTEM."
 318   (and coding-system
 319        (symbolp coding-system)
 320        (or (get coding-system 'coding-category)
 321            (coding-system-category (get coding-system 'coding-system)))))
 322
 323 (defun coding-system-parent (coding-system)
 324   "Return parent of CODING-SYSTEM."
 325   (let ((parent (get coding-system 'parent-coding-system)))
 326     (and parent
 327          (or (coding-system-parent parent)
 328              parent))))
 329
 330 ;; Make subsidiary coding systems (eol-type variants) of CODING-SYSTEM.
 331 (defun make-subsidiary-coding-system (coding-system)
 332   (let ((subsidiaries (vector (intern (format "%s-unix" coding-system))
 333                               (intern (format "%s-dos" coding-system))
 334                               (intern (format "%s-mac" coding-system))))
 335         (i 0))
 336     (while (< i 3)
 337       (put (aref subsidiaries i) 'coding-system coding-system)
 338       (put (aref subsidiaries i) 'eol-type i)
 339       (put (aref subsidiaries i) 'eol-variant t)
 340       (setq i (1+ i)))
 341     subsidiaries))
 342
 343 (defun make-coding-system (coding-system type mnemonic doc-string
 344                                          &optional flags)
 345   "Define a new CODING-SYSTEM (symbol).
 346 Remaining arguments are TYPE, MNEMONIC, DOC-STRING, and FLAGS (optional) which
 347 construct a coding-spec of CODING-SYSTEM in the following format:
 348         [TYPE MNEMONIC DOC-STRING nil FLAGS]
 349 TYPE is an integer value indicating the type of coding-system as follows:
 350   0: Emacs internal format,
 351   1: Shift-JIS (or MS-Kanji) used mainly on Japanese PC,
 352   2: ISO-2022 including many variants,
 353   3: Big5 used mainly on Chinese PC,
 354   4: private, CCL programs provide encoding/decoding algorithm.
 355 MNEMONIC is a character to be displayed on mode line for the coding-system.
 356 DOC-STRING is a documentation string for the coding-system.
 357 FLAGS specifies more precise information of each TYPE.
 358   If TYPE is 2 (ISO-2022), FLAGS should be a list of:
 359       CHARSET0, CHARSET1, CHARSET2, CHARSET3, SHORT-FORM,
 360       ASCII-EOL, ASCII-CNTL, SEVEN, LOCKING-SHIFT, SINGLE-SHIFT,
 361       USE-ROMAN, USE-OLDJIS, NO-ISO6429, INIT-BOL, DESIGNATION-BOL.
 362     CHARSETn are character sets initially designated to Gn graphic registers.
 363       If CHARSETn is nil, Gn is never used.
 364       If CHARSETn is t, Gn can be used but nothing designated initially.
 365       If CHARSETn is a list of character sets, those character sets are
 366         designated to Gn on output, but nothing designated to Gn initially.
 367     SHORT-FORM non-nil means use short designation sequence on output.
 368     ASCII-EOL non-nil means designate ASCII to g0 at end of line on output.
 369     ASCII-CNTL non-nil means designate ASCII to g0 before control codes and
 370       SPACE on output.
 371     SEVEN non-nil means use 7-bit code only on output.
 372     LOCKING-SHIFT non-nil means use locking-shift.
 373     SINGLE-SHIFT non-nil means use single-shift.
 374     USE-ROMAN non-nil means designate JIS0201-1976-Roman instead of ASCII.
 375     USE-OLDJIS non-nil means designate JIS0208-1976 instead of JIS0208-1983.
 376     NO-ISO6429 non-nil means not use ISO6429's direction specification.
 377     INIT-BOL non-nil means any designation state is assumed to be reset
 378       to initial at each beginning of line on output.
 379     DESIGNATION-BOL non-nil means designation sequences should be placed
 380       at beginning of line on output.
 381   If TYPE is 4 (private), FLAGS should be a cons of CCL programs,
 382     for encoding and decoding.  See the documentation of CCL for more detail."
 383
 384   ;; At first, set a value of `coding-system' property.
 385   (let ((coding-spec (make-vector 5 nil))
 386         coding-category)
 387     (if (or (not (integerp type)) (< type 0) (> type 4))
 388         (error "TYPE argument must be 0..4"))
 389     (if (or (not (integerp mnemonic)) (<= mnemonic ? ) (> mnemonic 127))
 390         (error "MNEMONIC arguemnt must be a printable character."))
 391     (aset coding-spec 0 type)
 392     (aset coding-spec 1 mnemonic)
 393     (aset coding-spec 2 (if (stringp doc-string) doc-string ""))
 394     (aset coding-spec 3 nil)            ; obsolete element
 395     (cond ((= type 0)
 396            (setq coding-category 'coding-category-emacs-mule))
 397           ((= type 1)
 398            (setq coding-category 'coding-category-sjis))
 399           ((= type 2)                   ; ISO2022
 400            (let ((i 0)
 401                  (vec (make-vector 32 nil))
 402                  (no-initial-designation t)
 403                  (g1-designation nil))
 404              (while (< i 4)
 405                (let ((charset (car flags)))
 406                  (if (and no-initial-designation
 407                           (> i 0)
 408                           (or (charsetp charset)
 409                               (and (consp charset)
 410                                    (charsetp (car charset)))))
 411                      (setq no-initial-designation nil))
 412                  (if (charsetp charset)
 413                      (if (= i 1) (setq g1-designation charset))
 414                    (if (consp charset)
 415                        (let ((tail charset)
 416                              elt)
 417                          (while tail
 418                            (setq elt (car tail))
 419                            (or (not elt) (eq elt t) (charsetp elt)
 420                                (error "Invalid charset: %s" elt))
 421                            (setq tail (cdr tail)))
 422                          (setq g1-designation (car charset)))
 423                      (if (and charset (not (eq charset t)))
 424                          (error "Invalid charset: %s" charset))))
 425                  (aset vec i charset))
 426                (setq flags (cdr flags) i (1+ i)))
 427              (while (and (< i 32) flags)
 428                (aset vec i (car flags))
 429                (setq flags (cdr flags) i (1+ i)))
 430              (aset coding-spec 4 vec)
 431              (if no-initial-designation
 432                  (put coding-system 'no-initial-designation t))
 433              (setq coding-category
 434                    (if (aref vec 8)     ; Use locking-shift.
 435                        'coding-category-iso-else
 436                      (if (aref vec 7)   ; 7-bit only.
 437                          (if (aref vec 9) ; Use single-shift.
 438                              'coding-category-iso-else
 439                            'coding-category-iso-7)
 440                        (if no-initial-designation
 441                            'coding-category-iso-else
 442                          (if (and (charsetp g1-designation)
 443                                   (= (charset-dimension g1-designation) 2))
 444                              'coding-category-iso-8-2
 445                            'coding-category-iso-8-1)))))))
 446           ((= type 3)
 447            (setq coding-category 'coding-category-big5))
 448           ((= type 4)                   ; private
 449            (setq coding-category 'coding-category-binary)
 450            (if (and (consp flags)
 451                     (vectorp (car flags))
 452                     (vectorp (cdr flags)))
 453                (aset coding-spec 4 flags)
 454              (error "Invalid FLAGS argument for TYPE 4 (CCL)"))))
 455     (put coding-system 'coding-system coding-spec)
 456     (put coding-system 'coding-category coding-category)
 457     (put coding-category 'coding-systems
 458          (cons coding-system (get coding-category 'coding-systems))))
 459
 460   ;; Next, set a value of `eol-type' property.  The value is a vector
 461   ;; of subsidiary coding systems, each corresponds to a coding system
 462   ;; for the detected end-of-line format.
 463   (put coding-system 'eol-type
 464        (if (<= type 3)
 465            (make-subsidiary-coding-system coding-system)
 466          0)))
 467
 468 (defun define-coding-system-alias (alias coding-system)
 469   "Define ALIAS as an alias for coding system
 470  CODING-SYSTEM."
 471   (check-coding-system coding-system)
 472   (let ((parent (coding-system-parent coding-system)))
 473     (if parent
 474         (setq coding-system parent)))
 475   (put alias 'coding-system coding-system)
 476   (put alias 'parent-coding-system coding-system)
 477   (put coding-system 'alias-coding-systems
 478        (cons alias (get coding-system 'alias-coding-systems)))
 479   (let ((eol-variants (coding-system-eol-type coding-system))
 480         subsidiaries)
 481     (if (vectorp eol-variants)
 482         (let ((i 0))
 483           (setq subsidiaries (make-subsidiary-coding-system alias))
 484           (while (< i 3)
 485             (put (aref subsidiaries i) 'parent-coding-system
 486                  (aref eol-variants i))
 487             (put (aref eol-variants i) 'alias-coding-systems
 488                  (cons (aref subsidiaries i) (get (aref eol-variants i)
 489                                                   'alias-coding-systems)))
 490             (setq i (1+ i)))))))
 491
 492 (defun set-buffer-file-coding-system (coding-system &optional force)
 493   "Set buffer-file-coding-system of the current buffer to CODING-SYSTEM.
 494 If eol-type of the current buffer-file-coding-system is an integer value N, and
 495  eol-type of CODING-SYSTEM is a vector, the Nth element of the vector is used
 496  instead of CODING-SYSTEM itself.
 497 Optional prefix argument FORCE non-nil means CODING-SYSTEM is set
 498  regardless of eol-type of the current buffer-file-coding-system."
 499   (interactive "zBuffer-file-coding-system: \nP")
 500   (check-coding-system coding-system)
 501   (if (null force)
 502       (let ((x (coding-system-eol-type buffer-file-coding-system))
 503             (y (coding-system-eol-type coding-system)))
 504         (if (and (numberp x) (>= x 0) (<= x 2) (vectorp y))
 505             (setq coding-system (aref y x)))))
 506   (setq buffer-file-coding-system coding-system)
 507   (set-buffer-modified-p t)
 508   (force-mode-line-update))
 509
 510 (defun set-terminal-coding-system (coding-system)
 511   "Set coding system of your terminal to CODING-SYSTEM.
 512 All outputs to terminal are encoded by the specified coding system."
 513   (interactive "zCoding-system for terminal display: ")
 514   (set-terminal-coding-system-internal coding-system)
 515   (redraw-frame (selected-frame)))
 516
 517 (defun set-keyboard-coding-system (coding-system)
 518   "Set coding system of codes sent from terminal keyboard to CODING-SYSTEM.
 519 In addition, this command toggles Encoded-kbd minor mode.
 520 If the specified coding system is nil, Encoded-bkd mode is turned off,
 521 else it is turned on so that user inputs are decoded by the
 522 specified coding system."
 523   (interactive "zCoding-system for keyboard input: ")
 524   (set-keyboard-coding-system-internal coding-system)
 525   (encoded-kbd-mode (if coding-system 1 0)))
 526
 527 (defun set-buffer-process-coding-system (decoding encoding)
 528   "Set coding systems to the process associated with the current buffer.
 529 DECODING is the coding system to be used to decode input from the process,
 530 ENCODING is to be used to encode output to the process."
 531   (interactive
 532    "zCoding-system for process input: \nzCoding-system for process output: ")
 533   (let ((proc (get-buffer-process (current-buffer))))
 534     (if (null proc)
 535         (error "no process")
 536       (check-coding-system decoding)
 537       (check-coding-system encoding)
 538       (set-process-coding-system proc decoding encoding)))
 539   (force-mode-line-update))
 540
 541 (defun set-coding-priority (arg)
 542   "Set priority of coding-category according to LIST.
 543 LIST is a list of coding-categories ordered by priority."
 544   (let (l)
 545     ;; Put coding-categories listed in ARG to L while checking the
 546     ;; validity.  We assume that `coding-category-list' contains whole
 547     ;; coding-categories.
 548     (while arg
 549       (if (null (memq (car arg) coding-category-list))
 550           (error "Invalid element in argument: %s" (car arg)))
 551       (setq l (cons (car arg) l))
 552       (setq arg (cdr arg)))
 553     ;; Put coding-category not listed in ARG to L.
 554     (while coding-category-list
 555       (if (null (memq (car coding-category-list) l))
 556           (setq l (cons (car coding-category-list) l)))
 557       (setq coding-category-list (cdr coding-category-list)))
 558     ;; Update `coding-category-list' and return it.
 559     (setq coding-category-list (nreverse l))))
 560
 561 ;;; FILE I/O
 562
 563 ;; Set buffer-file-coding-system of the current buffer after some text
 564 ;; is inserted.
 565 (defun after-insert-file-set-buffer-file-coding-system (inserted)
 566   (if last-coding-system-used
 567       (let ((coding-system
 568              (find-new-buffer-file-coding-system last-coding-system-used))
 569             (modified-p (buffer-modified-p)))
 570         (if coding-system
 571             (set-buffer-file-coding-system coding-system))
 572         (set-buffer-modified-p modified-p)))
 573   nil)
 574
 575 (setq after-insert-file-functions
 576       (cons 'after-insert-file-set-buffer-file-coding-system
 577             after-insert-file-functions))
 578
 579 ;; The coding-spec and eol-type of coding-system returned is decided
 580 ;; independently in the following order.
 581 ;;      1. That of buffer-file-coding-system locally bound.
 582 ;;      2. That of CODING.
 583
 584 (defun find-new-buffer-file-coding-system (coding)
 585   "Return a coding system for a buffer when a file of CODING is inserted.
 586 The local variable `buffer-file-coding-system' of the current buffer
 587 is set to the returned value.
 588 Return nil if there's no need of setting new buffer-file-coding-system."
 589   (let (local-coding local-eol
 590         found-eol
 591         new-coding new-eol)
 592     (if (null coding)
 593         ;; Nothing found about coding.
 594         nil
 595
 596       ;; Get information of the current local value of
 597       ;; `buffer-file-coding-system' in LOCAL-EOL and LOCAL-CODING.
 598       (if (local-variable-p 'buffer-file-coding-system)
 599           ;; Something already set locally.
 600           (progn
 601             (setq local-eol (coding-system-eol-type buffer-file-coding-system))
 602             (if (null (numberp local-eol))
 603                 ;; But eol-type is not yet set.
 604                 (setq local-eol nil))
 605             (if (null (eq (coding-system-type buffer-file-coding-system) t))
 606                 ;; This is not `undecided'.
 607                 (progn
 608                   (setq local-coding buffer-file-coding-system)
 609                   (while (symbolp (get local-coding 'coding-system))
 610                     (setq local-coding (get local-coding 'coding-system))))
 611               )))
 612
 613       (if (and local-eol local-coding)
 614           ;; The current buffer has already set full coding-system, we
 615           ;; had better not change it.
 616           nil
 617
 618         (setq found-eol (coding-system-eol-type coding))
 619         (if (null (numberp found-eol))
 620             ;; But eol-type is not found.
 621             (setq found-eol nil))
 622
 623         ;; The local setting takes precedence over the found one.
 624         (setq new-coding (or local-coding coding))
 625         (setq new-eol (or local-eol found-eol))
 626         (if (and (numberp new-eol)
 627                  (vectorp (coding-system-eol-type new-coding)))
 628             (setq new-coding
 629                   (aref (coding-system-eol-type new-coding) new-eol)))
 630         new-coding))))
 631
 632 (defun make-unification-table (&rest args)
 633   "Make a unification table (char table) from arguments.
 634 Each argument is a list of the form (FROM . TO),
 635 where FROM is a character to be unified to TO.
 636
 637 FROM can be a generic character (see make-char).  In this case, TO is
 638 a generic character containing the same number of charcters or a
 639 oridinal character.  If FROM and TO are both generic characters, all
 640 characters belonging to FROM are unified to characters belonging to TO
 641 without changing their position code(s)."
 642   (let ((table (make-char-table 'character-unification-table))
 643         revlist)
 644     (while args
 645       (let ((elts (car args)))
 646         (while elts
 647           (let* ((from (car (car elts)))
 648                  (from-i 0)             ; degree of freedom of FROM
 649                  (from-rev (nreverse (split-char from)))
 650                  (to (cdr (car elts)))
 651                  (to-i 0)               ; degree of freedom of TO
 652                  (to-rev (nreverse (split-char to))))
 653             ;; Check numbers of heading 0s in FROM-REV and TO-REV.
 654             (while (eq (car from-rev) 0)
 655               (setq from-i (1+ from-i) from-rev (cdr from-rev)))
 656             (while (eq (car to-rev) 0)
 657               (setq to-i (1+ to-i) to-rev (cdr to-rev)))
 658             (if (and (/= from-i to-i) (/= to-i 0))
 659                 (error "Invalid character pair (%d . %d)" from to))
 660             ;; If we have already unified TO to TO-ALT, FROM should
 661             ;; also be unified to TO-ALT.  But, this is only if TO is
 662             ;; a generic character or TO-ALT is not a generic
 663             ;; character.
 664             (let ((to-alt (aref table to)))
 665               (if (and to-alt
 666                        (or (> to-i 0) (not (generic-char-p to-alt))))
 667                   (setq to to-alt)))
 668             (if (> from-i 0)
 669                 (set-char-table-default table from to)
 670               (aset table from to))
 671             ;; If we have already unified some chars to FROM, they
 672             ;; should also be unified to TO.
 673             (let ((l (assq from revlist)))
 674               (if l
 675                   (let ((ch (car l)))
 676                     (setcar l to)
 677                     (setq l (cdr l))
 678                     (while l
 679                       (aset table ch to)
 680                       (setq l (cdr l)) ))))
 681             ;; Now update REVLIST.
 682             (let ((l (assq to revlist)))
 683               (if l
 684                   (setcdr l (cons from (cdr l)))
 685                 (setq revlist (cons (list to from) revlist)))))
 686           (setq elts (cdr elts))))
 687       (setq args (cdr args)))
 688     ;; Return TABLE just created.
 689     table))
 690
 691 ;;; Initialize some variables.
 692
 693 (put 'use-default-ascent 'char-table-extra-slots 0)
 694 (setq use-default-ascent (make-char-table 'use-default-ascent))
 695
 696 ;;;
 697 (provide 'mule)
 698
 699 ;;; mule.el ends here