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