From: Kenichi Handa <handa@m17n.org>
Date: Thu, 5 Jun 2003 23:18:23 +0000 (+0000)
Subject: (set-coding-priority): Re-written.
X-Git-Tag: emacs-pretest-23.0.90~8295^2~1864^2~13
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=5d75f46fcaeca06eadbce0c7719ad490511ef5c9;p=emacs.git

(set-coding-priority): Re-written.
(make-translation-table): Re-written.
---

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 3366d023a09..1163222dbbb 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,8 @@
+2003-06-06  Kenichi Handa  <handa@m17n.org>
+
+	* international/mule.el (set-coding-priority): Re-written.
+	(make-translation-table): Re-written.
+
 2003-06-05  Kenichi Handa  <handa@m17n.org>
 
 	* font-lock.el
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 5d6f481f556..687a58b94ac 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -615,7 +615,6 @@ encoding.  This attribute has a meaning only when `:coding-type' is
 				   ((eq coding-type 'utf-16)
 				    '(:bom
 				      :endian))
-				   ;; Fixme: CCL definition is broken.
 				   ((eq coding-type 'ccl)
 				    '(:ccl-decoder
 				      :ccl-encoder
@@ -928,28 +927,14 @@ This setting is effective for the next communication only."
 
   (setq next-selection-coding-system coding-system))
 
-;; Fixme: Should this just go?
 (defun set-coding-priority (arg)
   "Set priority of coding categories according to ARG.
 ARG is a list of coding categories ordered by priority.
 
 This function is provided for backward compatibility.
 Now we have more convenient function `set-coding-system-priority'."
-  (let ((l arg)
-	(current-list (copy-sequence coding-category-list)))
-    ;; Check the validity of ARG while deleting coding categories in
-    ;; ARG from CURRENT-LIST.  We assume that CODING-CATEGORY-LIST
-    ;; contains all coding categories.
-    (while l
-      (if (or (null (get (car l) 'coding-category-index))
-	      (null (memq (car l) current-list)))
-	  (error "Invalid or duplicated element in argument: %s" arg))
-      (setq current-list (delq (car l) current-list))
-      (setq l (cdr l)))
-    ;; Update `coding-category-list' and return it.
-    (setq coding-category-list (append arg current-list))
-    ;; Fixme: not defined.
-    (set-coding-priority-internal)))
+  (apply 'set-coding-system-priority
+	 (mapcar #'(lambda (x) (symbol-value x)) arg)))
 (make-obsolete 'set-coding-priority 'set-coding-system-priority "22.1")
 
 ;;; X selections
@@ -1418,48 +1403,31 @@ order, and if a previous form already translates TO to some other
 character, say TO-ALT, FROM is also translated to TO-ALT."
   (let ((table (make-char-table 'translation-table))
 	revlist)
-    (while args
-      (let ((elts (car args)))
-	(while elts
-	  (let* ((from (car (car elts)))
-		 (from-i 0)		; degree of freedom of FROM
-		 (from-rev (nreverse (split-char from)))
-		 (to (cdr (car elts)))
-		 (to-i 0)		; degree of freedom of TO
-		 (to-rev (nreverse (split-char to))))
-	    ;; Check numbers of heading 0s in FROM-REV and TO-REV.
-	    (while (eq (car from-rev) 0)
-	      (setq from-i (1+ from-i) from-rev (cdr from-rev)))
-	    (while (eq (car to-rev) 0)
-	      (setq to-i (1+ to-i) to-rev (cdr to-rev)))
-	    (if (and (/= from-i to-i) (/= to-i 0))
-		(error "Invalid character pair (%d . %d)" from to))
-	    ;; If we have already translated TO to TO-ALT, FROM should
-	    ;; also be translated to TO-ALT.
-	    (let ((to-alt (aref table to)))
-	      (if (and to-alt (> to-i 0))
-		  (setq to to-alt)))
-	    ;; Fixme: set-char-table-default is now a no-op.
-	    (if (> from-i 0)
-		(set-char-table-default table from to)
-	      (aset table from to))
-	    ;; If we have already translated some chars to FROM, they
-	    ;; should also be translated to TO.
-	    (let ((l (assq from revlist)))
-	      (if l
-		  (let ((ch (car l)))
-		    (setcar l to)
-		    (setq l (cdr l))
-		    (while l
-		      (aset table ch to)
-		      (setq l (cdr l)) ))))
-	    ;; Now update REVLIST.
-	    (let ((l (assq to revlist)))
-	      (if l
-		  (setcdr l (cons from (cdr l)))
-		(setq revlist (cons (list to from) revlist)))))
-	  (setq elts (cdr elts))))
-      (setq args (cdr args)))
+    (dolist (elts args)
+      (dolist (elt elts)
+	(let ((from (car elt))
+	      (to (cdr elt))
+	      to-alt rev-from rev-to)
+	  ;; If we have already translated TO to TO-ALT, FROM should
+	  ;; also be translated to TO-ALT.
+	  (if (setq to-alt (aref table to))
+	      (setq to to-alt))
+	  (aset table from to)
+	  ;; If we have already translated some chars to FROM, they
+	  ;; should also be translated to TO.
+	  (when (setq rev-from (assq from revlist))
+	    (dolist (elt (cdr rev-from))
+	      (aset table elt to))
+	    (setq revlist (delq rev-from revlist)
+		  rev-from (cdr rev-from)))
+	  ;; Now update REVLIST.
+	  (setq rev-to (assq to revlist))
+	  (if rev-to
+	      (setcdr rev-to (cons from (cdr rev-to)))
+	    (setq rev-to (list to from)
+		  revlist (cons rev-to revlist)))
+	  (if rev-from
+	      (setcdr rev-to (append rev-from (cdr rev-to)))))))
     ;; Return TABLE just created.
     table))