(=ucs@gb/fw): New coded-charset for XEmacs CHISE.

[chise/xemacs-chise.git-] / lisp / utf-2000 / char-db-util.el

diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el
index f427369..19d49ad 100644 (file)
--- a/lisp/utf-2000/char-db-util.el
+++ b/lisp/utf-2000/char-db-util.el
@@ -621,19 +621,18 @@
       )
     (let (key)
       (dolist (domain
-              ;; char-db-feature-domains
-              (let* ((dest char-db-feature-domains)
-                     (dlast (last dest))
-                     domain)
-                (dolist (feature (char-attribute-list))
-                  (setq feature (symbol-name feature))
-                  (when (string-match
-                         "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
-                         feature)
-                    (setq domain (intern (match-string 2 feature)))
+              (append
+               char-db-feature-domains
+               (let (dest domain)
+                 (dolist (feature (char-attribute-list))
+                   (setq feature (symbol-name feature))
+                   (when (string-match
+                          "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
+                          feature)
+                     (setq domain (intern (match-string 2 feature)))
                     (unless (memq domain dest)
-                      (setcdr dlast (setq dlast (list domain))))))
-                dest))
+                      (setq dest (cons domain dest)))))
+                 (sort dest #'string<))))
        (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
        (when (and (memq key attributes)
                   (setq value (get-char-attribute char key)))
@@ -1111,20 +1110,26 @@
                      (let ((ucs (get-char-attribute char '->ucs)))
                        (if ucs
                            (delete char (char-variants (int-char ucs)))))))
-       variant vs)
+       variant vs ret)
     (setq variants (sort variants #'<))
     (while variants
       (setq variant (car variants))
-      (if (and (or (null script)
-                  (null (setq vs (get-char-attribute variant 'script)))
-                  (memq script vs))
-              (or (null excluded-script)
-                  (null (setq vs (get-char-attribute variant 'script)))
-                  (not (memq excluded-script vs))))
-         (or (and no-ucs-unified (get-char-attribute variant '=ucs))
-             (insert-char-data variant printable)))
-      (setq variants (cdr variants))
-      )))
+      (unless (get-char-attribute variant '<-subsumptive)
+       (if (and (or (null script)
+                    (null (setq vs (get-char-attribute variant 'script)))
+                    (memq script vs))
+                (or (null excluded-script)
+                    (null (setq vs (get-char-attribute variant 'script)))
+                    (not (memq excluded-script vs))))
+           (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
+             (insert-char-data variant printable)
+             (if (setq ret (char-variants variant))
+                 (while ret
+                   (or (memq (car ret) variants)
+                        ;; (get-char-attribute (car ret) '<-subsumptive)
+                       (setq variants (append variants (list (car ret)))))
+                   (setq ret (cdr ret)))))))
+      (setq variants (cdr variants)))))
 
 (defun insert-char-range-data (min max &optional script excluded-script)
   (let ((code min)