code.delx.au - gnu-emacs/blob - admin/unidata/unidata-gen.el

   1 ;; unidata-gen.el -- Create files containing character property data.
   2
   3 ;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
   4
   5 ;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011
   6 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
   7 ;;   Registration Number H13PRO009
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; SPECIAL NOTICE
  27 ;;
  28 ;;   This file must be byte-compilable/loadable by `temacs' and also
  29 ;;   the entry function `unidata-gen-files' must be runnable by `temacs'.
  30
  31 ;; FILES TO BE GENERATED
  32 ;;
  33 ;;   The entry function `unidata-gen-files' generates these files in
  34 ;;   in directory specified by its dest-dir argument.
  35 ;;
  36 ;;   charprop.el
  37 ;;      It contains a series of forms of this format:
  38 ;;        (define-char-code-property PROP FILE)
  39 ;;      where PROP is a symbol representing a character property
  40 ;;      (name, general-category, etc), and FILE is a name of one of
  41 ;;      the following files.
  42 ;;
  43 ;;   uni-name.el, uni-category.el, uni-combining.el, uni-bidi.el,
  44 ;;   uni-decomposition.el, uni-decimal.el, uni-digit.el, uni-numeric.el,
  45 ;;   uni-mirrored.el, uni-old-name.el, uni-comment.el, uni-uppercase.el,
  46 ;;   uni-lowercase.el, uni-titlecase.el
  47 ;;      They contain one or more forms of this format:
  48 ;;        (define-char-code-property PROP CHAR-TABLE)
  49 ;;      where PROP is the same as above, and CHAR-TABLE is a
  50 ;;      char-table containing property values in a compressed format.
  51 ;;
  52 ;;   When they are installed in .../lisp/international/, the file
  53 ;;   "charprop.el" is preloaded in loadup.el.  The other files are
  54 ;;   automatically loaded when the Lisp functions
  55 ;;   `get-char-code-property' and `put-char-code-property', and C
  56 ;;   function uniprop_table are called.
  57 ;;
  58 ;; FORMAT OF A CHAR TABLE
  59 ;;
  60 ;;   We want to make a file size containing a char-table small.  We
  61 ;;   also want to load the file and get a property value fast.  We
  62 ;;   also want to reduce the used memory after loading it.  So,
  63 ;;   instead of naively storing a property value for each character in
  64 ;;   a char-table (and write it out into a file), we store compressed
  65 ;;   data in a char-table as below.
  66 ;;
  67 ;;   If succeeding 128*N characters have the same property value, we
  68 ;;   store that value (or the encoded one) for them.  Otherwise,
  69 ;;   compress values (or the encoded ones) for succeeding 128
  70 ;;   characters into a single string and store it for those
  71 ;;   characters.  The way of compression depends on a property.  See
  72 ;;   the section "SIMPLE TABLE", "RUN-LENGTH TABLE", and "WORD-LIST
  73 ;;   TABLE".
  74
  75 ;;   The char table has five extra slots:
  76 ;;      1st: property symbol
  77 ;;      2nd: function to call to get a property value,
  78 ;;           or an index number of C function to decode the value,
  79 ;;           or nil if the value can be directly got from the table.
  80 ;;      3nd: function to call to put a property value,
  81 ;;           or an index number of C function to encode the value,
  82 ;;           or nil if the value can be directly stored in the table.
  83 ;;      4th: function to call to get a description of a property value, or nil
  84 ;;      5th: data referred by the above functions
  85
  86 ;; List of elements of this form:
  87 ;;   (CHAR-or-RANGE PROP1 PROP2 ... PROPn)
  88 ;; CHAR-or-RANGE: a character code or a cons of character codes
  89 ;; PROPn: string representing the nth property value
  90
  91 (eval-when-compile (require 'cl-lib))
  92
  93 (defvar unidata-list nil)
  94
  95 ;; Name of the directory containing files of Unicode Character Database.
  96
  97 ;; Dynamically bound in unidata-gen-files.
  98 (defvar unidata-dir nil)
  99
 100 (defun unidata-setup-list (unidata-text-file)
 101   (let* ((table (list nil))
 102          (tail table)
 103          (block-names '(("^<CJK Ideograph" . CJK\ IDEOGRAPH)
 104                         ("^<Tangut Ideograph" . TANGUT\ IDEOGRAPH)
 105                         ("^<Hangul Syllable" . HANGUL\ SYLLABLE)
 106                         ("^<.*High Surrogate" . HIGH\ SURROGATE)
 107                         ("^<.*Low Surrogate" . LOW\ SURROGATE)
 108                         ("^<.*Private Use" . PRIVATE\ USE)))
 109          val char name)
 110     (setq unidata-text-file (expand-file-name unidata-text-file unidata-dir))
 111     (or (file-readable-p unidata-text-file)
 112         (error "File not readable: %s" unidata-text-file))
 113     (with-temp-buffer
 114       ;; Insert a file of this format:
 115       ;;   (CHAR NAME CATEGORY ...)
 116       ;; where CHAR is a character code, the following elements are strings
 117       ;; representing character properties.
 118       (insert-file-contents unidata-text-file)
 119       (goto-char (point-min))
 120       (condition-case nil
 121           (while t
 122             (setq val (read (current-buffer))
 123                   char (car val)
 124                   name (cadr val))
 125
 126             ;; Check this kind of block.
 127             ;;   4E00;<CJK Ideograph, First>;Lo;0;L;;;;;N;;;;;
 128             ;;   9FCB;<CJK Ideograph, Last>;Lo;0;L;;;;;N;;;;;
 129             (if (and (= (aref name 0) ?<)
 130                      (string-match ", First>$" name))
 131                 (let ((first char)
 132                       (l block-names)
 133                       block-name)
 134                   (setq val (read (current-buffer))
 135                         char (car val)
 136                         block-name (cadr val)
 137                         name nil)
 138                   (while l
 139                     (if (string-match (caar l) block-name)
 140                         (setq name (cdar l) l nil)
 141                       (setq l (cdr l))))
 142                   (setcar val (cons first char))
 143                   (setcar (cdr val) name)))
 144
 145             (when val
 146               (setcdr tail (list val))
 147               (setq tail (cdr tail))))
 148         (error nil)))
 149     (setq unidata-list (cdr table))))
 150
 151 ;; Alist of this form:
 152 ;;   (PROP INDEX GENERATOR FILENAME DOCSTRING DESCRIBER DEFAULT VAL-LIST)
 153 ;; PROP: character property
 154 ;; INDEX: index to each element of unidata-list for PROP.
 155 ;;   It may be a function that generates an alist of character codes
 156 ;;   vs. the corresponding property values.  Currently, only character
 157 ;;   codepoints or symbol values are supported in this case.
 158 ;; GENERATOR: function to generate a char-table
 159 ;; FILENAME: filename to store the char-table
 160 ;; DOCSTRING: docstring for the property
 161 ;; DESCRIBER: function to call to get a description string of property value
 162 ;; DEFAULT: the default value of the property.  It may have the form
 163 ;;   (VAL0 (FROM1 TO1 VAL1) ...) which indicates that the default
 164 ;;   value is VAL0 except for characters in the ranges specified by
 165 ;;   FROMn and TOn (inclusive).  The default value of characters
 166 ;;   between FROMn and TOn is VALn.
 167 ;; VAL-LIST: list of specially ordered property values
 168
 169 (defconst unidata-prop-alist
 170   '((name
 171      1 unidata-gen-table-name "uni-name.el"
 172      "Unicode character name.
 173 Property value is a string or nil.
 174 The value nil stands for the default value \"null string\")."
 175      nil
 176      nil)
 177     (general-category
 178      2 unidata-gen-table-symbol "uni-category.el"
 179      "Unicode general category.
 180 Property value is one of the following symbols:
 181   Lu, Ll, Lt, Lm, Lo, Mn, Mc, Me, Nd, Nl, No, Pc, Pd, Ps, Pe, Pi, Pf, Po,
 182   Sm, Sc, Sk, So, Zs, Zl, Zp, Cc, Cf, Cs, Co, Cn"
 183      unidata-describe-general-category
 184      Cn
 185      ;; The order of elements must be in sync with unicode_category_t
 186      ;; in src/character.h.
 187      (Lu Ll Lt Lm Lo Mn Mc Me Nd Nl No Pc Pd Ps Pe Pi Pf Po
 188          Sm Sc Sk So Zs Zl Zp Cc Cf Cs Co Cn))
 189     (canonical-combining-class
 190      3 unidata-gen-table-integer "uni-combining.el"
 191      "Unicode canonical combining class.
 192 Property value is an integer."
 193      unidata-describe-canonical-combining-class
 194      0)
 195     (bidi-class
 196      4 unidata-gen-table-symbol "uni-bidi.el"
 197      "Unicode bidi class.
 198 Property value is one of the following symbols:
 199   L, LRE, LRO, LRI, R, AL, RLE, RLO, RLI, FSI, PDF, PDI,
 200   EN, ES, ET, AN, CS, NSM, BN, B, S, WS, ON"
 201      unidata-describe-bidi-class
 202      ;; The assignment of default values to blocks of code points
 203      ;; follows the file DerivedBidiClass.txt from the Unicode
 204      ;; Character Database (UCD).
 205      (L (#x0600 #x06FF AL) (#xFB50 #xFDFF AL) (#xFE70 #xFEFF AL)
 206         (#x0590 #x05FF R) (#x07C0 #x08FF R)
 207         (#xFB1D #xFB4F R) (#x10800 #x10FFF R) (#x1E800 #x1EFFF R))
 208      ;; The order of elements must be in sync with bidi_type_t in
 209      ;; src/dispextern.h.
 210      (L R EN AN BN B AL LRE LRO RLE RLO PDF LRI RLI FSI PDI
 211         ES ET CS NSM S WS ON))
 212     (decomposition
 213      5 unidata-gen-table-decomposition "uni-decomposition.el"
 214      "Unicode decomposition mapping.
 215 Property value is a list of characters.  The first element may be
 216 one of these symbols representing compatibility formatting tag:
 217   font, noBreak, initial, medial, final, isolated, circle, super,
 218   sub, vertical, wide, narrow, small, square, fraction, compat"
 219      unidata-describe-decomposition)
 220     (decimal-digit-value
 221      6 unidata-gen-table-integer "uni-decimal.el"
 222      "Unicode numeric value (decimal digit).
 223 Property value is an integer 0..9, or nil.
 224 The value nil stands for NaN \"Numeric_Value\".")
 225     (digit-value
 226      7 unidata-gen-table-integer "uni-digit.el"
 227      "Unicode numeric value (digit).
 228 Property value is an integer 0..9, or nil.
 229 The value nil stands for NaN \"Numeric_Value\".")
 230     (numeric-value
 231      8 unidata-gen-table-numeric "uni-numeric.el"
 232      "Unicode numeric value (numeric).
 233 Property value is an integer, a floating point, or nil.
 234 The value nil stands for NaN \"Numeric_Value\".")
 235     (mirrored
 236      9 unidata-gen-table-symbol "uni-mirrored.el"
 237      "Unicode bidi mirrored flag.
 238 Property value is a symbol `Y' or `N'.  See also the property `mirroring'."
 239      nil
 240      N)
 241     (old-name
 242      10 unidata-gen-table-name "uni-old-name.el"
 243      "Unicode old names as published in Unicode 1.0.
 244 Property value is a string or nil.
 245 The value nil stands for the default value \"null string\").")
 246     (iso-10646-comment
 247      11 unidata-gen-table-name "uni-comment.el"
 248      "Unicode ISO 10646 comment.
 249 Property value is a string.")
 250     (uppercase
 251      12 unidata-gen-table-character "uni-uppercase.el"
 252      "Unicode simple uppercase mapping.
 253 Property value is a character or nil.
 254 The value nil means that the actual property value of a character
 255 is the character itself."
 256      string)
 257     (lowercase
 258      13 unidata-gen-table-character "uni-lowercase.el"
 259      "Unicode simple lowercase mapping.
 260 Property value is a character or nil.
 261 The value nil means that the actual property value of a character
 262 is the character itself."
 263      string)
 264     (titlecase
 265      14 unidata-gen-table-character "uni-titlecase.el"
 266      "Unicode simple titlecase mapping.
 267 Property value is a character or nil.
 268 The value nil means that the actual property value of a character
 269 is the character itself."
 270      string)
 271     (mirroring
 272      unidata-gen-mirroring-list unidata-gen-table-character "uni-mirrored.el"
 273      "Unicode bidi-mirroring characters.
 274 Property value is a character that has the corresponding mirroring image or nil.
 275 The value nil means that the actual property value of a character
 276 is the character itself.")
 277     (paired-bracket
 278      unidata-gen-brackets-list unidata-gen-table-character "uni-brackets.el"
 279      "Unicode bidi paired-bracket characters.
 280 Property value is the paired bracket character, or nil.
 281 The value nil means that the character is neither an opening nor
 282 a closing paired bracket."
 283      string)
 284     (bracket-type
 285      unidata-gen-bracket-type-list unidata-gen-table-symbol "uni-brackets.el"
 286      "Unicode bidi paired-bracket type.
 287 Property value is a symbol `o' (Open), `c' (Close), or `n' (None)."
 288      unidata-describe-bidi-bracket-type
 289      n
 290      ;; The order of elements must be in sync with bidi_bracket_type_t
 291      ;; in src/dispextern.h.
 292      (n o c))))
 293
 294 ;; Functions to access the above data.
 295 (defsubst unidata-prop-index (prop) (nth 1 (assq prop unidata-prop-alist)))
 296 (defsubst unidata-prop-generator (prop) (nth 2 (assq prop unidata-prop-alist)))
 297 (defsubst unidata-prop-file (prop) (nth 3 (assq prop unidata-prop-alist)))
 298 (defsubst unidata-prop-docstring (prop) (nth 4 (assq prop unidata-prop-alist)))
 299 (defsubst unidata-prop-describer (prop) (nth 5 (assq prop unidata-prop-alist)))
 300 (defsubst unidata-prop-default (prop) (nth 6 (assq prop unidata-prop-alist)))
 301 (defsubst unidata-prop-val-list (prop) (nth 7 (assq prop unidata-prop-alist)))
 302
 303 \f
 304 ;; SIMPLE TABLE
 305 ;;
 306 ;; If the type of character property value is character, and the
 307 ;; values of succeeding character codes are usually different, we use
 308 ;; a char-table described here to store such values.
 309 ;;
 310 ;; A char-table divides character code space (#x0..#x3FFFFF) into
 311 ;; #x8000 blocks (each block contains 128 characters).
 312
 313 ;; If all characters of a block have no property, a char-table has the
 314 ;; symbol nil for that block.  Otherwise a char-table has a string of
 315 ;; the following format for it.
 316 ;;
 317 ;; The first character of the string is ?\001.
 318 ;; The second character of the string is FIRST-INDEX.
 319 ;; The Nth (N > 1) character of the string is a property value of the
 320 ;; character (BLOCK-HEAD + FIRST-INDEX + N - 2), where BLOCK-HEAD is
 321 ;; the first character of the block.
 322 ;;
 323 ;; This kind of char-table has these extra slots:
 324 ;;   1st: the property symbol
 325 ;;   2nd: nil
 326 ;;   3rd: 0 (corresponding to uniprop_encode_character in chartab.c)
 327 ;;   4th to 5th: nil
 328
 329 (defun unidata-gen-table-character (prop &rest ignore)
 330   (let ((table (make-char-table 'char-code-property-table))
 331         (prop-idx (unidata-prop-index prop))
 332         (vec (make-vector 128 0))
 333         (tail unidata-list)
 334         elt range val idx slot)
 335     (if (functionp prop-idx)
 336         (setq tail (funcall prop-idx)
 337               prop-idx 1))
 338     (while tail
 339       (setq elt (car tail) tail (cdr tail))
 340       (setq range (car elt)
 341             val (nth prop-idx elt))
 342       (if (= (length val) 0)
 343           (setq val nil)
 344         (setq val (string-to-number val 16)))
 345       (if (consp range)
 346           (if val
 347               (set-char-table-range table range val))
 348         (let* ((start (lsh (lsh range -7) 7))
 349                (limit (+ start 127))
 350                first-index last-index)
 351           (fillarray vec 0)
 352           (if val
 353               (aset vec (setq last-index (setq first-index (- range start)))
 354                     val))
 355           (while (and (setq elt (car tail) range (car elt))
 356                       (integerp range)
 357                       (<= range limit))
 358             (setq val (nth prop-idx elt))
 359             (when (> (length val) 0)
 360               (aset vec (setq last-index (- range start))
 361                     (string-to-number val 16))
 362               (or first-index
 363                   (setq first-index last-index)))
 364             (setq tail (cdr tail)))
 365           (when first-index
 366             (let ((str (string 1 first-index))
 367                   c)
 368               (while (<= first-index last-index)
 369                 (setq str (format "%s%c"  str (or (aref vec first-index) 0))
 370                       first-index (1+ first-index)))
 371               (set-char-table-range table (cons start limit) str))))))
 372
 373     (set-char-table-extra-slot table 0 prop)
 374     (set-char-table-extra-slot table 2 0)
 375     table))
 376
 377
 378 \f
 379 ;; RUN-LENGTH TABLE
 380 ;;
 381 ;; If many characters of successive character codes have the same
 382 ;; property value, we use a char-table described here to store the
 383 ;; values.
 384 ;;
 385 ;; At first, instead of a value itself, we store an index number to
 386 ;; the VAL-TABLE (5th extra slot) in the table.  We call that index
 387 ;; number as VAL-CODE here after.
 388 ;;
 389 ;; A char-table divides character code space (#x0..#x3FFFFF) into
 390 ;; #x8000 blocks (each block contains 128 characters).
 391 ;;
 392 ;; If all characters of a block have the same value, a char-table has
 393 ;; VAL-CODE for that block.  Otherwise a char-table has a string of
 394 ;; the following format for that block.
 395 ;;
 396 ;; The first character of the string is ?\002.
 397 ;; The following characters has this form:
 398 ;;   ( VAL-CODE RUN-LENGTH ? ) +
 399 ;; where:
 400 ;;   VAL-CODE (0..127): index into VAL-TABLE.
 401 ;;   RUN-LENGTH (130..255):
 402 ;;     (RUN-LENGTH - 128) specifies how many characters have the same
 403 ;;     value.  If omitted, it means 1.
 404 ;;
 405 ;; This kind of char-table has these extra slots:
 406 ;;   1st: the property symbol
 407 ;;   2nd: 0 (corresponding to uniprop_decode_value in chartab.c)
 408 ;;   3rd: 1..3 (corresponding to uniprop_encode_xxx in chartab.c)
 409 ;;   4th: function or nil
 410 ;;   5th: VAL-TABLE
 411
 412 ;; Encode the character property value VAL into an integer value by
 413 ;; VAL-LIST.  By side effect, VAL-LIST is modified.
 414 ;; VAL-LIST has this form:
 415 ;;   ((nil . 0) (VAL1 . 1) (VAL2 . 2) ...)
 416 ;; If VAL is one of VALn, just return n.
 417 ;; Otherwise, VAL-LIST is modified to this:
 418 ;;   ((nil . 0) (VAL1 . 1) (VAL2 . 2) ... (VAL . n+1))
 419 ;;
 420 ;; WARN is an optional warning to display when the value list is
 421 ;; extended, for property values that need to be in sync with other
 422 ;; parts of Emacs; currently only used for bidi-class.
 423
 424 (defun unidata-encode-val (val-list val &optional warn)
 425   (let ((slot (assoc val val-list))
 426         val-code)
 427     (if slot
 428         (cdr slot)
 429       (if warn (message warn val))
 430       (setq val-code (length val-list))
 431       (nconc val-list (list (cons val val-code)))
 432       val-code)))
 433
 434 ;; Generate a char-table for the character property PROP.
 435
 436 (defun unidata-gen-table (prop val-func default-value val-list)
 437   (let ((table (make-char-table 'char-code-property-table))
 438         (prop-idx (unidata-prop-index prop))
 439         (vec (make-vector 128 0))
 440         ;; When this warning is printed, there's a need to make the
 441         ;; following changes:
 442         ;; (1) update unidata-prop-alist with the new bidi-class values;
 443         ;; (2) extend bidi_type_t enumeration on src/dispextern.h to
 444         ;;     include the new classes;
 445         ;; (3) possibly update the assertion in bidi.c:bidi_check_type; and
 446         ;; (4) possibly update the switch cases in
 447         ;;     bidi.c:bidi_get_type and bidi.c:bidi_get_category.
 448         (bidi-warning "\
 449 ** Found new bidi-class `%s', please update bidi.c and dispextern.h")
 450         tail elt range val val-code idx slot
 451         prev-range-data)
 452     (setq val-list (cons nil (copy-sequence val-list)))
 453     (setq tail val-list val-code 0)
 454     ;; Convert (nil A B ...) to ((nil . 0) (A . 1) (B . 2) ...)
 455     (while tail
 456       (setcar tail (cons (car tail) val-code))
 457       (setq tail (cdr tail) val-code (1+ val-code)))
 458     (if (consp default-value)
 459         (setq default-value (copy-sequence default-value))
 460       (setq default-value (list default-value)))
 461     (setcar default-value
 462             (unidata-encode-val val-list (car default-value)))
 463     (set-char-table-range table t (car default-value))
 464     (set-char-table-range table nil (car default-value))
 465     (dolist (elm (cdr default-value))
 466       (setcar (nthcdr 2 elm)
 467               (unidata-encode-val val-list (nth 2 elm)))
 468       (set-char-table-range table (cons (car elm) (nth 1 elm)) (nth 2 elm)))
 469
 470     (if (functionp prop-idx)
 471         (setq tail (funcall prop-idx)
 472               prop-idx 1)
 473       (setq tail unidata-list))
 474     (while tail
 475       (setq elt (car tail) tail (cdr tail))
 476       (setq range (car elt)
 477             val (funcall val-func (nth prop-idx elt)))
 478       (setq val-code (if val (unidata-encode-val val-list val
 479                                                  (and (eq prop 'bidi-class)
 480                                                       bidi-warning))))
 481       (if (consp range)
 482           (when val-code
 483             (set-char-table-range table range val-code)
 484             (let ((from (car range)) (to (cdr range)))
 485               ;; If RANGE doesn't end at the char-table boundary (each
 486               ;; 128 characters), we may have to carry over the data
 487               ;; for the last several characters (at most 127 chars)
 488               ;; to the next loop.  In that case, set PREV-RANGE-DATA
 489               ;; to ((FROM . TO) . VAL-CODE) where (FROM . TO)
 490               ;; specifies the range of characters handled in the next
 491               ;; loop.
 492               (when (< (logand to #x7F) #x7F)
 493                 (if (< from (logand to #x1FFF80))
 494                     (setq from (logand to #x1FFF80)))
 495                 (setq prev-range-data (cons (cons from to) val-code)))))
 496         (let* ((start (lsh (lsh range -7) 7))
 497                (limit (+ start 127))
 498                str count new-val from to vcode)
 499           (fillarray vec (car default-value))
 500           (dolist (elm (cdr default-value))
 501             (setq from (car elm) to (nth 1 elm))
 502             (when (and (<= from limit)
 503                        (or (>= from start) (>= to start)))
 504               (setq from (max from start)
 505                     to (min to limit)
 506                     vcode (nth 2 elm))
 507               (while (<= from to)
 508                 (aset vec (- from start) vcode)
 509                 (setq from (1+ from)))))
 510           ;; See the comment above.
 511           (when (and prev-range-data
 512                      (>= (cdr (car prev-range-data)) start))
 513             (setq from (car (car prev-range-data))
 514                   to (cdr (car prev-range-data))
 515                   vcode (cdr prev-range-data))
 516             (while (<= from to)
 517               (aset vec (- from start) vcode)
 518               (setq from (1+ from))))
 519           (setq prev-range-data nil)
 520           (if val-code
 521               (aset vec (- range start) val-code))
 522           (while (and (setq elt (car tail) range (car elt))
 523                       (integerp range)
 524                       (<= range limit))
 525             (setq new-val (funcall val-func (nth prop-idx elt)))
 526             (if (not (eq val new-val))
 527                 (setq val new-val
 528                       val-code (if val (unidata-encode-val
 529                                         val-list val (and (eq prop 'bidi-class)
 530                                                           bidi-warning)))))
 531             (if val-code
 532                 (aset vec (- range start) val-code))
 533             (setq tail (cdr tail)))
 534           (setq str "\002" val-code -1 count 0)
 535           (mapc #'(lambda (x)
 536                     (if (= val-code x)
 537                         (setq count (1+ count))
 538                       (if (> count 2)
 539                           (setq str (concat str (string val-code
 540                                                         (+ count 128))))
 541                         (if (= count 2)
 542                             (setq str (concat str (string val-code val-code)))
 543                           (if (= count 1)
 544                               (setq str (concat str (string val-code))))))
 545                       (setq val-code x count 1)))
 546                 vec)
 547           (if (= count 128)
 548               (if val
 549                   (set-char-table-range table (cons start limit) val-code))
 550             (if (= val-code 0)
 551                 (set-char-table-range table (cons start limit) str)
 552               (if (> count 2)
 553                   (setq str (concat str (string val-code (+ count 128))))
 554                 (if (= count 2)
 555                     (setq str (concat str (string val-code val-code)))
 556                   (setq str (concat str (string val-code)))))
 557               (set-char-table-range table (cons start limit) str))))))
 558
 559     (set-char-table-extra-slot table 0 prop)
 560     (set-char-table-extra-slot table 4 (vconcat (mapcar 'car val-list)))
 561     table))
 562
 563 (defun unidata-gen-table-symbol (prop default-value val-list)
 564   (let ((table (unidata-gen-table prop
 565                                   #'(lambda (x) (and (> (length x) 0)
 566                                                      (intern x)))
 567                                   default-value val-list)))
 568     (set-char-table-extra-slot table 1 0)
 569     (set-char-table-extra-slot table 2 1)
 570     table))
 571
 572 (defun unidata-gen-table-integer (prop default-value val-list)
 573   (let ((table (unidata-gen-table prop
 574                                   #'(lambda (x) (and (> (length x) 0)
 575                                                      (string-to-number x)))
 576                                   default-value val-list)))
 577     (set-char-table-extra-slot table 1 0)
 578     (set-char-table-extra-slot table 2 1)
 579     table))
 580
 581 (defun unidata-gen-table-numeric (prop default-value val-list)
 582   (let ((table (unidata-gen-table prop
 583                                   #'(lambda (x)
 584                                       (if (string-match "/" x)
 585                                           (/ (float (string-to-number x))
 586                                              (string-to-number
 587                                               (substring x (match-end 0))))
 588                                         (if (> (length x) 0)
 589                                             (string-to-number x))))
 590                                   default-value val-list)))
 591     (set-char-table-extra-slot table 1 0)
 592     (set-char-table-extra-slot table 2 2)
 593     table))
 594
 595 \f
 596 ;; WORD-LIST TABLE
 597
 598 ;;   If the table is for `name' property, each character in the string
 599 ;;   is one of these:
 600 ;;      DIFF-HEAD-CODE (0, 1, or 2):
 601 ;;        specifies how to decode the following characters.
 602 ;;      WORD-CODE (3..#x7FF excluding '-', '0'..'9', 'A'..'Z'):
 603 ;;        specifies an index number into WORD-TABLE (see below)
 604 ;;      Otherwise (' ', '-', '0'..'9', 'A'..'Z'):
 605 ;;        specifies a literal word.
 606 ;;
 607 ;;   The 4th slots is a vector:
 608 ;;      [ WORD-TABLE BLOCK-NAME HANGUL-JAMO-TABLE ]
 609 ;;   WORD-TABLE is a vector of word symbols.
 610 ;;   BLOCK-NAME is a vector of name symbols for a block of characters.
 611 ;;   HANGUL-JAMO-TABLE is `unidata-name-jamo-name-table'.
 612
 613 ;; Return the difference of symbol list L1 and L2 in this form:
 614 ;;   (DIFF-HEAD SYM1 SYM2 ...)
 615 ;; DIFF-HEAD is ((SAME-HEAD-LENGTH * 16) + SAME-TAIL-LENGTH).
 616 ;; Ex: If L1 is (a b c d e f) and L2 is (a g h e f), this function
 617 ;; returns ((+ (* 1 16) 2) g h).
 618 ;; It means that we can get L2 from L1 by prepending the first element
 619 ;; of L1 and appending the last 2 elements of L1 to the list (g h).
 620 ;; If L1 and L2 don't have common elements at the head and tail,
 621 ;; set DIFF-HEAD to -1 and SYM1 ... to the elements of L2.
 622
 623 (defun unidata-word-list-diff (l1 l2)
 624   (let ((beg 0)
 625         (end 0)
 626         (len1 (length l1))
 627         (len2 (length l2))
 628         result)
 629     (when (< len1 16)
 630       (while (and l1 (eq (car l1) (car l2)))
 631         (setq beg (1+ beg)
 632               l1 (cdr l1) len1 (1- len1) l2 (cdr l2) len2 (1- len2)))
 633       (while (and (< end len1) (< end len2)
 634                   (eq (nth (- len1 end 1) l1) (nth (- len2 end 1) l2)))
 635         (setq end (1+ end))))
 636     (if (= (+ beg end) 0)
 637         (setq result (list -1))
 638       (setq result (list (+ (* beg 16) (+ beg (- len1 end))))))
 639     (while (< end len2)
 640       (setcdr result (cons (nth (- len2 end 1) l2) (cdr result)))
 641       (setq end (1+ end)))
 642     result))
 643
 644 ;; Return a compressed form of the vector VEC.  Each element of VEC is
 645 ;; a list of symbols of which names can be concatenated to form a
 646 ;; character name.  This function changes those elements into
 647 ;; compressed forms by utilizing the fact that diff of consecutive
 648 ;; elements is usually small.
 649
 650 (defun unidata-word-list-compress (vec)
 651   (let (last-elt last-idx diff-head tail elt val)
 652     (dotimes (i 128)
 653       (setq elt (aref vec i))
 654       (when elt
 655         (if (null last-elt)
 656             (setq diff-head -1
 657                   val (cons 0 elt))
 658           (setq val (unidata-word-list-diff last-elt elt))
 659           (if (= (car val) -1)
 660               (setq diff-head -1
 661                     val (cons 0 (cdr val)))
 662             (if (eq diff-head (car val))
 663                 (setq val (cons 2 (cdr val)))
 664               (setq diff-head (car val))
 665               (if (>= diff-head 0)
 666                   (setq val (cons 1 val))))))
 667         (aset vec i val)
 668         (setq last-idx i last-elt elt)))
 669     (if (not last-idx)
 670         (setq vec nil)
 671       (if (< last-idx 127)
 672           (let ((shorter (make-vector (1+ last-idx) nil)))
 673             (dotimes (i (1+ last-idx))
 674               (aset shorter i (aref vec i)))
 675             (setq vec shorter))))
 676     vec))
 677
 678 ;; Encode the word index IDX into a characters code that can be
 679 ;; embedded in a string.
 680
 681 (defsubst unidata-encode-word (idx)
 682   ;; Exclude 0, 1, 2.
 683   (+ idx 3))
 684
 685 ;; Decode the character code CODE (that is embedded in a string) into
 686 ;; the corresponding word name by looking up WORD-TABLE.
 687
 688 (defsubst unidata-decode-word (code word-table)
 689   (setq code (- code 3))
 690   (if (< code (length word-table))
 691       (aref word-table code)))
 692
 693 ;; Table of short transliterated name symbols of Hangul Jamo divided
 694 ;; into Choseong, Jungseong, and Jongseong.
 695
 696 (defconst unidata-name-jamo-name-table
 697   [[G GG N D DD R M B BB S SS nil J JJ C K T P H]
 698    [A AE YA YAE EO E YEO YE O WA WAE OE YO U WEO WE WI YU EU YI I]
 699    [G GG GS N NJ NH D L LG LM LB LS LT LP LH M B BS S SS NG J C K T P H]])
 700
 701 ;; Return a name of CHAR.  VAL is the current value of (aref TABLE
 702 ;; CHAR).
 703
 704 (defun unidata-get-name (char val table)
 705   (cond
 706    ((stringp val)
 707     (if (> (aref val 0) 0)
 708         val
 709       (let* ((first-char (lsh (lsh char -7) 7))
 710              (word-table (aref (char-table-extra-slot table 4) 0))
 711              (i 1)
 712              (len (length val))
 713              (vec (make-vector 128 nil))
 714              (idx 0)
 715              (case-fold-search nil)
 716              c word-list tail-list last-list word diff-head)
 717         (while (< i len)
 718           (setq c (aref val i))
 719           (if (< c 3)
 720               (progn
 721                 (if (or word-list tail-list)
 722                     (aset vec idx
 723                           (setq last-list (nconc word-list tail-list))))
 724                 (setq i (1+ i) idx (1+ idx)
 725                       word-list nil tail-list nil)
 726                 (if (> c 0)
 727                     (let ((l last-list))
 728                       (if (= c 1)
 729                           (setq diff-head
 730                                 (prog1 (aref val i) (setq i (1+ i)))))
 731                       (setq tail-list (nthcdr (% diff-head 16) last-list))
 732                       (dotimes (i (/ diff-head 16))
 733                         (setq word-list (nconc word-list (list (car l)))
 734                               l (cdr l))))))
 735             (setq word-list
 736                   (nconc word-list
 737                          (list (symbol-name
 738                                 (unidata-decode-word c word-table))))
 739                   i (1+ i))))
 740         (if (or word-list tail-list)
 741             (aset vec idx (nconc word-list tail-list)))
 742         (setq val nil)
 743         (dotimes (i 128)
 744           (setq c (+ first-char i))
 745           (let ((name (aref vec i)))
 746             (if name
 747                 (let ((tail (cdr (setq name (copy-sequence name))))
 748                       elt)
 749                   (while tail
 750                     (setq elt (car tail))
 751                     (or (string= elt "-")
 752                         (progn
 753                           (setcdr tail (cons elt (cdr tail)))
 754                           (setcar tail " ")))
 755                     (setq tail (cddr tail)))
 756                   (setq name (apply 'concat name))))
 757             (aset table c name)
 758             (if (= c char)
 759                 (setq val name))))
 760         val)))
 761
 762    ((and (integerp val) (> val 0))
 763     (let* ((symbol-table (aref (char-table-extra-slot table 4) 1))
 764            (sym (aref symbol-table (1- val))))
 765       (cond ((eq sym 'HANGUL\ SYLLABLE)
 766              (let ((jamo-name-table (aref (char-table-extra-slot table 4) 2)))
 767                ;; SIndex = S - SBase
 768                (setq char (- char #xAC00))
 769                (let ( ;; LIndex = SIndex / NCount
 770                      (L (/ char 588))
 771                      ;; VIndex = (SIndex % NCount) * TCount
 772                      (V (/ (% char 588) 28))
 773                      ;; TIndex = SIndex % TCount
 774                      (T (% char 28)))
 775                  (format "HANGUL SYLLABLE %s%s%s"
 776                          ;; U+110B is nil in this table.
 777                          (or (aref (aref jamo-name-table 0) L) "")
 778                          (aref (aref jamo-name-table 1) V)
 779                          (if (= T 0) ""
 780                            (aref (aref jamo-name-table 2) (1- T)))))))
 781             ((eq sym 'CJK\ IDEOGRAPH)
 782              (format "%s-%04X" sym char))
 783             ((eq sym 'TANGUT\ IDEOGRAPH)
 784              (format "%s-%04X" sym char))
 785             ((eq sym 'CJK\ COMPATIBILITY\ IDEOGRAPH)
 786              (format "%s-%04X" sym char))
 787             ((eq sym 'HIGH\ SURROGATE)
 788              (format "%s-%04X" sym char))
 789             ((eq sym 'LOW\ SURROGATE)
 790              (format "%s-%04X" sym char))
 791             ((eq sym 'VARIATION\ SELECTOR)
 792              (format "%s-%d" sym (+ (- char #xe0100) 17))))))))
 793
 794 ;; Store VAL as the name of CHAR in TABLE.
 795
 796 (defun unidata-put-name (char val table)
 797   (let ((current-val (aref table char)))
 798     (if (and (stringp current-val) (= (aref current-val 0) 0))
 799         (funcall (char-table-extra-slot table 1) char current-val table))
 800     (aset table char val)))
 801
 802 (defun unidata-get-decomposition (char val table)
 803   (cond
 804    ((not val)
 805     (list char))
 806
 807    ((consp val)
 808     val)
 809
 810    ((stringp val)
 811     (if (> (aref val 0) 0)
 812         val
 813       (let* ((first-char (lsh (lsh char -7) 7))
 814              (word-table (char-table-extra-slot table 4))
 815              (i 1)
 816              (len (length val))
 817              (vec (make-vector 128 nil))
 818              (idx 0)
 819              (case-fold-search nil)
 820              c word-list tail-list last-list word diff-head)
 821         (while (< i len)
 822           (setq c (aref val i))
 823           (if (< c 3)
 824               (progn
 825                 (if (or word-list tail-list)
 826                     (aset vec idx
 827                           (setq last-list (nconc word-list tail-list))))
 828                 (setq i (1+ i) idx (1+ idx)
 829                       word-list nil tail-list nil)
 830                 (if (> c 0)
 831                     (let ((l last-list))
 832                       (if (= c 1)
 833                           (setq diff-head
 834                                 (prog1 (aref val i) (setq i (1+ i)))))
 835                       (setq tail-list (nthcdr (% diff-head 16) last-list))
 836                       (dotimes (i (/ diff-head 16))
 837                         (setq word-list (nconc word-list (list (car l)))
 838                               l (cdr l))))))
 839             (setq word-list
 840                   (nconc word-list
 841                          (list (or (unidata-decode-word c word-table) c)))
 842                   i (1+ i))))
 843         (if (or word-list tail-list)
 844             (aset vec idx (nconc word-list tail-list)))
 845         (dotimes (i 128)
 846           (aset table (+ first-char i) (aref vec i)))
 847         (setq val (aref vec (- char first-char)))
 848         (or val (list char)))))
 849
 850    ;; Hangul syllable
 851    ((and (eq val 0) (>= char #xAC00) (<= char #xD7A3))
 852     ;; SIndex = S (char) - SBase (#xAC00)
 853     (setq char (- char #xAC00))
 854     (let (;; L = LBase + SIndex / NCount
 855           (L (+ #x1100 (/ char 588)))
 856           ;; V = VBase + (SIndex % NCount) * TCount
 857           (V (+ #x1161 (/ (% char 588) 28)))
 858           ;; LV = SBase + (SIndex / TCount) * TCount
 859           (LV (+ #xAC00 (* (/ char 28) 28)))
 860           ;; T = TBase + SIndex % TCount
 861           (T (+ #x11A7 (% char 28))))
 862       (if (= T #x11A7)
 863           (list L V)
 864         (list LV T))))
 865
 866    ))
 867
 868 ;; Store VAL as the decomposition information of CHAR in TABLE.
 869
 870 (defun unidata-put-decomposition (char val table)
 871   (let ((current-val (aref table char)))
 872     (if (and (stringp current-val) (= (aref current-val 0) 0))
 873         (funcall (char-table-extra-slot table 1) char current-val table))
 874     (aset table char val)))
 875
 876 ;; UnicodeData.txt contains these lines:
 877 ;;   0000;<control>;Cc;0;BN;;;;;N;NULL;;;;
 878 ;;   ...
 879 ;;   0020;SPACE;Zs;0;WS;;;;;N;;;;;
 880 ;;   ...
 881 ;; The following command yields a file of about 96K bytes.
 882 ;;   % gawk -F ';' '{print $1,$2;}' < UnicodeData.txt | gzip > temp.gz
 883 ;; With the following function, we can get a file of almost the same
 884 ;; size.
 885
 886 ;; Generate a char-table for character names.
 887
 888 (defun unidata-gen-table-word-list (prop val-func)
 889   (let ((table (make-char-table 'char-code-property-table))
 890         (prop-idx (unidata-prop-index prop))
 891         (word-list (list nil))
 892         word-table
 893         block-list block-word-table block-end
 894         tail elt range val idx slot)
 895     (setq tail unidata-list)
 896     (setq block-end -1)
 897     (while tail
 898       (setq elt (car tail) tail (cdr tail))
 899       (setq range (car elt)
 900             val (funcall val-func (nth prop-idx elt)))
 901       ;; Treat the sequence of "CJK COMPATIBILITY IDEOGRAPH-XXXX" and
 902       ;; "VARIATION SELECTOR-XXX" as a block.
 903       (if (and (consp val) (eq prop 'name)
 904                (or (and (eq (car val) 'CJK)
 905                         (eq (nth 1 val) 'COMPATIBILITY))
 906                    (and (>= range #xe0100)
 907                         (eq (car val) 'VARIATION)
 908                         (eq (nth 1 val) 'SELECTOR))))
 909           (let ((first (car val))
 910                 (second (nth 1 val))
 911                 (start range))
 912             (while (and (setq elt (car tail) range (car elt)
 913                               val (funcall val-func (nth prop-idx elt)))
 914                         (consp val)
 915                         (eq first (car val))
 916                         (eq second (nth 1 val)))
 917               (setq block-end range
 918                     tail (cdr tail)))
 919             (setq range (cons start block-end)
 920                   val (if (eq first 'CJK) 'CJK\ COMPATIBILITY\ IDEOGRAPH
 921                         'VARIATION\ SELECTOR))))
 922
 923       (if (consp range)
 924           (if val
 925               (let ((slot (assq val block-list)))
 926                 (setq range (cons (car range) (cdr range)))
 927                 (setq block-end (cdr range))
 928                 (if slot
 929                     (nconc slot (list range))
 930                   (push (list val range) block-list))))
 931         (let* ((start (lsh (lsh range -7) 7))
 932                (limit (+ start 127))
 933                (first tail)
 934                (vec (make-vector 128 nil))
 935                c name len)
 936           (if (<= start block-end)
 937               ;; START overlap with the previous block.
 938               (aset table range (nth prop-idx elt))
 939             (if val
 940                 (aset vec (- range start) val))
 941             (while (and (setq elt (car tail) range (car elt))
 942                         (integerp range)
 943                         (<= range limit))
 944               (setq val (funcall val-func (nth prop-idx elt)))
 945               (if val
 946                   (aset vec (- range start) val))
 947               (setq tail (cdr tail)))
 948             (setq vec (unidata-word-list-compress vec))
 949             (when vec
 950               (dotimes (i (length vec))
 951                 (dolist (elt (aref vec i))
 952                   (if (symbolp elt)
 953                       (cl-incf (alist-get elt (cdr word-list) 0)))))
 954               (set-char-table-range table (cons start limit) vec))))))
 955     (setq word-list (sort (cdr word-list)
 956                           #'(lambda (x y) (> (cdr x) (cdr y)))))
 957     (setq tail word-list idx 0)
 958     (while tail
 959       (setcdr (car tail) (unidata-encode-word idx))
 960       (setq idx (1+ idx) tail (cdr tail)))
 961     (setq word-table (make-vector (length word-list) nil))
 962     (setq idx 0)
 963     (dolist (elt word-list)
 964       (aset word-table idx (car elt))
 965       (setq idx (1+ idx)))
 966
 967     (if (and (eq prop 'decomposition)
 968              (> idx 32))
 969         (error "Too many symbols in decomposition data"))
 970
 971     (dotimes (i (/ #x110000 128))
 972       (let* ((idx (* i 128))
 973              (vec (aref table idx)))
 974         (when (vectorp vec)
 975           (dotimes (i (length vec))
 976             (let ((tail (aref vec i))
 977                   elt code)
 978               (if (not tail)
 979                   (aset vec i "\0")
 980                 (while tail
 981                   (setq elt (car tail)
 982                         code (if (integerp elt) elt
 983                                (cdr (assq elt word-list))))
 984                   (setcar tail (string code))
 985                   (setq tail (cdr tail)))
 986                 (aset vec i (mapconcat 'identity (aref vec i) "")))))
 987           (set-char-table-range
 988            table (cons idx (+ idx 127))
 989            (mapconcat 'identity vec "")))))
 990
 991     (setq block-word-table (make-vector (length block-list) nil))
 992     (setq idx 0)
 993     (dolist (elt block-list)
 994       (dolist (e (cdr elt))
 995         (set-char-table-range table e (1+ idx)))
 996       (aset block-word-table idx (car elt))
 997       (setq idx (1+ idx)))
 998
 999     (set-char-table-extra-slot table 0 prop)
1000     (set-char-table-extra-slot table 4 (cons word-table block-word-table))
1001     table))
1002
1003 (defun unidata-split-name (str)
1004   (if (symbolp str)
1005       str
1006     (let ((len (length str))
1007           (l nil)
1008           (idx 0)
1009           c)
1010       (if (or (= len 0)
1011               ;; Unicode Standard, paragraph 4.8: "For all other
1012               ;; Unicode code points of all other types (Control,
1013               ;; Private-Use, Surrogate, Noncharacter, and Reserved),
1014               ;; the value of the Name property is the null string."
1015               ;; We already handle elsewhere all the characters except
1016               ;; Cc, Control characters, which are handled here.
1017               (string= str "<control>"))
1018           nil
1019         (dotimes (i len)
1020           (setq c (aref str i))
1021           (if (= c 32)
1022               (setq l (cons (intern (substring str idx i)) l)
1023                     idx (1+ i))
1024             (if (and (= c ?-) (< idx i)
1025                      (< (1+ i) len) (/= (aref str (1+ i)) 32))
1026                 (setq l (cons '- (cons (intern (substring str idx i)) l))
1027                       idx (1+ i)))))
1028         (nreverse (cons (intern (substring str idx)) l))))))
1029
1030 (defun unidata--ensure-compiled (&rest funcs)
1031   (dolist (fun funcs)
1032     (or (byte-code-function-p (symbol-function fun))
1033         (byte-compile fun))))
1034
1035 (defun unidata-gen-table-name (prop &rest ignore)
1036   (let* ((table (unidata-gen-table-word-list prop 'unidata-split-name))
1037          (word-tables (char-table-extra-slot table 4)))
1038     (unidata--ensure-compiled 'unidata-get-name 'unidata-put-name)
1039     (set-char-table-extra-slot table 1 (symbol-function 'unidata-get-name))
1040     (set-char-table-extra-slot table 2 (symbol-function 'unidata-put-name))
1041
1042     (if (eq prop 'name)
1043         (set-char-table-extra-slot table 4
1044                                    (vector (car word-tables)
1045                                            (cdr word-tables)
1046                                            unidata-name-jamo-name-table))
1047       (set-char-table-extra-slot table 4
1048                                  (vector (car word-tables))))
1049     table))
1050
1051 (defun unidata-split-decomposition (str)
1052   (if (symbolp str)
1053       str
1054     (let ((len (length str))
1055           (l nil)
1056           (idx 0)
1057           c)
1058       (if (= len 0)
1059           nil
1060         (dotimes (i len)
1061           (setq c (aref str i))
1062           (if (= c 32)
1063               (setq l (if (= (aref str idx) ?<)
1064                           (cons (intern (substring str (1+ idx) (1- i))) l)
1065                         (cons (string-to-number (substring str idx i) 16) l))
1066                     idx (1+ i))))
1067         (if (= (aref str idx) ?<)
1068             (setq l (cons (intern (substring str (1+ idx) (1- len))) l))
1069           (setq l (cons (string-to-number (substring str idx len) 16) l)))
1070         (nreverse l)))))
1071
1072
1073 (defun unidata-gen-table-decomposition (prop &rest ignore)
1074   (let* ((table (unidata-gen-table-word-list prop 'unidata-split-decomposition))
1075          (word-tables (char-table-extra-slot table 4)))
1076     (unidata--ensure-compiled 'unidata-get-decomposition
1077                               'unidata-put-decomposition)
1078     (set-char-table-extra-slot table 1
1079                                (symbol-function 'unidata-get-decomposition))
1080     (set-char-table-extra-slot table 2
1081                                (symbol-function 'unidata-put-decomposition))
1082     (set-char-table-extra-slot table 4 (car word-tables))
1083     table))
1084
1085
1086 \f
1087 (defun unidata-describe-general-category (val)
1088   (cdr (assq val
1089              '((nil . "Uknown")
1090                (Lu . "Letter, Uppercase")
1091                (Ll . "Letter, Lowercase")
1092                (Lt . "Letter, Titlecase")
1093                (Lm . "Letter, Modifier")
1094                (Lo . "Letter, Other")
1095                (Mn . "Mark, Nonspacing")
1096                (Mc . "Mark, Spacing Combining")
1097                (Me . "Mark, Enclosing")
1098                (Nd . "Number, Decimal Digit")
1099                (Nl . "Number, Letter")
1100                (No . "Number, Other")
1101                (Pc . "Punctuation, Connector")
1102                (Pd . "Punctuation, Dash")
1103                (Ps . "Punctuation, Open")
1104                (Pe . "Punctuation, Close")
1105                (Pi . "Punctuation, Initial quote")
1106                (Pf . "Punctuation, Final quote")
1107                (Po . "Punctuation, Other")
1108                (Sm . "Symbol, Math")
1109                (Sc . "Symbol, Currency")
1110                (Sk . "Symbol, Modifier")
1111                (So . "Symbol, Other")
1112                (Zs . "Separator, Space")
1113                (Zl . "Separator, Line")
1114                (Zp . "Separator, Paragraph")
1115                (Cc . "Other, Control")
1116                (Cf . "Other, Format")
1117                (Cs . "Other, Surrogate")
1118                (Co . "Other, Private Use")
1119                (Cn . "Other, Not Assigned")))))
1120
1121 (defun unidata-describe-canonical-combining-class (val)
1122   (cdr (assq val
1123              '((0 . "Spacing, split, enclosing, reordrant, and Tibetan subjoined")
1124                (1 . "Overlays and interior")
1125                (7 . "Nuktas")
1126                (8 . "Hiragana/Katakana voicing marks")
1127                (9 . "Viramas")
1128                (10 . "Start of fixed position classes")
1129                (199 . "End of fixed position classes")
1130                (200 . "Below left attached")
1131                (202 . "Below attached")
1132                (204 . "Below right attached")
1133                (208 . "Left attached (reordrant around single base character)")
1134                (210 . "Right attached")
1135                (212 . "Above left attached")
1136                (214 . "Above attached")
1137                (216 . "Above right attached")
1138                (218 . "Below left")
1139                (220 . "Below")
1140                (222 . "Below right")
1141                (224 . "Left (reordrant around single base character)")
1142                (226 . "Right")
1143                (228 . "Above left")
1144                (230 . "Above")
1145                (232 . "Above right")
1146                (233 . "Double below")
1147                (234 . "Double above")
1148                (240 . "Below (iota subscript)")))))
1149
1150 (defun unidata-describe-bidi-class (val)
1151   (cdr (assq val
1152              '((L . "Left-to-Right")
1153                (LRE . "Left-to-Right Embedding")
1154                (LRO . "Left-to-Right Override")
1155                (R . "Right-to-Left")
1156                (AL . "Right-to-Left Arabic")
1157                (RLE . "Right-to-Left Embedding")
1158                (RLO . "Right-to-Left Override")
1159                (PDF . "Pop Directional Format")
1160                (LRI . "Left-to-Right Isolate")
1161                (RLI . "Right-to-Left Isolate")
1162                (FSI . "First Strong Isolate")
1163                (PDI . "Pop Directional Isolate")
1164                (EN . "European Number")
1165                (ES . "European Number Separator")
1166                (ET . "European Number Terminator")
1167                (AN . "Arabic Number")
1168                (CS . "Common Number Separator")
1169                (NSM . "Non-Spacing Mark")
1170                (BN . "Boundary Neutral")
1171                (B . "Paragraph Separator")
1172                (S . "Segment Separator")
1173                (WS . "Whitespace")
1174                (ON . "Other Neutrals")))))
1175
1176 (defun unidata-describe-decomposition (val)
1177   (mapconcat
1178    #'(lambda (x)
1179        (if (symbolp x) (symbol-name x)
1180          (concat (string ?')
1181                  (compose-string (string x) 0 1 (string ?\t x ?\t))
1182                  (string ?'))))
1183    val " "))
1184
1185 (defun unidata-describe-bidi-bracket-type (val)
1186   (cdr (assq val
1187              '((n . "Not a paired bracket character.")
1188                (o . "Opening paired bracket character.")
1189                (c . "Closing paired bracket character.")))))
1190
1191 (defun unidata-gen-mirroring-list ()
1192   (let ((head (list nil))
1193         tail)
1194     (with-temp-buffer
1195       (insert-file-contents (expand-file-name "BidiMirroring.txt" unidata-dir))
1196       (goto-char (point-min))
1197       (setq tail head)
1198       (while (re-search-forward "^\\([0-9A-F]+\\);\\s +\\([0-9A-F]+\\)" nil t)
1199         (let ((char (string-to-number (match-string 1) 16))
1200               (mirror (match-string 2)))
1201           (setq tail (setcdr tail (list (list char mirror)))))))
1202     (cdr head)))
1203
1204 (defun unidata-gen-brackets-list ()
1205   (let ((head (list nil))
1206         tail)
1207     (with-temp-buffer
1208       (insert-file-contents (expand-file-name "BidiBrackets.txt" unidata-dir))
1209       (goto-char (point-min))
1210       (setq tail head)
1211       (while (re-search-forward
1212               "^\\([0-9A-F]+\\);\\s +\\([0-9A-F]+\\);\\s +\\([oc]\\)"
1213               nil t)
1214         (let ((char (string-to-number (match-string 1) 16))
1215               (paired (match-string 2)))
1216           (setq tail (setcdr tail (list (list char paired)))))))
1217     (cdr head)))
1218
1219 (defun unidata-gen-bracket-type-list ()
1220   (let ((head (list nil))
1221         tail)
1222     (with-temp-buffer
1223       (insert-file-contents (expand-file-name "BidiBrackets.txt" unidata-dir))
1224       (goto-char (point-min))
1225       (setq tail head)
1226       (while (re-search-forward
1227               "^\\([0-9A-F]+\\);\\s +\\([0-9A-F]+\\);\\s +\\([oc]\\)"
1228               nil t)
1229         (let ((char (string-to-number (match-string 1) 16))
1230               (type (match-string 3)))
1231           (setq tail (setcdr tail (list (list char type)))))))
1232     (cdr head)))
1233
1234 ;; Verify if we can retrieve correct values from the generated
1235 ;; char-tables.
1236 ;;
1237 ;; Use like this:
1238 ;;
1239 ;; (let ((unidata-dir "/path/to/admin/unidata"))
1240 ;;   (unidata-setup-list "unidata.txt")
1241 ;;   (unidata-check))
1242
1243 (defun unidata-check ()
1244   (dolist (elt unidata-prop-alist)
1245     (let* ((prop (car elt))
1246            (index (unidata-prop-index prop))
1247            (generator (unidata-prop-generator prop))
1248            (default-value (unidata-prop-default prop))
1249            (val-list (unidata-prop-val-list prop))
1250            (table (progn
1251                     (message "Generating %S table..." prop)
1252                     (funcall generator prop default-value val-list)))
1253            (decoder (char-table-extra-slot table 1))
1254            (alist (and (functionp index)
1255                        (funcall index)))
1256            (check #x400))
1257       (dolist (e unidata-list)
1258         (let* ((char (car e))
1259                (val1
1260                 (if alist (nth 1 (assoc char alist))
1261                   (nth index e)))
1262                val2)
1263           (if (and (stringp val1) (= (length val1) 0))
1264               (setq val1 nil))
1265           (unless (or (consp char)
1266                       (integerp decoder))
1267             (setq val2
1268                   (cond ((functionp decoder)
1269                          (funcall decoder char (aref table char) table))
1270                         (t              ; must be nil
1271                          (aref table char))))
1272             (if val1
1273                 (cond ((eq generator 'unidata-gen-table-symbol)
1274                        (setq val1 (intern val1)))
1275                       ((eq generator 'unidata-gen-table-integer)
1276                        (setq val1 (string-to-number val1)))
1277                       ((eq generator 'unidata-gen-table-character)
1278                        (setq val1 (string-to-number val1 16)))
1279                       ((eq generator 'unidata-gen-table-decomposition)
1280                        (setq val1 (unidata-split-decomposition val1))))
1281               (cond ((eq prop 'decomposition)
1282                      (setq val1 (list char)))
1283                     ((eq prop 'bracket-type)
1284                      (setq val1 'n))))
1285             (when (>= char check)
1286               (message "%S %04X" prop check)
1287               (setq check (+ check #x400)))
1288             (or (equal val1 val2)
1289                 ;; <control> characters get a 'name' property of nil
1290                 (and (eq prop 'name) (string= val1 "<control>") (null val2))
1291                 (insert (format "> %04X %S\n< %04X %S\n"
1292                                 char val1 char val2)))
1293             (sit-for 0)))))))
1294
1295 ;; The entry function.  It generates files described in the header
1296 ;; comment of this file.
1297
1298 ;; Write files (charprop.el, uni-*.el) to dest-dir (default PWD),
1299 ;; using as input files from data-dir, and
1300 ;; unidata-text-file (default "unidata.txt" in PWD).
1301 (defun unidata-gen-files (&optional data-dir dest-dir unidata-text-file)
1302   (or data-dir
1303       (setq data-dir (pop command-line-args-left)
1304             dest-dir (or (pop command-line-args-left) default-directory)
1305             unidata-text-file (or (pop command-line-args-left)
1306                                   (expand-file-name "unidata.txt"))))
1307   (let ((coding-system-for-write 'utf-8-unix)
1308         (coding-system-for-read 'utf-8)
1309         (charprop-file (expand-file-name "charprop.el" dest-dir))
1310         (unidata-dir data-dir))
1311     (dolist (elt unidata-prop-alist)
1312       (let* ((prop (car elt))
1313              (file (expand-file-name (unidata-prop-file prop) dest-dir)))
1314         (if (file-exists-p file)
1315             (delete-file file))))
1316     (unidata-setup-list unidata-text-file)
1317     (with-temp-file charprop-file
1318       (insert ";; Automatically generated by unidata-gen.el.\n")
1319       (dolist (elt unidata-prop-alist)
1320         (let* ((prop (car elt))
1321                (generator (unidata-prop-generator prop))
1322                (file (expand-file-name (unidata-prop-file prop) dest-dir))
1323                (basename (file-name-nondirectory file))
1324                (docstring (unidata-prop-docstring prop))
1325                (describer (unidata-prop-describer prop))
1326                (default-value (unidata-prop-default prop))
1327                (val-list (unidata-prop-val-list prop))
1328                ;; Avoid creating backup files for those uni-*.el files
1329                ;; that hold more than one table.
1330                (backup-inhibited t)
1331                table)
1332           ;; Filename in this comment line is extracted by sed in
1333           ;; Makefile.
1334           (insert (format ";; FILE: %s\n" basename))
1335           (insert (format "(define-char-code-property '%S %S\n  %S)\n"
1336                           prop basename docstring))
1337           (with-temp-buffer
1338             (or noninteractive (message "Generating %s..." file))
1339             (when (file-exists-p file)
1340               (insert-file-contents file)
1341               (goto-char (point-max))
1342               (search-backward ";; Local Variables:"))
1343             (setq table (funcall generator prop default-value val-list))
1344             (when describer
1345               (unless (subrp (symbol-function describer))
1346                 (unidata--ensure-compiled describer)
1347                 (setq describer (symbol-function describer)))
1348               (set-char-table-extra-slot table 3 describer))
1349             (if (bobp)
1350                 (insert ";; Copyright (C) 1991-2014 Unicode, Inc.
1351 ;; This file was generated from the Unicode data files at
1352 ;; http://www.unicode.org/Public/UNIDATA/.
1353 ;; See lisp/international/README for the copyright and permission notice.\n"))
1354             (insert (format "(define-char-code-property '%S\n  %S\n  %S)\n"
1355                             prop table docstring))
1356             (if (eobp)
1357                 (insert ";; Local Variables:\n"
1358                         ";; coding: utf-8\n"
1359                         ";; version-control: never\n"
1360                         ";; no-byte-compile: t\n"
1361                         ";; no-update-autoloads: t\n"
1362                         ";; End:\n\n"
1363                         (format ";; %s ends here\n" basename)))
1364             (write-file file)
1365             (or noninteractive (message "Generating %s...done" file)))))
1366       (message "Writing %s..." charprop-file)
1367       (insert ";; Local Variables:\n"
1368               ";; coding: utf-8\n"
1369               ";; version-control: never\n"
1370               ";; no-byte-compile: t\n"
1371               ";; no-update-autoloads: t\n"
1372               ";; End:\n\n"
1373               (format ";; %s ends here\n"
1374                       (file-name-nondirectory charprop-file))))))
1375
1376 \f
1377
1378 ;;; unidata-gen.el ends here