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 #ifdef UTF2000
2573 struct map_char_table_for_charset_arg
2574 {
2575   int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2576   Lisp_Char_Table *ct;
2577   void *arg;
2578 };
2579
2580 static int
2581 map_char_table_for_charset_fun (struct chartab_range *range,
2582                                 Lisp_Object val, void *arg)
2583 {
2584   struct map_char_table_for_charset_arg *closure =
2585     (struct map_char_table_for_charset_arg *) arg;
2586   Lisp_Object ret;
2587
2588   switch (range->type)
2589     {
2590     case CHARTAB_RANGE_ALL:
2591       break;
2592
2593     case CHARTAB_RANGE_DEFAULT:
2594       break;
2595
2596     case CHARTAB_RANGE_CHARSET:
2597       break;
2598
2599     case CHARTAB_RANGE_ROW:
2600       break;
2601
2602     case CHARTAB_RANGE_CHAR:
2603       ret = get_char_table (range->ch, closure->ct);
2604       if (!UNBOUNDP (ret))
2605         return (closure->fn) (range, ret, closure->arg);
2606       break;
2607
2608     default:
2609       abort ();
2610     }
2611
2612   return 0;
2613 }
2614 #endif
2615
2616 /* Map FN (with client data ARG) over range RANGE in char table CT.
2617    Mapping stops the first time FN returns non-zero, and that value
2618    becomes the return value of map_char_table(). */
2619
2620 int
2621 map_char_table (Lisp_Char_Table *ct,
2622                 struct chartab_range *range,
2623                 int (*fn) (struct chartab_range *range,
2624                            Lisp_Object val, void *arg),
2625                 void *arg)
2626 {
2627   switch (range->type)
2628     {
2629     case CHARTAB_RANGE_ALL:
2630 #ifdef UTF2000
2631       if (!UNBOUNDP (ct->default_value))
2632         {
2633           struct chartab_range rainj;
2634           int retval;
2635
2636           rainj.type = CHARTAB_RANGE_DEFAULT;
2637           retval = (fn) (&rainj, ct->default_value, arg);
2638           if (retval != 0)
2639             return retval;
2640         }
2641       if (UINT8_BYTE_TABLE_P (ct->table))
2642         return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), 0, 3,
2643                                           Qnil, fn, arg);
2644       else if (UINT16_BYTE_TABLE_P (ct->table))
2645         return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), 0, 3,
2646                                            Qnil, fn, arg);
2647       else if (BYTE_TABLE_P (ct->table))
2648         return map_over_byte_table (XBYTE_TABLE(ct->table), 0, 3,
2649                                     Qnil, fn, arg);
2650       else if (!UNBOUNDP (ct->table))
2651 #if 0
2652         {
2653           struct chartab_range rainj;
2654           int unit = 1 << 30;
2655           Emchar c = 0;
2656           Emchar c1 = c + unit;
2657           int retval;
2658
2659           rainj.type = CHARTAB_RANGE_CHAR;
2660
2661           for (retval = 0; c < c1 && retval == 0; c++)
2662             {
2663               rainj.ch = c;
2664               retval = (fn) (&rainj, ct->table, arg);
2665             }
2666           return retval;
2667         }
2668 #else
2669       return (fn) (range, ct->table, arg);
2670 #endif
2671       return 0;
2672 #else
2673       {
2674         int retval;
2675
2676         retval = map_over_charset_ascii (ct, fn, arg);
2677         if (retval)
2678           return retval;
2679 #ifdef MULE
2680         retval = map_over_charset_control_1 (ct, fn, arg);
2681         if (retval)
2682           return retval;
2683         {
2684           Charset_ID i;
2685           Charset_ID start = MIN_LEADING_BYTE;
2686           Charset_ID stop  = start + NUM_LEADING_BYTES;
2687
2688           for (i = start, retval = 0; i < stop && retval == 0; i++)
2689             {
2690               retval = map_over_other_charset (ct, i, fn, arg);
2691             }
2692         }
2693 #endif /* MULE */
2694         return retval;
2695       }
2696 #endif
2697
2698 #ifdef UTF2000
2699     case CHARTAB_RANGE_DEFAULT:
2700       if (!UNBOUNDP (ct->default_value))
2701         return (fn) (range, ct->default_value, arg);
2702       return 0;
2703 #endif
2704
2705 #ifdef MULE
2706     case CHARTAB_RANGE_CHARSET:
2707 #ifdef UTF2000
2708       {
2709         Lisp_Object encoding_table
2710           = XCHARSET_ENCODING_TABLE (range->charset);
2711
2712         if (!NILP (encoding_table))
2713           {
2714             struct chartab_range rainj;
2715             struct map_char_table_for_charset_arg mcarg;
2716
2717             mcarg.fn = fn;
2718             mcarg.ct = ct;
2719             mcarg.arg = arg;
2720             rainj.type = CHARTAB_RANGE_ALL;
2721             return map_char_table (XCHAR_TABLE(encoding_table),
2722                                    &rainj,
2723                                    &map_char_table_for_charset_fun,
2724                                    &mcarg);
2725           }
2726       }
2727       return 0;
2728 #else
2729       return map_over_other_charset (ct,
2730                                      XCHARSET_LEADING_BYTE (range->charset),
2731                                      fn, arg);
2732 #endif
2733
2734     case CHARTAB_RANGE_ROW:
2735 #ifdef UTF2000
2736       {
2737         int cell_min, cell_max, i;
2738         int retval;
2739         struct chartab_range rainj;
2740
2741         if (XCHARSET_DIMENSION (range->charset) < 2)
2742           signal_simple_error ("Charset in row vector must be multi-byte",
2743                                range->charset);
2744         else
2745           {
2746             switch (XCHARSET_CHARS (range->charset))
2747               {
2748               case 94:
2749                 cell_min = 33; cell_max = 126;
2750                 break;
2751               case 96:
2752                 cell_min = 32; cell_max = 127;
2753                 break;
2754               case 128:
2755                 cell_min = 0; cell_max = 127;
2756                 break;
2757               case 256:
2758                 cell_min = 0; cell_max = 255;
2759                 break;
2760               default:
2761                 abort ();
2762               }
2763           }
2764         if (XCHARSET_DIMENSION (range->charset) == 2)
2765           check_int_range (range->row, cell_min, cell_max);
2766         else if (XCHARSET_DIMENSION (range->charset) == 3)
2767           {
2768             check_int_range (range->row >> 8  , cell_min, cell_max);
2769             check_int_range (range->row & 0xFF, cell_min, cell_max);
2770           }
2771         else if (XCHARSET_DIMENSION (range->charset) == 4)
2772           {
2773             check_int_range ( range->row >> 16       , cell_min, cell_max);
2774             check_int_range ((range->row >> 8) & 0xFF, cell_min, cell_max);
2775             check_int_range ( range->row       & 0xFF, cell_min, cell_max);
2776           }
2777         else
2778           abort ();
2779
2780         rainj.type = CHARTAB_RANGE_CHAR;
2781         for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2782           {
2783             Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2784
2785             if ( charset_code_point (range->charset, ch) >= 0 )
2786               {
2787                 Lisp_Object val
2788                   = get_byte_table (get_byte_table
2789                                     (get_byte_table
2790                                      (get_byte_table
2791                                       (ct->table,
2792                                        (unsigned char)(ch >> 24)),
2793                                       (unsigned char) (ch >> 16)),
2794                                      (unsigned char)  (ch >> 8)),
2795                                     (unsigned char)    ch);
2796
2797                 if (UNBOUNDP (val))
2798                   val = ct->default_value;
2799                 rainj.ch = ch;
2800                 retval = (fn) (&rainj, val, arg);
2801               }
2802           }
2803         return retval;
2804       }
2805 #else
2806       {
2807         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2808                                     - MIN_LEADING_BYTE];
2809         if (!CHAR_TABLE_ENTRYP (val))
2810           {
2811             struct chartab_range rainj;
2812
2813             rainj.type = CHARTAB_RANGE_ROW;
2814             rainj.charset = range->charset;
2815             rainj.row = range->row;
2816             return (fn) (&rainj, val, arg);
2817           }
2818         else
2819           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2820                                        range->charset, range->row,
2821                                        fn, arg);
2822       }
2823 #endif /* not UTF2000 */
2824 #endif /* MULE */
2825
2826     case CHARTAB_RANGE_CHAR:
2827       {
2828         Emchar ch = range->ch;
2829         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2830
2831         if (!UNBOUNDP (val))
2832           {
2833             struct chartab_range rainj;
2834
2835             rainj.type = CHARTAB_RANGE_CHAR;
2836             rainj.ch = ch;
2837             return (fn) (&rainj, val, arg);
2838           }
2839         return 0;
2840       }
2841
2842     default:
2843       abort ();
2844     }
2845
2846   return 0;
2847 }
2848
2849 struct slow_map_char_table_arg
2850 {
2851   Lisp_Object function;
2852   Lisp_Object retval;
2853 };
2854
2855 static int
2856 slow_map_char_table_fun (struct chartab_range *range,
2857                          Lisp_Object val, void *arg)
2858 {
2859   Lisp_Object ranjarg = Qnil;
2860   struct slow_map_char_table_arg *closure =
2861     (struct slow_map_char_table_arg *) arg;
2862
2863   switch (range->type)
2864     {
2865     case CHARTAB_RANGE_ALL:
2866       ranjarg = Qt;
2867       break;
2868
2869 #ifdef UTF2000
2870     case CHARTAB_RANGE_DEFAULT:
2871       ranjarg = Qnil;
2872       break;
2873 #endif
2874
2875 #ifdef MULE
2876     case CHARTAB_RANGE_CHARSET:
2877       ranjarg = XCHARSET_NAME (range->charset);
2878       break;
2879
2880     case CHARTAB_RANGE_ROW:
2881       ranjarg = vector2 (XCHARSET_NAME (range->charset),
2882                          make_int (range->row));
2883       break;
2884 #endif /* MULE */
2885     case CHARTAB_RANGE_CHAR:
2886       ranjarg = make_char (range->ch);
2887       break;
2888     default:
2889       abort ();
2890     }
2891
2892   closure->retval = call2 (closure->function, ranjarg, val);
2893   return !NILP (closure->retval);
2894 }
2895
2896 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2897 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2898 each key and value in the table.
2899
2900 RANGE specifies a subrange to map over and is in the same format as
2901 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
2902 the entire table.
2903 */
2904        (function, char_table, range))
2905 {
2906   Lisp_Char_Table *ct;
2907   struct slow_map_char_table_arg slarg;
2908   struct gcpro gcpro1, gcpro2;
2909   struct chartab_range rainj;
2910
2911   CHECK_CHAR_TABLE (char_table);
2912   ct = XCHAR_TABLE (char_table);
2913   if (NILP (range))
2914     range = Qt;
2915   decode_char_table_range (range, &rainj);
2916   slarg.function = function;
2917   slarg.retval = Qnil;
2918   GCPRO2 (slarg.function, slarg.retval);
2919   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2920   UNGCPRO;
2921
2922   return slarg.retval;
2923 }
2924
2925 \f
2926 /************************************************************************/
2927 /*                         Character Attributes                         */
2928 /************************************************************************/
2929
2930 #ifdef UTF2000
2931
2932 Lisp_Object Vchar_attribute_hash_table;
2933
2934 /* We store the char-attributes in hash tables with the names as the
2935    key and the actual char-id-table object as the value.  Occasionally
2936    we need to use them in a list format.  These routines provide us
2937    with that. */
2938 struct char_attribute_list_closure
2939 {
2940   Lisp_Object *char_attribute_list;
2941 };
2942
2943 static int
2944 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
2945                                    void *char_attribute_list_closure)
2946 {
2947   /* This function can GC */
2948   struct char_attribute_list_closure *calcl
2949     = (struct char_attribute_list_closure*) char_attribute_list_closure;
2950   Lisp_Object *char_attribute_list = calcl->char_attribute_list;
2951
2952   *char_attribute_list = Fcons (key, *char_attribute_list);
2953   return 0;
2954 }
2955
2956 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
2957 Return the list of all existing character attributes except coded-charsets.
2958 */
2959        ())
2960 {
2961   Lisp_Object char_attribute_list = Qnil;
2962   struct gcpro gcpro1;
2963   struct char_attribute_list_closure char_attribute_list_closure;
2964
2965   GCPRO1 (char_attribute_list);
2966   char_attribute_list_closure.char_attribute_list = &char_attribute_list;
2967   elisp_maphash (add_char_attribute_to_list_mapper,
2968                  Vchar_attribute_hash_table,
2969                  &char_attribute_list_closure);
2970   UNGCPRO;
2971   return char_attribute_list;
2972 }
2973
2974 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
2975 Return char-id-table corresponding to ATTRIBUTE.
2976 */
2977        (attribute))
2978 {
2979   return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
2980 }
2981
2982
2983 /* We store the char-id-tables in hash tables with the attributes as
2984    the key and the actual char-id-table object as the value.  Each
2985    char-id-table stores values of an attribute corresponding with
2986    characters.  Occasionally we need to get attributes of a character
2987    in a association-list format.  These routines provide us with
2988    that. */
2989 struct char_attribute_alist_closure
2990 {
2991   Emchar char_id;
2992   Lisp_Object *char_attribute_alist;
2993 };
2994
2995 static int
2996 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
2997                                  void *char_attribute_alist_closure)
2998 {
2999   /* This function can GC */
3000   struct char_attribute_alist_closure *caacl =
3001     (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3002   Lisp_Object ret
3003     = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3004   if (!UNBOUNDP (ret))
3005     {
3006       Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3007       *char_attribute_alist
3008         = Fcons (Fcons (key, ret), *char_attribute_alist);
3009     }
3010   return 0;
3011 }
3012
3013 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3014 Return the alist of attributes of CHARACTER.
3015 */
3016        (character))
3017 {
3018   Lisp_Object alist = Qnil;
3019   int i;
3020
3021   CHECK_CHAR (character);
3022   {
3023     struct gcpro gcpro1;
3024     struct char_attribute_alist_closure char_attribute_alist_closure;
3025
3026     GCPRO1 (alist);
3027     char_attribute_alist_closure.char_id = XCHAR (character);
3028     char_attribute_alist_closure.char_attribute_alist = &alist;
3029     elisp_maphash (add_char_attribute_alist_mapper,
3030                    Vchar_attribute_hash_table,
3031                    &char_attribute_alist_closure);
3032     UNGCPRO;
3033   }
3034
3035   for (i = 0; i < countof (chlook->charset_by_leading_byte); i++)
3036     {
3037       Lisp_Object ccs = chlook->charset_by_leading_byte[i];
3038
3039       if (!NILP (ccs))
3040         {
3041           Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3042           Lisp_Object cpos;
3043
3044           if ( CHAR_TABLEP (encoding_table)
3045                && INTP (cpos
3046                         = get_char_id_table (XCHAR_TABLE(encoding_table),
3047                                              XCHAR (character))) )
3048             {
3049               alist = Fcons (Fcons (ccs, cpos), alist);
3050             }
3051         }
3052     }
3053   return alist;
3054 }
3055
3056 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3057 Return the value of CHARACTER's ATTRIBUTE.
3058 Return DEFAULT-VALUE if the value is not exist.
3059 */
3060        (character, attribute, default_value))
3061 {
3062   Lisp_Object ccs;
3063
3064   CHECK_CHAR (character);
3065   if (!NILP (ccs = Ffind_charset (attribute)))
3066     {
3067       Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3068
3069       if (CHAR_TABLEP (encoding_table))
3070         return get_char_id_table (XCHAR_TABLE(encoding_table),
3071                                   XCHAR (character));
3072     }
3073   else
3074     {
3075       Lisp_Object table = Fgethash (attribute,
3076                                     Vchar_attribute_hash_table,
3077                                     Qunbound);
3078       if (!UNBOUNDP (table))
3079         {
3080           Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3081                                                XCHAR (character));
3082           if (!UNBOUNDP (ret))
3083             return ret;
3084         }
3085     }
3086   return default_value;
3087 }
3088
3089 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3090 Store CHARACTER's ATTRIBUTE with VALUE.
3091 */
3092        (character, attribute, value))
3093 {
3094   Lisp_Object ccs;
3095
3096   ccs = Ffind_charset (attribute);
3097   if (!NILP (ccs))
3098     {
3099       CHECK_CHAR (character);
3100       return put_char_ccs_code_point (character, ccs, value);
3101     }
3102   else if (EQ (attribute, Q_decomposition))
3103     {
3104       Lisp_Object seq;
3105
3106       CHECK_CHAR (character);
3107       if (!CONSP (value))
3108         signal_simple_error ("Invalid value for ->decomposition",
3109                              value);
3110
3111       if (CONSP (Fcdr (value)))
3112         {
3113           Lisp_Object rest = value;
3114           Lisp_Object table = Vcharacter_composition_table;
3115           size_t len;
3116           int i = 0;
3117
3118           GET_EXTERNAL_LIST_LENGTH (rest, len);
3119           seq = make_vector (len, Qnil);
3120
3121           while (CONSP (rest))
3122             {
3123               Lisp_Object v = Fcar (rest);
3124               Lisp_Object ntable;
3125               Emchar c
3126                 = to_char_id (v, "Invalid value for ->decomposition", value);
3127
3128               if (c < 0)
3129                 XVECTOR_DATA(seq)[i++] = v;
3130               else
3131                 XVECTOR_DATA(seq)[i++] = make_char (c);
3132               rest = Fcdr (rest);
3133               if (!CONSP (rest))
3134                 {
3135                   put_char_id_table (XCHAR_TABLE(table),
3136                                      make_char (c), character);
3137                   break;
3138                 }
3139               else
3140                 {
3141                   ntable = get_char_id_table (XCHAR_TABLE(table), c);
3142                   if (!CHAR_TABLEP (ntable))
3143                     {
3144                       ntable = make_char_id_table (Qnil);
3145                       put_char_id_table (XCHAR_TABLE(table),
3146                                          make_char (c), ntable);
3147                     }
3148                   table = ntable;
3149                 }
3150             }
3151         }
3152       else
3153         {
3154           Lisp_Object v = Fcar (value);
3155
3156           if (INTP (v))
3157             {
3158               Emchar c = XINT (v);
3159               Lisp_Object ret
3160                 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3161                                      c);
3162
3163               if (NILP (Fmemq (v, ret)))
3164                 {
3165                   put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3166                                      make_char (c), Fcons (character, ret));
3167                 }
3168             }
3169           seq = make_vector (1, v);
3170         }
3171       value = seq;
3172     }
3173   else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3174     {
3175       Lisp_Object ret;
3176       Emchar c;
3177
3178       CHECK_CHAR (character);
3179       if (!INTP (value))
3180         signal_simple_error ("Invalid value for ->ucs", value);
3181
3182       c = XINT (value);
3183
3184       ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
3185       if (NILP (Fmemq (character, ret)))
3186         {
3187           put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3188                              make_char (c), Fcons (character, ret));
3189         }
3190 #if 0
3191       if (EQ (attribute, Q_ucs))
3192         attribute = Qto_ucs;
3193 #endif
3194     }
3195   {
3196     Lisp_Object table = Fgethash (attribute,
3197                                   Vchar_attribute_hash_table,
3198                                   Qnil);
3199
3200     if (NILP (table))
3201       {
3202         table = make_char_id_table (Qunbound);
3203         Fputhash (attribute, table, Vchar_attribute_hash_table);
3204       }
3205     put_char_id_table (XCHAR_TABLE(table), character, value);
3206     return value;
3207   }
3208 }
3209
3210 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3211 Remove CHARACTER's ATTRIBUTE.
3212 */
3213        (character, attribute))
3214 {
3215   Lisp_Object ccs;
3216
3217   CHECK_CHAR (character);
3218   ccs = Ffind_charset (attribute);
3219   if (!NILP (ccs))
3220     {
3221       return remove_char_ccs (character, ccs);
3222     }
3223   else
3224     {
3225       Lisp_Object table = Fgethash (attribute,
3226                                     Vchar_attribute_hash_table,
3227                                     Qunbound);
3228       if (!UNBOUNDP (table))
3229         {
3230           put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3231           return Qt;
3232         }
3233     }
3234   return Qnil;
3235 }
3236
3237 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3238 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3239 each key and value in the table.
3240
3241 RANGE specifies a subrange to map over and is in the same format as
3242 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
3243 the entire table.
3244 */
3245        (function, attribute, range))
3246 {
3247   Lisp_Object ccs;
3248   Lisp_Char_Table *ct;
3249   struct slow_map_char_table_arg slarg;
3250   struct gcpro gcpro1, gcpro2;
3251   struct chartab_range rainj;
3252
3253   if (!NILP (ccs = Ffind_charset (attribute)))
3254     {
3255       Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3256
3257       if (CHAR_TABLEP (encoding_table))
3258         ct = XCHAR_TABLE (encoding_table);
3259       else
3260         return Qnil;
3261     }
3262   else
3263     {
3264       Lisp_Object table = Fgethash (attribute,
3265                                     Vchar_attribute_hash_table,
3266                                     Qunbound);
3267       if (CHAR_TABLEP (table))
3268         ct = XCHAR_TABLE (table);
3269       else
3270         return Qnil;
3271     }
3272   if (NILP (range))
3273     range = Qt;
3274   decode_char_table_range (range, &rainj);
3275   slarg.function = function;
3276   slarg.retval = Qnil;
3277   GCPRO2 (slarg.function, slarg.retval);
3278   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3279   UNGCPRO;
3280
3281   return slarg.retval;
3282 }
3283
3284 EXFUN (Fmake_char, 3);
3285 EXFUN (Fdecode_char, 2);
3286
3287 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3288 Store character's ATTRIBUTES.
3289 */
3290        (attributes))
3291 {
3292   Lisp_Object rest = attributes;
3293   Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3294   Lisp_Object character;
3295
3296   if (NILP (code))
3297     {
3298       while (CONSP (rest))
3299         {
3300           Lisp_Object cell = Fcar (rest);
3301           Lisp_Object ccs;
3302
3303           if (!LISTP (cell))
3304             signal_simple_error ("Invalid argument", attributes);
3305           if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3306               && ((XCHARSET_FINAL (ccs) != 0) ||
3307                   (XCHARSET_UCS_MAX (ccs) > 0)) )
3308             {
3309               cell = Fcdr (cell);
3310               if (CONSP (cell))
3311                 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3312               else
3313                 character = Fdecode_char (ccs, cell);
3314               if (!NILP (character))
3315                 goto setup_attributes;
3316             }
3317           rest = Fcdr (rest);
3318         }
3319       if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3320            (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3321
3322         {
3323           if (!INTP (code))
3324             signal_simple_error ("Invalid argument", attributes);
3325           else
3326             character = make_char (XINT (code) + 0x100000);
3327           goto setup_attributes;
3328         }
3329       return Qnil;
3330     }
3331   else if (!INTP (code))
3332     signal_simple_error ("Invalid argument", attributes);
3333   else
3334     character = make_char (XINT (code));
3335
3336  setup_attributes:
3337   rest = attributes;
3338   while (CONSP (rest))
3339     {
3340       Lisp_Object cell = Fcar (rest);
3341
3342       if (!LISTP (cell))
3343         signal_simple_error ("Invalid argument", attributes);
3344
3345       Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3346       rest = Fcdr (rest);
3347     }
3348   return character;
3349 }
3350
3351 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3352 Retrieve the character of the given ATTRIBUTES.
3353 */
3354        (attributes))
3355 {
3356   Lisp_Object rest = attributes;
3357   Lisp_Object code;
3358
3359   while (CONSP (rest))
3360     {
3361       Lisp_Object cell = Fcar (rest);
3362       Lisp_Object ccs;
3363
3364       if (!LISTP (cell))
3365         signal_simple_error ("Invalid argument", attributes);
3366       if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3367         {
3368           cell = Fcdr (cell);
3369           if (CONSP (cell))
3370             return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3371           else
3372             return Fdecode_char (ccs, cell);
3373         }
3374       rest = Fcdr (rest);
3375     }
3376   if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3377        (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3378     {
3379       if (!INTP (code))
3380         signal_simple_error ("Invalid argument", attributes);
3381       else
3382         return make_char (XINT (code) + 0x100000);
3383     }
3384   return Qnil;
3385 }
3386
3387 #endif
3388
3389 \f
3390 /************************************************************************/
3391 /*                         Char table read syntax                       */
3392 /************************************************************************/
3393
3394 static int
3395 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3396                        Error_behavior errb)
3397 {
3398   /* #### should deal with ERRB */
3399   symbol_to_char_table_type (value);
3400   return 1;
3401 }
3402
3403 static int
3404 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3405                        Error_behavior errb)
3406 {
3407   Lisp_Object rest;
3408
3409   /* #### should deal with ERRB */
3410   EXTERNAL_LIST_LOOP (rest, value)
3411     {
3412       Lisp_Object range = XCAR (rest);
3413       struct chartab_range dummy;
3414
3415       rest = XCDR (rest);
3416       if (!CONSP (rest))
3417         signal_simple_error ("Invalid list format", value);
3418       if (CONSP (range))
3419         {
3420           if (!CONSP (XCDR (range))
3421               || !NILP (XCDR (XCDR (range))))
3422             signal_simple_error ("Invalid range format", range);
3423           decode_char_table_range (XCAR (range), &dummy);
3424           decode_char_table_range (XCAR (XCDR (range)), &dummy);
3425         }
3426       else
3427         decode_char_table_range (range, &dummy);
3428     }
3429
3430   return 1;
3431 }
3432
3433 static Lisp_Object
3434 chartab_instantiate (Lisp_Object data)
3435 {
3436   Lisp_Object chartab;
3437   Lisp_Object type = Qgeneric;
3438   Lisp_Object dataval = Qnil;
3439
3440   while (!NILP (data))
3441     {
3442       Lisp_Object keyw = Fcar (data);
3443       Lisp_Object valw;
3444
3445       data = Fcdr (data);
3446       valw = Fcar (data);
3447       data = Fcdr (data);
3448       if (EQ (keyw, Qtype))
3449         type = valw;
3450       else if (EQ (keyw, Qdata))
3451         dataval = valw;
3452     }
3453
3454   chartab = Fmake_char_table (type);
3455
3456   data = dataval;
3457   while (!NILP (data))
3458     {
3459       Lisp_Object range = Fcar (data);
3460       Lisp_Object val = Fcar (Fcdr (data));
3461
3462       data = Fcdr (Fcdr (data));
3463       if (CONSP (range))
3464         {
3465           if (CHAR_OR_CHAR_INTP (XCAR (range)))
3466             {
3467               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3468               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3469               Emchar i;
3470
3471               for (i = first; i <= last; i++)
3472                  Fput_char_table (make_char (i), val, chartab);
3473             }
3474           else
3475             abort ();
3476         }
3477       else
3478         Fput_char_table (range, val, chartab);
3479     }
3480
3481   return chartab;
3482 }
3483
3484 #ifdef MULE
3485
3486 \f
3487 /************************************************************************/
3488 /*                     Category Tables, specifically                    */
3489 /************************************************************************/
3490
3491 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3492 Return t if OBJECT is a category table.
3493 A category table is a type of char table used for keeping track of
3494 categories.  Categories are used for classifying characters for use
3495 in regexps -- you can refer to a category rather than having to use
3496 a complicated [] expression (and category lookups are significantly
3497 faster).
3498
3499 There are 95 different categories available, one for each printable
3500 character (including space) in the ASCII charset.  Each category
3501 is designated by one such character, called a "category designator".
3502 They are specified in a regexp using the syntax "\\cX", where X is
3503 a category designator.
3504
3505 A category table specifies, for each character, the categories that
3506 the character is in.  Note that a character can be in more than one
3507 category.  More specifically, a category table maps from a character
3508 to either the value nil (meaning the character is in no categories)
3509 or a 95-element bit vector, specifying for each of the 95 categories
3510 whether the character is in that category.
3511
3512 Special Lisp functions are provided that abstract this, so you do not
3513 have to directly manipulate bit vectors.
3514 */
3515        (object))
3516 {
3517   return (CHAR_TABLEP (object) &&
3518           XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3519     Qt : Qnil;
3520 }
3521
3522 static Lisp_Object
3523 check_category_table (Lisp_Object object, Lisp_Object default_)
3524 {
3525   if (NILP (object))
3526     object = default_;
3527   while (NILP (Fcategory_table_p (object)))
3528     object = wrong_type_argument (Qcategory_table_p, object);
3529   return object;
3530 }
3531
3532 int
3533 check_category_char (Emchar ch, Lisp_Object table,
3534                      unsigned int designator, unsigned int not)
3535 {
3536   REGISTER Lisp_Object temp;
3537   Lisp_Char_Table *ctbl;
3538 #ifdef ERROR_CHECK_TYPECHECK
3539   if (NILP (Fcategory_table_p (table)))
3540     signal_simple_error ("Expected category table", table);
3541 #endif
3542   ctbl = XCHAR_TABLE (table);
3543   temp = get_char_table (ch, ctbl);
3544   if (NILP (temp))
3545     return not;
3546
3547   designator -= ' ';
3548   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
3549 }
3550
3551 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3552 Return t if category of the character at POSITION includes DESIGNATOR.
3553 Optional third arg BUFFER specifies which buffer to use, and defaults
3554 to the current buffer.
3555 Optional fourth arg CATEGORY-TABLE specifies the category table to
3556 use, and defaults to BUFFER's category table.
3557 */
3558        (position, designator, buffer, category_table))
3559 {
3560   Lisp_Object ctbl;
3561   Emchar ch;
3562   unsigned int des;
3563   struct buffer *buf = decode_buffer (buffer, 0);
3564
3565   CHECK_INT (position);
3566   CHECK_CATEGORY_DESIGNATOR (designator);
3567   des = XCHAR (designator);
3568   ctbl = check_category_table (category_table, Vstandard_category_table);
3569   ch = BUF_FETCH_CHAR (buf, XINT (position));
3570   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3571 }
3572
3573 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3574 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3575 Optional third arg CATEGORY-TABLE specifies the category table to use,
3576 and defaults to the standard category table.
3577 */
3578        (character, designator, category_table))
3579 {
3580   Lisp_Object ctbl;
3581   Emchar ch;
3582   unsigned int des;
3583
3584   CHECK_CATEGORY_DESIGNATOR (designator);
3585   des = XCHAR (designator);
3586   CHECK_CHAR (character);
3587   ch = XCHAR (character);
3588   ctbl = check_category_table (category_table, Vstandard_category_table);
3589   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3590 }
3591
3592 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3593 Return BUFFER's current category table.
3594 BUFFER defaults to the current buffer.
3595 */
3596        (buffer))
3597 {
3598   return decode_buffer (buffer, 0)->category_table;
3599 }
3600
3601 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3602 Return the standard category table.
3603 This is the one used for new buffers.
3604 */
3605        ())
3606 {
3607   return Vstandard_category_table;
3608 }
3609
3610 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3611 Return a new category table which is a copy of CATEGORY-TABLE.
3612 CATEGORY-TABLE defaults to the standard category table.
3613 */
3614        (category_table))
3615 {
3616   if (NILP (Vstandard_category_table))
3617     return Fmake_char_table (Qcategory);
3618
3619   category_table =
3620     check_category_table (category_table, Vstandard_category_table);
3621   return Fcopy_char_table (category_table);
3622 }
3623
3624 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3625 Select CATEGORY-TABLE as the new category table for BUFFER.
3626 BUFFER defaults to the current buffer if omitted.
3627 */
3628        (category_table, buffer))
3629 {
3630   struct buffer *buf = decode_buffer (buffer, 0);
3631   category_table = check_category_table (category_table, Qnil);
3632   buf->category_table = category_table;
3633   /* Indicate that this buffer now has a specified category table.  */
3634   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3635   return category_table;
3636 }
3637
3638 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3639 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3640 */
3641        (object))
3642 {
3643   return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3644 }
3645
3646 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3647 Return t if OBJECT is a category table value.
3648 Valid values are nil or a bit vector of size 95.
3649 */
3650        (object))
3651 {
3652   return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3653 }
3654
3655
3656 #define CATEGORYP(x) \
3657   (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3658
3659 #define CATEGORY_SET(c)                                         \
3660   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3661
3662 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3663    The faster version of `!NILP (Faref (category_set, category))'.  */
3664 #define CATEGORY_MEMBER(category, category_set)                 \
3665   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3666
3667 /* Return 1 if there is a word boundary between two word-constituent
3668    characters C1 and C2 if they appear in this order, else return 0.
3669    Use the macro WORD_BOUNDARY_P instead of calling this function
3670    directly.  */
3671
3672 int word_boundary_p (Emchar c1, Emchar c2);
3673 int
3674 word_boundary_p (Emchar c1, Emchar c2)
3675 {
3676   Lisp_Object category_set1, category_set2;
3677   Lisp_Object tail;
3678   int default_result;
3679
3680 #if 0
3681   if (COMPOSITE_CHAR_P (c1))
3682     c1 = cmpchar_component (c1, 0, 1);
3683   if (COMPOSITE_CHAR_P (c2))
3684     c2 = cmpchar_component (c2, 0, 1);
3685 #endif
3686
3687   if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3688     {
3689       tail = Vword_separating_categories;
3690       default_result = 0;
3691     }
3692   else
3693     {
3694       tail = Vword_combining_categories;
3695       default_result = 1;
3696     }
3697
3698   category_set1 = CATEGORY_SET (c1);
3699   if (NILP (category_set1))
3700     return default_result;
3701   category_set2 = CATEGORY_SET (c2);
3702   if (NILP (category_set2))
3703     return default_result;
3704
3705   for (; CONSP (tail); tail = XCONS (tail)->cdr)
3706     {
3707       Lisp_Object elt = XCONS(tail)->car;
3708
3709       if (CONSP (elt)
3710           && CATEGORYP (XCONS (elt)->car)
3711           && CATEGORYP (XCONS (elt)->cdr)
3712           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3713           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3714         return !default_result;
3715     }
3716   return default_result;
3717 }
3718 #endif /* MULE */
3719
3720 \f
3721 void
3722 syms_of_chartab (void)
3723 {
3724 #ifdef UTF2000
3725   INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3726   INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3727   INIT_LRECORD_IMPLEMENTATION (byte_table);
3728
3729   defsymbol (&Qto_ucs,                  "=>ucs");
3730   defsymbol (&Q_ucs,                    "->ucs");
3731   defsymbol (&Q_decomposition,          "->decomposition");
3732   defsymbol (&Qcompat,                  "compat");
3733   defsymbol (&Qisolated,                "isolated");
3734   defsymbol (&Qinitial,                 "initial");
3735   defsymbol (&Qmedial,                  "medial");
3736   defsymbol (&Qfinal,                   "final");
3737   defsymbol (&Qvertical,                "vertical");
3738   defsymbol (&QnoBreak,                 "noBreak");
3739   defsymbol (&Qfraction,                "fraction");
3740   defsymbol (&Qsuper,                   "super");
3741   defsymbol (&Qsub,                     "sub");
3742   defsymbol (&Qcircle,                  "circle");
3743   defsymbol (&Qsquare,                  "square");
3744   defsymbol (&Qwide,                    "wide");
3745   defsymbol (&Qnarrow,                  "narrow");
3746   defsymbol (&Qsmall,                   "small");
3747   defsymbol (&Qfont,                    "font");
3748
3749   DEFSUBR (Fchar_attribute_list);
3750   DEFSUBR (Ffind_char_attribute_table);
3751   DEFSUBR (Fchar_attribute_alist);
3752   DEFSUBR (Fget_char_attribute);
3753   DEFSUBR (Fput_char_attribute);
3754   DEFSUBR (Fremove_char_attribute);
3755   DEFSUBR (Fmap_char_attribute);
3756   DEFSUBR (Fdefine_char);
3757   DEFSUBR (Ffind_char);
3758   DEFSUBR (Fchar_variants);
3759
3760   DEFSUBR (Fget_composite_char);
3761 #endif
3762
3763   INIT_LRECORD_IMPLEMENTATION (char_table);
3764
3765 #ifdef MULE
3766 #ifndef UTF2000
3767   INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3768 #endif
3769
3770   defsymbol (&Qcategory_table_p, "category-table-p");
3771   defsymbol (&Qcategory_designator_p, "category-designator-p");
3772   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3773 #endif /* MULE */
3774
3775   defsymbol (&Qchar_table, "char-table");
3776   defsymbol (&Qchar_tablep, "char-table-p");
3777
3778   DEFSUBR (Fchar_table_p);
3779   DEFSUBR (Fchar_table_type_list);
3780   DEFSUBR (Fvalid_char_table_type_p);
3781   DEFSUBR (Fchar_table_type);
3782   DEFSUBR (Freset_char_table);
3783   DEFSUBR (Fmake_char_table);
3784   DEFSUBR (Fcopy_char_table);
3785   DEFSUBR (Fget_char_table);
3786   DEFSUBR (Fget_range_char_table);
3787   DEFSUBR (Fvalid_char_table_value_p);
3788   DEFSUBR (Fcheck_valid_char_table_value);
3789   DEFSUBR (Fput_char_table);
3790   DEFSUBR (Fmap_char_table);
3791
3792 #ifdef MULE
3793   DEFSUBR (Fcategory_table_p);
3794   DEFSUBR (Fcategory_table);
3795   DEFSUBR (Fstandard_category_table);
3796   DEFSUBR (Fcopy_category_table);
3797   DEFSUBR (Fset_category_table);
3798   DEFSUBR (Fcheck_category_at);
3799   DEFSUBR (Fchar_in_category_p);
3800   DEFSUBR (Fcategory_designator_p);
3801   DEFSUBR (Fcategory_table_value_p);
3802 #endif /* MULE */
3803
3804 }
3805
3806 void
3807 vars_of_chartab (void)
3808 {
3809 #ifdef UTF2000
3810   Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)");
3811   DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3812 Version number of XEmacs UTF-2000.
3813 */ );
3814
3815   staticpro (&Vcharacter_composition_table);
3816   Vcharacter_composition_table = make_char_id_table (Qnil);
3817
3818   staticpro (&Vcharacter_variant_table);
3819   Vcharacter_variant_table = make_char_id_table (Qnil);
3820 #endif
3821   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
3822   Vall_syntax_tables = Qnil;
3823   dump_add_weak_object_chain (&Vall_syntax_tables);
3824 }
3825
3826 void
3827 structure_type_create_chartab (void)
3828 {
3829   struct structure_type *st;
3830
3831   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3832
3833   define_structure_type_keyword (st, Qtype, chartab_type_validate);
3834   define_structure_type_keyword (st, Qdata, chartab_data_validate);
3835 }
3836
3837 void
3838 complex_vars_of_chartab (void)
3839 {
3840 #ifdef UTF2000
3841   staticpro (&Vchar_attribute_hash_table);
3842   Vchar_attribute_hash_table
3843     = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3844 #endif /* UTF2000 */
3845 #ifdef MULE
3846   /* Set this now, so first buffer creation can refer to it. */
3847   /* Make it nil before calling copy-category-table
3848      so that copy-category-table will know not to try to copy from garbage */
3849   Vstandard_category_table = Qnil;
3850   Vstandard_category_table = Fcopy_category_table (Qnil);
3851   staticpro (&Vstandard_category_table);
3852
3853   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3854 List of pair (cons) of categories to determine word boundary.
3855
3856 Emacs treats a sequence of word constituent characters as a single
3857 word (i.e. finds no word boundary between them) iff they belongs to
3858 the same charset.  But, exceptions are allowed in the following cases.
3859
3860 \(1) The case that characters are in different charsets is controlled
3861 by the variable `word-combining-categories'.
3862
3863 Emacs finds no word boundary between characters of different charsets
3864 if they have categories matching some element of this list.
3865
3866 More precisely, if an element of this list is a cons of category CAT1
3867 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3868 C2 which has CAT2, there's no word boundary between C1 and C2.
3869
3870 For instance, to tell that ASCII characters and Latin-1 characters can
3871 form a single word, the element `(?l . ?l)' should be in this list
3872 because both characters have the category `l' (Latin characters).
3873
3874 \(2) The case that character are in the same charset is controlled by
3875 the variable `word-separating-categories'.
3876
3877 Emacs find a word boundary between characters of the same charset
3878 if they have categories matching some element of this list.
3879
3880 More precisely, if an element of this list is a cons of category CAT1
3881 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3882 C2 which has CAT2, there's a word boundary between C1 and C2.
3883
3884 For instance, to tell that there's a word boundary between Japanese
3885 Hiragana and Japanese Kanji (both are in the same charset), the
3886 element `(?H . ?C) should be in this list.
3887 */ );
3888
3889   Vword_combining_categories = Qnil;
3890
3891   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3892 List of pair (cons) of categories to determine word boundary.
3893 See the documentation of the variable `word-combining-categories'.
3894 */ );
3895
3896   Vword_separating_categories = Qnil;
3897 #endif /* MULE */
3898 }