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