git.chise.org Git - chise/xemacs-chise.git-/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    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       switch (XCHARSET_TYPE (outrange->charset))
 748         {
 749         case CHARSET_TYPE_94:
 750         case CHARSET_TYPE_96:
 751           signal_simple_error ("Charset in row vector must be multi-byte",
 752                                outrange->charset);
 753         case CHARSET_TYPE_94X94:
 754           check_int_range (outrange->row, 33, 126);
 755           break;
 756         case CHARSET_TYPE_96X96:
 757           check_int_range (outrange->row, 32, 127);
 758           break;
 759         default:
 760           abort ();
 761         }
 762     }
 763   else
 764     {
 765       if (!CHARSETP (range) && !SYMBOLP (range))
 766         signal_simple_error
 767           ("Char table range must be t, charset, char, or vector", range);
 768       outrange->type = CHARTAB_RANGE_CHARSET;
 769       outrange->charset = Fget_charset (range);
 770     }
 771 #endif /* MULE */
 772 }
 773
 774 #ifdef MULE
 775
 776 /* called from CHAR_TABLE_VALUE(). */
 777 Lisp_Object
 778 get_non_ascii_char_table_value (struct Lisp_Char_Table *ct,
 779                                 Charset_ID leading_byte, Emchar c)
 780 {
 781   Lisp_Object val;
 782 #ifdef UTF2000
 783   Lisp_Object charset;
 784 #else
 785   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
 786 #endif
 787   int byte1, byte2;
 788
 789 #ifdef UTF2000
 790   BREAKUP_CHAR (c, charset, byte1, byte2);
 791 #else
 792   BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
 793 #endif
 794   val = ct->level1[leading_byte - MIN_LEADING_BYTE];
 795   if (CHAR_TABLE_ENTRYP (val))
 796     {
 797       struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
 798       val = cte->level2[byte1 - 32];
 799       if (CHAR_TABLE_ENTRYP (val))
 800         {
 801           cte = XCHAR_TABLE_ENTRY (val);
 802           assert (byte2 >= 32);
 803           val = cte->level2[byte2 - 32];
 804           assert (!CHAR_TABLE_ENTRYP (val));
 805         }
 806     }
 807
 808   return val;
 809 }
 810
 811 #endif /* MULE */
 812
 813 Lisp_Object
 814 get_char_table (Emchar ch, struct Lisp_Char_Table *ct)
 815 {
 816 #ifdef MULE
 817   {
 818     Lisp_Object charset;
 819     int byte1, byte2;
 820     Lisp_Object val;
 821
 822     BREAKUP_CHAR (ch, charset, byte1, byte2);
 823
 824     if (EQ (charset, Vcharset_ascii))
 825       val = ct->ascii[byte1];
 826     else if (EQ (charset, Vcharset_control_1))
 827       val = ct->ascii[byte1 + 128];
 828     else
 829       {
 830         int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
 831         val = ct->level1[lb];
 832         if (CHAR_TABLE_ENTRYP (val))
 833           {
 834             struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
 835             val = cte->level2[byte1 - 32];
 836             if (CHAR_TABLE_ENTRYP (val))
 837               {
 838                 cte = XCHAR_TABLE_ENTRY (val);
 839                 assert (byte2 >= 32);
 840                 val = cte->level2[byte2 - 32];
 841                 assert (!CHAR_TABLE_ENTRYP (val));
 842               }
 843           }
 844       }
 845
 846     return val;
 847   }
 848 #else /* not MULE */
 849   return ct->ascii[(unsigned char)ch];
 850 #endif /* not MULE */
 851 }
 852
 853
 854 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
 855 Find value for char CH in TABLE.
 856 */
 857        (ch, table))
 858 {
 859   struct Lisp_Char_Table *ct;
 860
 861   CHECK_CHAR_TABLE (table);
 862   ct = XCHAR_TABLE (table);
 863   CHECK_CHAR_COERCE_INT (ch);
 864
 865   return get_char_table (XCHAR (ch), ct);
 866 }
 867
 868 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
 869 Find value for a range in TABLE.
 870 If there is more than one value, return MULTI (defaults to nil).
 871 */
 872        (range, table, multi))
 873 {
 874   struct Lisp_Char_Table *ct;
 875   struct chartab_range rainj;
 876
 877   if (CHAR_OR_CHAR_INTP (range))
 878     return Fget_char_table (range, table);
 879   CHECK_CHAR_TABLE (table);
 880   ct = XCHAR_TABLE (table);
 881
 882   decode_char_table_range (range, &rainj);
 883   switch (rainj.type)
 884     {
 885     case CHARTAB_RANGE_ALL:
 886       {
 887         int i;
 888         Lisp_Object first = ct->ascii[0];
 889
 890         for (i = 1; i < NUM_ASCII_CHARS; i++)
 891           if (!EQ (first, ct->ascii[i]))
 892             return multi;
 893
 894 #ifdef MULE
 895         for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
 896              i++)
 897           {
 898             if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
 899                 || i == LEADING_BYTE_ASCII
 900                 || i == LEADING_BYTE_CONTROL_1)
 901               continue;
 902             if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
 903               return multi;
 904           }
 905 #endif /* MULE */
 906
 907         return first;
 908       }
 909
 910 #ifdef MULE
 911     case CHARTAB_RANGE_CHARSET:
 912       if (EQ (rainj.charset, Vcharset_ascii))
 913         {
 914           int i;
 915           Lisp_Object first = ct->ascii[0];
 916
 917           for (i = 1; i < 128; i++)
 918             if (!EQ (first, ct->ascii[i]))
 919               return multi;
 920           return first;
 921         }
 922
 923       if (EQ (rainj.charset, Vcharset_control_1))
 924         {
 925           int i;
 926           Lisp_Object first = ct->ascii[128];
 927
 928           for (i = 129; i < 160; i++)
 929             if (!EQ (first, ct->ascii[i]))
 930               return multi;
 931           return first;
 932         }
 933
 934       {
 935         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
 936                                      MIN_LEADING_BYTE];
 937         if (CHAR_TABLE_ENTRYP (val))
 938           return multi;
 939         return val;
 940       }
 941
 942     case CHARTAB_RANGE_ROW:
 943       {
 944         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
 945                                      MIN_LEADING_BYTE];
 946         if (!CHAR_TABLE_ENTRYP (val))
 947           return val;
 948         val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
 949         if (CHAR_TABLE_ENTRYP (val))
 950           return multi;
 951         return val;
 952       }
 953 #endif /* not MULE */
 954
 955     default:
 956       abort ();
 957     }
 958
 959   return Qnil; /* not reached */
 960 }
 961
 962 static int
 963 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
 964                               Error_behavior errb)
 965 {
 966   switch (type)
 967     {
 968     case CHAR_TABLE_TYPE_SYNTAX:
 969       if (!ERRB_EQ (errb, ERROR_ME))
 970         return INTP (value) || (CONSP (value) && INTP (XCAR (value))
 971                                 && CHAR_OR_CHAR_INTP (XCDR (value)));
 972       if (CONSP (value))
 973         {
 974           Lisp_Object cdr = XCDR (value);
 975           CHECK_INT (XCAR (value));
 976           CHECK_CHAR_COERCE_INT (cdr);
 977          }
 978       else
 979         CHECK_INT (value);
 980       break;
 981
 982 #ifdef MULE
 983     case CHAR_TABLE_TYPE_CATEGORY:
 984       if (!ERRB_EQ (errb, ERROR_ME))
 985         return CATEGORY_TABLE_VALUEP (value);
 986       CHECK_CATEGORY_TABLE_VALUE (value);
 987       break;
 988 #endif /* MULE */
 989
 990     case CHAR_TABLE_TYPE_GENERIC:
 991       return 1;
 992
 993     case CHAR_TABLE_TYPE_DISPLAY:
 994       /* #### fix this */
 995       maybe_signal_simple_error ("Display char tables not yet implemented",
 996                                  value, Qchar_table, errb);
 997       return 0;
 998
 999     case CHAR_TABLE_TYPE_CHAR:
1000       if (!ERRB_EQ (errb, ERROR_ME))
1001         return CHAR_OR_CHAR_INTP (value);
1002       CHECK_CHAR_COERCE_INT (value);
1003       break;
1004
1005     default:
1006       abort ();
1007     }
1008
1009   return 0; /* not reached */
1010 }
1011
1012 static Lisp_Object
1013 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
1014 {
1015   switch (type)
1016     {
1017     case CHAR_TABLE_TYPE_SYNTAX:
1018       if (CONSP (value))
1019         {
1020           Lisp_Object car = XCAR (value);
1021           Lisp_Object cdr = XCDR (value);
1022           CHECK_CHAR_COERCE_INT (cdr);
1023           return Fcons (car, cdr);
1024         }
1025       break;
1026     case CHAR_TABLE_TYPE_CHAR:
1027       CHECK_CHAR_COERCE_INT (value);
1028       break;
1029     default:
1030       break;
1031     }
1032   return value;
1033 }
1034
1035 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
1036 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
1037 */
1038        (value, char_table_type))
1039 {
1040   enum char_table_type type = symbol_to_char_table_type (char_table_type);
1041
1042   return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
1043 }
1044
1045 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
1046 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
1047 */
1048        (value, char_table_type))
1049 {
1050   enum char_table_type type = symbol_to_char_table_type (char_table_type);
1051
1052   check_valid_char_table_value (value, type, ERROR_ME);
1053   return Qnil;
1054 }
1055
1056 /* Assign VAL to all characters in RANGE in char table CT. */
1057
1058 void
1059 put_char_table (struct Lisp_Char_Table *ct, struct chartab_range *range,
1060                 Lisp_Object val)
1061 {
1062   switch (range->type)
1063     {
1064     case CHARTAB_RANGE_ALL:
1065       fill_char_table (ct, val);
1066       return; /* avoid the duplicate call to update_syntax_table() below,
1067                  since fill_char_table() also did that. */
1068
1069 #ifdef MULE
1070     case CHARTAB_RANGE_CHARSET:
1071       if (EQ (range->charset, Vcharset_ascii))
1072         {
1073           int i;
1074           for (i = 0; i < 128; i++)
1075             ct->ascii[i] = val;
1076         }
1077       else if (EQ (range->charset, Vcharset_control_1))
1078         {
1079           int i;
1080           for (i = 128; i < 160; i++)
1081             ct->ascii[i] = val;
1082         }
1083       else
1084         {
1085           int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1086           ct->level1[lb] = val;
1087         }
1088       break;
1089
1090     case CHARTAB_RANGE_ROW:
1091       {
1092         struct Lisp_Char_Table_Entry *cte;
1093         int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1094         /* make sure that there is a separate entry for the row. */
1095         if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1096           ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1097         cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1098         cte->level2[range->row - 32] = val;
1099       }
1100       break;
1101 #endif /* MULE */
1102
1103     case CHARTAB_RANGE_CHAR:
1104 #ifdef MULE
1105       {
1106         Lisp_Object charset;
1107         int byte1, byte2;
1108
1109         BREAKUP_CHAR (range->ch, charset, byte1, byte2);
1110         if (EQ (charset, Vcharset_ascii))
1111           ct->ascii[byte1] = val;
1112         else if (EQ (charset, Vcharset_control_1))
1113           ct->ascii[byte1 + 128] = val;
1114         else
1115           {
1116             struct Lisp_Char_Table_Entry *cte;
1117             int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1118             /* make sure that there is a separate entry for the row. */
1119             if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1120               ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1121             cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1122             /* now CTE is a char table entry for the charset;
1123                each entry is for a single row (or character of
1124                a one-octet charset). */
1125             if (XCHARSET_DIMENSION (charset) == 1)
1126               cte->level2[byte1 - 32] = val;
1127             else
1128               {
1129                 /* assigning to one character in a two-octet charset. */
1130                 /* make sure that the charset row contains a separate
1131                    entry for each character. */
1132                 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
1133                   cte->level2[byte1 - 32] =
1134                     make_char_table_entry (cte->level2[byte1 - 32]);
1135                 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
1136                 cte->level2[byte2 - 32] = val;
1137               }
1138           }
1139       }
1140 #else /* not MULE */
1141       ct->ascii[(unsigned char) (range->ch)] = val;
1142       break;
1143 #endif /* not MULE */
1144     }
1145
1146   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1147     update_syntax_table (ct);
1148 }
1149
1150 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
1151 Set the value for chars in RANGE to be VAL in TABLE.
1152
1153 RANGE specifies one or more characters to be affected and should be
1154 one of the following:
1155
1156 -- t (all characters are affected)
1157 -- A charset (only allowed when Mule support is present)
1158 -- A vector of two elements: a two-octet charset and a row number
1159    (only allowed when Mule support is present)
1160 -- A single character
1161
1162 VAL must be a value appropriate for the type of TABLE.
1163 See `valid-char-table-type-p'.
1164 */
1165        (range, val, table))
1166 {
1167   struct Lisp_Char_Table *ct;
1168   struct chartab_range rainj;
1169
1170   CHECK_CHAR_TABLE (table);
1171   ct = XCHAR_TABLE (table);
1172   check_valid_char_table_value (val, ct->type, ERROR_ME);
1173   decode_char_table_range (range, &rainj);
1174   val = canonicalize_char_table_value (val, ct->type);
1175   put_char_table (ct, &rainj, val);
1176   return Qnil;
1177 }
1178
1179 /* Map FN over the ASCII chars in CT. */
1180
1181 static int
1182 map_over_charset_ascii (struct Lisp_Char_Table *ct,
1183                         int (*fn) (struct chartab_range *range,
1184                                    Lisp_Object val, void *arg),
1185                         void *arg)
1186 {
1187   struct chartab_range rainj;
1188   int i, retval;
1189   int start = 0;
1190 #ifdef MULE
1191   int stop = 128;
1192 #else
1193   int stop = 256;
1194 #endif
1195
1196   rainj.type = CHARTAB_RANGE_CHAR;
1197
1198   for (i = start, retval = 0; i < stop && retval == 0; i++)
1199     {
1200       rainj.ch = (Emchar) i;
1201       retval = (fn) (&rainj, ct->ascii[i], arg);
1202     }
1203
1204   return retval;
1205 }
1206
1207 #ifdef MULE
1208
1209 /* Map FN over the Control-1 chars in CT. */
1210
1211 static int
1212 map_over_charset_control_1 (struct Lisp_Char_Table *ct,
1213                             int (*fn) (struct chartab_range *range,
1214                                        Lisp_Object val, void *arg),
1215                             void *arg)
1216 {
1217   struct chartab_range rainj;
1218   int i, retval;
1219   int start = 128;
1220   int stop  = start + 32;
1221
1222   rainj.type = CHARTAB_RANGE_CHAR;
1223
1224   for (i = start, retval = 0; i < stop && retval == 0; i++)
1225     {
1226       rainj.ch = (Emchar) (i);
1227       retval = (fn) (&rainj, ct->ascii[i], arg);
1228     }
1229
1230   return retval;
1231 }
1232
1233 /* Map FN over the row ROW of two-byte charset CHARSET.
1234    There must be a separate value for that row in the char table.
1235    CTE specifies the char table entry for CHARSET. */
1236
1237 static int
1238 map_over_charset_row (struct Lisp_Char_Table_Entry *cte,
1239                       Lisp_Object charset, int row,
1240                       int (*fn) (struct chartab_range *range,
1241                                  Lisp_Object val, void *arg),
1242                       void *arg)
1243 {
1244   Lisp_Object val = cte->level2[row - 32];
1245
1246   if (!CHAR_TABLE_ENTRYP (val))
1247     {
1248       struct chartab_range rainj;
1249
1250       rainj.type = CHARTAB_RANGE_ROW;
1251       rainj.charset = charset;
1252       rainj.row = row;
1253       return (fn) (&rainj, val, arg);
1254     }
1255   else
1256     {
1257       struct chartab_range rainj;
1258       int i, retval;
1259       int charset94_p = (XCHARSET_CHARS (charset) == 94);
1260       int start = charset94_p ?  33 :  32;
1261       int stop  = charset94_p ? 127 : 128;
1262
1263       cte = XCHAR_TABLE_ENTRY (val);
1264
1265       rainj.type = CHARTAB_RANGE_CHAR;
1266
1267       for (i = start, retval = 0; i < stop && retval == 0; i++)
1268         {
1269           rainj.ch = MAKE_CHAR (charset, row, i);
1270           retval = (fn) (&rainj, cte->level2[i - 32], arg);
1271         }
1272       return retval;
1273     }
1274 }
1275
1276
1277 static int
1278 map_over_other_charset (struct Lisp_Char_Table *ct, Charset_ID lb,
1279                         int (*fn) (struct chartab_range *range,
1280                                    Lisp_Object val, void *arg),
1281                         void *arg)
1282 {
1283   Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
1284   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
1285
1286   if (!CHARSETP (charset)
1287       || lb == LEADING_BYTE_ASCII
1288       || lb == LEADING_BYTE_CONTROL_1)
1289     return 0;
1290
1291   if (!CHAR_TABLE_ENTRYP (val))
1292     {
1293       struct chartab_range rainj;
1294
1295       rainj.type = CHARTAB_RANGE_CHARSET;
1296       rainj.charset = charset;
1297       return (fn) (&rainj, val, arg);
1298     }
1299
1300   {
1301     struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1302     int charset94_p = (XCHARSET_CHARS (charset) == 94);
1303     int start = charset94_p ?  33 :  32;
1304     int stop  = charset94_p ? 127 : 128;
1305     int i, retval;
1306
1307     if (XCHARSET_DIMENSION (charset) == 1)
1308       {
1309         struct chartab_range rainj;
1310         rainj.type = CHARTAB_RANGE_CHAR;
1311
1312         for (i = start, retval = 0; i < stop && retval == 0; i++)
1313           {
1314             rainj.ch = MAKE_CHAR (charset, i, 0);
1315             retval = (fn) (&rainj, cte->level2[i - 32], arg);
1316           }
1317       }
1318     else
1319       {
1320         for (i = start, retval = 0; i < stop && retval == 0; i++)
1321           retval = map_over_charset_row (cte, charset, i, fn, arg);
1322       }
1323
1324     return retval;
1325   }
1326 }
1327
1328 #endif /* MULE */
1329
1330 /* Map FN (with client data ARG) over range RANGE in char table CT.
1331    Mapping stops the first time FN returns non-zero, and that value
1332    becomes the return value of map_char_table(). */
1333
1334 int
1335 map_char_table (struct Lisp_Char_Table *ct,
1336                 struct chartab_range *range,
1337                 int (*fn) (struct chartab_range *range,
1338                            Lisp_Object val, void *arg),
1339                 void *arg)
1340 {
1341   switch (range->type)
1342     {
1343     case CHARTAB_RANGE_ALL:
1344       {
1345         int retval;
1346
1347         retval = map_over_charset_ascii (ct, fn, arg);
1348         if (retval)
1349           return retval;
1350 #ifdef MULE
1351         retval = map_over_charset_control_1 (ct, fn, arg);
1352         if (retval)
1353           return retval;
1354         {
1355           Charset_ID i;
1356           Charset_ID start = MIN_LEADING_BYTE;
1357           Charset_ID stop  = start + NUM_LEADING_BYTES;
1358
1359           for (i = start, retval = 0; i < stop && retval == 0; i++)
1360             {
1361               retval = map_over_other_charset (ct, i, fn, arg);
1362             }
1363         }
1364 #endif /* MULE */
1365         return retval;
1366       }
1367
1368 #ifdef MULE
1369     case CHARTAB_RANGE_CHARSET:
1370       return map_over_other_charset (ct,
1371                                      XCHARSET_LEADING_BYTE (range->charset),
1372                                      fn, arg);
1373
1374     case CHARTAB_RANGE_ROW:
1375       {
1376         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
1377                                     - MIN_LEADING_BYTE];
1378         if (!CHAR_TABLE_ENTRYP (val))
1379           {
1380             struct chartab_range rainj;
1381
1382             rainj.type = CHARTAB_RANGE_ROW;
1383             rainj.charset = range->charset;
1384             rainj.row = range->row;
1385             return (fn) (&rainj, val, arg);
1386           }
1387         else
1388           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
1389                                        range->charset, range->row,
1390                                        fn, arg);
1391       }
1392 #endif /* MULE */
1393
1394     case CHARTAB_RANGE_CHAR:
1395       {
1396         Emchar ch = range->ch;
1397         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
1398         struct chartab_range rainj;
1399
1400         rainj.type = CHARTAB_RANGE_CHAR;
1401         rainj.ch = ch;
1402         return (fn) (&rainj, val, arg);
1403       }
1404
1405     default:
1406       abort ();
1407     }
1408
1409   return 0;
1410 }
1411
1412 struct slow_map_char_table_arg
1413 {
1414   Lisp_Object function;
1415   Lisp_Object retval;
1416 };
1417
1418 static int
1419 slow_map_char_table_fun (struct chartab_range *range,
1420                          Lisp_Object val, void *arg)
1421 {
1422   Lisp_Object ranjarg = Qnil;
1423   struct slow_map_char_table_arg *closure =
1424     (struct slow_map_char_table_arg *) arg;
1425
1426   switch (range->type)
1427     {
1428     case CHARTAB_RANGE_ALL:
1429       ranjarg = Qt;
1430       break;
1431
1432 #ifdef MULE
1433     case CHARTAB_RANGE_CHARSET:
1434       ranjarg = XCHARSET_NAME (range->charset);
1435       break;
1436
1437     case CHARTAB_RANGE_ROW:
1438       ranjarg = vector2 (XCHARSET_NAME (range->charset),
1439                          make_int (range->row));
1440       break;
1441 #endif /* MULE */
1442     case CHARTAB_RANGE_CHAR:
1443       ranjarg = make_char (range->ch);
1444       break;
1445     default:
1446       abort ();
1447     }
1448
1449   closure->retval = call2 (closure->function, ranjarg, val);
1450   return !NILP (closure->retval);
1451 }
1452
1453 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
1454 Map FUNCTION over entries in TABLE, calling it with two args,
1455 each key and value in the table.
1456
1457 RANGE specifies a subrange to map over and is in the same format as
1458 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
1459 the entire table.
1460 */
1461        (function, table, range))
1462 {
1463   struct Lisp_Char_Table *ct;
1464   struct slow_map_char_table_arg slarg;
1465   struct gcpro gcpro1, gcpro2;
1466   struct chartab_range rainj;
1467
1468   CHECK_CHAR_TABLE (table);
1469   ct = XCHAR_TABLE (table);
1470   if (NILP (range))
1471     range = Qt;
1472   decode_char_table_range (range, &rainj);
1473   slarg.function = function;
1474   slarg.retval = Qnil;
1475   GCPRO2 (slarg.function, slarg.retval);
1476   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
1477   UNGCPRO;
1478
1479   return slarg.retval;
1480 }
1481
1482
1483 \f
1484 /************************************************************************/
1485 /*                         Char table read syntax                       */
1486 /************************************************************************/
1487
1488 static int
1489 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
1490                        Error_behavior errb)
1491 {
1492   /* #### should deal with ERRB */
1493   symbol_to_char_table_type (value);
1494   return 1;
1495 }
1496
1497 static int
1498 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
1499                        Error_behavior errb)
1500 {
1501   Lisp_Object rest;
1502
1503   /* #### should deal with ERRB */
1504   EXTERNAL_LIST_LOOP (rest, value)
1505     {
1506       Lisp_Object range = XCAR (rest);
1507       struct chartab_range dummy;
1508
1509       rest = XCDR (rest);
1510       if (!CONSP (rest))
1511         signal_simple_error ("Invalid list format", value);
1512       if (CONSP (range))
1513         {
1514           if (!CONSP (XCDR (range))
1515               || !NILP (XCDR (XCDR (range))))
1516             signal_simple_error ("Invalid range format", range);
1517           decode_char_table_range (XCAR (range), &dummy);
1518           decode_char_table_range (XCAR (XCDR (range)), &dummy);
1519         }
1520       else
1521         decode_char_table_range (range, &dummy);
1522     }
1523
1524   return 1;
1525 }
1526
1527 static Lisp_Object
1528 chartab_instantiate (Lisp_Object data)
1529 {
1530   Lisp_Object chartab;
1531   Lisp_Object type = Qgeneric;
1532   Lisp_Object dataval = Qnil;
1533
1534   while (!NILP (data))
1535     {
1536       Lisp_Object keyw = Fcar (data);
1537       Lisp_Object valw;
1538
1539       data = Fcdr (data);
1540       valw = Fcar (data);
1541       data = Fcdr (data);
1542       if (EQ (keyw, Qtype))
1543         type = valw;
1544       else if (EQ (keyw, Qdata))
1545         dataval = valw;
1546     }
1547
1548   chartab = Fmake_char_table (type);
1549
1550   data = dataval;
1551   while (!NILP (data))
1552     {
1553       Lisp_Object range = Fcar (data);
1554       Lisp_Object val = Fcar (Fcdr (data));
1555
1556       data = Fcdr (Fcdr (data));
1557       if (CONSP (range))
1558         {
1559           if (CHAR_OR_CHAR_INTP (XCAR (range)))
1560             {
1561               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
1562               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
1563               Emchar i;
1564
1565               for (i = first; i <= last; i++)
1566                  Fput_char_table (make_char (i), val, chartab);
1567             }
1568           else
1569             abort ();
1570         }
1571       else
1572         Fput_char_table (range, val, chartab);
1573     }
1574
1575   return chartab;
1576 }
1577
1578 #ifdef MULE
1579
1580 \f
1581 /************************************************************************/
1582 /*                     Category Tables, specifically                    */
1583 /************************************************************************/
1584
1585 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
1586 Return t if ARG is a category table.
1587 A category table is a type of char table used for keeping track of
1588 categories.  Categories are used for classifying characters for use
1589 in regexps -- you can refer to a category rather than having to use
1590 a complicated [] expression (and category lookups are significantly
1591 faster).
1592
1593 There are 95 different categories available, one for each printable
1594 character (including space) in the ASCII charset.  Each category
1595 is designated by one such character, called a "category designator".
1596 They are specified in a regexp using the syntax "\\cX", where X is
1597 a category designator.
1598
1599 A category table specifies, for each character, the categories that
1600 the character is in.  Note that a character can be in more than one
1601 category.  More specifically, a category table maps from a character
1602 to either the value nil (meaning the character is in no categories)
1603 or a 95-element bit vector, specifying for each of the 95 categories
1604 whether the character is in that category.
1605
1606 Special Lisp functions are provided that abstract this, so you do not
1607 have to directly manipulate bit vectors.
1608 */
1609        (obj))
1610 {
1611   return (CHAR_TABLEP (obj) &&
1612           XCHAR_TABLE_TYPE (obj) == CHAR_TABLE_TYPE_CATEGORY) ?
1613     Qt : Qnil;
1614 }
1615
1616 static Lisp_Object
1617 check_category_table (Lisp_Object obj, Lisp_Object def)
1618 {
1619   if (NILP (obj))
1620     obj = def;
1621   while (NILP (Fcategory_table_p (obj)))
1622     obj = wrong_type_argument (Qcategory_table_p, obj);
1623   return obj;
1624 }
1625
1626 int
1627 check_category_char (Emchar ch, Lisp_Object table,
1628                      unsigned int designator, unsigned int not)
1629 {
1630   REGISTER Lisp_Object temp;
1631   struct Lisp_Char_Table *ctbl;
1632 #ifdef ERROR_CHECK_TYPECHECK
1633   if (NILP (Fcategory_table_p (table)))
1634     signal_simple_error ("Expected category table", table);
1635 #endif
1636   ctbl = XCHAR_TABLE (table);
1637   temp = get_char_table (ch, ctbl);
1638   if (NILP (temp))
1639     return not;
1640
1641   designator -= ' ';
1642   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
1643 }
1644
1645 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
1646 Return t if category of a character at POS includes DESIGNATOR,
1647 else return nil. Optional third arg specifies which buffer
1648 \(defaulting to current), and fourth specifies the CATEGORY-TABLE,
1649 \(defaulting to the buffer's category table).
1650 */
1651        (pos, designator, buffer, category_table))
1652 {
1653   Lisp_Object ctbl;
1654   Emchar ch;
1655   unsigned int des;
1656   struct buffer *buf = decode_buffer (buffer, 0);
1657
1658   CHECK_INT (pos);
1659   CHECK_CATEGORY_DESIGNATOR (designator);
1660   des = XCHAR (designator);
1661   ctbl = check_category_table (category_table, Vstandard_category_table);
1662   ch = BUF_FETCH_CHAR (buf, XINT (pos));
1663   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1664 }
1665
1666 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
1667 Return t if category of character CHR includes DESIGNATOR, else nil.
1668 Optional third arg specifies the CATEGORY-TABLE to use,
1669 which defaults to the system default table.
1670 */
1671        (chr, designator, category_table))
1672 {
1673   Lisp_Object ctbl;
1674   Emchar ch;
1675   unsigned int des;
1676
1677   CHECK_CATEGORY_DESIGNATOR (designator);
1678   des = XCHAR (designator);
1679   CHECK_CHAR (chr);
1680   ch = XCHAR (chr);
1681   ctbl = check_category_table (category_table, Vstandard_category_table);
1682   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1683 }
1684
1685 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
1686 Return the current category table.
1687 This is the one specified by the current buffer, or by BUFFER if it
1688 is non-nil.
1689 */
1690        (buffer))
1691 {
1692   return decode_buffer (buffer, 0)->category_table;
1693 }
1694
1695 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
1696 Return the standard category table.
1697 This is the one used for new buffers.
1698 */
1699        ())
1700 {
1701   return Vstandard_category_table;
1702 }
1703
1704 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
1705 Construct a new category table and return it.
1706 It is a copy of the TABLE, which defaults to the standard category table.
1707 */
1708        (table))
1709 {
1710   if (NILP (Vstandard_category_table))
1711     return Fmake_char_table (Qcategory);
1712
1713   table = check_category_table (table, Vstandard_category_table);
1714   return Fcopy_char_table (table);
1715 }
1716
1717 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
1718 Select a new category table for BUFFER.
1719 One argument, a category table.
1720 BUFFER defaults to the current buffer if omitted.
1721 */
1722        (table, buffer))
1723 {
1724   struct buffer *buf = decode_buffer (buffer, 0);
1725   table = check_category_table (table, Qnil);
1726   buf->category_table = table;
1727   /* Indicate that this buffer now has a specified category table.  */
1728   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
1729   return table;
1730 }
1731
1732 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
1733 Return t if ARG is a category designator (a char in the range ' ' to '~').
1734 */
1735        (obj))
1736 {
1737   return CATEGORY_DESIGNATORP (obj) ? Qt : Qnil;
1738 }
1739
1740 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
1741 Return t if ARG is a category table value.
1742 Valid values are nil or a bit vector of size 95.
1743 */
1744        (obj))
1745 {
1746   return CATEGORY_TABLE_VALUEP (obj) ? Qt : Qnil;
1747 }
1748
1749
1750 #define CATEGORYP(x) \
1751   (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
1752
1753 #define CATEGORY_SET(c)                                         \
1754   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
1755
1756 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
1757    The faster version of `!NILP (Faref (category_set, category))'.  */
1758 #define CATEGORY_MEMBER(category, category_set)                 \
1759   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
1760
1761 /* Return 1 if there is a word boundary between two word-constituent
1762    characters C1 and C2 if they appear in this order, else return 0.
1763    Use the macro WORD_BOUNDARY_P instead of calling this function
1764    directly.  */
1765
1766 int word_boundary_p (Emchar c1, Emchar c2);
1767 int
1768 word_boundary_p (Emchar c1, Emchar c2)
1769 {
1770   Lisp_Object category_set1, category_set2;
1771   Lisp_Object tail;
1772   int default_result;
1773
1774 #if 0
1775   if (COMPOSITE_CHAR_P (c1))
1776     c1 = cmpchar_component (c1, 0, 1);
1777   if (COMPOSITE_CHAR_P (c2))
1778     c2 = cmpchar_component (c2, 0, 1);
1779 #endif
1780
1781   if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
1782     {
1783       tail = Vword_separating_categories;
1784       default_result = 0;
1785     }
1786   else
1787     {
1788       tail = Vword_combining_categories;
1789       default_result = 1;
1790     }
1791
1792   category_set1 = CATEGORY_SET (c1);
1793   if (NILP (category_set1))
1794     return default_result;
1795   category_set2 = CATEGORY_SET (c2);
1796   if (NILP (category_set2))
1797     return default_result;
1798
1799   for (; CONSP (tail); tail = XCONS (tail)->cdr)
1800     {
1801       Lisp_Object elt = XCONS(tail)->car;
1802
1803       if (CONSP (elt)
1804           && CATEGORYP (XCONS (elt)->car)
1805           && CATEGORYP (XCONS (elt)->cdr)
1806           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
1807           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
1808         return !default_result;
1809     }
1810   return default_result;
1811 }
1812 #endif /* MULE */
1813
1814 \f
1815 void
1816 syms_of_chartab (void)
1817 {
1818 #ifdef MULE
1819   defsymbol (&Qcategory_table_p, "category-table-p");
1820   defsymbol (&Qcategory_designator_p, "category-designator-p");
1821   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
1822 #endif /* MULE */
1823
1824   defsymbol (&Qchar_table, "char-table");
1825   defsymbol (&Qchar_tablep, "char-table-p");
1826
1827   DEFSUBR (Fchar_table_p);
1828   DEFSUBR (Fchar_table_type_list);
1829   DEFSUBR (Fvalid_char_table_type_p);
1830   DEFSUBR (Fchar_table_type);
1831   DEFSUBR (Freset_char_table);
1832   DEFSUBR (Fmake_char_table);
1833   DEFSUBR (Fcopy_char_table);
1834   DEFSUBR (Fget_char_table);
1835   DEFSUBR (Fget_range_char_table);
1836   DEFSUBR (Fvalid_char_table_value_p);
1837   DEFSUBR (Fcheck_valid_char_table_value);
1838   DEFSUBR (Fput_char_table);
1839   DEFSUBR (Fmap_char_table);
1840
1841 #ifdef MULE
1842   DEFSUBR (Fcategory_table_p);
1843   DEFSUBR (Fcategory_table);
1844   DEFSUBR (Fstandard_category_table);
1845   DEFSUBR (Fcopy_category_table);
1846   DEFSUBR (Fset_category_table);
1847   DEFSUBR (Fcheck_category_at);
1848   DEFSUBR (Fchar_in_category_p);
1849   DEFSUBR (Fcategory_designator_p);
1850   DEFSUBR (Fcategory_table_value_p);
1851 #endif /* MULE */
1852
1853 }
1854
1855 void
1856 vars_of_chartab (void)
1857 {
1858   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
1859   Vall_syntax_tables = Qnil;
1860   pdump_wire_list (&Vall_syntax_tables);
1861 }
1862
1863 void
1864 structure_type_create_chartab (void)
1865 {
1866   struct structure_type *st;
1867
1868   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
1869
1870   define_structure_type_keyword (st, Qtype, chartab_type_validate);
1871   define_structure_type_keyword (st, Qdata, chartab_data_validate);
1872 }
1873
1874 void
1875 complex_vars_of_chartab (void)
1876 {
1877 #ifdef MULE
1878   /* Set this now, so first buffer creation can refer to it. */
1879   /* Make it nil before calling copy-category-table
1880      so that copy-category-table will know not to try to copy from garbage */
1881   Vstandard_category_table = Qnil;
1882   Vstandard_category_table = Fcopy_category_table (Qnil);
1883   staticpro (&Vstandard_category_table);
1884
1885   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
1886 List of pair (cons) of categories to determine word boundary.
1887
1888 Emacs treats a sequence of word constituent characters as a single
1889 word (i.e. finds no word boundary between them) iff they belongs to
1890 the same charset.  But, exceptions are allowed in the following cases.
1891
1892 (1) The case that characters are in different charsets is controlled
1893 by the variable `word-combining-categories'.
1894
1895 Emacs finds no word boundary between characters of different charsets
1896 if they have categories matching some element of this list.
1897
1898 More precisely, if an element of this list is a cons of category CAT1
1899 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1900 C2 which has CAT2, there's no word boundary between C1 and C2.
1901
1902 For instance, to tell that ASCII characters and Latin-1 characters can
1903 form a single word, the element `(?l . ?l)' should be in this list
1904 because both characters have the category `l' (Latin characters).
1905
1906 (2) The case that character are in the same charset is controlled by
1907 the variable `word-separating-categories'.
1908
1909 Emacs find a word boundary between characters of the same charset
1910 if they have categories matching some element of this list.
1911
1912 More precisely, if an element of this list is a cons of category CAT1
1913 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1914 C2 which has CAT2, there's a word boundary between C1 and C2.
1915
1916 For instance, to tell that there's a word boundary between Japanese
1917 Hiragana and Japanese Kanji (both are in the same charset), the
1918 element `(?H . ?C) should be in this list.
1919 */ );
1920
1921   Vword_combining_categories = Qnil;
1922
1923   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
1924 List of pair (cons) of categories to determine word boundary.
1925 See the documentation of the variable `word-combining-categories'.
1926 */ );
1927
1928   Vword_separating_categories = Qnil;
1929 #endif /* MULE */
1930 }