root/src/chartab.c

DEFINITIONS

1. CHECK_CHAR_TABLE
2. set_char_table_ascii
3. set_char_table_parent
4. make_sub_char_table
5. char_table_ascii
6. copy_sub_char_table
7. copy_char_table
8. sub_char_table_ref
9. char_table_ref
10. char_table_ref_simple
11. sub_char_table_ref_and_range
12. char_table_ref_and_range
13. sub_char_table_set
14. char_table_set
15. sub_char_table_set_range
16. char_table_set_range
17. DEFUN
18. DEFUN
19. optimize_sub_char_table
20. map_sub_char_table
21. map_char_table
22. map_sub_char_table_for_charset
23. map_char_table_for_charset
24. uniprop_table_uncompress
25. uniprop_decode_value_run_length
26. uniprop_get_decoder
27. uniprop_encode_value_character
28. uniprop_encode_value_run_length
29. uniprop_encode_value_numeric
30. uniprop_get_encoder
31. uniprop_table
32. DEFUN
33. get_unicode_property
34. syms_of_chartab

     1 /* chartab.c -- char-table support
     2    Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
     3      National Institute of Advanced Industrial Science and Technology (AIST)
     4      Registration Number H13PRO009
     5 
     6 This file is part of GNU Emacs.
     7 
     8 GNU Emacs is free software: you can redistribute it and/or modify
     9 it under the terms of the GNU General Public License as published by
    10 the Free Software Foundation, either version 3 of the License, or (at
    11 your option) any later version.
    12 
    13 GNU Emacs is distributed in the hope that it will be useful,
    14 but WITHOUT ANY WARRANTY; without even the implied warranty of
    15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16 GNU General Public License for more details.
    17 
    18 You should have received a copy of the GNU General Public License
    19 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    20 
    21 #include <config.h>
    22 
    23 #include "lisp.h"
    24 #include "character.h"
    25 #include "charset.h"
    26 
    27 /* 64/16/32/128 */
    28 
    29 /* Number of elements in Nth level char-table.  */
    30 const int chartab_size[4] =
    31   { (1 << CHARTAB_SIZE_BITS_0),
    32     (1 << CHARTAB_SIZE_BITS_1),
    33     (1 << CHARTAB_SIZE_BITS_2),
    34     (1 << CHARTAB_SIZE_BITS_3) };
    35 
    36 /* Number of characters each element of Nth level char-table
    37    covers.  */
    38 static const int chartab_chars[4] =
    39   { (1 << (CHARTAB_SIZE_BITS_1 + CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3)),
    40     (1 << (CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3)),
    41     (1 << CHARTAB_SIZE_BITS_3),
    42     1 };
    43 
    44 /* Number of characters (in bits) each element of Nth level char-table
    45    covers.  */
    46 static const int chartab_bits[4] =
    47   { (CHARTAB_SIZE_BITS_1 + CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3),
    48     (CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3),
    49     CHARTAB_SIZE_BITS_3,
    50     0 };
    51 
    52 #define CHARTAB_IDX(c, depth, min_char)         \
    53   (((c) - (min_char)) >> chartab_bits[(depth)])
    54 
    55 
    56 /* Preamble for uniprop (Unicode character property) tables.  See the
    57    comment of "Unicode character property tables".  */
    58 
    59 /* Types of decoder and encoder functions for uniprop values.  */
    60 typedef Lisp_Object (*uniprop_decoder_t) (Lisp_Object, Lisp_Object);
    61 typedef Lisp_Object (*uniprop_encoder_t) (Lisp_Object, Lisp_Object);
    62 
    63 static Lisp_Object uniprop_table_uncompress (Lisp_Object, int);
    64 static uniprop_decoder_t uniprop_get_decoder (Lisp_Object);
    65 static Lisp_Object
    66 sub_char_table_ref_and_range (Lisp_Object, int, int *, int *,
    67                               Lisp_Object, bool);
    68 
    69 /* 1 iff TABLE is a uniprop table.  */
    70 #define UNIPROP_TABLE_P(TABLE)                                  \
    71   (EQ (XCHAR_TABLE (TABLE)->purpose, Qchar_code_property_table) \
    72    && CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (TABLE)) == 5)
    73 
    74 /* Return a decoder for values in the uniprop table TABLE.  */
    75 #define UNIPROP_GET_DECODER(TABLE)      \
    76   (UNIPROP_TABLE_P (TABLE) ? uniprop_get_decoder (TABLE) : NULL)
    77 
    78 /* Nonzero iff OBJ is a string representing uniprop values of 128
    79    succeeding characters (the bottom level of a char-table) by a
    80    compressed format.  We are sure that no property value has a string
    81    starting with '\001' nor '\002'.  */
    82 #define UNIPROP_COMPRESSED_FORM_P(OBJ)  \
    83   (STRINGP (OBJ) && SCHARS (OBJ) > 0    \
    84    && ((SREF (OBJ, 0) == 1 || (SREF (OBJ, 0) == 2))))
    85 
    86 static void
    87 CHECK_CHAR_TABLE (Lisp_Object x)
    88 {
    89   CHECK_TYPE (CHAR_TABLE_P (x), Qchar_table_p, x);
    90 }
    91 
    92 static void
    93 set_char_table_ascii (Lisp_Object table, Lisp_Object val)
    94 {
    95   XCHAR_TABLE (table)->ascii = val;
    96 }
    97 static void
    98 set_char_table_parent (Lisp_Object table, Lisp_Object val)
    99 {
   100   XCHAR_TABLE (table)->parent = val;
   101 }
   102 
   103 DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
   104        doc: /* Return a newly created char-table, with purpose PURPOSE.
   105 Each element is initialized to INIT, which defaults to nil.
   106 
   107 PURPOSE should be a symbol.  If it has a `char-table-extra-slots'
   108 property, the property's value should be an integer between 0 and 10
   109 that specifies how many extra slots the char-table has.  Otherwise,
   110 the char-table has no extra slot.  */)
   111   (register Lisp_Object purpose, Lisp_Object init)
   112 {
   113   Lisp_Object vector;
   114   Lisp_Object n;
   115   int n_extras;
   116   int size;
   117 
   118   CHECK_SYMBOL (purpose);
   119   n = Fget (purpose, Qchar_table_extra_slots);
   120   if (NILP (n))
   121     n_extras = 0;
   122   else
   123     {
   124       CHECK_FIXNAT (n);
   125       if (XFIXNUM (n) > 10)
   126         args_out_of_range (n, Qnil);
   127       n_extras = XFIXNUM (n);
   128     }
   129 
   130   size = CHAR_TABLE_STANDARD_SLOTS + n_extras;
   131   vector = make_vector (size, init);
   132   XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
   133   set_char_table_parent (vector, Qnil);
   134   set_char_table_purpose (vector, purpose);
   135   XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
   136   return vector;
   137 }
   138 
   139 static Lisp_Object
   140 make_sub_char_table (int depth, int min_char, Lisp_Object defalt)
   141 {
   142   int i;
   143   Lisp_Object table = make_uninit_sub_char_table (depth, min_char);
   144 
   145   for (i = 0; i < chartab_size[depth]; i++)
   146     XSUB_CHAR_TABLE (table)->contents[i] = defalt;
   147   return table;
   148 }
   149 
   150 static Lisp_Object
   151 char_table_ascii (Lisp_Object table)
   152 {
   153   Lisp_Object sub, val;
   154 
   155   sub = XCHAR_TABLE (table)->contents[0];
   156   if (! SUB_CHAR_TABLE_P (sub))
   157     return sub;
   158   sub = XSUB_CHAR_TABLE (sub)->contents[0];
   159   if (! SUB_CHAR_TABLE_P (sub))
   160     return sub;
   161   val = XSUB_CHAR_TABLE (sub)->contents[0];
   162   if (UNIPROP_TABLE_P (table) && UNIPROP_COMPRESSED_FORM_P (val))
   163     val = uniprop_table_uncompress (sub, 0);
   164   return val;
   165 }
   166 
   167 static Lisp_Object
   168 copy_sub_char_table (Lisp_Object table)
   169 {
   170   int depth = XSUB_CHAR_TABLE (table)->depth;
   171   int min_char = XSUB_CHAR_TABLE (table)->min_char;
   172   Lisp_Object copy = make_sub_char_table (depth, min_char, Qnil);
   173   int i;
   174 
   175   /* Recursively copy any sub char-tables.  */
   176   for (i = 0; i < chartab_size[depth]; i++)
   177     {
   178       Lisp_Object val = XSUB_CHAR_TABLE (table)->contents[i];
   179       set_sub_char_table_contents
   180         (copy, i, SUB_CHAR_TABLE_P (val) ? copy_sub_char_table (val) : val);
   181     }
   182 
   183   return copy;
   184 }
   185 
   186 
   187 Lisp_Object
   188 copy_char_table (Lisp_Object table)
   189 {
   190   int size = PVSIZE (table);
   191   Lisp_Object copy = make_nil_vector (size);
   192   XSETPVECTYPE (XVECTOR (copy), PVEC_CHAR_TABLE);
   193   set_char_table_defalt (copy, XCHAR_TABLE (table)->defalt);
   194   set_char_table_parent (copy, XCHAR_TABLE (table)->parent);
   195   set_char_table_purpose (copy, XCHAR_TABLE (table)->purpose);
   196   for (int i = 0; i < chartab_size[0]; i++)
   197     set_char_table_contents
   198       (copy, i,
   199        (SUB_CHAR_TABLE_P (XCHAR_TABLE (table)->contents[i])
   200         ? copy_sub_char_table (XCHAR_TABLE (table)->contents[i])
   201         : XCHAR_TABLE (table)->contents[i]));
   202   set_char_table_ascii (copy, char_table_ascii (copy));
   203   size -= CHAR_TABLE_STANDARD_SLOTS;
   204   for (int i = 0; i < size; i++)
   205     set_char_table_extras (copy, i, XCHAR_TABLE (table)->extras[i]);
   206 
   207   XSETCHAR_TABLE (copy, XCHAR_TABLE (copy));
   208   return copy;
   209 }
   210 
   211 static Lisp_Object
   212 sub_char_table_ref (Lisp_Object table, int c, bool is_uniprop)
   213 {
   214   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
   215   Lisp_Object val;
   216   int idx = CHARTAB_IDX (c, tbl->depth, tbl->min_char);
   217 
   218   val = tbl->contents[idx];
   219   if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val))
   220     val = uniprop_table_uncompress (table, idx);
   221   if (SUB_CHAR_TABLE_P (val))
   222     val = sub_char_table_ref (val, c, is_uniprop);
   223   return val;
   224 }
   225 
   226 Lisp_Object
   227 char_table_ref (Lisp_Object table, int c)
   228 {
   229   struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
   230   Lisp_Object val;
   231 
   232   if (ASCII_CHAR_P (c))
   233     {
   234       val = tbl->ascii;
   235       if (SUB_CHAR_TABLE_P (val))
   236         val = XSUB_CHAR_TABLE (val)->contents[c];
   237     }
   238   else
   239     {
   240       val = tbl->contents[CHARTAB_IDX (c, 0, 0)];
   241       if (SUB_CHAR_TABLE_P (val))
   242         val = sub_char_table_ref (val, c, UNIPROP_TABLE_P (table));
   243     }
   244   if (NILP (val))
   245     {
   246       val = tbl->defalt;
   247       if (NILP (val) && CHAR_TABLE_P (tbl->parent))
   248         val = char_table_ref (tbl->parent, c);
   249     }
   250   return val;
   251 }
   252 
   253 static inline Lisp_Object
   254 char_table_ref_simple (Lisp_Object table, int idx, int c, int *from, int *to,
   255                        Lisp_Object defalt, bool is_uniprop, bool is_subtable)
   256 {
   257   Lisp_Object val = is_subtable ?
   258     XSUB_CHAR_TABLE (table)->contents[idx]:
   259     XCHAR_TABLE (table)->contents[idx];
   260   if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val))
   261     val = uniprop_table_uncompress (table, idx);
   262   if (SUB_CHAR_TABLE_P (val))
   263     val = sub_char_table_ref_and_range (val, c, from, to,
   264                                         defalt, is_uniprop);
   265   else if (NILP (val))
   266     val = defalt;
   267   return val;
   268 }
   269 
   270 static Lisp_Object
   271 sub_char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to,
   272                               Lisp_Object defalt, bool is_uniprop)
   273 {
   274   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
   275   int depth = tbl->depth, min_char = tbl->min_char;
   276   int chartab_idx = CHARTAB_IDX (c, depth, min_char), idx;
   277   Lisp_Object val
   278     = char_table_ref_simple (table, chartab_idx, c, from, to,
   279                              defalt, is_uniprop, true);
   280 
   281   idx = chartab_idx;
   282   while (idx > 0 && *from < min_char + idx * chartab_chars[depth])
   283     {
   284       c = min_char + idx * chartab_chars[depth] - 1;
   285       idx--;
   286       Lisp_Object this_val
   287         = char_table_ref_simple (table, idx, c, from, to,
   288                                  defalt, is_uniprop, true);
   289 
   290       if (! EQ (this_val, val))
   291         {
   292           *from = c + 1;
   293           break;
   294         }
   295     }
   296   while (((c = (chartab_idx + 1) * chartab_chars[depth])
   297           < chartab_chars[depth - 1])
   298          && (c += min_char) <= *to)
   299     {
   300       chartab_idx++;
   301       Lisp_Object this_val
   302         = char_table_ref_simple (table, chartab_idx, c, from, to,
   303                                  defalt, is_uniprop, true);
   304 
   305       if (! EQ (this_val, val))
   306         {
   307           *to = c - 1;
   308           break;
   309         }
   310     }
   311 
   312   return val;
   313 }
   314 
   315 
   316 /* Return the value for C in char-table TABLE.  Shrink the range *FROM
   317    and *TO to cover characters (containing C) that have the same value
   318    as C.  It is not assured that the values of (*FROM - 1) and (*TO +
   319    1) are different from that of C.  */
   320 
   321 Lisp_Object
   322 char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to)
   323 {
   324   struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
   325   int chartab_idx = CHARTAB_IDX (c, 0, 0);
   326   bool is_uniprop = UNIPROP_TABLE_P (table);
   327 
   328   if (*from < 0)
   329     *from = 0;
   330   if (*to < 0)
   331     *to = MAX_CHAR;
   332 
   333   Lisp_Object val
   334     = char_table_ref_simple (table, chartab_idx, c, from, to,
   335                              tbl->defalt, is_uniprop, false);
   336 
   337   int idx = chartab_idx;
   338   while (*from < idx * chartab_chars[0])
   339     {
   340       c = idx * chartab_chars[0] - 1;
   341       idx--;
   342       Lisp_Object this_val
   343         = char_table_ref_simple (table, idx, c, from, to,
   344                                  tbl->defalt, is_uniprop, false);
   345 
   346       if (! EQ (this_val, val))
   347         {
   348           *from = c + 1;
   349           break;
   350         }
   351     }
   352   while (*to >= (chartab_idx + 1) * chartab_chars[0])
   353     {
   354       chartab_idx++;
   355       c = chartab_idx * chartab_chars[0];
   356       Lisp_Object this_val
   357         = char_table_ref_simple (table, chartab_idx, c, from, to,
   358                                  tbl->defalt, is_uniprop, false);
   359 
   360       if (! EQ (this_val, val))
   361         {
   362           *to = c - 1;
   363           break;
   364         }
   365     }
   366 
   367   return val;
   368 }
   369 
   370 
   371 static void
   372 sub_char_table_set (Lisp_Object table, int c, Lisp_Object val, bool is_uniprop)
   373 {
   374   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
   375   int depth = tbl->depth, min_char = tbl->min_char;
   376   int i = CHARTAB_IDX (c, depth, min_char);
   377   Lisp_Object sub;
   378 
   379   if (depth == 3)
   380     set_sub_char_table_contents (table, i, val);
   381   else
   382     {
   383       sub = tbl->contents[i];
   384       if (! SUB_CHAR_TABLE_P (sub))
   385         {
   386           if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (sub))
   387             sub = uniprop_table_uncompress (table, i);
   388           else
   389             {
   390               sub = make_sub_char_table (depth + 1,
   391                                          min_char + i * chartab_chars[depth],
   392                                          sub);
   393               set_sub_char_table_contents (table, i, sub);
   394             }
   395         }
   396       sub_char_table_set (sub, c, val, is_uniprop);
   397     }
   398 }
   399 
   400 void
   401 char_table_set (Lisp_Object table, int c, Lisp_Object val)
   402 {
   403   struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
   404 
   405   if (ASCII_CHAR_P (c)
   406       && SUB_CHAR_TABLE_P (tbl->ascii))
   407     set_sub_char_table_contents (tbl->ascii, c, val);
   408   else
   409     {
   410       int i = CHARTAB_IDX (c, 0, 0);
   411       Lisp_Object sub;
   412 
   413       sub = tbl->contents[i];
   414       if (! SUB_CHAR_TABLE_P (sub))
   415         {
   416           sub = make_sub_char_table (1, i * chartab_chars[0], sub);
   417           set_char_table_contents (table, i, sub);
   418         }
   419       sub_char_table_set (sub, c, val, UNIPROP_TABLE_P (table));
   420       if (ASCII_CHAR_P (c))
   421         set_char_table_ascii (table, char_table_ascii (table));
   422     }
   423 }
   424 
   425 static void
   426 sub_char_table_set_range (Lisp_Object table, int from, int to, Lisp_Object val,
   427                           bool is_uniprop)
   428 {
   429   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
   430   int depth = tbl->depth, min_char = tbl->min_char;
   431   int chars_in_block = chartab_chars[depth];
   432   int i, c, lim = chartab_size[depth];
   433 
   434   if (from < min_char)
   435     from = min_char;
   436   i = CHARTAB_IDX (from, depth, min_char);
   437   c = min_char + chars_in_block * i;
   438   for (; i < lim; i++, c += chars_in_block)
   439     {
   440       if (c > to)
   441         break;
   442       if (from <= c && c + chars_in_block - 1 <= to)
   443         set_sub_char_table_contents (table, i, val);
   444       else
   445         {
   446           Lisp_Object sub = tbl->contents[i];
   447           if (! SUB_CHAR_TABLE_P (sub))
   448             {
   449               if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (sub))
   450                 sub = uniprop_table_uncompress (table, i);
   451               else
   452                 {
   453                   sub = make_sub_char_table (depth + 1, c, sub);
   454                   set_sub_char_table_contents (table, i, sub);
   455                 }
   456             }
   457           sub_char_table_set_range (sub, from, to, val, is_uniprop);
   458         }
   459     }
   460 }
   461 
   462 
   463 void
   464 char_table_set_range (Lisp_Object table, int from, int to, Lisp_Object val)
   465 {
   466   struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
   467 
   468   if (from == to)
   469     char_table_set (table, from, val);
   470   else
   471     {
   472       bool is_uniprop = UNIPROP_TABLE_P (table);
   473       int lim = CHARTAB_IDX (to, 0, 0);
   474       int i, c;
   475 
   476       for (i = CHARTAB_IDX (from, 0, 0), c = i * chartab_chars[0]; i <= lim;
   477            i++, c += chartab_chars[0])
   478         {
   479           if (c > to)
   480             break;
   481           if (from <= c && c + chartab_chars[0] - 1 <= to)
   482             set_char_table_contents (table, i, val);
   483           else
   484             {
   485               Lisp_Object sub = tbl->contents[i];
   486               if (! SUB_CHAR_TABLE_P (sub))
   487                 {
   488                   sub = make_sub_char_table (1, i * chartab_chars[0], sub);
   489                   set_char_table_contents (table, i, sub);
   490                 }
   491               sub_char_table_set_range (sub, from, to, val, is_uniprop);
   492             }
   493         }
   494       if (ASCII_CHAR_P (from))
   495         set_char_table_ascii (table, char_table_ascii (table));
   496     }
   497 }
   498 
   499 
   500 DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
   501        1, 1, 0,
   502        doc: /*
   503 Return the subtype of char-table CHAR-TABLE.  The value is a symbol.  */)
   504   (Lisp_Object char_table)
   505 {
   506   CHECK_CHAR_TABLE (char_table);
   507 
   508   return XCHAR_TABLE (char_table)->purpose;
   509 }
   510 
   511 DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
   512        1, 1, 0,
   513        doc: /* Return the parent char-table of CHAR-TABLE.
   514 The value is either nil or another char-table.
   515 If CHAR-TABLE holds nil for a given character,
   516 then the actual applicable value is inherited from the parent char-table
   517 \(or from its parents, if necessary).  */)
   518   (Lisp_Object char_table)
   519 {
   520   CHECK_CHAR_TABLE (char_table);
   521 
   522   return XCHAR_TABLE (char_table)->parent;
   523 }
   524 
   525 DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
   526        2, 2, 0,
   527        doc: /* Set the parent char-table of CHAR-TABLE to PARENT.
   528 Return PARENT.  PARENT must be either nil or another char-table.  */)
   529   (Lisp_Object char_table, Lisp_Object parent)
   530 {
   531   Lisp_Object temp;
   532 
   533   CHECK_CHAR_TABLE (char_table);
   534 
   535   if (!NILP (parent))
   536     {
   537       CHECK_CHAR_TABLE (parent);
   538 
   539       for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
   540         if (EQ (temp, char_table))
   541           error ("Attempt to make a chartable be its own parent");
   542     }
   543 
   544   set_char_table_parent (char_table, parent);
   545 
   546   return parent;
   547 }
   548 
   549 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
   550        2, 2, 0,
   551        doc: /* Return the value of CHAR-TABLE's extra-slot number N.  */)
   552   (Lisp_Object char_table, Lisp_Object n)
   553 {
   554   CHECK_CHAR_TABLE (char_table);
   555   CHECK_FIXNUM (n);
   556   if (XFIXNUM (n) < 0
   557       || XFIXNUM (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
   558     args_out_of_range (char_table, n);
   559 
   560   return XCHAR_TABLE (char_table)->extras[XFIXNUM (n)];
   561 }
   562 
   563 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
   564        Sset_char_table_extra_slot,
   565        3, 3, 0,
   566        doc: /* Set CHAR-TABLE's extra-slot number N to VALUE.  */)
   567   (Lisp_Object char_table, Lisp_Object n, Lisp_Object value)
   568 {
   569   CHECK_CHAR_TABLE (char_table);
   570   CHECK_FIXNUM (n);
   571   if (XFIXNUM (n) < 0
   572       || XFIXNUM (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
   573     args_out_of_range (char_table, n);
   574 
   575   set_char_table_extras (char_table, XFIXNUM (n), value);
   576   return value;
   577 }
   578 
   579 DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
   580        2, 2, 0,
   581        doc: /* Return the value in CHAR-TABLE for a range of characters RANGE.
   582 RANGE should be nil (for the default value),
   583 a cons of character codes (for characters in the range), or a character code.  */)
   584   (Lisp_Object char_table, Lisp_Object range)
   585 {
   586   Lisp_Object val;
   587   CHECK_CHAR_TABLE (char_table);
   588 
   589   if (NILP (range))
   590     val = XCHAR_TABLE (char_table)->defalt;
   591   else if (CHARACTERP (range))
   592     val = CHAR_TABLE_REF (char_table, XFIXNAT (range));
   593   else if (CONSP (range))
   594     {
   595       int from, to;
   596 
   597       CHECK_CHARACTER_CAR (range);
   598       CHECK_CHARACTER_CDR (range);
   599       from = XFIXNAT (XCAR (range));
   600       to = XFIXNAT (XCDR (range));
   601       val = char_table_ref_and_range (char_table, from, &from, &to);
   602       /* Not yet implemented. */
   603     }
   604   else
   605     error ("Invalid RANGE argument to `char-table-range'");
   606   return val;
   607 }
   608 
   609 DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
   610        3, 3, 0,
   611        doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
   612 RANGE should be t (for all characters), nil (for the default value),
   613 a cons of character codes (for characters in the range),
   614 or a character code.  Return VALUE.  */)
   615   (Lisp_Object char_table, Lisp_Object range, Lisp_Object value)
   616 {
   617   CHECK_CHAR_TABLE (char_table);
   618   if (EQ (range, Qt))
   619     {
   620       int i;
   621 
   622       set_char_table_ascii (char_table, value);
   623       for (i = 0; i < chartab_size[0]; i++)
   624         set_char_table_contents (char_table, i, value);
   625     }
   626   else if (NILP (range))
   627     set_char_table_defalt (char_table, value);
   628   else if (CHARACTERP (range))
   629     char_table_set (char_table, XFIXNUM (range), value);
   630   else if (CONSP (range))
   631     {
   632       CHECK_CHARACTER_CAR (range);
   633       CHECK_CHARACTER_CDR (range);
   634       char_table_set_range (char_table,
   635                             XFIXNUM (XCAR (range)), XFIXNUM (XCDR (range)), value);
   636     }
   637   else
   638     error ("Invalid RANGE argument to `set-char-table-range'");
   639 
   640   return value;
   641 }
   642 
   643 static Lisp_Object
   644 optimize_sub_char_table (Lisp_Object table, Lisp_Object test)
   645 {
   646   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
   647   int i, depth = tbl->depth;
   648   Lisp_Object elt, this;
   649   bool optimizable;
   650 
   651   elt = XSUB_CHAR_TABLE (table)->contents[0];
   652   if (SUB_CHAR_TABLE_P (elt))
   653     {
   654       elt = optimize_sub_char_table (elt, test);
   655       set_sub_char_table_contents (table, 0, elt);
   656     }
   657   optimizable = SUB_CHAR_TABLE_P (elt) ? 0 : 1;
   658   for (i = 1; i < chartab_size[depth]; i++)
   659     {
   660       this = XSUB_CHAR_TABLE (table)->contents[i];
   661       if (SUB_CHAR_TABLE_P (this))
   662         {
   663           this = optimize_sub_char_table (this, test);
   664           set_sub_char_table_contents (table, i, this);
   665         }
   666       if (optimizable
   667           && (NILP (test) ? NILP (Fequal (this, elt)) /* defaults to `equal'. */
   668               : EQ (test, Qeq) ? !EQ (this, elt)      /* Optimize `eq' case.  */
   669               : NILP (call2 (test, this, elt))))
   670         optimizable = 0;
   671     }
   672 
   673   return (optimizable ? elt : table);
   674 }
   675 
   676 DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
   677        1, 2, 0,
   678        doc: /* Optimize CHAR-TABLE.
   679 TEST is the comparison function used to decide whether two entries are
   680 equivalent and can be merged.  It defaults to `equal'.  */)
   681   (Lisp_Object char_table, Lisp_Object test)
   682 {
   683   Lisp_Object elt;
   684   int i;
   685 
   686   CHECK_CHAR_TABLE (char_table);
   687 
   688   for (i = 0; i < chartab_size[0]; i++)
   689     {
   690       elt = XCHAR_TABLE (char_table)->contents[i];
   691       if (SUB_CHAR_TABLE_P (elt))
   692         set_char_table_contents
   693           (char_table, i, optimize_sub_char_table (elt, test));
   694     }
   695   /* Reset the `ascii' cache, in case it got optimized away.  */
   696   set_char_table_ascii (char_table, char_table_ascii (char_table));
   697 
   698   return Qnil;
   699 }
   700 
   701 
   702 /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
   703    calling it for each character or group of characters that share a
   704    value.  RANGE is a cons (FROM . TO) specifying the range of target
   705    characters, VAL is a value of FROM in TABLE, TOP is the top
   706    char-table.
   707 
   708    ARG is passed to C_FUNCTION when that is called.
   709 
   710    It returns the value of last character covered by TABLE (not the
   711    value inherited from the parent), and by side-effect, the car part
   712    of RANGE is updated to the minimum character C where C and all the
   713    following characters in TABLE have the same value.  */
   714 
   715 static Lisp_Object
   716 map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
   717                     Lisp_Object function, Lisp_Object table, Lisp_Object arg, Lisp_Object val,
   718                     Lisp_Object range, Lisp_Object top)
   719 {
   720   /* Depth of TABLE.  */
   721   int depth;
   722   /* Minimum and maximum characters covered by TABLE. */
   723   int min_char, max_char;
   724   /* Number of characters covered by one element of TABLE.  */
   725   int chars_in_block;
   726   int from = XFIXNUM (XCAR (range)), to = XFIXNUM (XCDR (range));
   727   int i, c;
   728   bool is_uniprop = UNIPROP_TABLE_P (top);
   729   uniprop_decoder_t decoder = UNIPROP_GET_DECODER (top);
   730 
   731   if (SUB_CHAR_TABLE_P (table))
   732     {
   733       struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
   734 
   735       depth = tbl->depth;
   736       min_char = tbl->min_char;
   737       max_char = min_char + chartab_chars[depth - 1] - 1;
   738     }
   739   else
   740     {
   741       depth = 0;
   742       min_char = 0;
   743       max_char = MAX_CHAR;
   744     }
   745   chars_in_block = chartab_chars[depth];
   746 
   747   if (to < max_char)
   748     max_char = to;
   749   /* Set I to the index of the first element to check.  */
   750   if (from <= min_char)
   751     i = 0;
   752   else
   753     i = (from - min_char) / chars_in_block;
   754   for (c = min_char + chars_in_block * i; c <= max_char;
   755        i++, c += chars_in_block)
   756     {
   757       Lisp_Object this = (SUB_CHAR_TABLE_P (table)
   758                           ? XSUB_CHAR_TABLE (table)->contents[i]
   759                           : XCHAR_TABLE (table)->contents[i]);
   760       int nextc = c + chars_in_block;
   761 
   762       if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this))
   763         this = uniprop_table_uncompress (table, i);
   764       if (SUB_CHAR_TABLE_P (this))
   765         {
   766           if (to >= nextc)
   767             XSETCDR (range, make_fixnum (nextc - 1));
   768           val = map_sub_char_table (c_function, function, this, arg,
   769                                     val, range, top);
   770         }
   771       else
   772         {
   773           if (NILP (this))
   774             this = XCHAR_TABLE (top)->defalt;
   775           if (!EQ (val, this))
   776             {
   777               bool different_value = 1;
   778 
   779               if (NILP (val))
   780                 {
   781                   if (! NILP (XCHAR_TABLE (top)->parent))
   782                     {
   783                       Lisp_Object parent = XCHAR_TABLE (top)->parent;
   784                       Lisp_Object temp = XCHAR_TABLE (parent)->parent;
   785 
   786                       /* This is to get a value of FROM in PARENT
   787                          without checking the parent of PARENT.  */
   788                       set_char_table_parent (parent, Qnil);
   789                       val = CHAR_TABLE_REF (parent, from);
   790                       set_char_table_parent (parent, temp);
   791                       XSETCDR (range, make_fixnum (c - 1));
   792                       val = map_sub_char_table (c_function, function,
   793                                                 parent, arg, val, range,
   794                                                 parent);
   795                       if (EQ (val, this))
   796                         different_value = 0;
   797                     }
   798                 }
   799               if (! NILP (val) && different_value)
   800                 {
   801                   XSETCDR (range, make_fixnum (c - 1));
   802                   if (EQ (XCAR (range), XCDR (range)))
   803                     {
   804                       if (c_function)
   805                         (*c_function) (arg, XCAR (range), val);
   806                       else
   807                         {
   808                           if (decoder)
   809                             val = decoder (top, val);
   810                           call2 (function, XCAR (range), val);
   811                         }
   812                     }
   813                   else
   814                     {
   815                       if (c_function)
   816                         (*c_function) (arg, range, val);
   817                       else
   818                         {
   819                           if (decoder)
   820                             val = decoder (top, val);
   821                           call2 (function, range, val);
   822                         }
   823                     }
   824                 }
   825               val = this;
   826               from = c;
   827               XSETCAR (range, make_fixnum (c));
   828             }
   829         }
   830       XSETCDR (range, make_fixnum (to));
   831     }
   832   return val;
   833 }
   834 
   835 
   836 /* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
   837    character or group of characters that share a value.
   838 
   839    ARG is passed to C_FUNCTION when that is called.  */
   840 
   841 void
   842 map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
   843                 Lisp_Object function, Lisp_Object table, Lisp_Object arg)
   844 {
   845   Lisp_Object range, val, parent;
   846   uniprop_decoder_t decoder = UNIPROP_GET_DECODER (table);
   847 
   848   range = Fcons (make_fixnum (0), make_fixnum (MAX_CHAR));
   849   parent = XCHAR_TABLE (table)->parent;
   850 
   851   val = XCHAR_TABLE (table)->ascii;
   852   if (SUB_CHAR_TABLE_P (val))
   853     val = XSUB_CHAR_TABLE (val)->contents[0];
   854   val = map_sub_char_table (c_function, function, table, arg, val, range,
   855                             table);
   856 
   857   /* If VAL is nil and TABLE has a parent, we must consult the parent
   858      recursively.  */
   859   while (NILP (val) && ! NILP (XCHAR_TABLE (table)->parent))
   860     {
   861       Lisp_Object temp;
   862       int from = XFIXNUM (XCAR (range));
   863 
   864       parent = XCHAR_TABLE (table)->parent;
   865       temp = XCHAR_TABLE (parent)->parent;
   866       /* This is to get a value of FROM in PARENT without checking the
   867          parent of PARENT.  */
   868       set_char_table_parent (parent, Qnil);
   869       val = CHAR_TABLE_REF (parent, from);
   870       set_char_table_parent (parent, temp);
   871       val = map_sub_char_table (c_function, function, parent, arg, val, range,
   872                                 parent);
   873       table = parent;
   874     }
   875 
   876   if (! NILP (val))
   877     {
   878       if (EQ (XCAR (range), XCDR (range)))
   879         {
   880           if (c_function)
   881             (*c_function) (arg, XCAR (range), val);
   882           else
   883             {
   884               if (decoder)
   885                 val = decoder (table, val);
   886               call2 (function, XCAR (range), val);
   887             }
   888         }
   889       else
   890         {
   891           if (c_function)
   892             (*c_function) (arg, range, val);
   893           else
   894             {
   895               if (decoder)
   896                 val = decoder (table, val);
   897               call2 (function, range, val);
   898             }
   899         }
   900     }
   901 }
   902 
   903 DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
   904   2, 2, 0,
   905        doc: /* Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
   906 FUNCTION is called with two arguments, KEY and VALUE.
   907 KEY is a character code or a cons of character codes specifying a
   908 range of characters that have the same value.
   909 VALUE is what (char-table-range CHAR-TABLE KEY) returns.  */)
   910   (Lisp_Object function, Lisp_Object char_table)
   911 {
   912   CHECK_CHAR_TABLE (char_table);
   913 
   914   map_char_table (NULL, function, char_table, char_table);
   915   return Qnil;
   916 }
   917 
   918 
   919 static void
   920 map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
   921                                 Lisp_Object function, Lisp_Object table, Lisp_Object arg,
   922                                 Lisp_Object range, struct charset *charset,
   923                                 unsigned from, unsigned to)
   924 {
   925   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
   926   int i, c = tbl->min_char, depth = tbl->depth;
   927 
   928   if (depth < 3)
   929     for (i = 0; i < chartab_size[depth]; i++, c += chartab_chars[depth])
   930       {
   931         Lisp_Object this;
   932 
   933         this = tbl->contents[i];
   934         if (SUB_CHAR_TABLE_P (this))
   935           map_sub_char_table_for_charset (c_function, function, this, arg,
   936                                           range, charset, from, to);
   937         else
   938           {
   939             if (! NILP (XCAR (range)))
   940               {
   941                 XSETCDR (range, make_fixnum (c - 1));
   942                 if (c_function)
   943                   (*c_function) (arg, range);
   944                 else
   945                   call2 (function, range, arg);
   946               }
   947             XSETCAR (range, Qnil);
   948           }
   949       }
   950   else
   951     for (i = 0; i < chartab_size[depth]; i++, c++)
   952       {
   953         Lisp_Object this;
   954         unsigned code;
   955 
   956         this = tbl->contents[i];
   957         if (NILP (this)
   958             || (charset
   959                 && (code = ENCODE_CHAR (charset, c),
   960                     (code < from || code > to))))
   961           {
   962             if (! NILP (XCAR (range)))
   963               {
   964                 XSETCDR (range, make_fixnum (c - 1));
   965                 if (c_function)
   966                   (*c_function) (arg, range);
   967                 else
   968                   call2 (function, range, arg);
   969                 XSETCAR (range, Qnil);
   970               }
   971           }
   972         else
   973           {
   974             if (NILP (XCAR (range)))
   975               XSETCAR (range, make_fixnum (c));
   976           }
   977       }
   978 }
   979 
   980 
   981 /* Support function for `map-charset-chars'.  Map C_FUNCTION or
   982    FUNCTION over TABLE, calling it for each character or a group of
   983    succeeding characters that have non-nil value in TABLE.  TABLE is a
   984    "mapping table" or a "deunifier table" of a certain charset.
   985 
   986    If CHARSET is not NULL (this is the case that `map-charset-chars'
   987    is called with non-nil FROM-CODE and TO-CODE), it is a charset that
   988    owns TABLE, and the function is called only for characters in the
   989    range FROM and TO.  FROM and TO are not character codes, but code
   990    points of characters in CHARSET (see 'decode-char').
   991 
   992    This function is called in these two cases:
   993 
   994    (1) A charset has a mapping file name in :map property.
   995 
   996    (2) A charset has an upper code space in :offset property and a
   997    mapping file name in :unify-map property.  In this case, this
   998    function is called only for characters in the Unicode code space.
   999    Characters in upper code space are handled directly in
  1000    map_charset_chars.  */
  1001 
  1002 void
  1003 map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
  1004                             Lisp_Object function, Lisp_Object table, Lisp_Object arg,
  1005                             struct charset *charset,
  1006                             unsigned from, unsigned to)
  1007 {
  1008   Lisp_Object range;
  1009   int c, i;
  1010 
  1011   range = Fcons (Qnil, Qnil);
  1012 
  1013   for (i = 0, c = 0; i < chartab_size[0]; i++, c += chartab_chars[0])
  1014     {
  1015       Lisp_Object this;
  1016 
  1017       this = XCHAR_TABLE (table)->contents[i];
  1018       if (SUB_CHAR_TABLE_P (this))
  1019         map_sub_char_table_for_charset (c_function, function, this, arg,
  1020                                         range, charset, from, to);
  1021       else
  1022         {
  1023           if (! NILP (XCAR (range)))
  1024             {
  1025               XSETCDR (range, make_fixnum (c - 1));
  1026               if (c_function)
  1027                 (*c_function) (arg, range);
  1028               else
  1029                 call2 (function, range, arg);
  1030             }
  1031           XSETCAR (range, Qnil);
  1032         }
  1033     }
  1034   if (! NILP (XCAR (range)))
  1035     {
  1036       XSETCDR (range, make_fixnum (c - 1));
  1037       if (c_function)
  1038         (*c_function) (arg, range);
  1039       else
  1040         call2 (function, range, arg);
  1041     }
  1042 }
  1043 
  1044 
  1045 /* Unicode character property tables.
  1046 
  1047    This section provides a convenient and efficient way to get Unicode
  1048    character properties of characters from C code (from Lisp, you must
  1049    use get-char-code-property).
  1050 
  1051    The typical usage is to get a char-table object for a specific
  1052    property like this (use of the "bidi-class" property below is just
  1053    an example):
  1054 
  1055         Lisp_Object bidi_class_table = uniprop_table (intern ("bidi-class"));
  1056 
  1057    (uniprop_table can return nil if it fails to find data for the
  1058    named property, or if it fails to load the appropriate Lisp support
  1059    file, so the return value should be tested to be non-nil, before it
  1060    is used.)
  1061 
  1062    To get a property value for character CH use CHAR_TABLE_REF:
  1063 
  1064         Lisp_Object bidi_class = CHAR_TABLE_REF (bidi_class_table, CH);
  1065 
  1066    In this case, what you actually get is an index number to the
  1067    vector of property values (symbols nil, L, R, etc).
  1068 
  1069    The full list of Unicode character properties supported by Emacs is
  1070    documented in the ELisp manual, in the node "Character Properties".
  1071 
  1072    A table for Unicode character property has these characteristics:
  1073 
  1074    o The purpose is `char-code-property-table', which implies that the
  1075    table has 5 extra slots.
  1076 
  1077    o The second extra slot is a Lisp function, an index (integer) to
  1078    the array uniprop_decoder[], or nil.  If it is a Lisp function, we
  1079    can't use such a table from C (at the moment).  If it is nil, it
  1080    means that we don't have to decode values.
  1081 
  1082    o The third extra slot is a Lisp function, an index (integer) to
  1083    the array uniprop_encoder[], or nil.  If it is a Lisp function, we
  1084    can't use such a table from C (at the moment).  If it is nil, it
  1085    means that we don't have to encode values.  */
  1086 
  1087 
  1088 /* Uncompress the IDXth element of sub-char-table TABLE.  */
  1089 
  1090 static Lisp_Object
  1091 uniprop_table_uncompress (Lisp_Object table, int idx)
  1092 {
  1093   Lisp_Object val = XSUB_CHAR_TABLE (table)->contents[idx];
  1094   int min_char = XSUB_CHAR_TABLE (table)->min_char + chartab_chars[2] * idx;
  1095   Lisp_Object sub = make_sub_char_table (3, min_char, Qnil);
  1096   const unsigned char *p, *pend;
  1097 
  1098   set_sub_char_table_contents (table, idx, sub);
  1099   p = SDATA (val), pend = p + SBYTES (val);
  1100   if (*p == 1)
  1101     {
  1102       /* SIMPLE TABLE */
  1103       p++;
  1104       idx = string_char_advance (&p);
  1105       while (p < pend && idx < chartab_chars[2])
  1106         {
  1107           int v = string_char_advance (&p);
  1108           set_sub_char_table_contents
  1109             (sub, idx++, v > 0 ? make_fixnum (v) : Qnil);
  1110         }
  1111     }
  1112   else if (*p == 2)
  1113     {
  1114       /* RUN-LENGTH TABLE */
  1115       p++;
  1116       for (idx = 0; p < pend; )
  1117         {
  1118           int v = string_char_advance (&p);
  1119           int count = 1;
  1120 
  1121           if (p < pend)
  1122             {
  1123               int len;
  1124               count = string_char_and_length (p, &len);
  1125               if (count < 128)
  1126                 count = 1;
  1127               else
  1128                 {
  1129                   count -= 128;
  1130                   p += len;
  1131                 }
  1132             }
  1133           while (count-- > 0)
  1134             set_sub_char_table_contents (sub, idx++, make_fixnum (v));
  1135         }
  1136     }
  1137 /* It seems that we don't need this function because C code won't need
  1138    to get a property that is compressed in this form.  */
  1139 #if 0
  1140   else if (*p == 0)
  1141     {
  1142       /* WORD-LIST TABLE */
  1143     }
  1144 #endif
  1145   return sub;
  1146 }
  1147 
  1148 
  1149 /* Decode VALUE as an element of char-table TABLE.  */
  1150 
  1151 static Lisp_Object
  1152 uniprop_decode_value_run_length (Lisp_Object table, Lisp_Object value)
  1153 {
  1154   if (VECTORP (XCHAR_TABLE (table)->extras[4]))
  1155     {
  1156       Lisp_Object valvec = XCHAR_TABLE (table)->extras[4];
  1157 
  1158       if (XFIXNUM (value) >= 0 && XFIXNUM (value) < ASIZE (valvec))
  1159         value = AREF (valvec, XFIXNUM (value));
  1160     }
  1161   return value;
  1162 }
  1163 
  1164 static uniprop_decoder_t uniprop_decoder [] =
  1165   { uniprop_decode_value_run_length };
  1166 
  1167 static const int uniprop_decoder_count = ARRAYELTS (uniprop_decoder);
  1168 
  1169 /* Return the decoder of char-table TABLE or nil if none.  */
  1170 
  1171 static uniprop_decoder_t
  1172 uniprop_get_decoder (Lisp_Object table)
  1173 {
  1174   EMACS_INT i;
  1175 
  1176   if (! FIXNUMP (XCHAR_TABLE (table)->extras[1]))
  1177     return NULL;
  1178   i = XFIXNUM (XCHAR_TABLE (table)->extras[1]);
  1179   if (i < 0 || i >= uniprop_decoder_count)
  1180     return NULL;
  1181   return uniprop_decoder[i];
  1182 }
  1183 
  1184 
  1185 /* Encode VALUE as an element of char-table TABLE which contains
  1186    characters as elements.  */
  1187 
  1188 static Lisp_Object
  1189 uniprop_encode_value_character (Lisp_Object table, Lisp_Object value)
  1190 {
  1191   if (! NILP (value) && ! CHARACTERP (value))
  1192     wrong_type_argument (Qintegerp, value);
  1193   return value;
  1194 }
  1195 
  1196 
  1197 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
  1198    compression.  */
  1199 
  1200 static Lisp_Object
  1201 uniprop_encode_value_run_length (Lisp_Object table, Lisp_Object value)
  1202 {
  1203   Lisp_Object *value_table = XVECTOR (XCHAR_TABLE (table)->extras[4])->contents;
  1204   int i, size = ASIZE (XCHAR_TABLE (table)->extras[4]);
  1205 
  1206   for (i = 0; i < size; i++)
  1207     if (EQ (value, value_table[i]))
  1208       break;
  1209   if (i == size)
  1210     wrong_type_argument (build_string ("Unicode property value"), value);
  1211   return make_fixnum (i);
  1212 }
  1213 
  1214 
  1215 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
  1216    compression and contains numbers as elements.  */
  1217 
  1218 static Lisp_Object
  1219 uniprop_encode_value_numeric (Lisp_Object table, Lisp_Object value)
  1220 {
  1221   Lisp_Object *value_table = XVECTOR (XCHAR_TABLE (table)->extras[4])->contents;
  1222   int i, size = ASIZE (XCHAR_TABLE (table)->extras[4]);
  1223 
  1224   CHECK_FIXNUM (value);
  1225   for (i = 0; i < size; i++)
  1226     if (EQ (value, value_table[i]))
  1227       break;
  1228   value = make_fixnum (i);
  1229   if (i == size)
  1230     set_char_table_extras (table, 4,
  1231                            CALLN (Fvconcat,
  1232                                   XCHAR_TABLE (table)->extras[4],
  1233                                   make_vector (1, value)));
  1234   return make_fixnum (i);
  1235 }
  1236 
  1237 static uniprop_encoder_t uniprop_encoder[] =
  1238   { uniprop_encode_value_character,
  1239     uniprop_encode_value_run_length,
  1240     uniprop_encode_value_numeric };
  1241 
  1242 static const int uniprop_encoder_count = ARRAYELTS (uniprop_encoder);
  1243 
  1244 /* Return the encoder of char-table TABLE or nil if none.  */
  1245 
  1246 static uniprop_decoder_t
  1247 uniprop_get_encoder (Lisp_Object table)
  1248 {
  1249   EMACS_INT i;
  1250 
  1251   if (! FIXNUMP (XCHAR_TABLE (table)->extras[2]))
  1252     return NULL;
  1253   i = XFIXNUM (XCHAR_TABLE (table)->extras[2]);
  1254   if (i < 0 || i >= uniprop_encoder_count)
  1255     return NULL;
  1256   return uniprop_encoder[i];
  1257 }
  1258 
  1259 /* Return a char-table for Unicode character property PROP.  This
  1260    function may load a Lisp file and thus may cause
  1261    garbage-collection.  */
  1262 
  1263 Lisp_Object
  1264 uniprop_table (Lisp_Object prop)
  1265 {
  1266   Lisp_Object val, table, result;
  1267 
  1268   val = Fassq (prop, Vchar_code_property_alist);
  1269   if (! CONSP (val))
  1270     return Qnil;
  1271   table = XCDR (val);
  1272   if (STRINGP (table))
  1273     {
  1274       AUTO_STRING (intl, "international/");
  1275       result = save_match_data_load (concat2 (intl, table), Qt, Qt, Qt, Qt);
  1276       if (NILP (result))
  1277         return Qnil;
  1278       table = XCDR (val);
  1279     }
  1280   if (! CHAR_TABLE_P (table)
  1281       || ! UNIPROP_TABLE_P (table))
  1282     return Qnil;
  1283   val = XCHAR_TABLE (table)->extras[1];
  1284   if (FIXNUMP (val)
  1285       ? (XFIXNUM (val) < 0 || XFIXNUM (val) >= uniprop_decoder_count)
  1286       : ! NILP (val))
  1287     return Qnil;
  1288   /* Prepare ASCII values in advance for CHAR_TABLE_REF.  */
  1289   set_char_table_ascii (table, char_table_ascii (table));
  1290   return table;
  1291 }
  1292 
  1293 DEFUN ("unicode-property-table-internal", Funicode_property_table_internal,
  1294        Sunicode_property_table_internal, 1, 1, 0,
  1295        doc: /* Return a char-table for Unicode character property PROP.
  1296 Use `get-unicode-property-internal' and
  1297 `put-unicode-property-internal' instead of `aref' and `aset' to get
  1298 and put an element value.  */)
  1299   (Lisp_Object prop)
  1300 {
  1301   Lisp_Object table = uniprop_table (prop);
  1302 
  1303   if (CHAR_TABLE_P (table))
  1304     return table;
  1305   return Fcdr (Fassq (prop, Vchar_code_property_alist));
  1306 }
  1307 
  1308 Lisp_Object
  1309 get_unicode_property (Lisp_Object char_table, int ch)
  1310 {
  1311   Lisp_Object val = CHAR_TABLE_REF (char_table, ch);
  1312   uniprop_decoder_t decoder = uniprop_get_decoder (char_table);
  1313   return (decoder ? decoder (char_table, val) : val);
  1314 }
  1315 
  1316 DEFUN ("get-unicode-property-internal", Fget_unicode_property_internal,
  1317        Sget_unicode_property_internal, 2, 2, 0,
  1318        doc: /* Return an element of CHAR-TABLE for character CH.
  1319 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
  1320   (Lisp_Object char_table, Lisp_Object ch)
  1321 {
  1322   CHECK_CHAR_TABLE (char_table);
  1323   CHECK_CHARACTER (ch);
  1324   if (! UNIPROP_TABLE_P (char_table))
  1325     error ("Invalid Unicode property table");
  1326   return get_unicode_property (char_table, XFIXNUM (ch));
  1327 }
  1328 
  1329 DEFUN ("put-unicode-property-internal", Fput_unicode_property_internal,
  1330        Sput_unicode_property_internal, 3, 3, 0,
  1331        doc: /* Set an element of CHAR-TABLE for character CH to VALUE.
  1332 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
  1333   (Lisp_Object char_table, Lisp_Object ch, Lisp_Object value)
  1334 {
  1335   uniprop_encoder_t encoder;
  1336 
  1337   CHECK_CHAR_TABLE (char_table);
  1338   CHECK_CHARACTER (ch);
  1339   if (! UNIPROP_TABLE_P (char_table))
  1340     error ("Invalid Unicode property table");
  1341   encoder = uniprop_get_encoder (char_table);
  1342   if (encoder)
  1343     value = encoder (char_table, value);
  1344   CHAR_TABLE_SET (char_table, XFIXNUM (ch), value);
  1345   return Qnil;
  1346 }
  1347 
  1348 
  1349 void
  1350 syms_of_chartab (void)
  1351 {
  1352   /* Purpose of uniprop tables. */
  1353   DEFSYM (Qchar_code_property_table, "char-code-property-table");
  1354 
  1355   defsubr (&Smake_char_table);
  1356   defsubr (&Schar_table_parent);
  1357   defsubr (&Schar_table_subtype);
  1358   defsubr (&Sset_char_table_parent);
  1359   defsubr (&Schar_table_extra_slot);
  1360   defsubr (&Sset_char_table_extra_slot);
  1361   defsubr (&Schar_table_range);
  1362   defsubr (&Sset_char_table_range);
  1363   defsubr (&Soptimize_char_table);
  1364   defsubr (&Smap_char_table);
  1365   defsubr (&Sunicode_property_table_internal);
  1366   defsubr (&Sget_unicode_property_internal);
  1367   defsubr (&Sput_unicode_property_internal);
  1368 
  1369   /* Each element has the form (PROP . TABLE).
  1370      PROP is a symbol representing a character property.
  1371      TABLE is a char-table containing the property value for each character.
  1372      TABLE may be a name of file to load to build a char-table.
  1373      This variable should be modified only through
  1374      `define-char-code-property'. */
  1375 
  1376   DEFVAR_LISP ("char-code-property-alist", Vchar_code_property_alist,
  1377                doc: /* Alist of character property name vs char-table containing property values.
  1378 Internal use only.  */);
  1379   Vchar_code_property_alist = Qnil;
  1380 }