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