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