git.chise.org Git - chise/xemacs-chise.git.1/blob - src/chartab.c

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