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