cgit.sxemacs.org Git - sxemacs/blob - src/chartab.c

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