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