git.chise.org Git - chise/xemacs-chise.git.1/blob - src/chartab.c

   1 /* XEmacs routines to deal with char tables.
   2    Copyright (C) 1992, 1995 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Sun Microsystems, Inc.
   4    Copyright (C) 1995, 1996 Ben Wing.
   5
   6 This file is part of XEmacs.
   7
   8 XEmacs is free software; you can redistribute it and/or modify it
   9 under the terms of the GNU General Public License as published by the
  10 Free Software Foundation; either version 2, or (at your option) any
  11 later version.
  12
  13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with XEmacs; 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 /* Synched up with: Mule 2.3.  Not synched with FSF.
  24
  25    This file was written independently of the FSF implementation,
  26    and is not compatible. */
  27
  28 /* Authorship:
  29
  30    Ben Wing: wrote, for 19.13 (Mule).  Some category table stuff
  31              loosely based on the original Mule.
  32    Jareth Hein: fixed a couple of bugs in the implementation, and
  33              added regex support for categories with check_category_at
  34  */
  35
  36 #include <config.h>
  37 #include "lisp.h"
  38
  39 #include "buffer.h"
  40 #include "chartab.h"
  41 #include "commands.h"
  42 #include "syntax.h"
  43
  44 Lisp_Object Qchar_tablep, Qchar_table;
  45
  46 Lisp_Object Vall_syntax_tables;
  47
  48 #ifdef MULE
  49 Lisp_Object Qcategory_table_p;
  50 Lisp_Object Qcategory_designator_p;
  51 Lisp_Object Qcategory_table_value_p;
  52
  53 Lisp_Object Vstandard_category_table;
  54 #endif /* MULE */
  55
  56 \f
  57 /* A char table maps from ranges of characters to values.
  58
  59    Implementing a general data structure that maps from arbitrary
  60    ranges of numbers to values is tricky to do efficiently.  As it
  61    happens, it should suffice (and is usually more convenient, anyway)
  62    when dealing with characters to restrict the sorts of ranges that
  63    can be assigned values, as follows:
  64
  65    1) All characters.
  66    2) All characters in a charset.
  67    3) All characters in a particular row of a charset, where a "row"
  68       means all characters with the same first byte.
  69    4) A particular character in a charset.
  70
  71    We use char tables to generalize the 256-element vectors now
  72    littering the Emacs code.
  73
  74    Possible uses (all should be converted at some point):
  75
  76    1) category tables
  77    2) syntax tables
  78    3) display tables
  79    4) case tables
  80    5) keyboard-translate-table?
  81
  82    We provide an
  83    abstract type to generalize the Emacs vectors and Mule
  84    vectors-of-vectors goo.
  85    */
  86
  87 /************************************************************************/
  88 /*                         Char Table object                            */
  89 /************************************************************************/
  90
  91 #ifdef MULE
  92
  93 static Lisp_Object
  94 mark_char_table_entry (Lisp_Object obj, void (*markobj) (Lisp_Object))
  95 {
  96   struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
  97   int i;
  98
  99   for (i = 0; i < 96; i++)
 100     {
 101       (markobj) (cte->level2[i]);
 102     }
 103   return Qnil;
 104 }
 105
 106 static int
 107 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 108 {
 109   struct Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
 110   struct Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
 111   int i;
 112
 113   for (i = 0; i < 96; i++)
 114     if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
 115       return 0;
 116
 117   return 1;
 118 }
 119
 120 static unsigned long
 121 char_table_entry_hash (Lisp_Object obj, int depth)
 122 {
 123   struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
 124
 125   return internal_array_hash (cte->level2, 96, depth);
 126 }
 127
 128 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
 129                                mark_char_table_entry, internal_object_printer,
 130                                0, char_table_entry_equal,
 131                                char_table_entry_hash,
 132                                struct Lisp_Char_Table_Entry);
 133 #endif /* MULE */
 134
 135 static Lisp_Object
 136 mark_char_table (Lisp_Object obj, void (*markobj) (Lisp_Object))
 137 {
 138   struct Lisp_Char_Table *ct = XCHAR_TABLE (obj);
 139   int i;
 140
 141   for (i = 0; i < NUM_ASCII_CHARS; i++)
 142     (markobj) (ct->ascii[i]);
 143 #ifdef MULE
 144   for (i = 0; i < NUM_LEADING_BYTES; i++)
 145     (markobj) (ct->level1[i]);
 146 #endif
 147   return ct->mirror_table;
 148 }
 149
 150 /* WARNING: All functions of this nature need to be written extremely
 151    carefully to avoid crashes during GC.  Cf. prune_specifiers()
 152    and prune_weak_hashtables(). */
 153
 154 void
 155 prune_syntax_tables (int (*obj_marked_p) (Lisp_Object))
 156 {
 157   Lisp_Object rest, prev = Qnil;
 158
 159   for (rest = Vall_syntax_tables;
 160        !GC_NILP (rest);
 161        rest = XCHAR_TABLE (rest)->next_table)
 162     {
 163       if (! ((*obj_marked_p) (rest)))
 164         {
 165           /* This table is garbage.  Remove it from the list. */
 166           if (GC_NILP (prev))
 167             Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
 168           else
 169             XCHAR_TABLE (prev)->next_table =
 170               XCHAR_TABLE (rest)->next_table;
 171         }
 172     }
 173 }
 174
 175 static Lisp_Object
 176 char_table_type_to_symbol (enum char_table_type type)
 177 {
 178   switch (type)
 179   {
 180   case CHAR_TABLE_TYPE_GENERIC:  return Qgeneric;
 181   case CHAR_TABLE_TYPE_SYNTAX:   return Qsyntax;
 182   case CHAR_TABLE_TYPE_DISPLAY:  return Qdisplay;
 183   case CHAR_TABLE_TYPE_CHAR:     return Qchar;
 184 #ifdef MULE
 185   case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
 186 #endif
 187   }
 188
 189   abort ();
 190   return Qnil; /* not reached */
 191 }
 192
 193 static enum char_table_type
 194 symbol_to_char_table_type (Lisp_Object symbol)
 195 {
 196   CHECK_SYMBOL (symbol);
 197
 198   if (EQ (symbol, Qgeneric))  return CHAR_TABLE_TYPE_GENERIC;
 199   if (EQ (symbol, Qsyntax))   return CHAR_TABLE_TYPE_SYNTAX;
 200   if (EQ (symbol, Qdisplay))  return CHAR_TABLE_TYPE_DISPLAY;
 201   if (EQ (symbol, Qchar))     return CHAR_TABLE_TYPE_CHAR;
 202 #ifdef MULE
 203   if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
 204 #endif
 205
 206   signal_simple_error ("Unrecognized char table type", symbol);
 207   return CHAR_TABLE_TYPE_GENERIC; /* not reached */
 208 }
 209
 210 static void
 211 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
 212                      Lisp_Object printcharfun)
 213 {
 214   if (first != last)
 215     {
 216       write_c_string (" (", printcharfun);
 217       print_internal (make_char (first), printcharfun, 0);
 218       write_c_string (" ", printcharfun);
 219       print_internal (make_char (last), printcharfun, 0);
 220       write_c_string (") ", printcharfun);
 221     }
 222   else
 223     {
 224       write_c_string (" ", printcharfun);
 225       print_internal (make_char (first), printcharfun, 0);
 226       write_c_string (" ", printcharfun);
 227     }
 228   print_internal (val, printcharfun, 1);
 229 }
 230
 231 #ifdef MULE
 232
 233 static void
 234 print_chartab_charset_row (Lisp_Object charset,
 235                            int row,
 236                            struct Lisp_Char_Table_Entry *cte,
 237                            Lisp_Object printcharfun)
 238 {
 239   int i;
 240   Lisp_Object cat = Qunbound;
 241   int first = -1;
 242
 243   for (i = 32; i < 128; i++)
 244     {
 245       Lisp_Object pam = cte->level2[i - 32];
 246
 247       if (first == -1)
 248         {
 249           first = i;
 250           cat = pam;
 251           continue;
 252         }
 253
 254       if (!EQ (cat, pam))
 255         {
 256           if (row == -1)
 257             print_chartab_range (MAKE_CHAR (charset, first, 0),
 258                                  MAKE_CHAR (charset, i - 1, 0),
 259                                  cat, printcharfun);
 260           else
 261             print_chartab_range (MAKE_CHAR (charset, row, first),
 262                                  MAKE_CHAR (charset, row, i - 1),
 263                                  cat, printcharfun);
 264           first = -1;
 265           i--;
 266         }
 267     }
 268
 269   if (first != -1)
 270     {
 271       if (row == -1)
 272         print_chartab_range (MAKE_CHAR (charset, first, 0),
 273                              MAKE_CHAR (charset, i - 1, 0),
 274                              cat, printcharfun);
 275       else
 276         print_chartab_range (MAKE_CHAR (charset, row, first),
 277                              MAKE_CHAR (charset, row, i - 1),
 278                              cat, printcharfun);
 279     }
 280 }
 281
 282 static void
 283 print_chartab_two_byte_charset (Lisp_Object charset,
 284                                 struct Lisp_Char_Table_Entry *cte,
 285                                 Lisp_Object printcharfun)
 286 {
 287   int i;
 288
 289   for (i = 32; i < 128; i++)
 290     {
 291       Lisp_Object jen = cte->level2[i - 32];
 292
 293       if (!CHAR_TABLE_ENTRYP (jen))
 294         {
 295           char buf[100];
 296
 297           write_c_string (" [", printcharfun);
 298           print_internal (XCHARSET_NAME (charset), printcharfun, 0);
 299           sprintf (buf, " %d] ", i);
 300           write_c_string (buf, printcharfun);
 301           print_internal (jen, printcharfun, 0);
 302         }
 303       else
 304         print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
 305                                    printcharfun);
 306     }
 307 }
 308
 309 #endif /* MULE */
 310
 311 static void
 312 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 313 {
 314   struct Lisp_Char_Table *ct = XCHAR_TABLE (obj);
 315   char buf[200];
 316
 317   sprintf (buf, "#s(char-table type %s data (",
 318            string_data (symbol_name (XSYMBOL
 319                                      (char_table_type_to_symbol (ct->type)))));
 320   write_c_string (buf, printcharfun);
 321
 322   /* Now write out the ASCII/Control-1 stuff. */
 323   {
 324     int i;
 325     int first = -1;
 326     Lisp_Object val = Qunbound;
 327
 328     for (i = 0; i < NUM_ASCII_CHARS; i++)
 329       {
 330         if (first == -1)
 331           {
 332             first = i;
 333             val = ct->ascii[i];
 334             continue;
 335           }
 336
 337         if (!EQ (ct->ascii[i], val))
 338           {
 339             print_chartab_range (first, i - 1, val, printcharfun);
 340             first = -1;
 341             i--;
 342           }
 343       }
 344
 345     if (first != -1)
 346       print_chartab_range (first, i - 1, val, printcharfun);
 347   }
 348
 349 #ifdef MULE
 350   {
 351     int i;
 352
 353     for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
 354          i++)
 355       {
 356         Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
 357         Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
 358
 359         if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
 360             || i == LEADING_BYTE_CONTROL_1)
 361           continue;
 362         if (!CHAR_TABLE_ENTRYP (ann))
 363           {
 364             write_c_string (" ", printcharfun);
 365             print_internal (XCHARSET_NAME (charset),
 366                             printcharfun, 0);
 367             write_c_string (" ", printcharfun);
 368             print_internal (ann, printcharfun, 0);
 369           }
 370         else
 371           {
 372             struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
 373             if (XCHARSET_DIMENSION (charset) == 1)
 374               print_chartab_charset_row (charset, -1, cte, printcharfun);
 375             else
 376               print_chartab_two_byte_charset (charset, cte, printcharfun);
 377           }
 378       }
 379   }
 380 #endif /* MULE */
 381
 382   write_c_string ("))", printcharfun);
 383 }
 384
 385 static int
 386 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 387 {
 388   struct Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
 389   struct Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
 390   int i;
 391
 392   if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
 393     return 0;
 394
 395   for (i = 0; i < NUM_ASCII_CHARS; i++)
 396     if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
 397       return 0;
 398
 399 #ifdef MULE
 400   for (i = 0; i < NUM_LEADING_BYTES; i++)
 401     if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
 402       return 0;
 403 #endif /* MULE */
 404
 405   return 1;
 406 }
 407
 408 static unsigned long
 409 char_table_hash (Lisp_Object obj, int depth)
 410 {
 411   struct Lisp_Char_Table *ct = XCHAR_TABLE (obj);
 412   unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
 413                                                depth);
 414 #ifdef MULE
 415   hashval = HASH2 (hashval,
 416                    internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
 417 #endif /* MULE */
 418   return hashval;
 419 }
 420
 421 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
 422                                mark_char_table, print_char_table, 0,
 423                                char_table_equal, char_table_hash,
 424                                struct Lisp_Char_Table);
 425
 426 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
 427 Return non-nil if OBJECT is a char table.
 428
 429 A char table is a table that maps characters (or ranges of characters)
 430 to values.  Char tables are specialized for characters, only allowing
 431 particular sorts of ranges to be assigned values.  Although this
 432 loses in generality, it makes for extremely fast (constant-time)
 433 lookups, and thus is feasible for applications that do an extremely
 434 large number of lookups (e.g. scanning a buffer for a character in
 435 a particular syntax, where a lookup in the syntax table must occur
 436 once per character).
 437
 438 When Mule support exists, the types of ranges that can be assigned
 439 values are
 440
 441 -- all characters
 442 -- an entire charset
 443 -- a single row in a two-octet charset
 444 -- a single character
 445
 446 When Mule support is not present, the types of ranges that can be
 447 assigned values are
 448
 449 -- all characters
 450 -- a single character
 451
 452 To create a char table, use `make-char-table'.  To modify a char
 453 table, use `put-char-table' or `remove-char-table'.  To retrieve the
 454 value for a particular character, use `get-char-table'.  See also
 455 `map-char-table', `clear-char-table', `copy-char-table',
 456 `valid-char-table-type-p', `char-table-type-list', `valid-char-table-value-p',
 457 and `check-char-table-value'.
 458 */
 459        (object))
 460 {
 461   return CHAR_TABLEP (object) ? Qt : Qnil;
 462 }
 463
 464 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
 465 Return a list of the recognized char table types.
 466 See `valid-char-table-type-p'.
 467 */
 468        ())
 469 {
 470 #ifdef MULE
 471   return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
 472 #else
 473   return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
 474 #endif
 475 }
 476
 477 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
 478 Return t if TYPE if a recognized char table type.
 479
 480 Each char table type is used for a different purpose and allows different
 481 sorts of values.  The different char table types are
 482
 483 `category'
 484         Used for category tables, which specify the regexp categories
 485         that a character is in.  The valid values are nil or a
 486         bit vector of 95 elements.  Higher-level Lisp functions are
 487         provided for working with category tables.  Currently categories
 488         and category tables only exist when Mule support is present.
 489 `char'
 490         A generalized char table, for mapping from one character to
 491         another.  Used for case tables, syntax matching tables,
 492         `keyboard-translate-table', etc.  The valid values are characters.
 493 `generic'
 494         An even more generalized char table, for mapping from a
 495         character to anything.
 496 `display'
 497         Used for display tables, which specify how a particular character
 498         is to appear when displayed.  #### Not yet implemented.
 499 `syntax'
 500         Used for syntax tables, which specify the syntax of a particular
 501         character.  Higher-level Lisp functions are provided for
 502         working with syntax tables.  The valid values are integers.
 503
 504 */
 505        (type))
 506 {
 507   return (EQ (type, Qchar)     ||
 508 #ifdef MULE
 509           EQ (type, Qcategory) ||
 510 #endif
 511           EQ (type, Qdisplay)  ||
 512           EQ (type, Qgeneric)  ||
 513           EQ (type, Qsyntax)) ? Qt : Qnil;
 514 }
 515
 516 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
 517 Return the type of char table TABLE.
 518 See `valid-char-table-type-p'.
 519 */
 520        (table))
 521 {
 522   CHECK_CHAR_TABLE (table);
 523   return char_table_type_to_symbol (XCHAR_TABLE (table)->type);
 524 }
 525
 526 void
 527 fill_char_table (struct Lisp_Char_Table *ct, Lisp_Object value)
 528 {
 529   int i;
 530
 531   for (i = 0; i < NUM_ASCII_CHARS; i++)
 532     ct->ascii[i] = value;
 533 #ifdef MULE
 534   for (i = 0; i < NUM_LEADING_BYTES; i++)
 535     ct->level1[i] = value;
 536 #endif /* MULE */
 537
 538   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
 539     update_syntax_table (ct);
 540 }
 541
 542 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
 543 Reset a char table to its default state.
 544 */
 545        (table))
 546 {
 547   struct Lisp_Char_Table *ct;
 548
 549   CHECK_CHAR_TABLE (table);
 550   ct = XCHAR_TABLE (table);
 551
 552   switch (ct->type)
 553     {
 554     case CHAR_TABLE_TYPE_CHAR:
 555       fill_char_table (ct, make_char (0));
 556       break;
 557     case CHAR_TABLE_TYPE_DISPLAY:
 558     case CHAR_TABLE_TYPE_GENERIC:
 559 #ifdef MULE
 560     case CHAR_TABLE_TYPE_CATEGORY:
 561 #endif /* MULE */
 562       fill_char_table (ct, Qnil);
 563       break;
 564
 565     case CHAR_TABLE_TYPE_SYNTAX:
 566       fill_char_table (ct, make_int (Sinherit));
 567       break;
 568
 569     default:
 570       abort ();
 571     }
 572
 573   return Qnil;
 574 }
 575
 576 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
 577 Return a new, empty char table of type TYPE.
 578 Currently recognized types are 'char, 'category, 'display, 'generic,
 579 and 'syntax.  See `valid-char-table-type-p'.
 580 */
 581        (type))
 582 {
 583   struct Lisp_Char_Table *ct;
 584   Lisp_Object obj;
 585   enum char_table_type ty = symbol_to_char_table_type (type);
 586
 587   ct = alloc_lcrecord_type (struct Lisp_Char_Table, lrecord_char_table);
 588   ct->type = ty;
 589   if (ty == CHAR_TABLE_TYPE_SYNTAX)
 590     {
 591       ct->mirror_table = Fmake_char_table (Qgeneric);
 592       fill_char_table (XCHAR_TABLE (ct->mirror_table),
 593                        make_int (Spunct));
 594     }
 595   else
 596     ct->mirror_table = Qnil;
 597   ct->next_table = Qnil;
 598   XSETCHAR_TABLE (obj, ct);
 599   if (ty == CHAR_TABLE_TYPE_SYNTAX)
 600     {
 601       ct->next_table = Vall_syntax_tables;
 602       Vall_syntax_tables = obj;
 603     }
 604   Freset_char_table (obj);
 605   return obj;
 606 }
 607
 608 #ifdef MULE
 609
 610 static Lisp_Object
 611 make_char_table_entry (Lisp_Object initval)
 612 {
 613   Lisp_Object obj;
 614   int i;
 615   struct Lisp_Char_Table_Entry *cte =
 616     alloc_lcrecord_type (struct Lisp_Char_Table_Entry,
 617                          lrecord_char_table_entry);
 618
 619   for (i = 0; i < 96; i++)
 620     cte->level2[i] = initval;
 621
 622   XSETCHAR_TABLE_ENTRY (obj, cte);
 623   return obj;
 624 }
 625
 626 static Lisp_Object
 627 copy_char_table_entry (Lisp_Object entry)
 628 {
 629   struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
 630   Lisp_Object obj;
 631   int i;
 632   struct Lisp_Char_Table_Entry *ctenew =
 633     alloc_lcrecord_type (struct Lisp_Char_Table_Entry,
 634                          lrecord_char_table_entry);
 635
 636   for (i = 0; i < 96; i++)
 637     {
 638       Lisp_Object new = cte->level2[i];
 639       if (CHAR_TABLE_ENTRYP (new))
 640         ctenew->level2[i] = copy_char_table_entry (new);
 641       else
 642         ctenew->level2[i] = new;
 643     }
 644
 645   XSETCHAR_TABLE_ENTRY (obj, ctenew);
 646   return obj;
 647 }
 648
 649 #endif /* MULE */
 650
 651 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
 652 Make a new char table which is a copy of OLD-TABLE.
 653 It will contain the same values for the same characters and ranges
 654 as OLD-TABLE.  The values will not themselves be copied.
 655 */
 656        (old_table))
 657 {
 658   struct Lisp_Char_Table *ct, *ctnew;
 659   Lisp_Object obj;
 660   int i;
 661
 662   CHECK_CHAR_TABLE (old_table);
 663   ct = XCHAR_TABLE (old_table);
 664   ctnew = alloc_lcrecord_type (struct Lisp_Char_Table, lrecord_char_table);
 665   ctnew->type = ct->type;
 666
 667   for (i = 0; i < NUM_ASCII_CHARS; i++)
 668     {
 669       Lisp_Object new = ct->ascii[i];
 670 #ifdef MULE
 671       assert (! (CHAR_TABLE_ENTRYP (new)));
 672 #endif /* MULE */
 673       ctnew->ascii[i] = new;
 674     }
 675
 676 #ifdef MULE
 677
 678   for (i = 0; i < NUM_LEADING_BYTES; i++)
 679     {
 680       Lisp_Object new = ct->level1[i];
 681       if (CHAR_TABLE_ENTRYP (new))
 682         ctnew->level1[i] = copy_char_table_entry (new);
 683       else
 684         ctnew->level1[i] = new;
 685     }
 686
 687 #endif /* MULE */
 688
 689   if (CHAR_TABLEP (ct->mirror_table))
 690     ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
 691   else
 692     ctnew->mirror_table = ct->mirror_table;
 693   XSETCHAR_TABLE (obj, ctnew);
 694   return obj;
 695 }
 696
 697 static void
 698 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
 699 {
 700   if (EQ (range, Qt))
 701     outrange->type = CHARTAB_RANGE_ALL;
 702   else if (CHAR_OR_CHAR_INTP (range))
 703     {
 704       outrange->type = CHARTAB_RANGE_CHAR;
 705       outrange->ch = XCHAR_OR_CHAR_INT (range);
 706     }
 707 #ifndef MULE
 708   else
 709     signal_simple_error ("Range must be t or a character", range);
 710 #else /* MULE */
 711   else if (VECTORP (range))
 712     {
 713       struct Lisp_Vector *vec = XVECTOR (range);
 714       Lisp_Object *elts = vector_data (vec);
 715       if (vector_length (vec) != 2)
 716         signal_simple_error ("Length of charset row vector must be 2",
 717                              range);
 718       outrange->type = CHARTAB_RANGE_ROW;
 719       outrange->charset = Fget_charset (elts[0]);
 720       CHECK_INT (elts[1]);
 721       outrange->row = XINT (elts[1]);
 722       switch (XCHARSET_TYPE (outrange->charset))
 723         {
 724         case CHARSET_TYPE_94:
 725         case CHARSET_TYPE_96:
 726           signal_simple_error ("Charset in row vector must be multi-byte",
 727                                outrange->charset);
 728         case CHARSET_TYPE_94X94:
 729           check_int_range (outrange->row, 33, 126);
 730           break;
 731         case CHARSET_TYPE_96X96:
 732           check_int_range (outrange->row, 32, 127);
 733           break;
 734         default:
 735           abort ();
 736         }
 737     }
 738   else
 739     {
 740       if (!CHARSETP (range) && !SYMBOLP (range))
 741         signal_simple_error
 742           ("Char table range must be t, charset, char, or vector", range);
 743       outrange->type = CHARTAB_RANGE_CHARSET;
 744       outrange->charset = Fget_charset (range);
 745     }
 746 #endif /* MULE */
 747 }
 748
 749 #ifdef MULE
 750
 751 /* called from CHAR_TABLE_VALUE(). */
 752 Lisp_Object
 753 get_non_ascii_char_table_value (struct Lisp_Char_Table *ct, int leading_byte,
 754                                Emchar c)
 755 {
 756   Lisp_Object val;
 757   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
 758   int byte1, byte2;
 759
 760   BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
 761   val = ct->level1[leading_byte - MIN_LEADING_BYTE];
 762   if (CHAR_TABLE_ENTRYP (val))
 763     {
 764       struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
 765       val = cte->level2[byte1 - 32];
 766       if (CHAR_TABLE_ENTRYP (val))
 767         {
 768           cte = XCHAR_TABLE_ENTRY (val);
 769           assert (byte2 >= 32);
 770           val = cte->level2[byte2 - 32];
 771           assert (!CHAR_TABLE_ENTRYP (val));
 772         }
 773     }
 774
 775   return val;
 776 }
 777
 778 #endif /* MULE */
 779
 780 Lisp_Object
 781 get_char_table (Emchar ch, struct Lisp_Char_Table *ct)
 782 {
 783 #ifdef MULE
 784   {
 785     Lisp_Object charset;
 786     int byte1, byte2;
 787     Lisp_Object val;
 788
 789     BREAKUP_CHAR (ch, charset, byte1, byte2);
 790
 791     if (EQ (charset, Vcharset_ascii))
 792       val = ct->ascii[byte1];
 793     else if (EQ (charset, Vcharset_control_1))
 794       val = ct->ascii[byte1 + 128];
 795     else
 796       {
 797         int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
 798         val = ct->level1[lb];
 799         if (CHAR_TABLE_ENTRYP (val))
 800           {
 801             struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
 802             val = cte->level2[byte1 - 32];
 803             if (CHAR_TABLE_ENTRYP (val))
 804               {
 805                 cte = XCHAR_TABLE_ENTRY (val);
 806                 assert (byte2 >= 32);
 807                 val = cte->level2[byte2 - 32];
 808                 assert (!CHAR_TABLE_ENTRYP (val));
 809               }
 810           }
 811       }
 812
 813     return val;
 814   }
 815 #else /* not MULE */
 816   return ct->ascii[(unsigned char)ch];
 817 #endif /* not MULE */
 818 }
 819
 820
 821 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
 822 Find value for char CH in TABLE.
 823 */
 824        (ch, table))
 825 {
 826   struct Lisp_Char_Table *ct;
 827
 828   CHECK_CHAR_TABLE (table);
 829   ct = XCHAR_TABLE (table);
 830   CHECK_CHAR_COERCE_INT (ch);
 831
 832   return get_char_table (XCHAR (ch), ct);
 833 }
 834
 835 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
 836 Find value for a range in TABLE.
 837 If there is more than one value, return MULTI (defaults to nil).
 838 */
 839        (range, table, multi))
 840 {
 841   struct Lisp_Char_Table *ct;
 842   struct chartab_range rainj;
 843
 844   if (CHAR_OR_CHAR_INTP (range))
 845     return Fget_char_table (range, table);
 846   CHECK_CHAR_TABLE (table);
 847   ct = XCHAR_TABLE (table);
 848
 849   decode_char_table_range (range, &rainj);
 850   switch (rainj.type)
 851     {
 852     case CHARTAB_RANGE_ALL:
 853       {
 854         int i;
 855         Lisp_Object first = ct->ascii[0];
 856
 857         for (i = 1; i < NUM_ASCII_CHARS; i++)
 858           if (!EQ (first, ct->ascii[i]))
 859             return multi;
 860
 861 #ifdef MULE
 862         for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
 863              i++)
 864           {
 865             if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
 866                 || i == LEADING_BYTE_ASCII
 867                 || i == LEADING_BYTE_CONTROL_1)
 868               continue;
 869             if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
 870               return multi;
 871           }
 872 #endif /* MULE */
 873
 874         return first;
 875       }
 876
 877 #ifdef MULE
 878     case CHARTAB_RANGE_CHARSET:
 879       if (EQ (rainj.charset, Vcharset_ascii))
 880         {
 881           int i;
 882           Lisp_Object first = ct->ascii[0];
 883
 884           for (i = 1; i < 128; i++)
 885             if (!EQ (first, ct->ascii[i]))
 886               return multi;
 887           return first;
 888         }
 889
 890       if (EQ (rainj.charset, Vcharset_control_1))
 891         {
 892           int i;
 893           Lisp_Object first = ct->ascii[128];
 894
 895           for (i = 129; i < 160; i++)
 896             if (!EQ (first, ct->ascii[i]))
 897               return multi;
 898           return first;
 899         }
 900
 901       {
 902         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
 903                                      MIN_LEADING_BYTE];
 904         if (CHAR_TABLE_ENTRYP (val))
 905           return multi;
 906         return val;
 907       }
 908
 909     case CHARTAB_RANGE_ROW:
 910       {
 911         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
 912                                      MIN_LEADING_BYTE];
 913         if (!CHAR_TABLE_ENTRYP (val))
 914           return val;
 915         val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
 916         if (CHAR_TABLE_ENTRYP (val))
 917           return multi;
 918         return val;
 919       }
 920 #endif /* not MULE */
 921
 922     default:
 923       abort ();
 924     }
 925
 926   return Qnil; /* not reached */
 927 }
 928
 929 static int
 930 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
 931                               Error_behavior errb)
 932 {
 933   switch (type)
 934     {
 935     case CHAR_TABLE_TYPE_SYNTAX:
 936       if (!ERRB_EQ (errb, ERROR_ME))
 937         return INTP (value) || (CONSP (value) && INTP (XCAR (value))
 938                                 && CHAR_OR_CHAR_INTP (XCDR (value)));
 939       if (CONSP (value))
 940         {
 941           Lisp_Object cdr = XCDR (value);
 942           CHECK_INT (XCAR (value));
 943           CHECK_CHAR_COERCE_INT (cdr);
 944          }
 945       else
 946         CHECK_INT (value);
 947       break;
 948
 949 #ifdef MULE
 950     case CHAR_TABLE_TYPE_CATEGORY:
 951       if (!ERRB_EQ (errb, ERROR_ME))
 952         return CATEGORY_TABLE_VALUEP (value);
 953       CHECK_CATEGORY_TABLE_VALUE (value);
 954       break;
 955 #endif /* MULE */
 956
 957     case CHAR_TABLE_TYPE_GENERIC:
 958       return 1;
 959
 960     case CHAR_TABLE_TYPE_DISPLAY:
 961       /* #### fix this */
 962       maybe_signal_simple_error ("Display char tables not yet implemented",
 963                                  value, Qchar_table, errb);
 964       return 0;
 965
 966     case CHAR_TABLE_TYPE_CHAR:
 967       if (!ERRB_EQ (errb, ERROR_ME))
 968         return CHAR_OR_CHAR_INTP (value);
 969       CHECK_CHAR_COERCE_INT (value);
 970       break;
 971
 972     default:
 973       abort ();
 974     }
 975
 976   return 0; /* not reached */
 977 }
 978
 979 static Lisp_Object
 980 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
 981 {
 982   switch (type)
 983     {
 984     case CHAR_TABLE_TYPE_SYNTAX:
 985       if (CONSP (value))
 986         {
 987           Lisp_Object car = XCAR (value);
 988           Lisp_Object cdr = XCDR (value);
 989           CHECK_CHAR_COERCE_INT (cdr);
 990           return Fcons (car, cdr);
 991         }
 992       break;
 993     case CHAR_TABLE_TYPE_CHAR:
 994       CHECK_CHAR_COERCE_INT (value);
 995       break;
 996     default:
 997       break;
 998     }
 999   return value;
1000 }
1001
1002 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
1003 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
1004 */
1005        (value, char_table_type))
1006 {
1007   enum char_table_type type = symbol_to_char_table_type (char_table_type);
1008
1009   return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
1010 }
1011
1012 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
1013 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
1014 */
1015        (value, char_table_type))
1016 {
1017   enum char_table_type type = symbol_to_char_table_type (char_table_type);
1018
1019   check_valid_char_table_value (value, type, ERROR_ME);
1020   return Qnil;
1021 }
1022
1023 /* Assign VAL to all characters in RANGE in char table CT. */
1024
1025 void
1026 put_char_table (struct Lisp_Char_Table *ct, struct chartab_range *range,
1027                 Lisp_Object val)
1028 {
1029   switch (range->type)
1030     {
1031     case CHARTAB_RANGE_ALL:
1032       fill_char_table (ct, val);
1033       return; /* avoid the duplicate call to update_syntax_table() below,
1034                  since fill_char_table() also did that. */
1035
1036 #ifdef MULE
1037     case CHARTAB_RANGE_CHARSET:
1038       if (EQ (range->charset, Vcharset_ascii))
1039         {
1040           int i;
1041           for (i = 0; i < 128; i++)
1042             ct->ascii[i] = val;
1043         }
1044       else if (EQ (range->charset, Vcharset_control_1))
1045         {
1046           int i;
1047           for (i = 128; i < 160; i++)
1048             ct->ascii[i] = val;
1049         }
1050       else
1051         {
1052           int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1053           ct->level1[lb] = val;
1054         }
1055       break;
1056
1057     case CHARTAB_RANGE_ROW:
1058       {
1059         struct Lisp_Char_Table_Entry *cte;
1060         int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1061         /* make sure that there is a separate entry for the row. */
1062         if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1063           ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1064         cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1065         cte->level2[range->row - 32] = val;
1066       }
1067       break;
1068 #endif /* MULE */
1069
1070     case CHARTAB_RANGE_CHAR:
1071 #ifdef MULE
1072       {
1073         Lisp_Object charset;
1074         int byte1, byte2;
1075
1076         BREAKUP_CHAR (range->ch, charset, byte1, byte2);
1077         if (EQ (charset, Vcharset_ascii))
1078           ct->ascii[byte1] = val;
1079         else if (EQ (charset, Vcharset_control_1))
1080           ct->ascii[byte1 + 128] = val;
1081         else
1082           {
1083             struct Lisp_Char_Table_Entry *cte;
1084             int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1085             /* make sure that there is a separate entry for the row. */
1086             if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1087               ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1088             cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1089             /* now CTE is a char table entry for the charset;
1090                each entry is for a single row (or character of
1091                a one-octet charset). */
1092             if (XCHARSET_DIMENSION (charset) == 1)
1093               cte->level2[byte1 - 32] = val;
1094             else
1095               {
1096                 /* assigning to one character in a two-octet charset. */
1097                 /* make sure that the charset row contains a separate
1098                    entry for each character. */
1099                 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
1100                   cte->level2[byte1 - 32] =
1101                     make_char_table_entry (cte->level2[byte1 - 32]);
1102                 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
1103                 cte->level2[byte2 - 32] = val;
1104               }
1105           }
1106       }
1107 #else /* not MULE */
1108       ct->ascii[(unsigned char) (range->ch)] = val;
1109       break;
1110 #endif /* not MULE */
1111     }
1112
1113   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1114     update_syntax_table (ct);
1115 }
1116
1117 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
1118 Set the value for chars in RANGE to be VAL in TABLE.
1119
1120 RANGE specifies one or more characters to be affected and should be
1121 one of the following:
1122
1123 -- t (all characters are affected)
1124 -- A charset (only allowed when Mule support is present)
1125 -- A vector of two elements: a two-octet charset and a row number
1126    (only allowed when Mule support is present)
1127 -- A single character
1128
1129 VAL must be a value appropriate for the type of TABLE.
1130 See `valid-char-table-type-p'.
1131 */
1132        (range, val, table))
1133 {
1134   struct Lisp_Char_Table *ct;
1135   struct chartab_range rainj;
1136
1137   CHECK_CHAR_TABLE (table);
1138   ct = XCHAR_TABLE (table);
1139   check_valid_char_table_value (val, ct->type, ERROR_ME);
1140   decode_char_table_range (range, &rainj);
1141   val = canonicalize_char_table_value (val, ct->type);
1142   put_char_table (ct, &rainj, val);
1143   return Qnil;
1144 }
1145
1146 /* Map FN over the ASCII chars in CT. */
1147
1148 static int
1149 map_over_charset_ascii (struct Lisp_Char_Table *ct,
1150                         int (*fn) (struct chartab_range *range,
1151                                    Lisp_Object val, void *arg),
1152                         void *arg)
1153 {
1154   struct chartab_range rainj;
1155   int i, retval;
1156   int start = 0;
1157 #ifdef MULE
1158   int stop = 128;
1159 #else
1160   int stop = 256;
1161 #endif
1162
1163   rainj.type = CHARTAB_RANGE_CHAR;
1164
1165   for (i = start, retval = 0; i < stop && retval == 0; i++)
1166     {
1167       rainj.ch = (Emchar) i;
1168       retval = (fn) (&rainj, ct->ascii[i], arg);
1169     }
1170
1171   return retval;
1172 }
1173
1174 #ifdef MULE
1175
1176 /* Map FN over the Control-1 chars in CT. */
1177
1178 static int
1179 map_over_charset_control_1 (struct Lisp_Char_Table *ct,
1180                             int (*fn) (struct chartab_range *range,
1181                                        Lisp_Object val, void *arg),
1182                             void *arg)
1183 {
1184   struct chartab_range rainj;
1185   int i, retval;
1186   int start = 128;
1187   int stop  = start + 32;
1188
1189   rainj.type = CHARTAB_RANGE_CHAR;
1190
1191   for (i = start, retval = 0; i < stop && retval == 0; i++)
1192     {
1193       rainj.ch = (Emchar) (i);
1194       retval = (fn) (&rainj, ct->ascii[i], arg);
1195     }
1196
1197   return retval;
1198 }
1199
1200 /* Map FN over the row ROW of two-byte charset CHARSET.
1201    There must be a separate value for that row in the char table.
1202    CTE specifies the char table entry for CHARSET. */
1203
1204 static int
1205 map_over_charset_row (struct Lisp_Char_Table_Entry *cte,
1206                       Lisp_Object charset, int row,
1207                       int (*fn) (struct chartab_range *range,
1208                                  Lisp_Object val, void *arg),
1209                       void *arg)
1210 {
1211   Lisp_Object val = cte->level2[row - 32];
1212
1213   if (!CHAR_TABLE_ENTRYP (val))
1214     {
1215       struct chartab_range rainj;
1216
1217       rainj.type = CHARTAB_RANGE_ROW;
1218       rainj.charset = charset;
1219       rainj.row = row;
1220       return (fn) (&rainj, val, arg);
1221     }
1222   else
1223     {
1224       struct chartab_range rainj;
1225       int i, retval;
1226       int charset94_p = (XCHARSET_CHARS (charset) == 94);
1227       int start = charset94_p ?  33 :  32;
1228       int stop  = charset94_p ? 127 : 128;
1229
1230       cte = XCHAR_TABLE_ENTRY (val);
1231
1232       rainj.type = CHARTAB_RANGE_CHAR;
1233
1234       for (i = start, retval = 0; i < stop && retval == 0; i++)
1235         {
1236           rainj.ch = MAKE_CHAR (charset, row, i);
1237           retval = (fn) (&rainj, cte->level2[i - 32], arg);
1238         }
1239       return retval;
1240     }
1241 }
1242
1243
1244 static int
1245 map_over_other_charset (struct Lisp_Char_Table *ct, int lb,
1246                         int (*fn) (struct chartab_range *range,
1247                                    Lisp_Object val, void *arg),
1248                         void *arg)
1249 {
1250   Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
1251   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
1252
1253   if (!CHARSETP (charset)
1254       || lb == LEADING_BYTE_ASCII
1255       || lb == LEADING_BYTE_CONTROL_1)
1256     return 0;
1257
1258   if (!CHAR_TABLE_ENTRYP (val))
1259     {
1260       struct chartab_range rainj;
1261
1262       rainj.type = CHARTAB_RANGE_CHARSET;
1263       rainj.charset = charset;
1264       return (fn) (&rainj, val, arg);
1265     }
1266
1267   {
1268     struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1269     int charset94_p = (XCHARSET_CHARS (charset) == 94);
1270     int start = charset94_p ?  33 :  32;
1271     int stop  = charset94_p ? 127 : 128;
1272     int i, retval;
1273
1274     if (XCHARSET_DIMENSION (charset) == 1)
1275       {
1276         struct chartab_range rainj;
1277         rainj.type = CHARTAB_RANGE_CHAR;
1278
1279         for (i = start, retval = 0; i < stop && retval == 0; i++)
1280           {
1281             rainj.ch = MAKE_CHAR (charset, i, 0);
1282             retval = (fn) (&rainj, cte->level2[i - 32], arg);
1283           }
1284       }
1285     else
1286       {
1287         for (i = start, retval = 0; i < stop && retval == 0; i++)
1288           retval = map_over_charset_row (cte, charset, i, fn, arg);
1289       }
1290
1291     return retval;
1292   }
1293 }
1294
1295 #endif /* MULE */
1296
1297 /* Map FN (with client data ARG) over range RANGE in char table CT.
1298    Mapping stops the first time FN returns non-zero, and that value
1299    becomes the return value of map_char_table(). */
1300
1301 int
1302 map_char_table (struct Lisp_Char_Table *ct,
1303                 struct chartab_range *range,
1304                 int (*fn) (struct chartab_range *range,
1305                            Lisp_Object val, void *arg),
1306                 void *arg)
1307 {
1308   switch (range->type)
1309     {
1310     case CHARTAB_RANGE_ALL:
1311       {
1312         int retval;
1313
1314         retval = map_over_charset_ascii (ct, fn, arg);
1315         if (retval)
1316           return retval;
1317 #ifdef MULE
1318         retval = map_over_charset_control_1 (ct, fn, arg);
1319         if (retval)
1320           return retval;
1321         {
1322           int i;
1323           int start = MIN_LEADING_BYTE;
1324           int stop  = start + NUM_LEADING_BYTES;
1325
1326           for (i = start, retval = 0; i < stop && retval == 0; i++)
1327             {
1328               retval = map_over_other_charset (ct, i, fn, arg);
1329             }
1330         }
1331 #endif /* MULE */
1332         return retval;
1333       }
1334
1335 #ifdef MULE
1336     case CHARTAB_RANGE_CHARSET:
1337       return map_over_other_charset (ct,
1338                                      XCHARSET_LEADING_BYTE (range->charset),
1339                                      fn, arg);
1340
1341     case CHARTAB_RANGE_ROW:
1342       {
1343         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE];
1344         if (!CHAR_TABLE_ENTRYP (val))
1345           {
1346             struct chartab_range rainj;
1347
1348             rainj.type = CHARTAB_RANGE_ROW;
1349             rainj.charset = range->charset;
1350             rainj.row = range->row;
1351             return (fn) (&rainj, val, arg);
1352           }
1353         else
1354           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
1355                                        range->charset, range->row,
1356                                        fn, arg);
1357       }
1358 #endif /* MULE */
1359
1360     case CHARTAB_RANGE_CHAR:
1361       {
1362         Emchar ch = range->ch;
1363         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
1364         struct chartab_range rainj;
1365
1366         rainj.type = CHARTAB_RANGE_CHAR;
1367         rainj.ch = ch;
1368         return (fn) (&rainj, val, arg);
1369       }
1370
1371     default:
1372       abort ();
1373     }
1374
1375   return 0;
1376 }
1377
1378 struct slow_map_char_table_arg
1379 {
1380   Lisp_Object function;
1381   Lisp_Object retval;
1382 };
1383
1384 static int
1385 slow_map_char_table_fun (struct chartab_range *range,
1386                          Lisp_Object val, void *arg)
1387 {
1388   Lisp_Object ranjarg = Qnil;
1389   struct slow_map_char_table_arg *closure =
1390     (struct slow_map_char_table_arg *) arg;
1391
1392   switch (range->type)
1393     {
1394     case CHARTAB_RANGE_ALL:
1395       ranjarg = Qt;
1396       break;
1397
1398 #ifdef MULE
1399     case CHARTAB_RANGE_CHARSET:
1400       ranjarg = XCHARSET_NAME (range->charset);
1401       break;
1402
1403     case CHARTAB_RANGE_ROW:
1404       ranjarg = vector2 (XCHARSET_NAME (range->charset),
1405                          make_int (range->row));
1406       break;
1407 #endif /* MULE */
1408     case CHARTAB_RANGE_CHAR:
1409       ranjarg = make_char (range->ch);
1410       break;
1411     default:
1412       abort ();
1413     }
1414
1415   closure->retval = call2 (closure->function, ranjarg, val);
1416   return !NILP (closure->retval);
1417 }
1418
1419 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
1420 Map FUNCTION over entries in TABLE, calling it with two args,
1421 each key and value in the table.
1422
1423 RANGE specifies a subrange to map over and is in the same format as
1424 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
1425 the entire table.
1426 */
1427        (function, table, range))
1428 {
1429   struct Lisp_Char_Table *ct;
1430   struct slow_map_char_table_arg slarg;
1431   struct gcpro gcpro1, gcpro2;
1432   struct chartab_range rainj;
1433
1434   CHECK_CHAR_TABLE (table);
1435   ct = XCHAR_TABLE (table);
1436   if (NILP (range))
1437     range = Qt;
1438   decode_char_table_range (range, &rainj);
1439   slarg.function = function;
1440   slarg.retval = Qnil;
1441   GCPRO2 (slarg.function, slarg.retval);
1442   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
1443   UNGCPRO;
1444
1445   return slarg.retval;
1446 }
1447
1448
1449 \f
1450 /************************************************************************/
1451 /*                         Char table read syntax                       */
1452 /************************************************************************/
1453
1454 static int
1455 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
1456                        Error_behavior errb)
1457 {
1458   /* #### should deal with ERRB */
1459   symbol_to_char_table_type (value);
1460   return 1;
1461 }
1462
1463 static int
1464 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
1465                        Error_behavior errb)
1466 {
1467   Lisp_Object rest;
1468
1469   /* #### should deal with ERRB */
1470   EXTERNAL_LIST_LOOP (rest, value)
1471     {
1472       Lisp_Object range = XCAR (rest);
1473       struct chartab_range dummy;
1474
1475       rest = XCDR (rest);
1476       if (!CONSP (rest))
1477         signal_simple_error ("Invalid list format", value);
1478       if (CONSP (range))
1479         {
1480           if (!CONSP (XCDR (range))
1481               || !NILP (XCDR (XCDR (range))))
1482             signal_simple_error ("Invalid range format", range);
1483           decode_char_table_range (XCAR (range), &dummy);
1484           decode_char_table_range (XCAR (XCDR (range)), &dummy);
1485         }
1486       else
1487         decode_char_table_range (range, &dummy);
1488     }
1489
1490   return 1;
1491 }
1492
1493 static Lisp_Object
1494 chartab_instantiate (Lisp_Object data)
1495 {
1496   Lisp_Object chartab;
1497   Lisp_Object type = Qgeneric;
1498   Lisp_Object dataval = Qnil;
1499
1500   while (!NILP (data))
1501     {
1502       Lisp_Object keyw = Fcar (data);
1503       Lisp_Object valw;
1504
1505       data = Fcdr (data);
1506       valw = Fcar (data);
1507       data = Fcdr (data);
1508       if (EQ (keyw, Qtype))
1509         type = valw;
1510       else if (EQ (keyw, Qdata))
1511         dataval = valw;
1512     }
1513
1514   chartab = Fmake_char_table (type);
1515
1516   data = dataval;
1517   while (!NILP (data))
1518     {
1519       Lisp_Object range = Fcar (data);
1520       Lisp_Object val = Fcar (Fcdr (data));
1521
1522       data = Fcdr (Fcdr (data));
1523       if (CONSP (range))
1524         {
1525           if (CHAR_OR_CHAR_INTP (XCAR (range)))
1526             {
1527               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
1528               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
1529               Emchar i;
1530
1531               for (i = first; i <= last; i++)
1532                  Fput_char_table (make_char (i), val, chartab);
1533             }
1534           else
1535             abort ();
1536         }
1537       else
1538         Fput_char_table (range, val, chartab);
1539     }
1540
1541   return chartab;
1542 }
1543
1544 #ifdef MULE
1545
1546 \f
1547 /************************************************************************/
1548 /*                     Category Tables, specifically                    */
1549 /************************************************************************/
1550
1551 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
1552 Return t if ARG is a category table.
1553 A category table is a type of char table used for keeping track of
1554 categories.  Categories are used for classifying characters for use
1555 in regexps -- you can refer to a category rather than having to use
1556 a complicated [] expression (and category lookups are significantly
1557 faster).
1558
1559 There are 95 different categories available, one for each printable
1560 character (including space) in the ASCII charset.  Each category
1561 is designated by one such character, called a "category designator".
1562 They are specified in a regexp using the syntax "\\cX", where X is
1563 a category designator.
1564
1565 A category table specifies, for each character, the categories that
1566 the character is in.  Note that a character can be in more than one
1567 category.  More specifically, a category table maps from a character
1568 to either the value nil (meaning the character is in no categories)
1569 or a 95-element bit vector, specifying for each of the 95 categories
1570 whether the character is in that category.
1571
1572 Special Lisp functions are provided that abstract this, so you do not
1573 have to directly manipulate bit vectors.
1574 */
1575        (obj))
1576 {
1577   return (CHAR_TABLEP (obj) &&
1578           XCHAR_TABLE_TYPE (obj) == CHAR_TABLE_TYPE_CATEGORY) ?
1579     Qt : Qnil;
1580 }
1581
1582 static Lisp_Object
1583 check_category_table (Lisp_Object obj, Lisp_Object def)
1584 {
1585   if (NILP (obj))
1586     obj = def;
1587   while (NILP (Fcategory_table_p (obj)))
1588     obj = wrong_type_argument (Qcategory_table_p, obj);
1589   return obj;
1590 }
1591
1592 int
1593 check_category_char (Emchar ch, Lisp_Object table,
1594                      unsigned int designator, unsigned int not)
1595 {
1596   REGISTER Lisp_Object temp;
1597   struct Lisp_Char_Table *ctbl;
1598 #ifdef ERROR_CHECK_TYPECHECK
1599   if (NILP (Fcategory_table_p (table)))
1600     signal_simple_error ("Expected category table", table);
1601 #endif
1602   ctbl = XCHAR_TABLE (table);
1603   temp = get_char_table (ch, ctbl);
1604   if (NILP (temp))
1605     return not;
1606
1607   designator -= ' ';
1608   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
1609 }
1610
1611 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
1612 Return t if category of a character at POS includes DESIGNATOR,
1613 else return nil. Optional third arg specifies which buffer
1614 \(defaulting to current), and fourth specifies the CATEGORY-TABLE,
1615 \(defaulting to the buffer's category table).
1616 */
1617        (pos, designator, buffer, category_table))
1618 {
1619   Lisp_Object ctbl;
1620   Emchar ch;
1621   unsigned int des;
1622   struct buffer *buf = decode_buffer (buffer, 0);
1623
1624   CHECK_INT (pos);
1625   CHECK_CATEGORY_DESIGNATOR (designator);
1626   des = XCHAR (designator);
1627   ctbl = check_category_table (category_table, Vstandard_category_table);
1628   ch = BUF_FETCH_CHAR (buf, XINT (pos));
1629   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1630 }
1631
1632 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
1633 Return t if category of character CHR includes DESIGNATOR, else nil.
1634 Optional third arg specifies the CATEGORY-TABLE to use,
1635 which defaults to the system default table.
1636 */
1637        (chr, designator, category_table))
1638 {
1639   Lisp_Object ctbl;
1640   Emchar ch;
1641   unsigned int des;
1642
1643   CHECK_CATEGORY_DESIGNATOR (designator);
1644   des = XCHAR (designator);
1645   CHECK_CHAR (chr);
1646   ch = XCHAR (chr);
1647   ctbl = check_category_table (category_table, Vstandard_category_table);
1648   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1649 }
1650
1651 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
1652 Return the current category table.
1653 This is the one specified by the current buffer, or by BUFFER if it
1654 is non-nil.
1655 */
1656        (buffer))
1657 {
1658   return decode_buffer (buffer, 0)->category_table;
1659 }
1660
1661 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
1662 Return the standard category table.
1663 This is the one used for new buffers.
1664 */
1665        ())
1666 {
1667   return Vstandard_category_table;
1668 }
1669
1670 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
1671 Construct a new category table and return it.
1672 It is a copy of the TABLE, which defaults to the standard category table.
1673 */
1674        (table))
1675 {
1676   if (NILP (Vstandard_category_table))
1677     return Fmake_char_table (Qcategory);
1678
1679   table = check_category_table (table, Vstandard_category_table);
1680   return Fcopy_char_table (table);
1681 }
1682
1683 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
1684 Select a new category table for BUFFER.
1685 One argument, a category table.
1686 BUFFER defaults to the current buffer if omitted.
1687 */
1688        (table, buffer))
1689 {
1690   struct buffer *buf = decode_buffer (buffer, 0);
1691   table = check_category_table (table, Qnil);
1692   buf->category_table = table;
1693   /* Indicate that this buffer now has a specified category table.  */
1694   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
1695   return table;
1696 }
1697
1698 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
1699 Return t if ARG is a category designator (a char in the range ' ' to '~').
1700 */
1701        (obj))
1702 {
1703   return CATEGORY_DESIGNATORP (obj) ? Qt : Qnil;
1704 }
1705
1706 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
1707 Return t if ARG is a category table value.
1708 Valid values are nil or a bit vector of size 95.
1709 */
1710        (obj))
1711 {
1712   return CATEGORY_TABLE_VALUEP (obj) ? Qt : Qnil;
1713 }
1714
1715 #endif /* MULE */
1716
1717 \f
1718 void
1719 syms_of_chartab (void)
1720 {
1721 #ifdef MULE
1722   defsymbol (&Qcategory_table_p, "category-table-p");
1723   defsymbol (&Qcategory_designator_p, "category-designator-p");
1724   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
1725 #endif /* MULE */
1726
1727   defsymbol (&Qchar_table, "char-table");
1728   defsymbol (&Qchar_tablep, "char-table-p");
1729
1730   DEFSUBR (Fchar_table_p);
1731   DEFSUBR (Fchar_table_type_list);
1732   DEFSUBR (Fvalid_char_table_type_p);
1733   DEFSUBR (Fchar_table_type);
1734   DEFSUBR (Freset_char_table);
1735   DEFSUBR (Fmake_char_table);
1736   DEFSUBR (Fcopy_char_table);
1737   DEFSUBR (Fget_char_table);
1738   DEFSUBR (Fget_range_char_table);
1739   DEFSUBR (Fvalid_char_table_value_p);
1740   DEFSUBR (Fcheck_valid_char_table_value);
1741   DEFSUBR (Fput_char_table);
1742   DEFSUBR (Fmap_char_table);
1743
1744 #ifdef MULE
1745   DEFSUBR (Fcategory_table_p);
1746   DEFSUBR (Fcategory_table);
1747   DEFSUBR (Fstandard_category_table);
1748   DEFSUBR (Fcopy_category_table);
1749   DEFSUBR (Fset_category_table);
1750   DEFSUBR (Fcheck_category_at);
1751   DEFSUBR (Fchar_in_category_p);
1752   DEFSUBR (Fcategory_designator_p);
1753   DEFSUBR (Fcategory_table_value_p);
1754 #endif /* MULE */
1755
1756   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
1757   Vall_syntax_tables = Qnil;
1758 }
1759
1760 void
1761 structure_type_create_chartab (void)
1762 {
1763   struct structure_type *st;
1764
1765   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
1766
1767   define_structure_type_keyword (st, Qtype, chartab_type_validate);
1768   define_structure_type_keyword (st, Qdata, chartab_data_validate);
1769 }
1770
1771 void
1772 complex_vars_of_chartab (void)
1773 {
1774 #ifdef MULE
1775   /* Set this now, so first buffer creation can refer to it. */
1776   /* Make it nil before calling copy-category-table
1777      so that copy-category-table will know not to try to copy from garbage */
1778   Vstandard_category_table = Qnil;
1779   Vstandard_category_table = Fcopy_category_table (Qnil);
1780   staticpro (&Vstandard_category_table);
1781 #endif /* MULE */
1782 }