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