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

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