git.chise.org Git - chise/xemacs-chise.git-/blob - src/chartab.c

   1 /* XEmacs routines to deal with char tables.
   2    Copyright (C) 1992, 1995 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Sun Microsystems, Inc.
   4    Copyright (C) 1995, 1996 Ben Wing.
   5    Copyright (C) 1995, 1997, 1999 Electrotechnical Laboratory, JAPAN.
   6    Licensed to the Free Software Foundation.
   7    Copyright (C) 1999,2000,2001 MORIOKA Tomohiko
   8
   9 This file is part of XEmacs.
  10
  11 XEmacs is free software; you can redistribute it and/or modify it
  12 under the terms of the GNU General Public License as published by the
  13 Free Software Foundation; either version 2, or (at your option) any
  14 later version.
  15
  16 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  17 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  18 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  19 for more details.
  20
  21 You should have received a copy of the GNU General Public License
  22 along with XEmacs; see the file COPYING.  If not, write to
  23 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 Boston, MA 02111-1307, USA.  */
  25
  26 /* Synched up with: Mule 2.3.  Not synched with FSF.
  27
  28    This file was written independently of the FSF implementation,
  29    and is not compatible. */
  30
  31 /* Authorship:
  32
  33    Ben Wing: wrote, for 19.13 (Mule).  Some category table stuff
  34              loosely based on the original Mule.
  35    Jareth Hein: fixed a couple of bugs in the implementation, and
  36              added regex support for categories with check_category_at
  37  */
  38
  39 #include <config.h>
  40 #include "lisp.h"
  41
  42 #include "buffer.h"
  43 #include "chartab.h"
  44 #include "syntax.h"
  45
  46 #ifdef UTF2000
  47 #include "elhash.h"
  48
  49 Lisp_Object Vutf_2000_version;
  50 #endif /* UTF2000 */
  51
  52 Lisp_Object Qchar_tablep, Qchar_table;
  53
  54 Lisp_Object Vall_syntax_tables;
  55
  56 #ifdef MULE
  57 Lisp_Object Qcategory_table_p;
  58 Lisp_Object Qcategory_designator_p;
  59 Lisp_Object Qcategory_table_value_p;
  60
  61 Lisp_Object Vstandard_category_table;
  62
  63 /* Variables to determine word boundary.  */
  64 Lisp_Object Vword_combining_categories, Vword_separating_categories;
  65 #endif /* MULE */
  66
  67 \f
  68 #ifdef UTF2000
  69
  70 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   switch (range.type)
 870     {
 871     case CHARTAB_RANGE_ALL:
 872       cit->table = value;
 873       break;
 874     case CHARTAB_RANGE_DEFAULT:
 875       cit->default_value = value;
 876       break;
 877     case CHARTAB_RANGE_CHARSET:
 878       {
 879         Emchar c;
 880         Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range.charset);
 881
 882         if ( CHAR_TABLEP (encoding_table) )
 883           {
 884             for (c = 0; c < 1 << 24; c++)
 885               {
 886                 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
 887                                               c)) )
 888                   put_char_id_table_0 (cit, c, value);
 889               }
 890           }
 891         else
 892           {
 893             for (c = 0; c < 1 << 24; c++)
 894               {
 895                 if ( charset_code_point (range.charset, c) >= 0 )
 896                   put_char_id_table_0 (cit, c, value);
 897               }
 898           }
 899       }
 900       break;
 901     case CHARTAB_RANGE_ROW:
 902       {
 903         int cell_min, cell_max, i;
 904
 905         if (XCHARSET_DIMENSION (range.charset) < 2)
 906           signal_simple_error ("Charset in row vector must be multi-byte",
 907                                range.charset);
 908         else
 909           {
 910             switch (XCHARSET_CHARS (range.charset))
 911               {
 912               case 94:
 913                 cell_min = 33; cell_max = 126;
 914                 break;
 915               case 96:
 916                 cell_min = 32; cell_max = 127;
 917                 break;
 918               case 128:
 919                 cell_min = 0; cell_max = 127;
 920                 break;
 921               case 256:
 922                 cell_min = 0; cell_max = 255;
 923                 break;
 924               default:
 925                 abort ();
 926               }
 927           }
 928         if (XCHARSET_DIMENSION (range.charset) == 2)
 929           check_int_range (range.row, cell_min, cell_max);
 930         else if (XCHARSET_DIMENSION (range.charset) == 3)
 931           {
 932             check_int_range (range.row >> 8  , cell_min, cell_max);
 933             check_int_range (range.row & 0xFF, cell_min, cell_max);
 934           }
 935         else if (XCHARSET_DIMENSION (range.charset) == 4)
 936           {
 937             check_int_range ( range.row >> 16       , cell_min, cell_max);
 938             check_int_range ((range.row >> 8) & 0xFF, cell_min, cell_max);
 939             check_int_range ( range.row       & 0xFF, cell_min, cell_max);
 940           }
 941         else
 942           abort ();
 943
 944         for (i = cell_min; i <= cell_max; i++)
 945           {
 946             Emchar ch = DECODE_CHAR (range.charset, (range.row << 8) | i);
 947             if ( charset_code_point (range.charset, ch) >= 0 )
 948               put_char_id_table_0 (cit, ch, value);
 949           }
 950       }
 951       break;
 952     case CHARTAB_RANGE_CHAR:
 953       put_char_id_table_0 (cit, range.ch, value);
 954       break;
 955     }
 956 }
 957
 958
 959 Lisp_Object Vcharacter_composition_table;
 960 Lisp_Object Vcharacter_variant_table;
 961
 962
 963 Lisp_Object Q_decomposition;
 964 Lisp_Object Qto_ucs;
 965 Lisp_Object Q_ucs;
 966 Lisp_Object Qcompat;
 967 Lisp_Object Qisolated;
 968 Lisp_Object Qinitial;
 969 Lisp_Object Qmedial;
 970 Lisp_Object Qfinal;
 971 Lisp_Object Qvertical;
 972 Lisp_Object QnoBreak;
 973 Lisp_Object Qfraction;
 974 Lisp_Object Qsuper;
 975 Lisp_Object Qsub;
 976 Lisp_Object Qcircle;
 977 Lisp_Object Qsquare;
 978 Lisp_Object Qwide;
 979 Lisp_Object Qnarrow;
 980 Lisp_Object Qsmall;
 981 Lisp_Object Qfont;
 982
 983 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
 984
 985 Emchar
 986 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
 987 {
 988   if (INTP (v))
 989     return XINT (v);
 990   if (CHARP (v))
 991     return XCHAR (v);
 992   else if (EQ (v, Qcompat))
 993     return -1;
 994   else if (EQ (v, Qisolated))
 995     return -2;
 996   else if (EQ (v, Qinitial))
 997     return -3;
 998   else if (EQ (v, Qmedial))
 999     return -4;
1000   else if (EQ (v, Qfinal))
1001     return -5;
1002   else if (EQ (v, Qvertical))
1003     return -6;
1004   else if (EQ (v, QnoBreak))
1005     return -7;
1006   else if (EQ (v, Qfraction))
1007     return -8;
1008   else if (EQ (v, Qsuper))
1009     return -9;
1010   else if (EQ (v, Qsub))
1011     return -10;
1012   else if (EQ (v, Qcircle))
1013     return -11;
1014   else if (EQ (v, Qsquare))
1015     return -12;
1016   else if (EQ (v, Qwide))
1017     return -13;
1018   else if (EQ (v, Qnarrow))
1019     return -14;
1020   else if (EQ (v, Qsmall))
1021     return -15;
1022   else if (EQ (v, Qfont))
1023     return -16;
1024   else
1025     signal_simple_error (err_msg, err_arg);
1026 }
1027
1028 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1029 Return character corresponding with list.
1030 */
1031        (list))
1032 {
1033   Lisp_Object table = Vcharacter_composition_table;
1034   Lisp_Object rest = list;
1035
1036   while (CONSP (rest))
1037     {
1038       Lisp_Object v = Fcar (rest);
1039       Lisp_Object ret;
1040       Emchar c = to_char_id (v, "Invalid value for composition", list);
1041
1042       ret = get_char_id_table (XCHAR_TABLE(table), c);
1043
1044       rest = Fcdr (rest);
1045       if (NILP (rest))
1046         {
1047           if (!CHAR_TABLEP (ret))
1048             return ret;
1049           else
1050             return Qt;
1051         }
1052       else if (!CONSP (rest))
1053         break;
1054       else if (CHAR_TABLEP (ret))
1055         table = ret;
1056       else
1057         signal_simple_error ("Invalid table is found with", list);
1058     }
1059   signal_simple_error ("Invalid value for composition", list);
1060 }
1061
1062 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1063 Return variants of CHARACTER.
1064 */
1065        (character))
1066 {
1067   CHECK_CHAR (character);
1068   return Fcopy_list (get_char_id_table
1069                      (XCHAR_TABLE(Vcharacter_variant_table),
1070                       XCHAR (character)));
1071 }
1072
1073 #endif
1074
1075 \f
1076 /* A char table maps from ranges of characters to values.
1077
1078    Implementing a general data structure that maps from arbitrary
1079    ranges of numbers to values is tricky to do efficiently.  As it
1080    happens, it should suffice (and is usually more convenient, anyway)
1081    when dealing with characters to restrict the sorts of ranges that
1082    can be assigned values, as follows:
1083
1084    1) All characters.
1085    2) All characters in a charset.
1086    3) All characters in a particular row of a charset, where a "row"
1087       means all characters with the same first byte.
1088    4) A particular character in a charset.
1089
1090    We use char tables to generalize the 256-element vectors now
1091    littering the Emacs code.
1092
1093    Possible uses (all should be converted at some point):
1094
1095    1) category tables
1096    2) syntax tables
1097    3) display tables
1098    4) case tables
1099    5) keyboard-translate-table?
1100
1101    We provide an
1102    abstract type to generalize the Emacs vectors and Mule
1103    vectors-of-vectors goo.
1104    */
1105
1106 /************************************************************************/
1107 /*                         Char Table object                            */
1108 /************************************************************************/
1109
1110 #if defined(MULE)&&!defined(UTF2000)
1111
1112 static Lisp_Object
1113 mark_char_table_entry (Lisp_Object obj)
1114 {
1115   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1116   int i;
1117
1118   for (i = 0; i < 96; i++)
1119     {
1120       mark_object (cte->level2[i]);
1121     }
1122   return Qnil;
1123 }
1124
1125 static int
1126 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1127 {
1128   Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1129   Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1130   int i;
1131
1132   for (i = 0; i < 96; i++)
1133     if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1134       return 0;
1135
1136   return 1;
1137 }
1138
1139 static unsigned long
1140 char_table_entry_hash (Lisp_Object obj, int depth)
1141 {
1142   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1143
1144   return internal_array_hash (cte->level2, 96, depth);
1145 }
1146
1147 static const struct lrecord_description char_table_entry_description[] = {
1148   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1149   { XD_END }
1150 };
1151
1152 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1153                                mark_char_table_entry, internal_object_printer,
1154                                0, char_table_entry_equal,
1155                                char_table_entry_hash,
1156                                char_table_entry_description,
1157                                Lisp_Char_Table_Entry);
1158 #endif /* MULE */
1159
1160 static Lisp_Object
1161 mark_char_table (Lisp_Object obj)
1162 {
1163   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1164 #ifdef UTF2000
1165
1166   mark_object (ct->table);
1167 #else
1168   int i;
1169
1170   for (i = 0; i < NUM_ASCII_CHARS; i++)
1171     mark_object (ct->ascii[i]);
1172 #ifdef MULE
1173   for (i = 0; i < NUM_LEADING_BYTES; i++)
1174     mark_object (ct->level1[i]);
1175 #endif
1176 #endif
1177 #ifdef UTF2000
1178   return ct->default_value;
1179 #else
1180   return ct->mirror_table;
1181 #endif
1182 }
1183
1184 /* WARNING: All functions of this nature need to be written extremely
1185    carefully to avoid crashes during GC.  Cf. prune_specifiers()
1186    and prune_weak_hash_tables(). */
1187
1188 void
1189 prune_syntax_tables (void)
1190 {
1191   Lisp_Object rest, prev = Qnil;
1192
1193   for (rest = Vall_syntax_tables;
1194        !NILP (rest);
1195        rest = XCHAR_TABLE (rest)->next_table)
1196     {
1197       if (! marked_p (rest))
1198         {
1199           /* This table is garbage.  Remove it from the list. */
1200           if (NILP (prev))
1201             Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1202           else
1203             XCHAR_TABLE (prev)->next_table =
1204               XCHAR_TABLE (rest)->next_table;
1205         }
1206     }
1207 }
1208
1209 static Lisp_Object
1210 char_table_type_to_symbol (enum char_table_type type)
1211 {
1212   switch (type)
1213   {
1214   default: abort();
1215   case CHAR_TABLE_TYPE_GENERIC:  return Qgeneric;
1216   case CHAR_TABLE_TYPE_SYNTAX:   return Qsyntax;
1217   case CHAR_TABLE_TYPE_DISPLAY:  return Qdisplay;
1218   case CHAR_TABLE_TYPE_CHAR:     return Qchar;
1219 #ifdef MULE
1220   case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1221 #endif
1222   }
1223 }
1224
1225 static enum char_table_type
1226 symbol_to_char_table_type (Lisp_Object symbol)
1227 {
1228   CHECK_SYMBOL (symbol);
1229
1230   if (EQ (symbol, Qgeneric))  return CHAR_TABLE_TYPE_GENERIC;
1231   if (EQ (symbol, Qsyntax))   return CHAR_TABLE_TYPE_SYNTAX;
1232   if (EQ (symbol, Qdisplay))  return CHAR_TABLE_TYPE_DISPLAY;
1233   if (EQ (symbol, Qchar))     return CHAR_TABLE_TYPE_CHAR;
1234 #ifdef MULE
1235   if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1236 #endif
1237
1238   signal_simple_error ("Unrecognized char table type", symbol);
1239   return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1240 }
1241
1242 static void
1243 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1244                      Lisp_Object printcharfun)
1245 {
1246   if (first != last)
1247     {
1248       write_c_string (" (", printcharfun);
1249       print_internal (make_char (first), printcharfun, 0);
1250       write_c_string (" ", printcharfun);
1251       print_internal (make_char (last), printcharfun, 0);
1252       write_c_string (") ", printcharfun);
1253     }
1254   else
1255     {
1256       write_c_string (" ", printcharfun);
1257       print_internal (make_char (first), printcharfun, 0);
1258       write_c_string (" ", printcharfun);
1259     }
1260   print_internal (val, printcharfun, 1);
1261 }
1262
1263 #if defined(MULE)&&!defined(UTF2000)
1264
1265 static void
1266 print_chartab_charset_row (Lisp_Object charset,
1267                            int row,
1268                            Lisp_Char_Table_Entry *cte,
1269                            Lisp_Object printcharfun)
1270 {
1271   int i;
1272   Lisp_Object cat = Qunbound;
1273   int first = -1;
1274
1275   for (i = 32; i < 128; i++)
1276     {
1277       Lisp_Object pam = cte->level2[i - 32];
1278
1279       if (first == -1)
1280         {
1281           first = i;
1282           cat = pam;
1283           continue;
1284         }
1285
1286       if (!EQ (cat, pam))
1287         {
1288           if (row == -1)
1289             print_chartab_range (MAKE_CHAR (charset, first, 0),
1290                                  MAKE_CHAR (charset, i - 1, 0),
1291                                  cat, printcharfun);
1292           else
1293             print_chartab_range (MAKE_CHAR (charset, row, first),
1294                                  MAKE_CHAR (charset, row, i - 1),
1295                                  cat, printcharfun);
1296           first = -1;
1297           i--;
1298         }
1299     }
1300
1301   if (first != -1)
1302     {
1303       if (row == -1)
1304         print_chartab_range (MAKE_CHAR (charset, first, 0),
1305                              MAKE_CHAR (charset, i - 1, 0),
1306                              cat, printcharfun);
1307       else
1308         print_chartab_range (MAKE_CHAR (charset, row, first),
1309                              MAKE_CHAR (charset, row, i - 1),
1310                              cat, printcharfun);
1311     }
1312 }
1313
1314 static void
1315 print_chartab_two_byte_charset (Lisp_Object charset,
1316                                 Lisp_Char_Table_Entry *cte,
1317                                 Lisp_Object printcharfun)
1318 {
1319   int i;
1320
1321   for (i = 32; i < 128; i++)
1322     {
1323       Lisp_Object jen = cte->level2[i - 32];
1324
1325       if (!CHAR_TABLE_ENTRYP (jen))
1326         {
1327           char buf[100];
1328
1329           write_c_string (" [", printcharfun);
1330           print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1331           sprintf (buf, " %d] ", i);
1332           write_c_string (buf, printcharfun);
1333           print_internal (jen, printcharfun, 0);
1334         }
1335       else
1336         print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1337                                    printcharfun);
1338     }
1339 }
1340
1341 #endif /* MULE */
1342
1343 static void
1344 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1345 {
1346   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1347 #ifdef UTF2000
1348   int i;
1349   struct gcpro gcpro1, gcpro2;
1350   GCPRO2 (obj, printcharfun);
1351
1352   write_c_string ("#s(char-table ", printcharfun);
1353   write_c_string (" ", printcharfun);
1354   write_c_string (string_data
1355                   (symbol_name
1356                    (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1357                   printcharfun);
1358   write_c_string ("\n ", printcharfun);
1359   print_internal (ct->default_value, printcharfun, escapeflag);
1360   for (i = 0; i < 256; i++)
1361     {
1362       Lisp_Object elt = get_byte_table (ct->table, i);
1363       if (i != 0) write_c_string ("\n  ", printcharfun);
1364       if (EQ (elt, Qunbound))
1365         write_c_string ("void", printcharfun);
1366       else
1367         print_internal (elt, printcharfun, escapeflag);
1368     }
1369   UNGCPRO;
1370 #else /* non UTF2000 */
1371   char buf[200];
1372
1373   sprintf (buf, "#s(char-table type %s data (",
1374            string_data (symbol_name (XSYMBOL
1375                                      (char_table_type_to_symbol (ct->type)))));
1376   write_c_string (buf, printcharfun);
1377
1378   /* Now write out the ASCII/Control-1 stuff. */
1379   {
1380     int i;
1381     int first = -1;
1382     Lisp_Object val = Qunbound;
1383
1384     for (i = 0; i < NUM_ASCII_CHARS; i++)
1385       {
1386         if (first == -1)
1387           {
1388             first = i;
1389             val = ct->ascii[i];
1390             continue;
1391           }
1392
1393         if (!EQ (ct->ascii[i], val))
1394           {
1395             print_chartab_range (first, i - 1, val, printcharfun);
1396             first = -1;
1397             i--;
1398           }
1399       }
1400
1401     if (first != -1)
1402       print_chartab_range (first, i - 1, val, printcharfun);
1403   }
1404
1405 #ifdef MULE
1406   {
1407     Charset_ID i;
1408
1409     for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1410          i++)
1411       {
1412         Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1413         Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1414
1415         if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1416             || i == LEADING_BYTE_CONTROL_1)
1417           continue;
1418         if (!CHAR_TABLE_ENTRYP (ann))
1419           {
1420             write_c_string (" ", printcharfun);
1421             print_internal (XCHARSET_NAME (charset),
1422                             printcharfun, 0);
1423             write_c_string (" ", printcharfun);
1424             print_internal (ann, printcharfun, 0);
1425           }
1426         else
1427           {
1428             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1429             if (XCHARSET_DIMENSION (charset) == 1)
1430               print_chartab_charset_row (charset, -1, cte, printcharfun);
1431             else
1432               print_chartab_two_byte_charset (charset, cte, printcharfun);
1433           }
1434       }
1435   }
1436 #endif /* MULE */
1437 #endif /* non UTF2000 */
1438
1439   write_c_string ("))", printcharfun);
1440 }
1441
1442 static int
1443 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1444 {
1445   Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1446   Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1447   int i;
1448
1449   if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1450     return 0;
1451
1452 #ifdef UTF2000
1453   for (i = 0; i < 256; i++)
1454     {
1455       if (!internal_equal (get_byte_table (ct1->table, i),
1456                            get_byte_table (ct2->table, i), 0))
1457         return 0;
1458     }
1459 #else
1460   for (i = 0; i < NUM_ASCII_CHARS; i++)
1461     if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1462       return 0;
1463
1464 #ifdef MULE
1465   for (i = 0; i < NUM_LEADING_BYTES; i++)
1466     if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1467       return 0;
1468 #endif /* MULE */
1469 #endif /* non UTF2000 */
1470
1471   return 1;
1472 }
1473
1474 static unsigned long
1475 char_table_hash (Lisp_Object obj, int depth)
1476 {
1477   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1478 #ifdef UTF2000
1479     return byte_table_hash (ct->table, depth + 1);
1480 #else
1481   unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1482                                                depth);
1483 #ifdef MULE
1484   hashval = HASH2 (hashval,
1485                    internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1486 #endif /* MULE */
1487   return hashval;
1488 #endif
1489 }
1490
1491 static const struct lrecord_description char_table_description[] = {
1492 #ifdef UTF2000
1493   { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1494   { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1495 #else
1496   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1497 #ifdef MULE
1498   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1499 #endif
1500 #endif
1501 #ifndef UTF2000
1502   { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1503 #endif
1504   { XD_LO_LINK,     offsetof (Lisp_Char_Table, next_table) },
1505   { XD_END }
1506 };
1507
1508 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1509                                mark_char_table, print_char_table, 0,
1510                                char_table_equal, char_table_hash,
1511                                char_table_description,
1512                                Lisp_Char_Table);
1513
1514 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1515 Return non-nil if OBJECT is a char table.
1516
1517 A char table is a table that maps characters (or ranges of characters)
1518 to values.  Char tables are specialized for characters, only allowing
1519 particular sorts of ranges to be assigned values.  Although this
1520 loses in generality, it makes for extremely fast (constant-time)
1521 lookups, and thus is feasible for applications that do an extremely
1522 large number of lookups (e.g. scanning a buffer for a character in
1523 a particular syntax, where a lookup in the syntax table must occur
1524 once per character).
1525
1526 When Mule support exists, the types of ranges that can be assigned
1527 values are
1528
1529 -- all characters
1530 -- an entire charset
1531 -- a single row in a two-octet charset
1532 -- a single character
1533
1534 When Mule support is not present, the types of ranges that can be
1535 assigned values are
1536
1537 -- all characters
1538 -- a single character
1539
1540 To create a char table, use `make-char-table'.
1541 To modify a char table, use `put-char-table' or `remove-char-table'.
1542 To retrieve the value for a particular character, use `get-char-table'.
1543 See also `map-char-table', `clear-char-table', `copy-char-table',
1544 `valid-char-table-type-p', `char-table-type-list',
1545 `valid-char-table-value-p', and `check-char-table-value'.
1546 */
1547        (object))
1548 {
1549   return CHAR_TABLEP (object) ? Qt : Qnil;
1550 }
1551
1552 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1553 Return a list of the recognized char table types.
1554 See `valid-char-table-type-p'.
1555 */
1556        ())
1557 {
1558 #ifdef MULE
1559   return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1560 #else
1561   return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1562 #endif
1563 }
1564
1565 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1566 Return t if TYPE if a recognized char table type.
1567
1568 Each char table type is used for a different purpose and allows different
1569 sorts of values.  The different char table types are
1570
1571 `category'
1572         Used for category tables, which specify the regexp categories
1573         that a character is in.  The valid values are nil or a
1574         bit vector of 95 elements.  Higher-level Lisp functions are
1575         provided for working with category tables.  Currently categories
1576         and category tables only exist when Mule support is present.
1577 `char'
1578         A generalized char table, for mapping from one character to
1579         another.  Used for case tables, syntax matching tables,
1580         `keyboard-translate-table', etc.  The valid values are characters.
1581 `generic'
1582         An even more generalized char table, for mapping from a
1583         character to anything.
1584 `display'
1585         Used for display tables, which specify how a particular character
1586         is to appear when displayed.  #### Not yet implemented.
1587 `syntax'
1588         Used for syntax tables, which specify the syntax of a particular
1589         character.  Higher-level Lisp functions are provided for
1590         working with syntax tables.  The valid values are integers.
1591
1592 */
1593        (type))
1594 {
1595   return (EQ (type, Qchar)     ||
1596 #ifdef MULE
1597           EQ (type, Qcategory) ||
1598 #endif
1599           EQ (type, Qdisplay)  ||
1600           EQ (type, Qgeneric)  ||
1601           EQ (type, Qsyntax)) ? Qt : Qnil;
1602 }
1603
1604 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1605 Return the type of CHAR-TABLE.
1606 See `valid-char-table-type-p'.
1607 */
1608        (char_table))
1609 {
1610   CHECK_CHAR_TABLE (char_table);
1611   return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1612 }
1613
1614 void
1615 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1616 {
1617 #ifdef UTF2000
1618   ct->table = Qunbound;
1619   ct->default_value = value;
1620 #else
1621   int i;
1622
1623   for (i = 0; i < NUM_ASCII_CHARS; i++)
1624     ct->ascii[i] = value;
1625 #ifdef MULE
1626   for (i = 0; i < NUM_LEADING_BYTES; i++)
1627     ct->level1[i] = value;
1628 #endif /* MULE */
1629 #endif
1630
1631 #ifndef UTF2000
1632   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1633     update_syntax_table (ct);
1634 #endif
1635 }
1636
1637 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1638 Reset CHAR-TABLE to its default state.
1639 */
1640        (char_table))
1641 {
1642   Lisp_Char_Table *ct;
1643
1644   CHECK_CHAR_TABLE (char_table);
1645   ct = XCHAR_TABLE (char_table);
1646
1647   switch (ct->type)
1648     {
1649     case CHAR_TABLE_TYPE_CHAR:
1650       fill_char_table (ct, make_char (0));
1651       break;
1652     case CHAR_TABLE_TYPE_DISPLAY:
1653     case CHAR_TABLE_TYPE_GENERIC:
1654 #ifdef MULE
1655     case CHAR_TABLE_TYPE_CATEGORY:
1656 #endif /* MULE */
1657       fill_char_table (ct, Qnil);
1658       break;
1659
1660     case CHAR_TABLE_TYPE_SYNTAX:
1661       fill_char_table (ct, make_int (Sinherit));
1662       break;
1663
1664     default:
1665       abort ();
1666     }
1667
1668   return Qnil;
1669 }
1670
1671 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1672 Return a new, empty char table of type TYPE.
1673 Currently recognized types are 'char, 'category, 'display, 'generic,
1674 and 'syntax.  See `valid-char-table-type-p'.
1675 */
1676        (type))
1677 {
1678   Lisp_Char_Table *ct;
1679   Lisp_Object obj;
1680   enum char_table_type ty = symbol_to_char_table_type (type);
1681
1682   ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1683   ct->type = ty;
1684 #ifndef UTF2000
1685   if (ty == CHAR_TABLE_TYPE_SYNTAX)
1686     {
1687       ct->mirror_table = Fmake_char_table (Qgeneric);
1688       fill_char_table (XCHAR_TABLE (ct->mirror_table),
1689                        make_int (Spunct));
1690     }
1691   else
1692     ct->mirror_table = Qnil;
1693 #endif
1694   ct->next_table = Qnil;
1695   XSETCHAR_TABLE (obj, ct);
1696   if (ty == CHAR_TABLE_TYPE_SYNTAX)
1697     {
1698       ct->next_table = Vall_syntax_tables;
1699       Vall_syntax_tables = obj;
1700     }
1701   Freset_char_table (obj);
1702   return obj;
1703 }
1704
1705 #if defined(MULE)&&!defined(UTF2000)
1706
1707 static Lisp_Object
1708 make_char_table_entry (Lisp_Object initval)
1709 {
1710   Lisp_Object obj;
1711   int i;
1712   Lisp_Char_Table_Entry *cte =
1713     alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1714
1715   for (i = 0; i < 96; i++)
1716     cte->level2[i] = initval;
1717
1718   XSETCHAR_TABLE_ENTRY (obj, cte);
1719   return obj;
1720 }
1721
1722 static Lisp_Object
1723 copy_char_table_entry (Lisp_Object entry)
1724 {
1725   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1726   Lisp_Object obj;
1727   int i;
1728   Lisp_Char_Table_Entry *ctenew =
1729     alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1730
1731   for (i = 0; i < 96; i++)
1732     {
1733       Lisp_Object new = cte->level2[i];
1734       if (CHAR_TABLE_ENTRYP (new))
1735         ctenew->level2[i] = copy_char_table_entry (new);
1736       else
1737         ctenew->level2[i] = new;
1738     }
1739
1740   XSETCHAR_TABLE_ENTRY (obj, ctenew);
1741   return obj;
1742 }
1743
1744 #endif /* MULE */
1745
1746 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1747 Return a new char table which is a copy of CHAR-TABLE.
1748 It will contain the same values for the same characters and ranges
1749 as CHAR-TABLE.  The values will not themselves be copied.
1750 */
1751        (char_table))
1752 {
1753   Lisp_Char_Table *ct, *ctnew;
1754   Lisp_Object obj;
1755 #ifndef UTF2000
1756   int i;
1757 #endif
1758
1759   CHECK_CHAR_TABLE (char_table);
1760   ct = XCHAR_TABLE (char_table);
1761   ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1762   ctnew->type = ct->type;
1763 #ifdef UTF2000
1764   ctnew->default_value = ct->default_value;
1765
1766   if (UINT8_BYTE_TABLE_P (ct->table))
1767     {
1768       ctnew->table = copy_uint8_byte_table (ct->table);
1769     }
1770   else if (UINT16_BYTE_TABLE_P (ct->table))
1771     {
1772       ctnew->table = copy_uint16_byte_table (ct->table);
1773     }
1774   else if (BYTE_TABLE_P (ct->table))
1775     {
1776       ctnew->table = copy_byte_table (ct->table);
1777     }
1778   else if (!UNBOUNDP (ct->table))
1779     ctnew->table = ct->table;
1780 #else /* non UTF2000 */
1781
1782   for (i = 0; i < NUM_ASCII_CHARS; i++)
1783     {
1784       Lisp_Object new = ct->ascii[i];
1785 #ifdef MULE
1786       assert (! (CHAR_TABLE_ENTRYP (new)));
1787 #endif /* MULE */
1788       ctnew->ascii[i] = new;
1789     }
1790
1791 #ifdef MULE
1792
1793   for (i = 0; i < NUM_LEADING_BYTES; i++)
1794     {
1795       Lisp_Object new = ct->level1[i];
1796       if (CHAR_TABLE_ENTRYP (new))
1797         ctnew->level1[i] = copy_char_table_entry (new);
1798       else
1799         ctnew->level1[i] = new;
1800     }
1801
1802 #endif /* MULE */
1803 #endif /* non UTF2000 */
1804
1805 #ifndef UTF2000
1806   if (CHAR_TABLEP (ct->mirror_table))
1807     ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1808   else
1809     ctnew->mirror_table = ct->mirror_table;
1810 #endif
1811   ctnew->next_table = Qnil;
1812   XSETCHAR_TABLE (obj, ctnew);
1813   if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1814     {
1815       ctnew->next_table = Vall_syntax_tables;
1816       Vall_syntax_tables = obj;
1817     }
1818   return obj;
1819 }
1820
1821 static void
1822 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1823 {
1824   if (EQ (range, Qt))
1825     outrange->type = CHARTAB_RANGE_ALL;
1826   else if (EQ (range, Qnil))
1827     outrange->type = CHARTAB_RANGE_DEFAULT;
1828   else if (CHAR_OR_CHAR_INTP (range))
1829     {
1830       outrange->type = CHARTAB_RANGE_CHAR;
1831       outrange->ch = XCHAR_OR_CHAR_INT (range);
1832     }
1833 #ifndef MULE
1834   else
1835     signal_simple_error ("Range must be t or a character", range);
1836 #else /* MULE */
1837   else if (VECTORP (range))
1838     {
1839       Lisp_Vector *vec = XVECTOR (range);
1840       Lisp_Object *elts = vector_data (vec);
1841       if (vector_length (vec) != 2)
1842         signal_simple_error ("Length of charset row vector must be 2",
1843                              range);
1844       outrange->type = CHARTAB_RANGE_ROW;
1845       outrange->charset = Fget_charset (elts[0]);
1846       CHECK_INT (elts[1]);
1847       outrange->row = XINT (elts[1]);
1848       if (XCHARSET_DIMENSION (outrange->charset) >= 2)
1849         {
1850           switch (XCHARSET_CHARS (outrange->charset))
1851             {
1852             case 94:
1853               check_int_range (outrange->row, 33, 126);
1854               break;
1855             case 96:
1856               check_int_range (outrange->row, 32, 127);
1857               break;
1858             default:
1859               abort ();
1860             }
1861         }
1862       else
1863         signal_simple_error ("Charset in row vector must be multi-byte",
1864                              outrange->charset);
1865     }
1866   else
1867     {
1868       if (!CHARSETP (range) && !SYMBOLP (range))
1869         signal_simple_error
1870           ("Char table range must be t, charset, char, or vector", range);
1871       outrange->type = CHARTAB_RANGE_CHARSET;
1872       outrange->charset = Fget_charset (range);
1873     }
1874 #endif /* MULE */
1875 }
1876
1877 #if defined(MULE)&&!defined(UTF2000)
1878
1879 /* called from CHAR_TABLE_VALUE(). */
1880 Lisp_Object
1881 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
1882                                Emchar c)
1883 {
1884   Lisp_Object val;
1885 #ifdef UTF2000
1886   Lisp_Object charset;
1887 #else
1888   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
1889 #endif
1890   int byte1, byte2;
1891
1892 #ifdef UTF2000
1893   BREAKUP_CHAR (c, charset, byte1, byte2);
1894 #else
1895   BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
1896 #endif
1897   val = ct->level1[leading_byte - MIN_LEADING_BYTE];
1898   if (CHAR_TABLE_ENTRYP (val))
1899     {
1900       Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1901       val = cte->level2[byte1 - 32];
1902       if (CHAR_TABLE_ENTRYP (val))
1903         {
1904           cte = XCHAR_TABLE_ENTRY (val);
1905           assert (byte2 >= 32);
1906           val = cte->level2[byte2 - 32];
1907           assert (!CHAR_TABLE_ENTRYP (val));
1908         }
1909     }
1910
1911   return val;
1912 }
1913
1914 #endif /* MULE */
1915
1916 Lisp_Object
1917 get_char_table (Emchar ch, Lisp_Char_Table *ct)
1918 {
1919 #ifdef UTF2000
1920   Lisp_Object val = get_byte_table (get_byte_table
1921                                     (get_byte_table
1922                                      (get_byte_table
1923                                       (ct->table,
1924                                        (unsigned char)(ch >> 24)),
1925                                       (unsigned char) (ch >> 16)),
1926                                      (unsigned char)  (ch >>  8)),
1927                                     (unsigned char)    ch);
1928   if (UNBOUNDP (val))
1929     return ct->default_value;
1930   else
1931     return val;
1932 #elif defined(MULE)
1933   {
1934     Lisp_Object charset;
1935     int byte1, byte2;
1936     Lisp_Object val;
1937
1938     BREAKUP_CHAR (ch, charset, byte1, byte2);
1939
1940     if (EQ (charset, Vcharset_ascii))
1941       val = ct->ascii[byte1];
1942     else if (EQ (charset, Vcharset_control_1))
1943       val = ct->ascii[byte1 + 128];
1944     else
1945       {
1946         int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1947         val = ct->level1[lb];
1948         if (CHAR_TABLE_ENTRYP (val))
1949           {
1950             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1951             val = cte->level2[byte1 - 32];
1952             if (CHAR_TABLE_ENTRYP (val))
1953               {
1954                 cte = XCHAR_TABLE_ENTRY (val);
1955                 assert (byte2 >= 32);
1956                 val = cte->level2[byte2 - 32];
1957                 assert (!CHAR_TABLE_ENTRYP (val));
1958               }
1959           }
1960       }
1961
1962     return val;
1963   }
1964 #else /* not MULE */
1965   return ct->ascii[(unsigned char)ch];
1966 #endif /* not MULE */
1967 }
1968
1969
1970 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
1971 Find value for CHARACTER in CHAR-TABLE.
1972 */
1973        (character, char_table))
1974 {
1975   CHECK_CHAR_TABLE (char_table);
1976   CHECK_CHAR_COERCE_INT (character);
1977
1978   return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
1979 }
1980
1981 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
1982 Find value for a range in CHAR-TABLE.
1983 If there is more than one value, return MULTI (defaults to nil).
1984 */
1985        (range, char_table, multi))
1986 {
1987   Lisp_Char_Table *ct;
1988   struct chartab_range rainj;
1989
1990   if (CHAR_OR_CHAR_INTP (range))
1991     return Fget_char_table (range, char_table);
1992   CHECK_CHAR_TABLE (char_table);
1993   ct = XCHAR_TABLE (char_table);
1994
1995   decode_char_table_range (range, &rainj);
1996   switch (rainj.type)
1997     {
1998     case CHARTAB_RANGE_ALL:
1999       {
2000 #ifdef UTF2000
2001         if (UINT8_BYTE_TABLE_P (ct->table))
2002           return multi;
2003         else if (UINT16_BYTE_TABLE_P (ct->table))
2004           return multi;
2005         else if (BYTE_TABLE_P (ct->table))
2006           return multi;
2007         else
2008           return ct->table;
2009 #else /* non UTF2000 */
2010         int i;
2011         Lisp_Object first = ct->ascii[0];
2012
2013         for (i = 1; i < NUM_ASCII_CHARS; i++)
2014           if (!EQ (first, ct->ascii[i]))
2015             return multi;
2016
2017 #ifdef MULE
2018         for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2019              i++)
2020           {
2021             if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2022                 || i == LEADING_BYTE_ASCII
2023                 || i == LEADING_BYTE_CONTROL_1)
2024               continue;
2025             if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2026               return multi;
2027           }
2028 #endif /* MULE */
2029
2030         return first;
2031 #endif /* non UTF2000 */
2032       }
2033
2034 #ifdef MULE
2035     case CHARTAB_RANGE_CHARSET:
2036 #ifdef UTF2000
2037       return multi;
2038 #else
2039       if (EQ (rainj.charset, Vcharset_ascii))
2040         {
2041           int i;
2042           Lisp_Object first = ct->ascii[0];
2043
2044           for (i = 1; i < 128; i++)
2045             if (!EQ (first, ct->ascii[i]))
2046               return multi;
2047           return first;
2048         }
2049
2050       if (EQ (rainj.charset, Vcharset_control_1))
2051         {
2052           int i;
2053           Lisp_Object first = ct->ascii[128];
2054
2055           for (i = 129; i < 160; i++)
2056             if (!EQ (first, ct->ascii[i]))
2057               return multi;
2058           return first;
2059         }
2060
2061       {
2062         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2063                                      MIN_LEADING_BYTE];
2064         if (CHAR_TABLE_ENTRYP (val))
2065           return multi;
2066         return val;
2067       }
2068 #endif
2069
2070     case CHARTAB_RANGE_ROW:
2071 #ifdef UTF2000
2072       return multi;
2073 #else
2074       {
2075         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2076                                      MIN_LEADING_BYTE];
2077         if (!CHAR_TABLE_ENTRYP (val))
2078           return val;
2079         val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2080         if (CHAR_TABLE_ENTRYP (val))
2081           return multi;
2082         return val;
2083       }
2084 #endif /* not UTF2000 */
2085 #endif /* not MULE */
2086
2087     default:
2088       abort ();
2089     }
2090
2091   return Qnil; /* not reached */
2092 }
2093
2094 static int
2095 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2096                               Error_behavior errb)
2097 {
2098   switch (type)
2099     {
2100     case CHAR_TABLE_TYPE_SYNTAX:
2101       if (!ERRB_EQ (errb, ERROR_ME))
2102         return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2103                                 && CHAR_OR_CHAR_INTP (XCDR (value)));
2104       if (CONSP (value))
2105         {
2106           Lisp_Object cdr = XCDR (value);
2107           CHECK_INT (XCAR (value));
2108           CHECK_CHAR_COERCE_INT (cdr);
2109          }
2110       else
2111         CHECK_INT (value);
2112       break;
2113
2114 #ifdef MULE
2115     case CHAR_TABLE_TYPE_CATEGORY:
2116       if (!ERRB_EQ (errb, ERROR_ME))
2117         return CATEGORY_TABLE_VALUEP (value);
2118       CHECK_CATEGORY_TABLE_VALUE (value);
2119       break;
2120 #endif /* MULE */
2121
2122     case CHAR_TABLE_TYPE_GENERIC:
2123       return 1;
2124
2125     case CHAR_TABLE_TYPE_DISPLAY:
2126       /* #### fix this */
2127       maybe_signal_simple_error ("Display char tables not yet implemented",
2128                                  value, Qchar_table, errb);
2129       return 0;
2130
2131     case CHAR_TABLE_TYPE_CHAR:
2132       if (!ERRB_EQ (errb, ERROR_ME))
2133         return CHAR_OR_CHAR_INTP (value);
2134       CHECK_CHAR_COERCE_INT (value);
2135       break;
2136
2137     default:
2138       abort ();
2139     }
2140
2141   return 0; /* not reached */
2142 }
2143
2144 static Lisp_Object
2145 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2146 {
2147   switch (type)
2148     {
2149     case CHAR_TABLE_TYPE_SYNTAX:
2150       if (CONSP (value))
2151         {
2152           Lisp_Object car = XCAR (value);
2153           Lisp_Object cdr = XCDR (value);
2154           CHECK_CHAR_COERCE_INT (cdr);
2155           return Fcons (car, cdr);
2156         }
2157       break;
2158     case CHAR_TABLE_TYPE_CHAR:
2159       CHECK_CHAR_COERCE_INT (value);
2160       break;
2161     default:
2162       break;
2163     }
2164   return value;
2165 }
2166
2167 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2168 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2169 */
2170        (value, char_table_type))
2171 {
2172   enum char_table_type type = symbol_to_char_table_type (char_table_type);
2173
2174   return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2175 }
2176
2177 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2178 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2179 */
2180        (value, char_table_type))
2181 {
2182   enum char_table_type type = symbol_to_char_table_type (char_table_type);
2183
2184   check_valid_char_table_value (value, type, ERROR_ME);
2185   return Qnil;
2186 }
2187
2188 /* Assign VAL to all characters in RANGE in char table CT. */
2189
2190 void
2191 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2192                 Lisp_Object val)
2193 {
2194   switch (range->type)
2195     {
2196     case CHARTAB_RANGE_ALL:
2197       /* printf ("put-char-table: range = all\n"); */
2198       fill_char_table (ct, val);
2199       return; /* avoid the duplicate call to update_syntax_table() below,
2200                  since fill_char_table() also did that. */
2201
2202 #ifdef UTF2000
2203     case CHARTAB_RANGE_DEFAULT:
2204       ct->default_value = val;
2205       return;
2206 #endif
2207
2208 #ifdef MULE
2209     case CHARTAB_RANGE_CHARSET:
2210 #ifdef UTF2000
2211       {
2212         Emchar c;
2213         Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2214
2215         /* printf ("put-char-table: range = charset: %d\n",
2216            XCHARSET_LEADING_BYTE (range->charset));
2217         */
2218         if ( CHAR_TABLEP (encoding_table) )
2219           {
2220             for (c = 0; c < 1 << 24; c++)
2221               {
2222                 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2223                                               c)) )
2224                   put_char_id_table_0 (ct, c, val);
2225               }
2226           }
2227         else
2228           {
2229             for (c = 0; c < 1 << 24; c++)
2230               {
2231                 if ( charset_code_point (range->charset, c) >= 0 )
2232                   put_char_id_table_0 (ct, c, val);
2233               }
2234           }
2235       }
2236 #else
2237       if (EQ (range->charset, Vcharset_ascii))
2238         {
2239           int i;
2240           for (i = 0; i < 128; i++)
2241             ct->ascii[i] = val;
2242         }
2243       else if (EQ (range->charset, Vcharset_control_1))
2244         {
2245           int i;
2246           for (i = 128; i < 160; i++)
2247             ct->ascii[i] = val;
2248         }
2249       else
2250         {
2251           int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2252           ct->level1[lb] = val;
2253         }
2254 #endif
2255       break;
2256
2257     case CHARTAB_RANGE_ROW:
2258 #ifdef UTF2000
2259       {
2260         int cell_min, cell_max, i;
2261
2262         /* printf ("put-char-table: range = charset-row: %d, 0x%x\n",
2263            XCHARSET_LEADING_BYTE (range->charset), range->row); */
2264         if (XCHARSET_DIMENSION (range->charset) < 2)
2265           signal_simple_error ("Charset in row vector must be multi-byte",
2266                                range->charset);
2267         else
2268           {
2269             switch (XCHARSET_CHARS (range->charset))
2270               {
2271               case 94:
2272                 cell_min = 33; cell_max = 126;
2273                 break;
2274               case 96:
2275                 cell_min = 32; cell_max = 127;
2276                 break;
2277               case 128:
2278                 cell_min = 0; cell_max = 127;
2279                 break;
2280               case 256:
2281                 cell_min = 0; cell_max = 255;
2282                 break;
2283               default:
2284                 abort ();
2285               }
2286           }
2287         if (XCHARSET_DIMENSION (range->charset) == 2)
2288           check_int_range (range->row, cell_min, cell_max);
2289         else if (XCHARSET_DIMENSION (range->charset) == 3)
2290           {
2291             check_int_range (range->row >> 8  , cell_min, cell_max);
2292             check_int_range (range->row & 0xFF, cell_min, cell_max);
2293           }
2294         else if (XCHARSET_DIMENSION (range->charset) == 4)
2295           {
2296             check_int_range ( range->row >> 16       , cell_min, cell_max);
2297             check_int_range ((range->row >> 8) & 0xFF, cell_min, cell_max);
2298             check_int_range ( range->row       & 0xFF, cell_min, cell_max);
2299           }
2300         else
2301           abort ();
2302
2303         for (i = cell_min; i <= cell_max; i++)
2304           {
2305             Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2306             if ( charset_code_point (range->charset, ch) >= 0 )
2307               put_char_id_table_0 (ct, ch, val);
2308           }
2309       }
2310 #else
2311       {
2312         Lisp_Char_Table_Entry *cte;
2313         int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2314         /* make sure that there is a separate entry for the row. */
2315         if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2316           ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2317         cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2318         cte->level2[range->row - 32] = val;
2319       }
2320 #endif /* not UTF2000 */
2321       break;
2322 #endif /* MULE */
2323
2324     case CHARTAB_RANGE_CHAR:
2325 #ifdef UTF2000
2326       /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2327       put_char_id_table_0 (ct, range->ch, val);
2328       break;
2329 #elif defined(MULE)
2330       {
2331         Lisp_Object charset;
2332         int byte1, byte2;
2333
2334         BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2335         if (EQ (charset, Vcharset_ascii))
2336           ct->ascii[byte1] = val;
2337         else if (EQ (charset, Vcharset_control_1))
2338           ct->ascii[byte1 + 128] = val;
2339         else
2340           {
2341             Lisp_Char_Table_Entry *cte;
2342             int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2343             /* make sure that there is a separate entry for the row. */
2344             if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2345               ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2346             cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2347             /* now CTE is a char table entry for the charset;
2348                each entry is for a single row (or character of
2349                a one-octet charset). */
2350             if (XCHARSET_DIMENSION (charset) == 1)
2351               cte->level2[byte1 - 32] = val;
2352             else
2353               {
2354                 /* assigning to one character in a two-octet charset. */
2355                 /* make sure that the charset row contains a separate
2356                    entry for each character. */
2357                 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2358                   cte->level2[byte1 - 32] =
2359                     make_char_table_entry (cte->level2[byte1 - 32]);
2360                 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2361                 cte->level2[byte2 - 32] = val;
2362               }
2363           }
2364       }
2365 #else /* not MULE */
2366       ct->ascii[(unsigned char) (range->ch)] = val;
2367       break;
2368 #endif /* not MULE */
2369     }
2370
2371 #ifndef UTF2000
2372   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2373     update_syntax_table (ct);
2374 #endif
2375 }
2376
2377 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2378 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2379
2380 RANGE specifies one or more characters to be affected and should be
2381 one of the following:
2382
2383 -- t (all characters are affected)
2384 -- A charset (only allowed when Mule support is present)
2385 -- A vector of two elements: a two-octet charset and a row number
2386    (only allowed when Mule support is present)
2387 -- A single character
2388
2389 VALUE must be a value appropriate for the type of CHAR-TABLE.
2390 See `valid-char-table-type-p'.
2391 */
2392        (range, value, char_table))
2393 {
2394   Lisp_Char_Table *ct;
2395   struct chartab_range rainj;
2396
2397   CHECK_CHAR_TABLE (char_table);
2398   ct = XCHAR_TABLE (char_table);
2399   check_valid_char_table_value (value, ct->type, ERROR_ME);
2400   decode_char_table_range (range, &rainj);
2401   value = canonicalize_char_table_value (value, ct->type);
2402   put_char_table (ct, &rainj, value);
2403   return Qnil;
2404 }
2405
2406 #ifndef UTF2000
2407 /* Map FN over the ASCII chars in CT. */
2408
2409 static int
2410 map_over_charset_ascii (Lisp_Char_Table *ct,
2411                         int (*fn) (struct chartab_range *range,
2412                                    Lisp_Object val, void *arg),
2413                         void *arg)
2414 {
2415   struct chartab_range rainj;
2416   int i, retval;
2417   int start = 0;
2418 #ifdef MULE
2419   int stop = 128;
2420 #else
2421   int stop = 256;
2422 #endif
2423
2424   rainj.type = CHARTAB_RANGE_CHAR;
2425
2426   for (i = start, retval = 0; i < stop && retval == 0; i++)
2427     {
2428       rainj.ch = (Emchar) i;
2429       retval = (fn) (&rainj, ct->ascii[i], arg);
2430     }
2431
2432   return retval;
2433 }
2434
2435 #ifdef MULE
2436
2437 /* Map FN over the Control-1 chars in CT. */
2438
2439 static int
2440 map_over_charset_control_1 (Lisp_Char_Table *ct,
2441                             int (*fn) (struct chartab_range *range,
2442                                        Lisp_Object val, void *arg),
2443                             void *arg)
2444 {
2445   struct chartab_range rainj;
2446   int i, retval;
2447   int start = 128;
2448   int stop  = start + 32;
2449
2450   rainj.type = CHARTAB_RANGE_CHAR;
2451
2452   for (i = start, retval = 0; i < stop && retval == 0; i++)
2453     {
2454       rainj.ch = (Emchar) (i);
2455       retval = (fn) (&rainj, ct->ascii[i], arg);
2456     }
2457
2458   return retval;
2459 }
2460
2461 /* Map FN over the row ROW of two-byte charset CHARSET.
2462    There must be a separate value for that row in the char table.
2463    CTE specifies the char table entry for CHARSET. */
2464
2465 static int
2466 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2467                       Lisp_Object charset, int row,
2468                       int (*fn) (struct chartab_range *range,
2469                                  Lisp_Object val, void *arg),
2470                       void *arg)
2471 {
2472   Lisp_Object val = cte->level2[row - 32];
2473
2474   if (!CHAR_TABLE_ENTRYP (val))
2475     {
2476       struct chartab_range rainj;
2477
2478       rainj.type = CHARTAB_RANGE_ROW;
2479       rainj.charset = charset;
2480       rainj.row = row;
2481       return (fn) (&rainj, val, arg);
2482     }
2483   else
2484     {
2485       struct chartab_range rainj;
2486       int i, retval;
2487       int charset94_p = (XCHARSET_CHARS (charset) == 94);
2488       int start = charset94_p ?  33 :  32;
2489       int stop  = charset94_p ? 127 : 128;
2490
2491       cte = XCHAR_TABLE_ENTRY (val);
2492
2493       rainj.type = CHARTAB_RANGE_CHAR;
2494
2495       for (i = start, retval = 0; i < stop && retval == 0; i++)
2496         {
2497           rainj.ch = MAKE_CHAR (charset, row, i);
2498           retval = (fn) (&rainj, cte->level2[i - 32], arg);
2499         }
2500       return retval;
2501     }
2502 }
2503
2504
2505 static int
2506 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2507                         int (*fn) (struct chartab_range *range,
2508                                    Lisp_Object val, void *arg),
2509                         void *arg)
2510 {
2511   Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2512   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2513
2514   if (!CHARSETP (charset)
2515       || lb == LEADING_BYTE_ASCII
2516       || lb == LEADING_BYTE_CONTROL_1)
2517     return 0;
2518
2519   if (!CHAR_TABLE_ENTRYP (val))
2520     {
2521       struct chartab_range rainj;
2522
2523       rainj.type = CHARTAB_RANGE_CHARSET;
2524       rainj.charset = charset;
2525       return (fn) (&rainj, val, arg);
2526     }
2527
2528   {
2529     Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2530     int charset94_p = (XCHARSET_CHARS (charset) == 94);
2531     int start = charset94_p ?  33 :  32;
2532     int stop  = charset94_p ? 127 : 128;
2533     int i, retval;
2534
2535     if (XCHARSET_DIMENSION (charset) == 1)
2536       {
2537         struct chartab_range rainj;
2538         rainj.type = CHARTAB_RANGE_CHAR;
2539
2540         for (i = start, retval = 0; i < stop && retval == 0; i++)
2541           {
2542             rainj.ch = MAKE_CHAR (charset, i, 0);
2543             retval = (fn) (&rainj, cte->level2[i - 32], arg);
2544           }
2545       }
2546     else
2547       {
2548         for (i = start, retval = 0; i < stop && retval == 0; i++)
2549           retval = map_over_charset_row (cte, charset, i, fn, arg);
2550       }
2551
2552     return retval;
2553   }
2554 }
2555
2556 #endif /* MULE */
2557 #endif /* not UTF2000 */
2558
2559 #ifdef UTF2000
2560 struct map_char_table_for_charset_arg
2561 {
2562   int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2563   Lisp_Char_Table *ct;
2564   void *arg;
2565 };
2566
2567 static int
2568 map_char_table_for_charset_fun (struct chartab_range *range,
2569                                 Lisp_Object val, void *arg)
2570 {
2571   struct map_char_table_for_charset_arg *closure =
2572     (struct map_char_table_for_charset_arg *) arg;
2573   Lisp_Object ret;
2574
2575   switch (range->type)
2576     {
2577     case CHARTAB_RANGE_ALL:
2578       break;
2579
2580     case CHARTAB_RANGE_DEFAULT:
2581       break;
2582
2583     case CHARTAB_RANGE_CHARSET:
2584       break;
2585
2586     case CHARTAB_RANGE_ROW:
2587       break;
2588
2589     case CHARTAB_RANGE_CHAR:
2590       ret = get_char_table (range->ch, closure->ct);
2591       if (!UNBOUNDP (ret))
2592         return (closure->fn) (range, ret, closure->arg);
2593       break;
2594
2595     default:
2596       abort ();
2597     }
2598
2599   return 0;
2600 }
2601 #endif
2602
2603 /* Map FN (with client data ARG) over range RANGE in char table CT.
2604    Mapping stops the first time FN returns non-zero, and that value
2605    becomes the return value of map_char_table(). */
2606
2607 int
2608 map_char_table (Lisp_Char_Table *ct,
2609                 struct chartab_range *range,
2610                 int (*fn) (struct chartab_range *range,
2611                            Lisp_Object val, void *arg),
2612                 void *arg)
2613 {
2614   switch (range->type)
2615     {
2616     case CHARTAB_RANGE_ALL:
2617 #ifdef UTF2000
2618       if (!UNBOUNDP (ct->default_value))
2619         {
2620           struct chartab_range rainj;
2621           int retval;
2622
2623           rainj.type = CHARTAB_RANGE_DEFAULT;
2624           retval = (fn) (&rainj, ct->default_value, arg);
2625           if (retval != 0)
2626             return retval;
2627         }
2628       if (UINT8_BYTE_TABLE_P (ct->table))
2629         return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table),
2630                                           0, 3, fn, arg);
2631       else if (UINT16_BYTE_TABLE_P (ct->table))
2632         return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table),
2633                                            0, 3, fn, arg);
2634       else if (BYTE_TABLE_P (ct->table))
2635         return map_over_byte_table (XBYTE_TABLE(ct->table),
2636                                     0, 3, fn, arg);
2637       else if (!UNBOUNDP (ct->table))
2638 #if 0
2639         {
2640           struct chartab_range rainj;
2641           int unit = 1 << 30;
2642           Emchar c = 0;
2643           Emchar c1 = c + unit;
2644           int retval;
2645
2646           rainj.type = CHARTAB_RANGE_CHAR;
2647
2648           for (retval = 0; c < c1 && retval == 0; c++)
2649             {
2650               rainj.ch = c;
2651               retval = (fn) (&rainj, ct->table, arg);
2652             }
2653           return retval;
2654         }
2655 #else
2656       return (fn) (range, ct->table, arg);
2657 #endif
2658       return 0;
2659 #else
2660       {
2661         int retval;
2662
2663         retval = map_over_charset_ascii (ct, fn, arg);
2664         if (retval)
2665           return retval;
2666 #ifdef MULE
2667         retval = map_over_charset_control_1 (ct, fn, arg);
2668         if (retval)
2669           return retval;
2670         {
2671           Charset_ID i;
2672           Charset_ID start = MIN_LEADING_BYTE;
2673           Charset_ID stop  = start + NUM_LEADING_BYTES;
2674
2675           for (i = start, retval = 0; i < stop && retval == 0; i++)
2676             {
2677               retval = map_over_other_charset (ct, i, fn, arg);
2678             }
2679         }
2680 #endif /* MULE */
2681         return retval;
2682       }
2683 #endif
2684
2685 #ifdef UTF2000
2686     case CHARTAB_RANGE_DEFAULT:
2687       if (!UNBOUNDP (ct->default_value))
2688         return (fn) (range, ct->default_value, arg);
2689       return 0;
2690 #endif
2691
2692 #ifdef MULE
2693     case CHARTAB_RANGE_CHARSET:
2694 #ifdef UTF2000
2695       {
2696         Lisp_Object encoding_table
2697           = XCHARSET_ENCODING_TABLE (range->charset);
2698
2699         if (!NILP (encoding_table))
2700           {
2701             struct chartab_range rainj;
2702             struct map_char_table_for_charset_arg mcarg;
2703
2704             mcarg.fn = fn;
2705             mcarg.ct = ct;
2706             mcarg.arg = arg;
2707             rainj.type = CHARTAB_RANGE_ALL;
2708             return map_char_table (XCHAR_TABLE(encoding_table),
2709                                    &rainj,
2710                                    &map_char_table_for_charset_fun,
2711                                    &mcarg);
2712           }
2713       }
2714       return 0;
2715 #else
2716       return map_over_other_charset (ct,
2717                                      XCHARSET_LEADING_BYTE (range->charset),
2718                                      fn, arg);
2719 #endif
2720
2721     case CHARTAB_RANGE_ROW:
2722 #ifdef UTF2000
2723       {
2724         int cell_min, cell_max, i;
2725         int retval;
2726         struct chartab_range rainj;
2727
2728         if (XCHARSET_DIMENSION (range->charset) < 2)
2729           signal_simple_error ("Charset in row vector must be multi-byte",
2730                                range->charset);
2731         else
2732           {
2733             switch (XCHARSET_CHARS (range->charset))
2734               {
2735               case 94:
2736                 cell_min = 33; cell_max = 126;
2737                 break;
2738               case 96:
2739                 cell_min = 32; cell_max = 127;
2740                 break;
2741               case 128:
2742                 cell_min = 0; cell_max = 127;
2743                 break;
2744               case 256:
2745                 cell_min = 0; cell_max = 255;
2746                 break;
2747               default:
2748                 abort ();
2749               }
2750           }
2751         if (XCHARSET_DIMENSION (range->charset) == 2)
2752           check_int_range (range->row, cell_min, cell_max);
2753         else if (XCHARSET_DIMENSION (range->charset) == 3)
2754           {
2755             check_int_range (range->row >> 8  , cell_min, cell_max);
2756             check_int_range (range->row & 0xFF, cell_min, cell_max);
2757           }
2758         else if (XCHARSET_DIMENSION (range->charset) == 4)
2759           {
2760             check_int_range ( range->row >> 16       , cell_min, cell_max);
2761             check_int_range ((range->row >> 8) & 0xFF, cell_min, cell_max);
2762             check_int_range ( range->row       & 0xFF, cell_min, cell_max);
2763           }
2764         else
2765           abort ();
2766
2767         rainj.type = CHARTAB_RANGE_CHAR;
2768         for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2769           {
2770             Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2771
2772             if ( charset_code_point (range->charset, ch) >= 0 )
2773               {
2774                 Lisp_Object val
2775                   = get_byte_table (get_byte_table
2776                                     (get_byte_table
2777                                      (get_byte_table
2778                                       (ct->table,
2779                                        (unsigned char)(ch >> 24)),
2780                                       (unsigned char) (ch >> 16)),
2781                                      (unsigned char)  (ch >> 8)),
2782                                     (unsigned char)    ch);
2783
2784                 if (UNBOUNDP (val))
2785                   val = ct->default_value;
2786                 rainj.ch = ch;
2787                 retval = (fn) (&rainj, val, arg);
2788               }
2789           }
2790         return retval;
2791       }
2792 #else
2793       {
2794         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2795                                     - MIN_LEADING_BYTE];
2796         if (!CHAR_TABLE_ENTRYP (val))
2797           {
2798             struct chartab_range rainj;
2799
2800             rainj.type = CHARTAB_RANGE_ROW;
2801             rainj.charset = range->charset;
2802             rainj.row = range->row;
2803             return (fn) (&rainj, val, arg);
2804           }
2805         else
2806           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2807                                        range->charset, range->row,
2808                                        fn, arg);
2809       }
2810 #endif /* not UTF2000 */
2811 #endif /* MULE */
2812
2813     case CHARTAB_RANGE_CHAR:
2814       {
2815         Emchar ch = range->ch;
2816         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2817
2818         if (!UNBOUNDP (val))
2819           {
2820             struct chartab_range rainj;
2821
2822             rainj.type = CHARTAB_RANGE_CHAR;
2823             rainj.ch = ch;
2824             return (fn) (&rainj, val, arg);
2825           }
2826         return 0;
2827       }
2828
2829     default:
2830       abort ();
2831     }
2832
2833   return 0;
2834 }
2835
2836 struct slow_map_char_table_arg
2837 {
2838   Lisp_Object function;
2839   Lisp_Object retval;
2840 };
2841
2842 static int
2843 slow_map_char_table_fun (struct chartab_range *range,
2844                          Lisp_Object val, void *arg)
2845 {
2846   Lisp_Object ranjarg = Qnil;
2847   struct slow_map_char_table_arg *closure =
2848     (struct slow_map_char_table_arg *) arg;
2849
2850   switch (range->type)
2851     {
2852     case CHARTAB_RANGE_ALL:
2853       ranjarg = Qt;
2854       break;
2855
2856 #ifdef UTF2000
2857     case CHARTAB_RANGE_DEFAULT:
2858       ranjarg = Qnil;
2859       break;
2860 #endif
2861
2862 #ifdef MULE
2863     case CHARTAB_RANGE_CHARSET:
2864       ranjarg = XCHARSET_NAME (range->charset);
2865       break;
2866
2867     case CHARTAB_RANGE_ROW:
2868       ranjarg = vector2 (XCHARSET_NAME (range->charset),
2869                          make_int (range->row));
2870       break;
2871 #endif /* MULE */
2872     case CHARTAB_RANGE_CHAR:
2873       ranjarg = make_char (range->ch);
2874       break;
2875     default:
2876       abort ();
2877     }
2878
2879   closure->retval = call2 (closure->function, ranjarg, val);
2880   return !NILP (closure->retval);
2881 }
2882
2883 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2884 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2885 each key and value in the table.
2886
2887 RANGE specifies a subrange to map over and is in the same format as
2888 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
2889 the entire table.
2890 */
2891        (function, char_table, range))
2892 {
2893   Lisp_Char_Table *ct;
2894   struct slow_map_char_table_arg slarg;
2895   struct gcpro gcpro1, gcpro2;
2896   struct chartab_range rainj;
2897
2898   CHECK_CHAR_TABLE (char_table);
2899   ct = XCHAR_TABLE (char_table);
2900   if (NILP (range))
2901     range = Qt;
2902   decode_char_table_range (range, &rainj);
2903   slarg.function = function;
2904   slarg.retval = Qnil;
2905   GCPRO2 (slarg.function, slarg.retval);
2906   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2907   UNGCPRO;
2908
2909   return slarg.retval;
2910 }
2911
2912 \f
2913 /************************************************************************/
2914 /*                         Character Attributes                         */
2915 /************************************************************************/
2916
2917 #ifdef UTF2000
2918
2919 Lisp_Object Vchar_attribute_hash_table;
2920
2921 /* We store the char-attributes in hash tables with the names as the
2922    key and the actual char-id-table object as the value.  Occasionally
2923    we need to use them in a list format.  These routines provide us
2924    with that. */
2925 struct char_attribute_list_closure
2926 {
2927   Lisp_Object *char_attribute_list;
2928 };
2929
2930 static int
2931 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
2932                                    void *char_attribute_list_closure)
2933 {
2934   /* This function can GC */
2935   struct char_attribute_list_closure *calcl
2936     = (struct char_attribute_list_closure*) char_attribute_list_closure;
2937   Lisp_Object *char_attribute_list = calcl->char_attribute_list;
2938
2939   *char_attribute_list = Fcons (key, *char_attribute_list);
2940   return 0;
2941 }
2942
2943 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
2944 Return the list of all existing character attributes except coded-charsets.
2945 */
2946        ())
2947 {
2948   Lisp_Object char_attribute_list = Qnil;
2949   struct gcpro gcpro1;
2950   struct char_attribute_list_closure char_attribute_list_closure;
2951
2952   GCPRO1 (char_attribute_list);
2953   char_attribute_list_closure.char_attribute_list = &char_attribute_list;
2954   elisp_maphash (add_char_attribute_to_list_mapper,
2955                  Vchar_attribute_hash_table,
2956                  &char_attribute_list_closure);
2957   UNGCPRO;
2958   return char_attribute_list;
2959 }
2960
2961 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
2962 Return char-id-table corresponding to ATTRIBUTE.
2963 */
2964        (attribute))
2965 {
2966   return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
2967 }
2968
2969
2970 /* We store the char-id-tables in hash tables with the attributes as
2971    the key and the actual char-id-table object as the value.  Each
2972    char-id-table stores values of an attribute corresponding with
2973    characters.  Occasionally we need to get attributes of a character
2974    in a association-list format.  These routines provide us with
2975    that. */
2976 struct char_attribute_alist_closure
2977 {
2978   Emchar char_id;
2979   Lisp_Object *char_attribute_alist;
2980 };
2981
2982 static int
2983 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
2984                                  void *char_attribute_alist_closure)
2985 {
2986   /* This function can GC */
2987   struct char_attribute_alist_closure *caacl =
2988     (struct char_attribute_alist_closure*) char_attribute_alist_closure;
2989   Lisp_Object ret
2990     = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
2991   if (!UNBOUNDP (ret))
2992     {
2993       Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
2994       *char_attribute_alist
2995         = Fcons (Fcons (key, ret), *char_attribute_alist);
2996     }
2997   return 0;
2998 }
2999
3000 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3001 Return the alist of attributes of CHARACTER.
3002 */
3003        (character))
3004 {
3005   Lisp_Object alist = Qnil;
3006   int i;
3007
3008   CHECK_CHAR (character);
3009   {
3010     struct gcpro gcpro1;
3011     struct char_attribute_alist_closure char_attribute_alist_closure;
3012
3013     GCPRO1 (alist);
3014     char_attribute_alist_closure.char_id = XCHAR (character);
3015     char_attribute_alist_closure.char_attribute_alist = &alist;
3016     elisp_maphash (add_char_attribute_alist_mapper,
3017                    Vchar_attribute_hash_table,
3018                    &char_attribute_alist_closure);
3019     UNGCPRO;
3020   }
3021
3022   for (i = 0; i < countof (chlook->charset_by_leading_byte); i++)
3023     {
3024       Lisp_Object ccs = chlook->charset_by_leading_byte[i];
3025
3026       if (!NILP (ccs))
3027         {
3028           Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3029           Lisp_Object cpos;
3030
3031           if ( CHAR_TABLEP (encoding_table)
3032                && INTP (cpos
3033                         = get_char_id_table (XCHAR_TABLE(encoding_table),
3034                                              XCHAR (character))) )
3035             {
3036               alist = Fcons (Fcons (ccs, cpos), alist);
3037             }
3038         }
3039     }
3040   return alist;
3041 }
3042
3043 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3044 Return the value of CHARACTER's ATTRIBUTE.
3045 Return DEFAULT-VALUE if the value is not exist.
3046 */
3047        (character, attribute, default_value))
3048 {
3049   Lisp_Object ccs;
3050
3051   CHECK_CHAR (character);
3052   if (!NILP (ccs = Ffind_charset (attribute)))
3053     {
3054       Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3055
3056       if (CHAR_TABLEP (encoding_table))
3057         return get_char_id_table (XCHAR_TABLE(encoding_table),
3058                                   XCHAR (character));
3059     }
3060   else
3061     {
3062       Lisp_Object table = Fgethash (attribute,
3063                                     Vchar_attribute_hash_table,
3064                                     Qunbound);
3065       if (!UNBOUNDP (table))
3066         {
3067           Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3068                                                XCHAR (character));
3069           if (!UNBOUNDP (ret))
3070             return ret;
3071         }
3072     }
3073   return default_value;
3074 }
3075
3076 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3077 Store CHARACTER's ATTRIBUTE with VALUE.
3078 */
3079        (character, attribute, value))
3080 {
3081   Lisp_Object ccs;
3082
3083   ccs = Ffind_charset (attribute);
3084   if (!NILP (ccs))
3085     {
3086       CHECK_CHAR (character);
3087       return put_char_ccs_code_point (character, ccs, value);
3088     }
3089   else if (EQ (attribute, Q_decomposition))
3090     {
3091       Lisp_Object seq;
3092
3093       CHECK_CHAR (character);
3094       if (!CONSP (value))
3095         signal_simple_error ("Invalid value for ->decomposition",
3096                              value);
3097
3098       if (CONSP (Fcdr (value)))
3099         {
3100           Lisp_Object rest = value;
3101           Lisp_Object table = Vcharacter_composition_table;
3102           size_t len;
3103           int i = 0;
3104
3105           GET_EXTERNAL_LIST_LENGTH (rest, len);
3106           seq = make_vector (len, Qnil);
3107
3108           while (CONSP (rest))
3109             {
3110               Lisp_Object v = Fcar (rest);
3111               Lisp_Object ntable;
3112               Emchar c
3113                 = to_char_id (v, "Invalid value for ->decomposition", value);
3114
3115               if (c < 0)
3116                 XVECTOR_DATA(seq)[i++] = v;
3117               else
3118                 XVECTOR_DATA(seq)[i++] = make_char (c);
3119               rest = Fcdr (rest);
3120               if (!CONSP (rest))
3121                 {
3122                   put_char_id_table (XCHAR_TABLE(table),
3123                                      make_char (c), character);
3124                   break;
3125                 }
3126               else
3127                 {
3128                   ntable = get_char_id_table (XCHAR_TABLE(table), c);
3129                   if (!CHAR_TABLEP (ntable))
3130                     {
3131                       ntable = make_char_id_table (Qnil);
3132                       put_char_id_table (XCHAR_TABLE(table),
3133                                          make_char (c), ntable);
3134                     }
3135                   table = ntable;
3136                 }
3137             }
3138         }
3139       else
3140         {
3141           Lisp_Object v = Fcar (value);
3142
3143           if (INTP (v))
3144             {
3145               Emchar c = XINT (v);
3146               Lisp_Object ret
3147                 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3148                                      c);
3149
3150               if (NILP (Fmemq (v, ret)))
3151                 {
3152                   put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3153                                      make_char (c), Fcons (character, ret));
3154                 }
3155             }
3156           seq = make_vector (1, v);
3157         }
3158       value = seq;
3159     }
3160   else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3161     {
3162       Lisp_Object ret;
3163       Emchar c;
3164
3165       CHECK_CHAR (character);
3166       if (!INTP (value))
3167         signal_simple_error ("Invalid value for ->ucs", value);
3168
3169       c = XINT (value);
3170
3171       ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
3172       if (NILP (Fmemq (character, ret)))
3173         {
3174           put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3175                              make_char (c), Fcons (character, ret));
3176         }
3177 #if 0
3178       if (EQ (attribute, Q_ucs))
3179         attribute = Qto_ucs;
3180 #endif
3181     }
3182   {
3183     Lisp_Object table = Fgethash (attribute,
3184                                   Vchar_attribute_hash_table,
3185                                   Qnil);
3186
3187     if (NILP (table))
3188       {
3189         table = make_char_id_table (Qunbound);
3190         Fputhash (attribute, table, Vchar_attribute_hash_table);
3191       }
3192     put_char_id_table (XCHAR_TABLE(table), character, value);
3193     return value;
3194   }
3195 }
3196
3197 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3198 Remove CHARACTER's ATTRIBUTE.
3199 */
3200        (character, attribute))
3201 {
3202   Lisp_Object ccs;
3203
3204   CHECK_CHAR (character);
3205   ccs = Ffind_charset (attribute);
3206   if (!NILP (ccs))
3207     {
3208       return remove_char_ccs (character, ccs);
3209     }
3210   else
3211     {
3212       Lisp_Object table = Fgethash (attribute,
3213                                     Vchar_attribute_hash_table,
3214                                     Qunbound);
3215       if (!UNBOUNDP (table))
3216         {
3217           put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3218           return Qt;
3219         }
3220     }
3221   return Qnil;
3222 }
3223
3224 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3225 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3226 each key and value in the table.
3227
3228 RANGE specifies a subrange to map over and is in the same format as
3229 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
3230 the entire table.
3231 */
3232        (function, attribute, range))
3233 {
3234   Lisp_Object ccs;
3235   Lisp_Char_Table *ct;
3236   struct slow_map_char_table_arg slarg;
3237   struct gcpro gcpro1, gcpro2;
3238   struct chartab_range rainj;
3239
3240   if (!NILP (ccs = Ffind_charset (attribute)))
3241     {
3242       Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3243
3244       if (CHAR_TABLEP (encoding_table))
3245         ct = XCHAR_TABLE (encoding_table);
3246       else
3247         return Qnil;
3248     }
3249   else
3250     {
3251       Lisp_Object table = Fgethash (attribute,
3252                                     Vchar_attribute_hash_table,
3253                                     Qunbound);
3254       if (CHAR_TABLEP (table))
3255         ct = XCHAR_TABLE (table);
3256       else
3257         return Qnil;
3258     }
3259   if (NILP (range))
3260     range = Qt;
3261   decode_char_table_range (range, &rainj);
3262   slarg.function = function;
3263   slarg.retval = Qnil;
3264   GCPRO2 (slarg.function, slarg.retval);
3265   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3266   UNGCPRO;
3267
3268   return slarg.retval;
3269 }
3270
3271 EXFUN (Fmake_char, 3);
3272 EXFUN (Fdecode_char, 2);
3273
3274 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3275 Store character's ATTRIBUTES.
3276 */
3277        (attributes))
3278 {
3279   Lisp_Object rest = attributes;
3280   Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3281   Lisp_Object character;
3282
3283   if (NILP (code))
3284     {
3285       while (CONSP (rest))
3286         {
3287           Lisp_Object cell = Fcar (rest);
3288           Lisp_Object ccs;
3289
3290           if (!LISTP (cell))
3291             signal_simple_error ("Invalid argument", attributes);
3292           if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3293               && ((XCHARSET_FINAL (ccs) != 0) ||
3294                   (XCHARSET_UCS_MAX (ccs) > 0)) )
3295             {
3296               cell = Fcdr (cell);
3297               if (CONSP (cell))
3298                 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3299               else
3300                 character = Fdecode_char (ccs, cell);
3301               if (!NILP (character))
3302                 goto setup_attributes;
3303             }
3304           rest = Fcdr (rest);
3305         }
3306       if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3307            (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3308
3309         {
3310           if (!INTP (code))
3311             signal_simple_error ("Invalid argument", attributes);
3312           else
3313             character = make_char (XINT (code) + 0x100000);
3314           goto setup_attributes;
3315         }
3316       return Qnil;
3317     }
3318   else if (!INTP (code))
3319     signal_simple_error ("Invalid argument", attributes);
3320   else
3321     character = make_char (XINT (code));
3322
3323  setup_attributes:
3324   rest = attributes;
3325   while (CONSP (rest))
3326     {
3327       Lisp_Object cell = Fcar (rest);
3328
3329       if (!LISTP (cell))
3330         signal_simple_error ("Invalid argument", attributes);
3331
3332       Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3333       rest = Fcdr (rest);
3334     }
3335   return character;
3336 }
3337
3338 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3339 Retrieve the character of the given ATTRIBUTES.
3340 */
3341        (attributes))
3342 {
3343   Lisp_Object rest = attributes;
3344   Lisp_Object code;
3345
3346   while (CONSP (rest))
3347     {
3348       Lisp_Object cell = Fcar (rest);
3349       Lisp_Object ccs;
3350
3351       if (!LISTP (cell))
3352         signal_simple_error ("Invalid argument", attributes);
3353       if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3354         {
3355           cell = Fcdr (cell);
3356           if (CONSP (cell))
3357             return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3358           else
3359             return Fdecode_char (ccs, cell);
3360         }
3361       rest = Fcdr (rest);
3362     }
3363   if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3364        (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3365     {
3366       if (!INTP (code))
3367         signal_simple_error ("Invalid argument", attributes);
3368       else
3369         return make_char (XINT (code) + 0x100000);
3370     }
3371   return Qnil;
3372 }
3373
3374 #endif
3375
3376 \f
3377 /************************************************************************/
3378 /*                         Char table read syntax                       */
3379 /************************************************************************/
3380
3381 static int
3382 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3383                        Error_behavior errb)
3384 {
3385   /* #### should deal with ERRB */
3386   symbol_to_char_table_type (value);
3387   return 1;
3388 }
3389
3390 static int
3391 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3392                        Error_behavior errb)
3393 {
3394   Lisp_Object rest;
3395
3396   /* #### should deal with ERRB */
3397   EXTERNAL_LIST_LOOP (rest, value)
3398     {
3399       Lisp_Object range = XCAR (rest);
3400       struct chartab_range dummy;
3401
3402       rest = XCDR (rest);
3403       if (!CONSP (rest))
3404         signal_simple_error ("Invalid list format", value);
3405       if (CONSP (range))
3406         {
3407           if (!CONSP (XCDR (range))
3408               || !NILP (XCDR (XCDR (range))))
3409             signal_simple_error ("Invalid range format", range);
3410           decode_char_table_range (XCAR (range), &dummy);
3411           decode_char_table_range (XCAR (XCDR (range)), &dummy);
3412         }
3413       else
3414         decode_char_table_range (range, &dummy);
3415     }
3416
3417   return 1;
3418 }
3419
3420 static Lisp_Object
3421 chartab_instantiate (Lisp_Object data)
3422 {
3423   Lisp_Object chartab;
3424   Lisp_Object type = Qgeneric;
3425   Lisp_Object dataval = Qnil;
3426
3427   while (!NILP (data))
3428     {
3429       Lisp_Object keyw = Fcar (data);
3430       Lisp_Object valw;
3431
3432       data = Fcdr (data);
3433       valw = Fcar (data);
3434       data = Fcdr (data);
3435       if (EQ (keyw, Qtype))
3436         type = valw;
3437       else if (EQ (keyw, Qdata))
3438         dataval = valw;
3439     }
3440
3441   chartab = Fmake_char_table (type);
3442
3443   data = dataval;
3444   while (!NILP (data))
3445     {
3446       Lisp_Object range = Fcar (data);
3447       Lisp_Object val = Fcar (Fcdr (data));
3448
3449       data = Fcdr (Fcdr (data));
3450       if (CONSP (range))
3451         {
3452           if (CHAR_OR_CHAR_INTP (XCAR (range)))
3453             {
3454               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3455               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3456               Emchar i;
3457
3458               for (i = first; i <= last; i++)
3459                  Fput_char_table (make_char (i), val, chartab);
3460             }
3461           else
3462             abort ();
3463         }
3464       else
3465         Fput_char_table (range, val, chartab);
3466     }
3467
3468   return chartab;
3469 }
3470
3471 #ifdef MULE
3472
3473 \f
3474 /************************************************************************/
3475 /*                     Category Tables, specifically                    */
3476 /************************************************************************/
3477
3478 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3479 Return t if OBJECT is a category table.
3480 A category table is a type of char table used for keeping track of
3481 categories.  Categories are used for classifying characters for use
3482 in regexps -- you can refer to a category rather than having to use
3483 a complicated [] expression (and category lookups are significantly
3484 faster).
3485
3486 There are 95 different categories available, one for each printable
3487 character (including space) in the ASCII charset.  Each category
3488 is designated by one such character, called a "category designator".
3489 They are specified in a regexp using the syntax "\\cX", where X is
3490 a category designator.
3491
3492 A category table specifies, for each character, the categories that
3493 the character is in.  Note that a character can be in more than one
3494 category.  More specifically, a category table maps from a character
3495 to either the value nil (meaning the character is in no categories)
3496 or a 95-element bit vector, specifying for each of the 95 categories
3497 whether the character is in that category.
3498
3499 Special Lisp functions are provided that abstract this, so you do not
3500 have to directly manipulate bit vectors.
3501 */
3502        (object))
3503 {
3504   return (CHAR_TABLEP (object) &&
3505           XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3506     Qt : Qnil;
3507 }
3508
3509 static Lisp_Object
3510 check_category_table (Lisp_Object object, Lisp_Object default_)
3511 {
3512   if (NILP (object))
3513     object = default_;
3514   while (NILP (Fcategory_table_p (object)))
3515     object = wrong_type_argument (Qcategory_table_p, object);
3516   return object;
3517 }
3518
3519 int
3520 check_category_char (Emchar ch, Lisp_Object table,
3521                      unsigned int designator, unsigned int not)
3522 {
3523   REGISTER Lisp_Object temp;
3524   Lisp_Char_Table *ctbl;
3525 #ifdef ERROR_CHECK_TYPECHECK
3526   if (NILP (Fcategory_table_p (table)))
3527     signal_simple_error ("Expected category table", table);
3528 #endif
3529   ctbl = XCHAR_TABLE (table);
3530   temp = get_char_table (ch, ctbl);
3531   if (NILP (temp))
3532     return not;
3533
3534   designator -= ' ';
3535   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
3536 }
3537
3538 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3539 Return t if category of the character at POSITION includes DESIGNATOR.
3540 Optional third arg BUFFER specifies which buffer to use, and defaults
3541 to the current buffer.
3542 Optional fourth arg CATEGORY-TABLE specifies the category table to
3543 use, and defaults to BUFFER's category table.
3544 */
3545        (position, designator, buffer, category_table))
3546 {
3547   Lisp_Object ctbl;
3548   Emchar ch;
3549   unsigned int des;
3550   struct buffer *buf = decode_buffer (buffer, 0);
3551
3552   CHECK_INT (position);
3553   CHECK_CATEGORY_DESIGNATOR (designator);
3554   des = XCHAR (designator);
3555   ctbl = check_category_table (category_table, Vstandard_category_table);
3556   ch = BUF_FETCH_CHAR (buf, XINT (position));
3557   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3558 }
3559
3560 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3561 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3562 Optional third arg CATEGORY-TABLE specifies the category table to use,
3563 and defaults to the standard category table.
3564 */
3565        (character, designator, category_table))
3566 {
3567   Lisp_Object ctbl;
3568   Emchar ch;
3569   unsigned int des;
3570
3571   CHECK_CATEGORY_DESIGNATOR (designator);
3572   des = XCHAR (designator);
3573   CHECK_CHAR (character);
3574   ch = XCHAR (character);
3575   ctbl = check_category_table (category_table, Vstandard_category_table);
3576   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3577 }
3578
3579 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3580 Return BUFFER's current category table.
3581 BUFFER defaults to the current buffer.
3582 */
3583        (buffer))
3584 {
3585   return decode_buffer (buffer, 0)->category_table;
3586 }
3587
3588 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3589 Return the standard category table.
3590 This is the one used for new buffers.
3591 */
3592        ())
3593 {
3594   return Vstandard_category_table;
3595 }
3596
3597 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3598 Return a new category table which is a copy of CATEGORY-TABLE.
3599 CATEGORY-TABLE defaults to the standard category table.
3600 */
3601        (category_table))
3602 {
3603   if (NILP (Vstandard_category_table))
3604     return Fmake_char_table (Qcategory);
3605
3606   category_table =
3607     check_category_table (category_table, Vstandard_category_table);
3608   return Fcopy_char_table (category_table);
3609 }
3610
3611 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3612 Select CATEGORY-TABLE as the new category table for BUFFER.
3613 BUFFER defaults to the current buffer if omitted.
3614 */
3615        (category_table, buffer))
3616 {
3617   struct buffer *buf = decode_buffer (buffer, 0);
3618   category_table = check_category_table (category_table, Qnil);
3619   buf->category_table = category_table;
3620   /* Indicate that this buffer now has a specified category table.  */
3621   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3622   return category_table;
3623 }
3624
3625 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3626 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3627 */
3628        (object))
3629 {
3630   return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3631 }
3632
3633 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3634 Return t if OBJECT is a category table value.
3635 Valid values are nil or a bit vector of size 95.
3636 */
3637        (object))
3638 {
3639   return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3640 }
3641
3642
3643 #define CATEGORYP(x) \
3644   (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3645
3646 #define CATEGORY_SET(c)                                         \
3647   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3648
3649 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3650    The faster version of `!NILP (Faref (category_set, category))'.  */
3651 #define CATEGORY_MEMBER(category, category_set)                 \
3652   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3653
3654 /* Return 1 if there is a word boundary between two word-constituent
3655    characters C1 and C2 if they appear in this order, else return 0.
3656    Use the macro WORD_BOUNDARY_P instead of calling this function
3657    directly.  */
3658
3659 int word_boundary_p (Emchar c1, Emchar c2);
3660 int
3661 word_boundary_p (Emchar c1, Emchar c2)
3662 {
3663   Lisp_Object category_set1, category_set2;
3664   Lisp_Object tail;
3665   int default_result;
3666
3667 #if 0
3668   if (COMPOSITE_CHAR_P (c1))
3669     c1 = cmpchar_component (c1, 0, 1);
3670   if (COMPOSITE_CHAR_P (c2))
3671     c2 = cmpchar_component (c2, 0, 1);
3672 #endif
3673
3674   if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3675     {
3676       tail = Vword_separating_categories;
3677       default_result = 0;
3678     }
3679   else
3680     {
3681       tail = Vword_combining_categories;
3682       default_result = 1;
3683     }
3684
3685   category_set1 = CATEGORY_SET (c1);
3686   if (NILP (category_set1))
3687     return default_result;
3688   category_set2 = CATEGORY_SET (c2);
3689   if (NILP (category_set2))
3690     return default_result;
3691
3692   for (; CONSP (tail); tail = XCONS (tail)->cdr)
3693     {
3694       Lisp_Object elt = XCONS(tail)->car;
3695
3696       if (CONSP (elt)
3697           && CATEGORYP (XCONS (elt)->car)
3698           && CATEGORYP (XCONS (elt)->cdr)
3699           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3700           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3701         return !default_result;
3702     }
3703   return default_result;
3704 }
3705 #endif /* MULE */
3706
3707 \f
3708 void
3709 syms_of_chartab (void)
3710 {
3711 #ifdef UTF2000
3712   INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3713   INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3714   INIT_LRECORD_IMPLEMENTATION (byte_table);
3715
3716   defsymbol (&Qto_ucs,                  "=>ucs");
3717   defsymbol (&Q_ucs,                    "->ucs");
3718   defsymbol (&Q_decomposition,          "->decomposition");
3719   defsymbol (&Qcompat,                  "compat");
3720   defsymbol (&Qisolated,                "isolated");
3721   defsymbol (&Qinitial,                 "initial");
3722   defsymbol (&Qmedial,                  "medial");
3723   defsymbol (&Qfinal,                   "final");
3724   defsymbol (&Qvertical,                "vertical");
3725   defsymbol (&QnoBreak,                 "noBreak");
3726   defsymbol (&Qfraction,                "fraction");
3727   defsymbol (&Qsuper,                   "super");
3728   defsymbol (&Qsub,                     "sub");
3729   defsymbol (&Qcircle,                  "circle");
3730   defsymbol (&Qsquare,                  "square");
3731   defsymbol (&Qwide,                    "wide");
3732   defsymbol (&Qnarrow,                  "narrow");
3733   defsymbol (&Qsmall,                   "small");
3734   defsymbol (&Qfont,                    "font");
3735
3736   DEFSUBR (Fchar_attribute_list);
3737   DEFSUBR (Ffind_char_attribute_table);
3738   DEFSUBR (Fchar_attribute_alist);
3739   DEFSUBR (Fget_char_attribute);
3740   DEFSUBR (Fput_char_attribute);
3741   DEFSUBR (Fremove_char_attribute);
3742   DEFSUBR (Fmap_char_attribute);
3743   DEFSUBR (Fdefine_char);
3744   DEFSUBR (Ffind_char);
3745   DEFSUBR (Fchar_variants);
3746
3747   DEFSUBR (Fget_composite_char);
3748 #endif
3749
3750   INIT_LRECORD_IMPLEMENTATION (char_table);
3751
3752 #ifdef MULE
3753 #ifndef UTF2000
3754   INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3755 #endif
3756
3757   defsymbol (&Qcategory_table_p, "category-table-p");
3758   defsymbol (&Qcategory_designator_p, "category-designator-p");
3759   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3760 #endif /* MULE */
3761
3762   defsymbol (&Qchar_table, "char-table");
3763   defsymbol (&Qchar_tablep, "char-table-p");
3764
3765   DEFSUBR (Fchar_table_p);
3766   DEFSUBR (Fchar_table_type_list);
3767   DEFSUBR (Fvalid_char_table_type_p);
3768   DEFSUBR (Fchar_table_type);
3769   DEFSUBR (Freset_char_table);
3770   DEFSUBR (Fmake_char_table);
3771   DEFSUBR (Fcopy_char_table);
3772   DEFSUBR (Fget_char_table);
3773   DEFSUBR (Fget_range_char_table);
3774   DEFSUBR (Fvalid_char_table_value_p);
3775   DEFSUBR (Fcheck_valid_char_table_value);
3776   DEFSUBR (Fput_char_table);
3777   DEFSUBR (Fmap_char_table);
3778
3779 #ifdef MULE
3780   DEFSUBR (Fcategory_table_p);
3781   DEFSUBR (Fcategory_table);
3782   DEFSUBR (Fstandard_category_table);
3783   DEFSUBR (Fcopy_category_table);
3784   DEFSUBR (Fset_category_table);
3785   DEFSUBR (Fcheck_category_at);
3786   DEFSUBR (Fchar_in_category_p);
3787   DEFSUBR (Fcategory_designator_p);
3788   DEFSUBR (Fcategory_table_value_p);
3789 #endif /* MULE */
3790
3791 }
3792
3793 void
3794 vars_of_chartab (void)
3795 {
3796 #ifdef UTF2000
3797   Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)");
3798   DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3799 Version number of XEmacs UTF-2000.
3800 */ );
3801
3802   staticpro (&Vcharacter_composition_table);
3803   Vcharacter_composition_table = make_char_id_table (Qnil);
3804
3805   staticpro (&Vcharacter_variant_table);
3806   Vcharacter_variant_table = make_char_id_table (Qnil);
3807 #endif
3808   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
3809   Vall_syntax_tables = Qnil;
3810   dump_add_weak_object_chain (&Vall_syntax_tables);
3811 }
3812
3813 void
3814 structure_type_create_chartab (void)
3815 {
3816   struct structure_type *st;
3817
3818   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3819
3820   define_structure_type_keyword (st, Qtype, chartab_type_validate);
3821   define_structure_type_keyword (st, Qdata, chartab_data_validate);
3822 }
3823
3824 void
3825 complex_vars_of_chartab (void)
3826 {
3827 #ifdef UTF2000
3828   staticpro (&Vchar_attribute_hash_table);
3829   Vchar_attribute_hash_table
3830     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3831 #endif /* UTF2000 */
3832 #ifdef MULE
3833   /* Set this now, so first buffer creation can refer to it. */
3834   /* Make it nil before calling copy-category-table
3835      so that copy-category-table will know not to try to copy from garbage */
3836   Vstandard_category_table = Qnil;
3837   Vstandard_category_table = Fcopy_category_table (Qnil);
3838   staticpro (&Vstandard_category_table);
3839
3840   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3841 List of pair (cons) of categories to determine word boundary.
3842
3843 Emacs treats a sequence of word constituent characters as a single
3844 word (i.e. finds no word boundary between them) iff they belongs to
3845 the same charset.  But, exceptions are allowed in the following cases.
3846
3847 \(1) The case that characters are in different charsets is controlled
3848 by the variable `word-combining-categories'.
3849
3850 Emacs finds no word boundary between characters of different charsets
3851 if they have categories matching some element of this list.
3852
3853 More precisely, if an element of this list is a cons of category CAT1
3854 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3855 C2 which has CAT2, there's no word boundary between C1 and C2.
3856
3857 For instance, to tell that ASCII characters and Latin-1 characters can
3858 form a single word, the element `(?l . ?l)' should be in this list
3859 because both characters have the category `l' (Latin characters).
3860
3861 \(2) The case that character are in the same charset is controlled by
3862 the variable `word-separating-categories'.
3863
3864 Emacs find a word boundary between characters of the same charset
3865 if they have categories matching some element of this list.
3866
3867 More precisely, if an element of this list is a cons of category CAT1
3868 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3869 C2 which has CAT2, there's a word boundary between C1 and C2.
3870
3871 For instance, to tell that there's a word boundary between Japanese
3872 Hiragana and Japanese Kanji (both are in the same charset), the
3873 element `(?H . ?C) should be in this list.
3874 */ );
3875
3876   Vword_combining_categories = Qnil;
3877
3878   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3879 List of pair (cons) of categories to determine word boundary.
3880 See the documentation of the variable `word-combining-categories'.
3881 */ );
3882
3883   Vword_separating_categories = Qnil;
3884 #endif /* MULE */
3885 }