(char-ref-p): New function.

[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 b0d07b7..89e99e5 100644 (file)
--- a/lisp/utf-2000/char-db-util.el
+++ b/lisp/utf-2000/char-db-util.el
@@ -71,6 +71,34 @@
        (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A)))
     v))
 
+;;;###autoload
+(defun char-ref-p (obj)
+  (and (consp obj)
+       (keywordp (car obj))))
+
+;;;###autoload
+(defun char-ref= (cr1 cr2)
+  (cond ((char-ref-p cr1)
+        (if (char-ref-p cr2)
+            (char-spec= (plist-get cr1 :char)
+                        (plist-get cr2 :char))
+          (char-spec= (plist-get cr1 :char) cr2)))
+       (t
+        (char-spec= cr1
+                    (if (char-ref-p cr2)
+                        (plist-get cr2 :char)
+                      cr2)))))
+
+;;;###autoload
+(defun char-spec= (cs1 cs2)
+  (if (characterp cs1)
+      (if (characterp cs2)
+         (eq cs1 cs2)
+       (eq cs1 (find-char cs2)))
+    (if (characterp cs2)
+       (eq (find-char cs1) cs2)
+      (eq (find-char cs1) (find-char cs2)))))
+
 (defun char-attribute-name< (ka kb)
   (cond
    ((find-charset ka)
@@ -116,6 +144,28 @@
    ((symbolp kb)
     nil)))
 
+(defvar char-db-coded-charset-priority-list
+  (let ((rest default-coded-charset-priority-list)
+       dest)
+    (while rest
+      (when (symbolp (car rest))
+       (cond ((memq (car rest)
+                    '(latin-viscii-lower
+                      latin-viscii-upper
+                      ipa
+                      lao
+                      ethiopic
+                      arabic-digit
+                      arabic-1-column
+                      arabic-2-column)))
+             ((string-match "^ideograph-gt-pj-" (symbol-name (car rest)))
+              (unless (memq 'ideograph-gt dest)
+                (setq dest (cons 'ideograph-gt dest))))
+             (t
+              (setq dest (cons (car rest) dest)))))
+      (setq rest (cdr rest)))
+    (sort dest #'char-attribute-name<)))
+
 (defun char-db-insert-char-spec (char &optional readable column)
   (unless column
     (setq column (current-column)))
@@ -127,13 +177,18 @@
                  (if (setq ret (get-char-attribute char 'name))
                      (setq char-spec (cons (cons 'name ret) char-spec)))
                  )
-                ((setq ret (split-char char))
+                ((setq ret
+                       (let ((default-coded-charset-priority-list
+                               char-db-coded-charset-priority-list))
+                         (split-char char)))
                  (setq char-spec (list ret))
                  (dolist (ccs (delq (car ret) (charset-list)))
                    (if (or (and (>= (charset-iso-final-char ccs) ?0)
                                 (setq ret (get-char-attribute char ccs)))
                            (eq ccs 'ideograph-daikanwa))
                        (setq char-spec (cons (cons ccs ret) char-spec))))
+                 (if (null char-spec)
+                     (setq char-spec (split-char char)))
                  (if (setq ret (get-char-attribute char 'name))
                      (setq char-spec (cons (cons 'name ret) char-spec)))
                  )))
@@ -579,6 +634,24 @@
                      line-breaking))
       (setq attributes (delq '->mojikyo attributes))
       )
+    (when (and (memq 'hanyu-dazidian-vol attributes)
+              (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
+      (insert (format "(hanyu-dazidian-vol  . %d)%s"
+                     value line-breaking))
+      (setq attributes (delq 'hanyu-dazidian-vol attributes))
+      )
+    (when (and (memq 'hanyu-dazidian-page attributes)
+              (setq value (get-char-attribute char 'hanyu-dazidian-page)))
+      (insert (format "(hanyu-dazidian-page . %d)%s"
+                     value line-breaking))
+      (setq attributes (delq 'hanyu-dazidian-page attributes))
+      )
+    (when (and (memq 'hanyu-dazidian-char attributes)
+              (setq value (get-char-attribute char 'hanyu-dazidian-char)))
+      (insert (format "(hanyu-dazidian-char . %d)%s"
+                     value line-breaking))
+      (setq attributes (delq 'hanyu-dazidian-char attributes))
+      )
     (setq rest ccs-attributes)
     (while (and rest
                (progn
@@ -601,6 +674,7 @@
                ((memq name '(->lowercase
                              ->uppercase ->titlecase
                              ->fullwidth <-fullwidth
+                             ->identical
                              ->vulgar-ideograph <-vulgar-ideograph
                              ->ancient-ideograph <-ancient-ideograph
                              ->original-ideograph <-original-ideograph
@@ -727,7 +801,8 @@
               (setq value (get-char-attribute char name)))
          (insert
           (format
-           (cond ((memq name '(ideograph-daikanwa ideograph-gt))
+           (cond ((memq name '(ideograph-daikanwa ideograph-gt
+                                                  ideograph-cbeta))
                   (if has-long-ccs-name
                       "(%-26s . %05d)\t; %c%s"
                     "(%-18s . %05d)\t; %c%s"))
@@ -867,6 +942,9 @@
     (condition-case err
        (progn
          (insert-char-data-with-variant char 'printable)
+         (unless (char-attribute-alist char)
+           (insert (format ";; = %c\n"
+                           (apply #'make-char (split-char char)))))
           ;; (char-db-update-comment)
          (set-buffer-modified-p nil)
          (view-mode the-buf (lambda (buf)