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