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

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