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 #ifdef MULE
 989         case CHAR_TABLE_TYPE_CATEGORY:
 990 #endif
 991         case CHAR_TABLE_TYPE_DISPLAY:
 992         default:
 993                 break;
 994         }
 995         return value;
 996 }
 997
 998 DEFUN("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0,   /*
 999 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
1000 */
1001       (value, char_table_type))
1002 {
1003         enum char_table_type type = symbol_to_char_table_type(char_table_type);
1004
1005         return check_valid_char_table_value(value, type,
1006                                             ERROR_ME_NOT) ? Qt : Qnil;
1007 }
1008
1009 DEFUN("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0,   /*
1010 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
1011 */
1012       (value, char_table_type))
1013 {
1014         enum char_table_type type = symbol_to_char_table_type(char_table_type);
1015
1016         check_valid_char_table_value(value, type, ERROR_ME);
1017         return Qnil;
1018 }
1019
1020 /* Assign VAL to all characters in RANGE in char table CT. */
1021
1022 void
1023 put_char_table(Lisp_Char_Table * ct, struct chartab_range *range,
1024                Lisp_Object val)
1025 {
1026         switch (range->type) {
1027         case CHARTAB_RANGE_ALL:
1028                 fill_char_table(ct, val);
1029                 /* avoid the duplicate call to update_syntax_table() below,
1030                    since fill_char_table() also did that. */
1031                 return;
1032
1033 #ifdef MULE
1034         case CHARTAB_RANGE_CHARSET:
1035                 if (EQ(range->charset, Vcharset_ascii)) {
1036                         int i;
1037                         for (i = 0; i < 128; i++)
1038                                 ct->ascii[i] = val;
1039                 } else if (EQ(range->charset, Vcharset_control_1)) {
1040                         int i;
1041                         for (i = 128; i < 160; i++)
1042                                 ct->ascii[i] = val;
1043                 } else {
1044                         int lb =
1045                             XCHARSET_LEADING_BYTE(range->charset) -
1046                             MIN_LEADING_BYTE;
1047                         ct->level1[lb] = val;
1048                 }
1049                 break;
1050
1051         case CHARTAB_RANGE_ROW:
1052                 {
1053                         Lisp_Char_Table_Entry *cte;
1054                         int lb =
1055                             XCHARSET_LEADING_BYTE(range->charset) -
1056                             MIN_LEADING_BYTE;
1057                         /* make sure that there is a separate entry for the
1058                            row. */
1059                         if (!CHAR_TABLE_ENTRYP(ct->level1[lb]))
1060                                 ct->level1[lb] =
1061                                     make_char_table_entry(ct->level1[lb]);
1062                         cte = XCHAR_TABLE_ENTRY(ct->level1[lb]);
1063                         cte->level2[range->row - 32] = val;
1064                 }
1065                 break;
1066 #endif                          /* MULE */
1067
1068         case CHARTAB_RANGE_CHAR: {
1069 #ifdef MULE
1070                 Lisp_Object charset;
1071                 int byte1, byte2;
1072
1073                 BREAKUP_CHAR(range->ch, charset, byte1, byte2);
1074                 if (EQ(charset, Vcharset_ascii))
1075                         ct->ascii[byte1] = val;
1076                 else if (EQ(charset, Vcharset_control_1))
1077                         ct->ascii[byte1 + 128] = val;
1078                 else {
1079                         Lisp_Char_Table_Entry *cte;
1080                         int lb =
1081                                 XCHARSET_LEADING_BYTE(charset) -
1082                                 MIN_LEADING_BYTE;
1083                         /* make sure that there is a separate entry for the
1084                            row. */
1085                         if (!CHAR_TABLE_ENTRYP(ct->level1[lb]))
1086                                 ct->level1[lb] =
1087                                         make_char_table_entry(ct->
1088                                                               level1[lb]);
1089                         cte = XCHAR_TABLE_ENTRY(ct->level1[lb]);
1090                         /* now CTE is a char table entry for the charset;
1091                            each entry is for a single row (or character of
1092                            a one-octet charset). */
1093                         if (XCHARSET_DIMENSION(charset) == 1)
1094                                 cte->level2[byte1 - 32] = val;
1095                         else {
1096                                 /* assigning to one character in a two-octet
1097                                    charset. */
1098                                 /* make sure that the charset row contains a
1099                                    separate entry for each character. */
1100                                 if (!CHAR_TABLE_ENTRYP
1101                                     (cte->level2[byte1 - 32]))
1102                                         cte->level2[byte1 - 32] =
1103                                                 make_char_table_entry(cte->
1104                                                                       level2
1105                                                                       [byte1
1106                                                                        -
1107                                                                        32]);
1108                                 cte = XCHAR_TABLE_ENTRY(cte->
1109                                                         level2[byte1 - 32]);
1110                                 cte->level2[byte2 - 32] = val;
1111                         }
1112                 }
1113 #else                           /* not MULE */
1114                 ct->ascii[(unsigned char)(range->ch)] = val;
1115                 break;
1116 #endif                          /* not MULE */
1117         }
1118         default:
1119                 /* shouldnt happen should it? */
1120                 break;
1121         }
1122
1123         if (ct->type == CHAR_TABLE_TYPE_SYNTAX) {
1124                 update_syntax_table(ct);
1125         }
1126         return;
1127 }
1128
1129 DEFUN("put-char-table", Fput_char_table, 3, 3, 0,       /*
1130 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
1131
1132 RANGE specifies one or more characters to be affected and should be
1133 one of the following:
1134
1135 -- t (all characters are affected)
1136 -- A charset (only allowed when Mule support is present)
1137 -- A vector of two elements: a two-octet charset and a row number
1138 (only allowed when Mule support is present)
1139 -- A single character
1140
1141 VALUE must be a value appropriate for the type of CHAR-TABLE.
1142 See `valid-char-table-type-p'.
1143 */
1144       (range, value, char_table))
1145 {
1146         Lisp_Char_Table *ct;
1147         struct chartab_range rainj;
1148
1149         CHECK_CHAR_TABLE(char_table);
1150         ct = XCHAR_TABLE(char_table);
1151         check_valid_char_table_value(value, ct->type, ERROR_ME);
1152         decode_char_table_range(range, &rainj);
1153         value = canonicalize_char_table_value(value, ct->type);
1154         put_char_table(ct, &rainj, value);
1155         return Qnil;
1156 }
1157
1158 /* Map FN over the ASCII chars in CT. */
1159
1160 static int
1161 map_over_charset_ascii(Lisp_Char_Table * ct,
1162                        int (*fn) (struct chartab_range * range,
1163                                   Lisp_Object val, void *arg), void *arg)
1164 {
1165         struct chartab_range rainj;
1166         int i, retval;
1167         int start = 0;
1168 #ifdef MULE
1169         int stop = 128;
1170 #else
1171         int stop = 256;
1172 #endif
1173
1174         rainj.type = CHARTAB_RANGE_CHAR;
1175
1176         for (i = start, retval = 0; i < stop && retval == 0; i++) {
1177                 rainj.ch = (Emchar) i;
1178                 retval = (fn) (&rainj, ct->ascii[i], arg);
1179         }
1180
1181         return retval;
1182 }
1183
1184 #ifdef MULE
1185
1186 /* Map FN over the Control-1 chars in CT. */
1187
1188 static int
1189 map_over_charset_control_1(Lisp_Char_Table * ct,
1190                            int (*fn) (struct chartab_range * range,
1191                                       Lisp_Object val, void *arg), void *arg)
1192 {
1193         struct chartab_range rainj;
1194         int i, retval;
1195         int start = 128;
1196         int stop = start + 32;
1197
1198         rainj.type = CHARTAB_RANGE_CHAR;
1199
1200         for (i = start, retval = 0; i < stop && retval == 0; i++) {
1201                 rainj.ch = (Emchar) (i);
1202                 retval = (fn) (&rainj, ct->ascii[i], arg);
1203         }
1204
1205         return retval;
1206 }
1207
1208 /* Map FN over the row ROW of two-byte charset CHARSET.
1209    There must be a separate value for that row in the char table.
1210    CTE specifies the char table entry for CHARSET. */
1211
1212 static int
1213 map_over_charset_row(Lisp_Char_Table_Entry * cte,
1214                      Lisp_Object charset, int row,
1215                      int (*fn) (struct chartab_range * range,
1216                                 Lisp_Object val, void *arg), void *arg)
1217 {
1218         Lisp_Object val = cte->level2[row - 32];
1219
1220         if (!CHAR_TABLE_ENTRYP(val)) {
1221                 struct chartab_range rainj;
1222
1223                 rainj.type = CHARTAB_RANGE_ROW;
1224                 rainj.charset = charset;
1225                 rainj.row = row;
1226                 return (fn) (&rainj, val, arg);
1227         } else {
1228                 struct chartab_range rainj;
1229                 int i, retval;
1230                 int charset94_p = (XCHARSET_CHARS(charset) == 94);
1231                 int start = charset94_p ? 33 : 32;
1232                 int stop = charset94_p ? 127 : 128;
1233
1234                 cte = XCHAR_TABLE_ENTRY(val);
1235
1236                 rainj.type = CHARTAB_RANGE_CHAR;
1237
1238                 for (i = start, retval = 0; i < stop && retval == 0; i++) {
1239                         rainj.ch = MAKE_CHAR(charset, row, i);
1240                         retval = (fn) (&rainj, cte->level2[i - 32], arg);
1241                 }
1242                 return retval;
1243         }
1244 }
1245
1246 static int
1247 map_over_other_charset(Lisp_Char_Table * ct, int lb,
1248                        int (*fn) (struct chartab_range * range,
1249                                   Lisp_Object val, void *arg), void *arg)
1250 {
1251         Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
1252         Lisp_Object charset = CHARSET_BY_LEADING_BYTE(lb);
1253
1254         if (!CHARSETP(charset)
1255             || lb == LEADING_BYTE_ASCII || lb == LEADING_BYTE_CONTROL_1)
1256                 return 0;
1257
1258         if (!CHAR_TABLE_ENTRYP(val)) {
1259                 struct chartab_range rainj;
1260
1261                 rainj.type = CHARTAB_RANGE_CHARSET;
1262                 rainj.charset = charset;
1263                 return (fn) (&rainj, val, arg);
1264         }
1265
1266         {
1267                 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY(val);
1268                 int charset94_p = (XCHARSET_CHARS(charset) == 94);
1269                 int start = charset94_p ? 33 : 32;
1270                 int stop = charset94_p ? 127 : 128;
1271                 int i, retval;
1272
1273                 if (XCHARSET_DIMENSION(charset) == 1) {
1274                         struct chartab_range rainj;
1275                         rainj.type = CHARTAB_RANGE_CHAR;
1276
1277                         for (i = start, retval = 0; i < stop && retval == 0;
1278                              i++) {
1279                                 rainj.ch = MAKE_CHAR(charset, i, 0);
1280                                 retval =
1281                                     (fn) (&rainj, cte->level2[i - 32], arg);
1282                         }
1283                 } else {
1284                         for (i = start, retval = 0; i < stop && retval == 0;
1285                              i++)
1286                                 retval =
1287                                     map_over_charset_row(cte, charset, i, fn,
1288                                                          arg);
1289                 }
1290
1291                 return retval;
1292         }
1293 }
1294
1295 #endif                          /* MULE */
1296
1297 /* Map FN (with client data ARG) over range RANGE in char table CT.
1298    Mapping stops the first time FN returns non-zero, and that value
1299    becomes the return value of map_char_table(). */
1300
1301 int
1302 map_char_table(Lisp_Char_Table * ct,
1303                struct chartab_range *range,
1304                int (*fn) (struct chartab_range * range,
1305                           Lisp_Object val, void *arg), void *arg)
1306 {
1307         switch (range->type) {
1308         case CHARTAB_RANGE_ALL:
1309                 {
1310                         int retval;
1311
1312                         retval = map_over_charset_ascii(ct, fn, arg);
1313                         if (retval)
1314                                 return retval;
1315 #ifdef MULE
1316                         retval = map_over_charset_control_1(ct, fn, arg);
1317                         if (retval)
1318                                 return retval;
1319                         {
1320                                 int i;
1321                                 int start = MIN_LEADING_BYTE;
1322                                 int stop = start + NUM_LEADING_BYTES;
1323
1324                                 for (i = start, retval = 0;
1325                                      i < stop && retval == 0; i++) {
1326                                         retval =
1327                                             map_over_other_charset(ct, i, fn,
1328                                                                    arg);
1329                                 }
1330                         }
1331 #endif                          /* MULE */
1332                         return retval;
1333                 }
1334
1335 #ifdef MULE
1336         case CHARTAB_RANGE_CHARSET:
1337                 return map_over_other_charset(ct,
1338                                               XCHARSET_LEADING_BYTE(range->
1339                                                                     charset),
1340                                               fn, arg);
1341
1342         case CHARTAB_RANGE_ROW:
1343                 {
1344                         Lisp_Object val =
1345                             ct->level1[XCHARSET_LEADING_BYTE(range->charset) -
1346                                        MIN_LEADING_BYTE];
1347                         if (!CHAR_TABLE_ENTRYP(val)) {
1348                                 struct chartab_range rainj;
1349
1350                                 rainj.type = CHARTAB_RANGE_ROW;
1351                                 rainj.charset = range->charset;
1352                                 rainj.row = range->row;
1353                                 return (fn) (&rainj, val, arg);
1354                         } else
1355                                 return
1356                                     map_over_charset_row(XCHAR_TABLE_ENTRY(val),
1357                                                          range->charset,
1358                                                          range->row, fn, arg);
1359                 }
1360 #endif                          /* MULE */
1361
1362         case CHARTAB_RANGE_CHAR:
1363                 {
1364                         Emchar ch = range->ch;
1365                         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE(ct, ch);
1366                         struct chartab_range rainj;
1367
1368                         rainj.type = CHARTAB_RANGE_CHAR;
1369                         rainj.ch = ch;
1370                         return (fn) (&rainj, val, arg);
1371                 }
1372
1373         default:
1374                 abort();
1375         }
1376
1377         return 0;
1378 }
1379
1380 struct slow_map_char_table_arg {
1381         Lisp_Object function;
1382         Lisp_Object retval;
1383 };
1384
1385 static int
1386 slow_map_char_table_fun(struct chartab_range *range, Lisp_Object val, void *arg)
1387 {
1388         Lisp_Object ranjarg = Qnil;
1389         struct slow_map_char_table_arg *closure =
1390             (struct slow_map_char_table_arg *)arg;
1391
1392         switch (range->type) {
1393         case CHARTAB_RANGE_ALL:
1394                 ranjarg = Qt;
1395                 break;
1396
1397 #ifdef MULE
1398         case CHARTAB_RANGE_CHARSET:
1399                 ranjarg = XCHARSET_NAME(range->charset);
1400                 break;
1401
1402         case CHARTAB_RANGE_ROW:
1403                 ranjarg = vector2(XCHARSET_NAME(range->charset),
1404                                   make_int(range->row));
1405                 break;
1406 #endif                          /* MULE */
1407         case CHARTAB_RANGE_CHAR:
1408                 ranjarg = make_char(range->ch);
1409                 break;
1410         default:
1411                 abort();
1412         }
1413
1414         closure->retval = call2(closure->function, ranjarg, val);
1415         return !NILP(closure->retval);
1416 }
1417
1418 DEFUN("map-char-table", Fmap_char_table, 2, 3, 0,       /*
1419 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
1420 each key and value in the table.
1421
1422 RANGE specifies a subrange to map over and is in the same format as
1423 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
1424 the entire table.
1425 */
1426       (function, char_table, range))
1427 {
1428         Lisp_Char_Table *ct;
1429         struct slow_map_char_table_arg slarg;
1430         struct gcpro gcpro1, gcpro2;
1431         struct chartab_range rainj;
1432
1433         CHECK_CHAR_TABLE(char_table);
1434         ct = XCHAR_TABLE(char_table);
1435         if (NILP(range))
1436                 range = Qt;
1437         decode_char_table_range(range, &rainj);
1438         slarg.function = function;
1439         slarg.retval = Qnil;
1440         GCPRO2(slarg.function, slarg.retval);
1441         map_char_table(ct, &rainj, slow_map_char_table_fun, &slarg);
1442         UNGCPRO;
1443
1444         return slarg.retval;
1445 }
1446 \f
1447 /************************************************************************/
1448 /*                         Char table read syntax                       */
1449 /************************************************************************/
1450
1451 static int
1452 chartab_type_validate(Lisp_Object keyword, Lisp_Object value,
1453                       Error_behavior errb)
1454 {
1455         /* #### should deal with ERRB */
1456         symbol_to_char_table_type(value);
1457         return 1;
1458 }
1459
1460 static int
1461 chartab_data_validate(Lisp_Object keyword, Lisp_Object value,
1462                       Error_behavior errb)
1463 {
1464         Lisp_Object rest;
1465
1466         /* #### should deal with ERRB */
1467         EXTERNAL_LIST_LOOP(rest, value) {
1468                 Lisp_Object range = XCAR(rest);
1469                 struct chartab_range dummy;
1470
1471                 rest = XCDR(rest);
1472                 if (!CONSP(rest))
1473                         signal_simple_error("Invalid list format", value);
1474                 if (CONSP(range)) {
1475                         if (!CONSP(XCDR(range))
1476                             || !NILP(XCDR(XCDR(range))))
1477                                 signal_simple_error("Invalid range format",
1478                                                     range);
1479                         decode_char_table_range(XCAR(range), &dummy);
1480                         decode_char_table_range(XCAR(XCDR(range)), &dummy);
1481                 } else
1482                         decode_char_table_range(range, &dummy);
1483         }
1484
1485         return 1;
1486 }
1487
1488 static Lisp_Object chartab_instantiate(Lisp_Object data)
1489 {
1490         Lisp_Object chartab;
1491         Lisp_Object type = Qgeneric;
1492         Lisp_Object dataval = Qnil;
1493
1494         while (!NILP(data)) {
1495                 Lisp_Object keyw = Fcar(data);
1496                 Lisp_Object valw;
1497
1498                 data = Fcdr(data);
1499                 valw = Fcar(data);
1500                 data = Fcdr(data);
1501                 if (EQ(keyw, Qtype))
1502                         type = valw;
1503                 else if (EQ(keyw, Qdata))
1504                         dataval = valw;
1505         }
1506
1507         chartab = Fmake_char_table(type);
1508
1509         data = dataval;
1510         while (!NILP(data)) {
1511                 Lisp_Object range = Fcar(data);
1512                 Lisp_Object val = Fcar(Fcdr(data));
1513
1514                 data = Fcdr(Fcdr(data));
1515                 if (CONSP(range)) {
1516                         if (CHAR_OR_CHAR_INTP(XCAR(range))) {
1517                                 Emchar first = XCHAR_OR_CHAR_INT(Fcar(range));
1518                                 Emchar last =
1519                                     XCHAR_OR_CHAR_INT(Fcar(Fcdr(range)));
1520                                 Emchar i;
1521
1522                                 for (i = first; i <= last; i++)
1523                                         Fput_char_table(make_char(i), val,
1524                                                         chartab);
1525                         } else
1526                                 abort();
1527                 } else
1528                         Fput_char_table(range, val, chartab);
1529         }
1530
1531         return chartab;
1532 }
1533
1534 #ifdef MULE
1535 \f
1536 /************************************************************************/
1537 /*                     Category Tables, specifically                    */
1538 /************************************************************************/
1539
1540 DEFUN("category-table-p", Fcategory_table_p, 1, 1, 0,   /*
1541 Return t if OBJECT is a category table.
1542 A category table is a type of char table used for keeping track of
1543 categories.  Categories are used for classifying characters for use
1544 in regexps -- you can refer to a category rather than having to use
1545 a complicated [] expression (and category lookups are significantly
1546 faster).
1547
1548 There are 95 different categories available, one for each printable
1549 character (including space) in the ASCII charset.  Each category
1550 is designated by one such character, called a "category designator".
1551 They are specified in a regexp using the syntax "\\cX", where X is
1552 a category designator.
1553
1554 A category table specifies, for each character, the categories that
1555 the character is in.  Note that a character can be in more than one
1556 category.  More specifically, a category table maps from a character
1557 to either the value nil (meaning the character is in no categories)
1558 or a 95-element bit vector, specifying for each of the 95 categories
1559 whether the character is in that category.
1560
1561 Special Lisp functions are provided that abstract this, so you do not
1562 have to directly manipulate bit vectors.
1563 */
1564       (object))
1565 {
1566         return (CHAR_TABLEP(object) &&
1567                 XCHAR_TABLE_TYPE(object) == CHAR_TABLE_TYPE_CATEGORY) ?
1568             Qt : Qnil;
1569 }
1570
1571 static Lisp_Object
1572 check_category_table(Lisp_Object object, Lisp_Object default_)
1573 {
1574         if (NILP(object))
1575                 object = default_;
1576         while (NILP(Fcategory_table_p(object)))
1577                 object = wrong_type_argument(Qcategory_table_p, object);
1578         return object;
1579 }
1580
1581 int
1582 check_category_char(Emchar ch, Lisp_Object table,
1583                     unsigned int designator, unsigned int not_p)
1584 {
1585         REGISTER Lisp_Object temp;
1586         Lisp_Char_Table *ctbl;
1587 #ifdef ERROR_CHECK_TYPECHECK
1588         if (NILP(Fcategory_table_p(table)))
1589                 signal_simple_error("Expected category table", table);
1590 #endif
1591         ctbl = XCHAR_TABLE(table);
1592         temp = get_char_table(ch, ctbl);
1593         if (NILP(temp))
1594                 return not_p;
1595
1596         designator -= ' ';
1597         return bit_vector_bit(XBIT_VECTOR(temp), designator) ? !not_p : not_p;
1598 }
1599
1600 DEFUN("check-category-at", Fcheck_category_at, 2, 4, 0, /*
1601 Return t if category of the character at POSITION includes DESIGNATOR.
1602 Optional third arg BUFFER specifies which buffer to use, and defaults
1603 to the current buffer.
1604 Optional fourth arg CATEGORY-TABLE specifies the category table to
1605 use, and defaults to BUFFER's category table.
1606 */
1607       (position, designator, buffer, category_table))
1608 {
1609         Lisp_Object ctbl;
1610         Emchar ch;
1611         unsigned int des;
1612         struct buffer *buf = decode_buffer(buffer, 0);
1613
1614         CHECK_INT(position);
1615         CHECK_CATEGORY_DESIGNATOR(designator);
1616         des = XCHAR(designator);
1617         ctbl = check_category_table(category_table, Vstandard_category_table);
1618         ch = BUF_FETCH_CHAR(buf, XINT(position));
1619         return check_category_char(ch, ctbl, des, 0) ? Qt : Qnil;
1620 }
1621
1622 DEFUN("char-in-category-p", Fchar_in_category_p, 2, 3, 0,       /*
1623 Return t if category of CHARACTER includes DESIGNATOR, else nil.
1624 Optional third arg CATEGORY-TABLE specifies the category table to use,
1625 and defaults to the standard category table.
1626 */
1627       (character, designator, category_table))
1628 {
1629         Lisp_Object ctbl;
1630         Emchar ch;
1631         unsigned int des;
1632
1633         CHECK_CATEGORY_DESIGNATOR(designator);
1634         des = XCHAR(designator);
1635         CHECK_CHAR(character);
1636         ch = XCHAR(character);
1637         ctbl = check_category_table(category_table, Vstandard_category_table);
1638         return check_category_char(ch, ctbl, des, 0) ? Qt : Qnil;
1639 }
1640
1641 DEFUN("category-table", Fcategory_table, 0, 1, 0,       /*
1642 Return BUFFER's current category table.
1643 BUFFER defaults to the current buffer.
1644 */
1645       (buffer))
1646 {
1647         return decode_buffer(buffer, 0)->category_table;
1648 }
1649
1650 DEFUN("standard-category-table", Fstandard_category_table, 0, 0, 0,     /*
1651 Return the standard category table.
1652 This is the one used for new buffers.
1653 */
1654       ())
1655 {
1656         return Vstandard_category_table;
1657 }
1658
1659 DEFUN("copy-category-table", Fcopy_category_table, 0, 1, 0,     /*
1660 Return a new category table which is a copy of CATEGORY-TABLE.
1661 CATEGORY-TABLE defaults to the standard category table.
1662 */
1663       (category_table))
1664 {
1665         if (NILP(Vstandard_category_table))
1666                 return Fmake_char_table(Qcategory);
1667
1668         category_table =
1669             check_category_table(category_table, Vstandard_category_table);
1670         return Fcopy_char_table(category_table);
1671 }
1672
1673 DEFUN("set-category-table", Fset_category_table, 1, 2, 0,       /*
1674 Select CATEGORY-TABLE as the new category table for BUFFER.
1675 BUFFER defaults to the current buffer if omitted.
1676 */
1677       (category_table, buffer))
1678 {
1679         struct buffer *buf = decode_buffer(buffer, 0);
1680         category_table = check_category_table(category_table, Qnil);
1681         buf->category_table = category_table;
1682         /* Indicate that this buffer now has a specified category table.  */
1683         buf->local_var_flags |= XINT(buffer_local_flags.category_table);
1684         return category_table;
1685 }
1686
1687 DEFUN("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
1688 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
1689 */
1690       (object))
1691 {
1692         return CATEGORY_DESIGNATORP(object) ? Qt : Qnil;
1693 }
1694
1695 DEFUN("category-table-value-p", Fcategory_table_value_p, 1, 1, 0,       /*
1696 Return t if OBJECT is a category table value.
1697 Valid values are nil or a bit vector of size 95.
1698 */
1699       (object))
1700 {
1701         return CATEGORY_TABLE_VALUEP(object) ? Qt : Qnil;
1702 }
1703
1704 #define CATEGORYP(x) \
1705   (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
1706
1707 #define CATEGORY_SET(c)                                         \
1708   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
1709
1710 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
1711    The faster version of `!NILP (Faref (category_set, category))'.  */
1712 #define CATEGORY_MEMBER(category, category_set)                 \
1713   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
1714
1715 /* Return 1 if there is a word boundary between two word-constituent
1716    characters C1 and C2 if they appear in this order, else return 0.
1717    Use the macro WORD_BOUNDARY_P instead of calling this function
1718    directly.  */
1719
1720 int word_boundary_p(Emchar c1, Emchar c2);
1721 int word_boundary_p(Emchar c1, Emchar c2)
1722 {
1723         Lisp_Object category_set1, category_set2;
1724         Lisp_Object tail;
1725         int default_result;
1726
1727 #if 0
1728         if (COMPOSITE_CHAR_P(c1))
1729                 c1 = cmpchar_component(c1, 0, 1);
1730         if (COMPOSITE_CHAR_P(c2))
1731                 c2 = cmpchar_component(c2, 0, 1);
1732 #endif
1733
1734         if (EQ(CHAR_CHARSET(c1), CHAR_CHARSET(c2))) {
1735                 tail = Vword_separating_categories;
1736                 default_result = 0;
1737         } else {
1738                 tail = Vword_combining_categories;
1739                 default_result = 1;
1740         }
1741
1742         category_set1 = CATEGORY_SET(c1);
1743         if (NILP(category_set1))
1744                 return default_result;
1745         category_set2 = CATEGORY_SET(c2);
1746         if (NILP(category_set2))
1747                 return default_result;
1748
1749         for (; CONSP(tail); tail = XCONS(tail)->cdr) {
1750                 Lisp_Object elt = XCONS(tail)->car;
1751
1752                 if (CONSP(elt)
1753                     && CATEGORYP(XCONS(elt)->car)
1754                     && CATEGORYP(XCONS(elt)->cdr)
1755                     && CATEGORY_MEMBER(XCHAR(XCONS(elt)->car), category_set1)
1756                     && CATEGORY_MEMBER(XCHAR(XCONS(elt)->cdr), category_set2))
1757                         return !default_result;
1758         }
1759         return default_result;
1760 }
1761 #endif                          /* MULE */
1762 \f
1763 void syms_of_chartab(void)
1764 {
1765         INIT_LRECORD_IMPLEMENTATION(char_table);
1766
1767 #ifdef MULE
1768         INIT_LRECORD_IMPLEMENTATION(char_table_entry);
1769
1770         defsymbol(&Qcategory_table_p, "category-table-p");
1771         defsymbol(&Qcategory_designator_p, "category-designator-p");
1772         defsymbol(&Qcategory_table_value_p, "category-table-value-p");
1773 #endif                          /* MULE */
1774
1775         defsymbol(&Qchar_table, "char-table");
1776         defsymbol(&Qchar_tablep, "char-table-p");
1777
1778         DEFSUBR(Fchar_table_p);
1779         DEFSUBR(Fchar_table_type_list);
1780         DEFSUBR(Fvalid_char_table_type_p);
1781         DEFSUBR(Fchar_table_type);
1782         DEFSUBR(Freset_char_table);
1783         DEFSUBR(Fmake_char_table);
1784         DEFSUBR(Fcopy_char_table);
1785         DEFSUBR(Fget_char_table);
1786         DEFSUBR(Fget_range_char_table);
1787         DEFSUBR(Fvalid_char_table_value_p);
1788         DEFSUBR(Fcheck_valid_char_table_value);
1789         DEFSUBR(Fput_char_table);
1790         DEFSUBR(Fmap_char_table);
1791
1792 #ifdef MULE
1793         DEFSUBR(Fcategory_table_p);
1794         DEFSUBR(Fcategory_table);
1795         DEFSUBR(Fstandard_category_table);
1796         DEFSUBR(Fcopy_category_table);
1797         DEFSUBR(Fset_category_table);
1798         DEFSUBR(Fcheck_category_at);
1799         DEFSUBR(Fchar_in_category_p);
1800         DEFSUBR(Fcategory_designator_p);
1801         DEFSUBR(Fcategory_table_value_p);
1802 #endif                          /* MULE */
1803
1804 }
1805
1806 void vars_of_chartab(void)
1807 {
1808         /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
1809         Vall_syntax_tables = Qnil;
1810         dump_add_weak_object_chain(&Vall_syntax_tables);
1811 }
1812
1813 void structure_type_create_chartab(void)
1814 {
1815         struct structure_type *st;
1816
1817         st = define_structure_type(Qchar_table, 0, chartab_instantiate);
1818
1819         define_structure_type_keyword(st, Qtype, chartab_type_validate);
1820         define_structure_type_keyword(st, Qdata, chartab_data_validate);
1821 }
1822
1823 void complex_vars_of_chartab(void)
1824 {
1825 #ifdef MULE
1826         /* Set this now, so first buffer creation can refer to it. */
1827         /* Make it nil before calling copy-category-table
1828            so that copy-category-table will know not to try to copy from garbage */
1829         Vstandard_category_table = Qnil;
1830         Vstandard_category_table = Fcopy_category_table(Qnil);
1831         staticpro(&Vstandard_category_table);
1832
1833         DEFVAR_LISP("word-combining-categories", &Vword_combining_categories    /*
1834 List of pair (cons) of categories to determine word boundary.
1835
1836 Emacs treats a sequence of word constituent characters as a single
1837 word (i.e. finds no word boundary between them) iff they belongs to
1838 the same charset.  But, exceptions are allowed in the following cases.
1839
1840 \(1) The case that characters are in different charsets is controlled
1841 by the variable `word-combining-categories'.
1842
1843 Emacs finds no word boundary between characters of different charsets
1844 if they have categories matching some element of this list.
1845
1846 More precisely, if an element of this list is a cons of category CAT1
1847 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1848 C2 which has CAT2, there's no word boundary between C1 and C2.
1849
1850 For instance, to tell that ASCII characters and Latin-1 characters can
1851 form a single word, the element `(?l . ?l)' should be in this list
1852 because both characters have the category `l' (Latin characters).
1853
1854 \(2) The case that character are in the same charset is controlled by
1855 the variable `word-separating-categories'.
1856
1857 Emacs find a word boundary between characters of the same charset
1858 if they have categories matching some element of this list.
1859
1860 More precisely, if an element of this list is a cons of category CAT1
1861 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1862 C2 which has CAT2, there's a word boundary between C1 and C2.
1863
1864 For instance, to tell that there's a word boundary between Japanese
1865 Hiragana and Japanese Kanji (both are in the same charset), the
1866 element `(?H . ?C) should be in this list.
1867                                                                                  */ );
1868
1869         Vword_combining_categories = Qnil;
1870
1871         DEFVAR_LISP("word-separating-categories", &Vword_separating_categories  /*
1872 List of pair (cons) of categories to determine word boundary.
1873 See the documentation of the variable `word-combining-categories'.
1874                                                                                  */ );
1875
1876         Vword_separating_categories = Qnil;
1877 #endif                          /* MULE */
1878 }