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