[Emacs-diffs] emacs/lisp/international mule-cmds.el

[Kenichi Handa]

CVSROOT:        /cvsroot/emacs
Module name:    emacs
Changes by:     Kenichi Handa <handa>   09/12/09 00:55:55

Modified files:
        lisp/international: mule-cmds.el 

Log message:
        (ucs-names): Supply a sufficiently fine ranges instead of
        pre-calculating accurate ranges.  Iterate with bigger
        gc-cons-threshold.

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/international/mule-cmds.el?cvsroot=emacs&r1=1.385&r2=1.386

Patches:
Index: mule-cmds.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/international/mule-cmds.el,v
retrieving revision 1.385
retrieving revision 1.386
diff -u -b -r1.385 -r1.386
--- mule-cmds.el        7 Dec 2009 16:53:48 -0000       1.385
+++ mule-cmds.el        9 Dec 2009 00:55:55 -0000       1.386
@@ -2889,47 +2889,38 @@
 (defun ucs-names ()
   "Return alist of (CHAR-NAME . CHAR-CODE) pairs cached in `ucs-names'."
   (or ucs-names
-      (let ((ranges
-             (purecopy
-              ;; We precompute at compile-time the ranges of chars
-              ;; that have names, so that at runtime, building the
-              ;; table can be done faster, since most of the time is
-              ;; spent looking for the chars that do have a name.
-              (eval-when-compile
-                (let ((ranges ())
-                      (first 0)
-                      (last 0))
-                  (dotimes-with-progress-reporter (c #xEFFFF)
-                      "Finding Unicode characters with names..."
-                    (unless (or
-                             ;; CJK Ideograph Extension Arch
-                             (and (>= c #x3400 ) (<= c #x4dbf ))
-                             ;; CJK Ideograph
-                             (and (>= c #x4e00 ) (<= c #x9fff ))
-                             ;; Private/Surrogate
-                             (and (>= c #xd800 ) (<= c #xfaff ))
-                             ;; CJK Ideograph Extensions B, C
-                             (and (>= c #x20000) (<= c #x2ffff))
-                             (null (get-char-code-property c 'name)))
-                      ;; This char has a name.
-                      (if (<= c (1+ last))
-                          ;; Extend the current range.
-                          (setq last c)
-                        ;; We have to split the range.
-                        (push (cons first last) ranges)
-                        (setq first (setq last c)))))
-                  (cons (cons first last) ranges)))))
-            name names)
-        (dolist (range ranges)
-          (let ((c (car range))
-                (end (cdr range)))
+      (let ((bmp-ranges
+            '((#x0000 . #x33FF)
+              ;; (#x3400 . #x4DBF) CJK Ideograph Extension A
+              (#x4DC0 . #x4DFF)
+              ;; (#x4E00 . #x9FFF) CJK Ideograph
+              (#xA000 . #x0D7FF)
+              ;; (#xD800 . #xFAFF) Surrogate/Private
+              (#xFB00 . #xFFFD)))
+           (upper-ranges
+            '((#x10000 . #x134FF)
+              ;; (#x13500 . #x1CFFF) unsed
+              (#x1D000 . #x1FFFF)
+              ;; (#x20000 . #xDFFFF) CJK Ideograph Extension A, B, etc, unsed
+              (#xE0000 . #xE01FF)))
+           (gc-cons-threshold 10000000)
+           c end name names)
+        (dolist (range bmp-ranges)
+          (setq c (car range)
+                end (cdr range))
             (while (<= c end)
               (if (setq name (get-char-code-property c 'name))
-                  (push (cons name c) names)
-                (error "Wrong range"))
+               (push (cons name c) names))
               (if (setq name (get-char-code-property c 'old-name))
                   (push (cons name c) names))
-              (setq c (1+ c)))))
+           (setq c (1+ c))))
+        (dolist (range upper-ranges)
+          (setq c (car range)
+                end (cdr range))
+         (while (<= c end)
+           (if (setq name (get-char-code-property c 'name))
+               (push (cons name c) names))
+           (setq c (1+ c))))
         (setq ucs-names names))))
 
 (defvar ucs-completions (lazy-completion-table ucs-completions ucs-names)