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