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