update.

[chise/xemacs-chise.git.1] / lisp / utf-2000 / chise-subr.el

diff --git a/lisp/utf-2000/chise-subr.el b/lisp/utf-2000/chise-subr.el
index c62e042..c6e968c 100644 (file)
--- a/lisp/utf-2000/chise-subr.el
+++ b/lisp/utf-2000/chise-subr.el
@@ -1,7 +1,7 @@
 ;;; chise-subr.el --- basic lisp subroutines for XEmacs CHISE
 
 ;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009,
-;;   2010, 2011, 2012 MORIOKA Tomohiko.
+;;   2010, 2011, 2012, 2013, 2014, 2015 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
@@ -38,10 +38,30 @@
   ;;           (unless (memq domain dest)
   ;;             (push domain dest))))))
   ;;   (sort dest #'string<))
-  '(ucs ucs/compat daikanwa cns gt jis jis/alt jis/a jis/b
+  '(ucs ucs/compat daikanwa cns gt jis jis/a jis/b
        jis-x0212 jis-x0213 cdp shinjigen
        r030 r140 misc unknown))
 
+(defconst charset-id-=adobe-japan1-0 (charset-id '=adobe-japan1-0))
+(defconst charset-id-=adobe-japan1-6 (charset-id '=adobe-japan1-6))
+(defconst charset-id-==adobe-japan1-0 (charset-id '==adobe-japan1-0))
+(defconst charset-id-==adobe-japan1-6 (charset-id '==adobe-japan1-6))
+;; (defconst charset-id-=>>>adobe-japan1-0 (charset-id '=>>>adobe-japan1-0))
+;; (defconst charset-id-=>>>adobe-japan1-6 (charset-id '=>>>adobe-japan1-6))
+(defconst charset-id-=>>adobe-japan1-0 (charset-id '=>>adobe-japan1-0))
+(defconst charset-id-=>>adobe-japan1-6 (charset-id '=>>adobe-japan1-6))
+
+(defun charset-id-adobe-japan1-p (id)
+  (or (and (<= charset-id-=adobe-japan1-0 id)
+          (<= id charset-id-=adobe-japan1-6))
+      (and (<= charset-id-==adobe-japan1-0 id)
+          (<= id charset-id-==adobe-japan1-6))
+      ;; (and (<= charset-id-=>>>adobe-japan1-0 id)
+      ;;      (<= id charset-id-=>>>adobe-japan1-6))
+      (and (<= charset-id-=>>adobe-japan1-0 id)
+          (<= id charset-id-=>>adobe-japan1-6))
+      ))
+
 
 ;;; @ feature name
 ;;;
@@ -56,6 +76,17 @@
 (defun char-attribute-name< (ka kb)
   "Return t if symbol KA is less than KB in feature-name sorting order."
   (cond
+   ((and (symbolp ka)
+        (eq (aref (symbol-name ka) 0) ?*))
+    (cond ((and (symbolp kb)
+               (eq (aref (symbol-name kb) 0) ?*))
+          (string< (symbol-name ka)
+                   (symbol-name kb))
+          ))
+    )
+   ((and (symbolp kb)
+        (eq (aref (symbol-name kb) 0) ?*))
+    t)
    ((eq '->denotational kb)
     t)
    ((eq '->subsumptive kb)
@@ -93,7 +124,7 @@
     )
    ((find-charset ka)
     (if (find-charset kb)
-       (let (a-ir b-ir)
+       (let (a-ir b-ir a-id b-id)
          (if (setq a-ir (charset-property ka 'iso-ir))
              (if (setq b-ir (charset-property kb 'iso-ir))
                  (cond
@@ -107,10 +138,66 @@
                   ((< a-ir
                       b-ir)
                    ))
+               (cond
+                ((= a-ir 177)
+                 t)
+                ((eq kb '=mj)
+                 nil)
+                ((eq kb '==mj)
+                 nil)
+                ((eq kb '=>>mj)
+                 nil)
+                ((and (setq b-id (charset-id kb))
+                      (charset-id-adobe-japan1-p b-id))
+                 nil)
+                (t)))
+           (if (setq b-ir (charset-property kb 'iso-ir))
+               (cond
+                ((= b-ir 177)
+                 nil)
+                ((eq ka '=mj)
+                 t)
+                ((eq ka '==mj)
+                 t)
+                ((eq ka '=>>mj)
+                 t)
+                ((and (setq a-id (charset-id ka))
+                      (charset-id-adobe-japan1-p a-id))
+                 t)
+                (t nil))
+             (cond
+              ((eq ka '=mj)
+               t)
+              ((eq ka '==mj)
+               t)
+              ((eq ka '=>>mj)
                t)
-           (if (charset-property kb 'iso-ir)
-               nil
-             (< (charset-id ka)(charset-id kb)))))
+              ((and (setq a-id (charset-id ka))
+                    (charset-id-adobe-japan1-p a-id))
+               (cond
+                ((eq kb '=mj)
+                 nil)
+                ((eq kb '==mj)
+                 nil)
+                ((eq kb '=>>mj)
+                 nil)
+                ((and (setq b-id (charset-id kb))
+                      (charset-id-adobe-japan1-p b-id))
+                 (< a-id b-id))
+                (t))
+               )
+              ((eq kb '=mj)
+               nil)
+              ((eq kb '==mj)
+               nil)
+              ((eq kb '=>>mj)
+               nil)
+              ((and (setq b-id (charset-id kb))
+                    (charset-id-adobe-japan1-p b-id))
+               nil)
+              (t
+               (< (charset-id ka)(charset-id kb))
+               )))))
       nil)
     )
    ((find-charset kb))
@@ -130,6 +217,7 @@
 (defun char-ucs (char)
   "Return code-point of UCS."
   (or (encode-char char '=ucs 'defined-only)
+      (char-feature char '=ucs)
       (char-feature char '=>ucs)))
 
 ;;;###autoload