(build-default-fontset-data): New macro.

(setup-default-fontset): Use build-default-fontset-data for CJK,
tibetan, ethiopic, and ipa

2 files changed, 89 insertions, 27 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 466d5da5c92..c8ac40269f4 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,9 @@
+2009-08-27  Kenichi Handa  <handa@m17n.org>
+
+        * international/fontset.el (build-default-fontset-data): New macro.
+        (setup-default-fontset): Use build-default-fontset-data for CJK,
+        tibetan, ethiopic, and ipa
+
 2009-08-27  Stefan Monnier  <monnier@iro.umontreal.ca>
 
         * cus-start.el (default-major-mode): Customize `major-mode' instead.
diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el
index e2c6491d4af..f9d3c85125a 100644
--- a/lisp/international/fontset.el
+++ b/lisp/international/fontset.el
@@ -308,6 +308,74 @@
 (declare-function set-fontset-font "fontset.c"
                   (name target font-spec &optional frame add))
 
+(eval-when-compile
+
+;; Build a data to initialize the default fontset at compile time to
+;; avoid loading charsets that won't be necessary at runtime.
+
+;; The value is (CJK-REGISTRY-VECTOR TARGET-SPEC ...), where
+;; CJK-REGISTRY-VECTOR is ["JISX0208.1983-0" "GB2312.1980-0" ...],
+;; TARGET-SPEC is (TARGET . BITMASK) or (TARGET SPEC ...),
+;; TARGET is CHAR or (FROM-CHAR . TO-CHAR),
+;; BITMASK is a bitmask of indices to CJK-REGISTRY-VECTOR,
+;; SPEC is a list of arguments to font-spec.
+
+(defmacro build-default-fontset-data ()
+  (let* (;;       CHARSET-REGISTRY  CHARSET            FROM-CODE TO-CODE
+         (cjk '(("JISX0208.1983-0" japanese-jisx0208  #x2121    #x287E)
+                ("GB2312.1980-0"   chinese-gb2312     #x2121    #x297E)
+                ("BIG5-0"          big5               #xA140    #xA3FE)
+                ("CNS11643.1992-1" chinese-cns11643-1 #x2121    #x427E)
+                ("KSC5601.1987-0"  korean-ksc5601     #x2121    #x2C7E)))
+         (scripts '((tibetan
+                     (:registry "iso10646-1" :otf (tibt nil (ccmp blws abvs)))
+                     (:family "mtib" :registry "iso10646-1")
+                     (:registry "muletibetan-2"))
+                    (ethiopic
+                     (:registry "iso10646-1" :script ethiopic)
+                     (:registry "ethiopic-unicode"))
+                    (phonetic
+                     (:registry "iso10646-1" :script phonetic)
+                     (:registry "MuleIPA-1")
+                     (:registry "iso10646-1"))))
+         (cjk-table (make-char-table nil))
+         (script-coverage
+          #'(lambda (script)
+              (let ((coverage))
+                (map-char-table
+                 #'(lambda (range val)
+                     (when (eq val script)
+                       (if (consp range)
+                           (setq range (cons (car range) (cdr range))))
+                       (push range coverage)))
+                 char-script-table)
+                coverage)))
+         (data (list (vconcat (mapcar 'car cjk))))
+         (i 0))
+    (dolist (elt cjk)
+      (let ((mask (lsh 1 i)))
+        (map-charset-chars
+         #'(lambda (range arg)
+             (let ((from (car range)) (to (cdr range)))
+               (if (< to #x110000)
+                   (while (<= from to)
+                     (aset cjk-table from
+                           (logior (or (aref cjk-table from) 0) mask))
+                     (setq from (1+ from))))))
+         (nth 1 elt) nil (nth 2 elt) (nth 3 elt)))
+      (setq i (1+ i)))
+    (map-char-table
+     #'(lambda (range val)
+         (if (consp range)
+             (setq range (cons (car range) (cdr range))))
+         (push (cons range val) data))
+     cjk-table)
+    (dolist (script scripts)
+      (dolist (range (funcall script-coverage (car script)))
+        (push (cons range (cdr script)) data)))
+    `(quote ,(nreverse data))))
+)
+
 (defun setup-default-fontset ()
   "Setup the default fontset."
   (new-fontset
@@ -349,16 +417,6 @@
 
      (tai-viet ("TaiViet" . "iso10646-1"))
 
-     ;; both for script and charset.
-     (tibetan ,(font-spec :registry "iso10646-1"
-                          :otf '(tibt nil (ccmp blws abvs)))
-              ,(font-spec :family "mtib" :registry "iso10646-1")
-              (nil . "muletibetan-2"))
-
-     ;; both for script and charset.
-     (ethiopic ,(font-spec :registry "iso10646-1" :script 'ethiopic)
-               (nil . "ethiopic-unicode"))
-
      (greek ,(font-spec :registry "iso10646-1" :script 'greek)
             (nil . "ISO8859-7"))
 
@@ -461,11 +519,6 @@
      (telugu-akruti (nil . "Telugu-Akruti"))
      (kannada-akruti (nil . "Kannada-Akruti"))
      (malayalam-akruti (nil . "Malayalam-Akruti"))
-     ;;(devanagari-glyph ("altsys-dv_ttsurekh" . "devanagari-cdac"))
-     ;;(malayalam-glyph ("altsys-ml_ttkarthika" . "malayalam-cdac"))
-     (ipa ,(font-spec :registry "iso10646-1" :script 'phonetic)
-          (nil . "MuleIPA-1")
-          (nil . "iso10646-1"))
 
      ;; Fallback fonts
      (nil (nil . "gb2312.1980")
@@ -567,18 +620,21 @@
      (font-spec :registry "iso10646-1" :script (nth 2 math-subgroup))))
 
   ;; Append CJK fonts for characters other than han, kana, cjk-misc.
-  ;;             CHARSET-REGISTRY  CHARSET            FROM-CODE TO-CODE
-  (let ((list '(("JISX0208.1983-0" japanese-jisx0208  #x2121    #x287E)
-                ("GB2312.1980-0"   chinese-gb2312     #x2121    #x297E)
-                ("BIG5-0"          big5               #xA140    #xA3FE)
-                ("CNS11643.1992-1" chinese-cns11643-1 #x2121    #x427E)
-                ("KSC5601.1987-0"  korean-ksc5601     #x2121    #x2C7E))))
-    (dolist (elt list)
-      (map-charset-chars
-       #'(lambda (range arg)
-           (set-fontset-font "fontset-default" range
-                             (cons nil (car elt)) nil 'append))
-       (nth 1 elt) nil (nth 2 elt) (nth 3 elt))))
+  ;; Append fonts for scripts whose name is also a charset name.
+  (let* ((data (build-default-fontset-data))
+         (registries (car data)))
+    (dolist (target-spec (cdr data))
+      (let ((target (car target-spec))
+            (spec (cdr target-spec)))
+        (if (integerp spec)
+            (dotimes (i (length registries))
+              (if (> (logand spec (lsh 1 i)) 0)
+                  (set-fontset-font "fontset-default" target
+                                    (cons nil (aref registries i))
+                                    nil 'append)))
+        (dolist (args spec)
+          (set-fontset-font "fontset-default" target
+                            (apply 'font-spec args) nil 'append))))))
 
   ;; Append Unicode fonts.
   ;; This may find fonts with more variants (bold, italic) but which