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