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