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

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