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