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

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