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