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