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