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