git.chise.org Git - chise/xemacs-chise.git-/blob - 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   else if (EQ (range, Qnil))
1744     outrange->type = CHARTAB_RANGE_DEFAULT;
1745   else if (CHAR_OR_CHAR_INTP (range))
1746     {
1747       outrange->type = CHARTAB_RANGE_CHAR;
1748       outrange->ch = XCHAR_OR_CHAR_INT (range);
1749     }
1750 #ifndef MULE
1751   else
1752     signal_simple_error ("Range must be t or a character", range);
1753 #else /* MULE */
1754   else if (VECTORP (range))
1755     {
1756       Lisp_Vector *vec = XVECTOR (range);
1757       Lisp_Object *elts = vector_data (vec);
1758       int cell_min, cell_max;
1759
1760       outrange->type = CHARTAB_RANGE_ROW;
1761       outrange->charset = Fget_charset (elts[0]);
1762       CHECK_INT (elts[1]);
1763       outrange->row = XINT (elts[1]);
1764       if (XCHARSET_DIMENSION (outrange->charset) < 2)
1765         signal_simple_error ("Charset in row vector must be multi-byte",
1766                              outrange->charset);
1767       else
1768         {
1769           int ret = XCHARSET_CELL_RANGE (outrange->charset);
1770
1771           cell_min = ret >> 8;
1772           cell_max = ret & 0xFF;
1773         }
1774       if (XCHARSET_DIMENSION (outrange->charset) == 2)
1775         check_int_range (outrange->row, cell_min, cell_max);
1776 #ifdef UTF2000
1777       else if (XCHARSET_DIMENSION (outrange->charset) == 3)
1778         {
1779           check_int_range (outrange->row >> 8  , cell_min, cell_max);
1780           check_int_range (outrange->row & 0xFF, cell_min, cell_max);
1781         }
1782       else if (XCHARSET_DIMENSION (outrange->charset) == 4)
1783         {
1784           check_int_range ( outrange->row >> 16       , cell_min, cell_max);
1785           check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
1786           check_int_range ( outrange->row       & 0xFF, cell_min, cell_max);
1787         }
1788 #endif
1789       else
1790         abort ();
1791     }
1792   else
1793     {
1794       if (!CHARSETP (range) && !SYMBOLP (range))
1795         signal_simple_error
1796           ("Char table range must be t, charset, char, or vector", range);
1797       outrange->type = CHARTAB_RANGE_CHARSET;
1798       outrange->charset = Fget_charset (range);
1799     }
1800 #endif /* MULE */
1801 }
1802
1803 #if defined(MULE)&&!defined(UTF2000)
1804
1805 /* called from CHAR_TABLE_VALUE(). */
1806 Lisp_Object
1807 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
1808                                Emchar c)
1809 {
1810   Lisp_Object val;
1811 #ifdef UTF2000
1812   Lisp_Object charset;
1813 #else
1814   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
1815 #endif
1816   int byte1, byte2;
1817
1818 #ifdef UTF2000
1819   BREAKUP_CHAR (c, charset, byte1, byte2);
1820 #else
1821   BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
1822 #endif
1823   val = ct->level1[leading_byte - MIN_LEADING_BYTE];
1824   if (CHAR_TABLE_ENTRYP (val))
1825     {
1826       Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1827       val = cte->level2[byte1 - 32];
1828       if (CHAR_TABLE_ENTRYP (val))
1829         {
1830           cte = XCHAR_TABLE_ENTRY (val);
1831           assert (byte2 >= 32);
1832           val = cte->level2[byte2 - 32];
1833           assert (!CHAR_TABLE_ENTRYP (val));
1834         }
1835     }
1836
1837   return val;
1838 }
1839
1840 #endif /* MULE */
1841
1842 Lisp_Object
1843 get_char_table (Emchar ch, Lisp_Char_Table *ct)
1844 {
1845 #ifdef UTF2000
1846   return get_char_id_table (ct, ch);
1847 #elif defined(MULE)
1848   {
1849     Lisp_Object charset;
1850     int byte1, byte2;
1851     Lisp_Object val;
1852
1853     BREAKUP_CHAR (ch, charset, byte1, byte2);
1854
1855     if (EQ (charset, Vcharset_ascii))
1856       val = ct->ascii[byte1];
1857     else if (EQ (charset, Vcharset_control_1))
1858       val = ct->ascii[byte1 + 128];
1859     else
1860       {
1861         int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1862         val = ct->level1[lb];
1863         if (CHAR_TABLE_ENTRYP (val))
1864           {
1865             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1866             val = cte->level2[byte1 - 32];
1867             if (CHAR_TABLE_ENTRYP (val))
1868               {
1869                 cte = XCHAR_TABLE_ENTRY (val);
1870                 assert (byte2 >= 32);
1871                 val = cte->level2[byte2 - 32];
1872                 assert (!CHAR_TABLE_ENTRYP (val));
1873               }
1874           }
1875       }
1876
1877     return val;
1878   }
1879 #else /* not MULE */
1880   return ct->ascii[(unsigned char)ch];
1881 #endif /* not MULE */
1882 }
1883
1884
1885 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
1886 Find value for CHARACTER in CHAR-TABLE.
1887 */
1888        (character, char_table))
1889 {
1890   CHECK_CHAR_TABLE (char_table);
1891   CHECK_CHAR_COERCE_INT (character);
1892
1893   return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
1894 }
1895
1896 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
1897 Find value for a range in CHAR-TABLE.
1898 If there is more than one value, return MULTI (defaults to nil).
1899 */
1900        (range, char_table, multi))
1901 {
1902   Lisp_Char_Table *ct;
1903   struct chartab_range rainj;
1904
1905   if (CHAR_OR_CHAR_INTP (range))
1906     return Fget_char_table (range, char_table);
1907   CHECK_CHAR_TABLE (char_table);
1908   ct = XCHAR_TABLE (char_table);
1909
1910   decode_char_table_range (range, &rainj);
1911   switch (rainj.type)
1912     {
1913     case CHARTAB_RANGE_ALL:
1914       {
1915 #ifdef UTF2000
1916         if (UINT8_BYTE_TABLE_P (ct->table))
1917           return multi;
1918         else if (UINT16_BYTE_TABLE_P (ct->table))
1919           return multi;
1920         else if (BYTE_TABLE_P (ct->table))
1921           return multi;
1922         else
1923           return ct->table;
1924 #else /* non UTF2000 */
1925         int i;
1926         Lisp_Object first = ct->ascii[0];
1927
1928         for (i = 1; i < NUM_ASCII_CHARS; i++)
1929           if (!EQ (first, ct->ascii[i]))
1930             return multi;
1931
1932 #ifdef MULE
1933         for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1934              i++)
1935           {
1936             if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
1937                 || i == LEADING_BYTE_ASCII
1938                 || i == LEADING_BYTE_CONTROL_1)
1939               continue;
1940             if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
1941               return multi;
1942           }
1943 #endif /* MULE */
1944
1945         return first;
1946 #endif /* non UTF2000 */
1947       }
1948
1949 #ifdef MULE
1950     case CHARTAB_RANGE_CHARSET:
1951 #ifdef UTF2000
1952       return multi;
1953 #else
1954       if (EQ (rainj.charset, Vcharset_ascii))
1955         {
1956           int i;
1957           Lisp_Object first = ct->ascii[0];
1958
1959           for (i = 1; i < 128; i++)
1960             if (!EQ (first, ct->ascii[i]))
1961               return multi;
1962           return first;
1963         }
1964
1965       if (EQ (rainj.charset, Vcharset_control_1))
1966         {
1967           int i;
1968           Lisp_Object first = ct->ascii[128];
1969
1970           for (i = 129; i < 160; i++)
1971             if (!EQ (first, ct->ascii[i]))
1972               return multi;
1973           return first;
1974         }
1975
1976       {
1977         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
1978                                      MIN_LEADING_BYTE];
1979         if (CHAR_TABLE_ENTRYP (val))
1980           return multi;
1981         return val;
1982       }
1983 #endif
1984
1985     case CHARTAB_RANGE_ROW:
1986 #ifdef UTF2000
1987       return multi;
1988 #else
1989       {
1990         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
1991                                      MIN_LEADING_BYTE];
1992         if (!CHAR_TABLE_ENTRYP (val))
1993           return val;
1994         val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
1995         if (CHAR_TABLE_ENTRYP (val))
1996           return multi;
1997         return val;
1998       }
1999 #endif /* not UTF2000 */
2000 #endif /* not MULE */
2001
2002     default:
2003       abort ();
2004     }
2005
2006   return Qnil; /* not reached */
2007 }
2008
2009 static int
2010 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2011                               Error_behavior errb)
2012 {
2013   switch (type)
2014     {
2015     case CHAR_TABLE_TYPE_SYNTAX:
2016       if (!ERRB_EQ (errb, ERROR_ME))
2017         return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2018                                 && CHAR_OR_CHAR_INTP (XCDR (value)));
2019       if (CONSP (value))
2020         {
2021           Lisp_Object cdr = XCDR (value);
2022           CHECK_INT (XCAR (value));
2023           CHECK_CHAR_COERCE_INT (cdr);
2024          }
2025       else
2026         CHECK_INT (value);
2027       break;
2028
2029 #ifdef MULE
2030     case CHAR_TABLE_TYPE_CATEGORY:
2031       if (!ERRB_EQ (errb, ERROR_ME))
2032         return CATEGORY_TABLE_VALUEP (value);
2033       CHECK_CATEGORY_TABLE_VALUE (value);
2034       break;
2035 #endif /* MULE */
2036
2037     case CHAR_TABLE_TYPE_GENERIC:
2038       return 1;
2039
2040     case CHAR_TABLE_TYPE_DISPLAY:
2041       /* #### fix this */
2042       maybe_signal_simple_error ("Display char tables not yet implemented",
2043                                  value, Qchar_table, errb);
2044       return 0;
2045
2046     case CHAR_TABLE_TYPE_CHAR:
2047       if (!ERRB_EQ (errb, ERROR_ME))
2048         return CHAR_OR_CHAR_INTP (value);
2049       CHECK_CHAR_COERCE_INT (value);
2050       break;
2051
2052     default:
2053       abort ();
2054     }
2055
2056   return 0; /* not reached */
2057 }
2058
2059 static Lisp_Object
2060 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2061 {
2062   switch (type)
2063     {
2064     case CHAR_TABLE_TYPE_SYNTAX:
2065       if (CONSP (value))
2066         {
2067           Lisp_Object car = XCAR (value);
2068           Lisp_Object cdr = XCDR (value);
2069           CHECK_CHAR_COERCE_INT (cdr);
2070           return Fcons (car, cdr);
2071         }
2072       break;
2073     case CHAR_TABLE_TYPE_CHAR:
2074       CHECK_CHAR_COERCE_INT (value);
2075       break;
2076     default:
2077       break;
2078     }
2079   return value;
2080 }
2081
2082 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2083 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2084 */
2085        (value, char_table_type))
2086 {
2087   enum char_table_type type = symbol_to_char_table_type (char_table_type);
2088
2089   return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2090 }
2091
2092 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2093 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2094 */
2095        (value, char_table_type))
2096 {
2097   enum char_table_type type = symbol_to_char_table_type (char_table_type);
2098
2099   check_valid_char_table_value (value, type, ERROR_ME);
2100   return Qnil;
2101 }
2102
2103 /* Assign VAL to all characters in RANGE in char table CT. */
2104
2105 void
2106 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2107                 Lisp_Object val)
2108 {
2109   switch (range->type)
2110     {
2111     case CHARTAB_RANGE_ALL:
2112       /* printf ("put-char-table: range = all\n"); */
2113       fill_char_table (ct, val);
2114       return; /* avoid the duplicate call to update_syntax_table() below,
2115                  since fill_char_table() also did that. */
2116
2117 #ifdef UTF2000
2118     case CHARTAB_RANGE_DEFAULT:
2119       ct->default_value = val;
2120       return;
2121 #endif
2122
2123 #ifdef MULE
2124     case CHARTAB_RANGE_CHARSET:
2125 #ifdef UTF2000
2126       {
2127         Emchar c;
2128         Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2129
2130         /* printf ("put-char-table: range = charset: %d\n",
2131            XCHARSET_LEADING_BYTE (range->charset));
2132         */
2133         if ( CHAR_TABLEP (encoding_table) )
2134           {
2135             for (c = 0; c < 1 << 24; c++)
2136               {
2137                 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2138                                               c)) )
2139                   put_char_id_table_0 (ct, c, val);
2140               }
2141           }
2142         else
2143           {
2144             for (c = 0; c < 1 << 24; c++)
2145               {
2146                 if ( charset_code_point (range->charset, c) >= 0 )
2147                   put_char_id_table_0 (ct, c, val);
2148               }
2149           }
2150       }
2151 #else
2152       if (EQ (range->charset, Vcharset_ascii))
2153         {
2154           int i;
2155           for (i = 0; i < 128; i++)
2156             ct->ascii[i] = val;
2157         }
2158       else if (EQ (range->charset, Vcharset_control_1))
2159         {
2160           int i;
2161           for (i = 128; i < 160; i++)
2162             ct->ascii[i] = val;
2163         }
2164       else
2165         {
2166           int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2167           ct->level1[lb] = val;
2168         }
2169 #endif
2170       break;
2171
2172     case CHARTAB_RANGE_ROW:
2173 #ifdef UTF2000
2174       {
2175         int cell_min, cell_max, i;
2176
2177         i = XCHARSET_CELL_RANGE (range->charset);
2178         cell_min = i >> 8;
2179         cell_max = i & 0xFF;
2180         for (i = cell_min; i <= cell_max; i++)
2181           {
2182             Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2183
2184             if ( charset_code_point (range->charset, ch) >= 0 )
2185               put_char_id_table_0 (ct, ch, val);
2186           }
2187       }
2188 #else
2189       {
2190         Lisp_Char_Table_Entry *cte;
2191         int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2192         /* make sure that there is a separate entry for the row. */
2193         if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2194           ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2195         cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2196         cte->level2[range->row - 32] = val;
2197       }
2198 #endif /* not UTF2000 */
2199       break;
2200 #endif /* MULE */
2201
2202     case CHARTAB_RANGE_CHAR:
2203 #ifdef UTF2000
2204       /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2205       put_char_id_table_0 (ct, range->ch, val);
2206       break;
2207 #elif defined(MULE)
2208       {
2209         Lisp_Object charset;
2210         int byte1, byte2;
2211
2212         BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2213         if (EQ (charset, Vcharset_ascii))
2214           ct->ascii[byte1] = val;
2215         else if (EQ (charset, Vcharset_control_1))
2216           ct->ascii[byte1 + 128] = val;
2217         else
2218           {
2219             Lisp_Char_Table_Entry *cte;
2220             int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2221             /* make sure that there is a separate entry for the row. */
2222             if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2223               ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2224             cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2225             /* now CTE is a char table entry for the charset;
2226                each entry is for a single row (or character of
2227                a one-octet charset). */
2228             if (XCHARSET_DIMENSION (charset) == 1)
2229               cte->level2[byte1 - 32] = val;
2230             else
2231               {
2232                 /* assigning to one character in a two-octet charset. */
2233                 /* make sure that the charset row contains a separate
2234                    entry for each character. */
2235                 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2236                   cte->level2[byte1 - 32] =
2237                     make_char_table_entry (cte->level2[byte1 - 32]);
2238                 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2239                 cte->level2[byte2 - 32] = val;
2240               }
2241           }
2242       }
2243 #else /* not MULE */
2244       ct->ascii[(unsigned char) (range->ch)] = val;
2245       break;
2246 #endif /* not MULE */
2247     }
2248
2249 #ifndef UTF2000
2250   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2251     update_syntax_table (ct);
2252 #endif
2253 }
2254
2255 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2256 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2257
2258 RANGE specifies one or more characters to be affected and should be
2259 one of the following:
2260
2261 -- t (all characters are affected)
2262 -- A charset (only allowed when Mule support is present)
2263 -- A vector of two elements: a two-octet charset and a row number
2264    (only allowed when Mule support is present)
2265 -- A single character
2266
2267 VALUE must be a value appropriate for the type of CHAR-TABLE.
2268 See `valid-char-table-type-p'.
2269 */
2270        (range, value, char_table))
2271 {
2272   Lisp_Char_Table *ct;
2273   struct chartab_range rainj;
2274
2275   CHECK_CHAR_TABLE (char_table);
2276   ct = XCHAR_TABLE (char_table);
2277   check_valid_char_table_value (value, ct->type, ERROR_ME);
2278   decode_char_table_range (range, &rainj);
2279   value = canonicalize_char_table_value (value, ct->type);
2280   put_char_table (ct, &rainj, value);
2281   return Qnil;
2282 }
2283
2284 #ifndef UTF2000
2285 /* Map FN over the ASCII chars in CT. */
2286
2287 static int
2288 map_over_charset_ascii (Lisp_Char_Table *ct,
2289                         int (*fn) (struct chartab_range *range,
2290                                    Lisp_Object val, void *arg),
2291                         void *arg)
2292 {
2293   struct chartab_range rainj;
2294   int i, retval;
2295   int start = 0;
2296 #ifdef MULE
2297   int stop = 128;
2298 #else
2299   int stop = 256;
2300 #endif
2301
2302   rainj.type = CHARTAB_RANGE_CHAR;
2303
2304   for (i = start, retval = 0; i < stop && retval == 0; i++)
2305     {
2306       rainj.ch = (Emchar) i;
2307       retval = (fn) (&rainj, ct->ascii[i], arg);
2308     }
2309
2310   return retval;
2311 }
2312
2313 #ifdef MULE
2314
2315 /* Map FN over the Control-1 chars in CT. */
2316
2317 static int
2318 map_over_charset_control_1 (Lisp_Char_Table *ct,
2319                             int (*fn) (struct chartab_range *range,
2320                                        Lisp_Object val, void *arg),
2321                             void *arg)
2322 {
2323   struct chartab_range rainj;
2324   int i, retval;
2325   int start = 128;
2326   int stop  = start + 32;
2327
2328   rainj.type = CHARTAB_RANGE_CHAR;
2329
2330   for (i = start, retval = 0; i < stop && retval == 0; i++)
2331     {
2332       rainj.ch = (Emchar) (i);
2333       retval = (fn) (&rainj, ct->ascii[i], arg);
2334     }
2335
2336   return retval;
2337 }
2338
2339 /* Map FN over the row ROW of two-byte charset CHARSET.
2340    There must be a separate value for that row in the char table.
2341    CTE specifies the char table entry for CHARSET. */
2342
2343 static int
2344 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2345                       Lisp_Object charset, int row,
2346                       int (*fn) (struct chartab_range *range,
2347                                  Lisp_Object val, void *arg),
2348                       void *arg)
2349 {
2350   Lisp_Object val = cte->level2[row - 32];
2351
2352   if (!CHAR_TABLE_ENTRYP (val))
2353     {
2354       struct chartab_range rainj;
2355
2356       rainj.type = CHARTAB_RANGE_ROW;
2357       rainj.charset = charset;
2358       rainj.row = row;
2359       return (fn) (&rainj, val, arg);
2360     }
2361   else
2362     {
2363       struct chartab_range rainj;
2364       int i, retval;
2365       int charset94_p = (XCHARSET_CHARS (charset) == 94);
2366       int start = charset94_p ?  33 :  32;
2367       int stop  = charset94_p ? 127 : 128;
2368
2369       cte = XCHAR_TABLE_ENTRY (val);
2370
2371       rainj.type = CHARTAB_RANGE_CHAR;
2372
2373       for (i = start, retval = 0; i < stop && retval == 0; i++)
2374         {
2375           rainj.ch = MAKE_CHAR (charset, row, i);
2376           retval = (fn) (&rainj, cte->level2[i - 32], arg);
2377         }
2378       return retval;
2379     }
2380 }
2381
2382
2383 static int
2384 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2385                         int (*fn) (struct chartab_range *range,
2386                                    Lisp_Object val, void *arg),
2387                         void *arg)
2388 {
2389   Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2390   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2391
2392   if (!CHARSETP (charset)
2393       || lb == LEADING_BYTE_ASCII
2394       || lb == LEADING_BYTE_CONTROL_1)
2395     return 0;
2396
2397   if (!CHAR_TABLE_ENTRYP (val))
2398     {
2399       struct chartab_range rainj;
2400
2401       rainj.type = CHARTAB_RANGE_CHARSET;
2402       rainj.charset = charset;
2403       return (fn) (&rainj, val, arg);
2404     }
2405
2406   {
2407     Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2408     int charset94_p = (XCHARSET_CHARS (charset) == 94);
2409     int start = charset94_p ?  33 :  32;
2410     int stop  = charset94_p ? 127 : 128;
2411     int i, retval;
2412
2413     if (XCHARSET_DIMENSION (charset) == 1)
2414       {
2415         struct chartab_range rainj;
2416         rainj.type = CHARTAB_RANGE_CHAR;
2417
2418         for (i = start, retval = 0; i < stop && retval == 0; i++)
2419           {
2420             rainj.ch = MAKE_CHAR (charset, i, 0);
2421             retval = (fn) (&rainj, cte->level2[i - 32], arg);
2422           }
2423       }
2424     else
2425       {
2426         for (i = start, retval = 0; i < stop && retval == 0; i++)
2427           retval = map_over_charset_row (cte, charset, i, fn, arg);
2428       }
2429
2430     return retval;
2431   }
2432 }
2433
2434 #endif /* MULE */
2435 #endif /* not UTF2000 */
2436
2437 #ifdef UTF2000
2438 struct map_char_table_for_charset_arg
2439 {
2440   int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2441   Lisp_Char_Table *ct;
2442   void *arg;
2443 };
2444
2445 static int
2446 map_char_table_for_charset_fun (struct chartab_range *range,
2447                                 Lisp_Object val, void *arg)
2448 {
2449   struct map_char_table_for_charset_arg *closure =
2450     (struct map_char_table_for_charset_arg *) arg;
2451   Lisp_Object ret;
2452
2453   switch (range->type)
2454     {
2455     case CHARTAB_RANGE_ALL:
2456       break;
2457
2458     case CHARTAB_RANGE_DEFAULT:
2459       break;
2460
2461     case CHARTAB_RANGE_CHARSET:
2462       break;
2463
2464     case CHARTAB_RANGE_ROW:
2465       break;
2466
2467     case CHARTAB_RANGE_CHAR:
2468       ret = get_char_table (range->ch, closure->ct);
2469       if (!UNBOUNDP (ret))
2470         return (closure->fn) (range, ret, closure->arg);
2471       break;
2472
2473     default:
2474       abort ();
2475     }
2476
2477   return 0;
2478 }
2479 #endif
2480
2481 /* Map FN (with client data ARG) over range RANGE in char table CT.
2482    Mapping stops the first time FN returns non-zero, and that value
2483    becomes the return value of map_char_table(). */
2484
2485 int
2486 map_char_table (Lisp_Char_Table *ct,
2487                 struct chartab_range *range,
2488                 int (*fn) (struct chartab_range *range,
2489                            Lisp_Object val, void *arg),
2490                 void *arg)
2491 {
2492   switch (range->type)
2493     {
2494     case CHARTAB_RANGE_ALL:
2495 #ifdef UTF2000
2496       if (!UNBOUNDP (ct->default_value))
2497         {
2498           struct chartab_range rainj;
2499           int retval;
2500
2501           rainj.type = CHARTAB_RANGE_DEFAULT;
2502           retval = (fn) (&rainj, ct->default_value, arg);
2503           if (retval != 0)
2504             return retval;
2505         }
2506       if (UINT8_BYTE_TABLE_P (ct->table))
2507         return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table),
2508                                           0, 3, fn, arg);
2509       else if (UINT16_BYTE_TABLE_P (ct->table))
2510         return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table),
2511                                            0, 3, fn, arg);
2512       else if (BYTE_TABLE_P (ct->table))
2513         return map_over_byte_table (XBYTE_TABLE(ct->table),
2514                                     0, 3, fn, arg);
2515       else if (!UNBOUNDP (ct->table))
2516 #if 0
2517         {
2518           struct chartab_range rainj;
2519           int unit = 1 << 30;
2520           Emchar c = 0;
2521           Emchar c1 = c + unit;
2522           int retval;
2523
2524           rainj.type = CHARTAB_RANGE_CHAR;
2525
2526           for (retval = 0; c < c1 && retval == 0; c++)
2527             {
2528               rainj.ch = c;
2529               retval = (fn) (&rainj, ct->table, arg);
2530             }
2531           return retval;
2532         }
2533 #else
2534       return (fn) (range, ct->table, arg);
2535 #endif
2536       return 0;
2537 #else
2538       {
2539         int retval;
2540
2541         retval = map_over_charset_ascii (ct, fn, arg);
2542         if (retval)
2543           return retval;
2544 #ifdef MULE
2545         retval = map_over_charset_control_1 (ct, fn, arg);
2546         if (retval)
2547           return retval;
2548         {
2549           Charset_ID i;
2550           Charset_ID start = MIN_LEADING_BYTE;
2551           Charset_ID stop  = start + NUM_LEADING_BYTES;
2552
2553           for (i = start, retval = 0; i < stop && retval == 0; i++)
2554             {
2555               retval = map_over_other_charset (ct, i, fn, arg);
2556             }
2557         }
2558 #endif /* MULE */
2559         return retval;
2560       }
2561 #endif
2562
2563 #ifdef UTF2000
2564     case CHARTAB_RANGE_DEFAULT:
2565       if (!UNBOUNDP (ct->default_value))
2566         return (fn) (range, ct->default_value, arg);
2567       return 0;
2568 #endif
2569
2570 #ifdef MULE
2571     case CHARTAB_RANGE_CHARSET:
2572 #ifdef UTF2000
2573       {
2574         Lisp_Object encoding_table
2575           = XCHARSET_ENCODING_TABLE (range->charset);
2576
2577         if (!NILP (encoding_table))
2578           {
2579             struct chartab_range rainj;
2580             struct map_char_table_for_charset_arg mcarg;
2581
2582             mcarg.fn = fn;
2583             mcarg.ct = ct;
2584             mcarg.arg = arg;
2585             rainj.type = CHARTAB_RANGE_ALL;
2586             return map_char_table (XCHAR_TABLE(encoding_table),
2587                                    &rainj,
2588                                    &map_char_table_for_charset_fun,
2589                                    &mcarg);
2590           }
2591       }
2592       return 0;
2593 #else
2594       return map_over_other_charset (ct,
2595                                      XCHARSET_LEADING_BYTE (range->charset),
2596                                      fn, arg);
2597 #endif
2598
2599     case CHARTAB_RANGE_ROW:
2600 #ifdef UTF2000
2601       {
2602         int cell_min, cell_max, i;
2603         int retval;
2604         struct chartab_range rainj;
2605
2606         i = XCHARSET_CELL_RANGE (range->charset);
2607         cell_min = i >> 8;
2608         cell_max = i & 0xFF;
2609         rainj.type = CHARTAB_RANGE_CHAR;
2610         for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2611           {
2612             Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2613
2614             if ( charset_code_point (range->charset, ch) >= 0 )
2615               {
2616                 Lisp_Object val
2617                   = get_byte_table (get_byte_table
2618                                     (get_byte_table
2619                                      (get_byte_table
2620                                       (ct->table,
2621                                        (unsigned char)(ch >> 24)),
2622                                       (unsigned char) (ch >> 16)),
2623                                      (unsigned char)  (ch >> 8)),
2624                                     (unsigned char)    ch);
2625
2626                 if (UNBOUNDP (val))
2627                   val = ct->default_value;
2628                 rainj.ch = ch;
2629                 retval = (fn) (&rainj, val, arg);
2630               }
2631           }
2632         return retval;
2633       }
2634 #else
2635       {
2636         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2637                                     - MIN_LEADING_BYTE];
2638         if (!CHAR_TABLE_ENTRYP (val))
2639           {
2640             struct chartab_range rainj;
2641
2642             rainj.type = CHARTAB_RANGE_ROW;
2643             rainj.charset = range->charset;
2644             rainj.row = range->row;
2645             return (fn) (&rainj, val, arg);
2646           }
2647         else
2648           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2649                                        range->charset, range->row,
2650                                        fn, arg);
2651       }
2652 #endif /* not UTF2000 */
2653 #endif /* MULE */
2654
2655     case CHARTAB_RANGE_CHAR:
2656       {
2657         Emchar ch = range->ch;
2658         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2659
2660         if (!UNBOUNDP (val))
2661           {
2662             struct chartab_range rainj;
2663
2664             rainj.type = CHARTAB_RANGE_CHAR;
2665             rainj.ch = ch;
2666             return (fn) (&rainj, val, arg);
2667           }
2668         return 0;
2669       }
2670
2671     default:
2672       abort ();
2673     }
2674
2675   return 0;
2676 }
2677
2678 struct slow_map_char_table_arg
2679 {
2680   Lisp_Object function;
2681   Lisp_Object retval;
2682 };
2683
2684 static int
2685 slow_map_char_table_fun (struct chartab_range *range,
2686                          Lisp_Object val, void *arg)
2687 {
2688   Lisp_Object ranjarg = Qnil;
2689   struct slow_map_char_table_arg *closure =
2690     (struct slow_map_char_table_arg *) arg;
2691
2692   switch (range->type)
2693     {
2694     case CHARTAB_RANGE_ALL:
2695       ranjarg = Qt;
2696       break;
2697
2698 #ifdef UTF2000
2699     case CHARTAB_RANGE_DEFAULT:
2700       ranjarg = Qnil;
2701       break;
2702 #endif
2703
2704 #ifdef MULE
2705     case CHARTAB_RANGE_CHARSET:
2706       ranjarg = XCHARSET_NAME (range->charset);
2707       break;
2708
2709     case CHARTAB_RANGE_ROW:
2710       ranjarg = vector2 (XCHARSET_NAME (range->charset),
2711                          make_int (range->row));
2712       break;
2713 #endif /* MULE */
2714     case CHARTAB_RANGE_CHAR:
2715       ranjarg = make_char (range->ch);
2716       break;
2717     default:
2718       abort ();
2719     }
2720
2721   closure->retval = call2 (closure->function, ranjarg, val);
2722   return !NILP (closure->retval);
2723 }
2724
2725 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2726 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2727 each key and value in the table.
2728
2729 RANGE specifies a subrange to map over and is in the same format as
2730 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
2731 the entire table.
2732 */
2733        (function, char_table, range))
2734 {
2735   Lisp_Char_Table *ct;
2736   struct slow_map_char_table_arg slarg;
2737   struct gcpro gcpro1, gcpro2;
2738   struct chartab_range rainj;
2739
2740   CHECK_CHAR_TABLE (char_table);
2741   ct = XCHAR_TABLE (char_table);
2742   if (NILP (range))
2743     range = Qt;
2744   decode_char_table_range (range, &rainj);
2745   slarg.function = function;
2746   slarg.retval = Qnil;
2747   GCPRO2 (slarg.function, slarg.retval);
2748   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2749   UNGCPRO;
2750
2751   return slarg.retval;
2752 }
2753
2754 \f
2755 /************************************************************************/
2756 /*                         Character Attributes                         */
2757 /************************************************************************/
2758
2759 #ifdef UTF2000
2760
2761 Lisp_Object Vchar_attribute_hash_table;
2762
2763 /* We store the char-attributes in hash tables with the names as the
2764    key and the actual char-id-table object as the value.  Occasionally
2765    we need to use them in a list format.  These routines provide us
2766    with that. */
2767 struct char_attribute_list_closure
2768 {
2769   Lisp_Object *char_attribute_list;
2770 };
2771
2772 static int
2773 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
2774                                    void *char_attribute_list_closure)
2775 {
2776   /* This function can GC */
2777   struct char_attribute_list_closure *calcl
2778     = (struct char_attribute_list_closure*) char_attribute_list_closure;
2779   Lisp_Object *char_attribute_list = calcl->char_attribute_list;
2780
2781   *char_attribute_list = Fcons (key, *char_attribute_list);
2782   return 0;
2783 }
2784
2785 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
2786 Return the list of all existing character attributes except coded-charsets.
2787 */
2788        ())
2789 {
2790   Lisp_Object char_attribute_list = Qnil;
2791   struct gcpro gcpro1;
2792   struct char_attribute_list_closure char_attribute_list_closure;
2793
2794   GCPRO1 (char_attribute_list);
2795   char_attribute_list_closure.char_attribute_list = &char_attribute_list;
2796   elisp_maphash (add_char_attribute_to_list_mapper,
2797                  Vchar_attribute_hash_table,
2798                  &char_attribute_list_closure);
2799   UNGCPRO;
2800   return char_attribute_list;
2801 }
2802
2803 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
2804 Return char-id-table corresponding to ATTRIBUTE.
2805 */
2806        (attribute))
2807 {
2808   return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
2809 }
2810
2811
2812 /* We store the char-id-tables in hash tables with the attributes as
2813    the key and the actual char-id-table object as the value.  Each
2814    char-id-table stores values of an attribute corresponding with
2815    characters.  Occasionally we need to get attributes of a character
2816    in a association-list format.  These routines provide us with
2817    that. */
2818 struct char_attribute_alist_closure
2819 {
2820   Emchar char_id;
2821   Lisp_Object *char_attribute_alist;
2822 };
2823
2824 static int
2825 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
2826                                  void *char_attribute_alist_closure)
2827 {
2828   /* This function can GC */
2829   struct char_attribute_alist_closure *caacl =
2830     (struct char_attribute_alist_closure*) char_attribute_alist_closure;
2831   Lisp_Object ret
2832     = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
2833   if (!UNBOUNDP (ret))
2834     {
2835       Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
2836       *char_attribute_alist
2837         = Fcons (Fcons (key, ret), *char_attribute_alist);
2838     }
2839   return 0;
2840 }
2841
2842 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
2843 Return the alist of attributes of CHARACTER.
2844 */
2845        (character))
2846 {
2847   struct gcpro gcpro1;
2848   struct char_attribute_alist_closure char_attribute_alist_closure;
2849   Lisp_Object alist = Qnil;
2850
2851   CHECK_CHAR (character);
2852
2853   GCPRO1 (alist);
2854   char_attribute_alist_closure.char_id = XCHAR (character);
2855   char_attribute_alist_closure.char_attribute_alist = &alist;
2856   elisp_maphash (add_char_attribute_alist_mapper,
2857                  Vchar_attribute_hash_table,
2858                  &char_attribute_alist_closure);
2859   UNGCPRO;
2860
2861   return alist;
2862 }
2863
2864 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
2865 Return the value of CHARACTER's ATTRIBUTE.
2866 Return DEFAULT-VALUE if the value is not exist.
2867 */
2868        (character, attribute, default_value))
2869 {
2870   Lisp_Object table;
2871
2872   CHECK_CHAR (character);
2873
2874   if (CHARSETP (attribute))
2875     attribute = XCHARSET_NAME (attribute);
2876
2877   table = Fgethash (attribute, Vchar_attribute_hash_table,
2878                     Qunbound);
2879   if (!UNBOUNDP (table))
2880     {
2881       Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
2882                                            XCHAR (character));
2883       if (!UNBOUNDP (ret))
2884         return ret;
2885     }
2886   return default_value;
2887 }
2888
2889 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
2890 Store CHARACTER's ATTRIBUTE with VALUE.
2891 */
2892        (character, attribute, value))
2893 {
2894   Lisp_Object ccs = Ffind_charset (attribute);
2895
2896   if (!NILP (ccs))
2897     {
2898       CHECK_CHAR (character);
2899       value = put_char_ccs_code_point (character, ccs, value);
2900     }
2901   else if (EQ (attribute, Q_decomposition))
2902     {
2903       Lisp_Object seq;
2904
2905       CHECK_CHAR (character);
2906       if (!CONSP (value))
2907         signal_simple_error ("Invalid value for ->decomposition",
2908                              value);
2909
2910       if (CONSP (Fcdr (value)))
2911         {
2912           Lisp_Object rest = value;
2913           Lisp_Object table = Vcharacter_composition_table;
2914           size_t len;
2915           int i = 0;
2916
2917           GET_EXTERNAL_LIST_LENGTH (rest, len);
2918           seq = make_vector (len, Qnil);
2919
2920           while (CONSP (rest))
2921             {
2922               Lisp_Object v = Fcar (rest);
2923               Lisp_Object ntable;
2924               Emchar c
2925                 = to_char_id (v, "Invalid value for ->decomposition", value);
2926
2927               if (c < 0)
2928                 XVECTOR_DATA(seq)[i++] = v;
2929               else
2930                 XVECTOR_DATA(seq)[i++] = make_char (c);
2931               rest = Fcdr (rest);
2932               if (!CONSP (rest))
2933                 {
2934                   put_char_id_table (XCHAR_TABLE(table),
2935                                      make_char (c), character);
2936                   break;
2937                 }
2938               else
2939                 {
2940                   ntable = get_char_id_table (XCHAR_TABLE(table), c);
2941                   if (!CHAR_TABLEP (ntable))
2942                     {
2943                       ntable = make_char_id_table (Qnil);
2944                       put_char_id_table (XCHAR_TABLE(table),
2945                                          make_char (c), ntable);
2946                     }
2947                   table = ntable;
2948                 }
2949             }
2950         }
2951       else
2952         {
2953           Lisp_Object v = Fcar (value);
2954
2955           if (INTP (v))
2956             {
2957               Emchar c = XINT (v);
2958               Lisp_Object ret
2959                 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2960                                      c);
2961
2962               if (NILP (Fmemq (v, ret)))
2963                 {
2964                   put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2965                                      make_char (c), Fcons (character, ret));
2966                 }
2967             }
2968           seq = make_vector (1, v);
2969         }
2970       value = seq;
2971     }
2972   else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
2973     {
2974       Lisp_Object ret;
2975       Emchar c;
2976
2977       CHECK_CHAR (character);
2978       if (!INTP (value))
2979         signal_simple_error ("Invalid value for ->ucs", value);
2980
2981       c = XINT (value);
2982
2983       ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
2984       if (NILP (Fmemq (character, ret)))
2985         {
2986           put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2987                              make_char (c), Fcons (character, ret));
2988         }
2989 #if 0
2990       if (EQ (attribute, Q_ucs))
2991         attribute = Qto_ucs;
2992 #endif
2993     }
2994   {
2995     Lisp_Object table = Fgethash (attribute,
2996                                   Vchar_attribute_hash_table,
2997                                   Qnil);
2998
2999     if (NILP (table))
3000       {
3001         table = make_char_id_table (Qunbound);
3002         Fputhash (attribute, table, Vchar_attribute_hash_table);
3003       }
3004     put_char_id_table (XCHAR_TABLE(table), character, value);
3005     return value;
3006   }
3007 }
3008
3009 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3010 Remove CHARACTER's ATTRIBUTE.
3011 */
3012        (character, attribute))
3013 {
3014   Lisp_Object ccs;
3015
3016   CHECK_CHAR (character);
3017   ccs = Ffind_charset (attribute);
3018   if (!NILP (ccs))
3019     {
3020       return remove_char_ccs (character, ccs);
3021     }
3022   else
3023     {
3024       Lisp_Object table = Fgethash (attribute,
3025                                     Vchar_attribute_hash_table,
3026                                     Qunbound);
3027       if (!UNBOUNDP (table))
3028         {
3029           put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3030           return Qt;
3031         }
3032     }
3033   return Qnil;
3034 }
3035
3036 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3037 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3038 each key and value in the table.
3039
3040 RANGE specifies a subrange to map over and is in the same format as
3041 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
3042 the entire table.
3043 */
3044        (function, attribute, range))
3045 {
3046   Lisp_Object ccs;
3047   Lisp_Char_Table *ct;
3048   struct slow_map_char_table_arg slarg;
3049   struct gcpro gcpro1, gcpro2;
3050   struct chartab_range rainj;
3051
3052   if (!NILP (ccs = Ffind_charset (attribute)))
3053     {
3054       Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3055
3056       if (CHAR_TABLEP (encoding_table))
3057         ct = XCHAR_TABLE (encoding_table);
3058       else
3059         return Qnil;
3060     }
3061   else
3062     {
3063       Lisp_Object table = Fgethash (attribute,
3064                                     Vchar_attribute_hash_table,
3065                                     Qunbound);
3066       if (CHAR_TABLEP (table))
3067         ct = XCHAR_TABLE (table);
3068       else
3069         return Qnil;
3070     }
3071   if (NILP (range))
3072     range = Qt;
3073   decode_char_table_range (range, &rainj);
3074   slarg.function = function;
3075   slarg.retval = Qnil;
3076   GCPRO2 (slarg.function, slarg.retval);
3077   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3078   UNGCPRO;
3079
3080   return slarg.retval;
3081 }
3082
3083 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3084 Store character's ATTRIBUTES.
3085 */
3086        (attributes))
3087 {
3088   Lisp_Object rest = attributes;
3089   Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3090   Lisp_Object character;
3091
3092   if (NILP (code))
3093     {
3094       while (CONSP (rest))
3095         {
3096           Lisp_Object cell = Fcar (rest);
3097           Lisp_Object ccs;
3098
3099           if (!LISTP (cell))
3100             signal_simple_error ("Invalid argument", attributes);
3101           if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3102               && ((XCHARSET_FINAL (ccs) != 0) ||
3103                   (XCHARSET_MAX_CODE (ccs) > 0) ||
3104                   (EQ (ccs, Vcharset_chinese_big5))) )
3105             {
3106               cell = Fcdr (cell);
3107               if (CONSP (cell))
3108                 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3109               else
3110                 character = Fdecode_char (ccs, cell, Qnil);
3111               if (!NILP (character))
3112                 goto setup_attributes;
3113             }
3114           rest = Fcdr (rest);
3115         }
3116       if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3117            (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3118
3119         {
3120           if (!INTP (code))
3121             signal_simple_error ("Invalid argument", attributes);
3122           else
3123             character = make_char (XINT (code) + 0x100000);
3124           goto setup_attributes;
3125         }
3126       return Qnil;
3127     }
3128   else if (!INTP (code))
3129     signal_simple_error ("Invalid argument", attributes);
3130   else
3131     character = make_char (XINT (code));
3132
3133  setup_attributes:
3134   rest = attributes;
3135   while (CONSP (rest))
3136     {
3137       Lisp_Object cell = Fcar (rest);
3138
3139       if (!LISTP (cell))
3140         signal_simple_error ("Invalid argument", attributes);
3141
3142       Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3143       rest = Fcdr (rest);
3144     }
3145   return character;
3146 }
3147
3148 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3149 Retrieve the character of the given ATTRIBUTES.
3150 */
3151        (attributes))
3152 {
3153   Lisp_Object rest = attributes;
3154   Lisp_Object code;
3155
3156   while (CONSP (rest))
3157     {
3158       Lisp_Object cell = Fcar (rest);
3159       Lisp_Object ccs;
3160
3161       if (!LISTP (cell))
3162         signal_simple_error ("Invalid argument", attributes);
3163       if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3164         {
3165           cell = Fcdr (cell);
3166           if (CONSP (cell))
3167             return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3168           else
3169             return Fdecode_char (ccs, cell, Qnil);
3170         }
3171       rest = Fcdr (rest);
3172     }
3173   if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3174        (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3175     {
3176       if (!INTP (code))
3177         signal_simple_error ("Invalid argument", attributes);
3178       else
3179         return make_char (XINT (code) + 0x100000);
3180     }
3181   return Qnil;
3182 }
3183
3184 #endif
3185
3186 \f
3187 /************************************************************************/
3188 /*                         Char table read syntax                       */
3189 /************************************************************************/
3190
3191 static int
3192 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3193                        Error_behavior errb)
3194 {
3195   /* #### should deal with ERRB */
3196   symbol_to_char_table_type (value);
3197   return 1;
3198 }
3199
3200 static int
3201 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3202                        Error_behavior errb)
3203 {
3204   Lisp_Object rest;
3205
3206   /* #### should deal with ERRB */
3207   EXTERNAL_LIST_LOOP (rest, value)
3208     {
3209       Lisp_Object range = XCAR (rest);
3210       struct chartab_range dummy;
3211
3212       rest = XCDR (rest);
3213       if (!CONSP (rest))
3214         signal_simple_error ("Invalid list format", value);
3215       if (CONSP (range))
3216         {
3217           if (!CONSP (XCDR (range))
3218               || !NILP (XCDR (XCDR (range))))
3219             signal_simple_error ("Invalid range format", range);
3220           decode_char_table_range (XCAR (range), &dummy);
3221           decode_char_table_range (XCAR (XCDR (range)), &dummy);
3222         }
3223       else
3224         decode_char_table_range (range, &dummy);
3225     }
3226
3227   return 1;
3228 }
3229
3230 static Lisp_Object
3231 chartab_instantiate (Lisp_Object data)
3232 {
3233   Lisp_Object chartab;
3234   Lisp_Object type = Qgeneric;
3235   Lisp_Object dataval = Qnil;
3236
3237   while (!NILP (data))
3238     {
3239       Lisp_Object keyw = Fcar (data);
3240       Lisp_Object valw;
3241
3242       data = Fcdr (data);
3243       valw = Fcar (data);
3244       data = Fcdr (data);
3245       if (EQ (keyw, Qtype))
3246         type = valw;
3247       else if (EQ (keyw, Qdata))
3248         dataval = valw;
3249     }
3250
3251   chartab = Fmake_char_table (type);
3252
3253   data = dataval;
3254   while (!NILP (data))
3255     {
3256       Lisp_Object range = Fcar (data);
3257       Lisp_Object val = Fcar (Fcdr (data));
3258
3259       data = Fcdr (Fcdr (data));
3260       if (CONSP (range))
3261         {
3262           if (CHAR_OR_CHAR_INTP (XCAR (range)))
3263             {
3264               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3265               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3266               Emchar i;
3267
3268               for (i = first; i <= last; i++)
3269                  Fput_char_table (make_char (i), val, chartab);
3270             }
3271           else
3272             abort ();
3273         }
3274       else
3275         Fput_char_table (range, val, chartab);
3276     }
3277
3278   return chartab;
3279 }
3280
3281 #ifdef MULE
3282
3283 \f
3284 /************************************************************************/
3285 /*                     Category Tables, specifically                    */
3286 /************************************************************************/
3287
3288 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3289 Return t if OBJECT is a category table.
3290 A category table is a type of char table used for keeping track of
3291 categories.  Categories are used for classifying characters for use
3292 in regexps -- you can refer to a category rather than having to use
3293 a complicated [] expression (and category lookups are significantly
3294 faster).
3295
3296 There are 95 different categories available, one for each printable
3297 character (including space) in the ASCII charset.  Each category
3298 is designated by one such character, called a "category designator".
3299 They are specified in a regexp using the syntax "\\cX", where X is
3300 a category designator.
3301
3302 A category table specifies, for each character, the categories that
3303 the character is in.  Note that a character can be in more than one
3304 category.  More specifically, a category table maps from a character
3305 to either the value nil (meaning the character is in no categories)
3306 or a 95-element bit vector, specifying for each of the 95 categories
3307 whether the character is in that category.
3308
3309 Special Lisp functions are provided that abstract this, so you do not
3310 have to directly manipulate bit vectors.
3311 */
3312        (object))
3313 {
3314   return (CHAR_TABLEP (object) &&
3315           XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3316     Qt : Qnil;
3317 }
3318
3319 static Lisp_Object
3320 check_category_table (Lisp_Object object, Lisp_Object default_)
3321 {
3322   if (NILP (object))
3323     object = default_;
3324   while (NILP (Fcategory_table_p (object)))
3325     object = wrong_type_argument (Qcategory_table_p, object);
3326   return object;
3327 }
3328
3329 int
3330 check_category_char (Emchar ch, Lisp_Object table,
3331                      unsigned int designator, unsigned int not_p)
3332 {
3333   REGISTER Lisp_Object temp;
3334   Lisp_Char_Table *ctbl;
3335 #ifdef ERROR_CHECK_TYPECHECK
3336   if (NILP (Fcategory_table_p (table)))
3337     signal_simple_error ("Expected category table", table);
3338 #endif
3339   ctbl = XCHAR_TABLE (table);
3340   temp = get_char_table (ch, ctbl);
3341   if (NILP (temp))
3342     return not_p;
3343
3344   designator -= ' ';
3345   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3346 }
3347
3348 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3349 Return t if category of the character at POSITION includes DESIGNATOR.
3350 Optional third arg BUFFER specifies which buffer to use, and defaults
3351 to the current buffer.
3352 Optional fourth arg CATEGORY-TABLE specifies the category table to
3353 use, and defaults to BUFFER's category table.
3354 */
3355        (position, designator, buffer, category_table))
3356 {
3357   Lisp_Object ctbl;
3358   Emchar ch;
3359   unsigned int des;
3360   struct buffer *buf = decode_buffer (buffer, 0);
3361
3362   CHECK_INT (position);
3363   CHECK_CATEGORY_DESIGNATOR (designator);
3364   des = XCHAR (designator);
3365   ctbl = check_category_table (category_table, Vstandard_category_table);
3366   ch = BUF_FETCH_CHAR (buf, XINT (position));
3367   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3368 }
3369
3370 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3371 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3372 Optional third arg CATEGORY-TABLE specifies the category table to use,
3373 and defaults to the standard category table.
3374 */
3375        (character, designator, category_table))
3376 {
3377   Lisp_Object ctbl;
3378   Emchar ch;
3379   unsigned int des;
3380
3381   CHECK_CATEGORY_DESIGNATOR (designator);
3382   des = XCHAR (designator);
3383   CHECK_CHAR (character);
3384   ch = XCHAR (character);
3385   ctbl = check_category_table (category_table, Vstandard_category_table);
3386   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3387 }
3388
3389 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3390 Return BUFFER's current category table.
3391 BUFFER defaults to the current buffer.
3392 */
3393        (buffer))
3394 {
3395   return decode_buffer (buffer, 0)->category_table;
3396 }
3397
3398 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3399 Return the standard category table.
3400 This is the one used for new buffers.
3401 */
3402        ())
3403 {
3404   return Vstandard_category_table;
3405 }
3406
3407 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3408 Return a new category table which is a copy of CATEGORY-TABLE.
3409 CATEGORY-TABLE defaults to the standard category table.
3410 */
3411        (category_table))
3412 {
3413   if (NILP (Vstandard_category_table))
3414     return Fmake_char_table (Qcategory);
3415
3416   category_table =
3417     check_category_table (category_table, Vstandard_category_table);
3418   return Fcopy_char_table (category_table);
3419 }
3420
3421 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3422 Select CATEGORY-TABLE as the new category table for BUFFER.
3423 BUFFER defaults to the current buffer if omitted.
3424 */
3425        (category_table, buffer))
3426 {
3427   struct buffer *buf = decode_buffer (buffer, 0);
3428   category_table = check_category_table (category_table, Qnil);
3429   buf->category_table = category_table;
3430   /* Indicate that this buffer now has a specified category table.  */
3431   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3432   return category_table;
3433 }
3434
3435 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3436 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3437 */
3438        (object))
3439 {
3440   return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3441 }
3442
3443 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3444 Return t if OBJECT is a category table value.
3445 Valid values are nil or a bit vector of size 95.
3446 */
3447        (object))
3448 {
3449   return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3450 }
3451
3452
3453 #define CATEGORYP(x) \
3454   (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3455
3456 #define CATEGORY_SET(c)                                         \
3457   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3458
3459 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3460    The faster version of `!NILP (Faref (category_set, category))'.  */
3461 #define CATEGORY_MEMBER(category, category_set)                 \
3462   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3463
3464 /* Return 1 if there is a word boundary between two word-constituent
3465    characters C1 and C2 if they appear in this order, else return 0.
3466    Use the macro WORD_BOUNDARY_P instead of calling this function
3467    directly.  */
3468
3469 int word_boundary_p (Emchar c1, Emchar c2);
3470 int
3471 word_boundary_p (Emchar c1, Emchar c2)
3472 {
3473   Lisp_Object category_set1, category_set2;
3474   Lisp_Object tail;
3475   int default_result;
3476
3477 #if 0
3478   if (COMPOSITE_CHAR_P (c1))
3479     c1 = cmpchar_component (c1, 0, 1);
3480   if (COMPOSITE_CHAR_P (c2))
3481     c2 = cmpchar_component (c2, 0, 1);
3482 #endif
3483
3484   if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3485     {
3486       tail = Vword_separating_categories;
3487       default_result = 0;
3488     }
3489   else
3490     {
3491       tail = Vword_combining_categories;
3492       default_result = 1;
3493     }
3494
3495   category_set1 = CATEGORY_SET (c1);
3496   if (NILP (category_set1))
3497     return default_result;
3498   category_set2 = CATEGORY_SET (c2);
3499   if (NILP (category_set2))
3500     return default_result;
3501
3502   for (; CONSP (tail); tail = XCONS (tail)->cdr)
3503     {
3504       Lisp_Object elt = XCONS(tail)->car;
3505
3506       if (CONSP (elt)
3507           && CATEGORYP (XCONS (elt)->car)
3508           && CATEGORYP (XCONS (elt)->cdr)
3509           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3510           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3511         return !default_result;
3512     }
3513   return default_result;
3514 }
3515 #endif /* MULE */
3516
3517 \f
3518 void
3519 syms_of_chartab (void)
3520 {
3521 #ifdef UTF2000
3522   INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3523   INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3524   INIT_LRECORD_IMPLEMENTATION (byte_table);
3525
3526   defsymbol (&Qto_ucs,                  "=>ucs");
3527   defsymbol (&Q_ucs,                    "->ucs");
3528   defsymbol (&Q_decomposition,          "->decomposition");
3529   defsymbol (&Qcompat,                  "compat");
3530   defsymbol (&Qisolated,                "isolated");
3531   defsymbol (&Qinitial,                 "initial");
3532   defsymbol (&Qmedial,                  "medial");
3533   defsymbol (&Qfinal,                   "final");
3534   defsymbol (&Qvertical,                "vertical");
3535   defsymbol (&QnoBreak,                 "noBreak");
3536   defsymbol (&Qfraction,                "fraction");
3537   defsymbol (&Qsuper,                   "super");
3538   defsymbol (&Qsub,                     "sub");
3539   defsymbol (&Qcircle,                  "circle");
3540   defsymbol (&Qsquare,                  "square");
3541   defsymbol (&Qwide,                    "wide");
3542   defsymbol (&Qnarrow,                  "narrow");
3543   defsymbol (&Qsmall,                   "small");
3544   defsymbol (&Qfont,                    "font");
3545
3546   DEFSUBR (Fchar_attribute_list);
3547   DEFSUBR (Ffind_char_attribute_table);
3548   DEFSUBR (Fchar_attribute_alist);
3549   DEFSUBR (Fget_char_attribute);
3550   DEFSUBR (Fput_char_attribute);
3551   DEFSUBR (Fremove_char_attribute);
3552   DEFSUBR (Fmap_char_attribute);
3553   DEFSUBR (Fdefine_char);
3554   DEFSUBR (Ffind_char);
3555   DEFSUBR (Fchar_variants);
3556
3557   DEFSUBR (Fget_composite_char);
3558 #endif
3559
3560   INIT_LRECORD_IMPLEMENTATION (char_table);
3561
3562 #ifdef MULE
3563 #ifndef UTF2000
3564   INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3565 #endif
3566
3567   defsymbol (&Qcategory_table_p, "category-table-p");
3568   defsymbol (&Qcategory_designator_p, "category-designator-p");
3569   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3570 #endif /* MULE */
3571
3572   defsymbol (&Qchar_table, "char-table");
3573   defsymbol (&Qchar_tablep, "char-table-p");
3574
3575   DEFSUBR (Fchar_table_p);
3576   DEFSUBR (Fchar_table_type_list);
3577   DEFSUBR (Fvalid_char_table_type_p);
3578   DEFSUBR (Fchar_table_type);
3579   DEFSUBR (Freset_char_table);
3580   DEFSUBR (Fmake_char_table);
3581   DEFSUBR (Fcopy_char_table);
3582   DEFSUBR (Fget_char_table);
3583   DEFSUBR (Fget_range_char_table);
3584   DEFSUBR (Fvalid_char_table_value_p);
3585   DEFSUBR (Fcheck_valid_char_table_value);
3586   DEFSUBR (Fput_char_table);
3587   DEFSUBR (Fmap_char_table);
3588
3589 #ifdef MULE
3590   DEFSUBR (Fcategory_table_p);
3591   DEFSUBR (Fcategory_table);
3592   DEFSUBR (Fstandard_category_table);
3593   DEFSUBR (Fcopy_category_table);
3594   DEFSUBR (Fset_category_table);
3595   DEFSUBR (Fcheck_category_at);
3596   DEFSUBR (Fchar_in_category_p);
3597   DEFSUBR (Fcategory_designator_p);
3598   DEFSUBR (Fcategory_table_value_p);
3599 #endif /* MULE */
3600
3601 }
3602
3603 void
3604 vars_of_chartab (void)
3605 {
3606 #ifdef UTF2000
3607   Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)");
3608   DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3609 Version number of XEmacs UTF-2000.
3610 */ );
3611
3612   staticpro (&Vcharacter_composition_table);
3613   Vcharacter_composition_table = make_char_id_table (Qnil);
3614
3615   staticpro (&Vcharacter_variant_table);
3616   Vcharacter_variant_table = make_char_id_table (Qnil);
3617 #endif
3618   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
3619   Vall_syntax_tables = Qnil;
3620   dump_add_weak_object_chain (&Vall_syntax_tables);
3621 }
3622
3623 void
3624 structure_type_create_chartab (void)
3625 {
3626   struct structure_type *st;
3627
3628   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3629
3630   define_structure_type_keyword (st, Qtype, chartab_type_validate);
3631   define_structure_type_keyword (st, Qdata, chartab_data_validate);
3632 }
3633
3634 void
3635 complex_vars_of_chartab (void)
3636 {
3637 #ifdef UTF2000
3638   staticpro (&Vchar_attribute_hash_table);
3639   Vchar_attribute_hash_table
3640     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3641 #endif /* UTF2000 */
3642 #ifdef MULE
3643   /* Set this now, so first buffer creation can refer to it. */
3644   /* Make it nil before calling copy-category-table
3645      so that copy-category-table will know not to try to copy from garbage */
3646   Vstandard_category_table = Qnil;
3647   Vstandard_category_table = Fcopy_category_table (Qnil);
3648   staticpro (&Vstandard_category_table);
3649
3650   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3651 List of pair (cons) of categories to determine word boundary.
3652
3653 Emacs treats a sequence of word constituent characters as a single
3654 word (i.e. finds no word boundary between them) iff they belongs to
3655 the same charset.  But, exceptions are allowed in the following cases.
3656
3657 \(1) The case that characters are in different charsets is controlled
3658 by the variable `word-combining-categories'.
3659
3660 Emacs finds no word boundary between characters of different charsets
3661 if they have categories matching some element of this list.
3662
3663 More precisely, if an element of this list is a cons of category CAT1
3664 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3665 C2 which has CAT2, there's no word boundary between C1 and C2.
3666
3667 For instance, to tell that ASCII characters and Latin-1 characters can
3668 form a single word, the element `(?l . ?l)' should be in this list
3669 because both characters have the category `l' (Latin characters).
3670
3671 \(2) The case that character are in the same charset is controlled by
3672 the variable `word-separating-categories'.
3673
3674 Emacs find a word boundary between characters of the same charset
3675 if they have categories matching some element of this list.
3676
3677 More precisely, if an element of this list is a cons of category CAT1
3678 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3679 C2 which has CAT2, there's a word boundary between C1 and C2.
3680
3681 For instance, to tell that there's a word boundary between Japanese
3682 Hiragana and Japanese Kanji (both are in the same charset), the
3683 element `(?H . ?C) should be in this list.
3684 */ );
3685
3686   Vword_combining_categories = Qnil;
3687
3688   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3689 List of pair (cons) of categories to determine word boundary.
3690 See the documentation of the variable `word-combining-categories'.
3691 */ );
3692
3693   Vword_separating_categories = Qnil;
3694 #endif /* MULE */
3695 }