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_UCS_MAX (ccs) > 0)) )
3104             {
3105               cell = Fcdr (cell);
3106               if (CONSP (cell))
3107                 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3108               else
3109                 character = Fdecode_char (ccs, cell, Qnil);
3110               if (!NILP (character))
3111                 goto setup_attributes;
3112             }
3113           rest = Fcdr (rest);
3114         }
3115       if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3116            (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3117
3118         {
3119           if (!INTP (code))
3120             signal_simple_error ("Invalid argument", attributes);
3121           else
3122             character = make_char (XINT (code) + 0x100000);
3123           goto setup_attributes;
3124         }
3125       return Qnil;
3126     }
3127   else if (!INTP (code))
3128     signal_simple_error ("Invalid argument", attributes);
3129   else
3130     character = make_char (XINT (code));
3131
3132  setup_attributes:
3133   rest = attributes;
3134   while (CONSP (rest))
3135     {
3136       Lisp_Object cell = Fcar (rest);
3137
3138       if (!LISTP (cell))
3139         signal_simple_error ("Invalid argument", attributes);
3140
3141       Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3142       rest = Fcdr (rest);
3143     }
3144   return character;
3145 }
3146
3147 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3148 Retrieve the character of the given ATTRIBUTES.
3149 */
3150        (attributes))
3151 {
3152   Lisp_Object rest = attributes;
3153   Lisp_Object code;
3154
3155   while (CONSP (rest))
3156     {
3157       Lisp_Object cell = Fcar (rest);
3158       Lisp_Object ccs;
3159
3160       if (!LISTP (cell))
3161         signal_simple_error ("Invalid argument", attributes);
3162       if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3163         {
3164           cell = Fcdr (cell);
3165           if (CONSP (cell))
3166             return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3167           else
3168             return Fdecode_char (ccs, cell, Qnil);
3169         }
3170       rest = Fcdr (rest);
3171     }
3172   if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3173        (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3174     {
3175       if (!INTP (code))
3176         signal_simple_error ("Invalid argument", attributes);
3177       else
3178         return make_char (XINT (code) + 0x100000);
3179     }
3180   return Qnil;
3181 }
3182
3183 #endif
3184
3185 \f
3186 /************************************************************************/
3187 /*                         Char table read syntax                       */
3188 /************************************************************************/
3189
3190 static int
3191 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3192                        Error_behavior errb)
3193 {
3194   /* #### should deal with ERRB */
3195   symbol_to_char_table_type (value);
3196   return 1;
3197 }
3198
3199 static int
3200 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3201                        Error_behavior errb)
3202 {
3203   Lisp_Object rest;
3204
3205   /* #### should deal with ERRB */
3206   EXTERNAL_LIST_LOOP (rest, value)
3207     {
3208       Lisp_Object range = XCAR (rest);
3209       struct chartab_range dummy;
3210
3211       rest = XCDR (rest);
3212       if (!CONSP (rest))
3213         signal_simple_error ("Invalid list format", value);
3214       if (CONSP (range))
3215         {
3216           if (!CONSP (XCDR (range))
3217               || !NILP (XCDR (XCDR (range))))
3218             signal_simple_error ("Invalid range format", range);
3219           decode_char_table_range (XCAR (range), &dummy);
3220           decode_char_table_range (XCAR (XCDR (range)), &dummy);
3221         }
3222       else
3223         decode_char_table_range (range, &dummy);
3224     }
3225
3226   return 1;
3227 }
3228
3229 static Lisp_Object
3230 chartab_instantiate (Lisp_Object data)
3231 {
3232   Lisp_Object chartab;
3233   Lisp_Object type = Qgeneric;
3234   Lisp_Object dataval = Qnil;
3235
3236   while (!NILP (data))
3237     {
3238       Lisp_Object keyw = Fcar (data);
3239       Lisp_Object valw;
3240
3241       data = Fcdr (data);
3242       valw = Fcar (data);
3243       data = Fcdr (data);
3244       if (EQ (keyw, Qtype))
3245         type = valw;
3246       else if (EQ (keyw, Qdata))
3247         dataval = valw;
3248     }
3249
3250   chartab = Fmake_char_table (type);
3251
3252   data = dataval;
3253   while (!NILP (data))
3254     {
3255       Lisp_Object range = Fcar (data);
3256       Lisp_Object val = Fcar (Fcdr (data));
3257
3258       data = Fcdr (Fcdr (data));
3259       if (CONSP (range))
3260         {
3261           if (CHAR_OR_CHAR_INTP (XCAR (range)))
3262             {
3263               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3264               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3265               Emchar i;
3266
3267               for (i = first; i <= last; i++)
3268                  Fput_char_table (make_char (i), val, chartab);
3269             }
3270           else
3271             abort ();
3272         }
3273       else
3274         Fput_char_table (range, val, chartab);
3275     }
3276
3277   return chartab;
3278 }
3279
3280 #ifdef MULE
3281
3282 \f
3283 /************************************************************************/
3284 /*                     Category Tables, specifically                    */
3285 /************************************************************************/
3286
3287 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3288 Return t if OBJECT is a category table.
3289 A category table is a type of char table used for keeping track of
3290 categories.  Categories are used for classifying characters for use
3291 in regexps -- you can refer to a category rather than having to use
3292 a complicated [] expression (and category lookups are significantly
3293 faster).
3294
3295 There are 95 different categories available, one for each printable
3296 character (including space) in the ASCII charset.  Each category
3297 is designated by one such character, called a "category designator".
3298 They are specified in a regexp using the syntax "\\cX", where X is
3299 a category designator.
3300
3301 A category table specifies, for each character, the categories that
3302 the character is in.  Note that a character can be in more than one
3303 category.  More specifically, a category table maps from a character
3304 to either the value nil (meaning the character is in no categories)
3305 or a 95-element bit vector, specifying for each of the 95 categories
3306 whether the character is in that category.
3307
3308 Special Lisp functions are provided that abstract this, so you do not
3309 have to directly manipulate bit vectors.
3310 */
3311        (object))
3312 {
3313   return (CHAR_TABLEP (object) &&
3314           XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3315     Qt : Qnil;
3316 }
3317
3318 static Lisp_Object
3319 check_category_table (Lisp_Object object, Lisp_Object default_)
3320 {
3321   if (NILP (object))
3322     object = default_;
3323   while (NILP (Fcategory_table_p (object)))
3324     object = wrong_type_argument (Qcategory_table_p, object);
3325   return object;
3326 }
3327
3328 int
3329 check_category_char (Emchar ch, Lisp_Object table,
3330                      unsigned int designator, unsigned int not)
3331 {
3332   REGISTER Lisp_Object temp;
3333   Lisp_Char_Table *ctbl;
3334 #ifdef ERROR_CHECK_TYPECHECK
3335   if (NILP (Fcategory_table_p (table)))
3336     signal_simple_error ("Expected category table", table);
3337 #endif
3338   ctbl = XCHAR_TABLE (table);
3339   temp = get_char_table (ch, ctbl);
3340   if (NILP (temp))
3341     return not;
3342
3343   designator -= ' ';
3344   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
3345 }
3346
3347 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3348 Return t if category of the character at POSITION includes DESIGNATOR.
3349 Optional third arg BUFFER specifies which buffer to use, and defaults
3350 to the current buffer.
3351 Optional fourth arg CATEGORY-TABLE specifies the category table to
3352 use, and defaults to BUFFER's category table.
3353 */
3354        (position, designator, buffer, category_table))
3355 {
3356   Lisp_Object ctbl;
3357   Emchar ch;
3358   unsigned int des;
3359   struct buffer *buf = decode_buffer (buffer, 0);
3360
3361   CHECK_INT (position);
3362   CHECK_CATEGORY_DESIGNATOR (designator);
3363   des = XCHAR (designator);
3364   ctbl = check_category_table (category_table, Vstandard_category_table);
3365   ch = BUF_FETCH_CHAR (buf, XINT (position));
3366   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3367 }
3368
3369 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3370 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3371 Optional third arg CATEGORY-TABLE specifies the category table to use,
3372 and defaults to the standard category table.
3373 */
3374        (character, designator, category_table))
3375 {
3376   Lisp_Object ctbl;
3377   Emchar ch;
3378   unsigned int des;
3379
3380   CHECK_CATEGORY_DESIGNATOR (designator);
3381   des = XCHAR (designator);
3382   CHECK_CHAR (character);
3383   ch = XCHAR (character);
3384   ctbl = check_category_table (category_table, Vstandard_category_table);
3385   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3386 }
3387
3388 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3389 Return BUFFER's current category table.
3390 BUFFER defaults to the current buffer.
3391 */
3392        (buffer))
3393 {
3394   return decode_buffer (buffer, 0)->category_table;
3395 }
3396
3397 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3398 Return the standard category table.
3399 This is the one used for new buffers.
3400 */
3401        ())
3402 {
3403   return Vstandard_category_table;
3404 }
3405
3406 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3407 Return a new category table which is a copy of CATEGORY-TABLE.
3408 CATEGORY-TABLE defaults to the standard category table.
3409 */
3410        (category_table))
3411 {
3412   if (NILP (Vstandard_category_table))
3413     return Fmake_char_table (Qcategory);
3414
3415   category_table =
3416     check_category_table (category_table, Vstandard_category_table);
3417   return Fcopy_char_table (category_table);
3418 }
3419
3420 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3421 Select CATEGORY-TABLE as the new category table for BUFFER.
3422 BUFFER defaults to the current buffer if omitted.
3423 */
3424        (category_table, buffer))
3425 {
3426   struct buffer *buf = decode_buffer (buffer, 0);
3427   category_table = check_category_table (category_table, Qnil);
3428   buf->category_table = category_table;
3429   /* Indicate that this buffer now has a specified category table.  */
3430   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3431   return category_table;
3432 }
3433
3434 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3435 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3436 */
3437        (object))
3438 {
3439   return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3440 }
3441
3442 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3443 Return t if OBJECT is a category table value.
3444 Valid values are nil or a bit vector of size 95.
3445 */
3446        (object))
3447 {
3448   return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3449 }
3450
3451
3452 #define CATEGORYP(x) \
3453   (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3454
3455 #define CATEGORY_SET(c)                                         \
3456   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3457
3458 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3459    The faster version of `!NILP (Faref (category_set, category))'.  */
3460 #define CATEGORY_MEMBER(category, category_set)                 \
3461   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3462
3463 /* Return 1 if there is a word boundary between two word-constituent
3464    characters C1 and C2 if they appear in this order, else return 0.
3465    Use the macro WORD_BOUNDARY_P instead of calling this function
3466    directly.  */
3467
3468 int word_boundary_p (Emchar c1, Emchar c2);
3469 int
3470 word_boundary_p (Emchar c1, Emchar c2)
3471 {
3472   Lisp_Object category_set1, category_set2;
3473   Lisp_Object tail;
3474   int default_result;
3475
3476 #if 0
3477   if (COMPOSITE_CHAR_P (c1))
3478     c1 = cmpchar_component (c1, 0, 1);
3479   if (COMPOSITE_CHAR_P (c2))
3480     c2 = cmpchar_component (c2, 0, 1);
3481 #endif
3482
3483   if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3484     {
3485       tail = Vword_separating_categories;
3486       default_result = 0;
3487     }
3488   else
3489     {
3490       tail = Vword_combining_categories;
3491       default_result = 1;
3492     }
3493
3494   category_set1 = CATEGORY_SET (c1);
3495   if (NILP (category_set1))
3496     return default_result;
3497   category_set2 = CATEGORY_SET (c2);
3498   if (NILP (category_set2))
3499     return default_result;
3500
3501   for (; CONSP (tail); tail = XCONS (tail)->cdr)
3502     {
3503       Lisp_Object elt = XCONS(tail)->car;
3504
3505       if (CONSP (elt)
3506           && CATEGORYP (XCONS (elt)->car)
3507           && CATEGORYP (XCONS (elt)->cdr)
3508           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3509           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3510         return !default_result;
3511     }
3512   return default_result;
3513 }
3514 #endif /* MULE */
3515
3516 \f
3517 void
3518 syms_of_chartab (void)
3519 {
3520 #ifdef UTF2000
3521   INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3522   INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3523   INIT_LRECORD_IMPLEMENTATION (byte_table);
3524
3525   defsymbol (&Qto_ucs,                  "=>ucs");
3526   defsymbol (&Q_ucs,                    "->ucs");
3527   defsymbol (&Q_decomposition,          "->decomposition");
3528   defsymbol (&Qcompat,                  "compat");
3529   defsymbol (&Qisolated,                "isolated");
3530   defsymbol (&Qinitial,                 "initial");
3531   defsymbol (&Qmedial,                  "medial");
3532   defsymbol (&Qfinal,                   "final");
3533   defsymbol (&Qvertical,                "vertical");
3534   defsymbol (&QnoBreak,                 "noBreak");
3535   defsymbol (&Qfraction,                "fraction");
3536   defsymbol (&Qsuper,                   "super");
3537   defsymbol (&Qsub,                     "sub");
3538   defsymbol (&Qcircle,                  "circle");
3539   defsymbol (&Qsquare,                  "square");
3540   defsymbol (&Qwide,                    "wide");
3541   defsymbol (&Qnarrow,                  "narrow");
3542   defsymbol (&Qsmall,                   "small");
3543   defsymbol (&Qfont,                    "font");
3544
3545   DEFSUBR (Fchar_attribute_list);
3546   DEFSUBR (Ffind_char_attribute_table);
3547   DEFSUBR (Fchar_attribute_alist);
3548   DEFSUBR (Fget_char_attribute);
3549   DEFSUBR (Fput_char_attribute);
3550   DEFSUBR (Fremove_char_attribute);
3551   DEFSUBR (Fmap_char_attribute);
3552   DEFSUBR (Fdefine_char);
3553   DEFSUBR (Ffind_char);
3554   DEFSUBR (Fchar_variants);
3555
3556   DEFSUBR (Fget_composite_char);
3557 #endif
3558
3559   INIT_LRECORD_IMPLEMENTATION (char_table);
3560
3561 #ifdef MULE
3562 #ifndef UTF2000
3563   INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3564 #endif
3565
3566   defsymbol (&Qcategory_table_p, "category-table-p");
3567   defsymbol (&Qcategory_designator_p, "category-designator-p");
3568   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3569 #endif /* MULE */
3570
3571   defsymbol (&Qchar_table, "char-table");
3572   defsymbol (&Qchar_tablep, "char-table-p");
3573
3574   DEFSUBR (Fchar_table_p);
3575   DEFSUBR (Fchar_table_type_list);
3576   DEFSUBR (Fvalid_char_table_type_p);
3577   DEFSUBR (Fchar_table_type);
3578   DEFSUBR (Freset_char_table);
3579   DEFSUBR (Fmake_char_table);
3580   DEFSUBR (Fcopy_char_table);
3581   DEFSUBR (Fget_char_table);
3582   DEFSUBR (Fget_range_char_table);
3583   DEFSUBR (Fvalid_char_table_value_p);
3584   DEFSUBR (Fcheck_valid_char_table_value);
3585   DEFSUBR (Fput_char_table);
3586   DEFSUBR (Fmap_char_table);
3587
3588 #ifdef MULE
3589   DEFSUBR (Fcategory_table_p);
3590   DEFSUBR (Fcategory_table);
3591   DEFSUBR (Fstandard_category_table);
3592   DEFSUBR (Fcopy_category_table);
3593   DEFSUBR (Fset_category_table);
3594   DEFSUBR (Fcheck_category_at);
3595   DEFSUBR (Fchar_in_category_p);
3596   DEFSUBR (Fcategory_designator_p);
3597   DEFSUBR (Fcategory_table_value_p);
3598 #endif /* MULE */
3599
3600 }
3601
3602 void
3603 vars_of_chartab (void)
3604 {
3605 #ifdef UTF2000
3606   Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)");
3607   DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3608 Version number of XEmacs UTF-2000.
3609 */ );
3610
3611   staticpro (&Vcharacter_composition_table);
3612   Vcharacter_composition_table = make_char_id_table (Qnil);
3613
3614   staticpro (&Vcharacter_variant_table);
3615   Vcharacter_variant_table = make_char_id_table (Qnil);
3616 #endif
3617   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
3618   Vall_syntax_tables = Qnil;
3619   dump_add_weak_object_chain (&Vall_syntax_tables);
3620 }
3621
3622 void
3623 structure_type_create_chartab (void)
3624 {
3625   struct structure_type *st;
3626
3627   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3628
3629   define_structure_type_keyword (st, Qtype, chartab_type_validate);
3630   define_structure_type_keyword (st, Qdata, chartab_data_validate);
3631 }
3632
3633 void
3634 complex_vars_of_chartab (void)
3635 {
3636 #ifdef UTF2000
3637   staticpro (&Vchar_attribute_hash_table);
3638   Vchar_attribute_hash_table
3639     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3640 #endif /* UTF2000 */
3641 #ifdef MULE
3642   /* Set this now, so first buffer creation can refer to it. */
3643   /* Make it nil before calling copy-category-table
3644      so that copy-category-table will know not to try to copy from garbage */
3645   Vstandard_category_table = Qnil;
3646   Vstandard_category_table = Fcopy_category_table (Qnil);
3647   staticpro (&Vstandard_category_table);
3648
3649   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3650 List of pair (cons) of categories to determine word boundary.
3651
3652 Emacs treats a sequence of word constituent characters as a single
3653 word (i.e. finds no word boundary between them) iff they belongs to
3654 the same charset.  But, exceptions are allowed in the following cases.
3655
3656 \(1) The case that characters are in different charsets is controlled
3657 by the variable `word-combining-categories'.
3658
3659 Emacs finds no word boundary between characters of different charsets
3660 if they have categories matching some element of this list.
3661
3662 More precisely, if an element of this list is a cons of category CAT1
3663 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3664 C2 which has CAT2, there's no word boundary between C1 and C2.
3665
3666 For instance, to tell that ASCII characters and Latin-1 characters can
3667 form a single word, the element `(?l . ?l)' should be in this list
3668 because both characters have the category `l' (Latin characters).
3669
3670 \(2) The case that character are in the same charset is controlled by
3671 the variable `word-separating-categories'.
3672
3673 Emacs find a word boundary between characters of the same charset
3674 if they have categories matching some element of this list.
3675
3676 More precisely, if an element of this list is a cons of category CAT1
3677 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3678 C2 which has CAT2, there's a word boundary between C1 and C2.
3679
3680 For instance, to tell that there's a word boundary between Japanese
3681 Hiragana and Japanese Kanji (both are in the same charset), the
3682 element `(?H . ?C) should be in this list.
3683 */ );
3684
3685   Vword_combining_categories = Qnil;
3686
3687   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3688 List of pair (cons) of categories to determine word boundary.
3689 See the documentation of the variable `word-combining-categories'.
3690 */ );
3691
3692   Vword_separating_categories = Qnil;
3693 #endif /* MULE */
3694 }