src/chartab.c

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