(set-coding-system-alist): Deleted.

(string-to-sequence): Doc string modified.
(coding-system-list): Add optional arg BASE-ONLY.
(coding-system-base): New function.
(coding-system-plist): New function.
(coding-system-equal): New function.
(coding-system-unification-table): New function.

1 files changed, 125 insertions, 61 deletions

diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el
index 2cd442c47b6..97404446c69 100644
--- a/lisp/international/mule-util.el
+++ b/lisp/international/mule-util.el
@@ -30,8 +30,7 @@
 ;;;###autoload
 (defun string-to-sequence (string type)
   "Convert STRING to a sequence of TYPE which contains characters in STRING.
-TYPE should be `list' or `vector'.
-Multibyte characters are conserned."
+TYPE should be `list' or `vector'."
   (or (eq type 'list) (eq type 'vector)
       (error "Invalid type: %s" type))
   (let* ((len (length string))
@@ -200,67 +199,132 @@ Optional 3rd argument NIL-FOR-TOO-LONG non-nil means return nil
 ;; Coding system related functions.
 
 ;;;###autoload
-(defun set-coding-system-alist (target-type regexp coding-system
-					    &optional operation)
-  "Update `coding-system-alist' according to the arguments.
-TARGET-TYPE specifies a type of the target: `file', `process', or `network'.
-  TARGET-TYPE tells which slots of coding-system-alist should be affected.
-  If `file', it affects slots for insert-file-contents and write-region.
-  If `process', it affects slots for call-process, call-process-region, and
-    start-process.
-  If `network', it affects a slot for open-network-process.
-REGEXP is a regular expression matching a target of I/O operation.
-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.
-Optional arg OPERATION if non-nil specifies directly one of slots above.
-  The valid value is: insert-file-contents, write-region,
-  call-process, call-process-region, start-process, or open-network-stream.
-If OPERATION is specified, TARGET-TYPE is ignored.
-See the documentation of `coding-system-alist' for more detail."
-  (or (stringp regexp)
-      (error "Invalid regular expression: %s" regexp))
-  (or (memq target-type '(file process network))
-      (error "Invalid target type: %s" target-type))
-  (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)))
-  (let ((op-list (if operation (list operation)
-		   (cond ((eq target-type 'file)
-			  '(insert-file-contents write-region))
-			 ((eq target-type 'process)
-			  '(call-process call-process-region start-process))
-			 (t		; i.e. (eq target-type network)
-			  '(open-network-stream)))))
-	slot)
-    (while op-list
-      (setq slot (assq (car op-list) coding-system-alist))
-      (if slot
-	  (let ((chain (cdr slot)))
-	    (if (catch 'tag
-		  (while chain
-		    (if (string= regexp (car (car chain)))
-			(progn
-			  (setcdr (car chain) coding-system)
-			  (throw 'tag nil)))
-		    (setq chain (cdr chain)))
-		  t)
-	      (setcdr slot (cons (cons regexp coding-system) (cdr slot)))))
-	(setq coding-system-alist
-	      (cons (cons (car op-list) (list (cons regexp coding-system)))
-		    coding-system-alist)))
-      (setq op-list (cdr op-list)))))
-
-;;;###autoload
-(defun coding-system-list ()
-  "Return a list of all existing coding systems."
+(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)))))
-    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
+coding-spec (see the function `make-coding-system')."
+  (let ((coding-spec (get coding-system 'coding-system)))
+    (if (vectorp coding-spec)
+	coding-system
+      (coding-system-base coding-spec))))
+
+;;;###autoload
+(defun coding-system-plist (coding-system)
+  "Return property list of CODING-SYSTEM."
+  (let ((found nil)
+	coding-spec eol-type
+	post-read-conversion pre-write-conversion
+	unification-table)
+    (while (not found)
+      (or eol-type
+	  (setq eol-type (get coding-system 'eol-type)))
+      (or post-read-conversion
+	  (setq post-read-conversion
+		(get coding-system 'post-read-conversion)))
+      (or pre-write-conversion
+	  (setq pre-write-conversion
+		(get coding-system 'pre-write-conversion)))
+      (or unification-table
+	  (setq unification-table
+		(get coding-system 'unification-table)))
+      (setq coding-spec (get coding-system 'coding-system))
+      (if (and coding-spec (symbolp coding-spec))
+	  (setq coding-system coding-spec)
+	(setq found t)))
+    (if (not coding-spec)
+	(error "Invalid coding system: %s" coding-system))
+    (list 'coding-spec coding-spec
+	  'eol-type eol-type
+	  'post-read-conversion post-read-conversion
+	  'pre-write-conversion pre-write-conversion
+	  'unification-table unification-table)))
+
+;;;###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.
+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)))
+
+;;;###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)))))
 
 
 ;;; Composite charcater manipulations.