Invoke emacs by --no-init-file --no-site-file.
[bpt/emacs.git] / lisp / international / mule.el
CommitLineData
4ed46869
KH
1;;; mule.el --- basic commands for mulitilingual environment
2
4ed46869 3;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
58cfed09 4;; Licensed to the Free Software Foundation.
4ed46869
KH
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
369314dc
KH
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.
4ed46869
KH
24
25;;; Code:
26
27(defconst mule-version "3.0 (MOMIJINOGA)" "\
28Version number and name of this version of MULE (multilingual environment).")
29
30(defconst mule-version-date "1998.1.1" "\
31Distribution 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.
35The FILE is decoded before evaluation if necessary.
36If optional second arg NOERROR is non-nil,
37 report no error if FILE doesn't exist.
38Print messages at start and end of loading unless
39 optional third arg NOMESSAGE is non-nil.
40Return 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))
cfc70cdf
RS
66 (let (kill-buffer-hook kill-buffer-query-functions)
67 (kill-buffer buffer)))
4ed46869
KH
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.
87The 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,
93where
94CHARSET-ID (integer) is the identification number of the charset.
95DIMENSION (integer) is the number of bytes to represent a character of
96the charset: 1 or 2.
97CHARS (integer) is the number of characters in a dimension: 94 or 96.
98BYTE (integer) is the length of multi-byte form of a character in
99 the charset: one of 1, 2, 3, and 4.
100WIDTH (integer) is the number of columns a character in the charset
101 occupies on the screen: one of 0, 1, and 2.
102DIRECTION (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.
105LEADING-CODE-BASE (integer) is the base leading-code for the
106 charset.
107LEADING-CODE-EXT (integer) is the extended leading-code for the
108 charset. All charsets of less than 0xA0 has the value 0.
109ISO-FINAL-CHAR (character) is the final character of the
110 corresponding ISO 2022 charset.
111ISO-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).
114REVERSE-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.
117SHORT-NAME (string) is the short name to refer to the charset.
118LONG-NAME (string) is the long name to refer to the charset
119DESCRIPTION (string) is the description string of the charset.
120PLIST (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)
900dc6e3
KH
132 "Return bytes of CHARSET.
133See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
139 "Return dimension of CHARSET.
140See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
146 "Return character numbers contained in a dimension of CHARSET.
147See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
153 "Return width (how many column occupied on a screen) of CHARSET.
154See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
160 "Return direction of CHARSET.
161See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
167 "Return final char of CHARSET.
168See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
174 "Return graphic plane of CHARSET.
175See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
181 "Return reverse charset of CHARSET.
182See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
188 "Return short name of CHARSET.
189See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
195 "Return long name of CHARSET.
196See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
202 "Return descriptoin of CHARSET.
203See the function `charset-info' for more detail."
4ed46869
KH
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)
900dc6e3
KH
209 "Return list charset property of CHARSET.
210See the function `charset-info' for more detail."
4ed46869 211 (if (quoted-symbol-p charset)
f98e2797 212 `(aref ,(charset-info (nth 1 charset)) 14)
4ed46869
KH
213 `(aref (charset-info ,charset) 14)))
214
215(defun set-charset-plist (charset plist)
900dc6e3 216 "Set CHARSET's property list to PLIST, and retrun PLIST."
4ed46869
KH
217 (aset (charset-info charset) 14 plist))
218
219(defmacro make-char (charset &optional c1 c2)
f98e2797
KH
220 "Return a character of CHARSET and position-codes CODE1 and CODE2.
221CODE1 and CODE2 are optional, but if you don't supply
900dc6e3 222sufficient position-codes, return a generic character which stands for
f98e2797 223all characters or group of characters in the character sets.
a73a8c89 224A generic character can be used to index a char table (e.g. syntax-table)."
4ed46869
KH
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
69eba008 229(defmacro charset-list ()
900dc6e3
KH
230 "Return list of charsets ever defined.
231
232This macro is provided for backward compatibility.
233Now we have the variable `charset-list'."
13d5617d
KH
234 'charset-list)
235
236(defsubst generic-char-p (char)
237 "Return t if and only if CHAR is a generic character.
238See 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)))))
69eba008 242
8057896b 243;; Coding system staffs
4ed46869 244
8057896b 245;; Coding system is a symbol that has the property `coding-system'.
4ed46869 246;;
8057896b
KH
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
4ed46869
KH
264;; end-of-line LF, CRLF, and CR respectively. The vector value
265;; indicates that the format of end-of-line should be detected
8057896b
KH
266;; automatically. Nth element of the vector is the subsidiary coding
267;; system whose `eol-type' property is N.
4ed46869 268;;
8057896b
KH
269;; Coding system may also have properties `post-read-conversion' and
270;; `pre-write-conversion. Values of these properties are functions.
4ed46869
KH
271;;
272;; The function in `post-read-conversion' is called after some text is
8057896b 273;; inserted and decoded along the coding system and before any
4ed46869
KH
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
8057896b 282;; the coding system. The arguments to this function is the same as
4ed46869
KH
283;; those of a function in `write-region-annotate-functions', i.e. FROM
284;; and TO specifying region of a text.
285
8057896b
KH
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))))
4ed46869 291
4ed46869 292(defun coding-system-type (coding-system)
6e9722b0 293 "Return TYPE element in coding-spec of CODING-SYSTEM."
8057896b 294 (coding-system-spec-ref coding-system coding-spec-type-idx))
4ed46869 295
4ed46869 296(defun coding-system-mnemonic (coding-system)
8057896b
KH
297 "Return MNEMONIC element in coding-spec of CODING-SYSTEM."
298 (or (coding-system-spec-ref coding-system coding-spec-mnemonic-idx)
299 ?-))
4ed46869 300
8057896b
KH
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))
4ed46869 304
4ed46869 305(defun coding-system-flags (coding-system)
8057896b
KH
306 "Return FLAGS element in coding-spec of CODING-SYSTEM."
307 (coding-system-spec-ref coding-system coding-spec-flags-idx))
4ed46869 308
8057896b
KH
309(defun coding-system-eol-type (coding-system)
310 "Return eol-type property of CODING-SYSTEM."
69eba008 311 (check-coding-system coding-system)
4ed46869
KH
312 (and coding-system
313 (or (get coding-system 'eol-type)
8057896b 314 (coding-system-eol-type (get coding-system 'coding-system)))))
4ed46869 315
6e9722b0
KH
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
bd882697
KH
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
6e9722b0
KH
330;; Make subsidiary coding systems (eol-type variants) of CODING-SYSTEM.
331(defun make-subsidiary-coding-system (coding-system)
8057896b
KH
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)
6e9722b0 337 (put (aref subsidiaries i) 'coding-system coding-system)
8057896b
KH
338 (put (aref subsidiaries i) 'eol-type i)
339 (put (aref subsidiaries i) 'eol-variant t)
340 (setq i (1+ i)))
341 subsidiaries))
4ed46869 342
8057896b
KH
343(defun make-coding-system (coding-system type mnemonic doc-string
344 &optional flags)
4ed46869 345 "Define a new CODING-SYSTEM (symbol).
8057896b
KH
346Remaining arguments are TYPE, MNEMONIC, DOC-STRING, and FLAGS (optional) which
347construct a coding-spec of CODING-SYSTEM in the following format:
348 [TYPE MNEMONIC DOC-STRING nil FLAGS]
4ed46869
KH
349TYPE 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.
355MNEMONIC is a character to be displayed on mode line for the coding-system.
8057896b 356DOC-STRING is a documentation string for the coding-system.
4ed46869
KH
357FLAGS 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,
a73a8c89 361 USE-ROMAN, USE-OLDJIS, NO-ISO6429, INIT-BOL, DESIGNATION-BOL.
4ed46869
KH
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.
69eba008
KH
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.
4ed46869
KH
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.
6e9722b0
KH
385 (let ((coding-spec (make-vector 5 nil))
386 coding-category)
8057896b
KH
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
6e9722b0
KH
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
4ed46869 400 (let ((i 0)
6e9722b0
KH
401 (vec (make-vector 32 nil))
402 (no-initial-designation t)
403 (g1-designation nil))
4ed46869
KH
404 (while (< i 4)
405 (let ((charset (car flags)))
6e9722b0
KH
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))
69eba008
KH
419 (or (not elt) (eq elt t) (charsetp elt)
420 (error "Invalid charset: %s" elt))
6e9722b0
KH
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))))
4ed46869
KH
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)))
6e9722b0
KH
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.
dc64cd19
KH
435 (or (and (aref vec 7) 'coding-category-iso-7-else)
436 'coding-category-iso-8-else)
6e9722b0
KH
437 (if (aref vec 7) ; 7-bit only.
438 (if (aref vec 9) ; Use single-shift.
dc64cd19 439 'coding-category-iso-7-else
6e9722b0
KH
440 'coding-category-iso-7)
441 (if no-initial-designation
dc64cd19 442 'coding-category-iso-8-else
6e9722b0
KH
443 (if (and (charsetp g1-designation)
444 (= (charset-dimension g1-designation) 2))
445 'coding-category-iso-8-2
446 'coding-category-iso-8-1)))))))
447 ((= type 3)
448 (setq coding-category 'coding-category-big5))
449 ((= type 4) ; private
450 (setq coding-category 'coding-category-binary)
4ed46869
KH
451 (if (and (consp flags)
452 (vectorp (car flags))
453 (vectorp (cdr flags)))
8057896b 454 (aset coding-spec 4 flags)
6e9722b0
KH
455 (error "Invalid FLAGS argument for TYPE 4 (CCL)"))))
456 (put coding-system 'coding-system coding-spec)
457 (put coding-system 'coding-category coding-category)
458 (put coding-category 'coding-systems
459 (cons coding-system (get coding-category 'coding-systems))))
4ed46869
KH
460
461 ;; Next, set a value of `eol-type' property. The value is a vector
6e9722b0 462 ;; of subsidiary coding systems, each corresponds to a coding system
4ed46869 463 ;; for the detected end-of-line format.
8057896b
KH
464 (put coding-system 'eol-type
465 (if (<= type 3)
6e9722b0 466 (make-subsidiary-coding-system coding-system)
8057896b
KH
467 0)))
468
a42763dc 469(defun define-coding-system-alias (alias coding-system)
358d28fb 470 "Define ALIAS as an alias for coding system CODING-SYSTEM."
8057896b 471 (check-coding-system coding-system)
6e9722b0
KH
472 (let ((parent (coding-system-parent coding-system)))
473 (if parent
474 (setq coding-system parent)))
8057896b 475 (put alias 'coding-system coding-system)
6e9722b0
KH
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)))))))
4ed46869
KH
491
492(defun set-buffer-file-coding-system (coding-system &optional force)
358d28fb
RS
493 "Set the file coding-system of the current buffer to CODING-SYSTEM.
494This means that when you save the buffer, it will be converted
495according to CODING-SYSTEM. For a list of possible values of CODING-SYSTEM,
496use \\[list-coding-systems].
497
498If the buffer's previous file coding-system value specifies end-of-line
499conversion, and CODING-SYSTEM does not specify one, CODING-SYSTEM is
500merged with the already-specified end-of-line conversion.
501However, if the optional prefix argument FORCE is non-nil,
502them CODING-SYSTEM is used exactly as specified."
4ed46869
KH
503 (interactive "zBuffer-file-coding-system: \nP")
504 (check-coding-system coding-system)
505 (if (null force)
8057896b
KH
506 (let ((x (coding-system-eol-type buffer-file-coding-system))
507 (y (coding-system-eol-type coding-system)))
4ed46869
KH
508 (if (and (numberp x) (>= x 0) (<= x 2) (vectorp y))
509 (setq coding-system (aref y x)))))
510 (setq buffer-file-coding-system coding-system)
511 (set-buffer-modified-p t)
512 (force-mode-line-update))
513
358d28fb
RS
514(defvar default-terminal-coding-system nil
515 "Default value for the terminal coding system.
516This is normally set according to the selected language environment.
517See also the command `set-terminal-coding-system'.")
518
df100398
KH
519(defun set-terminal-coding-system (coding-system)
520 "Set coding system of your terminal to CODING-SYSTEM.
358d28fb
RS
521All text output to the terminal will be encoded
522with the specified coding system.
523For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems].
524The default is determined by the selected language environment
525or by the previous use of this command."
526 (interactive
527 (list (read-coding-system
528 (format "Coding system for terminal display (default, %s): "
529 (if (and (not (terminal-coding-system))
530 default-terminal-coding-system)
531 default-terminal-coding-system)))))
532 (if (and (not coding-system)
533 (not (terminal-coding-system)))
534 (setq coding-system default-terminal-coding-system))
535 (if coding-system
536 (setq default-terminal-coding-system coding-system))
df100398
KH
537 (set-terminal-coding-system-internal coding-system)
538 (redraw-frame (selected-frame)))
539
358d28fb
RS
540(defvar default-keyboard-coding-system nil
541 "Default value of the keyboard coding system.
542This is normally set according to the selected language environment.
543See also the command `set-keyboard-coding-system'.")
544
df100398 545(defun set-keyboard-coding-system (coding-system)
358d28fb
RS
546 "Set coding system for keyboard input to CODING-SYSTEM.
547In addition, this command enables Encoded-kbd minor mode.
548\(If CODING-SYSTEM is nil, Encoded-bkd mode is turned off.)
549For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems].
550The default is determined by the selected language environment
551or by the previous use of this command."
552 (interactive
553 (list (read-coding-system
554 (format "Coding system for keyboard input (default, %s): "
555 (if (and (not (keyboard-coding-system))
556 default-keyboard-coding-system)
557 default-keyboard-coding-system)))))
558 (if (and (not coding-system)
559 (not (keyboard-coding-system)))
560 (setq coding-system default-keyboard-coding-system))
561 (if coding-system
562 (setq default-keyboard-coding-system coding-system))
df100398
KH
563 (set-keyboard-coding-system-internal coding-system)
564 (encoded-kbd-mode (if coding-system 1 0)))
565
566(defun set-buffer-process-coding-system (decoding encoding)
358d28fb 567 "Set coding systems for the process associated with the current buffer.
df100398 568DECODING is the coding system to be used to decode input from the process,
358d28fb
RS
569ENCODING is the coding system to be used to encode output to the process.
570
571For a list of possible values of CODING-SYSTEM, use \\[list-coding-systems]."
4ed46869
KH
572 (interactive
573 "zCoding-system for process input: \nzCoding-system for process output: ")
574 (let ((proc (get-buffer-process (current-buffer))))
575 (if (null proc)
576 (error "no process")
df100398
KH
577 (check-coding-system decoding)
578 (check-coding-system encoding)
579 (set-process-coding-system proc decoding encoding)))
4ed46869
KH
580 (force-mode-line-update))
581
4ed46869
KH
582(defun set-coding-priority (arg)
583 "Set priority of coding-category according to LIST.
584LIST is a list of coding-categories ordered by priority."
585 (let (l)
586 ;; Put coding-categories listed in ARG to L while checking the
587 ;; validity. We assume that `coding-category-list' contains whole
588 ;; coding-categories.
589 (while arg
590 (if (null (memq (car arg) coding-category-list))
591 (error "Invalid element in argument: %s" (car arg)))
592 (setq l (cons (car arg) l))
593 (setq arg (cdr arg)))
594 ;; Put coding-category not listed in ARG to L.
595 (while coding-category-list
596 (if (null (memq (car coding-category-list) l))
597 (setq l (cons (car coding-category-list) l)))
598 (setq coding-category-list (cdr coding-category-list)))
599 ;; Update `coding-category-list' and return it.
600 (setq coding-category-list (nreverse l))))
601
602;;; FILE I/O
603
604;; Set buffer-file-coding-system of the current buffer after some text
605;; is inserted.
606(defun after-insert-file-set-buffer-file-coding-system (inserted)
607 (if last-coding-system-used
608 (let ((coding-system
609 (find-new-buffer-file-coding-system last-coding-system-used))
610 (modified-p (buffer-modified-p)))
611 (if coding-system
612 (set-buffer-file-coding-system coding-system))
613 (set-buffer-modified-p modified-p)))
614 nil)
615
616(setq after-insert-file-functions
617 (cons 'after-insert-file-set-buffer-file-coding-system
618 after-insert-file-functions))
619
8057896b 620;; The coding-spec and eol-type of coding-system returned is decided
4ed46869
KH
621;; independently in the following order.
622;; 1. That of buffer-file-coding-system locally bound.
623;; 2. That of CODING.
624
625(defun find-new-buffer-file-coding-system (coding)
626 "Return a coding system for a buffer when a file of CODING is inserted.
a73a8c89
KH
627The local variable `buffer-file-coding-system' of the current buffer
628is set to the returned value.
df100398 629Return nil if there's no need of setting new buffer-file-coding-system."
4ed46869
KH
630 (let (local-coding local-eol
631 found-eol
632 new-coding new-eol)
633 (if (null coding)
634 ;; Nothing found about coding.
635 nil
636
637 ;; Get information of the current local value of
638 ;; `buffer-file-coding-system' in LOCAL-EOL and LOCAL-CODING.
639 (if (local-variable-p 'buffer-file-coding-system)
640 ;; Something already set locally.
641 (progn
8057896b 642 (setq local-eol (coding-system-eol-type buffer-file-coding-system))
4ed46869
KH
643 (if (null (numberp local-eol))
644 ;; But eol-type is not yet set.
645 (setq local-eol nil))
646 (if (null (eq (coding-system-type buffer-file-coding-system) t))
13d5617d 647 ;; This is not `undecided'.
4ed46869
KH
648 (progn
649 (setq local-coding buffer-file-coding-system)
650 (while (symbolp (get local-coding 'coding-system))
651 (setq local-coding (get local-coding 'coding-system))))
652 )))
653
654 (if (and local-eol local-coding)
655 ;; The current buffer has already set full coding-system, we
656 ;; had better not change it.
657 nil
658
8057896b 659 (setq found-eol (coding-system-eol-type coding))
4ed46869
KH
660 (if (null (numberp found-eol))
661 ;; But eol-type is not found.
662 (setq found-eol nil))
4ed46869
KH
663
664 ;; The local setting takes precedence over the found one.
665 (setq new-coding (or local-coding coding))
666 (setq new-eol (or local-eol found-eol))
667 (if (and (numberp new-eol)
8057896b 668 (vectorp (coding-system-eol-type new-coding)))
4ed46869 669 (setq new-coding
8057896b 670 (aref (coding-system-eol-type new-coding) new-eol)))
4ed46869
KH
671 new-coding))))
672
fe831d33
GV
673(defun modify-coding-system-alist (target-type regexp coding-system)
674 "Modify one of look up tables for finding a coding system on I/O operation.
8c453b46
RS
675There are three of such tables, `file-coding-system-alist',
676`process-coding-system-alist', and `network-coding-system-alist'.
fe831d33
GV
677
678TARGET-TYPE specifies which of them to modify.
8c453b46
RS
679If it is `file', it affects `file-coding-system-alist' (which see).
680If it is `process', it affects `process-coding-system-alist' (which see).
681If it is `network', it affects `network-codign-system-alist' (which see).
fe831d33
GV
682
683REGEXP is a regular expression matching a target of I/O operation.
684The target is a file name if TARGET-TYPE is `file', a program name if
685TARGET-TYPE is `process', or a network service name or a port number
686to connect to if TARGET-TYPE is `network'.
687
688CODING-SYSTEM is a coding system to perform code conversion on the I/O
8c453b46
RS
689operation, or a cons cell (DECODING . ENCODING) specifying the coding systems
690for decoding and encoding respectively,
691or a function symbol which, when called, returns such a cons cell."
fe831d33
GV
692 (or (memq target-type '(file process network))
693 (error "Invalid target type: %s" target-type))
694 (or (stringp regexp)
695 (and (eq target-type 'network) (integerp regexp))
696 (error "Invalid regular expression: %s" regexp))
697 (if (symbolp coding-system)
698 (if (not (fboundp coding-system))
699 (progn
700 (check-coding-system coding-system)
701 (setq coding-system (cons coding-system coding-system))))
702 (check-coding-system (car coding-system))
703 (check-coding-system (cdr coding-system)))
704 (cond ((eq target-type 'file)
705 (let ((slot (assoc regexp file-coding-system-alist)))
706 (if slot
707 (setcdr slot coding-system)
708 (setq file-coding-system-alist
709 (cons (cons regexp coding-system)
710 file-coding-system-alist)))))
711 ((eq target-type 'process)
712 (let ((slot (assoc regexp process-coding-system-alist)))
713 (if slot
714 (setcdr slot coding-system)
715 (setq process-coding-system-alist
716 (cons (cons regexp coding-system)
717 process-coding-system-alist)))))
718 (t
719 (let ((slot (assoc regexp network-coding-system-alist)))
720 (if slot
721 (setcdr slot coding-system)
722 (setq network-coding-system-alist
723 (cons (cons regexp coding-system)
724 network-coding-system-alist)))))))
725
a73a8c89
KH
726(defun make-unification-table (&rest args)
727 "Make a unification table (char table) from arguments.
13d5617d
KH
728Each argument is a list of the form (FROM . TO),
729where FROM is a character to be unified to TO.
730
731FROM can be a generic character (see make-char). In this case, TO is
732a generic character containing the same number of charcters or a
733oridinal character. If FROM and TO are both generic characters, all
734characters belonging to FROM are unified to characters belonging to TO
735without changing their position code(s)."
a73a8c89
KH
736 (let ((table (make-char-table 'character-unification-table))
737 revlist)
738 (while args
739 (let ((elts (car args)))
740 (while elts
13d5617d
KH
741 (let* ((from (car (car elts)))
742 (from-i 0) ; degree of freedom of FROM
743 (from-rev (nreverse (split-char from)))
744 (to (cdr (car elts)))
745 (to-i 0) ; degree of freedom of TO
746 (to-rev (nreverse (split-char to))))
747 ;; Check numbers of heading 0s in FROM-REV and TO-REV.
748 (while (eq (car from-rev) 0)
749 (setq from-i (1+ from-i) from-rev (cdr from-rev)))
750 (while (eq (car to-rev) 0)
751 (setq to-i (1+ to-i) to-rev (cdr to-rev)))
752 (if (and (/= from-i to-i) (/= to-i 0))
753 (error "Invalid character pair (%d . %d)" from to))
754 ;; If we have already unified TO to TO-ALT, FROM should
755 ;; also be unified to TO-ALT. But, this is only if TO is
756 ;; a generic character or TO-ALT is not a generic
757 ;; character.
758 (let ((to-alt (aref table to)))
759 (if (and to-alt
760 (or (> to-i 0) (not (generic-char-p to-alt))))
761 (setq to to-alt)))
762 (if (> from-i 0)
763 (set-char-table-default table from to)
764 (aset table from to))
a73a8c89
KH
765 ;; If we have already unified some chars to FROM, they
766 ;; should also be unified to TO.
767 (let ((l (assq from revlist)))
768 (if l
769 (let ((ch (car l)))
770 (setcar l to)
771 (setq l (cdr l))
772 (while l
773 (aset table ch to)
774 (setq l (cdr l)) ))))
775 ;; Now update REVLIST.
776 (let ((l (assq to revlist)))
777 (if l
778 (setcdr l (cons from (cdr l)))
779 (setq revlist (cons (list to from) revlist)))))
780 (setq elts (cdr elts))))
781 (setq args (cdr args)))
782 ;; Return TABLE just created.
783 table))
784
69eba008
KH
785;;; Initialize some variables.
786
787(put 'use-default-ascent 'char-table-extra-slots 0)
788(setq use-default-ascent (make-char-table 'use-default-ascent))
789
790;;;
4ed46869
KH
791(provide 'mule)
792
793;;; mule.el ends here