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