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