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