(coding-system-parent): New function.

(coding-system-lessp): New function.
(coding-system-list): Sort coding systems by coding-system-lessp.
An element of returned list is always coing system, never be a
cons.
(modify-coding-system-alist): Renamed from
set-coding-system-alist.
(prefer-coding-system): New function.
(compose-chars-component): But fix for handling a composite
character of no compositon rule.

1 files changed, 155 insertions, 83 deletions

diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el
index 97404446c69..25f2c6db6ba 100644
--- a/lisp/international/mule-util.el
+++ b/lisp/international/mule-util.el
@@ -196,51 +196,10 @@ Optional 3rd argument NIL-FOR-TOO-LONG non-nil means return nil
 	(if nil-for-too-long nil i)
       alist)))
 
+
 ;; Coding system related functions.
 
 ;;;###autoload
-(defun coding-system-list (&optional base-only)
-  "Return a list of all existing coding systems.
-If optional arg BASE-ONLY is non-nil, each element of the list
-is a base coding system or a list of coding systems.
-In the latter case, the first element is a base coding system,
-and the remainings are aliases of it."
-  (let (l)
-    (mapatoms (lambda (x) (if (get x 'coding-system) (setq l (cons x l)))))
-    (if (not base-only)
-	l
-      (let* ((codings (sort l (function
-			       (lambda (x y)
-				 (<= (coding-system-mnemonic x)
-				     (coding-system-mnemonic y))))))
-	     (tail (cons nil codings))
-	     (aliases nil)		; ((BASE ALIAS ...) ...)
-	     base coding)
-	;; At first, remove subsidiary coding systems (eol variants) and
-	;; move alias coding systems to ALIASES.
-	(while (cdr tail)
-	  (setq coding (car (cdr tail)))
-	  (if (get coding 'eol-variant)
-	      (setcdr tail (cdr (cdr tail)))
-	    (setq base (coding-system-base coding))
-	    (if (and (not (eq coding base))
-		     (coding-system-equal coding base))
-		(let ((slot (memq base aliases)))
-		  (setcdr tail (cdr (cdr tail)))
-		  (if slot
-		      (setcdr slot (cons coding (cdr slot)))
-		    (setq aliases (cons (list base coding) aliases))))
-	      (setq tail (cdr tail)))))
-	;; Then, replace a coding system who has aliases with a list.
-	(setq tail codings)
-	(while tail
-	  (let ((alias (assq (car tail) aliases)))
-	    (if alias
-		(setcar tail alias)))
-	  (setq tail (cdr tail)))
-	codings))))
-
-;;;###autoload
 (defun coding-system-base (coding-system)
   "Return a base of CODING-SYSTEM.
 The base is a coding system of which coding-system property is a
@@ -251,6 +210,136 @@ coding-spec (see the function `make-coding-system')."
       (coding-system-base coding-spec))))
 
 ;;;###autoload
+(defun coding-system-eol-type-mnemonic (coding-system)
+  "Return mnemonic letter of eol-type of CODING-SYSTEM."
+  (let ((eol-type (coding-system-eol-type coding-system)))
+    (cond ((vectorp eol-type) eol-mnemonic-undecided)
+	  ((eq eol-type 0) eol-mnemonic-unix)
+	  ((eq eol-type 1) eol-mnemonic-unix)
+	  ((eq eol-type 2) eol-mnemonic-unix)
+	  (t ?-))))
+
+;;;###autoload
+(defun coding-system-post-read-conversion (coding-system)
+  "Return post-read-conversion property of CODING-SYSTEM."
+  (and coding-system
+       (symbolp coding-system)
+       (or (get coding-system 'post-read-conversion)
+	   (coding-system-post-read-conversion
+	    (get coding-system 'coding-system)))))
+
+;;;###autoload
+(defun coding-system-pre-write-conversion (coding-system)
+  "Return pre-write-conversion property of CODING-SYSTEM."
+  (and coding-system
+       (symbolp coding-system)
+       (or (get coding-system 'pre-write-conversion)
+	   (coding-system-pre-write-conversion
+	    (get coding-system 'coding-system)))))
+
+;;;###autoload
+(defun coding-system-unification-table (coding-system)
+  "Return unification-table property of CODING-SYSTEM."
+  (and coding-system
+       (symbolp coding-system)
+       (or (get coding-system 'unification-table)
+	   (coding-system-unification-table
+	    (get coding-system 'coding-system)))))
+
+;;;###autoload
+(defun coding-system-parent (coding-system)
+  "Return parent of CODING-SYSTEM."
+  (let ((parent (get coding-system 'parent-coding-system)))
+    (and parent
+	 (or (coding-system-parent parent)
+	     parent))))
+
+(defun coding-system-lessp (x y)
+  (cond ((eq x 'no-conversion) t)
+	((eq y 'no-conversion) nil)
+	((eq x 'emacs-mule) t)
+	((eq y 'emacs-mule) nil)
+	((eq x 'undecided) t)
+	((eq y 'undecided) nil)
+	(t (let ((c1 (coding-system-mnemonic x))
+		 (c2 (coding-system-mnemonic y)))
+	     (or (< (downcase c1) (downcase c2))
+		 (and (not (> (downcase c1) (downcase c2)))
+		      (< c1 c2)))))))
+
+;;;###autoload
+(defun coding-system-list (&optional base-only)
+  "Return a list of all existing coding systems.
+If optional arg BASE-ONLY is non-nil, only base coding systems are listed."
+  (let (l)
+    (mapatoms (lambda (x) (if (get x 'coding-system) (setq l (cons x l)))))
+    (let* ((codings (sort l 'coding-system-lessp))
+	   (tail (cons nil codings))
+	   coding)
+      ;; At first, remove subsidiary coding systems (eol variants) and
+      ;; alias coding systems (if necessary).
+      (while (cdr tail)
+	(setq coding (car (cdr tail)))
+	(if (or (get coding 'eol-variant)
+		(and base-only (coding-system-parent coding)))
+	    (setcdr tail (cdr (cdr tail)))
+	  (setq tail (cdr tail))))
+      codings)))
+
+;;;###autoload
+(defun modify-coding-system-alist (target-type regexp coding-system)
+  "Modify one of look up tables for finding a coding system on I/O operation.
+There are three of such tables, file-coding-system-alist,
+process-coding-system-alist, and network-coding-system-alist.
+
+TARGET-TYPE specifies which of them to modify.
+If it is `file', it affects file-coding-system-alist (which see).
+If it is `process', it affects process-coding-system-alist (which see).
+If it is `network', it affects network-codign-system-alist (which see).
+
+REGEXP is a regular expression matching a target of I/O operation.
+The target is a file name if TARGET-TYPE is `file', a program name if
+TARGET-TYPE is `process', or a network service name or a port number
+to connect to if TARGET-TYPE is `network'.
+
+CODING-SYSTEM is a coding system to perform code conversion on the I/O
+operation, or a cons of coding systems for decoding and encoding
+respectively, or a function symbol which returns the cons."
+  (or (memq target-type '(file process network))
+      (error "Invalid target type: %s" target-type))
+  (or (stringp regexp)
+      (and (eq target-type 'network) (integerp regexp))
+      (error "Invalid regular expression: %s" regexp))
+  (if (symbolp coding-system)
+      (if (not (fboundp coding-system))
+	  (progn
+	    (check-coding-system coding-system)
+	    (setq coding-system (cons coding-system coding-system))))
+    (check-coding-system (car coding-system))
+    (check-coding-system (cdr coding-system)))
+  (cond ((eq target-type 'file)
+	 (let ((slot (assoc regexp file-coding-system-alist)))
+	   (if slot
+	       (setcdr slot coding-system)
+	     (setq file-coding-system-alist
+		   (cons (cons regexp coding-system)
+			 file-coding-system-alist)))))
+	((eq target-type 'process)
+	 (let ((slot (assoc regexp process-coding-system-alist)))
+	   (if slot
+	       (setcdr slot coding-system)
+	     (setq process-coding-system-alist
+		   (cons (cons regexp coding-system)
+			 process-coding-system-alist)))))
+	(t
+	 (let ((slot (assoc regexp network-coding-system-alist)))
+	   (if slot
+	       (setcdr slot coding-system)
+	     (setq network-coding-system-alist
+		   (cons (cons regexp coding-system)
+			 network-coding-system-alist)))))))
+
+;;;###autoload
 (defun coding-system-plist (coding-system)
   "Return property list of CODING-SYSTEM."
   (let ((found nil)
@@ -283,48 +372,33 @@ coding-spec (see the function `make-coding-system')."
 
 ;;;###autoload
 (defun coding-system-equal (coding-system-1 coding-system-2)
-  "Return t if and only of CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical.
+  "Return t if and only if CODING-SYSTEM-1 and CODING-SYSTEM-2 are identical.
 Two coding systems are identical if two symbols are equal
 or one is an alias of the other."
-  (equal (coding-system-plist coding-system-1)
-	 (coding-system-plist coding-system-2)))
+  (or (eq coding-system-1 coding-system-2)
+      (equal (coding-system-plist coding-system-1)
+	     (coding-system-plist coding-system-2))))
 
 ;;;###autoload
-(defun coding-system-eol-type-mnemonic (coding-system)
-  "Return mnemonic letter of eol-type of CODING-SYSTEM."
-  (let ((eol-type (coding-system-eol-type coding-system)))
-    (cond ((vectorp eol-type) eol-mnemonic-undecided)
-	  ((eq eol-type 0) eol-mnemonic-unix)
-	  ((eq eol-type 1) eol-mnemonic-unix)
-	  ((eq eol-type 2) eol-mnemonic-unix)
-	  (t ?-))))
-
-;;;###autoload
-(defun coding-system-post-read-conversion (coding-system)
-  "Return post-read-conversion property of CODING-SYSTEM."
-  (and coding-system
-       (symbolp coding-system)
-       (or (get coding-system 'post-read-conversion)
-	   (coding-system-post-read-conversion
-	    (get coding-system 'coding-system)))))
-
-;;;###autoload
-(defun coding-system-pre-write-conversion (coding-system)
-  "Return pre-write-conversion property of CODING-SYSTEM."
-  (and coding-system
-       (symbolp coding-system)
-       (or (get coding-system 'pre-write-conversion)
-	   (coding-system-pre-write-conversion
-	    (get coding-system 'coding-system)))))
-
-;;;###autoload
-(defun coding-system-unification-table (coding-system)
-  "Return unification-table property of CODING-SYSTEM."
-  (and coding-system
-       (symbolp coding-system)
-       (or (get coding-system 'unification-table)
-	   (coding-system-unification-table
-	    (get coding-system 'coding-system)))))
+(defun prefer-coding-system (coding-system)
+  (interactive "zPrefered coding system: ")
+  (if (not (and coding-system (coding-system-p coding-system)))
+      (error "Invalid coding system `%s'" coding-system))
+  (let ((coding-category (coding-system-category coding-system))
+	(parent (coding-system-parent coding-system)))
+    (if (not coding-category)
+	;; CODING-SYSTEM is no-conversion or undecided.
+	(error "Can't prefer the coding system `%s'" coding-system))
+    (set coding-category (or parent coding-system))
+    (if (not (eq coding-category (car coding-category-list)))
+	;; We must change the order.
+	(setq coding-category-list
+	      (cons coding-category
+		    (delq coding-category coding-category-list))))
+    (if (and parent (interactive-p))
+	(message "Highest priority is set to %s (parent of %s)"
+		 parent coding-system))
+    ))
 
 
 ;;; Composite charcater manipulations.
@@ -410,9 +484,7 @@ overall glyph is updated as follows:
       (format "\240%c" (+ ch 128))
     (let ((str (char-to-string ch)))
       (if (cmpcharp ch)
-	  (if (/= (aref str 1) ?\xFF)
-	      (error "Char %c can't be composed" ch)
-	    (substring str 2))
+	  (substring str (if (= (aref str 1) ?\xFF) 2 1))
 	(aset str 0 (+ (aref str 0) ?\x20))
 	str))))