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