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

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