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