src/chartab.c

   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
  11 (at 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 <http://www.gnu.org/licenses/>.  */
  20
  21 #include <config.h>
  22 #include <setjmp.h>
  23 #include "lisp.h"
  24 #include "character.h"
  25 #include "charset.h"
  26 #include "ccl.h"
  27
  28 /* 64/16/32/128 */
  29
  30 /* Number of elements in Nth level char-table.  */
  31 const int chartab_size[4] =
  32   { (1 << CHARTAB_SIZE_BITS_0),
  33     (1 << CHARTAB_SIZE_BITS_1),
  34     (1 << CHARTAB_SIZE_BITS_2),
  35     (1 << CHARTAB_SIZE_BITS_3) };
  36
  37 /* Number of characters each element of Nth level char-table
  38    covers.  */
  39 static const int chartab_chars[4] =
  40   { (1 << (CHARTAB_SIZE_BITS_1 + CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3)),
  41     (1 << (CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3)),
  42     (1 << CHARTAB_SIZE_BITS_3),
  43     1 };
  44
  45 /* Number of characters (in bits) each element of Nth level char-table
  46    covers.  */
  47 static const int chartab_bits[4] =
  48   { (CHARTAB_SIZE_BITS_1 + CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3),
  49     (CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3),
  50     CHARTAB_SIZE_BITS_3,
  51     0 };
  52
  53 #define CHARTAB_IDX(c, depth, min_char)         \
  54   (((c) - (min_char)) >> chartab_bits[(depth)])
  55
  56
  57 DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
  58        doc: /* Return a newly created char-table, with purpose PURPOSE.
  59 Each element is initialized to INIT, which defaults to nil.
  60
  61 PURPOSE should be a symbol.  If it has a `char-table-extra-slots'
  62 property, the property's value should be an integer between 0 and 10
  63 that specifies how many extra slots the char-table has.  Otherwise,
  64 the char-table has no extra slot.  */)
  65   (register Lisp_Object purpose, Lisp_Object init)
  66 {
  67   Lisp_Object vector;
  68   Lisp_Object n;
  69   int n_extras;
  70   int size;
  71
  72   CHECK_SYMBOL (purpose);
  73   n = Fget (purpose, Qchar_table_extra_slots);
  74   if (NILP (n))
  75     n_extras = 0;
  76   else
  77     {
  78       CHECK_NATNUM (n);
  79       n_extras = XINT (n);
  80       if (n_extras > 10)
  81         args_out_of_range (n, Qnil);
  82     }
  83
  84   size = VECSIZE (struct Lisp_Char_Table) - 1 + n_extras;
  85   vector = Fmake_vector (make_number (size), init);
  86   XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
  87   XCHAR_TABLE (vector)->parent = Qnil;
  88   XCHAR_TABLE (vector)->purpose = purpose;
  89   XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
  90   return vector;
  91 }
  92
  93 static Lisp_Object
  94 make_sub_char_table (int depth, int min_char, Lisp_Object defalt)
  95 {
  96   Lisp_Object table;
  97   int size = VECSIZE (struct Lisp_Sub_Char_Table) - 1 + chartab_size[depth];
  98
  99   table = Fmake_vector (make_number (size), defalt);
 100   XSETPVECTYPE (XVECTOR (table), PVEC_SUB_CHAR_TABLE);
 101   XSUB_CHAR_TABLE (table)->depth = make_number (depth);
 102   XSUB_CHAR_TABLE (table)->min_char = make_number (min_char);
 103
 104   return table;
 105 }
 106
 107 static Lisp_Object
 108 char_table_ascii (Lisp_Object table)
 109 {
 110   Lisp_Object sub;
 111
 112   sub = XCHAR_TABLE (table)->contents[0];
 113   if (! SUB_CHAR_TABLE_P (sub))
 114     return sub;
 115   sub = XSUB_CHAR_TABLE (sub)->contents[0];
 116   if (! SUB_CHAR_TABLE_P (sub))
 117     return sub;
 118   return XSUB_CHAR_TABLE (sub)->contents[0];
 119 }
 120
 121 static Lisp_Object
 122 copy_sub_char_table (Lisp_Object table)
 123 {
 124   Lisp_Object copy;
 125   int depth = XINT (XSUB_CHAR_TABLE (table)->depth);
 126   int min_char = XINT (XSUB_CHAR_TABLE (table)->min_char);
 127   Lisp_Object val;
 128   int i;
 129
 130   copy = make_sub_char_table (depth, min_char, Qnil);
 131   /* Recursively copy any sub char-tables.  */
 132   for (i = 0; i < chartab_size[depth]; i++)
 133     {
 134       val = XSUB_CHAR_TABLE (table)->contents[i];
 135       if (SUB_CHAR_TABLE_P (val))
 136         XSUB_CHAR_TABLE (copy)->contents[i] = copy_sub_char_table (val);
 137       else
 138         XSUB_CHAR_TABLE (copy)->contents[i] = val;
 139     }
 140
 141   return copy;
 142 }
 143
 144
 145 Lisp_Object
 146 copy_char_table (Lisp_Object table)
 147 {
 148   Lisp_Object copy;
 149   int size = XCHAR_TABLE (table)->header.size & PSEUDOVECTOR_SIZE_MASK;
 150   int i;
 151
 152   copy = Fmake_vector (make_number (size), Qnil);
 153   XSETPVECTYPE (XVECTOR (copy), PVEC_CHAR_TABLE);
 154   XCHAR_TABLE (copy)->defalt = XCHAR_TABLE (table)->defalt;
 155   XCHAR_TABLE (copy)->parent = XCHAR_TABLE (table)->parent;
 156   XCHAR_TABLE (copy)->purpose = XCHAR_TABLE (table)->purpose;
 157   for (i = 0; i < chartab_size[0]; i++)
 158     XCHAR_TABLE (copy)->contents[i]
 159       = (SUB_CHAR_TABLE_P (XCHAR_TABLE (table)->contents[i])
 160          ? copy_sub_char_table (XCHAR_TABLE (table)->contents[i])
 161          : XCHAR_TABLE (table)->contents[i]);
 162   XCHAR_TABLE (copy)->ascii = char_table_ascii (copy);
 163   size -= VECSIZE (struct Lisp_Char_Table) - 1;
 164   for (i = 0; i < size; i++)
 165     XCHAR_TABLE (copy)->extras[i] = XCHAR_TABLE (table)->extras[i];
 166
 167   XSETCHAR_TABLE (copy, XCHAR_TABLE (copy));
 168   return copy;
 169 }
 170
 171 static Lisp_Object
 172 sub_char_table_ref (Lisp_Object table, int c)
 173 {
 174   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
 175   int depth = XINT (tbl->depth);
 176   int min_char = XINT (tbl->min_char);
 177   Lisp_Object val;
 178
 179   val = tbl->contents[CHARTAB_IDX (c, depth, min_char)];
 180   if (SUB_CHAR_TABLE_P (val))
 181     val = sub_char_table_ref (val, c);
 182   return val;
 183 }
 184
 185 Lisp_Object
 186 char_table_ref (Lisp_Object table, int c)
 187 {
 188   struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
 189   Lisp_Object val;
 190
 191   if (ASCII_CHAR_P (c))
 192     {
 193       val = tbl->ascii;
 194       if (SUB_CHAR_TABLE_P (val))
 195         val = XSUB_CHAR_TABLE (val)->contents[c];
 196     }
 197   else
 198     {
 199       val = tbl->contents[CHARTAB_IDX (c, 0, 0)];
 200       if (SUB_CHAR_TABLE_P (val))
 201         val = sub_char_table_ref (val, c);
 202     }
 203   if (NILP (val))
 204     {
 205       val = tbl->defalt;
 206       if (NILP (val) && CHAR_TABLE_P (tbl->parent))
 207         val = char_table_ref (tbl->parent, c);
 208     }
 209   return val;
 210 }
 211
 212 static Lisp_Object
 213 sub_char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to, Lisp_Object defalt)
 214 {
 215   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
 216   int depth = XINT (tbl->depth);
 217   int min_char = XINT (tbl->min_char);
 218   int chartab_idx = CHARTAB_IDX (c, depth, min_char), idx;
 219   Lisp_Object val;
 220
 221   val = tbl->contents[chartab_idx];
 222   if (SUB_CHAR_TABLE_P (val))
 223     val = sub_char_table_ref_and_range (val, c, from, to, defalt);
 224   else if (NILP (val))
 225     val = defalt;
 226
 227   idx = chartab_idx;
 228   while (idx > 0 && *from < min_char + idx * chartab_chars[depth])
 229     {
 230       Lisp_Object this_val;
 231
 232       c = min_char + idx * chartab_chars[depth] - 1;
 233       idx--;
 234       this_val = tbl->contents[idx];
 235       if (SUB_CHAR_TABLE_P (this_val))
 236         this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt);
 237       else if (NILP (this_val))
 238         this_val = defalt;
 239
 240       if (! EQ (this_val, val))
 241         {
 242           *from = c + 1;
 243           break;
 244         }
 245     }
 246   while (((c = (chartab_idx + 1) * chartab_chars[depth])
 247           < chartab_chars[depth - 1])
 248          && (c += min_char) <= *to)
 249     {
 250       Lisp_Object this_val;
 251
 252       chartab_idx++;
 253       this_val = tbl->contents[chartab_idx];
 254       if (SUB_CHAR_TABLE_P (this_val))
 255         this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt);
 256       else if (NILP (this_val))
 257         this_val = defalt;
 258       if (! EQ (this_val, val))
 259         {
 260           *to = c - 1;
 261           break;
 262         }
 263     }
 264
 265   return val;
 266 }
 267
 268
 269 /* Return the value for C in char-table TABLE.  Shrink the range *FROM
 270    and *TO to cover characters (containing C) that have the same value
 271    as C.  It is not assured that the values of (*FROM - 1) and (*TO +
 272    1) are different from that of C.  */
 273
 274 Lisp_Object
 275 char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to)
 276 {
 277   struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
 278   int chartab_idx = CHARTAB_IDX (c, 0, 0), idx;
 279   Lisp_Object val;
 280
 281   val = tbl->contents[chartab_idx];
 282   if (*from < 0)
 283     *from = 0;
 284   if (*to < 0)
 285     *to = MAX_CHAR;
 286   if (SUB_CHAR_TABLE_P (val))
 287     val = sub_char_table_ref_and_range (val, c, from, to, tbl->defalt);
 288   else if (NILP (val))
 289     val = tbl->defalt;
 290
 291   idx = chartab_idx;
 292   while (*from < idx * chartab_chars[0])
 293     {
 294       Lisp_Object this_val;
 295
 296       c = idx * chartab_chars[0] - 1;
 297       idx--;
 298       this_val = tbl->contents[idx];
 299       if (SUB_CHAR_TABLE_P (this_val))
 300         this_val = sub_char_table_ref_and_range (this_val, c, from, to,
 301                                                  tbl->defalt);
 302       else if (NILP (this_val))
 303         this_val = tbl->defalt;
 304
 305       if (! EQ (this_val, val))
 306         {
 307           *from = c + 1;
 308           break;
 309         }
 310     }
 311   while (*to >= (chartab_idx + 1) * chartab_chars[0])
 312     {
 313       Lisp_Object this_val;
 314
 315       chartab_idx++;
 316       c = chartab_idx * chartab_chars[0];
 317       this_val = tbl->contents[chartab_idx];
 318       if (SUB_CHAR_TABLE_P (this_val))
 319         this_val = sub_char_table_ref_and_range (this_val, c, from, to,
 320                                                  tbl->defalt);
 321       else if (NILP (this_val))
 322         this_val = tbl->defalt;
 323       if (! EQ (this_val, val))
 324         {
 325           *to = c - 1;
 326           break;
 327         }
 328     }
 329
 330   return val;
 331 }
 332
 333
 334 static void
 335 sub_char_table_set (Lisp_Object table, int c, Lisp_Object val)
 336 {
 337   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
 338   int depth = XINT ((tbl)->depth);
 339   int min_char = XINT ((tbl)->min_char);
 340   int i = CHARTAB_IDX (c, depth, min_char);
 341   Lisp_Object sub;
 342
 343   if (depth == 3)
 344     tbl->contents[i] = val;
 345   else
 346     {
 347       sub = tbl->contents[i];
 348       if (! SUB_CHAR_TABLE_P (sub))
 349         {
 350           sub = make_sub_char_table (depth + 1,
 351                                      min_char + i * chartab_chars[depth], sub);
 352           tbl->contents[i] = sub;
 353         }
 354       sub_char_table_set (sub, c, val);
 355     }
 356 }
 357
 358 Lisp_Object
 359 char_table_set (Lisp_Object table, int c, Lisp_Object val)
 360 {
 361   struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
 362
 363   if (ASCII_CHAR_P (c)
 364       && SUB_CHAR_TABLE_P (tbl->ascii))
 365     {
 366       XSUB_CHAR_TABLE (tbl->ascii)->contents[c] = val;
 367     }
 368   else
 369     {
 370       int i = CHARTAB_IDX (c, 0, 0);
 371       Lisp_Object sub;
 372
 373       sub = tbl->contents[i];
 374       if (! SUB_CHAR_TABLE_P (sub))
 375         {
 376           sub = make_sub_char_table (1, i * chartab_chars[0], sub);
 377           tbl->contents[i] = sub;
 378         }
 379       sub_char_table_set (sub, c, val);
 380       if (ASCII_CHAR_P (c))
 381         tbl->ascii = char_table_ascii (table);
 382     }
 383   return val;
 384 }
 385
 386 static void
 387 sub_char_table_set_range (Lisp_Object *table, int depth, int min_char, int from, int to, Lisp_Object val)
 388 {
 389   int max_char = min_char + chartab_chars[depth] - 1;
 390
 391   if (depth == 3 || (from <= min_char && to >= max_char))
 392     *table = val;
 393   else
 394     {
 395       int i;
 396       unsigned j;
 397
 398       depth++;
 399       if (! SUB_CHAR_TABLE_P (*table))
 400         *table = make_sub_char_table (depth, min_char, *table);
 401       if (from < min_char)
 402         from = min_char;
 403       if (to > max_char)
 404         to = max_char;
 405       i = CHARTAB_IDX (from, depth, min_char);
 406       j = CHARTAB_IDX (to, depth, min_char);
 407       min_char += chartab_chars[depth] * i;
 408       for (j++; i < j; i++, min_char += chartab_chars[depth])
 409         sub_char_table_set_range (XSUB_CHAR_TABLE (*table)->contents + i,
 410                                   depth, min_char, from, to, val);
 411     }
 412 }
 413
 414
 415 Lisp_Object
 416 char_table_set_range (Lisp_Object table, int from, int to, Lisp_Object val)
 417 {
 418   struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
 419   Lisp_Object *contents = tbl->contents;
 420   int i;
 421
 422   if (from == to)
 423     char_table_set (table, from, val);
 424   else
 425     {
 426       unsigned lim = to / chartab_chars[0] + 1;
 427       for (i = CHARTAB_IDX (from, 0, 0); i < lim; i++)
 428         sub_char_table_set_range (contents + i, 0, i * chartab_chars[0],
 429                                   from, to, val);
 430       if (ASCII_CHAR_P (from))
 431         tbl->ascii = char_table_ascii (table);
 432     }
 433   return val;
 434 }
 435
 436 \f
 437 DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
 438        1, 1, 0,
 439        doc: /*
 440 Return the subtype of char-table CHAR-TABLE.  The value is a symbol.  */)
 441   (Lisp_Object char_table)
 442 {
 443   CHECK_CHAR_TABLE (char_table);
 444
 445   return XCHAR_TABLE (char_table)->purpose;
 446 }
 447
 448 DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
 449        1, 1, 0,
 450        doc: /* Return the parent char-table of CHAR-TABLE.
 451 The value is either nil or another char-table.
 452 If CHAR-TABLE holds nil for a given character,
 453 then the actual applicable value is inherited from the parent char-table
 454 \(or from its parents, if necessary).  */)
 455   (Lisp_Object char_table)
 456 {
 457   CHECK_CHAR_TABLE (char_table);
 458
 459   return XCHAR_TABLE (char_table)->parent;
 460 }
 461
 462 DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
 463        2, 2, 0,
 464        doc: /* Set the parent char-table of CHAR-TABLE to PARENT.
 465 Return PARENT.  PARENT must be either nil or another char-table.  */)
 466   (Lisp_Object char_table, Lisp_Object parent)
 467 {
 468   Lisp_Object temp;
 469
 470   CHECK_CHAR_TABLE (char_table);
 471
 472   if (!NILP (parent))
 473     {
 474       CHECK_CHAR_TABLE (parent);
 475
 476       for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
 477         if (EQ (temp, char_table))
 478           error ("Attempt to make a chartable be its own parent");
 479     }
 480
 481   XCHAR_TABLE (char_table)->parent = parent;
 482
 483   return parent;
 484 }
 485
 486 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
 487        2, 2, 0,
 488        doc: /* Return the value of CHAR-TABLE's extra-slot number N.  */)
 489   (Lisp_Object char_table, Lisp_Object n)
 490 {
 491   CHECK_CHAR_TABLE (char_table);
 492   CHECK_NUMBER (n);
 493   if (XINT (n) < 0
 494       || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
 495     args_out_of_range (char_table, n);
 496
 497   return XCHAR_TABLE (char_table)->extras[XINT (n)];
 498 }
 499
 500 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
 501        Sset_char_table_extra_slot,
 502        3, 3, 0,
 503        doc: /* Set CHAR-TABLE's extra-slot number N to VALUE.  */)
 504   (Lisp_Object char_table, Lisp_Object n, Lisp_Object value)
 505 {
 506   CHECK_CHAR_TABLE (char_table);
 507   CHECK_NUMBER (n);
 508   if (XINT (n) < 0
 509       || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
 510     args_out_of_range (char_table, n);
 511
 512   return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
 513 }
 514 \f
 515 DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
 516        2, 2, 0,
 517        doc: /* Return the value in CHAR-TABLE for a range of characters RANGE.
 518 RANGE should be nil (for the default value),
 519 a cons of character codes (for characters in the range), or a character code.  */)
 520   (Lisp_Object char_table, Lisp_Object range)
 521 {
 522   Lisp_Object val;
 523   CHECK_CHAR_TABLE (char_table);
 524
 525   if (EQ (range, Qnil))
 526     val = XCHAR_TABLE (char_table)->defalt;
 527   else if (INTEGERP (range))
 528     val = CHAR_TABLE_REF (char_table, XINT (range));
 529   else if (CONSP (range))
 530     {
 531       int from, to;
 532
 533       CHECK_CHARACTER_CAR (range);
 534       CHECK_CHARACTER_CDR (range);
 535       val = char_table_ref_and_range (char_table, XINT (XCAR (range)),
 536                                       &from, &to);
 537       /* Not yet implemented. */
 538     }
 539   else
 540     error ("Invalid RANGE argument to `char-table-range'");
 541   return val;
 542 }
 543
 544 DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
 545        3, 3, 0,
 546        doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
 547 RANGE should be t (for all characters), nil (for the default value),
 548 a cons of character codes (for characters in the range),
 549 or a character code.  Return VALUE.  */)
 550   (Lisp_Object char_table, Lisp_Object range, Lisp_Object value)
 551 {
 552   CHECK_CHAR_TABLE (char_table);
 553   if (EQ (range, Qt))
 554     {
 555       int i;
 556
 557       XCHAR_TABLE (char_table)->ascii = value;
 558       for (i = 0; i < chartab_size[0]; i++)
 559         XCHAR_TABLE (char_table)->contents[i] = value;
 560     }
 561   else if (EQ (range, Qnil))
 562     XCHAR_TABLE (char_table)->defalt = value;
 563   else if (INTEGERP (range))
 564     char_table_set (char_table, XINT (range), value);
 565   else if (CONSP (range))
 566     {
 567       CHECK_CHARACTER_CAR (range);
 568       CHECK_CHARACTER_CDR (range);
 569       char_table_set_range (char_table,
 570                             XINT (XCAR (range)), XINT (XCDR (range)), value);
 571     }
 572   else
 573     error ("Invalid RANGE argument to `set-char-table-range'");
 574
 575   return value;
 576 }
 577
 578 DEFUN ("set-char-table-default", Fset_char_table_default,
 579        Sset_char_table_default, 3, 3, 0,
 580        doc: /*
 581 This function is obsolete and has no effect.  */)
 582   (Lisp_Object char_table, Lisp_Object ch, Lisp_Object value)
 583 {
 584   return Qnil;
 585 }
 586
 587 /* Look up the element in TABLE at index CH, and return it as an
 588    integer.  If the element is not a character, return CH itself.  */
 589
 590 int
 591 char_table_translate (Lisp_Object table, int ch)
 592 {
 593   Lisp_Object value;
 594   value = Faref (table, make_number (ch));
 595   if (! CHARACTERP (value))
 596     return ch;
 597   return XINT (value);
 598 }
 599
 600 static Lisp_Object
 601 optimize_sub_char_table (Lisp_Object table, Lisp_Object test)
 602 {
 603   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
 604   int depth = XINT (tbl->depth);
 605   Lisp_Object elt, this;
 606   int i, optimizable;
 607
 608   elt = XSUB_CHAR_TABLE (table)->contents[0];
 609   if (SUB_CHAR_TABLE_P (elt))
 610     elt = XSUB_CHAR_TABLE (table)->contents[0]
 611       = optimize_sub_char_table (elt, test);
 612   optimizable = SUB_CHAR_TABLE_P (elt) ? 0 : 1;
 613   for (i = 1; i < chartab_size[depth]; i++)
 614     {
 615       this = XSUB_CHAR_TABLE (table)->contents[i];
 616       if (SUB_CHAR_TABLE_P (this))
 617         this = XSUB_CHAR_TABLE (table)->contents[i]
 618           = optimize_sub_char_table (this, test);
 619       if (optimizable
 620           && (NILP (test) ? NILP (Fequal (this, elt)) /* defaults to `equal'. */
 621               : EQ (test, Qeq) ? !EQ (this, elt)      /* Optimize `eq' case.  */
 622               : NILP (call2 (test, this, elt))))
 623         optimizable = 0;
 624     }
 625
 626   return (optimizable ? elt : table);
 627 }
 628
 629 DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
 630        1, 2, 0,
 631        doc: /* Optimize CHAR-TABLE.
 632 TEST is the comparison function used to decide whether two entries are
 633 equivalent and can be merged.  It defaults to `equal'.  */)
 634   (Lisp_Object char_table, Lisp_Object test)
 635 {
 636   Lisp_Object elt;
 637   int i;
 638
 639   CHECK_CHAR_TABLE (char_table);
 640
 641   for (i = 0; i < chartab_size[0]; i++)
 642     {
 643       elt = XCHAR_TABLE (char_table)->contents[i];
 644       if (SUB_CHAR_TABLE_P (elt))
 645         XCHAR_TABLE (char_table)->contents[i]
 646           = optimize_sub_char_table (elt, test);
 647     }
 648   /* Reset the `ascii' cache, in case it got optimized away.  */
 649   XCHAR_TABLE (char_table)->ascii = char_table_ascii (char_table);
 650
 651   return Qnil;
 652 }
 653
 654 \f
 655 /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
 656    calling it for each character or group of characters that share a
 657    value.  RANGE is a cons (FROM . TO) specifying the range of target
 658    characters, VAL is a value of FROM in TABLE, DEFAULT_VAL is the
 659    default value of the char-table, PARENT is the parent of the
 660    char-table.
 661
 662    ARG is passed to C_FUNCTION when that is called.
 663
 664    It returns the value of last character covered by TABLE (not the
 665    value inheritted from the parent), and by side-effect, the car part
 666    of RANGE is updated to the minimum character C where C and all the
 667    following characters in TABLE have the same value.  */
 668
 669 static Lisp_Object
 670 map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
 671                     Lisp_Object function, Lisp_Object table, Lisp_Object arg, Lisp_Object val,
 672                     Lisp_Object range, Lisp_Object default_val, Lisp_Object parent)
 673 {
 674   /* Pointer to the elements of TABLE. */
 675   Lisp_Object *contents;
 676   /* Depth of TABLE.  */
 677   int depth;
 678   /* Minimum and maxinum characters covered by TABLE. */
 679   int min_char, max_char;
 680   /* Number of characters covered by one element of TABLE.  */
 681   int chars_in_block;
 682   int from = XINT (XCAR (range)), to = XINT (XCDR (range));
 683   int i, c;
 684
 685   if (SUB_CHAR_TABLE_P (table))
 686     {
 687       struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
 688
 689       depth = XINT (tbl->depth);
 690       contents = tbl->contents;
 691       min_char = XINT (tbl->min_char);
 692       max_char = min_char + chartab_chars[depth - 1] - 1;
 693     }
 694   else
 695     {
 696       depth = 0;
 697       contents = XCHAR_TABLE (table)->contents;
 698       min_char = 0;
 699       max_char = MAX_CHAR;
 700     }
 701   chars_in_block = chartab_chars[depth];
 702
 703   if (to < max_char)
 704     max_char = to;
 705   /* Set I to the index of the first element to check.  */
 706   if (from <= min_char)
 707     i = 0;
 708   else
 709     i = (from - min_char) / chars_in_block;
 710   for (c = min_char + chars_in_block * i; c <= max_char;
 711        i++, c += chars_in_block)
 712     {
 713       Lisp_Object this = contents[i];
 714       int nextc = c + chars_in_block;
 715
 716       if (SUB_CHAR_TABLE_P (this))
 717         {
 718           if (to >= nextc)
 719             XSETCDR (range, make_number (nextc - 1));
 720           val = map_sub_char_table (c_function, function, this, arg,
 721                                     val, range, default_val, parent);
 722         }
 723       else
 724         {
 725           if (NILP (this))
 726             this = default_val;
 727           if (!EQ (val, this))
 728             {
 729               int different_value = 1;
 730
 731               if (NILP (val))
 732                 {
 733                   if (! NILP (parent))
 734                     {
 735                       Lisp_Object temp = XCHAR_TABLE (parent)->parent;
 736
 737                       /* This is to get a value of FROM in PARENT
 738                          without checking the parent of PARENT.  */
 739                       XCHAR_TABLE (parent)->parent = Qnil;
 740                       val = CHAR_TABLE_REF (parent, from);
 741                       XCHAR_TABLE (parent)->parent = temp;
 742                       XSETCDR (range, make_number (c - 1));
 743                       val = map_sub_char_table (c_function, function,
 744                                                 parent, arg, val, range,
 745                                                 XCHAR_TABLE (parent)->defalt,
 746                                                 XCHAR_TABLE (parent)->parent);
 747                       if (EQ (val, this))
 748                         different_value = 0;
 749                     }
 750                 }
 751               if (! NILP (val) && different_value)
 752                 {
 753                   XSETCDR (range, make_number (c - 1));
 754                   if (EQ (XCAR (range), XCDR (range)))
 755                     {
 756                       if (c_function)
 757                         (*c_function) (arg, XCAR (range), val);
 758                       else
 759                         call2 (function, XCAR (range), val);
 760                     }
 761                   else
 762                     {
 763                       if (c_function)
 764                         (*c_function) (arg, range, val);
 765                       else
 766                         call2 (function, range, val);
 767                     }
 768                 }
 769               val = this;
 770               from = c;
 771               XSETCAR (range, make_number (c));
 772             }
 773         }
 774       XSETCDR (range, make_number (to));
 775     }
 776   return val;
 777 }
 778
 779
 780 /* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
 781    character or group of characters that share a value.
 782
 783    ARG is passed to C_FUNCTION when that is called.  */
 784
 785 void
 786 map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object function, Lisp_Object table, Lisp_Object arg)
 787 {
 788   Lisp_Object range, val;
 789   struct gcpro gcpro1, gcpro2, gcpro3;
 790
 791   range = Fcons (make_number (0), make_number (MAX_CHAR));
 792   GCPRO3 (table, arg, range);
 793   val = XCHAR_TABLE (table)->ascii;
 794   if (SUB_CHAR_TABLE_P (val))
 795     val = XSUB_CHAR_TABLE (val)->contents[0];
 796   val = map_sub_char_table (c_function, function, table, arg, val, range,
 797                             XCHAR_TABLE (table)->defalt,
 798                             XCHAR_TABLE (table)->parent);
 799   /* If VAL is nil and TABLE has a parent, we must consult the parent
 800      recursively.  */
 801   while (NILP (val) && ! NILP (XCHAR_TABLE (table)->parent))
 802     {
 803       Lisp_Object parent = XCHAR_TABLE (table)->parent;
 804       Lisp_Object temp = XCHAR_TABLE (parent)->parent;
 805       int from = XINT (XCAR (range));
 806
 807       /* This is to get a value of FROM in PARENT without checking the
 808          parent of PARENT.  */
 809       XCHAR_TABLE (parent)->parent = Qnil;
 810       val = CHAR_TABLE_REF (parent, from);
 811       XCHAR_TABLE (parent)->parent = temp;
 812       val = map_sub_char_table (c_function, function, parent, arg, val, range,
 813                                 XCHAR_TABLE (parent)->defalt,
 814                                 XCHAR_TABLE (parent)->parent);
 815       table = parent;
 816     }
 817
 818   if (! NILP (val))
 819     {
 820       if (EQ (XCAR (range), XCDR (range)))
 821         {
 822           if (c_function)
 823             (*c_function) (arg, XCAR (range), val);
 824           else
 825             call2 (function, XCAR (range), val);
 826         }
 827       else
 828         {
 829           if (c_function)
 830             (*c_function) (arg, range, val);
 831           else
 832             call2 (function, range, val);
 833         }
 834     }
 835
 836   UNGCPRO;
 837 }
 838
 839 DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
 840   2, 2, 0,
 841        doc: /*
 842 Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
 843 FUNCTION is called with two arguments--a key and a value.
 844 The key is a character code or a cons of character codes specifying a
 845 range of characters that have the same value.  */)
 846   (Lisp_Object function, Lisp_Object char_table)
 847 {
 848   CHECK_CHAR_TABLE (char_table);
 849
 850   map_char_table (NULL, function, char_table, char_table);
 851   return Qnil;
 852 }
 853
 854
 855 static void
 856 map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
 857                                 Lisp_Object function, Lisp_Object table, Lisp_Object arg,
 858                                 Lisp_Object range, struct charset *charset,
 859                                 unsigned from, unsigned to)
 860 {
 861   struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
 862   int depth = XINT (tbl->depth);
 863   int c, i;
 864
 865   if (depth < 3)
 866     for (i = 0, c = XINT (tbl->min_char); i < chartab_size[depth];
 867          i++, c += chartab_chars[depth])
 868       {
 869         Lisp_Object this;
 870
 871         this = tbl->contents[i];
 872         if (SUB_CHAR_TABLE_P (this))
 873           map_sub_char_table_for_charset (c_function, function, this, arg,
 874                                           range, charset, from, to);
 875         else
 876           {
 877             if (! NILP (XCAR (range)))
 878               {
 879                 XSETCDR (range, make_number (c - 1));
 880                 if (c_function)
 881                   (*c_function) (arg, range);
 882                 else
 883                   call2 (function, range, arg);
 884               }
 885             XSETCAR (range, Qnil);
 886           }
 887       }
 888   else
 889     for (i = 0, c = XINT (tbl->min_char); i < chartab_size[depth]; i++, c ++)
 890       {
 891         Lisp_Object this;
 892         unsigned code;
 893
 894         this = tbl->contents[i];
 895         if (NILP (this)
 896             || (charset
 897                 && (code = ENCODE_CHAR (charset, c),
 898                     (code < from || code > to))))
 899           {
 900             if (! NILP (XCAR (range)))
 901               {
 902                 XSETCDR (range, make_number (c - 1));
 903                 if (c_function)
 904                   (*c_function) (arg, range);
 905                 else
 906                   call2 (function, range, arg);
 907                 XSETCAR (range, Qnil);
 908               }
 909           }
 910         else
 911           {
 912             if (NILP (XCAR (range)))
 913               XSETCAR (range, make_number (c));
 914           }
 915       }
 916 }
 917
 918
 919 /* Support function for `map-charset-chars'.  Map C_FUNCTION or
 920    FUNCTION over TABLE, calling it for each character or a group of
 921    succeeding characters that have non-nil value in TABLE.  TABLE is a
 922    "mapping table" or a "deunifier table" of a certain charset.
 923
 924    If CHARSET is not NULL (this is the case that `map-charset-chars'
 925    is called with non-nil FROM-CODE and TO-CODE), it is a charset who
 926    owns TABLE, and the function is called only on a character in the
 927    range FROM and TO.  FROM and TO are not character codes, but code
 928    points of a character in CHARSET.
 929
 930    This function is called in these two cases:
 931
 932    (1) A charset has a mapping file name in :map property.
 933
 934    (2) A charset has an upper code space in :offset property and a
 935    mapping file name in :unify-map property.  In this case, this
 936    function is called only for characters in the Unicode code space.
 937    Characters in upper code space are handled directly in
 938    map_charset_chars.  */
 939
 940 void
 941 map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
 942                             Lisp_Object function, Lisp_Object table, Lisp_Object arg,
 943                             struct charset *charset,
 944                             unsigned from, unsigned to)
 945 {
 946   Lisp_Object range;
 947   int c, i;
 948   struct gcpro gcpro1;
 949
 950   range = Fcons (Qnil, Qnil);
 951   GCPRO1 (range);
 952
 953   for (i = 0, c = 0; i < chartab_size[0]; i++, c += chartab_chars[0])
 954     {
 955       Lisp_Object this;
 956
 957       this = XCHAR_TABLE (table)->contents[i];
 958       if (SUB_CHAR_TABLE_P (this))
 959         map_sub_char_table_for_charset (c_function, function, this, arg,
 960                                         range, charset, from, to);
 961       else
 962         {
 963           if (! NILP (XCAR (range)))
 964             {
 965               XSETCDR (range, make_number (c - 1));
 966               if (c_function)
 967                 (*c_function) (arg, range);
 968               else
 969                 call2 (function, range, arg);
 970             }
 971           XSETCAR (range, Qnil);
 972         }
 973     }
 974   if (! NILP (XCAR (range)))
 975     {
 976       XSETCDR (range, make_number (c - 1));
 977       if (c_function)
 978         (*c_function) (arg, range);
 979       else
 980         call2 (function, range, arg);
 981     }
 982
 983   UNGCPRO;
 984 }
 985
 986 \f
 987 void
 988 syms_of_chartab (void)
 989 {
 990   defsubr (&Smake_char_table);
 991   defsubr (&Schar_table_parent);
 992   defsubr (&Schar_table_subtype);
 993   defsubr (&Sset_char_table_parent);
 994   defsubr (&Schar_table_extra_slot);
 995   defsubr (&Sset_char_table_extra_slot);
 996   defsubr (&Schar_table_range);
 997   defsubr (&Sset_char_table_range);
 998   defsubr (&Sset_char_table_default);
 999   defsubr (&Soptimize_char_table);
1000   defsubr (&Smap_char_table);
1001 }