src/chartab.c

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