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