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

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