src/chartab.c

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