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

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