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

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