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

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