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, void (*markobj) (Lisp_Object))
  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       markobj (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, void (*markobj) (Lisp_Object))
 147 {
 148   struct Lisp_Char_Table *ct = XCHAR_TABLE (obj);
 149   int i;
 150
 151   for (i = 0; i < NUM_ASCII_CHARS; i++)
 152     markobj (ct->ascii[i]);
 153 #ifdef MULE
 154   for (i = 0; i < NUM_LEADING_BYTES; i++)
 155     markobj (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 (int (*obj_marked_p) (Lisp_Object))
 166 {
 167   Lisp_Object rest, prev = Qnil;
 168
 169   for (rest = Vall_syntax_tables;
 170        !GC_NILP (rest);
 171        rest = XCHAR_TABLE (rest)->next_table)
 172     {
 173       if (! obj_marked_p (rest))
 174         {
 175           /* This table is garbage.  Remove it from the list. */
 176           if (GC_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_END }
 435 };
 436
 437 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
 438                                mark_char_table, print_char_table, 0,
 439                                char_table_equal, char_table_hash,
 440                                char_table_description,
 441                                struct Lisp_Char_Table);
 442
 443 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
 444 Return non-nil if OBJECT is a char table.
 445
 446 A char table is a table that maps characters (or ranges of characters)
 447 to values.  Char tables are specialized for characters, only allowing
 448 particular sorts of ranges to be assigned values.  Although this
 449 loses in generality, it makes for extremely fast (constant-time)
 450 lookups, and thus is feasible for applications that do an extremely
 451 large number of lookups (e.g. scanning a buffer for a character in
 452 a particular syntax, where a lookup in the syntax table must occur
 453 once per character).
 454
 455 When Mule support exists, the types of ranges that can be assigned
 456 values are
 457
 458 -- all characters
 459 -- an entire charset
 460 -- a single row in a two-octet charset
 461 -- a single character
 462
 463 When Mule support is not present, the types of ranges that can be
 464 assigned values are
 465
 466 -- all characters
 467 -- a single character
 468
 469 To create a char table, use `make-char-table'.  To modify a char
 470 table, use `put-char-table' or `remove-char-table'.  To retrieve the
 471 value for a particular character, use `get-char-table'.  See also
 472 `map-char-table', `clear-char-table', `copy-char-table',
 473 `valid-char-table-type-p', `char-table-type-list', `valid-char-table-value-p',
 474 and `check-char-table-value'.
 475 */
 476        (object))
 477 {
 478   return CHAR_TABLEP (object) ? Qt : Qnil;
 479 }
 480
 481 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
 482 Return a list of the recognized char table types.
 483 See `valid-char-table-type-p'.
 484 */
 485        ())
 486 {
 487 #ifdef MULE
 488   return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
 489 #else
 490   return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
 491 #endif
 492 }
 493
 494 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
 495 Return t if TYPE if a recognized char table type.
 496
 497 Each char table type is used for a different purpose and allows different
 498 sorts of values.  The different char table types are
 499
 500 `category'
 501         Used for category tables, which specify the regexp categories
 502         that a character is in.  The valid values are nil or a
 503         bit vector of 95 elements.  Higher-level Lisp functions are
 504         provided for working with category tables.  Currently categories
 505         and category tables only exist when Mule support is present.
 506 `char'
 507         A generalized char table, for mapping from one character to
 508         another.  Used for case tables, syntax matching tables,
 509         `keyboard-translate-table', etc.  The valid values are characters.
 510 `generic'
 511         An even more generalized char table, for mapping from a
 512         character to anything.
 513 `display'
 514         Used for display tables, which specify how a particular character
 515         is to appear when displayed.  #### Not yet implemented.
 516 `syntax'
 517         Used for syntax tables, which specify the syntax of a particular
 518         character.  Higher-level Lisp functions are provided for
 519         working with syntax tables.  The valid values are integers.
 520
 521 */
 522        (type))
 523 {
 524   return (EQ (type, Qchar)     ||
 525 #ifdef MULE
 526           EQ (type, Qcategory) ||
 527 #endif
 528           EQ (type, Qdisplay)  ||
 529           EQ (type, Qgeneric)  ||
 530           EQ (type, Qsyntax)) ? Qt : Qnil;
 531 }
 532
 533 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
 534 Return the type of char table TABLE.
 535 See `valid-char-table-type-p'.
 536 */
 537        (table))
 538 {
 539   CHECK_CHAR_TABLE (table);
 540   return char_table_type_to_symbol (XCHAR_TABLE (table)->type);
 541 }
 542
 543 void
 544 fill_char_table (struct Lisp_Char_Table *ct, Lisp_Object value)
 545 {
 546   int i;
 547
 548   for (i = 0; i < NUM_ASCII_CHARS; i++)
 549     ct->ascii[i] = value;
 550 #ifdef MULE
 551   for (i = 0; i < NUM_LEADING_BYTES; i++)
 552     ct->level1[i] = value;
 553 #endif /* MULE */
 554
 555   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
 556     update_syntax_table (ct);
 557 }
 558
 559 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
 560 Reset a char table to its default state.
 561 */
 562        (table))
 563 {
 564   struct Lisp_Char_Table *ct;
 565
 566   CHECK_CHAR_TABLE (table);
 567   ct = XCHAR_TABLE (table);
 568
 569   switch (ct->type)
 570     {
 571     case CHAR_TABLE_TYPE_CHAR:
 572       fill_char_table (ct, make_char (0));
 573       break;
 574     case CHAR_TABLE_TYPE_DISPLAY:
 575     case CHAR_TABLE_TYPE_GENERIC:
 576 #ifdef MULE
 577     case CHAR_TABLE_TYPE_CATEGORY:
 578 #endif /* MULE */
 579       fill_char_table (ct, Qnil);
 580       break;
 581
 582     case CHAR_TABLE_TYPE_SYNTAX:
 583       fill_char_table (ct, make_int (Sinherit));
 584       break;
 585
 586     default:
 587       abort ();
 588     }
 589
 590   return Qnil;
 591 }
 592
 593 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
 594 Return a new, empty char table of type TYPE.
 595 Currently recognized types are 'char, 'category, 'display, 'generic,
 596 and 'syntax.  See `valid-char-table-type-p'.
 597 */
 598        (type))
 599 {
 600   struct Lisp_Char_Table *ct;
 601   Lisp_Object obj;
 602   enum char_table_type ty = symbol_to_char_table_type (type);
 603
 604   ct = alloc_lcrecord_type (struct Lisp_Char_Table, &lrecord_char_table);
 605   ct->type = ty;
 606   if (ty == CHAR_TABLE_TYPE_SYNTAX)
 607     {
 608       ct->mirror_table = Fmake_char_table (Qgeneric);
 609       fill_char_table (XCHAR_TABLE (ct->mirror_table),
 610                        make_int (Spunct));
 611     }
 612   else
 613     ct->mirror_table = Qnil;
 614   ct->next_table = Qnil;
 615   XSETCHAR_TABLE (obj, ct);
 616   if (ty == CHAR_TABLE_TYPE_SYNTAX)
 617     {
 618       ct->next_table = Vall_syntax_tables;
 619       Vall_syntax_tables = obj;
 620     }
 621   Freset_char_table (obj);
 622   return obj;
 623 }
 624
 625 #ifdef MULE
 626
 627 static Lisp_Object
 628 make_char_table_entry (Lisp_Object initval)
 629 {
 630   Lisp_Object obj;
 631   int i;
 632   struct Lisp_Char_Table_Entry *cte =
 633     alloc_lcrecord_type (struct Lisp_Char_Table_Entry,
 634                          &lrecord_char_table_entry);
 635
 636   for (i = 0; i < 96; i++)
 637     cte->level2[i] = initval;
 638
 639   XSETCHAR_TABLE_ENTRY (obj, cte);
 640   return obj;
 641 }
 642
 643 static Lisp_Object
 644 copy_char_table_entry (Lisp_Object entry)
 645 {
 646   struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
 647   Lisp_Object obj;
 648   int i;
 649   struct Lisp_Char_Table_Entry *ctenew =
 650     alloc_lcrecord_type (struct Lisp_Char_Table_Entry,
 651                          &lrecord_char_table_entry);
 652
 653   for (i = 0; i < 96; i++)
 654     {
 655       Lisp_Object new = cte->level2[i];
 656       if (CHAR_TABLE_ENTRYP (new))
 657         ctenew->level2[i] = copy_char_table_entry (new);
 658       else
 659         ctenew->level2[i] = new;
 660     }
 661
 662   XSETCHAR_TABLE_ENTRY (obj, ctenew);
 663   return obj;
 664 }
 665
 666 #endif /* MULE */
 667
 668 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
 669 Make a new char table which is a copy of OLD-TABLE.
 670 It will contain the same values for the same characters and ranges
 671 as OLD-TABLE.  The values will not themselves be copied.
 672 */
 673        (old_table))
 674 {
 675   struct Lisp_Char_Table *ct, *ctnew;
 676   Lisp_Object obj;
 677   int i;
 678
 679   CHECK_CHAR_TABLE (old_table);
 680   ct = XCHAR_TABLE (old_table);
 681   ctnew = alloc_lcrecord_type (struct Lisp_Char_Table, &lrecord_char_table);
 682   ctnew->type = ct->type;
 683
 684   for (i = 0; i < NUM_ASCII_CHARS; i++)
 685     {
 686       Lisp_Object new = ct->ascii[i];
 687 #ifdef MULE
 688       assert (! (CHAR_TABLE_ENTRYP (new)));
 689 #endif /* MULE */
 690       ctnew->ascii[i] = new;
 691     }
 692
 693 #ifdef MULE
 694
 695   for (i = 0; i < NUM_LEADING_BYTES; i++)
 696     {
 697       Lisp_Object new = ct->level1[i];
 698       if (CHAR_TABLE_ENTRYP (new))
 699         ctnew->level1[i] = copy_char_table_entry (new);
 700       else
 701         ctnew->level1[i] = new;
 702     }
 703
 704 #endif /* MULE */
 705
 706   if (CHAR_TABLEP (ct->mirror_table))
 707     ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
 708   else
 709     ctnew->mirror_table = ct->mirror_table;
 710   XSETCHAR_TABLE (obj, ctnew);
 711   return obj;
 712 }
 713
 714 static void
 715 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
 716 {
 717   if (EQ (range, Qt))
 718     outrange->type = CHARTAB_RANGE_ALL;
 719   else if (CHAR_OR_CHAR_INTP (range))
 720     {
 721       outrange->type = CHARTAB_RANGE_CHAR;
 722       outrange->ch = XCHAR_OR_CHAR_INT (range);
 723     }
 724 #ifndef MULE
 725   else
 726     signal_simple_error ("Range must be t or a character", range);
 727 #else /* MULE */
 728   else if (VECTORP (range))
 729     {
 730       struct Lisp_Vector *vec = XVECTOR (range);
 731       Lisp_Object *elts = vector_data (vec);
 732       if (vector_length (vec) != 2)
 733         signal_simple_error ("Length of charset row vector must be 2",
 734                              range);
 735       outrange->type = CHARTAB_RANGE_ROW;
 736       outrange->charset = Fget_charset (elts[0]);
 737       CHECK_INT (elts[1]);
 738       outrange->row = XINT (elts[1]);
 739       switch (XCHARSET_TYPE (outrange->charset))
 740         {
 741         case CHARSET_TYPE_94:
 742         case CHARSET_TYPE_96:
 743           signal_simple_error ("Charset in row vector must be multi-byte",
 744                                outrange->charset);
 745         case CHARSET_TYPE_94X94:
 746           check_int_range (outrange->row, 33, 126);
 747           break;
 748         case CHARSET_TYPE_96X96:
 749           check_int_range (outrange->row, 32, 127);
 750           break;
 751         default:
 752           abort ();
 753         }
 754     }
 755   else
 756     {
 757       if (!CHARSETP (range) && !SYMBOLP (range))
 758         signal_simple_error
 759           ("Char table range must be t, charset, char, or vector", range);
 760       outrange->type = CHARTAB_RANGE_CHARSET;
 761       outrange->charset = Fget_charset (range);
 762     }
 763 #endif /* MULE */
 764 }
 765
 766 #ifdef MULE
 767
 768 /* called from CHAR_TABLE_VALUE(). */
 769 Lisp_Object
 770 get_non_ascii_char_table_value (struct Lisp_Char_Table *ct,
 771                                 Charset_ID leading_byte, Emchar c)
 772 {
 773   Lisp_Object val;
 774 #ifdef UTF2000
 775   Lisp_Object charset;
 776 #else
 777   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
 778 #endif
 779   int byte1, byte2;
 780
 781 #ifdef UTF2000
 782   BREAKUP_CHAR (c, charset, byte1, byte2);
 783 #else
 784   BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
 785 #endif
 786   val = ct->level1[leading_byte - MIN_LEADING_BYTE];
 787   if (CHAR_TABLE_ENTRYP (val))
 788     {
 789       struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
 790       val = cte->level2[byte1 - 32];
 791       if (CHAR_TABLE_ENTRYP (val))
 792         {
 793           cte = XCHAR_TABLE_ENTRY (val);
 794           assert (byte2 >= 32);
 795           val = cte->level2[byte2 - 32];
 796           assert (!CHAR_TABLE_ENTRYP (val));
 797         }
 798     }
 799
 800   return val;
 801 }
 802
 803 #endif /* MULE */
 804
 805 Lisp_Object
 806 get_char_table (Emchar ch, struct Lisp_Char_Table *ct)
 807 {
 808 #ifdef MULE
 809   {
 810     Lisp_Object charset;
 811     int byte1, byte2;
 812     Lisp_Object val;
 813
 814     BREAKUP_CHAR (ch, charset, byte1, byte2);
 815
 816     if (EQ (charset, Vcharset_ascii))
 817       val = ct->ascii[byte1];
 818     else if (EQ (charset, Vcharset_control_1))
 819       val = ct->ascii[byte1 + 128];
 820     else
 821       {
 822         Charset_ID lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
 823         val = ct->level1[lb];
 824         if (CHAR_TABLE_ENTRYP (val))
 825           {
 826             struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
 827             val = cte->level2[byte1 - 32];
 828             if (CHAR_TABLE_ENTRYP (val))
 829               {
 830                 cte = XCHAR_TABLE_ENTRY (val);
 831                 assert (byte2 >= 32);
 832                 val = cte->level2[byte2 - 32];
 833                 assert (!CHAR_TABLE_ENTRYP (val));
 834               }
 835           }
 836       }
 837
 838     return val;
 839   }
 840 #else /* not MULE */
 841   return ct->ascii[(unsigned char)ch];
 842 #endif /* not MULE */
 843 }
 844
 845
 846 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
 847 Find value for char CH in TABLE.
 848 */
 849        (ch, table))
 850 {
 851   struct Lisp_Char_Table *ct;
 852
 853   CHECK_CHAR_TABLE (table);
 854   ct = XCHAR_TABLE (table);
 855   CHECK_CHAR_COERCE_INT (ch);
 856
 857   return get_char_table (XCHAR (ch), ct);
 858 }
 859
 860 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
 861 Find value for a range in TABLE.
 862 If there is more than one value, return MULTI (defaults to nil).
 863 */
 864        (range, table, multi))
 865 {
 866   struct Lisp_Char_Table *ct;
 867   struct chartab_range rainj;
 868
 869   if (CHAR_OR_CHAR_INTP (range))
 870     return Fget_char_table (range, table);
 871   CHECK_CHAR_TABLE (table);
 872   ct = XCHAR_TABLE (table);
 873
 874   decode_char_table_range (range, &rainj);
 875   switch (rainj.type)
 876     {
 877     case CHARTAB_RANGE_ALL:
 878       {
 879         int i;
 880         Lisp_Object first = ct->ascii[0];
 881
 882         for (i = 1; i < NUM_ASCII_CHARS; i++)
 883           if (!EQ (first, ct->ascii[i]))
 884             return multi;
 885
 886 #ifdef MULE
 887         for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
 888              i++)
 889           {
 890             if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
 891                 || i == LEADING_BYTE_ASCII
 892                 || i == LEADING_BYTE_CONTROL_1)
 893               continue;
 894             if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
 895               return multi;
 896           }
 897 #endif /* MULE */
 898
 899         return first;
 900       }
 901
 902 #ifdef MULE
 903     case CHARTAB_RANGE_CHARSET:
 904       if (EQ (rainj.charset, Vcharset_ascii))
 905         {
 906           int i;
 907           Lisp_Object first = ct->ascii[0];
 908
 909           for (i = 1; i < 128; i++)
 910             if (!EQ (first, ct->ascii[i]))
 911               return multi;
 912           return first;
 913         }
 914
 915       if (EQ (rainj.charset, Vcharset_control_1))
 916         {
 917           int i;
 918           Lisp_Object first = ct->ascii[128];
 919
 920           for (i = 129; i < 160; i++)
 921             if (!EQ (first, ct->ascii[i]))
 922               return multi;
 923           return first;
 924         }
 925
 926       {
 927         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
 928                                      MIN_LEADING_BYTE];
 929         if (CHAR_TABLE_ENTRYP (val))
 930           return multi;
 931         return val;
 932       }
 933
 934     case CHARTAB_RANGE_ROW:
 935       {
 936         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
 937                                      MIN_LEADING_BYTE];
 938         if (!CHAR_TABLE_ENTRYP (val))
 939           return val;
 940         val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
 941         if (CHAR_TABLE_ENTRYP (val))
 942           return multi;
 943         return val;
 944       }
 945 #endif /* not MULE */
 946
 947     default:
 948       abort ();
 949     }
 950
 951   return Qnil; /* not reached */
 952 }
 953
 954 static int
 955 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
 956                               Error_behavior errb)
 957 {
 958   switch (type)
 959     {
 960     case CHAR_TABLE_TYPE_SYNTAX:
 961       if (!ERRB_EQ (errb, ERROR_ME))
 962         return INTP (value) || (CONSP (value) && INTP (XCAR (value))
 963                                 && CHAR_OR_CHAR_INTP (XCDR (value)));
 964       if (CONSP (value))
 965         {
 966           Lisp_Object cdr = XCDR (value);
 967           CHECK_INT (XCAR (value));
 968           CHECK_CHAR_COERCE_INT (cdr);
 969          }
 970       else
 971         CHECK_INT (value);
 972       break;
 973
 974 #ifdef MULE
 975     case CHAR_TABLE_TYPE_CATEGORY:
 976       if (!ERRB_EQ (errb, ERROR_ME))
 977         return CATEGORY_TABLE_VALUEP (value);
 978       CHECK_CATEGORY_TABLE_VALUE (value);
 979       break;
 980 #endif /* MULE */
 981
 982     case CHAR_TABLE_TYPE_GENERIC:
 983       return 1;
 984
 985     case CHAR_TABLE_TYPE_DISPLAY:
 986       /* #### fix this */
 987       maybe_signal_simple_error ("Display char tables not yet implemented",
 988                                  value, Qchar_table, errb);
 989       return 0;
 990
 991     case CHAR_TABLE_TYPE_CHAR:
 992       if (!ERRB_EQ (errb, ERROR_ME))
 993         return CHAR_OR_CHAR_INTP (value);
 994       CHECK_CHAR_COERCE_INT (value);
 995       break;
 996
 997     default:
 998       abort ();
 999     }
1000
1001   return 0; /* not reached */
1002 }
1003
1004 static Lisp_Object
1005 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
1006 {
1007   switch (type)
1008     {
1009     case CHAR_TABLE_TYPE_SYNTAX:
1010       if (CONSP (value))
1011         {
1012           Lisp_Object car = XCAR (value);
1013           Lisp_Object cdr = XCDR (value);
1014           CHECK_CHAR_COERCE_INT (cdr);
1015           return Fcons (car, cdr);
1016         }
1017       break;
1018     case CHAR_TABLE_TYPE_CHAR:
1019       CHECK_CHAR_COERCE_INT (value);
1020       break;
1021     default:
1022       break;
1023     }
1024   return value;
1025 }
1026
1027 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
1028 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
1029 */
1030        (value, char_table_type))
1031 {
1032   enum char_table_type type = symbol_to_char_table_type (char_table_type);
1033
1034   return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
1035 }
1036
1037 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
1038 Signal an error if VALUE is not 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   check_valid_char_table_value (value, type, ERROR_ME);
1045   return Qnil;
1046 }
1047
1048 /* Assign VAL to all characters in RANGE in char table CT. */
1049
1050 void
1051 put_char_table (struct Lisp_Char_Table *ct, struct chartab_range *range,
1052                 Lisp_Object val)
1053 {
1054   switch (range->type)
1055     {
1056     case CHARTAB_RANGE_ALL:
1057       fill_char_table (ct, val);
1058       return; /* avoid the duplicate call to update_syntax_table() below,
1059                  since fill_char_table() also did that. */
1060
1061 #ifdef MULE
1062     case CHARTAB_RANGE_CHARSET:
1063       if (EQ (range->charset, Vcharset_ascii))
1064         {
1065           int i;
1066           for (i = 0; i < 128; i++)
1067             ct->ascii[i] = val;
1068         }
1069       else if (EQ (range->charset, Vcharset_control_1))
1070         {
1071           int i;
1072           for (i = 128; i < 160; i++)
1073             ct->ascii[i] = val;
1074         }
1075       else
1076         {
1077           Charset_ID lb
1078             = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1079           ct->level1[lb] = val;
1080         }
1081       break;
1082
1083     case CHARTAB_RANGE_ROW:
1084       {
1085         struct Lisp_Char_Table_Entry *cte;
1086         Charset_ID lb
1087           = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1088         /* make sure that there is a separate entry for the row. */
1089         if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1090           ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1091         cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1092         cte->level2[range->row - 32] = val;
1093       }
1094       break;
1095 #endif /* MULE */
1096
1097     case CHARTAB_RANGE_CHAR:
1098 #ifdef MULE
1099       {
1100         Lisp_Object charset;
1101         int byte1, byte2;
1102
1103         BREAKUP_CHAR (range->ch, charset, byte1, byte2);
1104         if (EQ (charset, Vcharset_ascii))
1105           ct->ascii[byte1] = val;
1106         else if (EQ (charset, Vcharset_control_1))
1107           ct->ascii[byte1 + 128] = val;
1108         else
1109           {
1110             struct Lisp_Char_Table_Entry *cte;
1111             Charset_ID lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1112             /* make sure that there is a separate entry for the row. */
1113             if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1114               ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1115             cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1116             /* now CTE is a char table entry for the charset;
1117                each entry is for a single row (or character of
1118                a one-octet charset). */
1119             if (XCHARSET_DIMENSION (charset) == 1)
1120               cte->level2[byte1 - 32] = val;
1121             else
1122               {
1123                 /* assigning to one character in a two-octet charset. */
1124                 /* make sure that the charset row contains a separate
1125                    entry for each character. */
1126                 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
1127                   cte->level2[byte1 - 32] =
1128                     make_char_table_entry (cte->level2[byte1 - 32]);
1129                 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
1130                 cte->level2[byte2 - 32] = val;
1131               }
1132           }
1133       }
1134 #else /* not MULE */
1135       ct->ascii[(unsigned char) (range->ch)] = val;
1136       break;
1137 #endif /* not MULE */
1138     }
1139
1140   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1141     update_syntax_table (ct);
1142 }
1143
1144 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
1145 Set the value for chars in RANGE to be VAL in TABLE.
1146
1147 RANGE specifies one or more characters to be affected and should be
1148 one of the following:
1149
1150 -- t (all characters are affected)
1151 -- A charset (only allowed when Mule support is present)
1152 -- A vector of two elements: a two-octet charset and a row number
1153    (only allowed when Mule support is present)
1154 -- A single character
1155
1156 VAL must be a value appropriate for the type of TABLE.
1157 See `valid-char-table-type-p'.
1158 */
1159        (range, val, table))
1160 {
1161   struct Lisp_Char_Table *ct;
1162   struct chartab_range rainj;
1163
1164   CHECK_CHAR_TABLE (table);
1165   ct = XCHAR_TABLE (table);
1166   check_valid_char_table_value (val, ct->type, ERROR_ME);
1167   decode_char_table_range (range, &rainj);
1168   val = canonicalize_char_table_value (val, ct->type);
1169   put_char_table (ct, &rainj, val);
1170   return Qnil;
1171 }
1172
1173 /* Map FN over the ASCII chars in CT. */
1174
1175 static int
1176 map_over_charset_ascii (struct Lisp_Char_Table *ct,
1177                         int (*fn) (struct chartab_range *range,
1178                                    Lisp_Object val, void *arg),
1179                         void *arg)
1180 {
1181   struct chartab_range rainj;
1182   int i, retval;
1183   int start = 0;
1184 #ifdef MULE
1185   int stop = 128;
1186 #else
1187   int stop = 256;
1188 #endif
1189
1190   rainj.type = CHARTAB_RANGE_CHAR;
1191
1192   for (i = start, retval = 0; i < stop && retval == 0; i++)
1193     {
1194       rainj.ch = (Emchar) i;
1195       retval = (fn) (&rainj, ct->ascii[i], arg);
1196     }
1197
1198   return retval;
1199 }
1200
1201 #ifdef MULE
1202
1203 /* Map FN over the Control-1 chars in CT. */
1204
1205 static int
1206 map_over_charset_control_1 (struct Lisp_Char_Table *ct,
1207                             int (*fn) (struct chartab_range *range,
1208                                        Lisp_Object val, void *arg),
1209                             void *arg)
1210 {
1211   struct chartab_range rainj;
1212   int i, retval;
1213   int start = 128;
1214   int stop  = start + 32;
1215
1216   rainj.type = CHARTAB_RANGE_CHAR;
1217
1218   for (i = start, retval = 0; i < stop && retval == 0; i++)
1219     {
1220       rainj.ch = (Emchar) (i);
1221       retval = (fn) (&rainj, ct->ascii[i], arg);
1222     }
1223
1224   return retval;
1225 }
1226
1227 /* Map FN over the row ROW of two-byte charset CHARSET.
1228    There must be a separate value for that row in the char table.
1229    CTE specifies the char table entry for CHARSET. */
1230
1231 static int
1232 map_over_charset_row (struct Lisp_Char_Table_Entry *cte,
1233                       Lisp_Object charset, int row,
1234                       int (*fn) (struct chartab_range *range,
1235                                  Lisp_Object val, void *arg),
1236                       void *arg)
1237 {
1238   Lisp_Object val = cte->level2[row - 32];
1239
1240   if (!CHAR_TABLE_ENTRYP (val))
1241     {
1242       struct chartab_range rainj;
1243
1244       rainj.type = CHARTAB_RANGE_ROW;
1245       rainj.charset = charset;
1246       rainj.row = row;
1247       return (fn) (&rainj, val, arg);
1248     }
1249   else
1250     {
1251       struct chartab_range rainj;
1252       int i, retval;
1253       int charset94_p = (XCHARSET_CHARS (charset) == 94);
1254       int start = charset94_p ?  33 :  32;
1255       int stop  = charset94_p ? 127 : 128;
1256
1257       cte = XCHAR_TABLE_ENTRY (val);
1258
1259       rainj.type = CHARTAB_RANGE_CHAR;
1260
1261       for (i = start, retval = 0; i < stop && retval == 0; i++)
1262         {
1263           rainj.ch = MAKE_CHAR (charset, row, i);
1264           retval = (fn) (&rainj, cte->level2[i - 32], arg);
1265         }
1266       return retval;
1267     }
1268 }
1269
1270
1271 static int
1272 map_over_other_charset (struct Lisp_Char_Table *ct, Charset_ID lb,
1273                         int (*fn) (struct chartab_range *range,
1274                                    Lisp_Object val, void *arg),
1275                         void *arg)
1276 {
1277   Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
1278   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
1279
1280   if (!CHARSETP (charset)
1281       || lb == LEADING_BYTE_ASCII
1282       || lb == LEADING_BYTE_CONTROL_1)
1283     return 0;
1284
1285   if (!CHAR_TABLE_ENTRYP (val))
1286     {
1287       struct chartab_range rainj;
1288
1289       rainj.type = CHARTAB_RANGE_CHARSET;
1290       rainj.charset = charset;
1291       return (fn) (&rainj, val, arg);
1292     }
1293
1294   {
1295     struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1296     int charset94_p = (XCHARSET_CHARS (charset) == 94);
1297     int start = charset94_p ?  33 :  32;
1298     int stop  = charset94_p ? 127 : 128;
1299     int i, retval;
1300
1301     if (XCHARSET_DIMENSION (charset) == 1)
1302       {
1303         struct chartab_range rainj;
1304         rainj.type = CHARTAB_RANGE_CHAR;
1305
1306         for (i = start, retval = 0; i < stop && retval == 0; i++)
1307           {
1308             rainj.ch = MAKE_CHAR (charset, i, 0);
1309             retval = (fn) (&rainj, cte->level2[i - 32], arg);
1310           }
1311       }
1312     else
1313       {
1314         for (i = start, retval = 0; i < stop && retval == 0; i++)
1315           retval = map_over_charset_row (cte, charset, i, fn, arg);
1316       }
1317
1318     return retval;
1319   }
1320 }
1321
1322 #endif /* MULE */
1323
1324 /* Map FN (with client data ARG) over range RANGE in char table CT.
1325    Mapping stops the first time FN returns non-zero, and that value
1326    becomes the return value of map_char_table(). */
1327
1328 int
1329 map_char_table (struct Lisp_Char_Table *ct,
1330                 struct chartab_range *range,
1331                 int (*fn) (struct chartab_range *range,
1332                            Lisp_Object val, void *arg),
1333                 void *arg)
1334 {
1335   switch (range->type)
1336     {
1337     case CHARTAB_RANGE_ALL:
1338       {
1339         int retval;
1340
1341         retval = map_over_charset_ascii (ct, fn, arg);
1342         if (retval)
1343           return retval;
1344 #ifdef MULE
1345         retval = map_over_charset_control_1 (ct, fn, arg);
1346         if (retval)
1347           return retval;
1348         {
1349           Charset_ID i;
1350           Charset_ID start = MIN_LEADING_BYTE;
1351           Charset_ID stop  = start + NUM_LEADING_BYTES;
1352
1353           for (i = start, retval = 0; i < stop && retval == 0; i++)
1354             {
1355               retval = map_over_other_charset (ct, i, fn, arg);
1356             }
1357         }
1358 #endif /* MULE */
1359         return retval;
1360       }
1361
1362 #ifdef MULE
1363     case CHARTAB_RANGE_CHARSET:
1364       return map_over_other_charset (ct,
1365                                      XCHARSET_LEADING_BYTE (range->charset),
1366                                      fn, arg);
1367
1368     case CHARTAB_RANGE_ROW:
1369       {
1370         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
1371                                     - MIN_LEADING_BYTE];
1372         if (!CHAR_TABLE_ENTRYP (val))
1373           {
1374             struct chartab_range rainj;
1375
1376             rainj.type = CHARTAB_RANGE_ROW;
1377             rainj.charset = range->charset;
1378             rainj.row = range->row;
1379             return (fn) (&rainj, val, arg);
1380           }
1381         else
1382           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
1383                                        range->charset, range->row,
1384                                        fn, arg);
1385       }
1386 #endif /* MULE */
1387
1388     case CHARTAB_RANGE_CHAR:
1389       {
1390         Emchar ch = range->ch;
1391         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
1392         struct chartab_range rainj;
1393
1394         rainj.type = CHARTAB_RANGE_CHAR;
1395         rainj.ch = ch;
1396         return (fn) (&rainj, val, arg);
1397       }
1398
1399     default:
1400       abort ();
1401     }
1402
1403   return 0;
1404 }
1405
1406 struct slow_map_char_table_arg
1407 {
1408   Lisp_Object function;
1409   Lisp_Object retval;
1410 };
1411
1412 static int
1413 slow_map_char_table_fun (struct chartab_range *range,
1414                          Lisp_Object val, void *arg)
1415 {
1416   Lisp_Object ranjarg = Qnil;
1417   struct slow_map_char_table_arg *closure =
1418     (struct slow_map_char_table_arg *) arg;
1419
1420   switch (range->type)
1421     {
1422     case CHARTAB_RANGE_ALL:
1423       ranjarg = Qt;
1424       break;
1425
1426 #ifdef MULE
1427     case CHARTAB_RANGE_CHARSET:
1428       ranjarg = XCHARSET_NAME (range->charset);
1429       break;
1430
1431     case CHARTAB_RANGE_ROW:
1432       ranjarg = vector2 (XCHARSET_NAME (range->charset),
1433                          make_int (range->row));
1434       break;
1435 #endif /* MULE */
1436     case CHARTAB_RANGE_CHAR:
1437       ranjarg = make_char (range->ch);
1438       break;
1439     default:
1440       abort ();
1441     }
1442
1443   closure->retval = call2 (closure->function, ranjarg, val);
1444   return !NILP (closure->retval);
1445 }
1446
1447 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
1448 Map FUNCTION over entries in TABLE, calling it with two args,
1449 each key and value in the table.
1450
1451 RANGE specifies a subrange to map over and is in the same format as
1452 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
1453 the entire table.
1454 */
1455        (function, table, range))
1456 {
1457   struct Lisp_Char_Table *ct;
1458   struct slow_map_char_table_arg slarg;
1459   struct gcpro gcpro1, gcpro2;
1460   struct chartab_range rainj;
1461
1462   CHECK_CHAR_TABLE (table);
1463   ct = XCHAR_TABLE (table);
1464   if (NILP (range))
1465     range = Qt;
1466   decode_char_table_range (range, &rainj);
1467   slarg.function = function;
1468   slarg.retval = Qnil;
1469   GCPRO2 (slarg.function, slarg.retval);
1470   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
1471   UNGCPRO;
1472
1473   return slarg.retval;
1474 }
1475
1476
1477 \f
1478 /************************************************************************/
1479 /*                         Char table read syntax                       */
1480 /************************************************************************/
1481
1482 static int
1483 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
1484                        Error_behavior errb)
1485 {
1486   /* #### should deal with ERRB */
1487   symbol_to_char_table_type (value);
1488   return 1;
1489 }
1490
1491 static int
1492 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
1493                        Error_behavior errb)
1494 {
1495   Lisp_Object rest;
1496
1497   /* #### should deal with ERRB */
1498   EXTERNAL_LIST_LOOP (rest, value)
1499     {
1500       Lisp_Object range = XCAR (rest);
1501       struct chartab_range dummy;
1502
1503       rest = XCDR (rest);
1504       if (!CONSP (rest))
1505         signal_simple_error ("Invalid list format", value);
1506       if (CONSP (range))
1507         {
1508           if (!CONSP (XCDR (range))
1509               || !NILP (XCDR (XCDR (range))))
1510             signal_simple_error ("Invalid range format", range);
1511           decode_char_table_range (XCAR (range), &dummy);
1512           decode_char_table_range (XCAR (XCDR (range)), &dummy);
1513         }
1514       else
1515         decode_char_table_range (range, &dummy);
1516     }
1517
1518   return 1;
1519 }
1520
1521 static Lisp_Object
1522 chartab_instantiate (Lisp_Object data)
1523 {
1524   Lisp_Object chartab;
1525   Lisp_Object type = Qgeneric;
1526   Lisp_Object dataval = Qnil;
1527
1528   while (!NILP (data))
1529     {
1530       Lisp_Object keyw = Fcar (data);
1531       Lisp_Object valw;
1532
1533       data = Fcdr (data);
1534       valw = Fcar (data);
1535       data = Fcdr (data);
1536       if (EQ (keyw, Qtype))
1537         type = valw;
1538       else if (EQ (keyw, Qdata))
1539         dataval = valw;
1540     }
1541
1542   chartab = Fmake_char_table (type);
1543
1544   data = dataval;
1545   while (!NILP (data))
1546     {
1547       Lisp_Object range = Fcar (data);
1548       Lisp_Object val = Fcar (Fcdr (data));
1549
1550       data = Fcdr (Fcdr (data));
1551       if (CONSP (range))
1552         {
1553           if (CHAR_OR_CHAR_INTP (XCAR (range)))
1554             {
1555               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
1556               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
1557               Emchar i;
1558
1559               for (i = first; i <= last; i++)
1560                  Fput_char_table (make_char (i), val, chartab);
1561             }
1562           else
1563             abort ();
1564         }
1565       else
1566         Fput_char_table (range, val, chartab);
1567     }
1568
1569   return chartab;
1570 }
1571
1572 #ifdef MULE
1573
1574 \f
1575 /************************************************************************/
1576 /*                     Category Tables, specifically                    */
1577 /************************************************************************/
1578
1579 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
1580 Return t if ARG is a category table.
1581 A category table is a type of char table used for keeping track of
1582 categories.  Categories are used for classifying characters for use
1583 in regexps -- you can refer to a category rather than having to use
1584 a complicated [] expression (and category lookups are significantly
1585 faster).
1586
1587 There are 95 different categories available, one for each printable
1588 character (including space) in the ASCII charset.  Each category
1589 is designated by one such character, called a "category designator".
1590 They are specified in a regexp using the syntax "\\cX", where X is
1591 a category designator.
1592
1593 A category table specifies, for each character, the categories that
1594 the character is in.  Note that a character can be in more than one
1595 category.  More specifically, a category table maps from a character
1596 to either the value nil (meaning the character is in no categories)
1597 or a 95-element bit vector, specifying for each of the 95 categories
1598 whether the character is in that category.
1599
1600 Special Lisp functions are provided that abstract this, so you do not
1601 have to directly manipulate bit vectors.
1602 */
1603        (obj))
1604 {
1605   return (CHAR_TABLEP (obj) &&
1606           XCHAR_TABLE_TYPE (obj) == CHAR_TABLE_TYPE_CATEGORY) ?
1607     Qt : Qnil;
1608 }
1609
1610 static Lisp_Object
1611 check_category_table (Lisp_Object obj, Lisp_Object def)
1612 {
1613   if (NILP (obj))
1614     obj = def;
1615   while (NILP (Fcategory_table_p (obj)))
1616     obj = wrong_type_argument (Qcategory_table_p, obj);
1617   return obj;
1618 }
1619
1620 int
1621 check_category_char (Emchar ch, Lisp_Object table,
1622                      unsigned int designator, unsigned int not)
1623 {
1624   REGISTER Lisp_Object temp;
1625   struct Lisp_Char_Table *ctbl;
1626 #ifdef ERROR_CHECK_TYPECHECK
1627   if (NILP (Fcategory_table_p (table)))
1628     signal_simple_error ("Expected category table", table);
1629 #endif
1630   ctbl = XCHAR_TABLE (table);
1631   temp = get_char_table (ch, ctbl);
1632   if (NILP (temp))
1633     return not;
1634
1635   designator -= ' ';
1636   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
1637 }
1638
1639 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
1640 Return t if category of a character at POS includes DESIGNATOR,
1641 else return nil. Optional third arg specifies which buffer
1642 \(defaulting to current), and fourth specifies the CATEGORY-TABLE,
1643 \(defaulting to the buffer's category table).
1644 */
1645        (pos, designator, buffer, category_table))
1646 {
1647   Lisp_Object ctbl;
1648   Emchar ch;
1649   unsigned int des;
1650   struct buffer *buf = decode_buffer (buffer, 0);
1651
1652   CHECK_INT (pos);
1653   CHECK_CATEGORY_DESIGNATOR (designator);
1654   des = XCHAR (designator);
1655   ctbl = check_category_table (category_table, Vstandard_category_table);
1656   ch = BUF_FETCH_CHAR (buf, XINT (pos));
1657   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1658 }
1659
1660 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
1661 Return t if category of character CHR includes DESIGNATOR, else nil.
1662 Optional third arg specifies the CATEGORY-TABLE to use,
1663 which defaults to the system default table.
1664 */
1665        (chr, designator, category_table))
1666 {
1667   Lisp_Object ctbl;
1668   Emchar ch;
1669   unsigned int des;
1670
1671   CHECK_CATEGORY_DESIGNATOR (designator);
1672   des = XCHAR (designator);
1673   CHECK_CHAR (chr);
1674   ch = XCHAR (chr);
1675   ctbl = check_category_table (category_table, Vstandard_category_table);
1676   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1677 }
1678
1679 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
1680 Return the current category table.
1681 This is the one specified by the current buffer, or by BUFFER if it
1682 is non-nil.
1683 */
1684        (buffer))
1685 {
1686   return decode_buffer (buffer, 0)->category_table;
1687 }
1688
1689 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
1690 Return the standard category table.
1691 This is the one used for new buffers.
1692 */
1693        ())
1694 {
1695   return Vstandard_category_table;
1696 }
1697
1698 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
1699 Construct a new category table and return it.
1700 It is a copy of the TABLE, which defaults to the standard category table.
1701 */
1702        (table))
1703 {
1704   if (NILP (Vstandard_category_table))
1705     return Fmake_char_table (Qcategory);
1706
1707   table = check_category_table (table, Vstandard_category_table);
1708   return Fcopy_char_table (table);
1709 }
1710
1711 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
1712 Select a new category table for BUFFER.
1713 One argument, a category table.
1714 BUFFER defaults to the current buffer if omitted.
1715 */
1716        (table, buffer))
1717 {
1718   struct buffer *buf = decode_buffer (buffer, 0);
1719   table = check_category_table (table, Qnil);
1720   buf->category_table = table;
1721   /* Indicate that this buffer now has a specified category table.  */
1722   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
1723   return table;
1724 }
1725
1726 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
1727 Return t if ARG is a category designator (a char in the range ' ' to '~').
1728 */
1729        (obj))
1730 {
1731   return CATEGORY_DESIGNATORP (obj) ? Qt : Qnil;
1732 }
1733
1734 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
1735 Return t if ARG is a category table value.
1736 Valid values are nil or a bit vector of size 95.
1737 */
1738        (obj))
1739 {
1740   return CATEGORY_TABLE_VALUEP (obj) ? Qt : Qnil;
1741 }
1742
1743
1744 #define CATEGORYP(x) \
1745   (CHARP ((x)) && XCHAR ((x)) >= 0x20 && XCHAR ((x)) <= 0x7E)
1746
1747 #define CATEGORY_SET(c)                                         \
1748   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
1749
1750 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
1751    The faster version of `!NILP (Faref (category_set, category))'.  */
1752 #define CATEGORY_MEMBER(category, category_set)                 \
1753   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
1754
1755 /* Return 1 if there is a word boundary between two word-constituent
1756    characters C1 and C2 if they appear in this order, else return 0.
1757    Use the macro WORD_BOUNDARY_P instead of calling this function
1758    directly.  */
1759
1760 int
1761 word_boundary_p (Emchar c1, Emchar c2)
1762 {
1763   Lisp_Object category_set1, category_set2;
1764   Lisp_Object tail;
1765   int default_result;
1766
1767 #if 0
1768   if (COMPOSITE_CHAR_P (c1))
1769     c1 = cmpchar_component (c1, 0, 1);
1770   if (COMPOSITE_CHAR_P (c2))
1771     c2 = cmpchar_component (c2, 0, 1);
1772 #endif
1773
1774   if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
1775     {
1776       tail = Vword_separating_categories;
1777       default_result = 0;
1778     }
1779   else
1780     {
1781       tail = Vword_combining_categories;
1782       default_result = 1;
1783     }
1784
1785   category_set1 = CATEGORY_SET (c1);
1786   if (NILP (category_set1))
1787     return default_result;
1788   category_set2 = CATEGORY_SET (c2);
1789   if (NILP (category_set2))
1790     return default_result;
1791
1792   for (; CONSP (tail); tail = XCONS (tail)->cdr)
1793     {
1794       Lisp_Object elt = XCONS(tail)->car;
1795
1796       if (CONSP (elt)
1797           && CATEGORYP (XCONS (elt)->car)
1798           && CATEGORYP (XCONS (elt)->cdr)
1799           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
1800           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
1801         return !default_result;
1802     }
1803   return default_result;
1804 }
1805 #endif /* MULE */
1806
1807 \f
1808 void
1809 syms_of_chartab (void)
1810 {
1811 #ifdef MULE
1812   defsymbol (&Qcategory_table_p, "category-table-p");
1813   defsymbol (&Qcategory_designator_p, "category-designator-p");
1814   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
1815 #endif /* MULE */
1816
1817   defsymbol (&Qchar_table, "char-table");
1818   defsymbol (&Qchar_tablep, "char-table-p");
1819
1820   DEFSUBR (Fchar_table_p);
1821   DEFSUBR (Fchar_table_type_list);
1822   DEFSUBR (Fvalid_char_table_type_p);
1823   DEFSUBR (Fchar_table_type);
1824   DEFSUBR (Freset_char_table);
1825   DEFSUBR (Fmake_char_table);
1826   DEFSUBR (Fcopy_char_table);
1827   DEFSUBR (Fget_char_table);
1828   DEFSUBR (Fget_range_char_table);
1829   DEFSUBR (Fvalid_char_table_value_p);
1830   DEFSUBR (Fcheck_valid_char_table_value);
1831   DEFSUBR (Fput_char_table);
1832   DEFSUBR (Fmap_char_table);
1833
1834 #ifdef MULE
1835   DEFSUBR (Fcategory_table_p);
1836   DEFSUBR (Fcategory_table);
1837   DEFSUBR (Fstandard_category_table);
1838   DEFSUBR (Fcopy_category_table);
1839   DEFSUBR (Fset_category_table);
1840   DEFSUBR (Fcheck_category_at);
1841   DEFSUBR (Fchar_in_category_p);
1842   DEFSUBR (Fcategory_designator_p);
1843   DEFSUBR (Fcategory_table_value_p);
1844 #endif /* MULE */
1845
1846 }
1847
1848 void
1849 vars_of_chartab (void)
1850 {
1851   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
1852   Vall_syntax_tables = Qnil;
1853 }
1854
1855 void
1856 structure_type_create_chartab (void)
1857 {
1858   struct structure_type *st;
1859
1860   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
1861
1862   define_structure_type_keyword (st, Qtype, chartab_type_validate);
1863   define_structure_type_keyword (st, Qdata, chartab_data_validate);
1864 }
1865
1866 void
1867 complex_vars_of_chartab (void)
1868 {
1869 #ifdef MULE
1870   /* Set this now, so first buffer creation can refer to it. */
1871   /* Make it nil before calling copy-category-table
1872      so that copy-category-table will know not to try to copy from garbage */
1873   Vstandard_category_table = Qnil;
1874   Vstandard_category_table = Fcopy_category_table (Qnil);
1875   staticpro (&Vstandard_category_table);
1876
1877   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
1878 List of pair (cons) of categories to determine word boundary.
1879
1880 Emacs treats a sequence of word constituent characters as a single
1881 word (i.e. finds no word boundary between them) iff they belongs to
1882 the same charset.  But, exceptions are allowed in the following cases.
1883
1884 (1) The case that characters are in different charsets is controlled
1885 by the variable `word-combining-categories'.
1886
1887 Emacs finds no word boundary between characters of different charsets
1888 if they have categories matching some element of this list.
1889
1890 More precisely, if an element of this list is a cons of category CAT1
1891 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1892 C2 which has CAT2, there's no word boundary between C1 and C2.
1893
1894 For instance, to tell that ASCII characters and Latin-1 characters can
1895 form a single word, the element `(?l . ?l)' should be in this list
1896 because both characters have the category `l' (Latin characters).
1897
1898 (2) The case that character are in the same charset is controlled by
1899 the variable `word-separating-categories'.
1900
1901 Emacs find a word boundary between characters of the same charset
1902 if they have categories matching some element of this list.
1903
1904 More precisely, if an element of this list is a cons of category CAT1
1905 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1906 C2 which has CAT2, there's a word boundary between C1 and C2.
1907
1908 For instance, to tell that there's a word boundary between Japanese
1909 Hiragana and Japanese Kanji (both are in the same charset), the
1910 element `(?H . ?C) should be in this list.
1911 */ );
1912
1913   Vword_combining_categories = Qnil;
1914
1915   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
1916 List of pair (cons) of categories to determine word boundary.
1917 See the documentation of the variable `word-combining-categories'.
1918 */ );
1919
1920   Vword_separating_categories = Qnil;
1921 #endif /* MULE */
1922 }