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