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_compat;
1135 Lisp_Object Q_canonical;
1136 Lisp_Object Q_compat_of;
1137 Lisp_Object Q_decomposition;
1138 Lisp_Object Q_identical;
1139 Lisp_Object Q_identical_from;
1140 Lisp_Object Q_denotational;
1141 Lisp_Object Q_denotational_from;
1142 Lisp_Object Q_subsumptive;
1143 Lisp_Object Q_subsumptive_from;
1144 Lisp_Object Q_component;
1145 Lisp_Object Q_component_of;
1146 Lisp_Object Qto_ucs;
1147 Lisp_Object Q_ucs_unified;
1148 Lisp_Object Qcompat;
1149 Lisp_Object Qisolated;
1150 Lisp_Object Qinitial;
1151 Lisp_Object Qmedial;
1152 Lisp_Object Qfinal;
1153 Lisp_Object Qvertical;
1154 Lisp_Object QnoBreak;
1155 Lisp_Object Qfraction;
1156 Lisp_Object Qsuper;
1157 Lisp_Object Qsub;
1158 Lisp_Object Qcircle;
1159 Lisp_Object Qsquare;
1160 Lisp_Object Qwide;
1161 Lisp_Object Qnarrow;
1162 Lisp_Object Qsmall;
1163 Lisp_Object Qfont;
1164
1165 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1166
1167 Emchar
1168 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1169 {
1170   if (INTP (v))
1171     return XINT (v);
1172   if (CHARP (v))
1173     return XCHAR (v);
1174   else if (EQ (v, Qcompat))
1175     return -1;
1176   else if (EQ (v, Qisolated))
1177     return -2;
1178   else if (EQ (v, Qinitial))
1179     return -3;
1180   else if (EQ (v, Qmedial))
1181     return -4;
1182   else if (EQ (v, Qfinal))
1183     return -5;
1184   else if (EQ (v, Qvertical))
1185     return -6;
1186   else if (EQ (v, QnoBreak))
1187     return -7;
1188   else if (EQ (v, Qfraction))
1189     return -8;
1190   else if (EQ (v, Qsuper))
1191     return -9;
1192   else if (EQ (v, Qsub))
1193     return -10;
1194   else if (EQ (v, Qcircle))
1195     return -11;
1196   else if (EQ (v, Qsquare))
1197     return -12;
1198   else if (EQ (v, Qwide))
1199     return -13;
1200   else if (EQ (v, Qnarrow))
1201     return -14;
1202   else if (EQ (v, Qsmall))
1203     return -15;
1204   else if (EQ (v, Qfont))
1205     return -16;
1206   else
1207     signal_simple_error (err_msg, err_arg);
1208 }
1209
1210 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1211 Return character corresponding with list.
1212 */
1213        (list))
1214 {
1215   Lisp_Object base, modifier;
1216   Lisp_Object rest;
1217
1218   if (!CONSP (list))
1219     signal_simple_error ("Invalid value for composition", list);
1220   base = Fcar (list);
1221   rest = Fcdr (list);
1222   while (!NILP (rest))
1223     {
1224       if (!CHARP (base))
1225         return Qnil;
1226       if (!CONSP (rest))
1227         signal_simple_error ("Invalid value for composition", list);
1228       modifier = Fcar (rest);
1229       rest = Fcdr (rest);
1230       base = Fcdr (Fassq (modifier,
1231                           Fchar_feature (base, Qcomposition, Qnil,
1232                                          Qnil, Qnil)));
1233     }
1234   return base;
1235 }
1236
1237 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1238 Return variants of CHARACTER.
1239 */
1240        (character))
1241 {
1242   CHECK_CHAR (character);
1243   return
1244     nconc2
1245     (Fcopy_list (Fget_char_attribute (character, Q_subsumptive, Qnil)),
1246      (nconc2
1247       (Fcopy_list (Fget_char_attribute (character, Q_denotational, Qnil)),
1248        (nconc2
1249         (Fcopy_list (Fget_char_attribute (character, Q_identical, Qnil)),
1250          Fcopy_list (Fchar_feature (character, Q_ucs_unified, Qnil,
1251                                     Qnil, Qnil)))))));
1252 }
1253
1254 #endif
1255
1256 \f
1257 /* A char table maps from ranges of characters to values.
1258
1259    Implementing a general data structure that maps from arbitrary
1260    ranges of numbers to values is tricky to do efficiently.  As it
1261    happens, it should suffice (and is usually more convenient, anyway)
1262    when dealing with characters to restrict the sorts of ranges that
1263    can be assigned values, as follows:
1264
1265    1) All characters.
1266    2) All characters in a charset.
1267    3) All characters in a particular row of a charset, where a "row"
1268       means all characters with the same first byte.
1269    4) A particular character in a charset.
1270
1271    We use char tables to generalize the 256-element vectors now
1272    littering the Emacs code.
1273
1274    Possible uses (all should be converted at some point):
1275
1276    1) category tables
1277    2) syntax tables
1278    3) display tables
1279    4) case tables
1280    5) keyboard-translate-table?
1281
1282    We provide an
1283    abstract type to generalize the Emacs vectors and Mule
1284    vectors-of-vectors goo.
1285    */
1286
1287 /************************************************************************/
1288 /*                         Char Table object                            */
1289 /************************************************************************/
1290
1291 #if defined(MULE)&&!defined(UTF2000)
1292
1293 static Lisp_Object
1294 mark_char_table_entry (Lisp_Object obj)
1295 {
1296   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1297   int i;
1298
1299   for (i = 0; i < 96; i++)
1300     {
1301       mark_object (cte->level2[i]);
1302     }
1303   return Qnil;
1304 }
1305
1306 static int
1307 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1308 {
1309   Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1310   Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1311   int i;
1312
1313   for (i = 0; i < 96; i++)
1314     if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1315       return 0;
1316
1317   return 1;
1318 }
1319
1320 static unsigned long
1321 char_table_entry_hash (Lisp_Object obj, int depth)
1322 {
1323   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1324
1325   return internal_array_hash (cte->level2, 96, depth);
1326 }
1327
1328 static const struct lrecord_description char_table_entry_description[] = {
1329   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1330   { XD_END }
1331 };
1332
1333 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1334                                mark_char_table_entry, internal_object_printer,
1335                                0, char_table_entry_equal,
1336                                char_table_entry_hash,
1337                                char_table_entry_description,
1338                                Lisp_Char_Table_Entry);
1339 #endif /* MULE */
1340
1341 static Lisp_Object
1342 mark_char_table (Lisp_Object obj)
1343 {
1344   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1345 #ifdef UTF2000
1346
1347   mark_object (ct->table);
1348   mark_object (ct->name);
1349 #ifndef HAVE_LIBCHISE
1350   mark_object (ct->db);
1351 #endif
1352 #else
1353   int i;
1354
1355   for (i = 0; i < NUM_ASCII_CHARS; i++)
1356     mark_object (ct->ascii[i]);
1357 #ifdef MULE
1358   for (i = 0; i < NUM_LEADING_BYTES; i++)
1359     mark_object (ct->level1[i]);
1360 #endif
1361 #endif
1362 #ifdef UTF2000
1363   return ct->default_value;
1364 #else
1365   return ct->mirror_table;
1366 #endif
1367 }
1368
1369 /* WARNING: All functions of this nature need to be written extremely
1370    carefully to avoid crashes during GC.  Cf. prune_specifiers()
1371    and prune_weak_hash_tables(). */
1372
1373 void
1374 prune_syntax_tables (void)
1375 {
1376   Lisp_Object rest, prev = Qnil;
1377
1378   for (rest = Vall_syntax_tables;
1379        !NILP (rest);
1380        rest = XCHAR_TABLE (rest)->next_table)
1381     {
1382       if (! marked_p (rest))
1383         {
1384           /* This table is garbage.  Remove it from the list. */
1385           if (NILP (prev))
1386             Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1387           else
1388             XCHAR_TABLE (prev)->next_table =
1389               XCHAR_TABLE (rest)->next_table;
1390         }
1391     }
1392 }
1393
1394 static Lisp_Object
1395 char_table_type_to_symbol (enum char_table_type type)
1396 {
1397   switch (type)
1398   {
1399   default: ABORT();
1400   case CHAR_TABLE_TYPE_GENERIC:  return Qgeneric;
1401   case CHAR_TABLE_TYPE_SYNTAX:   return Qsyntax;
1402   case CHAR_TABLE_TYPE_DISPLAY:  return Qdisplay;
1403   case CHAR_TABLE_TYPE_CHAR:     return Qchar;
1404 #ifdef MULE
1405   case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1406 #endif
1407   }
1408 }
1409
1410 static enum char_table_type
1411 symbol_to_char_table_type (Lisp_Object symbol)
1412 {
1413   CHECK_SYMBOL (symbol);
1414
1415   if (EQ (symbol, Qgeneric))  return CHAR_TABLE_TYPE_GENERIC;
1416   if (EQ (symbol, Qsyntax))   return CHAR_TABLE_TYPE_SYNTAX;
1417   if (EQ (symbol, Qdisplay))  return CHAR_TABLE_TYPE_DISPLAY;
1418   if (EQ (symbol, Qchar))     return CHAR_TABLE_TYPE_CHAR;
1419 #ifdef MULE
1420   if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1421 #endif
1422
1423   signal_simple_error ("Unrecognized char table type", symbol);
1424   return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1425 }
1426
1427 #ifndef UTF2000
1428 static void
1429 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1430                      Lisp_Object printcharfun)
1431 {
1432   if (first != last)
1433     {
1434       write_c_string (" (", printcharfun);
1435       print_internal (make_char (first), printcharfun, 0);
1436       write_c_string (" ", printcharfun);
1437       print_internal (make_char (last), printcharfun, 0);
1438       write_c_string (") ", printcharfun);
1439     }
1440   else
1441     {
1442       write_c_string (" ", printcharfun);
1443       print_internal (make_char (first), printcharfun, 0);
1444       write_c_string (" ", printcharfun);
1445     }
1446   print_internal (val, printcharfun, 1);
1447 }
1448 #endif
1449
1450 #if defined(MULE)&&!defined(UTF2000)
1451
1452 static void
1453 print_chartab_charset_row (Lisp_Object charset,
1454                            int row,
1455                            Lisp_Char_Table_Entry *cte,
1456                            Lisp_Object printcharfun)
1457 {
1458   int i;
1459   Lisp_Object cat = Qunbound;
1460   int first = -1;
1461
1462   for (i = 32; i < 128; i++)
1463     {
1464       Lisp_Object pam = cte->level2[i - 32];
1465
1466       if (first == -1)
1467         {
1468           first = i;
1469           cat = pam;
1470           continue;
1471         }
1472
1473       if (!EQ (cat, pam))
1474         {
1475           if (row == -1)
1476             print_chartab_range (MAKE_CHAR (charset, first, 0),
1477                                  MAKE_CHAR (charset, i - 1, 0),
1478                                  cat, printcharfun);
1479           else
1480             print_chartab_range (MAKE_CHAR (charset, row, first),
1481                                  MAKE_CHAR (charset, row, i - 1),
1482                                  cat, printcharfun);
1483           first = -1;
1484           i--;
1485         }
1486     }
1487
1488   if (first != -1)
1489     {
1490       if (row == -1)
1491         print_chartab_range (MAKE_CHAR (charset, first, 0),
1492                              MAKE_CHAR (charset, i - 1, 0),
1493                              cat, printcharfun);
1494       else
1495         print_chartab_range (MAKE_CHAR (charset, row, first),
1496                              MAKE_CHAR (charset, row, i - 1),
1497                              cat, printcharfun);
1498     }
1499 }
1500
1501 static void
1502 print_chartab_two_byte_charset (Lisp_Object charset,
1503                                 Lisp_Char_Table_Entry *cte,
1504                                 Lisp_Object printcharfun)
1505 {
1506   int i;
1507
1508   for (i = 32; i < 128; i++)
1509     {
1510       Lisp_Object jen = cte->level2[i - 32];
1511
1512       if (!CHAR_TABLE_ENTRYP (jen))
1513         {
1514           char buf[100];
1515
1516           write_c_string (" [", printcharfun);
1517           print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1518           sprintf (buf, " %d] ", i);
1519           write_c_string (buf, printcharfun);
1520           print_internal (jen, printcharfun, 0);
1521         }
1522       else
1523         print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1524                                    printcharfun);
1525     }
1526 }
1527
1528 #endif /* MULE */
1529
1530 static void
1531 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1532 {
1533   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1534 #ifdef UTF2000
1535   int i;
1536   struct gcpro gcpro1, gcpro2;
1537   GCPRO2 (obj, printcharfun);
1538
1539   write_c_string ("#s(char-table ", printcharfun);
1540   write_c_string (" ", printcharfun);
1541   write_c_string (string_data
1542                   (symbol_name
1543                    (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1544                   printcharfun);
1545   write_c_string ("\n ", printcharfun);
1546   print_internal (ct->default_value, printcharfun, escapeflag);
1547   for (i = 0; i < 256; i++)
1548     {
1549       Lisp_Object elt = get_byte_table (ct->table, i);
1550       if (i != 0) write_c_string ("\n  ", printcharfun);
1551       if (EQ (elt, Qunbound))
1552         write_c_string ("void", printcharfun);
1553       else
1554         print_internal (elt, printcharfun, escapeflag);
1555     }
1556   UNGCPRO;
1557 #else /* non UTF2000 */
1558   char buf[200];
1559
1560   sprintf (buf, "#s(char-table type %s data (",
1561            string_data (symbol_name (XSYMBOL
1562                                      (char_table_type_to_symbol (ct->type)))));
1563   write_c_string (buf, printcharfun);
1564
1565   /* Now write out the ASCII/Control-1 stuff. */
1566   {
1567     int i;
1568     int first = -1;
1569     Lisp_Object val = Qunbound;
1570
1571     for (i = 0; i < NUM_ASCII_CHARS; i++)
1572       {
1573         if (first == -1)
1574           {
1575             first = i;
1576             val = ct->ascii[i];
1577             continue;
1578           }
1579
1580         if (!EQ (ct->ascii[i], val))
1581           {
1582             print_chartab_range (first, i - 1, val, printcharfun);
1583             first = -1;
1584             i--;
1585           }
1586       }
1587
1588     if (first != -1)
1589       print_chartab_range (first, i - 1, val, printcharfun);
1590   }
1591
1592 #ifdef MULE
1593   {
1594     Charset_ID i;
1595
1596     for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1597          i++)
1598       {
1599         Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1600         Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1601
1602         if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1603             || i == LEADING_BYTE_CONTROL_1)
1604           continue;
1605         if (!CHAR_TABLE_ENTRYP (ann))
1606           {
1607             write_c_string (" ", printcharfun);
1608             print_internal (XCHARSET_NAME (charset),
1609                             printcharfun, 0);
1610             write_c_string (" ", printcharfun);
1611             print_internal (ann, printcharfun, 0);
1612           }
1613         else
1614           {
1615             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1616             if (XCHARSET_DIMENSION (charset) == 1)
1617               print_chartab_charset_row (charset, -1, cte, printcharfun);
1618             else
1619               print_chartab_two_byte_charset (charset, cte, printcharfun);
1620           }
1621       }
1622   }
1623 #endif /* MULE */
1624 #endif /* non UTF2000 */
1625
1626   write_c_string ("))", printcharfun);
1627 }
1628
1629 static int
1630 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1631 {
1632   Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1633   Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1634   int i;
1635
1636   if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1637     return 0;
1638
1639 #ifdef UTF2000
1640   for (i = 0; i < 256; i++)
1641     {
1642       if (!internal_equal (get_byte_table (ct1->table, i),
1643                            get_byte_table (ct2->table, i), 0))
1644         return 0;
1645     }
1646 #else
1647   for (i = 0; i < NUM_ASCII_CHARS; i++)
1648     if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1649       return 0;
1650
1651 #ifdef MULE
1652   for (i = 0; i < NUM_LEADING_BYTES; i++)
1653     if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1654       return 0;
1655 #endif /* MULE */
1656 #endif /* non UTF2000 */
1657
1658   return 1;
1659 }
1660
1661 static unsigned long
1662 char_table_hash (Lisp_Object obj, int depth)
1663 {
1664   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1665 #ifdef UTF2000
1666     return byte_table_hash (ct->table, depth + 1);
1667 #else
1668   unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1669                                                depth);
1670 #ifdef MULE
1671   hashval = HASH2 (hashval,
1672                    internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1673 #endif /* MULE */
1674   return hashval;
1675 #endif
1676 }
1677
1678 static const struct lrecord_description char_table_description[] = {
1679 #ifdef UTF2000
1680   { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1681   { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1682   { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1683 #ifndef HAVE_LIBCHISE
1684   { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1685 #endif
1686 #else
1687   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1688 #ifdef MULE
1689   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1690 #endif
1691 #endif
1692 #ifndef UTF2000
1693   { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1694 #endif
1695   { XD_LO_LINK,     offsetof (Lisp_Char_Table, next_table) },
1696   { XD_END }
1697 };
1698
1699 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1700                                mark_char_table, print_char_table, 0,
1701                                char_table_equal, char_table_hash,
1702                                char_table_description,
1703                                Lisp_Char_Table);
1704
1705 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1706 Return non-nil if OBJECT is a char table.
1707
1708 A char table is a table that maps characters (or ranges of characters)
1709 to values.  Char tables are specialized for characters, only allowing
1710 particular sorts of ranges to be assigned values.  Although this
1711 loses in generality, it makes for extremely fast (constant-time)
1712 lookups, and thus is feasible for applications that do an extremely
1713 large number of lookups (e.g. scanning a buffer for a character in
1714 a particular syntax, where a lookup in the syntax table must occur
1715 once per character).
1716
1717 When Mule support exists, the types of ranges that can be assigned
1718 values are
1719
1720 -- all characters
1721 -- an entire charset
1722 -- a single row in a two-octet charset
1723 -- a single character
1724
1725 When Mule support is not present, the types of ranges that can be
1726 assigned values are
1727
1728 -- all characters
1729 -- a single character
1730
1731 To create a char table, use `make-char-table'.
1732 To modify a char table, use `put-char-table' or `remove-char-table'.
1733 To retrieve the value for a particular character, use `get-char-table'.
1734 See also `map-char-table', `clear-char-table', `copy-char-table',
1735 `valid-char-table-type-p', `char-table-type-list',
1736 `valid-char-table-value-p', and `check-char-table-value'.
1737 */
1738        (object))
1739 {
1740   return CHAR_TABLEP (object) ? Qt : Qnil;
1741 }
1742
1743 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1744 Return a list of the recognized char table types.
1745 See `valid-char-table-type-p'.
1746 */
1747        ())
1748 {
1749 #ifdef MULE
1750   return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1751 #else
1752   return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1753 #endif
1754 }
1755
1756 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1757 Return t if TYPE if a recognized char table type.
1758
1759 Each char table type is used for a different purpose and allows different
1760 sorts of values.  The different char table types are
1761
1762 `category'
1763         Used for category tables, which specify the regexp categories
1764         that a character is in.  The valid values are nil or a
1765         bit vector of 95 elements.  Higher-level Lisp functions are
1766         provided for working with category tables.  Currently categories
1767         and category tables only exist when Mule support is present.
1768 `char'
1769         A generalized char table, for mapping from one character to
1770         another.  Used for case tables, syntax matching tables,
1771         `keyboard-translate-table', etc.  The valid values are characters.
1772 `generic'
1773         An even more generalized char table, for mapping from a
1774         character to anything.
1775 `display'
1776         Used for display tables, which specify how a particular character
1777         is to appear when displayed.  #### Not yet implemented.
1778 `syntax'
1779         Used for syntax tables, which specify the syntax of a particular
1780         character.  Higher-level Lisp functions are provided for
1781         working with syntax tables.  The valid values are integers.
1782
1783 */
1784        (type))
1785 {
1786   return (EQ (type, Qchar)     ||
1787 #ifdef MULE
1788           EQ (type, Qcategory) ||
1789 #endif
1790           EQ (type, Qdisplay)  ||
1791           EQ (type, Qgeneric)  ||
1792           EQ (type, Qsyntax)) ? Qt : Qnil;
1793 }
1794
1795 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1796 Return the type of CHAR-TABLE.
1797 See `valid-char-table-type-p'.
1798 */
1799        (char_table))
1800 {
1801   CHECK_CHAR_TABLE (char_table);
1802   return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1803 }
1804
1805 void
1806 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1807 {
1808 #ifdef UTF2000
1809   ct->table = Qunbound;
1810   ct->default_value = value;
1811   ct->unloaded = 0;
1812 #else
1813   int i;
1814
1815   for (i = 0; i < NUM_ASCII_CHARS; i++)
1816     ct->ascii[i] = value;
1817 #ifdef MULE
1818   for (i = 0; i < NUM_LEADING_BYTES; i++)
1819     ct->level1[i] = value;
1820 #endif /* MULE */
1821 #endif
1822
1823 #ifndef UTF2000
1824   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1825     update_syntax_table (ct);
1826 #endif
1827 }
1828
1829 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1830 Reset CHAR-TABLE to its default state.
1831 */
1832        (char_table))
1833 {
1834   Lisp_Char_Table *ct;
1835
1836   CHECK_CHAR_TABLE (char_table);
1837   ct = XCHAR_TABLE (char_table);
1838
1839   switch (ct->type)
1840     {
1841     case CHAR_TABLE_TYPE_CHAR:
1842       fill_char_table (ct, make_char (0));
1843       break;
1844     case CHAR_TABLE_TYPE_DISPLAY:
1845     case CHAR_TABLE_TYPE_GENERIC:
1846 #ifdef MULE
1847     case CHAR_TABLE_TYPE_CATEGORY:
1848 #endif /* MULE */
1849       fill_char_table (ct, Qnil);
1850       break;
1851
1852     case CHAR_TABLE_TYPE_SYNTAX:
1853       fill_char_table (ct, make_int (Sinherit));
1854       break;
1855
1856     default:
1857       ABORT ();
1858     }
1859
1860   return Qnil;
1861 }
1862
1863 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1864 Return a new, empty char table of type TYPE.
1865 Currently recognized types are 'char, 'category, 'display, 'generic,
1866 and 'syntax.  See `valid-char-table-type-p'.
1867 */
1868        (type))
1869 {
1870   Lisp_Char_Table *ct;
1871   Lisp_Object obj;
1872   enum char_table_type ty = symbol_to_char_table_type (type);
1873
1874   ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1875   ct->type = ty;
1876 #ifndef UTF2000
1877   if (ty == CHAR_TABLE_TYPE_SYNTAX)
1878     {
1879       ct->mirror_table = Fmake_char_table (Qgeneric);
1880       fill_char_table (XCHAR_TABLE (ct->mirror_table),
1881                        make_int (Spunct));
1882     }
1883   else
1884     ct->mirror_table = Qnil;
1885 #else
1886   ct->name = Qnil;
1887 #ifndef HAVE_LIBCHISE
1888   ct->db = Qnil;
1889 #endif
1890 #endif
1891   ct->next_table = Qnil;
1892   XSETCHAR_TABLE (obj, ct);
1893   if (ty == CHAR_TABLE_TYPE_SYNTAX)
1894     {
1895       ct->next_table = Vall_syntax_tables;
1896       Vall_syntax_tables = obj;
1897     }
1898   Freset_char_table (obj);
1899   return obj;
1900 }
1901
1902 #if defined(MULE)&&!defined(UTF2000)
1903
1904 static Lisp_Object
1905 make_char_table_entry (Lisp_Object initval)
1906 {
1907   Lisp_Object obj;
1908   int i;
1909   Lisp_Char_Table_Entry *cte =
1910     alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1911
1912   for (i = 0; i < 96; i++)
1913     cte->level2[i] = initval;
1914
1915   XSETCHAR_TABLE_ENTRY (obj, cte);
1916   return obj;
1917 }
1918
1919 static Lisp_Object
1920 copy_char_table_entry (Lisp_Object entry)
1921 {
1922   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1923   Lisp_Object obj;
1924   int i;
1925   Lisp_Char_Table_Entry *ctenew =
1926     alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1927
1928   for (i = 0; i < 96; i++)
1929     {
1930       Lisp_Object new = cte->level2[i];
1931       if (CHAR_TABLE_ENTRYP (new))
1932         ctenew->level2[i] = copy_char_table_entry (new);
1933       else
1934         ctenew->level2[i] = new;
1935     }
1936
1937   XSETCHAR_TABLE_ENTRY (obj, ctenew);
1938   return obj;
1939 }
1940
1941 #endif /* MULE */
1942
1943 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1944 Return a new char table which is a copy of CHAR-TABLE.
1945 It will contain the same values for the same characters and ranges
1946 as CHAR-TABLE.  The values will not themselves be copied.
1947 */
1948        (char_table))
1949 {
1950   Lisp_Char_Table *ct, *ctnew;
1951   Lisp_Object obj;
1952 #ifndef UTF2000
1953   int i;
1954 #endif
1955
1956   CHECK_CHAR_TABLE (char_table);
1957   ct = XCHAR_TABLE (char_table);
1958   ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1959   ctnew->type = ct->type;
1960 #ifdef UTF2000
1961   ctnew->default_value = ct->default_value;
1962   /* [tomo:2002-01-21] Perhaps this code seems wrong */
1963   ctnew->name = ct->name;
1964 #ifndef HAVE_LIBCHISE
1965   ctnew->db = ct->db;
1966 #endif
1967
1968   if (UINT8_BYTE_TABLE_P (ct->table))
1969     {
1970       ctnew->table = copy_uint8_byte_table (ct->table);
1971     }
1972   else if (UINT16_BYTE_TABLE_P (ct->table))
1973     {
1974       ctnew->table = copy_uint16_byte_table (ct->table);
1975     }
1976   else if (BYTE_TABLE_P (ct->table))
1977     {
1978       ctnew->table = copy_byte_table (ct->table);
1979     }
1980   else if (!UNBOUNDP (ct->table))
1981     ctnew->table = ct->table;
1982 #else /* non UTF2000 */
1983
1984   for (i = 0; i < NUM_ASCII_CHARS; i++)
1985     {
1986       Lisp_Object new = ct->ascii[i];
1987 #ifdef MULE
1988       assert (! (CHAR_TABLE_ENTRYP (new)));
1989 #endif /* MULE */
1990       ctnew->ascii[i] = new;
1991     }
1992
1993 #ifdef MULE
1994
1995   for (i = 0; i < NUM_LEADING_BYTES; i++)
1996     {
1997       Lisp_Object new = ct->level1[i];
1998       if (CHAR_TABLE_ENTRYP (new))
1999         ctnew->level1[i] = copy_char_table_entry (new);
2000       else
2001         ctnew->level1[i] = new;
2002     }
2003
2004 #endif /* MULE */
2005 #endif /* non UTF2000 */
2006
2007 #ifndef UTF2000
2008   if (CHAR_TABLEP (ct->mirror_table))
2009     ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
2010   else
2011     ctnew->mirror_table = ct->mirror_table;
2012 #endif
2013   ctnew->next_table = Qnil;
2014   XSETCHAR_TABLE (obj, ctnew);
2015   if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
2016     {
2017       ctnew->next_table = Vall_syntax_tables;
2018       Vall_syntax_tables = obj;
2019     }
2020   return obj;
2021 }
2022
2023 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
2024 INLINE_HEADER int
2025 XCHARSET_CELL_RANGE (Lisp_Object ccs)
2026 {
2027   switch (XCHARSET_CHARS (ccs))
2028     {
2029     case 94:
2030       return (33 << 8) | 126;
2031     case 96:
2032       return (32 << 8) | 127;
2033 #ifdef UTF2000
2034     case 128:
2035       return (0 << 8) | 127;
2036     case 256:
2037       return (0 << 8) | 255;
2038 #endif
2039     default:
2040       ABORT ();
2041       return 0;
2042     }
2043 }
2044
2045 #ifndef UTF2000
2046 static
2047 #endif
2048 void
2049 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
2050 {
2051   if (EQ (range, Qt))
2052     outrange->type = CHARTAB_RANGE_ALL;
2053 #ifdef UTF2000
2054   else if (EQ (range, Qnil))
2055     outrange->type = CHARTAB_RANGE_DEFAULT;
2056 #endif
2057   else if (CHAR_OR_CHAR_INTP (range))
2058     {
2059       outrange->type = CHARTAB_RANGE_CHAR;
2060       outrange->ch = XCHAR_OR_CHAR_INT (range);
2061     }
2062 #ifndef MULE
2063   else
2064     signal_simple_error ("Range must be t or a character", range);
2065 #else /* MULE */
2066   else if (VECTORP (range))
2067     {
2068       Lisp_Vector *vec = XVECTOR (range);
2069       Lisp_Object *elts = vector_data (vec);
2070       int cell_min, cell_max;
2071
2072       outrange->type = CHARTAB_RANGE_ROW;
2073       outrange->charset = Fget_charset (elts[0]);
2074       CHECK_INT (elts[1]);
2075       outrange->row = XINT (elts[1]);
2076       if (XCHARSET_DIMENSION (outrange->charset) < 2)
2077         signal_simple_error ("Charset in row vector must be multi-byte",
2078                              outrange->charset);
2079       else
2080         {
2081           int ret = XCHARSET_CELL_RANGE (outrange->charset);
2082
2083           cell_min = ret >> 8;
2084           cell_max = ret & 0xFF;
2085         }
2086       if (XCHARSET_DIMENSION (outrange->charset) == 2)
2087         check_int_range (outrange->row, cell_min, cell_max);
2088 #ifdef UTF2000
2089       else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2090         {
2091           check_int_range (outrange->row >> 8  , cell_min, cell_max);
2092           check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2093         }
2094       else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2095         {
2096           check_int_range ( outrange->row >> 16       , cell_min, cell_max);
2097           check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2098           check_int_range ( outrange->row       & 0xFF, cell_min, cell_max);
2099         }
2100 #endif
2101       else
2102         ABORT ();
2103     }
2104   else
2105     {
2106       if (!CHARSETP (range) && !SYMBOLP (range))
2107         signal_simple_error
2108           ("Char table range must be t, charset, char, or vector", range);
2109       outrange->type = CHARTAB_RANGE_CHARSET;
2110       outrange->charset = Fget_charset (range);
2111     }
2112 #endif /* MULE */
2113 }
2114
2115 #if defined(MULE)&&!defined(UTF2000)
2116
2117 /* called from CHAR_TABLE_VALUE(). */
2118 Lisp_Object
2119 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2120                                Emchar c)
2121 {
2122   Lisp_Object val;
2123 #ifdef UTF2000
2124   Lisp_Object charset;
2125 #else
2126   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2127 #endif
2128   int byte1, byte2;
2129
2130 #ifdef UTF2000
2131   BREAKUP_CHAR (c, charset, byte1, byte2);
2132 #else
2133   BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2134 #endif
2135   val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2136   if (CHAR_TABLE_ENTRYP (val))
2137     {
2138       Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2139       val = cte->level2[byte1 - 32];
2140       if (CHAR_TABLE_ENTRYP (val))
2141         {
2142           cte = XCHAR_TABLE_ENTRY (val);
2143           assert (byte2 >= 32);
2144           val = cte->level2[byte2 - 32];
2145           assert (!CHAR_TABLE_ENTRYP (val));
2146         }
2147     }
2148
2149   return val;
2150 }
2151
2152 #endif /* MULE */
2153
2154 Lisp_Object
2155 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2156 {
2157 #ifdef UTF2000
2158   {
2159     Lisp_Object ret = get_char_id_table (ct, ch);
2160
2161 #ifdef HAVE_CHISE
2162     if (NILP (ret))
2163       {
2164         if (EQ (CHAR_TABLE_NAME (ct), Qdowncase))
2165           ret = Fchar_feature (make_char (ch), Q_lowercase, Qnil,
2166                                Qnil, Qnil);
2167         else if (EQ (CHAR_TABLE_NAME (ct), Qflippedcase))
2168           ret = Fchar_feature (make_char (ch), Q_uppercase, Qnil,
2169                                Qnil, Qnil);
2170         if (CONSP (ret))
2171           {
2172             ret = XCAR (ret);
2173             if (CONSP (ret))
2174               ret = Ffind_char (ret);
2175           }
2176       }
2177 #endif
2178     return ret;
2179   }
2180 #elif defined(MULE)
2181   {
2182     Lisp_Object charset;
2183     int byte1, byte2;
2184     Lisp_Object val;
2185
2186     BREAKUP_CHAR (ch, charset, byte1, byte2);
2187
2188     if (EQ (charset, Vcharset_ascii))
2189       val = ct->ascii[byte1];
2190     else if (EQ (charset, Vcharset_control_1))
2191       val = ct->ascii[byte1 + 128];
2192     else
2193       {
2194         int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2195         val = ct->level1[lb];
2196         if (CHAR_TABLE_ENTRYP (val))
2197           {
2198             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2199             val = cte->level2[byte1 - 32];
2200             if (CHAR_TABLE_ENTRYP (val))
2201               {
2202                 cte = XCHAR_TABLE_ENTRY (val);
2203                 assert (byte2 >= 32);
2204                 val = cte->level2[byte2 - 32];
2205                 assert (!CHAR_TABLE_ENTRYP (val));
2206               }
2207           }
2208       }
2209
2210     return val;
2211   }
2212 #else /* not MULE */
2213   return ct->ascii[(unsigned char)ch];
2214 #endif /* not MULE */
2215 }
2216
2217
2218 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2219 Find value for CHARACTER in CHAR-TABLE.
2220 */
2221        (character, char_table))
2222 {
2223   CHECK_CHAR_TABLE (char_table);
2224   CHECK_CHAR_COERCE_INT (character);
2225
2226   return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2227 }
2228
2229 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2230 Find value for a range in CHAR-TABLE.
2231 If there is more than one value, return MULTI (defaults to nil).
2232 */
2233        (range, char_table, multi))
2234 {
2235   Lisp_Char_Table *ct;
2236   struct chartab_range rainj;
2237
2238   if (CHAR_OR_CHAR_INTP (range))
2239     return Fget_char_table (range, char_table);
2240   CHECK_CHAR_TABLE (char_table);
2241   ct = XCHAR_TABLE (char_table);
2242
2243   decode_char_table_range (range, &rainj);
2244   switch (rainj.type)
2245     {
2246     case CHARTAB_RANGE_ALL:
2247       {
2248 #ifdef UTF2000
2249         if (UINT8_BYTE_TABLE_P (ct->table))
2250           return multi;
2251         else if (UINT16_BYTE_TABLE_P (ct->table))
2252           return multi;
2253         else if (BYTE_TABLE_P (ct->table))
2254           return multi;
2255         else
2256           return ct->table;
2257 #else /* non UTF2000 */
2258         int i;
2259         Lisp_Object first = ct->ascii[0];
2260
2261         for (i = 1; i < NUM_ASCII_CHARS; i++)
2262           if (!EQ (first, ct->ascii[i]))
2263             return multi;
2264
2265 #ifdef MULE
2266         for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2267              i++)
2268           {
2269             if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2270                 || i == LEADING_BYTE_ASCII
2271                 || i == LEADING_BYTE_CONTROL_1)
2272               continue;
2273             if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2274               return multi;
2275           }
2276 #endif /* MULE */
2277
2278         return first;
2279 #endif /* non UTF2000 */
2280       }
2281
2282 #ifdef MULE
2283     case CHARTAB_RANGE_CHARSET:
2284 #ifdef UTF2000
2285       return multi;
2286 #else
2287       if (EQ (rainj.charset, Vcharset_ascii))
2288         {
2289           int i;
2290           Lisp_Object first = ct->ascii[0];
2291
2292           for (i = 1; i < 128; i++)
2293             if (!EQ (first, ct->ascii[i]))
2294               return multi;
2295           return first;
2296         }
2297
2298       if (EQ (rainj.charset, Vcharset_control_1))
2299         {
2300           int i;
2301           Lisp_Object first = ct->ascii[128];
2302
2303           for (i = 129; i < 160; i++)
2304             if (!EQ (first, ct->ascii[i]))
2305               return multi;
2306           return first;
2307         }
2308
2309       {
2310         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2311                                      MIN_LEADING_BYTE];
2312         if (CHAR_TABLE_ENTRYP (val))
2313           return multi;
2314         return val;
2315       }
2316 #endif
2317
2318     case CHARTAB_RANGE_ROW:
2319 #ifdef UTF2000
2320       return multi;
2321 #else
2322       {
2323         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2324                                      MIN_LEADING_BYTE];
2325         if (!CHAR_TABLE_ENTRYP (val))
2326           return val;
2327         val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2328         if (CHAR_TABLE_ENTRYP (val))
2329           return multi;
2330         return val;
2331       }
2332 #endif /* not UTF2000 */
2333 #endif /* not MULE */
2334
2335 #ifdef UTF2000
2336     case CHARTAB_RANGE_DEFAULT:
2337       return ct->default_value;
2338 #endif /* not UTF2000 */
2339
2340     default:
2341       ABORT ();
2342     }
2343
2344   return Qnil; /* not reached */
2345 }
2346
2347 static int
2348 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2349                               Error_behavior errb)
2350 {
2351   switch (type)
2352     {
2353     case CHAR_TABLE_TYPE_SYNTAX:
2354       if (!ERRB_EQ (errb, ERROR_ME))
2355         return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2356                                 && CHAR_OR_CHAR_INTP (XCDR (value)));
2357       if (CONSP (value))
2358         {
2359           Lisp_Object cdr = XCDR (value);
2360           CHECK_INT (XCAR (value));
2361           CHECK_CHAR_COERCE_INT (cdr);
2362          }
2363       else
2364         CHECK_INT (value);
2365       break;
2366
2367 #ifdef MULE
2368     case CHAR_TABLE_TYPE_CATEGORY:
2369       if (!ERRB_EQ (errb, ERROR_ME))
2370         return CATEGORY_TABLE_VALUEP (value);
2371       CHECK_CATEGORY_TABLE_VALUE (value);
2372       break;
2373 #endif /* MULE */
2374
2375     case CHAR_TABLE_TYPE_GENERIC:
2376       return 1;
2377
2378     case CHAR_TABLE_TYPE_DISPLAY:
2379       /* #### fix this */
2380       maybe_signal_simple_error ("Display char tables not yet implemented",
2381                                  value, Qchar_table, errb);
2382       return 0;
2383
2384     case CHAR_TABLE_TYPE_CHAR:
2385       if (!ERRB_EQ (errb, ERROR_ME))
2386         return CHAR_OR_CHAR_INTP (value);
2387       CHECK_CHAR_COERCE_INT (value);
2388       break;
2389
2390     default:
2391       ABORT ();
2392     }
2393
2394   return 0; /* not reached */
2395 }
2396
2397 static Lisp_Object
2398 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2399 {
2400   switch (type)
2401     {
2402     case CHAR_TABLE_TYPE_SYNTAX:
2403       if (CONSP (value))
2404         {
2405           Lisp_Object car = XCAR (value);
2406           Lisp_Object cdr = XCDR (value);
2407           CHECK_CHAR_COERCE_INT (cdr);
2408           return Fcons (car, cdr);
2409         }
2410       break;
2411     case CHAR_TABLE_TYPE_CHAR:
2412       CHECK_CHAR_COERCE_INT (value);
2413       break;
2414     default:
2415       break;
2416     }
2417   return value;
2418 }
2419
2420 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2421 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2422 */
2423        (value, char_table_type))
2424 {
2425   enum char_table_type type = symbol_to_char_table_type (char_table_type);
2426
2427   return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2428 }
2429
2430 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2431 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2432 */
2433        (value, char_table_type))
2434 {
2435   enum char_table_type type = symbol_to_char_table_type (char_table_type);
2436
2437   check_valid_char_table_value (value, type, ERROR_ME);
2438   return Qnil;
2439 }
2440
2441 #ifdef UTF2000
2442 Lisp_Char_Table* char_attribute_table_to_put;
2443 Lisp_Object Qput_char_table_map_function;
2444 Lisp_Object value_to_put;
2445
2446 DEFUN ("put-char-table-map-function",
2447        Fput_char_table_map_function, 2, 2, 0, /*
2448 For internal use.  Don't use it.
2449 */
2450        (c, value))
2451 {
2452   put_char_id_table_0 (char_attribute_table_to_put,
2453                        XCHAR (c), value_to_put);
2454   return Qnil;
2455 }
2456 #endif
2457
2458 /* Assign VAL to all characters in RANGE in char table CT. */
2459
2460 void
2461 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2462                 Lisp_Object val)
2463 {
2464   switch (range->type)
2465     {
2466     case CHARTAB_RANGE_ALL:
2467       fill_char_table (ct, val);
2468       return; /* avoid the duplicate call to update_syntax_table() below,
2469                  since fill_char_table() also did that. */
2470
2471 #ifdef UTF2000
2472     case CHARTAB_RANGE_DEFAULT:
2473       ct->default_value = val;
2474       return;
2475 #endif
2476
2477 #ifdef MULE
2478     case CHARTAB_RANGE_CHARSET:
2479 #ifdef UTF2000
2480       {
2481         Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2482
2483         if ( CHAR_TABLEP (encoding_table) )
2484           {
2485             Lisp_Object mother = XCHARSET_MOTHER (range->charset);
2486
2487             char_attribute_table_to_put = ct;
2488             value_to_put = val;
2489             Fmap_char_attribute (Qput_char_table_map_function,
2490                                  XCHAR_TABLE_NAME (encoding_table),
2491                                  Qnil);
2492             if ( CHARSETP (mother) )
2493               {
2494                 struct chartab_range r;
2495
2496                 r.type = CHARTAB_RANGE_CHARSET;
2497                 r.charset = mother;
2498                 put_char_table (ct, &r, val);
2499               }
2500           }
2501 #if 0
2502         else
2503           {
2504             Emchar c;
2505
2506             for (c = 0; c < 1 << 24; c++)
2507               {
2508                 if ( charset_code_point (range->charset, c) >= 0 )
2509                   put_char_id_table_0 (ct, c, val);
2510               }
2511           }
2512 #endif
2513       }
2514 #else
2515       if (EQ (range->charset, Vcharset_ascii))
2516         {
2517           int i;
2518           for (i = 0; i < 128; i++)
2519             ct->ascii[i] = val;
2520         }
2521       else if (EQ (range->charset, Vcharset_control_1))
2522         {
2523           int i;
2524           for (i = 128; i < 160; i++)
2525             ct->ascii[i] = val;
2526         }
2527       else
2528         {
2529           int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2530           ct->level1[lb] = val;
2531         }
2532 #endif
2533       break;
2534
2535     case CHARTAB_RANGE_ROW:
2536 #ifdef UTF2000
2537       {
2538         int cell_min, cell_max, i;
2539
2540         i = XCHARSET_CELL_RANGE (range->charset);
2541         cell_min = i >> 8;
2542         cell_max = i & 0xFF;
2543         for (i = cell_min; i <= cell_max; i++)
2544           {
2545             Emchar ch
2546               = DECODE_CHAR (range->charset, (range->row << 8) | i, 0);
2547
2548             if ( charset_code_point (range->charset, ch, 0) >= 0 )
2549               put_char_id_table_0 (ct, ch, val);
2550           }
2551       }
2552 #else
2553       {
2554         Lisp_Char_Table_Entry *cte;
2555         int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2556         /* make sure that there is a separate entry for the row. */
2557         if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2558           ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2559         cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2560         cte->level2[range->row - 32] = val;
2561       }
2562 #endif /* not UTF2000 */
2563       break;
2564 #endif /* MULE */
2565
2566     case CHARTAB_RANGE_CHAR:
2567 #ifdef UTF2000
2568       put_char_id_table_0 (ct, range->ch, val);
2569       break;
2570 #elif defined(MULE)
2571       {
2572         Lisp_Object charset;
2573         int byte1, byte2;
2574
2575         BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2576         if (EQ (charset, Vcharset_ascii))
2577           ct->ascii[byte1] = val;
2578         else if (EQ (charset, Vcharset_control_1))
2579           ct->ascii[byte1 + 128] = val;
2580         else
2581           {
2582             Lisp_Char_Table_Entry *cte;
2583             int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2584             /* make sure that there is a separate entry for the row. */
2585             if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2586               ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2587             cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2588             /* now CTE is a char table entry for the charset;
2589                each entry is for a single row (or character of
2590                a one-octet charset). */
2591             if (XCHARSET_DIMENSION (charset) == 1)
2592               cte->level2[byte1 - 32] = val;
2593             else
2594               {
2595                 /* assigning to one character in a two-octet charset. */
2596                 /* make sure that the charset row contains a separate
2597                    entry for each character. */
2598                 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2599                   cte->level2[byte1 - 32] =
2600                     make_char_table_entry (cte->level2[byte1 - 32]);
2601                 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2602                 cte->level2[byte2 - 32] = val;
2603               }
2604           }
2605       }
2606 #else /* not MULE */
2607       ct->ascii[(unsigned char) (range->ch)] = val;
2608       break;
2609 #endif /* not MULE */
2610     }
2611
2612 #ifndef UTF2000
2613   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2614     update_syntax_table (ct);
2615 #endif
2616 }
2617
2618 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2619 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2620
2621 RANGE specifies one or more characters to be affected and should be
2622 one of the following:
2623
2624 -- t (all characters are affected)
2625 -- A charset (only allowed when Mule support is present)
2626 -- A vector of two elements: a two-octet charset and a row number
2627    (only allowed when Mule support is present)
2628 -- A single character
2629
2630 VALUE must be a value appropriate for the type of CHAR-TABLE.
2631 See `valid-char-table-type-p'.
2632 */
2633        (range, value, char_table))
2634 {
2635   Lisp_Char_Table *ct;
2636   struct chartab_range rainj;
2637
2638   CHECK_CHAR_TABLE (char_table);
2639   ct = XCHAR_TABLE (char_table);
2640   check_valid_char_table_value (value, ct->type, ERROR_ME);
2641   decode_char_table_range (range, &rainj);
2642   value = canonicalize_char_table_value (value, ct->type);
2643   put_char_table (ct, &rainj, value);
2644   return Qnil;
2645 }
2646
2647 #ifndef UTF2000
2648 /* Map FN over the ASCII chars in CT. */
2649
2650 static int
2651 map_over_charset_ascii (Lisp_Char_Table *ct,
2652                         int (*fn) (struct chartab_range *range,
2653                                    Lisp_Object val, void *arg),
2654                         void *arg)
2655 {
2656   struct chartab_range rainj;
2657   int i, retval;
2658   int start = 0;
2659 #ifdef MULE
2660   int stop = 128;
2661 #else
2662   int stop = 256;
2663 #endif
2664
2665   rainj.type = CHARTAB_RANGE_CHAR;
2666
2667   for (i = start, retval = 0; i < stop && retval == 0; i++)
2668     {
2669       rainj.ch = (Emchar) i;
2670       retval = (fn) (&rainj, ct->ascii[i], arg);
2671     }
2672
2673   return retval;
2674 }
2675
2676 #ifdef MULE
2677
2678 /* Map FN over the Control-1 chars in CT. */
2679
2680 static int
2681 map_over_charset_control_1 (Lisp_Char_Table *ct,
2682                             int (*fn) (struct chartab_range *range,
2683                                        Lisp_Object val, void *arg),
2684                             void *arg)
2685 {
2686   struct chartab_range rainj;
2687   int i, retval;
2688   int start = 128;
2689   int stop  = start + 32;
2690
2691   rainj.type = CHARTAB_RANGE_CHAR;
2692
2693   for (i = start, retval = 0; i < stop && retval == 0; i++)
2694     {
2695       rainj.ch = (Emchar) (i);
2696       retval = (fn) (&rainj, ct->ascii[i], arg);
2697     }
2698
2699   return retval;
2700 }
2701
2702 /* Map FN over the row ROW of two-byte charset CHARSET.
2703    There must be a separate value for that row in the char table.
2704    CTE specifies the char table entry for CHARSET. */
2705
2706 static int
2707 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2708                       Lisp_Object charset, int row,
2709                       int (*fn) (struct chartab_range *range,
2710                                  Lisp_Object val, void *arg),
2711                       void *arg)
2712 {
2713   Lisp_Object val = cte->level2[row - 32];
2714
2715   if (!CHAR_TABLE_ENTRYP (val))
2716     {
2717       struct chartab_range rainj;
2718
2719       rainj.type = CHARTAB_RANGE_ROW;
2720       rainj.charset = charset;
2721       rainj.row = row;
2722       return (fn) (&rainj, val, arg);
2723     }
2724   else
2725     {
2726       struct chartab_range rainj;
2727       int i, retval;
2728       int charset94_p = (XCHARSET_CHARS (charset) == 94);
2729       int start = charset94_p ?  33 :  32;
2730       int stop  = charset94_p ? 127 : 128;
2731
2732       cte = XCHAR_TABLE_ENTRY (val);
2733
2734       rainj.type = CHARTAB_RANGE_CHAR;
2735
2736       for (i = start, retval = 0; i < stop && retval == 0; i++)
2737         {
2738           rainj.ch = MAKE_CHAR (charset, row, i);
2739           retval = (fn) (&rainj, cte->level2[i - 32], arg);
2740         }
2741       return retval;
2742     }
2743 }
2744
2745
2746 static int
2747 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2748                         int (*fn) (struct chartab_range *range,
2749                                    Lisp_Object val, void *arg),
2750                         void *arg)
2751 {
2752   Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2753   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2754
2755   if (!CHARSETP (charset)
2756       || lb == LEADING_BYTE_ASCII
2757       || lb == LEADING_BYTE_CONTROL_1)
2758     return 0;
2759
2760   if (!CHAR_TABLE_ENTRYP (val))
2761     {
2762       struct chartab_range rainj;
2763
2764       rainj.type = CHARTAB_RANGE_CHARSET;
2765       rainj.charset = charset;
2766       return (fn) (&rainj, val, arg);
2767     }
2768
2769   {
2770     Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2771     int charset94_p = (XCHARSET_CHARS (charset) == 94);
2772     int start = charset94_p ?  33 :  32;
2773     int stop  = charset94_p ? 127 : 128;
2774     int i, retval;
2775
2776     if (XCHARSET_DIMENSION (charset) == 1)
2777       {
2778         struct chartab_range rainj;
2779         rainj.type = CHARTAB_RANGE_CHAR;
2780
2781         for (i = start, retval = 0; i < stop && retval == 0; i++)
2782           {
2783             rainj.ch = MAKE_CHAR (charset, i, 0);
2784             retval = (fn) (&rainj, cte->level2[i - 32], arg);
2785           }
2786       }
2787     else
2788       {
2789         for (i = start, retval = 0; i < stop && retval == 0; i++)
2790           retval = map_over_charset_row (cte, charset, i, fn, arg);
2791       }
2792
2793     return retval;
2794   }
2795 }
2796
2797 #endif /* MULE */
2798 #endif /* not UTF2000 */
2799
2800 #ifdef UTF2000
2801 struct map_char_table_for_charset_arg
2802 {
2803   int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2804   Lisp_Char_Table *ct;
2805   void *arg;
2806 };
2807
2808 static int
2809 map_char_table_for_charset_fun (struct chartab_range *range,
2810                                 Lisp_Object val, void *arg)
2811 {
2812   struct map_char_table_for_charset_arg *closure =
2813     (struct map_char_table_for_charset_arg *) arg;
2814   Lisp_Object ret;
2815
2816   switch (range->type)
2817     {
2818     case CHARTAB_RANGE_ALL:
2819       break;
2820
2821     case CHARTAB_RANGE_DEFAULT:
2822       break;
2823
2824     case CHARTAB_RANGE_CHARSET:
2825       break;
2826
2827     case CHARTAB_RANGE_ROW:
2828       break;
2829
2830     case CHARTAB_RANGE_CHAR:
2831       ret = get_char_table (range->ch, closure->ct);
2832       if (!UNBOUNDP (ret))
2833         return (closure->fn) (range, ret, closure->arg);
2834       break;
2835
2836     default:
2837       ABORT ();
2838     }
2839
2840   return 0;
2841 }
2842
2843 #endif
2844
2845 /* Map FN (with client data ARG) over range RANGE in char table CT.
2846    Mapping stops the first time FN returns non-zero, and that value
2847    becomes the return value of map_char_table(). */
2848
2849 int
2850 map_char_table (Lisp_Char_Table *ct,
2851                 struct chartab_range *range,
2852                 int (*fn) (struct chartab_range *range,
2853                            Lisp_Object val, void *arg),
2854                 void *arg)
2855 {
2856   switch (range->type)
2857     {
2858     case CHARTAB_RANGE_ALL:
2859 #ifdef UTF2000
2860       if (!UNBOUNDP (ct->default_value))
2861         {
2862           struct chartab_range rainj;
2863           int retval;
2864
2865           rainj.type = CHARTAB_RANGE_DEFAULT;
2866           retval = (fn) (&rainj, ct->default_value, arg);
2867           if (retval != 0)
2868             return retval;
2869         }
2870       if (UINT8_BYTE_TABLE_P (ct->table))
2871         return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2872                                           0, 3, fn, arg);
2873       else if (UINT16_BYTE_TABLE_P (ct->table))
2874         return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2875                                            0, 3, fn, arg);
2876       else if (BYTE_TABLE_P (ct->table))
2877         return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2878                                     0, 3, fn, arg);
2879       else if (EQ (ct->table, Qunloaded))
2880         {
2881 #if 0
2882           struct chartab_range rainj;
2883           int unit = 1 << 30;
2884           Emchar c = 0;
2885           Emchar c1 = c + unit;
2886           int retval;
2887
2888           rainj.type = CHARTAB_RANGE_CHAR;
2889
2890           for (retval = 0; c < c1 && retval == 0; c++)
2891             {
2892               Lisp_Object ret = get_char_id_table (ct, c);
2893
2894               if (!UNBOUNDP (ret))
2895                 {
2896                   rainj.ch = c;
2897                   retval = (fn) (&rainj, ct->table, arg);
2898                 }
2899             }
2900           return retval;
2901 #else
2902           ct->table = Qunbound;
2903 #endif
2904         }
2905       else if (!UNBOUNDP (ct->table))
2906         return (fn) (range, ct->table, arg);
2907       return 0;
2908 #else
2909       {
2910         int retval;
2911
2912         retval = map_over_charset_ascii (ct, fn, arg);
2913         if (retval)
2914           return retval;
2915 #ifdef MULE
2916         retval = map_over_charset_control_1 (ct, fn, arg);
2917         if (retval)
2918           return retval;
2919         {
2920           Charset_ID i;
2921           Charset_ID start = MIN_LEADING_BYTE;
2922           Charset_ID stop  = start + NUM_LEADING_BYTES;
2923
2924           for (i = start, retval = 0; i < stop && retval == 0; i++)
2925             {
2926               retval = map_over_other_charset (ct, i, fn, arg);
2927             }
2928         }
2929 #endif /* MULE */
2930         return retval;
2931       }
2932 #endif
2933
2934 #ifdef UTF2000
2935     case CHARTAB_RANGE_DEFAULT:
2936       if (!UNBOUNDP (ct->default_value))
2937         return (fn) (range, ct->default_value, arg);
2938       return 0;
2939 #endif
2940
2941 #ifdef MULE
2942     case CHARTAB_RANGE_CHARSET:
2943 #ifdef UTF2000
2944       {
2945         Lisp_Object encoding_table
2946           = XCHARSET_ENCODING_TABLE (range->charset);
2947
2948         if (!NILP (encoding_table))
2949           {
2950             struct chartab_range rainj;
2951             struct map_char_table_for_charset_arg mcarg;
2952
2953 #ifdef HAVE_CHISE
2954             if (XCHAR_TABLE_UNLOADED(encoding_table))
2955               Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2956 #endif
2957             mcarg.fn = fn;
2958             mcarg.ct = ct;
2959             mcarg.arg = arg;
2960             rainj.type = CHARTAB_RANGE_ALL;
2961             return map_char_table (XCHAR_TABLE(encoding_table),
2962                                    &rainj,
2963                                    &map_char_table_for_charset_fun,
2964                                    &mcarg);
2965           }
2966       }
2967       return 0;
2968 #else
2969       return map_over_other_charset (ct,
2970                                      XCHARSET_LEADING_BYTE (range->charset),
2971                                      fn, arg);
2972 #endif
2973
2974     case CHARTAB_RANGE_ROW:
2975 #ifdef UTF2000
2976       {
2977         int cell_min, cell_max, i;
2978         int retval;
2979         struct chartab_range rainj;
2980
2981         i = XCHARSET_CELL_RANGE (range->charset);
2982         cell_min = i >> 8;
2983         cell_max = i & 0xFF;
2984         rainj.type = CHARTAB_RANGE_CHAR;
2985         for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2986           {
2987             Emchar ch
2988               = DECODE_CHAR (range->charset, (range->row << 8) | i, 0);
2989
2990             if ( charset_code_point (range->charset, ch, 0) >= 0 )
2991               {
2992                 Lisp_Object val
2993                   = get_byte_table (get_byte_table
2994                                     (get_byte_table
2995                                      (get_byte_table
2996                                       (ct->table,
2997                                        (unsigned char)(ch >> 24)),
2998                                       (unsigned char) (ch >> 16)),
2999                                      (unsigned char)  (ch >> 8)),
3000                                     (unsigned char)    ch);
3001
3002                 if (UNBOUNDP (val))
3003                   val = ct->default_value;
3004                 rainj.ch = ch;
3005                 retval = (fn) (&rainj, val, arg);
3006               }
3007           }
3008         return retval;
3009       }
3010 #else
3011       {
3012         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
3013                                     - MIN_LEADING_BYTE];
3014         if (!CHAR_TABLE_ENTRYP (val))
3015           {
3016             struct chartab_range rainj;
3017
3018             rainj.type = CHARTAB_RANGE_ROW;
3019             rainj.charset = range->charset;
3020             rainj.row = range->row;
3021             return (fn) (&rainj, val, arg);
3022           }
3023         else
3024           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
3025                                        range->charset, range->row,
3026                                        fn, arg);
3027       }
3028 #endif /* not UTF2000 */
3029 #endif /* MULE */
3030
3031     case CHARTAB_RANGE_CHAR:
3032       {
3033         Emchar ch = range->ch;
3034         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
3035
3036         if (!UNBOUNDP (val))
3037           {
3038             struct chartab_range rainj;
3039
3040             rainj.type = CHARTAB_RANGE_CHAR;
3041             rainj.ch = ch;
3042             return (fn) (&rainj, val, arg);
3043           }
3044         return 0;
3045       }
3046
3047     default:
3048       ABORT ();
3049     }
3050
3051   return 0;
3052 }
3053
3054 struct slow_map_char_table_arg
3055 {
3056   Lisp_Object function;
3057   Lisp_Object retval;
3058 };
3059
3060 static int
3061 slow_map_char_table_fun (struct chartab_range *range,
3062                          Lisp_Object val, void *arg)
3063 {
3064   Lisp_Object ranjarg = Qnil;
3065   struct slow_map_char_table_arg *closure =
3066     (struct slow_map_char_table_arg *) arg;
3067
3068   switch (range->type)
3069     {
3070     case CHARTAB_RANGE_ALL:
3071       ranjarg = Qt;
3072       break;
3073
3074 #ifdef UTF2000
3075     case CHARTAB_RANGE_DEFAULT:
3076       ranjarg = Qnil;
3077       break;
3078 #endif
3079
3080 #ifdef MULE
3081     case CHARTAB_RANGE_CHARSET:
3082       ranjarg = XCHARSET_NAME (range->charset);
3083       break;
3084
3085     case CHARTAB_RANGE_ROW:
3086       ranjarg = vector2 (XCHARSET_NAME (range->charset),
3087                          make_int (range->row));
3088       break;
3089 #endif /* MULE */
3090     case CHARTAB_RANGE_CHAR:
3091       ranjarg = make_char (range->ch);
3092       break;
3093     default:
3094       ABORT ();
3095     }
3096
3097   closure->retval = call2 (closure->function, ranjarg, val);
3098   return !NILP (closure->retval);
3099 }
3100
3101 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
3102 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
3103 each key and value in the table.
3104
3105 RANGE specifies a subrange to map over and is in the same format as
3106 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
3107 the entire table.
3108 */
3109        (function, char_table, range))
3110 {
3111   Lisp_Char_Table *ct;
3112   struct slow_map_char_table_arg slarg;
3113   struct gcpro gcpro1, gcpro2;
3114   struct chartab_range rainj;
3115
3116   CHECK_CHAR_TABLE (char_table);
3117   ct = XCHAR_TABLE (char_table);
3118   if (NILP (range))
3119     range = Qt;
3120   decode_char_table_range (range, &rainj);
3121   slarg.function = function;
3122   slarg.retval = Qnil;
3123   GCPRO2 (slarg.function, slarg.retval);
3124   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3125   UNGCPRO;
3126
3127   return slarg.retval;
3128 }
3129
3130 \f
3131 /************************************************************************/
3132 /*                         Character Attributes                         */
3133 /************************************************************************/
3134
3135 #ifdef UTF2000
3136
3137 Lisp_Object Vchar_attribute_hash_table;
3138
3139 /* We store the char-attributes in hash tables with the names as the
3140    key and the actual char-id-table object as the value.  Occasionally
3141    we need to use them in a list format.  These routines provide us
3142    with that. */
3143 struct char_attribute_list_closure
3144 {
3145   Lisp_Object *char_attribute_list;
3146 };
3147
3148 static int
3149 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3150                                    void *char_attribute_list_closure)
3151 {
3152   /* This function can GC */
3153   struct char_attribute_list_closure *calcl
3154     = (struct char_attribute_list_closure*) char_attribute_list_closure;
3155   Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3156
3157   *char_attribute_list = Fcons (key, *char_attribute_list);
3158   return 0;
3159 }
3160
3161 #ifdef HAVE_LIBCHISE
3162 static int
3163 char_attribute_list_reset_map_func (CHISE_DS *ds, unsigned char *name)
3164 {
3165   Fmount_char_attribute_table (intern (name));
3166   return 0;
3167 }
3168
3169 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 1, 0, /*
3170 Return the list of all existing character attributes except coded-charsets.
3171 */
3172        (rehash))
3173 #else
3174 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3175 Return the list of all existing character attributes except coded-charsets.
3176 */
3177        ())
3178 #endif
3179 {
3180   Lisp_Object char_attribute_list = Qnil;
3181   struct gcpro gcpro1;
3182   struct char_attribute_list_closure char_attribute_list_closure;
3183
3184 #ifdef HAVE_LIBCHISE
3185   if (!NILP (rehash))
3186     {
3187       open_chise_data_source_maybe ();
3188       chise_ds_foreach_char_feature_name
3189         (default_chise_data_source, &char_attribute_list_reset_map_func);
3190     }
3191 #endif
3192   GCPRO1 (char_attribute_list);
3193   char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3194   elisp_maphash (add_char_attribute_to_list_mapper,
3195                  Vchar_attribute_hash_table,
3196                  &char_attribute_list_closure);
3197   UNGCPRO;
3198   return char_attribute_list;
3199 }
3200
3201 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3202 Return char-id-table corresponding to ATTRIBUTE.
3203 */
3204        (attribute))
3205 {
3206   return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3207 }
3208
3209
3210 /* We store the char-id-tables in hash tables with the attributes as
3211    the key and the actual char-id-table object as the value.  Each
3212    char-id-table stores values of an attribute corresponding with
3213    characters.  Occasionally we need to get attributes of a character
3214    in a association-list format.  These routines provide us with
3215    that. */
3216 struct char_attribute_alist_closure
3217 {
3218   Emchar char_id;
3219   Lisp_Object *char_attribute_alist;
3220 };
3221
3222 static int
3223 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3224                                  void *char_attribute_alist_closure)
3225 {
3226   /* This function can GC */
3227   struct char_attribute_alist_closure *caacl =
3228     (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3229   Lisp_Object ret
3230     = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3231   if (!UNBOUNDP (ret))
3232     {
3233       Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3234       *char_attribute_alist
3235         = Fcons (Fcons (key, ret), *char_attribute_alist);
3236     }
3237   return 0;
3238 }
3239
3240 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3241 Return the alist of attributes of CHARACTER.
3242 */
3243        (character))
3244 {
3245   struct gcpro gcpro1;
3246   struct char_attribute_alist_closure char_attribute_alist_closure;
3247   Lisp_Object alist = Qnil;
3248
3249   CHECK_CHAR (character);
3250
3251   GCPRO1 (alist);
3252   char_attribute_alist_closure.char_id = XCHAR (character);
3253   char_attribute_alist_closure.char_attribute_alist = &alist;
3254   elisp_maphash (add_char_attribute_alist_mapper,
3255                  Vchar_attribute_hash_table,
3256                  &char_attribute_alist_closure);
3257   UNGCPRO;
3258
3259   return alist;
3260 }
3261
3262 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3263 Return the value of CHARACTER's ATTRIBUTE.
3264 Return DEFAULT-VALUE if the value is not exist.
3265 */
3266        (character, attribute, default_value))
3267 {
3268   Lisp_Object table;
3269
3270   CHECK_CHAR (character);
3271
3272   if (CHARSETP (attribute))
3273     attribute = XCHARSET_NAME (attribute);
3274
3275   table = Fgethash (attribute, Vchar_attribute_hash_table,
3276                     Qunbound);
3277   if (!UNBOUNDP (table))
3278     {
3279       Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3280                                            XCHAR (character));
3281       if (!UNBOUNDP (ret))
3282         return ret;
3283     }
3284   return default_value;
3285 }
3286
3287 static Lisp_Object
3288 find_char_feature_in_family (Lisp_Object character,
3289                              Lisp_Object con_feature,
3290                              Lisp_Object feature,
3291                              Lisp_Object feature_rel_max)
3292 {
3293   Lisp_Object ancestors
3294     = Fget_char_attribute (character, con_feature, Qnil);
3295
3296   while (!NILP (ancestors))
3297     {
3298       Lisp_Object ancestor = XCAR (ancestors);
3299       Lisp_Object ret;
3300
3301       if (EQ (ancestor, character))
3302         return Qunbound;
3303
3304       ret = Fchar_feature (ancestor, feature, Qunbound,
3305                            Qnil, make_int (0));
3306       if (!UNBOUNDP (ret))
3307         return ret;
3308
3309       ancestors = XCDR (ancestors);
3310
3311       ret = Fget_char_attribute (ancestor, Q_subsumptive_from, Qnil);
3312       if (!NILP (ret))
3313         ancestors = nconc2 (Fcopy_sequence (ancestors), ret);
3314
3315       ret = Fget_char_attribute (ancestor, Q_denotational_from, Qnil);
3316       if (!NILP (ret))
3317         ancestors = nconc2 (Fcopy_sequence (ancestors), ret);
3318     }
3319   return Qunbound;
3320 }
3321
3322 DEFUN ("char-feature", Fchar_feature, 2, 5, 0, /*
3323 Return the value of CHARACTER's FEATURE.
3324 Return DEFAULT-VALUE if the value is not exist.
3325 */
3326        (character, attribute, default_value,
3327         feature_rel_max, char_rel_max))
3328 {
3329   Lisp_Object ret
3330     = Fget_char_attribute (character, attribute, Qunbound);
3331
3332   if (!UNBOUNDP (ret))
3333     return ret;
3334
3335   if (NILP (feature_rel_max)
3336       || (INTP (feature_rel_max) &&
3337           XINT (feature_rel_max) > 0))
3338     {
3339       Lisp_String* name = symbol_name (XSYMBOL (attribute));
3340       Bufbyte *name_str = string_data (name);
3341
3342       if (name_str[0] == '=' && name_str[1] == '>')
3343         {
3344           Bytecount length = string_length (name) - 1;
3345           Lisp_Object map_to = make_uninit_string (length);
3346
3347           memcpy (XSTRING_DATA (map_to) + 1, name_str + 2, length - 1);
3348           XSTRING_DATA(map_to)[0] = '=';
3349           ret = Fchar_feature (character, Fintern (map_to, Qnil),
3350                                Qunbound,
3351                                NILP (feature_rel_max)
3352                                ? feature_rel_max
3353                                : make_int (XINT (feature_rel_max) - 1),
3354                                char_rel_max);
3355           if (!UNBOUNDP (ret))
3356             return ret;
3357         }
3358     }
3359
3360   if ( !(EQ (attribute, Q_identical)) &&
3361        !(EQ (attribute, Q_subsumptive_from)) &&
3362        !(EQ (attribute, Q_denotational_from)) &&
3363        ( (NILP (char_rel_max)
3364           || (INTP (char_rel_max) &&
3365               XINT (char_rel_max) > 0)) ) )
3366     {
3367       Lisp_String* name = symbol_name (XSYMBOL (attribute));
3368       Bufbyte *name_str = string_data (name);
3369
3370       if ( (name_str[0] != '=') || (name_str[1] == '>') )
3371         {
3372           ret = find_char_feature_in_family (character, Q_identical,
3373                                              attribute, feature_rel_max);
3374           if (!UNBOUNDP (ret))
3375             return ret;
3376
3377           ret = find_char_feature_in_family (character, Q_subsumptive_from,
3378                                              attribute, feature_rel_max);
3379           if (!UNBOUNDP (ret))
3380             return ret;
3381
3382           ret = find_char_feature_in_family (character, Q_denotational_from,
3383                                              attribute, feature_rel_max);
3384           if (!UNBOUNDP (ret))
3385             return ret;
3386         }
3387     }
3388   return default_value;
3389 }
3390
3391 Lisp_Object
3392 put_char_composition (Lisp_Object character, Lisp_Object value);
3393 Lisp_Object
3394 put_char_composition (Lisp_Object character, Lisp_Object value)
3395 {
3396   if (!CONSP (value))
3397     signal_simple_error ("Invalid value for =decomposition",
3398                          value);
3399
3400   if (CONSP (XCDR (value)))
3401     {
3402       if (NILP (Fcdr (XCDR (value))))
3403         {
3404           Lisp_Object base = XCAR (value);
3405           Lisp_Object modifier = XCAR (XCDR (value));
3406
3407           if (INTP (base))
3408             {
3409               base = make_char (XINT (base));
3410               Fsetcar (value, base);
3411             }
3412           if (INTP (modifier))
3413             {
3414               modifier = make_char (XINT (modifier));
3415               Fsetcar (XCDR (value), modifier);
3416             }
3417           if (CHARP (base))
3418             {
3419               Lisp_Object alist
3420                 = Fchar_feature (base, Qcomposition, Qnil,
3421                                  Qnil, Qnil);
3422               Lisp_Object ret = Fassq (modifier, alist);
3423
3424               if (NILP (ret))
3425                 Fput_char_attribute (base, Qcomposition,
3426                                      Fcons (Fcons (modifier, character),
3427                                             alist));
3428               else
3429                 Fsetcdr (ret, character);
3430             }
3431           else if (EQ (base, Qcompat))
3432             return Q_compat_of;
3433         }
3434       else if (EQ (XCAR (value), Qcompat))
3435         return Qto_decomposition_at_compat;
3436       else
3437         return
3438           Fintern
3439           (concat2 (build_string ("=>decomposition@"),
3440                     symbol_name (XSYMBOL (XCAR (value)))),
3441            Qnil);
3442     }
3443   else
3444     {
3445       return Q_canonical;
3446 #if 0
3447       Lisp_Object v = Fcar (value);
3448
3449       if (INTP (v))
3450         {
3451           Emchar c = DECODE_CHAR (Vcharset_ucs, XINT (v), 0);
3452           Lisp_Object ret
3453             = Fchar_feature (make_char (c), Q_ucs_unified, Qnil,
3454                              Qnil, Qnil);
3455
3456           if (!CONSP (ret))
3457             {
3458               Fput_char_attribute (make_char (c), Q_ucs_unified,
3459                                    Fcons (character, Qnil));
3460             }
3461           else if (NILP (Fmemq (character, ret)))
3462             {
3463               Fput_char_attribute (make_char (c), Q_ucs_unified,
3464                                    Fcons (character, ret));
3465             }
3466         }
3467 #endif
3468     }
3469   return Qmap_decomposition;
3470 }
3471
3472 static Lisp_Object
3473 put_char_attribute (Lisp_Object character, Lisp_Object attribute,
3474                     Lisp_Object value)
3475 {
3476   Lisp_Object table = Fgethash (attribute,
3477                                 Vchar_attribute_hash_table,
3478                                 Qnil);
3479
3480   if (NILP (table))
3481     {
3482       table = make_char_id_table (Qunbound);
3483       Fputhash (attribute, table, Vchar_attribute_hash_table);
3484 #ifdef HAVE_CHISE
3485       XCHAR_TABLE_NAME (table) = attribute;
3486 #endif
3487     }
3488   put_char_id_table (XCHAR_TABLE(table), character, value);
3489   return value;
3490 }
3491
3492 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3493 Store CHARACTER's ATTRIBUTE with VALUE.
3494 */
3495        (character, attribute, value))
3496 {
3497   Lisp_Object ccs = Ffind_charset (attribute);
3498
3499   CHECK_CHAR (character);
3500
3501   if (!NILP (ccs))
3502     {
3503       value = put_char_ccs_code_point (character, ccs, value);
3504       attribute = XCHARSET_NAME (ccs);
3505     }
3506   else if ( EQ (attribute, Qmap_decomposition) ||
3507             EQ (attribute, Q_decomposition) )
3508     {
3509       attribute = put_char_composition (character, value);
3510       if ( /*
3511              EQ (attribute, Q_compat_of) ||
3512              EQ (attribute, Qto_decomposition_at_compat)
3513            */
3514           /* SYMBOLP (XCAR (value)) */
3515           !EQ (attribute, Qmap_decomposition) )
3516         value = XCDR (value);
3517     }
3518   else if (EQ (attribute, Qto_ucs))
3519     {
3520       Lisp_Object ret;
3521       Emchar c;
3522
3523       if (!INTP (value))
3524         signal_simple_error ("Invalid value for =>ucs", value);
3525
3526       c = DECODE_CHAR (Vcharset_ucs, XINT (value), 0);
3527
3528       ret = Fchar_feature (make_char (c), Q_ucs_unified, Qnil,
3529                            Qnil, Qnil);
3530       if (!CONSP (ret))
3531         put_char_attribute (make_char (c), Q_ucs_unified,
3532                             list1 (character));
3533       else if (NILP (Fmemq (character, ret)))
3534         Fput_char_attribute (make_char (c), Q_ucs_unified,
3535                              Fcons (character, ret));
3536     }
3537   if ( EQ (attribute, Q_subsumptive)            ||
3538        EQ (attribute, Q_subsumptive_from)       ||
3539        EQ (attribute, Q_denotational)           ||
3540        EQ (attribute, Q_denotational_from)      ||
3541        EQ (attribute, Q_identical)              ||
3542        EQ (attribute, Q_identical_from)         ||
3543        EQ (attribute, Q_canonical)              ||
3544        EQ (attribute, Q_compat_of)      ||
3545        EQ (attribute, Q_component)              ||
3546        EQ (attribute, Q_component_of)           ||
3547        !NILP (Fstring_match
3548               (build_string ("^\\(<-\\|->\\)\\("
3549                              "canonical"
3550                              "\\|compat"
3551                              "\\|fullwidth\\|halfwidth"
3552                              "\\|simplified\\|vulgar\\|wrong"
3553                              "\\|same\\|original\\|ancient"
3554                              "\\|Oracle-Bones\\)[^*]*$"),
3555                Fsymbol_name (attribute),
3556                Qnil, Qnil)) )
3557     {
3558       Lisp_Object rest = value;
3559       Lisp_Object ret;
3560       Lisp_Object rev_feature = Qnil;
3561       struct gcpro gcpro1;
3562       GCPRO1 (rev_feature);
3563
3564       if (EQ (attribute, Q_identical))
3565         rev_feature = Q_identical_from;
3566       else if (EQ (attribute, Q_identical_from))
3567         rev_feature = Q_identical;
3568       else if (EQ (attribute, Q_subsumptive))
3569         rev_feature = Q_subsumptive_from;
3570       else if (EQ (attribute, Q_subsumptive_from))
3571         rev_feature = Q_subsumptive;
3572       else if (EQ (attribute, Q_denotational))
3573         rev_feature = Q_denotational_from;
3574       else if (EQ (attribute, Q_denotational_from))
3575         rev_feature = Q_denotational;
3576       else if (EQ (attribute, Q_component))
3577         rev_feature = Q_component_of;
3578       else if (EQ (attribute, Q_component_of))
3579         rev_feature = Q_component;
3580       else
3581         {
3582           Lisp_String* name = symbol_name (XSYMBOL (attribute));
3583           Bufbyte *name_str = string_data (name);
3584
3585           if ( (name_str[0] == '<' && name_str[1] == '-') ||
3586                (name_str[0] == '-' && name_str[1] == '>') )
3587             {
3588               Bytecount length = string_length (name);
3589               Bufbyte *rev_name_str = alloca (length + 1);
3590
3591               memcpy (rev_name_str + 2, name_str + 2, length - 2);
3592               if (name_str[0] == '<')
3593                 {
3594                   rev_name_str[0] = '-';
3595                   rev_name_str[1] = '>';
3596                 }
3597               else
3598                 {
3599                   rev_name_str[0] = '<';
3600                   rev_name_str[1] = '-';
3601                 }
3602               rev_name_str[length] = 0;
3603               rev_feature = intern (rev_name_str);
3604             }
3605         }
3606
3607       while (CONSP (rest))
3608         {
3609           ret = XCAR (rest);
3610
3611           if (CONSP (ret))
3612             ret = Fdefine_char (ret);
3613           else if (INTP (ret))
3614             {
3615               int code_point = XINT (ret);
3616               Emchar cid = DECODE_CHAR (Vcharset_ucs, code_point, 0);
3617
3618               if (cid >= 0)
3619                 ret = make_char (cid);
3620               else
3621                 ret = make_char (code_point);
3622             }
3623
3624           if ( !NILP (ret) && !EQ (ret, character) )
3625             {
3626               Lisp_Object ffv;
3627
3628               ffv = Fget_char_attribute (ret, rev_feature, Qnil);
3629               if (!CONSP (ffv))
3630                 put_char_attribute (ret, rev_feature, list1 (character));
3631               else if (NILP (Fmemq (character, ffv)))
3632                 put_char_attribute
3633                   (ret, rev_feature,
3634                    nconc2 (Fcopy_sequence (ffv), list1 (character)));
3635               Fsetcar (rest, ret);
3636             }
3637           rest = XCDR (rest);
3638         }
3639       UNGCPRO;
3640     }
3641 #if 1
3642   else if ( EQ (attribute, Qideographic_structure) ||
3643             !NILP (Fstring_match
3644                    (build_string ("^=>decomposition\\(\\|@[^*]+\\)$"),
3645                     Fsymbol_name (attribute),
3646                     Qnil, Qnil)) )
3647     value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value));
3648 #endif
3649   return put_char_attribute (character, attribute, value);
3650 }
3651
3652 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3653 Remove CHARACTER's ATTRIBUTE.
3654 */
3655        (character, attribute))
3656 {
3657   Lisp_Object ccs;
3658
3659   CHECK_CHAR (character);
3660   ccs = Ffind_charset (attribute);
3661   if (!NILP (ccs))
3662     {
3663       return remove_char_ccs (character, ccs);
3664     }
3665   else
3666     {
3667       Lisp_Object table = Fgethash (attribute,
3668                                     Vchar_attribute_hash_table,
3669                                     Qunbound);
3670       if (!UNBOUNDP (table))
3671         {
3672           put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3673           return Qt;
3674         }
3675     }
3676   return Qnil;
3677 }
3678
3679 #ifdef HAVE_CHISE
3680
3681 int char_table_open_db_maybe (Lisp_Char_Table* cit);
3682 void char_table_close_db_maybe (Lisp_Char_Table* cit);
3683 Lisp_Object char_table_get_db (Lisp_Char_Table* cit, Emchar ch);
3684
3685 #ifdef HAVE_LIBCHISE
3686 int
3687 open_chise_data_source_maybe ()
3688 {
3689   if (default_chise_data_source == NULL)
3690     {
3691       Lisp_Object db_dir = Vdata_directory;
3692       int modemask = 0755;              /* rwxr-xr-x */
3693
3694       if (NILP (db_dir))
3695         db_dir = build_string ("../etc");
3696       db_dir = Fexpand_file_name (build_string ("chise-db"), db_dir);
3697
3698       default_chise_data_source
3699         = CHISE_DS_open (CHISE_DS_Berkeley_DB, XSTRING_DATA (db_dir),
3700                          0 /* DB_HASH */, modemask);
3701       if (default_chise_data_source == NULL)
3702         return -1;
3703 #if 0
3704       chise_ds_set_make_string_function (default_chise_data_source,
3705                                          &make_string);
3706 #endif
3707     }
3708   return 0;
3709 }
3710 #endif /* HAVE_LIBCHISE */
3711
3712 DEFUN ("close-char-data-source", Fclose_char_data_source, 0, 0, 0, /*
3713 Close data-source of CHISE.
3714 */
3715        ())
3716 {
3717 #ifdef HAVE_LIBCHISE
3718   int status = CHISE_DS_close (default_chise_data_source);
3719
3720   default_chise_data_source = NULL;
3721   if (status)
3722     return Qt;
3723 #endif /* HAVE_LIBCHISE */
3724   return Qnil;
3725 }
3726
3727 int
3728 char_table_open_db_maybe (Lisp_Char_Table* cit)
3729 {
3730   Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3731
3732   if (!NILP (attribute))
3733     {
3734 #ifdef HAVE_LIBCHISE
3735       if ( open_chise_data_source_maybe () )
3736         return -1;
3737 #else /* HAVE_LIBCHISE */
3738       if (NILP (Fdatabase_live_p (cit->db)))
3739         {
3740           Lisp_Object db_file
3741             = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3742
3743           cit->db = Fopen_database (db_file, Qnil, Qnil,
3744                                     build_string ("r"), Qnil);
3745           if (NILP (cit->db))
3746             return -1;
3747         }
3748 #endif /* not HAVE_LIBCHISE */
3749       return 0;
3750     }
3751   else
3752     return -1;
3753 }
3754
3755 void
3756 char_table_close_db_maybe (Lisp_Char_Table* cit)
3757 {
3758 #ifndef HAVE_LIBCHISE
3759   if (!NILP (cit->db))
3760     {
3761       if (!NILP (Fdatabase_live_p (cit->db)))
3762         Fclose_database (cit->db);
3763       cit->db = Qnil;
3764     }
3765 #endif /* not HAVE_LIBCHISE */
3766 }
3767
3768 Lisp_Object
3769 char_table_get_db (Lisp_Char_Table* cit, Emchar ch)
3770 {
3771   Lisp_Object val;
3772 #ifdef HAVE_LIBCHISE
3773   CHISE_Value value;
3774   int status
3775     = chise_ds_load_char_feature_value (default_chise_data_source, ch,
3776                                         XSTRING_DATA(Fsymbol_name
3777                                                      (cit->name)),
3778                                         &value);
3779
3780   if (!status)
3781     {
3782 #if 0
3783       val = Fread (make_string (chise_value_data (&value),
3784                                 chise_value_size (&value) ));
3785 #else
3786       val = read_from_c_string (chise_value_data (&value),
3787                                 chise_value_size (&value) );
3788 #endif
3789     }
3790   else
3791     val = Qunbound;
3792 #else /* HAVE_LIBCHISE */
3793   val = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3794                        cit->db, Qunbound);
3795   if (!UNBOUNDP (val))
3796     val = Fread (val);
3797   else
3798     val = Qunbound;
3799 #endif /* not HAVE_LIBCHISE */
3800   return val;
3801 }
3802
3803 #ifndef HAVE_LIBCHISE
3804 Lisp_Object
3805 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3806                                int writing_mode)
3807 {
3808   Lisp_Object db_dir = Vdata_directory;
3809
3810   if (NILP (db_dir))
3811     db_dir = build_string ("../etc");
3812
3813   db_dir = Fexpand_file_name (build_string ("chise-db"), db_dir);
3814   if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3815     Fmake_directory_internal (db_dir);
3816
3817   db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3818   if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3819     Fmake_directory_internal (db_dir);
3820
3821   {
3822     Lisp_Object attribute_name = Fsymbol_name (attribute);
3823     Lisp_Object dest = Qnil, ret;
3824     int base = 0;
3825     struct gcpro gcpro1, gcpro2;
3826     int len = XSTRING_CHAR_LENGTH (attribute_name);
3827     int i;
3828
3829     GCPRO2 (dest, ret);
3830     for (i = 0; i < len; i++)
3831       {
3832         Emchar c = string_char (XSTRING (attribute_name), i);
3833
3834         if ( (c == '/') || (c == '%') )
3835           {
3836             char str[4];
3837
3838             sprintf (str, "%%%02X", c);
3839             dest = concat3 (dest,
3840                             Fsubstring (attribute_name,
3841                                         make_int (base), make_int (i)),
3842                             build_string (str));
3843             base = i + 1;
3844           }
3845       }
3846     ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3847     dest = concat2 (dest, ret);
3848     UNGCPRO;
3849     return Fexpand_file_name (dest, db_dir);
3850   }
3851 }
3852 #endif /* not HAVE_LIBCHISE */
3853
3854 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3855 Save values of ATTRIBUTE into database file.
3856 */
3857        (attribute))
3858 {
3859   Lisp_Object table = Fgethash (attribute,
3860                                 Vchar_attribute_hash_table, Qunbound);
3861   Lisp_Char_Table *ct;
3862 #ifdef HAVE_LIBCHISE
3863   CHISE_Feature feature;
3864 #else /* HAVE_LIBCHISE */
3865   Lisp_Object db_file;
3866   Lisp_Object db;
3867 #endif /* not HAVE_LIBCHISE */
3868
3869   if (CHAR_TABLEP (table))
3870     ct = XCHAR_TABLE (table);
3871   else
3872     return Qnil;
3873
3874 #ifdef HAVE_LIBCHISE
3875   if ( open_chise_data_source_maybe () )
3876     return -1;
3877   feature
3878     = chise_ds_get_feature (default_chise_data_source,
3879                             XSTRING_DATA (Fsymbol_name (attribute)));
3880 #else /* HAVE_LIBCHISE */
3881   db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3882   db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3883 #endif /* not HAVE_LIBCHISE */
3884   if (
3885 #ifdef HAVE_LIBCHISE
3886       feature != NULL
3887 #else /* HAVE_LIBCHISE */
3888       !NILP (db)
3889 #endif /* not HAVE_LIBCHISE */
3890       )
3891     {
3892       Lisp_Object (*filter)(Lisp_Object value);
3893
3894       if ( !NILP (Ffind_charset (attribute)) )
3895         filter = NULL;
3896       else if ( EQ (attribute, Qideographic_structure)  ||
3897                 EQ (attribute, Q_identical)             ||
3898                 EQ (attribute, Q_identical_from)        ||
3899                 EQ (attribute, Q_canonical)             ||
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_compat, "=>decomposition@compat");
4684   defsymbol (&Q_canonical,              "->canonical");
4685   defsymbol (&Q_compat_of,              "<-compat");
4686   defsymbol (&Q_decomposition,          "->decomposition");
4687   defsymbol (&Qcompat,                  "compat");
4688   defsymbol (&Qisolated,                "isolated");
4689   defsymbol (&Qinitial,                 "initial");
4690   defsymbol (&Qmedial,                  "medial");
4691   defsymbol (&Qfinal,                   "final");
4692   defsymbol (&Qvertical,                "vertical");
4693   defsymbol (&QnoBreak,                 "noBreak");
4694   defsymbol (&Qfraction,                "fraction");
4695   defsymbol (&Qsuper,                   "super");
4696   defsymbol (&Qsub,                     "sub");
4697   defsymbol (&Qcircle,                  "circle");
4698   defsymbol (&Qsquare,                  "square");
4699   defsymbol (&Qwide,                    "wide");
4700   defsymbol (&Qnarrow,                  "narrow");
4701   defsymbol (&Qsmall,                   "small");
4702   defsymbol (&Qfont,                    "font");
4703
4704   DEFSUBR (Fchar_attribute_list);
4705   DEFSUBR (Ffind_char_attribute_table);
4706   defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4707   DEFSUBR (Fput_char_table_map_function);
4708 #ifdef HAVE_CHISE
4709   DEFSUBR (Fsave_char_attribute_table);
4710   DEFSUBR (Fmount_char_attribute_table);
4711   DEFSUBR (Freset_char_attribute_table);
4712   DEFSUBR (Fclose_char_attribute_table);
4713   DEFSUBR (Fclose_char_data_source);
4714 #ifndef HAVE_LIBCHISE
4715   defsymbol (&Qload_char_attribute_table_map_function,
4716              "load-char-attribute-table-map-function");
4717   DEFSUBR (Fload_char_attribute_table_map_function);
4718 #endif
4719   DEFSUBR (Fload_char_attribute_table);
4720 #endif
4721   DEFSUBR (Fchar_feature);
4722   DEFSUBR (Fchar_attribute_alist);
4723   DEFSUBR (Fget_char_attribute);
4724   DEFSUBR (Fput_char_attribute);
4725   DEFSUBR (Fremove_char_attribute);
4726   DEFSUBR (Fmap_char_attribute);
4727   DEFSUBR (Fdefine_char);
4728   DEFSUBR (Ffind_char);
4729   DEFSUBR (Fchar_variants);
4730
4731   DEFSUBR (Fget_composite_char);
4732 #endif
4733
4734   INIT_LRECORD_IMPLEMENTATION (char_table);
4735
4736 #ifdef MULE
4737 #ifndef UTF2000
4738   INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4739 #endif
4740
4741   defsymbol (&Qcategory_table_p, "category-table-p");
4742   defsymbol (&Qcategory_designator_p, "category-designator-p");
4743   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4744 #endif /* MULE */
4745
4746   defsymbol (&Qchar_table, "char-table");
4747   defsymbol (&Qchar_tablep, "char-table-p");
4748
4749   DEFSUBR (Fchar_table_p);
4750   DEFSUBR (Fchar_table_type_list);
4751   DEFSUBR (Fvalid_char_table_type_p);
4752   DEFSUBR (Fchar_table_type);
4753   DEFSUBR (Freset_char_table);
4754   DEFSUBR (Fmake_char_table);
4755   DEFSUBR (Fcopy_char_table);
4756   DEFSUBR (Fget_char_table);
4757   DEFSUBR (Fget_range_char_table);
4758   DEFSUBR (Fvalid_char_table_value_p);
4759   DEFSUBR (Fcheck_valid_char_table_value);
4760   DEFSUBR (Fput_char_table);
4761   DEFSUBR (Fmap_char_table);
4762
4763 #ifdef MULE
4764   DEFSUBR (Fcategory_table_p);
4765   DEFSUBR (Fcategory_table);
4766   DEFSUBR (Fstandard_category_table);
4767   DEFSUBR (Fcopy_category_table);
4768   DEFSUBR (Fset_category_table);
4769   DEFSUBR (Fcheck_category_at);
4770   DEFSUBR (Fchar_in_category_p);
4771   DEFSUBR (Fcategory_designator_p);
4772   DEFSUBR (Fcategory_table_value_p);
4773 #endif /* MULE */
4774
4775 }
4776
4777 void
4778 vars_of_chartab (void)
4779 {
4780 #ifdef UTF2000
4781   DEFVAR_LISP ("next-defined-char-id", &Vnext_defined_char_id /*
4782 */ );
4783   Vnext_defined_char_id = make_int (0x0F0000);
4784 #endif
4785
4786 #ifdef HAVE_CHISE
4787   DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4788 */ );
4789   Vchar_db_stingy_mode = Qt;
4790
4791 #ifdef HAVE_LIBCHISE
4792   Vchise_db_directory = build_string(chise_db_dir);
4793   DEFVAR_LISP ("chise-db-directory", &Vchise_db_directory /*
4794 Directory of CHISE character databases.
4795 */ );
4796
4797   Vchise_system_db_directory = build_string(chise_system_db_dir);
4798   DEFVAR_LISP ("chise-system-db-directory", &Vchise_system_db_directory /*
4799 Directory of system character database of CHISE.
4800 */ );
4801 #endif
4802
4803 #endif /* HAVE_CHISE */
4804   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
4805   Vall_syntax_tables = Qnil;
4806   dump_add_weak_object_chain (&Vall_syntax_tables);
4807 }
4808
4809 void
4810 structure_type_create_chartab (void)
4811 {
4812   struct structure_type *st;
4813
4814   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4815
4816   define_structure_type_keyword (st, Qtype, chartab_type_validate);
4817   define_structure_type_keyword (st, Qdata, chartab_data_validate);
4818 }
4819
4820 void
4821 complex_vars_of_chartab (void)
4822 {
4823 #ifdef UTF2000
4824   staticpro (&Vchar_attribute_hash_table);
4825   Vchar_attribute_hash_table
4826     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4827 #endif /* UTF2000 */
4828 #ifdef MULE
4829   /* Set this now, so first buffer creation can refer to it. */
4830   /* Make it nil before calling copy-category-table
4831      so that copy-category-table will know not to try to copy from garbage */
4832   Vstandard_category_table = Qnil;
4833   Vstandard_category_table = Fcopy_category_table (Qnil);
4834   staticpro (&Vstandard_category_table);
4835
4836   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4837 List of pair (cons) of categories to determine word boundary.
4838
4839 Emacs treats a sequence of word constituent characters as a single
4840 word (i.e. finds no word boundary between them) iff they belongs to
4841 the same charset.  But, exceptions are allowed in the following cases.
4842
4843 \(1) The case that characters are in different charsets is controlled
4844 by the variable `word-combining-categories'.
4845
4846 Emacs finds no word boundary between characters of different charsets
4847 if they have categories matching some element of this list.
4848
4849 More precisely, if an element of this list is a cons of category CAT1
4850 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4851 C2 which has CAT2, there's no word boundary between C1 and C2.
4852
4853 For instance, to tell that ASCII characters and Latin-1 characters can
4854 form a single word, the element `(?l . ?l)' should be in this list
4855 because both characters have the category `l' (Latin characters).
4856
4857 \(2) The case that character are in the same charset is controlled by
4858 the variable `word-separating-categories'.
4859
4860 Emacs find a word boundary between characters of the same charset
4861 if they have categories matching some element of this list.
4862
4863 More precisely, if an element of this list is a cons of category CAT1
4864 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4865 C2 which has CAT2, there's a word boundary between C1 and C2.
4866
4867 For instance, to tell that there's a word boundary between Japanese
4868 Hiragana and Japanese Kanji (both are in the same charset), the
4869 element `(?H . ?C) should be in this list.
4870 */ );
4871
4872   Vword_combining_categories = Qnil;
4873
4874   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4875 List of pair (cons) of categories to determine word boundary.
4876 See the documentation of the variable `word-combining-categories'.
4877 */ );
4878
4879   Vword_separating_categories = Qnil;
4880 #endif /* MULE */
4881 }