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