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

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