src/chartab.c

   1 /* XEmacs routines to deal with char tables.
   2    Copyright (C) 1992, 1995 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Sun Microsystems, Inc.
   4    Copyright (C) 1995, 1996 Ben Wing.
   5    Copyright (C) 1995, 1997, 1999 Electrotechnical Laboratory, JAPAN.
   6    Licensed to the Free Software Foundation.
   7    Copyright (C) 1999,2000,2001 MORIOKA Tomohiko
   8
   9 This file is part of XEmacs.
  10
  11 XEmacs is free software; you can redistribute it and/or modify it
  12 under the terms of the GNU General Public License as published by the
  13 Free Software Foundation; either version 2, or (at your option) any
  14 later version.
  15
  16 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  17 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  18 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  19 for more details.
  20
  21 You should have received a copy of the GNU General Public License
  22 along with XEmacs; see the file COPYING.  If not, write to
  23 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 Boston, MA 02111-1307, USA.  */
  25
  26 /* Synched up with: Mule 2.3.  Not synched with FSF.
  27
  28    This file was written independently of the FSF implementation,
  29    and is not compatible. */
  30
  31 /* Authorship:
  32
  33    Ben Wing: wrote, for 19.13 (Mule).  Some category table stuff
  34              loosely based on the original Mule.
  35    Jareth Hein: fixed a couple of bugs in the implementation, and
  36              added regex support for categories with check_category_at
  37  */
  38
  39 #include <config.h>
  40 #include "lisp.h"
  41
  42 #include "buffer.h"
  43 #include "chartab.h"
  44 #include "syntax.h"
  45
  46 #ifdef UTF2000
  47 #include "elhash.h"
  48
  49 Lisp_Object Vutf_2000_version;
  50 #endif /* UTF2000 */
  51
  52 Lisp_Object Qchar_tablep, Qchar_table;
  53
  54 Lisp_Object Vall_syntax_tables;
  55
  56 #ifdef MULE
  57 Lisp_Object Qcategory_table_p;
  58 Lisp_Object Qcategory_designator_p;
  59 Lisp_Object Qcategory_table_value_p;
  60
  61 Lisp_Object Vstandard_category_table;
  62
  63 /* Variables to determine word boundary.  */
  64 Lisp_Object Vword_combining_categories, Vword_separating_categories;
  65 #endif /* MULE */
  66
  67 \f
  68 #ifdef UTF2000
  69
  70 #define BT_UINT8_MIN            0
  71 #define BT_UINT8_MAX    (UCHAR_MAX - 3)
  72 #define BT_UINT8_t      (UCHAR_MAX - 2)
  73 #define BT_UINT8_nil    (UCHAR_MAX - 1)
  74 #define BT_UINT8_unbound UCHAR_MAX
  75
  76 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
  77 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
  78 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
  79 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
  80 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
  81
  82 INLINE_HEADER int
  83 INT_UINT8_P (Lisp_Object obj)
  84 {
  85   if (INTP (obj))
  86     {
  87       int num = XINT (obj);
  88
  89       return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
  90     }
  91   else
  92     return 0;
  93 }
  94
  95 INLINE_HEADER int
  96 UINT8_VALUE_P (Lisp_Object obj)
  97 {
  98   return EQ (obj, Qunbound)
  99     || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
 100 }
 101
 102 INLINE_HEADER unsigned char
 103 UINT8_ENCODE (Lisp_Object obj)
 104 {
 105   if (EQ (obj, Qunbound))
 106     return BT_UINT8_unbound;
 107   else if (EQ (obj, Qnil))
 108     return BT_UINT8_nil;
 109   else if (EQ (obj, Qt))
 110     return BT_UINT8_t;
 111   else
 112     return XINT (obj);
 113 }
 114
 115 INLINE_HEADER Lisp_Object
 116 UINT8_DECODE (unsigned char n)
 117 {
 118   if (n == BT_UINT8_unbound)
 119     return Qunbound;
 120   else if (n == BT_UINT8_nil)
 121     return Qnil;
 122   else if (n == BT_UINT8_t)
 123     return Qt;
 124   else
 125     return make_int (n);
 126 }
 127
 128 static Lisp_Object
 129 mark_uint8_byte_table (Lisp_Object obj)
 130 {
 131   return Qnil;
 132 }
 133
 134 static void
 135 print_uint8_byte_table (Lisp_Object obj,
 136                         Lisp_Object printcharfun, int escapeflag)
 137 {
 138   Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
 139   int i;
 140   struct gcpro gcpro1, gcpro2;
 141   GCPRO2 (obj, printcharfun);
 142
 143   write_c_string ("\n#<uint8-byte-table", printcharfun);
 144   for (i = 0; i < 256; i++)
 145     {
 146       unsigned char n = bte->property[i];
 147       if ( (i & 15) == 0 )
 148         write_c_string ("\n  ", printcharfun);
 149       write_c_string (" ", printcharfun);
 150       if (n == BT_UINT8_unbound)
 151         write_c_string ("void", printcharfun);
 152       else if (n == BT_UINT8_nil)
 153         write_c_string ("nil", printcharfun);
 154       else if (n == BT_UINT8_t)
 155         write_c_string ("t", printcharfun);
 156       else
 157         {
 158           char buf[4];
 159
 160           sprintf (buf, "%hd", n);
 161           write_c_string (buf, printcharfun);
 162         }
 163     }
 164   UNGCPRO;
 165   write_c_string (">", printcharfun);
 166 }
 167
 168 static int
 169 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 170 {
 171   Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
 172   Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
 173   int i;
 174
 175   for (i = 0; i < 256; i++)
 176     if (te1->property[i] != te2->property[i])
 177       return 0;
 178   return 1;
 179 }
 180
 181 static unsigned long
 182 uint8_byte_table_hash (Lisp_Object obj, int depth)
 183 {
 184   Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
 185   int i;
 186   hashcode_t hash = 0;
 187
 188   for (i = 0; i < 256; i++)
 189     hash = HASH2 (hash, te->property[i]);
 190   return hash;
 191 }
 192
 193 static const struct lrecord_description uint8_byte_table_description[] = {
 194   { XD_END }
 195 };
 196
 197 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
 198                                mark_uint8_byte_table,
 199                                print_uint8_byte_table,
 200                                0, uint8_byte_table_equal,
 201                                uint8_byte_table_hash,
 202                                uint8_byte_table_description,
 203                                Lisp_Uint8_Byte_Table);
 204
 205 static Lisp_Object
 206 make_uint8_byte_table (unsigned char initval)
 207 {
 208   Lisp_Object obj;
 209   int i;
 210   Lisp_Uint8_Byte_Table *cte;
 211
 212   cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
 213                              &lrecord_uint8_byte_table);
 214
 215   for (i = 0; i < 256; i++)
 216     cte->property[i] = initval;
 217
 218   XSETUINT8_BYTE_TABLE (obj, cte);
 219   return obj;
 220 }
 221
 222 static Lisp_Object
 223 copy_uint8_byte_table (Lisp_Object entry)
 224 {
 225   Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
 226   Lisp_Object obj;
 227   int i;
 228   Lisp_Uint8_Byte_Table *ctenew
 229     = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
 230                            &lrecord_uint8_byte_table);
 231
 232   for (i = 0; i < 256; i++)
 233     {
 234       ctenew->property[i] = cte->property[i];
 235     }
 236
 237   XSETUINT8_BYTE_TABLE (obj, ctenew);
 238   return obj;
 239 }
 240
 241 static int
 242 uint8_byte_table_same_value_p (Lisp_Object obj)
 243 {
 244   Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
 245   unsigned char v0 = bte->property[0];
 246   int i;
 247
 248   for (i = 1; i < 256; i++)
 249     {
 250       if (bte->property[i] != v0)
 251         return 0;
 252     }
 253   return -1;
 254 }
 255
 256 static int
 257 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place,
 258                            int (*fn) (struct chartab_range *range,
 259                                       Lisp_Object val, void *arg),
 260                            void *arg)
 261 {
 262   struct chartab_range rainj;
 263   int i, retval;
 264   int unit = 1 << (8 * place);
 265   Emchar c = ofs;
 266   Emchar c1;
 267
 268   rainj.type = CHARTAB_RANGE_CHAR;
 269
 270   for (i = 0, retval = 0; i < 256 && retval == 0; i++)
 271     {
 272       if (ct->property[i] != BT_UINT8_unbound)
 273         {
 274           c1 = c + unit;
 275           for (; c < c1 && retval == 0; c++)
 276             {
 277               rainj.ch = c;
 278               retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
 279             }
 280         }
 281       else
 282         c += unit;
 283     }
 284   return retval;
 285 }
 286
 287 #define BT_UINT16_MIN           0
 288 #define BT_UINT16_MAX    (USHRT_MAX - 3)
 289 #define BT_UINT16_t      (USHRT_MAX - 2)
 290 #define BT_UINT16_nil    (USHRT_MAX - 1)
 291 #define BT_UINT16_unbound USHRT_MAX
 292
 293 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
 294 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
 295 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
 296 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
 297
 298 INLINE_HEADER int
 299 INT_UINT16_P (Lisp_Object obj)
 300 {
 301   if (INTP (obj))
 302     {
 303       int num = XINT (obj);
 304
 305       return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
 306     }
 307   else
 308     return 0;
 309 }
 310
 311 INLINE_HEADER int
 312 UINT16_VALUE_P (Lisp_Object obj)
 313 {
 314   return EQ (obj, Qunbound)
 315     || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
 316 }
 317
 318 INLINE_HEADER unsigned short
 319 UINT16_ENCODE (Lisp_Object obj)
 320 {
 321   if (EQ (obj, Qunbound))
 322     return BT_UINT16_unbound;
 323   else if (EQ (obj, Qnil))
 324     return BT_UINT16_nil;
 325   else if (EQ (obj, Qt))
 326     return BT_UINT16_t;
 327   else
 328     return XINT (obj);
 329 }
 330
 331 INLINE_HEADER Lisp_Object
 332 UINT16_DECODE (unsigned short n)
 333 {
 334   if (n == BT_UINT16_unbound)
 335     return Qunbound;
 336   else if (n == BT_UINT16_nil)
 337     return Qnil;
 338   else if (n == BT_UINT16_t)
 339     return Qt;
 340   else
 341     return make_int (n);
 342 }
 343
 344 INLINE_HEADER unsigned short
 345 UINT8_TO_UINT16 (unsigned char n)
 346 {
 347   if (n == BT_UINT8_unbound)
 348     return BT_UINT16_unbound;
 349   else if (n == BT_UINT8_nil)
 350     return BT_UINT16_nil;
 351   else if (n == BT_UINT8_t)
 352     return BT_UINT16_t;
 353   else
 354     return n;
 355 }
 356
 357 static Lisp_Object
 358 mark_uint16_byte_table (Lisp_Object obj)
 359 {
 360   return Qnil;
 361 }
 362
 363 static void
 364 print_uint16_byte_table (Lisp_Object obj,
 365                          Lisp_Object printcharfun, int escapeflag)
 366 {
 367   Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
 368   int i;
 369   struct gcpro gcpro1, gcpro2;
 370   GCPRO2 (obj, printcharfun);
 371
 372   write_c_string ("\n#<uint16-byte-table", printcharfun);
 373   for (i = 0; i < 256; i++)
 374     {
 375       unsigned short n = bte->property[i];
 376       if ( (i & 15) == 0 )
 377         write_c_string ("\n  ", printcharfun);
 378       write_c_string (" ", printcharfun);
 379       if (n == BT_UINT16_unbound)
 380         write_c_string ("void", printcharfun);
 381       else if (n == BT_UINT16_nil)
 382         write_c_string ("nil", printcharfun);
 383       else if (n == BT_UINT16_t)
 384         write_c_string ("t", printcharfun);
 385       else
 386         {
 387           char buf[7];
 388
 389           sprintf (buf, "%hd", n);
 390           write_c_string (buf, printcharfun);
 391         }
 392     }
 393   UNGCPRO;
 394   write_c_string (">", printcharfun);
 395 }
 396
 397 static int
 398 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 399 {
 400   Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
 401   Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
 402   int i;
 403
 404   for (i = 0; i < 256; i++)
 405     if (te1->property[i] != te2->property[i])
 406       return 0;
 407   return 1;
 408 }
 409
 410 static unsigned long
 411 uint16_byte_table_hash (Lisp_Object obj, int depth)
 412 {
 413   Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
 414   int i;
 415   hashcode_t hash = 0;
 416
 417   for (i = 0; i < 256; i++)
 418     hash = HASH2 (hash, te->property[i]);
 419   return hash;
 420 }
 421
 422 static const struct lrecord_description uint16_byte_table_description[] = {
 423   { XD_END }
 424 };
 425
 426 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
 427                                mark_uint16_byte_table,
 428                                print_uint16_byte_table,
 429                                0, uint16_byte_table_equal,
 430                                uint16_byte_table_hash,
 431                                uint16_byte_table_description,
 432                                Lisp_Uint16_Byte_Table);
 433
 434 static Lisp_Object
 435 make_uint16_byte_table (unsigned short initval)
 436 {
 437   Lisp_Object obj;
 438   int i;
 439   Lisp_Uint16_Byte_Table *cte;
 440
 441   cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
 442                              &lrecord_uint16_byte_table);
 443
 444   for (i = 0; i < 256; i++)
 445     cte->property[i] = initval;
 446
 447   XSETUINT16_BYTE_TABLE (obj, cte);
 448   return obj;
 449 }
 450
 451 static Lisp_Object
 452 copy_uint16_byte_table (Lisp_Object entry)
 453 {
 454   Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
 455   Lisp_Object obj;
 456   int i;
 457   Lisp_Uint16_Byte_Table *ctenew
 458     = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
 459                            &lrecord_uint16_byte_table);
 460
 461   for (i = 0; i < 256; i++)
 462     {
 463       ctenew->property[i] = cte->property[i];
 464     }
 465
 466   XSETUINT16_BYTE_TABLE (obj, ctenew);
 467   return obj;
 468 }
 469
 470 static Lisp_Object
 471 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
 472 {
 473   Lisp_Object obj;
 474   int i;
 475   Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
 476   Lisp_Uint16_Byte_Table* cte;
 477
 478   cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
 479                              &lrecord_uint16_byte_table);
 480   for (i = 0; i < 256; i++)
 481     {
 482       cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
 483     }
 484   XSETUINT16_BYTE_TABLE (obj, cte);
 485   return obj;
 486 }
 487
 488 static int
 489 uint16_byte_table_same_value_p (Lisp_Object obj)
 490 {
 491   Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
 492   unsigned short v0 = bte->property[0];
 493   int i;
 494
 495   for (i = 1; i < 256; i++)
 496     {
 497       if (bte->property[i] != v0)
 498         return 0;
 499     }
 500   return -1;
 501 }
 502
 503 static int
 504 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place,
 505                             int (*fn) (struct chartab_range *range,
 506                                        Lisp_Object val, void *arg),
 507                             void *arg)
 508 {
 509   struct chartab_range rainj;
 510   int i, retval;
 511   int unit = 1 << (8 * place);
 512   Emchar c = ofs;
 513   Emchar c1;
 514
 515   rainj.type = CHARTAB_RANGE_CHAR;
 516
 517   for (i = 0, retval = 0; i < 256 && retval == 0; i++)
 518     {
 519       if (ct->property[i] != BT_UINT16_unbound)
 520         {
 521           c1 = c + unit;
 522           for (; c < c1 && retval == 0; c++)
 523             {
 524               rainj.ch = c;
 525               retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
 526             }
 527         }
 528       else
 529         c += unit;
 530     }
 531   return retval;
 532 }
 533
 534
 535 static Lisp_Object
 536 mark_byte_table (Lisp_Object obj)
 537 {
 538   Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
 539   int i;
 540
 541   for (i = 0; i < 256; i++)
 542     {
 543       mark_object (cte->property[i]);
 544     }
 545   return Qnil;
 546 }
 547
 548 static void
 549 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 550 {
 551   Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
 552   int i;
 553   struct gcpro gcpro1, gcpro2;
 554   GCPRO2 (obj, printcharfun);
 555
 556   write_c_string ("\n#<byte-table", printcharfun);
 557   for (i = 0; i < 256; i++)
 558     {
 559       Lisp_Object elt = bte->property[i];
 560       if ( (i & 15) == 0 )
 561         write_c_string ("\n  ", printcharfun);
 562       write_c_string (" ", printcharfun);
 563       if (EQ (elt, Qunbound))
 564         write_c_string ("void", printcharfun);
 565       else
 566         print_internal (elt, printcharfun, escapeflag);
 567     }
 568   UNGCPRO;
 569   write_c_string (">", printcharfun);
 570 }
 571
 572 static int
 573 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
 574 {
 575   Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
 576   Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
 577   int i;
 578
 579   for (i = 0; i < 256; i++)
 580     if (BYTE_TABLE_P (cte1->property[i]))
 581       {
 582         if (BYTE_TABLE_P (cte2->property[i]))
 583           {
 584             if (!byte_table_equal (cte1->property[i],
 585                                    cte2->property[i], depth + 1))
 586               return 0;
 587           }
 588         else
 589           return 0;
 590       }
 591     else
 592       if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
 593         return 0;
 594   return 1;
 595 }
 596
 597 static unsigned long
 598 byte_table_hash (Lisp_Object obj, int depth)
 599 {
 600   Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
 601
 602   return internal_array_hash (cte->property, 256, depth);
 603 }
 604
 605 static const struct lrecord_description byte_table_description[] = {
 606   { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
 607   { XD_END }
 608 };
 609
 610 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
 611                                mark_byte_table,
 612                                print_byte_table,
 613                                0, byte_table_equal,
 614                                byte_table_hash,
 615                                byte_table_description,
 616                                Lisp_Byte_Table);
 617
 618 static Lisp_Object
 619 make_byte_table (Lisp_Object initval)
 620 {
 621   Lisp_Object obj;
 622   int i;
 623   Lisp_Byte_Table *cte;
 624
 625   cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
 626
 627   for (i = 0; i < 256; i++)
 628     cte->property[i] = initval;
 629
 630   XSETBYTE_TABLE (obj, cte);
 631   return obj;
 632 }
 633
 634 static Lisp_Object
 635 copy_byte_table (Lisp_Object entry)
 636 {
 637   Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
 638   Lisp_Object obj;
 639   int i;
 640   Lisp_Byte_Table *ctnew
 641     = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
 642
 643   for (i = 0; i < 256; i++)
 644     {
 645       if (UINT8_BYTE_TABLE_P (cte->property[i]))
 646         {
 647           ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
 648         }
 649       else if (UINT16_BYTE_TABLE_P (cte->property[i]))
 650         {
 651           ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
 652         }
 653       else if (BYTE_TABLE_P (cte->property[i]))
 654         {
 655           ctnew->property[i] = copy_byte_table (cte->property[i]);
 656         }
 657       else
 658         ctnew->property[i] = cte->property[i];
 659     }
 660
 661   XSETBYTE_TABLE (obj, ctnew);
 662   return obj;
 663 }
 664
 665 static int
 666 byte_table_same_value_p (Lisp_Object obj)
 667 {
 668   Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
 669   Lisp_Object v0 = bte->property[0];
 670   int i;
 671
 672   for (i = 1; i < 256; i++)
 673     {
 674       if (!internal_equal (bte->property[i], v0, 0))
 675         return 0;
 676     }
 677   return -1;
 678 }
 679
 680 static int
 681 map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place,
 682                      int (*fn) (struct chartab_range *range,
 683                                 Lisp_Object val, void *arg),
 684                      void *arg)
 685 {
 686   int i, retval;
 687   Lisp_Object v;
 688   int unit = 1 << (8 * place);
 689   Emchar c = ofs;
 690
 691   for (i = 0, retval = 0; i < 256 && retval == 0; i++)
 692     {
 693       v = ct->property[i];
 694       if (UINT8_BYTE_TABLE_P (v))
 695         {
 696           retval
 697             = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v),
 698                                          c, place - 1, fn, arg);
 699           c += unit;
 700         }
 701       else if (UINT16_BYTE_TABLE_P (v))
 702         {
 703           retval
 704             = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v),
 705                                           c, place - 1, fn, arg);
 706           c += unit;
 707         }
 708       else if (BYTE_TABLE_P (v))
 709         {
 710           retval = map_over_byte_table (XBYTE_TABLE(v),
 711                                         c, place - 1, fn, arg);
 712           c += unit;
 713         }
 714       else if (!UNBOUNDP (v))
 715         {
 716           struct chartab_range rainj;
 717           Emchar c1 = c + unit;
 718
 719           rainj.type = CHARTAB_RANGE_CHAR;
 720
 721           for (; c < c1 && retval == 0; c++)
 722             {
 723               rainj.ch = c;
 724               retval = (fn) (&rainj, v, arg);
 725             }
 726         }
 727       else
 728         c += unit;
 729     }
 730   return retval;
 731 }
 732
 733
 734 Lisp_Object
 735 get_byte_table (Lisp_Object table, unsigned char idx)
 736 {
 737   if (UINT8_BYTE_TABLE_P (table))
 738     return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
 739   else if (UINT16_BYTE_TABLE_P (table))
 740     return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
 741   else if (BYTE_TABLE_P (table))
 742     return XBYTE_TABLE(table)->property[idx];
 743   else
 744     return table;
 745 }
 746
 747 Lisp_Object
 748 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
 749 {
 750   if (UINT8_BYTE_TABLE_P (table))
 751     {
 752       if (UINT8_VALUE_P (value))
 753         {
 754           XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
 755           if (!UINT8_BYTE_TABLE_P (value) &&
 756               !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
 757               && uint8_byte_table_same_value_p (table))
 758             {
 759               return value;
 760             }
 761         }
 762       else if (UINT16_VALUE_P (value))
 763         {
 764           Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
 765
 766           XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
 767           return new;
 768         }
 769       else
 770         {
 771           Lisp_Object new = make_byte_table (Qnil);
 772           int i;
 773
 774           for (i = 0; i < 256; i++)
 775             {
 776               XBYTE_TABLE(new)->property[i]
 777                 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
 778             }
 779           XBYTE_TABLE(new)->property[idx] = value;
 780           return new;
 781         }
 782     }
 783   else if (UINT16_BYTE_TABLE_P (table))
 784     {
 785       if (UINT16_VALUE_P (value))
 786         {
 787           XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
 788           if (!UINT8_BYTE_TABLE_P (value) &&
 789               !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
 790               && uint16_byte_table_same_value_p (table))
 791             {
 792               return value;
 793             }
 794         }
 795       else
 796         {
 797           Lisp_Object new = make_byte_table (Qnil);
 798           int i;
 799
 800           for (i = 0; i < 256; i++)
 801             {
 802               XBYTE_TABLE(new)->property[i]
 803                 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
 804             }
 805           XBYTE_TABLE(new)->property[idx] = value;
 806           return new;
 807         }
 808     }
 809   else if (BYTE_TABLE_P (table))
 810     {
 811       XBYTE_TABLE(table)->property[idx] = value;
 812       if (!UINT8_BYTE_TABLE_P (value) &&
 813           !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
 814           && byte_table_same_value_p (table))
 815         {
 816           return value;
 817         }
 818     }
 819   else if (!internal_equal (table, value, 0))
 820     {
 821       if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
 822         {
 823           table = make_uint8_byte_table (UINT8_ENCODE (table));
 824           XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
 825         }
 826       else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
 827         {
 828           table = make_uint16_byte_table (UINT16_ENCODE (table));
 829           XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
 830         }
 831       else
 832         {
 833           table = make_byte_table (table);
 834           XBYTE_TABLE(table)->property[idx] = value;
 835         }
 836     }
 837   return table;
 838 }
 839
 840
 841 Lisp_Object
 842 make_char_id_table (Lisp_Object initval)
 843 {
 844   Lisp_Object obj;
 845   obj = Fmake_char_table (Qgeneric);
 846   fill_char_table (XCHAR_TABLE (obj), initval);
 847   return obj;
 848 }
 849
 850
 851 Lisp_Object Vcharacter_composition_table;
 852 Lisp_Object Vcharacter_variant_table;
 853
 854
 855 Lisp_Object Q_decomposition;
 856 Lisp_Object Qto_ucs;
 857 Lisp_Object Q_ucs;
 858 Lisp_Object Qcompat;
 859 Lisp_Object Qisolated;
 860 Lisp_Object Qinitial;
 861 Lisp_Object Qmedial;
 862 Lisp_Object Qfinal;
 863 Lisp_Object Qvertical;
 864 Lisp_Object QnoBreak;
 865 Lisp_Object Qfraction;
 866 Lisp_Object Qsuper;
 867 Lisp_Object Qsub;
 868 Lisp_Object Qcircle;
 869 Lisp_Object Qsquare;
 870 Lisp_Object Qwide;
 871 Lisp_Object Qnarrow;
 872 Lisp_Object Qsmall;
 873 Lisp_Object Qfont;
 874
 875 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
 876
 877 Emchar
 878 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
 879 {
 880   if (INTP (v))
 881     return XINT (v);
 882   if (CHARP (v))
 883     return XCHAR (v);
 884   else if (EQ (v, Qcompat))
 885     return -1;
 886   else if (EQ (v, Qisolated))
 887     return -2;
 888   else if (EQ (v, Qinitial))
 889     return -3;
 890   else if (EQ (v, Qmedial))
 891     return -4;
 892   else if (EQ (v, Qfinal))
 893     return -5;
 894   else if (EQ (v, Qvertical))
 895     return -6;
 896   else if (EQ (v, QnoBreak))
 897     return -7;
 898   else if (EQ (v, Qfraction))
 899     return -8;
 900   else if (EQ (v, Qsuper))
 901     return -9;
 902   else if (EQ (v, Qsub))
 903     return -10;
 904   else if (EQ (v, Qcircle))
 905     return -11;
 906   else if (EQ (v, Qsquare))
 907     return -12;
 908   else if (EQ (v, Qwide))
 909     return -13;
 910   else if (EQ (v, Qnarrow))
 911     return -14;
 912   else if (EQ (v, Qsmall))
 913     return -15;
 914   else if (EQ (v, Qfont))
 915     return -16;
 916   else
 917     signal_simple_error (err_msg, err_arg);
 918 }
 919
 920 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
 921 Return character corresponding with list.
 922 */
 923        (list))
 924 {
 925   Lisp_Object table = Vcharacter_composition_table;
 926   Lisp_Object rest = list;
 927
 928   while (CONSP (rest))
 929     {
 930       Lisp_Object v = Fcar (rest);
 931       Lisp_Object ret;
 932       Emchar c = to_char_id (v, "Invalid value for composition", list);
 933
 934       ret = get_char_id_table (XCHAR_TABLE(table), c);
 935
 936       rest = Fcdr (rest);
 937       if (NILP (rest))
 938         {
 939           if (!CHAR_TABLEP (ret))
 940             return ret;
 941           else
 942             return Qt;
 943         }
 944       else if (!CONSP (rest))
 945         break;
 946       else if (CHAR_TABLEP (ret))
 947         table = ret;
 948       else
 949         signal_simple_error ("Invalid table is found with", list);
 950     }
 951   signal_simple_error ("Invalid value for composition", list);
 952 }
 953
 954 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
 955 Return variants of CHARACTER.
 956 */
 957        (character))
 958 {
 959   CHECK_CHAR (character);
 960   return Fcopy_list (get_char_id_table
 961                      (XCHAR_TABLE(Vcharacter_variant_table),
 962                       XCHAR (character)));
 963 }
 964
 965 #endif
 966
 967 \f
 968 /* A char table maps from ranges of characters to values.
 969
 970    Implementing a general data structure that maps from arbitrary
 971    ranges of numbers to values is tricky to do efficiently.  As it
 972    happens, it should suffice (and is usually more convenient, anyway)
 973    when dealing with characters to restrict the sorts of ranges that
 974    can be assigned values, as follows:
 975
 976    1) All characters.
 977    2) All characters in a charset.
 978    3) All characters in a particular row of a charset, where a "row"
 979       means all characters with the same first byte.
 980    4) A particular character in a charset.
 981
 982    We use char tables to generalize the 256-element vectors now
 983    littering the Emacs code.
 984
 985    Possible uses (all should be converted at some point):
 986
 987    1) category tables
 988    2) syntax tables
 989    3) display tables
 990    4) case tables
 991    5) keyboard-translate-table?
 992
 993    We provide an
 994    abstract type to generalize the Emacs vectors and Mule
 995    vectors-of-vectors goo.
 996    */
 997
 998 /************************************************************************/
 999 /*                         Char Table object                            */
1000 /************************************************************************/
1001
1002 #if defined(MULE)&&!defined(UTF2000)
1003
1004 static Lisp_Object
1005 mark_char_table_entry (Lisp_Object obj)
1006 {
1007   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1008   int i;
1009
1010   for (i = 0; i < 96; i++)
1011     {
1012       mark_object (cte->level2[i]);
1013     }
1014   return Qnil;
1015 }
1016
1017 static int
1018 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1019 {
1020   Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1021   Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1022   int i;
1023
1024   for (i = 0; i < 96; i++)
1025     if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1026       return 0;
1027
1028   return 1;
1029 }
1030
1031 static unsigned long
1032 char_table_entry_hash (Lisp_Object obj, int depth)
1033 {
1034   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1035
1036   return internal_array_hash (cte->level2, 96, depth);
1037 }
1038
1039 static const struct lrecord_description char_table_entry_description[] = {
1040   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1041   { XD_END }
1042 };
1043
1044 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1045                                mark_char_table_entry, internal_object_printer,
1046                                0, char_table_entry_equal,
1047                                char_table_entry_hash,
1048                                char_table_entry_description,
1049                                Lisp_Char_Table_Entry);
1050 #endif /* MULE */
1051
1052 static Lisp_Object
1053 mark_char_table (Lisp_Object obj)
1054 {
1055   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1056 #ifdef UTF2000
1057
1058   mark_object (ct->table);
1059 #else
1060   int i;
1061
1062   for (i = 0; i < NUM_ASCII_CHARS; i++)
1063     mark_object (ct->ascii[i]);
1064 #ifdef MULE
1065   for (i = 0; i < NUM_LEADING_BYTES; i++)
1066     mark_object (ct->level1[i]);
1067 #endif
1068 #endif
1069 #ifdef UTF2000
1070   return ct->default_value;
1071 #else
1072   return ct->mirror_table;
1073 #endif
1074 }
1075
1076 /* WARNING: All functions of this nature need to be written extremely
1077    carefully to avoid crashes during GC.  Cf. prune_specifiers()
1078    and prune_weak_hash_tables(). */
1079
1080 void
1081 prune_syntax_tables (void)
1082 {
1083   Lisp_Object rest, prev = Qnil;
1084
1085   for (rest = Vall_syntax_tables;
1086        !NILP (rest);
1087        rest = XCHAR_TABLE (rest)->next_table)
1088     {
1089       if (! marked_p (rest))
1090         {
1091           /* This table is garbage.  Remove it from the list. */
1092           if (NILP (prev))
1093             Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1094           else
1095             XCHAR_TABLE (prev)->next_table =
1096               XCHAR_TABLE (rest)->next_table;
1097         }
1098     }
1099 }
1100
1101 static Lisp_Object
1102 char_table_type_to_symbol (enum char_table_type type)
1103 {
1104   switch (type)
1105   {
1106   default: abort();
1107   case CHAR_TABLE_TYPE_GENERIC:  return Qgeneric;
1108   case CHAR_TABLE_TYPE_SYNTAX:   return Qsyntax;
1109   case CHAR_TABLE_TYPE_DISPLAY:  return Qdisplay;
1110   case CHAR_TABLE_TYPE_CHAR:     return Qchar;
1111 #ifdef MULE
1112   case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1113 #endif
1114   }
1115 }
1116
1117 static enum char_table_type
1118 symbol_to_char_table_type (Lisp_Object symbol)
1119 {
1120   CHECK_SYMBOL (symbol);
1121
1122   if (EQ (symbol, Qgeneric))  return CHAR_TABLE_TYPE_GENERIC;
1123   if (EQ (symbol, Qsyntax))   return CHAR_TABLE_TYPE_SYNTAX;
1124   if (EQ (symbol, Qdisplay))  return CHAR_TABLE_TYPE_DISPLAY;
1125   if (EQ (symbol, Qchar))     return CHAR_TABLE_TYPE_CHAR;
1126 #ifdef MULE
1127   if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1128 #endif
1129
1130   signal_simple_error ("Unrecognized char table type", symbol);
1131   return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1132 }
1133
1134 static void
1135 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1136                      Lisp_Object printcharfun)
1137 {
1138   if (first != last)
1139     {
1140       write_c_string (" (", printcharfun);
1141       print_internal (make_char (first), printcharfun, 0);
1142       write_c_string (" ", printcharfun);
1143       print_internal (make_char (last), printcharfun, 0);
1144       write_c_string (") ", printcharfun);
1145     }
1146   else
1147     {
1148       write_c_string (" ", printcharfun);
1149       print_internal (make_char (first), printcharfun, 0);
1150       write_c_string (" ", printcharfun);
1151     }
1152   print_internal (val, printcharfun, 1);
1153 }
1154
1155 #if defined(MULE)&&!defined(UTF2000)
1156
1157 static void
1158 print_chartab_charset_row (Lisp_Object charset,
1159                            int row,
1160                            Lisp_Char_Table_Entry *cte,
1161                            Lisp_Object printcharfun)
1162 {
1163   int i;
1164   Lisp_Object cat = Qunbound;
1165   int first = -1;
1166
1167   for (i = 32; i < 128; i++)
1168     {
1169       Lisp_Object pam = cte->level2[i - 32];
1170
1171       if (first == -1)
1172         {
1173           first = i;
1174           cat = pam;
1175           continue;
1176         }
1177
1178       if (!EQ (cat, pam))
1179         {
1180           if (row == -1)
1181             print_chartab_range (MAKE_CHAR (charset, first, 0),
1182                                  MAKE_CHAR (charset, i - 1, 0),
1183                                  cat, printcharfun);
1184           else
1185             print_chartab_range (MAKE_CHAR (charset, row, first),
1186                                  MAKE_CHAR (charset, row, i - 1),
1187                                  cat, printcharfun);
1188           first = -1;
1189           i--;
1190         }
1191     }
1192
1193   if (first != -1)
1194     {
1195       if (row == -1)
1196         print_chartab_range (MAKE_CHAR (charset, first, 0),
1197                              MAKE_CHAR (charset, i - 1, 0),
1198                              cat, printcharfun);
1199       else
1200         print_chartab_range (MAKE_CHAR (charset, row, first),
1201                              MAKE_CHAR (charset, row, i - 1),
1202                              cat, printcharfun);
1203     }
1204 }
1205
1206 static void
1207 print_chartab_two_byte_charset (Lisp_Object charset,
1208                                 Lisp_Char_Table_Entry *cte,
1209                                 Lisp_Object printcharfun)
1210 {
1211   int i;
1212
1213   for (i = 32; i < 128; i++)
1214     {
1215       Lisp_Object jen = cte->level2[i - 32];
1216
1217       if (!CHAR_TABLE_ENTRYP (jen))
1218         {
1219           char buf[100];
1220
1221           write_c_string (" [", printcharfun);
1222           print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1223           sprintf (buf, " %d] ", i);
1224           write_c_string (buf, printcharfun);
1225           print_internal (jen, printcharfun, 0);
1226         }
1227       else
1228         print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1229                                    printcharfun);
1230     }
1231 }
1232
1233 #endif /* MULE */
1234
1235 static void
1236 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1237 {
1238   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1239 #ifdef UTF2000
1240   int i;
1241   struct gcpro gcpro1, gcpro2;
1242   GCPRO2 (obj, printcharfun);
1243
1244   write_c_string ("#s(char-table ", printcharfun);
1245   write_c_string (" ", printcharfun);
1246   write_c_string (string_data
1247                   (symbol_name
1248                    (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1249                   printcharfun);
1250   write_c_string ("\n ", printcharfun);
1251   print_internal (ct->default_value, printcharfun, escapeflag);
1252   for (i = 0; i < 256; i++)
1253     {
1254       Lisp_Object elt = get_byte_table (ct->table, i);
1255       if (i != 0) write_c_string ("\n  ", printcharfun);
1256       if (EQ (elt, Qunbound))
1257         write_c_string ("void", printcharfun);
1258       else
1259         print_internal (elt, printcharfun, escapeflag);
1260     }
1261   UNGCPRO;
1262 #else /* non UTF2000 */
1263   char buf[200];
1264
1265   sprintf (buf, "#s(char-table type %s data (",
1266            string_data (symbol_name (XSYMBOL
1267                                      (char_table_type_to_symbol (ct->type)))));
1268   write_c_string (buf, printcharfun);
1269
1270   /* Now write out the ASCII/Control-1 stuff. */
1271   {
1272     int i;
1273     int first = -1;
1274     Lisp_Object val = Qunbound;
1275
1276     for (i = 0; i < NUM_ASCII_CHARS; i++)
1277       {
1278         if (first == -1)
1279           {
1280             first = i;
1281             val = ct->ascii[i];
1282             continue;
1283           }
1284
1285         if (!EQ (ct->ascii[i], val))
1286           {
1287             print_chartab_range (first, i - 1, val, printcharfun);
1288             first = -1;
1289             i--;
1290           }
1291       }
1292
1293     if (first != -1)
1294       print_chartab_range (first, i - 1, val, printcharfun);
1295   }
1296
1297 #ifdef MULE
1298   {
1299     Charset_ID i;
1300
1301     for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1302          i++)
1303       {
1304         Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1305         Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1306
1307         if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1308             || i == LEADING_BYTE_CONTROL_1)
1309           continue;
1310         if (!CHAR_TABLE_ENTRYP (ann))
1311           {
1312             write_c_string (" ", printcharfun);
1313             print_internal (XCHARSET_NAME (charset),
1314                             printcharfun, 0);
1315             write_c_string (" ", printcharfun);
1316             print_internal (ann, printcharfun, 0);
1317           }
1318         else
1319           {
1320             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1321             if (XCHARSET_DIMENSION (charset) == 1)
1322               print_chartab_charset_row (charset, -1, cte, printcharfun);
1323             else
1324               print_chartab_two_byte_charset (charset, cte, printcharfun);
1325           }
1326       }
1327   }
1328 #endif /* MULE */
1329 #endif /* non UTF2000 */
1330
1331   write_c_string ("))", printcharfun);
1332 }
1333
1334 static int
1335 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1336 {
1337   Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1338   Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1339   int i;
1340
1341   if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1342     return 0;
1343
1344 #ifdef UTF2000
1345   for (i = 0; i < 256; i++)
1346     {
1347       if (!internal_equal (get_byte_table (ct1->table, i),
1348                            get_byte_table (ct2->table, i), 0))
1349         return 0;
1350     }
1351 #else
1352   for (i = 0; i < NUM_ASCII_CHARS; i++)
1353     if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1354       return 0;
1355
1356 #ifdef MULE
1357   for (i = 0; i < NUM_LEADING_BYTES; i++)
1358     if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1359       return 0;
1360 #endif /* MULE */
1361 #endif /* non UTF2000 */
1362
1363   return 1;
1364 }
1365
1366 static unsigned long
1367 char_table_hash (Lisp_Object obj, int depth)
1368 {
1369   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1370 #ifdef UTF2000
1371     return byte_table_hash (ct->table, depth + 1);
1372 #else
1373   unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1374                                                depth);
1375 #ifdef MULE
1376   hashval = HASH2 (hashval,
1377                    internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1378 #endif /* MULE */
1379   return hashval;
1380 #endif
1381 }
1382
1383 static const struct lrecord_description char_table_description[] = {
1384 #ifdef UTF2000
1385   { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1386   { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1387 #else
1388   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1389 #ifdef MULE
1390   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1391 #endif
1392 #endif
1393 #ifndef UTF2000
1394   { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1395 #endif
1396   { XD_LO_LINK,     offsetof (Lisp_Char_Table, next_table) },
1397   { XD_END }
1398 };
1399
1400 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1401                                mark_char_table, print_char_table, 0,
1402                                char_table_equal, char_table_hash,
1403                                char_table_description,
1404                                Lisp_Char_Table);
1405
1406 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1407 Return non-nil if OBJECT is a char table.
1408
1409 A char table is a table that maps characters (or ranges of characters)
1410 to values.  Char tables are specialized for characters, only allowing
1411 particular sorts of ranges to be assigned values.  Although this
1412 loses in generality, it makes for extremely fast (constant-time)
1413 lookups, and thus is feasible for applications that do an extremely
1414 large number of lookups (e.g. scanning a buffer for a character in
1415 a particular syntax, where a lookup in the syntax table must occur
1416 once per character).
1417
1418 When Mule support exists, the types of ranges that can be assigned
1419 values are
1420
1421 -- all characters
1422 -- an entire charset
1423 -- a single row in a two-octet charset
1424 -- a single character
1425
1426 When Mule support is not present, the types of ranges that can be
1427 assigned values are
1428
1429 -- all characters
1430 -- a single character
1431
1432 To create a char table, use `make-char-table'.
1433 To modify a char table, use `put-char-table' or `remove-char-table'.
1434 To retrieve the value for a particular character, use `get-char-table'.
1435 See also `map-char-table', `clear-char-table', `copy-char-table',
1436 `valid-char-table-type-p', `char-table-type-list',
1437 `valid-char-table-value-p', and `check-char-table-value'.
1438 */
1439        (object))
1440 {
1441   return CHAR_TABLEP (object) ? Qt : Qnil;
1442 }
1443
1444 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1445 Return a list of the recognized char table types.
1446 See `valid-char-table-type-p'.
1447 */
1448        ())
1449 {
1450 #ifdef MULE
1451   return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1452 #else
1453   return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1454 #endif
1455 }
1456
1457 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1458 Return t if TYPE if a recognized char table type.
1459
1460 Each char table type is used for a different purpose and allows different
1461 sorts of values.  The different char table types are
1462
1463 `category'
1464         Used for category tables, which specify the regexp categories
1465         that a character is in.  The valid values are nil or a
1466         bit vector of 95 elements.  Higher-level Lisp functions are
1467         provided for working with category tables.  Currently categories
1468         and category tables only exist when Mule support is present.
1469 `char'
1470         A generalized char table, for mapping from one character to
1471         another.  Used for case tables, syntax matching tables,
1472         `keyboard-translate-table', etc.  The valid values are characters.
1473 `generic'
1474         An even more generalized char table, for mapping from a
1475         character to anything.
1476 `display'
1477         Used for display tables, which specify how a particular character
1478         is to appear when displayed.  #### Not yet implemented.
1479 `syntax'
1480         Used for syntax tables, which specify the syntax of a particular
1481         character.  Higher-level Lisp functions are provided for
1482         working with syntax tables.  The valid values are integers.
1483
1484 */
1485        (type))
1486 {
1487   return (EQ (type, Qchar)     ||
1488 #ifdef MULE
1489           EQ (type, Qcategory) ||
1490 #endif
1491           EQ (type, Qdisplay)  ||
1492           EQ (type, Qgeneric)  ||
1493           EQ (type, Qsyntax)) ? Qt : Qnil;
1494 }
1495
1496 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1497 Return the type of CHAR-TABLE.
1498 See `valid-char-table-type-p'.
1499 */
1500        (char_table))
1501 {
1502   CHECK_CHAR_TABLE (char_table);
1503   return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1504 }
1505
1506 void
1507 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1508 {
1509 #ifdef UTF2000
1510   ct->table = Qunbound;
1511   ct->default_value = value;
1512 #else
1513   int i;
1514
1515   for (i = 0; i < NUM_ASCII_CHARS; i++)
1516     ct->ascii[i] = value;
1517 #ifdef MULE
1518   for (i = 0; i < NUM_LEADING_BYTES; i++)
1519     ct->level1[i] = value;
1520 #endif /* MULE */
1521 #endif
1522
1523 #ifndef UTF2000
1524   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1525     update_syntax_table (ct);
1526 #endif
1527 }
1528
1529 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1530 Reset CHAR-TABLE to its default state.
1531 */
1532        (char_table))
1533 {
1534   Lisp_Char_Table *ct;
1535
1536   CHECK_CHAR_TABLE (char_table);
1537   ct = XCHAR_TABLE (char_table);
1538
1539   switch (ct->type)
1540     {
1541     case CHAR_TABLE_TYPE_CHAR:
1542       fill_char_table (ct, make_char (0));
1543       break;
1544     case CHAR_TABLE_TYPE_DISPLAY:
1545     case CHAR_TABLE_TYPE_GENERIC:
1546 #ifdef MULE
1547     case CHAR_TABLE_TYPE_CATEGORY:
1548 #endif /* MULE */
1549       fill_char_table (ct, Qnil);
1550       break;
1551
1552     case CHAR_TABLE_TYPE_SYNTAX:
1553       fill_char_table (ct, make_int (Sinherit));
1554       break;
1555
1556     default:
1557       abort ();
1558     }
1559
1560   return Qnil;
1561 }
1562
1563 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1564 Return a new, empty char table of type TYPE.
1565 Currently recognized types are 'char, 'category, 'display, 'generic,
1566 and 'syntax.  See `valid-char-table-type-p'.
1567 */
1568        (type))
1569 {
1570   Lisp_Char_Table *ct;
1571   Lisp_Object obj;
1572   enum char_table_type ty = symbol_to_char_table_type (type);
1573
1574   ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1575   ct->type = ty;
1576 #ifndef UTF2000
1577   if (ty == CHAR_TABLE_TYPE_SYNTAX)
1578     {
1579       ct->mirror_table = Fmake_char_table (Qgeneric);
1580       fill_char_table (XCHAR_TABLE (ct->mirror_table),
1581                        make_int (Spunct));
1582     }
1583   else
1584     ct->mirror_table = Qnil;
1585 #endif
1586   ct->next_table = Qnil;
1587   XSETCHAR_TABLE (obj, ct);
1588   if (ty == CHAR_TABLE_TYPE_SYNTAX)
1589     {
1590       ct->next_table = Vall_syntax_tables;
1591       Vall_syntax_tables = obj;
1592     }
1593   Freset_char_table (obj);
1594   return obj;
1595 }
1596
1597 #if defined(MULE)&&!defined(UTF2000)
1598
1599 static Lisp_Object
1600 make_char_table_entry (Lisp_Object initval)
1601 {
1602   Lisp_Object obj;
1603   int i;
1604   Lisp_Char_Table_Entry *cte =
1605     alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1606
1607   for (i = 0; i < 96; i++)
1608     cte->level2[i] = initval;
1609
1610   XSETCHAR_TABLE_ENTRY (obj, cte);
1611   return obj;
1612 }
1613
1614 static Lisp_Object
1615 copy_char_table_entry (Lisp_Object entry)
1616 {
1617   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1618   Lisp_Object obj;
1619   int i;
1620   Lisp_Char_Table_Entry *ctenew =
1621     alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1622
1623   for (i = 0; i < 96; i++)
1624     {
1625       Lisp_Object new = cte->level2[i];
1626       if (CHAR_TABLE_ENTRYP (new))
1627         ctenew->level2[i] = copy_char_table_entry (new);
1628       else
1629         ctenew->level2[i] = new;
1630     }
1631
1632   XSETCHAR_TABLE_ENTRY (obj, ctenew);
1633   return obj;
1634 }
1635
1636 #endif /* MULE */
1637
1638 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1639 Return a new char table which is a copy of CHAR-TABLE.
1640 It will contain the same values for the same characters and ranges
1641 as CHAR-TABLE.  The values will not themselves be copied.
1642 */
1643        (char_table))
1644 {
1645   Lisp_Char_Table *ct, *ctnew;
1646   Lisp_Object obj;
1647 #ifndef UTF2000
1648   int i;
1649 #endif
1650
1651   CHECK_CHAR_TABLE (char_table);
1652   ct = XCHAR_TABLE (char_table);
1653   ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1654   ctnew->type = ct->type;
1655 #ifdef UTF2000
1656   ctnew->default_value = ct->default_value;
1657
1658   if (UINT8_BYTE_TABLE_P (ct->table))
1659     {
1660       ctnew->table = copy_uint8_byte_table (ct->table);
1661     }
1662   else if (UINT16_BYTE_TABLE_P (ct->table))
1663     {
1664       ctnew->table = copy_uint16_byte_table (ct->table);
1665     }
1666   else if (BYTE_TABLE_P (ct->table))
1667     {
1668       ctnew->table = copy_byte_table (ct->table);
1669     }
1670   else if (!UNBOUNDP (ct->table))
1671     ctnew->table = ct->table;
1672 #else /* non UTF2000 */
1673
1674   for (i = 0; i < NUM_ASCII_CHARS; i++)
1675     {
1676       Lisp_Object new = ct->ascii[i];
1677 #ifdef MULE
1678       assert (! (CHAR_TABLE_ENTRYP (new)));
1679 #endif /* MULE */
1680       ctnew->ascii[i] = new;
1681     }
1682
1683 #ifdef MULE
1684
1685   for (i = 0; i < NUM_LEADING_BYTES; i++)
1686     {
1687       Lisp_Object new = ct->level1[i];
1688       if (CHAR_TABLE_ENTRYP (new))
1689         ctnew->level1[i] = copy_char_table_entry (new);
1690       else
1691         ctnew->level1[i] = new;
1692     }
1693
1694 #endif /* MULE */
1695 #endif /* non UTF2000 */
1696
1697 #ifndef UTF2000
1698   if (CHAR_TABLEP (ct->mirror_table))
1699     ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1700   else
1701     ctnew->mirror_table = ct->mirror_table;
1702 #endif
1703   ctnew->next_table = Qnil;
1704   XSETCHAR_TABLE (obj, ctnew);
1705   if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1706     {
1707       ctnew->next_table = Vall_syntax_tables;
1708       Vall_syntax_tables = obj;
1709     }
1710   return obj;
1711 }
1712
1713 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1714 INLINE_HEADER int
1715 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1716 {
1717   switch (XCHARSET_CHARS (ccs))
1718     {
1719     case 94:
1720       return (33 << 8) | 126;
1721     case 96:
1722       return (32 << 8) | 127;
1723 #ifdef UTF2000
1724     case 128:
1725       return (0 << 8) | 127;
1726     case 256:
1727       return (0 << 8) | 255;
1728 #endif
1729     default:
1730       abort ();
1731       return 0;
1732     }
1733 }
1734
1735 #ifndef UTF2000
1736 static
1737 #endif
1738 void
1739 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1740 {
1741   if (EQ (range, Qt))
1742     outrange->type = CHARTAB_RANGE_ALL;
1743 #ifdef UTF2000
1744   else if (EQ (range, Qnil))
1745     outrange->type = CHARTAB_RANGE_DEFAULT;
1746 #endif
1747   else if (CHAR_OR_CHAR_INTP (range))
1748     {
1749       outrange->type = CHARTAB_RANGE_CHAR;
1750       outrange->ch = XCHAR_OR_CHAR_INT (range);
1751     }
1752 #ifndef MULE
1753   else
1754     signal_simple_error ("Range must be t or a character", range);
1755 #else /* MULE */
1756   else if (VECTORP (range))
1757     {
1758       Lisp_Vector *vec = XVECTOR (range);
1759       Lisp_Object *elts = vector_data (vec);
1760       int cell_min, cell_max;
1761
1762       outrange->type = CHARTAB_RANGE_ROW;
1763       outrange->charset = Fget_charset (elts[0]);
1764       CHECK_INT (elts[1]);
1765       outrange->row = XINT (elts[1]);
1766       if (XCHARSET_DIMENSION (outrange->charset) < 2)
1767         signal_simple_error ("Charset in row vector must be multi-byte",
1768                              outrange->charset);
1769       else
1770         {
1771           int ret = XCHARSET_CELL_RANGE (outrange->charset);
1772
1773           cell_min = ret >> 8;
1774           cell_max = ret & 0xFF;
1775         }
1776       if (XCHARSET_DIMENSION (outrange->charset) == 2)
1777         check_int_range (outrange->row, cell_min, cell_max);
1778 #ifdef UTF2000
1779       else if (XCHARSET_DIMENSION (outrange->charset) == 3)
1780         {
1781           check_int_range (outrange->row >> 8  , cell_min, cell_max);
1782           check_int_range (outrange->row & 0xFF, cell_min, cell_max);
1783         }
1784       else if (XCHARSET_DIMENSION (outrange->charset) == 4)
1785         {
1786           check_int_range ( outrange->row >> 16       , cell_min, cell_max);
1787           check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
1788           check_int_range ( outrange->row       & 0xFF, cell_min, cell_max);
1789         }
1790 #endif
1791       else
1792         abort ();
1793     }
1794   else
1795     {
1796       if (!CHARSETP (range) && !SYMBOLP (range))
1797         signal_simple_error
1798           ("Char table range must be t, charset, char, or vector", range);
1799       outrange->type = CHARTAB_RANGE_CHARSET;
1800       outrange->charset = Fget_charset (range);
1801     }
1802 #endif /* MULE */
1803 }
1804
1805 #if defined(MULE)&&!defined(UTF2000)
1806
1807 /* called from CHAR_TABLE_VALUE(). */
1808 Lisp_Object
1809 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
1810                                Emchar c)
1811 {
1812   Lisp_Object val;
1813 #ifdef UTF2000
1814   Lisp_Object charset;
1815 #else
1816   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
1817 #endif
1818   int byte1, byte2;
1819
1820 #ifdef UTF2000
1821   BREAKUP_CHAR (c, charset, byte1, byte2);
1822 #else
1823   BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
1824 #endif
1825   val = ct->level1[leading_byte - MIN_LEADING_BYTE];
1826   if (CHAR_TABLE_ENTRYP (val))
1827     {
1828       Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1829       val = cte->level2[byte1 - 32];
1830       if (CHAR_TABLE_ENTRYP (val))
1831         {
1832           cte = XCHAR_TABLE_ENTRY (val);
1833           assert (byte2 >= 32);
1834           val = cte->level2[byte2 - 32];
1835           assert (!CHAR_TABLE_ENTRYP (val));
1836         }
1837     }
1838
1839   return val;
1840 }
1841
1842 #endif /* MULE */
1843
1844 Lisp_Object
1845 get_char_table (Emchar ch, Lisp_Char_Table *ct)
1846 {
1847 #ifdef UTF2000
1848   return get_char_id_table (ct, ch);
1849 #elif defined(MULE)
1850   {
1851     Lisp_Object charset;
1852     int byte1, byte2;
1853     Lisp_Object val;
1854
1855     BREAKUP_CHAR (ch, charset, byte1, byte2);
1856
1857     if (EQ (charset, Vcharset_ascii))
1858       val = ct->ascii[byte1];
1859     else if (EQ (charset, Vcharset_control_1))
1860       val = ct->ascii[byte1 + 128];
1861     else
1862       {
1863         int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1864         val = ct->level1[lb];
1865         if (CHAR_TABLE_ENTRYP (val))
1866           {
1867             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1868             val = cte->level2[byte1 - 32];
1869             if (CHAR_TABLE_ENTRYP (val))
1870               {
1871                 cte = XCHAR_TABLE_ENTRY (val);
1872                 assert (byte2 >= 32);
1873                 val = cte->level2[byte2 - 32];
1874                 assert (!CHAR_TABLE_ENTRYP (val));
1875               }
1876           }
1877       }
1878
1879     return val;
1880   }
1881 #else /* not MULE */
1882   return ct->ascii[(unsigned char)ch];
1883 #endif /* not MULE */
1884 }
1885
1886
1887 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
1888 Find value for CHARACTER in CHAR-TABLE.
1889 */
1890        (character, char_table))
1891 {
1892   CHECK_CHAR_TABLE (char_table);
1893   CHECK_CHAR_COERCE_INT (character);
1894
1895   return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
1896 }
1897
1898 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
1899 Find value for a range in CHAR-TABLE.
1900 If there is more than one value, return MULTI (defaults to nil).
1901 */
1902        (range, char_table, multi))
1903 {
1904   Lisp_Char_Table *ct;
1905   struct chartab_range rainj;
1906
1907   if (CHAR_OR_CHAR_INTP (range))
1908     return Fget_char_table (range, char_table);
1909   CHECK_CHAR_TABLE (char_table);
1910   ct = XCHAR_TABLE (char_table);
1911
1912   decode_char_table_range (range, &rainj);
1913   switch (rainj.type)
1914     {
1915     case CHARTAB_RANGE_ALL:
1916       {
1917 #ifdef UTF2000
1918         if (UINT8_BYTE_TABLE_P (ct->table))
1919           return multi;
1920         else if (UINT16_BYTE_TABLE_P (ct->table))
1921           return multi;
1922         else if (BYTE_TABLE_P (ct->table))
1923           return multi;
1924         else
1925           return ct->table;
1926 #else /* non UTF2000 */
1927         int i;
1928         Lisp_Object first = ct->ascii[0];
1929
1930         for (i = 1; i < NUM_ASCII_CHARS; i++)
1931           if (!EQ (first, ct->ascii[i]))
1932             return multi;
1933
1934 #ifdef MULE
1935         for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1936              i++)
1937           {
1938             if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
1939                 || i == LEADING_BYTE_ASCII
1940                 || i == LEADING_BYTE_CONTROL_1)
1941               continue;
1942             if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
1943               return multi;
1944           }
1945 #endif /* MULE */
1946
1947         return first;
1948 #endif /* non UTF2000 */
1949       }
1950
1951 #ifdef MULE
1952     case CHARTAB_RANGE_CHARSET:
1953 #ifdef UTF2000
1954       return multi;
1955 #else
1956       if (EQ (rainj.charset, Vcharset_ascii))
1957         {
1958           int i;
1959           Lisp_Object first = ct->ascii[0];
1960
1961           for (i = 1; i < 128; i++)
1962             if (!EQ (first, ct->ascii[i]))
1963               return multi;
1964           return first;
1965         }
1966
1967       if (EQ (rainj.charset, Vcharset_control_1))
1968         {
1969           int i;
1970           Lisp_Object first = ct->ascii[128];
1971
1972           for (i = 129; i < 160; i++)
1973             if (!EQ (first, ct->ascii[i]))
1974               return multi;
1975           return first;
1976         }
1977
1978       {
1979         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
1980                                      MIN_LEADING_BYTE];
1981         if (CHAR_TABLE_ENTRYP (val))
1982           return multi;
1983         return val;
1984       }
1985 #endif
1986
1987     case CHARTAB_RANGE_ROW:
1988 #ifdef UTF2000
1989       return multi;
1990 #else
1991       {
1992         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
1993                                      MIN_LEADING_BYTE];
1994         if (!CHAR_TABLE_ENTRYP (val))
1995           return val;
1996         val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
1997         if (CHAR_TABLE_ENTRYP (val))
1998           return multi;
1999         return val;
2000       }
2001 #endif /* not UTF2000 */
2002 #endif /* not MULE */
2003
2004     default:
2005       abort ();
2006     }
2007
2008   return Qnil; /* not reached */
2009 }
2010
2011 static int
2012 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2013                               Error_behavior errb)
2014 {
2015   switch (type)
2016     {
2017     case CHAR_TABLE_TYPE_SYNTAX:
2018       if (!ERRB_EQ (errb, ERROR_ME))
2019         return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2020                                 && CHAR_OR_CHAR_INTP (XCDR (value)));
2021       if (CONSP (value))
2022         {
2023           Lisp_Object cdr = XCDR (value);
2024           CHECK_INT (XCAR (value));
2025           CHECK_CHAR_COERCE_INT (cdr);
2026          }
2027       else
2028         CHECK_INT (value);
2029       break;
2030
2031 #ifdef MULE
2032     case CHAR_TABLE_TYPE_CATEGORY:
2033       if (!ERRB_EQ (errb, ERROR_ME))
2034         return CATEGORY_TABLE_VALUEP (value);
2035       CHECK_CATEGORY_TABLE_VALUE (value);
2036       break;
2037 #endif /* MULE */
2038
2039     case CHAR_TABLE_TYPE_GENERIC:
2040       return 1;
2041
2042     case CHAR_TABLE_TYPE_DISPLAY:
2043       /* #### fix this */
2044       maybe_signal_simple_error ("Display char tables not yet implemented",
2045                                  value, Qchar_table, errb);
2046       return 0;
2047
2048     case CHAR_TABLE_TYPE_CHAR:
2049       if (!ERRB_EQ (errb, ERROR_ME))
2050         return CHAR_OR_CHAR_INTP (value);
2051       CHECK_CHAR_COERCE_INT (value);
2052       break;
2053
2054     default:
2055       abort ();
2056     }
2057
2058   return 0; /* not reached */
2059 }
2060
2061 static Lisp_Object
2062 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2063 {
2064   switch (type)
2065     {
2066     case CHAR_TABLE_TYPE_SYNTAX:
2067       if (CONSP (value))
2068         {
2069           Lisp_Object car = XCAR (value);
2070           Lisp_Object cdr = XCDR (value);
2071           CHECK_CHAR_COERCE_INT (cdr);
2072           return Fcons (car, cdr);
2073         }
2074       break;
2075     case CHAR_TABLE_TYPE_CHAR:
2076       CHECK_CHAR_COERCE_INT (value);
2077       break;
2078     default:
2079       break;
2080     }
2081   return value;
2082 }
2083
2084 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2085 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2086 */
2087        (value, char_table_type))
2088 {
2089   enum char_table_type type = symbol_to_char_table_type (char_table_type);
2090
2091   return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2092 }
2093
2094 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2095 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2096 */
2097        (value, char_table_type))
2098 {
2099   enum char_table_type type = symbol_to_char_table_type (char_table_type);
2100
2101   check_valid_char_table_value (value, type, ERROR_ME);
2102   return Qnil;
2103 }
2104
2105 /* Assign VAL to all characters in RANGE in char table CT. */
2106
2107 void
2108 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2109                 Lisp_Object val)
2110 {
2111   switch (range->type)
2112     {
2113     case CHARTAB_RANGE_ALL:
2114       /* printf ("put-char-table: range = all\n"); */
2115       fill_char_table (ct, val);
2116       return; /* avoid the duplicate call to update_syntax_table() below,
2117                  since fill_char_table() also did that. */
2118
2119 #ifdef UTF2000
2120     case CHARTAB_RANGE_DEFAULT:
2121       ct->default_value = val;
2122       return;
2123 #endif
2124
2125 #ifdef MULE
2126     case CHARTAB_RANGE_CHARSET:
2127 #ifdef UTF2000
2128       {
2129         Emchar c;
2130         Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2131
2132         /* printf ("put-char-table: range = charset: %d\n",
2133            XCHARSET_LEADING_BYTE (range->charset));
2134         */
2135         if ( CHAR_TABLEP (encoding_table) )
2136           {
2137             for (c = 0; c < 1 << 24; c++)
2138               {
2139                 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2140                                               c)) )
2141                   put_char_id_table_0 (ct, c, val);
2142               }
2143           }
2144         else
2145           {
2146             for (c = 0; c < 1 << 24; c++)
2147               {
2148                 if ( charset_code_point (range->charset, c, 0) >= 0 )
2149                   put_char_id_table_0 (ct, c, val);
2150               }
2151           }
2152       }
2153 #else
2154       if (EQ (range->charset, Vcharset_ascii))
2155         {
2156           int i;
2157           for (i = 0; i < 128; i++)
2158             ct->ascii[i] = val;
2159         }
2160       else if (EQ (range->charset, Vcharset_control_1))
2161         {
2162           int i;
2163           for (i = 128; i < 160; i++)
2164             ct->ascii[i] = val;
2165         }
2166       else
2167         {
2168           int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2169           ct->level1[lb] = val;
2170         }
2171 #endif
2172       break;
2173
2174     case CHARTAB_RANGE_ROW:
2175 #ifdef UTF2000
2176       {
2177         int cell_min, cell_max, i;
2178
2179         i = XCHARSET_CELL_RANGE (range->charset);
2180         cell_min = i >> 8;
2181         cell_max = i & 0xFF;
2182         for (i = cell_min; i <= cell_max; i++)
2183           {
2184             Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2185
2186             if ( charset_code_point (range->charset, ch, 0) >= 0 )
2187               put_char_id_table_0 (ct, ch, val);
2188           }
2189       }
2190 #else
2191       {
2192         Lisp_Char_Table_Entry *cte;
2193         int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2194         /* make sure that there is a separate entry for the row. */
2195         if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2196           ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2197         cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2198         cte->level2[range->row - 32] = val;
2199       }
2200 #endif /* not UTF2000 */
2201       break;
2202 #endif /* MULE */
2203
2204     case CHARTAB_RANGE_CHAR:
2205 #ifdef UTF2000
2206       /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2207       put_char_id_table_0 (ct, range->ch, val);
2208       break;
2209 #elif defined(MULE)
2210       {
2211         Lisp_Object charset;
2212         int byte1, byte2;
2213
2214         BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2215         if (EQ (charset, Vcharset_ascii))
2216           ct->ascii[byte1] = val;
2217         else if (EQ (charset, Vcharset_control_1))
2218           ct->ascii[byte1 + 128] = val;
2219         else
2220           {
2221             Lisp_Char_Table_Entry *cte;
2222             int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2223             /* make sure that there is a separate entry for the row. */
2224             if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2225               ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2226             cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2227             /* now CTE is a char table entry for the charset;
2228                each entry is for a single row (or character of
2229                a one-octet charset). */
2230             if (XCHARSET_DIMENSION (charset) == 1)
2231               cte->level2[byte1 - 32] = val;
2232             else
2233               {
2234                 /* assigning to one character in a two-octet charset. */
2235                 /* make sure that the charset row contains a separate
2236                    entry for each character. */
2237                 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2238                   cte->level2[byte1 - 32] =
2239                     make_char_table_entry (cte->level2[byte1 - 32]);
2240                 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2241                 cte->level2[byte2 - 32] = val;
2242               }
2243           }
2244       }
2245 #else /* not MULE */
2246       ct->ascii[(unsigned char) (range->ch)] = val;
2247       break;
2248 #endif /* not MULE */
2249     }
2250
2251 #ifndef UTF2000
2252   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2253     update_syntax_table (ct);
2254 #endif
2255 }
2256
2257 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2258 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2259
2260 RANGE specifies one or more characters to be affected and should be
2261 one of the following:
2262
2263 -- t (all characters are affected)
2264 -- A charset (only allowed when Mule support is present)
2265 -- A vector of two elements: a two-octet charset and a row number
2266    (only allowed when Mule support is present)
2267 -- A single character
2268
2269 VALUE must be a value appropriate for the type of CHAR-TABLE.
2270 See `valid-char-table-type-p'.
2271 */
2272        (range, value, char_table))
2273 {
2274   Lisp_Char_Table *ct;
2275   struct chartab_range rainj;
2276
2277   CHECK_CHAR_TABLE (char_table);
2278   ct = XCHAR_TABLE (char_table);
2279   check_valid_char_table_value (value, ct->type, ERROR_ME);
2280   decode_char_table_range (range, &rainj);
2281   value = canonicalize_char_table_value (value, ct->type);
2282   put_char_table (ct, &rainj, value);
2283   return Qnil;
2284 }
2285
2286 #ifndef UTF2000
2287 /* Map FN over the ASCII chars in CT. */
2288
2289 static int
2290 map_over_charset_ascii (Lisp_Char_Table *ct,
2291                         int (*fn) (struct chartab_range *range,
2292                                    Lisp_Object val, void *arg),
2293                         void *arg)
2294 {
2295   struct chartab_range rainj;
2296   int i, retval;
2297   int start = 0;
2298 #ifdef MULE
2299   int stop = 128;
2300 #else
2301   int stop = 256;
2302 #endif
2303
2304   rainj.type = CHARTAB_RANGE_CHAR;
2305
2306   for (i = start, retval = 0; i < stop && retval == 0; i++)
2307     {
2308       rainj.ch = (Emchar) i;
2309       retval = (fn) (&rainj, ct->ascii[i], arg);
2310     }
2311
2312   return retval;
2313 }
2314
2315 #ifdef MULE
2316
2317 /* Map FN over the Control-1 chars in CT. */
2318
2319 static int
2320 map_over_charset_control_1 (Lisp_Char_Table *ct,
2321                             int (*fn) (struct chartab_range *range,
2322                                        Lisp_Object val, void *arg),
2323                             void *arg)
2324 {
2325   struct chartab_range rainj;
2326   int i, retval;
2327   int start = 128;
2328   int stop  = start + 32;
2329
2330   rainj.type = CHARTAB_RANGE_CHAR;
2331
2332   for (i = start, retval = 0; i < stop && retval == 0; i++)
2333     {
2334       rainj.ch = (Emchar) (i);
2335       retval = (fn) (&rainj, ct->ascii[i], arg);
2336     }
2337
2338   return retval;
2339 }
2340
2341 /* Map FN over the row ROW of two-byte charset CHARSET.
2342    There must be a separate value for that row in the char table.
2343    CTE specifies the char table entry for CHARSET. */
2344
2345 static int
2346 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2347                       Lisp_Object charset, int row,
2348                       int (*fn) (struct chartab_range *range,
2349                                  Lisp_Object val, void *arg),
2350                       void *arg)
2351 {
2352   Lisp_Object val = cte->level2[row - 32];
2353
2354   if (!CHAR_TABLE_ENTRYP (val))
2355     {
2356       struct chartab_range rainj;
2357
2358       rainj.type = CHARTAB_RANGE_ROW;
2359       rainj.charset = charset;
2360       rainj.row = row;
2361       return (fn) (&rainj, val, arg);
2362     }
2363   else
2364     {
2365       struct chartab_range rainj;
2366       int i, retval;
2367       int charset94_p = (XCHARSET_CHARS (charset) == 94);
2368       int start = charset94_p ?  33 :  32;
2369       int stop  = charset94_p ? 127 : 128;
2370
2371       cte = XCHAR_TABLE_ENTRY (val);
2372
2373       rainj.type = CHARTAB_RANGE_CHAR;
2374
2375       for (i = start, retval = 0; i < stop && retval == 0; i++)
2376         {
2377           rainj.ch = MAKE_CHAR (charset, row, i);
2378           retval = (fn) (&rainj, cte->level2[i - 32], arg);
2379         }
2380       return retval;
2381     }
2382 }
2383
2384
2385 static int
2386 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2387                         int (*fn) (struct chartab_range *range,
2388                                    Lisp_Object val, void *arg),
2389                         void *arg)
2390 {
2391   Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2392   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2393
2394   if (!CHARSETP (charset)
2395       || lb == LEADING_BYTE_ASCII
2396       || lb == LEADING_BYTE_CONTROL_1)
2397     return 0;
2398
2399   if (!CHAR_TABLE_ENTRYP (val))
2400     {
2401       struct chartab_range rainj;
2402
2403       rainj.type = CHARTAB_RANGE_CHARSET;
2404       rainj.charset = charset;
2405       return (fn) (&rainj, val, arg);
2406     }
2407
2408   {
2409     Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2410     int charset94_p = (XCHARSET_CHARS (charset) == 94);
2411     int start = charset94_p ?  33 :  32;
2412     int stop  = charset94_p ? 127 : 128;
2413     int i, retval;
2414
2415     if (XCHARSET_DIMENSION (charset) == 1)
2416       {
2417         struct chartab_range rainj;
2418         rainj.type = CHARTAB_RANGE_CHAR;
2419
2420         for (i = start, retval = 0; i < stop && retval == 0; i++)
2421           {
2422             rainj.ch = MAKE_CHAR (charset, i, 0);
2423             retval = (fn) (&rainj, cte->level2[i - 32], arg);
2424           }
2425       }
2426     else
2427       {
2428         for (i = start, retval = 0; i < stop && retval == 0; i++)
2429           retval = map_over_charset_row (cte, charset, i, fn, arg);
2430       }
2431
2432     return retval;
2433   }
2434 }
2435
2436 #endif /* MULE */
2437 #endif /* not UTF2000 */
2438
2439 #ifdef UTF2000
2440 struct map_char_table_for_charset_arg
2441 {
2442   int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2443   Lisp_Char_Table *ct;
2444   void *arg;
2445 };
2446
2447 static int
2448 map_char_table_for_charset_fun (struct chartab_range *range,
2449                                 Lisp_Object val, void *arg)
2450 {
2451   struct map_char_table_for_charset_arg *closure =
2452     (struct map_char_table_for_charset_arg *) arg;
2453   Lisp_Object ret;
2454
2455   switch (range->type)
2456     {
2457     case CHARTAB_RANGE_ALL:
2458       break;
2459
2460     case CHARTAB_RANGE_DEFAULT:
2461       break;
2462
2463     case CHARTAB_RANGE_CHARSET:
2464       break;
2465
2466     case CHARTAB_RANGE_ROW:
2467       break;
2468
2469     case CHARTAB_RANGE_CHAR:
2470       ret = get_char_table (range->ch, closure->ct);
2471       if (!UNBOUNDP (ret))
2472         return (closure->fn) (range, ret, closure->arg);
2473       break;
2474
2475     default:
2476       abort ();
2477     }
2478
2479   return 0;
2480 }
2481 #endif
2482
2483 /* Map FN (with client data ARG) over range RANGE in char table CT.
2484    Mapping stops the first time FN returns non-zero, and that value
2485    becomes the return value of map_char_table(). */
2486
2487 int
2488 map_char_table (Lisp_Char_Table *ct,
2489                 struct chartab_range *range,
2490                 int (*fn) (struct chartab_range *range,
2491                            Lisp_Object val, void *arg),
2492                 void *arg)
2493 {
2494   switch (range->type)
2495     {
2496     case CHARTAB_RANGE_ALL:
2497 #ifdef UTF2000
2498       if (!UNBOUNDP (ct->default_value))
2499         {
2500           struct chartab_range rainj;
2501           int retval;
2502
2503           rainj.type = CHARTAB_RANGE_DEFAULT;
2504           retval = (fn) (&rainj, ct->default_value, arg);
2505           if (retval != 0)
2506             return retval;
2507         }
2508       if (UINT8_BYTE_TABLE_P (ct->table))
2509         return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table),
2510                                           0, 3, fn, arg);
2511       else if (UINT16_BYTE_TABLE_P (ct->table))
2512         return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table),
2513                                            0, 3, fn, arg);
2514       else if (BYTE_TABLE_P (ct->table))
2515         return map_over_byte_table (XBYTE_TABLE(ct->table),
2516                                     0, 3, fn, arg);
2517       else if (!UNBOUNDP (ct->table))
2518 #if 0
2519         {
2520           struct chartab_range rainj;
2521           int unit = 1 << 30;
2522           Emchar c = 0;
2523           Emchar c1 = c + unit;
2524           int retval;
2525
2526           rainj.type = CHARTAB_RANGE_CHAR;
2527
2528           for (retval = 0; c < c1 && retval == 0; c++)
2529             {
2530               rainj.ch = c;
2531               retval = (fn) (&rainj, ct->table, arg);
2532             }
2533           return retval;
2534         }
2535 #else
2536       return (fn) (range, ct->table, arg);
2537 #endif
2538       return 0;
2539 #else
2540       {
2541         int retval;
2542
2543         retval = map_over_charset_ascii (ct, fn, arg);
2544         if (retval)
2545           return retval;
2546 #ifdef MULE
2547         retval = map_over_charset_control_1 (ct, fn, arg);
2548         if (retval)
2549           return retval;
2550         {
2551           Charset_ID i;
2552           Charset_ID start = MIN_LEADING_BYTE;
2553           Charset_ID stop  = start + NUM_LEADING_BYTES;
2554
2555           for (i = start, retval = 0; i < stop && retval == 0; i++)
2556             {
2557               retval = map_over_other_charset (ct, i, fn, arg);
2558             }
2559         }
2560 #endif /* MULE */
2561         return retval;
2562       }
2563 #endif
2564
2565 #ifdef UTF2000
2566     case CHARTAB_RANGE_DEFAULT:
2567       if (!UNBOUNDP (ct->default_value))
2568         return (fn) (range, ct->default_value, arg);
2569       return 0;
2570 #endif
2571
2572 #ifdef MULE
2573     case CHARTAB_RANGE_CHARSET:
2574 #ifdef UTF2000
2575       {
2576         Lisp_Object encoding_table
2577           = XCHARSET_ENCODING_TABLE (range->charset);
2578
2579         if (!NILP (encoding_table))
2580           {
2581             struct chartab_range rainj;
2582             struct map_char_table_for_charset_arg mcarg;
2583
2584             mcarg.fn = fn;
2585             mcarg.ct = ct;
2586             mcarg.arg = arg;
2587             rainj.type = CHARTAB_RANGE_ALL;
2588             return map_char_table (XCHAR_TABLE(encoding_table),
2589                                    &rainj,
2590                                    &map_char_table_for_charset_fun,
2591                                    &mcarg);
2592           }
2593       }
2594       return 0;
2595 #else
2596       return map_over_other_charset (ct,
2597                                      XCHARSET_LEADING_BYTE (range->charset),
2598                                      fn, arg);
2599 #endif
2600
2601     case CHARTAB_RANGE_ROW:
2602 #ifdef UTF2000
2603       {
2604         int cell_min, cell_max, i;
2605         int retval;
2606         struct chartab_range rainj;
2607
2608         i = XCHARSET_CELL_RANGE (range->charset);
2609         cell_min = i >> 8;
2610         cell_max = i & 0xFF;
2611         rainj.type = CHARTAB_RANGE_CHAR;
2612         for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2613           {
2614             Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2615
2616             if ( charset_code_point (range->charset, ch, 0) >= 0 )
2617               {
2618                 Lisp_Object val
2619                   = get_byte_table (get_byte_table
2620                                     (get_byte_table
2621                                      (get_byte_table
2622                                       (ct->table,
2623                                        (unsigned char)(ch >> 24)),
2624                                       (unsigned char) (ch >> 16)),
2625                                      (unsigned char)  (ch >> 8)),
2626                                     (unsigned char)    ch);
2627
2628                 if (UNBOUNDP (val))
2629                   val = ct->default_value;
2630                 rainj.ch = ch;
2631                 retval = (fn) (&rainj, val, arg);
2632               }
2633           }
2634         return retval;
2635       }
2636 #else
2637       {
2638         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2639                                     - MIN_LEADING_BYTE];
2640         if (!CHAR_TABLE_ENTRYP (val))
2641           {
2642             struct chartab_range rainj;
2643
2644             rainj.type = CHARTAB_RANGE_ROW;
2645             rainj.charset = range->charset;
2646             rainj.row = range->row;
2647             return (fn) (&rainj, val, arg);
2648           }
2649         else
2650           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2651                                        range->charset, range->row,
2652                                        fn, arg);
2653       }
2654 #endif /* not UTF2000 */
2655 #endif /* MULE */
2656
2657     case CHARTAB_RANGE_CHAR:
2658       {
2659         Emchar ch = range->ch;
2660         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2661
2662         if (!UNBOUNDP (val))
2663           {
2664             struct chartab_range rainj;
2665
2666             rainj.type = CHARTAB_RANGE_CHAR;
2667             rainj.ch = ch;
2668             return (fn) (&rainj, val, arg);
2669           }
2670         return 0;
2671       }
2672
2673     default:
2674       abort ();
2675     }
2676
2677   return 0;
2678 }
2679
2680 struct slow_map_char_table_arg
2681 {
2682   Lisp_Object function;
2683   Lisp_Object retval;
2684 };
2685
2686 static int
2687 slow_map_char_table_fun (struct chartab_range *range,
2688                          Lisp_Object val, void *arg)
2689 {
2690   Lisp_Object ranjarg = Qnil;
2691   struct slow_map_char_table_arg *closure =
2692     (struct slow_map_char_table_arg *) arg;
2693
2694   switch (range->type)
2695     {
2696     case CHARTAB_RANGE_ALL:
2697       ranjarg = Qt;
2698       break;
2699
2700 #ifdef UTF2000
2701     case CHARTAB_RANGE_DEFAULT:
2702       ranjarg = Qnil;
2703       break;
2704 #endif
2705
2706 #ifdef MULE
2707     case CHARTAB_RANGE_CHARSET:
2708       ranjarg = XCHARSET_NAME (range->charset);
2709       break;
2710
2711     case CHARTAB_RANGE_ROW:
2712       ranjarg = vector2 (XCHARSET_NAME (range->charset),
2713                          make_int (range->row));
2714       break;
2715 #endif /* MULE */
2716     case CHARTAB_RANGE_CHAR:
2717       ranjarg = make_char (range->ch);
2718       break;
2719     default:
2720       abort ();
2721     }
2722
2723   closure->retval = call2 (closure->function, ranjarg, val);
2724   return !NILP (closure->retval);
2725 }
2726
2727 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2728 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2729 each key and value in the table.
2730
2731 RANGE specifies a subrange to map over and is in the same format as
2732 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
2733 the entire table.
2734 */
2735        (function, char_table, range))
2736 {
2737   Lisp_Char_Table *ct;
2738   struct slow_map_char_table_arg slarg;
2739   struct gcpro gcpro1, gcpro2;
2740   struct chartab_range rainj;
2741
2742   CHECK_CHAR_TABLE (char_table);
2743   ct = XCHAR_TABLE (char_table);
2744   if (NILP (range))
2745     range = Qt;
2746   decode_char_table_range (range, &rainj);
2747   slarg.function = function;
2748   slarg.retval = Qnil;
2749   GCPRO2 (slarg.function, slarg.retval);
2750   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2751   UNGCPRO;
2752
2753   return slarg.retval;
2754 }
2755
2756 \f
2757 /************************************************************************/
2758 /*                         Character Attributes                         */
2759 /************************************************************************/
2760
2761 #ifdef UTF2000
2762
2763 Lisp_Object Vchar_attribute_hash_table;
2764
2765 /* We store the char-attributes in hash tables with the names as the
2766    key and the actual char-id-table object as the value.  Occasionally
2767    we need to use them in a list format.  These routines provide us
2768    with that. */
2769 struct char_attribute_list_closure
2770 {
2771   Lisp_Object *char_attribute_list;
2772 };
2773
2774 static int
2775 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
2776                                    void *char_attribute_list_closure)
2777 {
2778   /* This function can GC */
2779   struct char_attribute_list_closure *calcl
2780     = (struct char_attribute_list_closure*) char_attribute_list_closure;
2781   Lisp_Object *char_attribute_list = calcl->char_attribute_list;
2782
2783   *char_attribute_list = Fcons (key, *char_attribute_list);
2784   return 0;
2785 }
2786
2787 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
2788 Return the list of all existing character attributes except coded-charsets.
2789 */
2790        ())
2791 {
2792   Lisp_Object char_attribute_list = Qnil;
2793   struct gcpro gcpro1;
2794   struct char_attribute_list_closure char_attribute_list_closure;
2795
2796   GCPRO1 (char_attribute_list);
2797   char_attribute_list_closure.char_attribute_list = &char_attribute_list;
2798   elisp_maphash (add_char_attribute_to_list_mapper,
2799                  Vchar_attribute_hash_table,
2800                  &char_attribute_list_closure);
2801   UNGCPRO;
2802   return char_attribute_list;
2803 }
2804
2805 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
2806 Return char-id-table corresponding to ATTRIBUTE.
2807 */
2808        (attribute))
2809 {
2810   return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
2811 }
2812
2813
2814 /* We store the char-id-tables in hash tables with the attributes as
2815    the key and the actual char-id-table object as the value.  Each
2816    char-id-table stores values of an attribute corresponding with
2817    characters.  Occasionally we need to get attributes of a character
2818    in a association-list format.  These routines provide us with
2819    that. */
2820 struct char_attribute_alist_closure
2821 {
2822   Emchar char_id;
2823   Lisp_Object *char_attribute_alist;
2824 };
2825
2826 static int
2827 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
2828                                  void *char_attribute_alist_closure)
2829 {
2830   /* This function can GC */
2831   struct char_attribute_alist_closure *caacl =
2832     (struct char_attribute_alist_closure*) char_attribute_alist_closure;
2833   Lisp_Object ret
2834     = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
2835   if (!UNBOUNDP (ret))
2836     {
2837       Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
2838       *char_attribute_alist
2839         = Fcons (Fcons (key, ret), *char_attribute_alist);
2840     }
2841   return 0;
2842 }
2843
2844 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
2845 Return the alist of attributes of CHARACTER.
2846 */
2847        (character))
2848 {
2849   struct gcpro gcpro1;
2850   struct char_attribute_alist_closure char_attribute_alist_closure;
2851   Lisp_Object alist = Qnil;
2852
2853   CHECK_CHAR (character);
2854
2855   GCPRO1 (alist);
2856   char_attribute_alist_closure.char_id = XCHAR (character);
2857   char_attribute_alist_closure.char_attribute_alist = &alist;
2858   elisp_maphash (add_char_attribute_alist_mapper,
2859                  Vchar_attribute_hash_table,
2860                  &char_attribute_alist_closure);
2861   UNGCPRO;
2862
2863   return alist;
2864 }
2865
2866 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
2867 Return the value of CHARACTER's ATTRIBUTE.
2868 Return DEFAULT-VALUE if the value is not exist.
2869 */
2870        (character, attribute, default_value))
2871 {
2872   Lisp_Object table;
2873
2874   CHECK_CHAR (character);
2875
2876   if (CHARSETP (attribute))
2877     attribute = XCHARSET_NAME (attribute);
2878
2879   table = Fgethash (attribute, Vchar_attribute_hash_table,
2880                     Qunbound);
2881   if (!UNBOUNDP (table))
2882     {
2883       Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
2884                                            XCHAR (character));
2885       if (!UNBOUNDP (ret))
2886         return ret;
2887     }
2888   return default_value;
2889 }
2890
2891 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
2892 Store CHARACTER's ATTRIBUTE with VALUE.
2893 */
2894        (character, attribute, value))
2895 {
2896   Lisp_Object ccs = Ffind_charset (attribute);
2897
2898   if (!NILP (ccs))
2899     {
2900       CHECK_CHAR (character);
2901       value = put_char_ccs_code_point (character, ccs, value);
2902       attribute = XCHARSET_NAME (ccs);
2903     }
2904   else if (EQ (attribute, Q_decomposition))
2905     {
2906       Lisp_Object seq;
2907
2908       CHECK_CHAR (character);
2909       if (!CONSP (value))
2910         signal_simple_error ("Invalid value for ->decomposition",
2911                              value);
2912
2913       if (CONSP (Fcdr (value)))
2914         {
2915           Lisp_Object rest = value;
2916           Lisp_Object table = Vcharacter_composition_table;
2917           size_t len;
2918           int i = 0;
2919
2920           GET_EXTERNAL_LIST_LENGTH (rest, len);
2921           seq = make_vector (len, Qnil);
2922
2923           while (CONSP (rest))
2924             {
2925               Lisp_Object v = Fcar (rest);
2926               Lisp_Object ntable;
2927               Emchar c
2928                 = to_char_id (v, "Invalid value for ->decomposition", value);
2929
2930               if (c < 0)
2931                 XVECTOR_DATA(seq)[i++] = v;
2932               else
2933                 XVECTOR_DATA(seq)[i++] = make_char (c);
2934               rest = Fcdr (rest);
2935               if (!CONSP (rest))
2936                 {
2937                   put_char_id_table (XCHAR_TABLE(table),
2938                                      make_char (c), character);
2939                   break;
2940                 }
2941               else
2942                 {
2943                   ntable = get_char_id_table (XCHAR_TABLE(table), c);
2944                   if (!CHAR_TABLEP (ntable))
2945                     {
2946                       ntable = make_char_id_table (Qnil);
2947                       put_char_id_table (XCHAR_TABLE(table),
2948                                          make_char (c), ntable);
2949                     }
2950                   table = ntable;
2951                 }
2952             }
2953         }
2954       else
2955         {
2956           Lisp_Object v = Fcar (value);
2957
2958           if (INTP (v))
2959             {
2960               Emchar c = XINT (v);
2961               Lisp_Object ret
2962                 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2963                                      c);
2964
2965               if (NILP (Fmemq (v, ret)))
2966                 {
2967                   put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2968                                      make_char (c), Fcons (character, ret));
2969                 }
2970             }
2971           seq = make_vector (1, v);
2972         }
2973       value = seq;
2974     }
2975   else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
2976     {
2977       Lisp_Object ret;
2978       Emchar c;
2979
2980       CHECK_CHAR (character);
2981       if (!INTP (value))
2982         signal_simple_error ("Invalid value for ->ucs", value);
2983
2984       c = XINT (value);
2985
2986       ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
2987       if (NILP (Fmemq (character, ret)))
2988         {
2989           put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2990                              make_char (c), Fcons (character, ret));
2991         }
2992 #if 0
2993       if (EQ (attribute, Q_ucs))
2994         attribute = Qto_ucs;
2995 #endif
2996     }
2997   {
2998     Lisp_Object table = Fgethash (attribute,
2999                                   Vchar_attribute_hash_table,
3000                                   Qnil);
3001
3002     if (NILP (table))
3003       {
3004         table = make_char_id_table (Qunbound);
3005         Fputhash (attribute, table, Vchar_attribute_hash_table);
3006       }
3007     put_char_id_table (XCHAR_TABLE(table), character, value);
3008     return value;
3009   }
3010 }
3011
3012 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3013 Remove CHARACTER's ATTRIBUTE.
3014 */
3015        (character, attribute))
3016 {
3017   Lisp_Object ccs;
3018
3019   CHECK_CHAR (character);
3020   ccs = Ffind_charset (attribute);
3021   if (!NILP (ccs))
3022     {
3023       return remove_char_ccs (character, ccs);
3024     }
3025   else
3026     {
3027       Lisp_Object table = Fgethash (attribute,
3028                                     Vchar_attribute_hash_table,
3029                                     Qunbound);
3030       if (!UNBOUNDP (table))
3031         {
3032           put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3033           return Qt;
3034         }
3035     }
3036   return Qnil;
3037 }
3038
3039 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3040 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3041 each key and value in the table.
3042
3043 RANGE specifies a subrange to map over and is in the same format as
3044 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
3045 the entire table.
3046 */
3047        (function, attribute, range))
3048 {
3049   Lisp_Object ccs;
3050   Lisp_Char_Table *ct;
3051   struct slow_map_char_table_arg slarg;
3052   struct gcpro gcpro1, gcpro2;
3053   struct chartab_range rainj;
3054
3055   if (!NILP (ccs = Ffind_charset (attribute)))
3056     {
3057       Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3058
3059       if (CHAR_TABLEP (encoding_table))
3060         ct = XCHAR_TABLE (encoding_table);
3061       else
3062         return Qnil;
3063     }
3064   else
3065     {
3066       Lisp_Object table = Fgethash (attribute,
3067                                     Vchar_attribute_hash_table,
3068                                     Qunbound);
3069       if (CHAR_TABLEP (table))
3070         ct = XCHAR_TABLE (table);
3071       else
3072         return Qnil;
3073     }
3074   if (NILP (range))
3075     range = Qt;
3076   decode_char_table_range (range, &rainj);
3077   slarg.function = function;
3078   slarg.retval = Qnil;
3079   GCPRO2 (slarg.function, slarg.retval);
3080   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3081   UNGCPRO;
3082
3083   return slarg.retval;
3084 }
3085
3086 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3087 Store character's ATTRIBUTES.
3088 */
3089        (attributes))
3090 {
3091   Lisp_Object rest = attributes;
3092   Lisp_Object code = Fcdr (Fassq (Qmap_ucs, attributes));
3093   Lisp_Object character;
3094
3095   if (NILP (code))
3096     code = Fcdr (Fassq (Qucs, attributes));
3097   if (NILP (code))
3098     {
3099       while (CONSP (rest))
3100         {
3101           Lisp_Object cell = Fcar (rest);
3102           Lisp_Object ccs;
3103
3104           if (!LISTP (cell))
3105             signal_simple_error ("Invalid argument", attributes);
3106           if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3107               && ((XCHARSET_FINAL (ccs) != 0) ||
3108                   (XCHARSET_MAX_CODE (ccs) > 0) ||
3109                   (EQ (ccs, Vcharset_chinese_big5))) )
3110             {
3111               cell = Fcdr (cell);
3112               if (CONSP (cell))
3113                 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3114               else
3115                 character = Fdecode_char (ccs, cell, Qnil);
3116               if (!NILP (character))
3117                 goto setup_attributes;
3118             }
3119           rest = Fcdr (rest);
3120         }
3121       if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3122            (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3123
3124         {
3125           if (!INTP (code))
3126             signal_simple_error ("Invalid argument", attributes);
3127           else
3128             character = make_char (XINT (code) + 0x100000);
3129           goto setup_attributes;
3130         }
3131       return Qnil;
3132     }
3133   else if (!INTP (code))
3134     signal_simple_error ("Invalid argument", attributes);
3135   else
3136     character = make_char (XINT (code));
3137
3138  setup_attributes:
3139   rest = attributes;
3140   while (CONSP (rest))
3141     {
3142       Lisp_Object cell = Fcar (rest);
3143
3144       if (!LISTP (cell))
3145         signal_simple_error ("Invalid argument", attributes);
3146
3147       Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3148       rest = Fcdr (rest);
3149     }
3150   return character;
3151 }
3152
3153 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3154 Retrieve the character of the given ATTRIBUTES.
3155 */
3156        (attributes))
3157 {
3158   Lisp_Object rest = attributes;
3159   Lisp_Object code;
3160
3161   while (CONSP (rest))
3162     {
3163       Lisp_Object cell = Fcar (rest);
3164       Lisp_Object ccs;
3165
3166       if (!LISTP (cell))
3167         signal_simple_error ("Invalid argument", attributes);
3168       if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3169         {
3170           cell = Fcdr (cell);
3171           if (CONSP (cell))
3172             return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3173           else
3174             return Fdecode_char (ccs, cell, Qnil);
3175         }
3176       rest = Fcdr (rest);
3177     }
3178   if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3179        (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3180     {
3181       if (!INTP (code))
3182         signal_simple_error ("Invalid argument", attributes);
3183       else
3184         return make_char (XINT (code) + 0x100000);
3185     }
3186   return Qnil;
3187 }
3188
3189 #endif
3190
3191 \f
3192 /************************************************************************/
3193 /*                         Char table read syntax                       */
3194 /************************************************************************/
3195
3196 static int
3197 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3198                        Error_behavior errb)
3199 {
3200   /* #### should deal with ERRB */
3201   symbol_to_char_table_type (value);
3202   return 1;
3203 }
3204
3205 static int
3206 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3207                        Error_behavior errb)
3208 {
3209   Lisp_Object rest;
3210
3211   /* #### should deal with ERRB */
3212   EXTERNAL_LIST_LOOP (rest, value)
3213     {
3214       Lisp_Object range = XCAR (rest);
3215       struct chartab_range dummy;
3216
3217       rest = XCDR (rest);
3218       if (!CONSP (rest))
3219         signal_simple_error ("Invalid list format", value);
3220       if (CONSP (range))
3221         {
3222           if (!CONSP (XCDR (range))
3223               || !NILP (XCDR (XCDR (range))))
3224             signal_simple_error ("Invalid range format", range);
3225           decode_char_table_range (XCAR (range), &dummy);
3226           decode_char_table_range (XCAR (XCDR (range)), &dummy);
3227         }
3228       else
3229         decode_char_table_range (range, &dummy);
3230     }
3231
3232   return 1;
3233 }
3234
3235 static Lisp_Object
3236 chartab_instantiate (Lisp_Object data)
3237 {
3238   Lisp_Object chartab;
3239   Lisp_Object type = Qgeneric;
3240   Lisp_Object dataval = Qnil;
3241
3242   while (!NILP (data))
3243     {
3244       Lisp_Object keyw = Fcar (data);
3245       Lisp_Object valw;
3246
3247       data = Fcdr (data);
3248       valw = Fcar (data);
3249       data = Fcdr (data);
3250       if (EQ (keyw, Qtype))
3251         type = valw;
3252       else if (EQ (keyw, Qdata))
3253         dataval = valw;
3254     }
3255
3256   chartab = Fmake_char_table (type);
3257
3258   data = dataval;
3259   while (!NILP (data))
3260     {
3261       Lisp_Object range = Fcar (data);
3262       Lisp_Object val = Fcar (Fcdr (data));
3263
3264       data = Fcdr (Fcdr (data));
3265       if (CONSP (range))
3266         {
3267           if (CHAR_OR_CHAR_INTP (XCAR (range)))
3268             {
3269               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3270               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3271               Emchar i;
3272
3273               for (i = first; i <= last; i++)
3274                  Fput_char_table (make_char (i), val, chartab);
3275             }
3276           else
3277             abort ();
3278         }
3279       else
3280         Fput_char_table (range, val, chartab);
3281     }
3282
3283   return chartab;
3284 }
3285
3286 #ifdef MULE
3287
3288 \f
3289 /************************************************************************/
3290 /*                     Category Tables, specifically                    */
3291 /************************************************************************/
3292
3293 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3294 Return t if OBJECT is a category table.
3295 A category table is a type of char table used for keeping track of
3296 categories.  Categories are used for classifying characters for use
3297 in regexps -- you can refer to a category rather than having to use
3298 a complicated [] expression (and category lookups are significantly
3299 faster).
3300
3301 There are 95 different categories available, one for each printable
3302 character (including space) in the ASCII charset.  Each category
3303 is designated by one such character, called a "category designator".
3304 They are specified in a regexp using the syntax "\\cX", where X is
3305 a category designator.
3306
3307 A category table specifies, for each character, the categories that
3308 the character is in.  Note that a character can be in more than one
3309 category.  More specifically, a category table maps from a character
3310 to either the value nil (meaning the character is in no categories)
3311 or a 95-element bit vector, specifying for each of the 95 categories
3312 whether the character is in that category.
3313
3314 Special Lisp functions are provided that abstract this, so you do not
3315 have to directly manipulate bit vectors.
3316 */
3317        (object))
3318 {
3319   return (CHAR_TABLEP (object) &&
3320           XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3321     Qt : Qnil;
3322 }
3323
3324 static Lisp_Object
3325 check_category_table (Lisp_Object object, Lisp_Object default_)
3326 {
3327   if (NILP (object))
3328     object = default_;
3329   while (NILP (Fcategory_table_p (object)))
3330     object = wrong_type_argument (Qcategory_table_p, object);
3331   return object;
3332 }
3333
3334 int
3335 check_category_char (Emchar ch, Lisp_Object table,
3336                      unsigned int designator, unsigned int not_p)
3337 {
3338   REGISTER Lisp_Object temp;
3339   Lisp_Char_Table *ctbl;
3340 #ifdef ERROR_CHECK_TYPECHECK
3341   if (NILP (Fcategory_table_p (table)))
3342     signal_simple_error ("Expected category table", table);
3343 #endif
3344   ctbl = XCHAR_TABLE (table);
3345   temp = get_char_table (ch, ctbl);
3346   if (NILP (temp))
3347     return not_p;
3348
3349   designator -= ' ';
3350   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3351 }
3352
3353 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3354 Return t if category of the character at POSITION includes DESIGNATOR.
3355 Optional third arg BUFFER specifies which buffer to use, and defaults
3356 to the current buffer.
3357 Optional fourth arg CATEGORY-TABLE specifies the category table to
3358 use, and defaults to BUFFER's category table.
3359 */
3360        (position, designator, buffer, category_table))
3361 {
3362   Lisp_Object ctbl;
3363   Emchar ch;
3364   unsigned int des;
3365   struct buffer *buf = decode_buffer (buffer, 0);
3366
3367   CHECK_INT (position);
3368   CHECK_CATEGORY_DESIGNATOR (designator);
3369   des = XCHAR (designator);
3370   ctbl = check_category_table (category_table, Vstandard_category_table);
3371   ch = BUF_FETCH_CHAR (buf, XINT (position));
3372   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3373 }
3374
3375 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3376 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3377 Optional third arg CATEGORY-TABLE specifies the category table to use,
3378 and defaults to the standard category table.
3379 */
3380        (character, designator, category_table))
3381 {
3382   Lisp_Object ctbl;
3383   Emchar ch;
3384   unsigned int des;
3385
3386   CHECK_CATEGORY_DESIGNATOR (designator);
3387   des = XCHAR (designator);
3388   CHECK_CHAR (character);
3389   ch = XCHAR (character);
3390   ctbl = check_category_table (category_table, Vstandard_category_table);
3391   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3392 }
3393
3394 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3395 Return BUFFER's current category table.
3396 BUFFER defaults to the current buffer.
3397 */
3398        (buffer))
3399 {
3400   return decode_buffer (buffer, 0)->category_table;
3401 }
3402
3403 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3404 Return the standard category table.
3405 This is the one used for new buffers.
3406 */
3407        ())
3408 {
3409   return Vstandard_category_table;
3410 }
3411
3412 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3413 Return a new category table which is a copy of CATEGORY-TABLE.
3414 CATEGORY-TABLE defaults to the standard category table.
3415 */
3416        (category_table))
3417 {
3418   if (NILP (Vstandard_category_table))
3419     return Fmake_char_table (Qcategory);
3420
3421   category_table =
3422     check_category_table (category_table, Vstandard_category_table);
3423   return Fcopy_char_table (category_table);
3424 }
3425
3426 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3427 Select CATEGORY-TABLE as the new category table for BUFFER.
3428 BUFFER defaults to the current buffer if omitted.
3429 */
3430        (category_table, buffer))
3431 {
3432   struct buffer *buf = decode_buffer (buffer, 0);
3433   category_table = check_category_table (category_table, Qnil);
3434   buf->category_table = category_table;
3435   /* Indicate that this buffer now has a specified category table.  */
3436   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3437   return category_table;
3438 }
3439
3440 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3441 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3442 */
3443        (object))
3444 {
3445   return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3446 }
3447
3448 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3449 Return t if OBJECT is a category table value.
3450 Valid values are nil or a bit vector of size 95.
3451 */
3452        (object))
3453 {
3454   return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3455 }
3456
3457
3458 #define CATEGORYP(x) \
3459   (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3460
3461 #define CATEGORY_SET(c)                                         \
3462   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3463
3464 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3465    The faster version of `!NILP (Faref (category_set, category))'.  */
3466 #define CATEGORY_MEMBER(category, category_set)                 \
3467   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3468
3469 /* Return 1 if there is a word boundary between two word-constituent
3470    characters C1 and C2 if they appear in this order, else return 0.
3471    Use the macro WORD_BOUNDARY_P instead of calling this function
3472    directly.  */
3473
3474 int word_boundary_p (Emchar c1, Emchar c2);
3475 int
3476 word_boundary_p (Emchar c1, Emchar c2)
3477 {
3478   Lisp_Object category_set1, category_set2;
3479   Lisp_Object tail;
3480   int default_result;
3481
3482 #if 0
3483   if (COMPOSITE_CHAR_P (c1))
3484     c1 = cmpchar_component (c1, 0, 1);
3485   if (COMPOSITE_CHAR_P (c2))
3486     c2 = cmpchar_component (c2, 0, 1);
3487 #endif
3488
3489   if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3490     {
3491       tail = Vword_separating_categories;
3492       default_result = 0;
3493     }
3494   else
3495     {
3496       tail = Vword_combining_categories;
3497       default_result = 1;
3498     }
3499
3500   category_set1 = CATEGORY_SET (c1);
3501   if (NILP (category_set1))
3502     return default_result;
3503   category_set2 = CATEGORY_SET (c2);
3504   if (NILP (category_set2))
3505     return default_result;
3506
3507   for (; CONSP (tail); tail = XCONS (tail)->cdr)
3508     {
3509       Lisp_Object elt = XCONS(tail)->car;
3510
3511       if (CONSP (elt)
3512           && CATEGORYP (XCONS (elt)->car)
3513           && CATEGORYP (XCONS (elt)->cdr)
3514           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3515           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3516         return !default_result;
3517     }
3518   return default_result;
3519 }
3520 #endif /* MULE */
3521
3522 \f
3523 void
3524 syms_of_chartab (void)
3525 {
3526 #ifdef UTF2000
3527   INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3528   INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3529   INIT_LRECORD_IMPLEMENTATION (byte_table);
3530
3531   defsymbol (&Qto_ucs,                  "=>ucs");
3532   defsymbol (&Q_ucs,                    "->ucs");
3533   defsymbol (&Q_decomposition,          "->decomposition");
3534   defsymbol (&Qcompat,                  "compat");
3535   defsymbol (&Qisolated,                "isolated");
3536   defsymbol (&Qinitial,                 "initial");
3537   defsymbol (&Qmedial,                  "medial");
3538   defsymbol (&Qfinal,                   "final");
3539   defsymbol (&Qvertical,                "vertical");
3540   defsymbol (&QnoBreak,                 "noBreak");
3541   defsymbol (&Qfraction,                "fraction");
3542   defsymbol (&Qsuper,                   "super");
3543   defsymbol (&Qsub,                     "sub");
3544   defsymbol (&Qcircle,                  "circle");
3545   defsymbol (&Qsquare,                  "square");
3546   defsymbol (&Qwide,                    "wide");
3547   defsymbol (&Qnarrow,                  "narrow");
3548   defsymbol (&Qsmall,                   "small");
3549   defsymbol (&Qfont,                    "font");
3550
3551   DEFSUBR (Fchar_attribute_list);
3552   DEFSUBR (Ffind_char_attribute_table);
3553   DEFSUBR (Fchar_attribute_alist);
3554   DEFSUBR (Fget_char_attribute);
3555   DEFSUBR (Fput_char_attribute);
3556   DEFSUBR (Fremove_char_attribute);
3557   DEFSUBR (Fmap_char_attribute);
3558   DEFSUBR (Fdefine_char);
3559   DEFSUBR (Ffind_char);
3560   DEFSUBR (Fchar_variants);
3561
3562   DEFSUBR (Fget_composite_char);
3563 #endif
3564
3565   INIT_LRECORD_IMPLEMENTATION (char_table);
3566
3567 #ifdef MULE
3568 #ifndef UTF2000
3569   INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3570 #endif
3571
3572   defsymbol (&Qcategory_table_p, "category-table-p");
3573   defsymbol (&Qcategory_designator_p, "category-designator-p");
3574   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3575 #endif /* MULE */
3576
3577   defsymbol (&Qchar_table, "char-table");
3578   defsymbol (&Qchar_tablep, "char-table-p");
3579
3580   DEFSUBR (Fchar_table_p);
3581   DEFSUBR (Fchar_table_type_list);
3582   DEFSUBR (Fvalid_char_table_type_p);
3583   DEFSUBR (Fchar_table_type);
3584   DEFSUBR (Freset_char_table);
3585   DEFSUBR (Fmake_char_table);
3586   DEFSUBR (Fcopy_char_table);
3587   DEFSUBR (Fget_char_table);
3588   DEFSUBR (Fget_range_char_table);
3589   DEFSUBR (Fvalid_char_table_value_p);
3590   DEFSUBR (Fcheck_valid_char_table_value);
3591   DEFSUBR (Fput_char_table);
3592   DEFSUBR (Fmap_char_table);
3593
3594 #ifdef MULE
3595   DEFSUBR (Fcategory_table_p);
3596   DEFSUBR (Fcategory_table);
3597   DEFSUBR (Fstandard_category_table);
3598   DEFSUBR (Fcopy_category_table);
3599   DEFSUBR (Fset_category_table);
3600   DEFSUBR (Fcheck_category_at);
3601   DEFSUBR (Fchar_in_category_p);
3602   DEFSUBR (Fcategory_designator_p);
3603   DEFSUBR (Fcategory_table_value_p);
3604 #endif /* MULE */
3605
3606 }
3607
3608 void
3609 vars_of_chartab (void)
3610 {
3611 #ifdef UTF2000
3612   Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)");
3613   DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3614 Version number of XEmacs UTF-2000.
3615 */ );
3616
3617   staticpro (&Vcharacter_composition_table);
3618   Vcharacter_composition_table = make_char_id_table (Qnil);
3619
3620   staticpro (&Vcharacter_variant_table);
3621   Vcharacter_variant_table = make_char_id_table (Qnil);
3622 #endif
3623   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
3624   Vall_syntax_tables = Qnil;
3625   dump_add_weak_object_chain (&Vall_syntax_tables);
3626 }
3627
3628 void
3629 structure_type_create_chartab (void)
3630 {
3631   struct structure_type *st;
3632
3633   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3634
3635   define_structure_type_keyword (st, Qtype, chartab_type_validate);
3636   define_structure_type_keyword (st, Qdata, chartab_data_validate);
3637 }
3638
3639 void
3640 complex_vars_of_chartab (void)
3641 {
3642 #ifdef UTF2000
3643   staticpro (&Vchar_attribute_hash_table);
3644   Vchar_attribute_hash_table
3645     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3646 #endif /* UTF2000 */
3647 #ifdef MULE
3648   /* Set this now, so first buffer creation can refer to it. */
3649   /* Make it nil before calling copy-category-table
3650      so that copy-category-table will know not to try to copy from garbage */
3651   Vstandard_category_table = Qnil;
3652   Vstandard_category_table = Fcopy_category_table (Qnil);
3653   staticpro (&Vstandard_category_table);
3654
3655   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3656 List of pair (cons) of categories to determine word boundary.
3657
3658 Emacs treats a sequence of word constituent characters as a single
3659 word (i.e. finds no word boundary between them) iff they belongs to
3660 the same charset.  But, exceptions are allowed in the following cases.
3661
3662 \(1) The case that characters are in different charsets is controlled
3663 by the variable `word-combining-categories'.
3664
3665 Emacs finds no word boundary between characters of different charsets
3666 if they have categories matching some element of this list.
3667
3668 More precisely, if an element of this list is a cons of category CAT1
3669 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3670 C2 which has CAT2, there's no word boundary between C1 and C2.
3671
3672 For instance, to tell that ASCII characters and Latin-1 characters can
3673 form a single word, the element `(?l . ?l)' should be in this list
3674 because both characters have the category `l' (Latin characters).
3675
3676 \(2) The case that character are in the same charset is controlled by
3677 the variable `word-separating-categories'.
3678
3679 Emacs find a word boundary between characters of the same charset
3680 if they have categories matching some element of this list.
3681
3682 More precisely, if an element of this list is a cons of category CAT1
3683 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3684 C2 which has CAT2, there's a word boundary between C1 and C2.
3685
3686 For instance, to tell that there's a word boundary between Japanese
3687 Hiragana and Japanese Kanji (both are in the same charset), the
3688 element `(?H . ?C) should be in this list.
3689 */ );
3690
3691   Vword_combining_categories = Qnil;
3692
3693   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3694 List of pair (cons) of categories to determine word boundary.
3695 See the documentation of the variable `word-combining-categories'.
3696 */ );
3697
3698   Vword_separating_categories = Qnil;
3699 #endif /* MULE */
3700 }