XEmacs 21.2.41 "Polyhymnia".
[chise/xemacs-chise.git.1] / 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
8 This file is part of XEmacs.
9
10 XEmacs is free software; you can redistribute it and/or modify it
11 under the terms of the GNU General Public License as published by the
12 Free Software Foundation; either version 2, or (at your option) any
13 later version.
14
15 XEmacs is distributed in the hope that it will be useful, but WITHOUT
16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
18 for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with XEmacs; see the file COPYING.  If not, write to
22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 Boston, MA 02111-1307, USA.  */
24
25 /* Synched up with: Mule 2.3.  Not synched with FSF.
26
27    This file was written independently of the FSF implementation,
28    and is not compatible. */
29
30 /* Authorship:
31
32    Ben Wing: wrote, for 19.13 (Mule).  Some category table stuff
33              loosely based on the original Mule.
34    Jareth Hein: fixed a couple of bugs in the implementation, and
35              added regex support for categories with check_category_at
36  */
37
38 #include <config.h>
39 #include "lisp.h"
40
41 #include "buffer.h"
42 #include "chartab.h"
43 #include "syntax.h"
44
45 Lisp_Object Qchar_tablep, Qchar_table;
46
47 Lisp_Object Vall_syntax_tables;
48
49 #ifdef MULE
50 Lisp_Object Qcategory_table_p;
51 Lisp_Object Qcategory_designator_p;
52 Lisp_Object Qcategory_table_value_p;
53
54 Lisp_Object Vstandard_category_table;
55
56 /* Variables to determine word boundary.  */
57 Lisp_Object Vword_combining_categories, Vword_separating_categories;
58 #endif /* MULE */
59
60 \f
61 /* A char table maps from ranges of characters to values.
62
63    Implementing a general data structure that maps from arbitrary
64    ranges of numbers to values is tricky to do efficiently.  As it
65    happens, it should suffice (and is usually more convenient, anyway)
66    when dealing with characters to restrict the sorts of ranges that
67    can be assigned values, as follows:
68
69    1) All characters.
70    2) All characters in a charset.
71    3) All characters in a particular row of a charset, where a "row"
72       means all characters with the same first byte.
73    4) A particular character in a charset.
74
75    We use char tables to generalize the 256-element vectors now
76    littering the Emacs code.
77
78    Possible uses (all should be converted at some point):
79
80    1) category tables
81    2) syntax tables
82    3) display tables
83    4) case tables
84    5) keyboard-translate-table?
85
86    We provide an
87    abstract type to generalize the Emacs vectors and Mule
88    vectors-of-vectors goo.
89    */
90
91 /************************************************************************/
92 /*                         Char Table object                            */
93 /************************************************************************/
94
95 #ifdef MULE
96
97 static Lisp_Object
98 mark_char_table_entry (Lisp_Object obj)
99 {
100   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
101   int i;
102
103   for (i = 0; i < 96; i++)
104     {
105       mark_object (cte->level2[i]);
106     }
107   return Qnil;
108 }
109
110 static int
111 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
112 {
113   Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
114   Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
115   int i;
116
117   for (i = 0; i < 96; i++)
118     if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
119       return 0;
120
121   return 1;
122 }
123
124 static unsigned long
125 char_table_entry_hash (Lisp_Object obj, int depth)
126 {
127   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
128
129   return internal_array_hash (cte->level2, 96, depth);
130 }
131
132 static const struct lrecord_description char_table_entry_description[] = {
133   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
134   { XD_END }
135 };
136
137 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
138                                mark_char_table_entry, internal_object_printer,
139                                0, char_table_entry_equal,
140                                char_table_entry_hash,
141                                char_table_entry_description,
142                                Lisp_Char_Table_Entry);
143 #endif /* MULE */
144
145 static Lisp_Object
146 mark_char_table (Lisp_Object obj)
147 {
148   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
149   int i;
150
151   for (i = 0; i < NUM_ASCII_CHARS; i++)
152     mark_object (ct->ascii[i]);
153 #ifdef MULE
154   for (i = 0; i < NUM_LEADING_BYTES; i++)
155     mark_object (ct->level1[i]);
156 #endif
157   return ct->mirror_table;
158 }
159
160 /* WARNING: All functions of this nature need to be written extremely
161    carefully to avoid crashes during GC.  Cf. prune_specifiers()
162    and prune_weak_hash_tables(). */
163
164 void
165 prune_syntax_tables (void)
166 {
167   Lisp_Object rest, prev = Qnil;
168
169   for (rest = Vall_syntax_tables;
170        !NILP (rest);
171        rest = XCHAR_TABLE (rest)->next_table)
172     {
173       if (! marked_p (rest))
174         {
175           /* This table is garbage.  Remove it from the list. */
176           if (NILP (prev))
177             Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
178           else
179             XCHAR_TABLE (prev)->next_table =
180               XCHAR_TABLE (rest)->next_table;
181         }
182     }
183 }
184
185 static Lisp_Object
186 char_table_type_to_symbol (enum char_table_type type)
187 {
188   switch (type)
189   {
190   default: abort();
191   case CHAR_TABLE_TYPE_GENERIC:  return Qgeneric;
192   case CHAR_TABLE_TYPE_SYNTAX:   return Qsyntax;
193   case CHAR_TABLE_TYPE_DISPLAY:  return Qdisplay;
194   case CHAR_TABLE_TYPE_CHAR:     return Qchar;
195 #ifdef MULE
196   case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
197 #endif
198   }
199 }
200
201 static enum char_table_type
202 symbol_to_char_table_type (Lisp_Object symbol)
203 {
204   CHECK_SYMBOL (symbol);
205
206   if (EQ (symbol, Qgeneric))  return CHAR_TABLE_TYPE_GENERIC;
207   if (EQ (symbol, Qsyntax))   return CHAR_TABLE_TYPE_SYNTAX;
208   if (EQ (symbol, Qdisplay))  return CHAR_TABLE_TYPE_DISPLAY;
209   if (EQ (symbol, Qchar))     return CHAR_TABLE_TYPE_CHAR;
210 #ifdef MULE
211   if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
212 #endif
213
214   signal_simple_error ("Unrecognized char table type", symbol);
215   return CHAR_TABLE_TYPE_GENERIC; /* not reached */
216 }
217
218 static void
219 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
220                      Lisp_Object printcharfun)
221 {
222   if (first != last)
223     {
224       write_c_string (" (", printcharfun);
225       print_internal (make_char (first), printcharfun, 0);
226       write_c_string (" ", printcharfun);
227       print_internal (make_char (last), printcharfun, 0);
228       write_c_string (") ", printcharfun);
229     }
230   else
231     {
232       write_c_string (" ", printcharfun);
233       print_internal (make_char (first), printcharfun, 0);
234       write_c_string (" ", printcharfun);
235     }
236   print_internal (val, printcharfun, 1);
237 }
238
239 #ifdef MULE
240
241 static void
242 print_chartab_charset_row (Lisp_Object charset,
243                            int row,
244                            Lisp_Char_Table_Entry *cte,
245                            Lisp_Object printcharfun)
246 {
247   int i;
248   Lisp_Object cat = Qunbound;
249   int first = -1;
250
251   for (i = 32; i < 128; i++)
252     {
253       Lisp_Object pam = cte->level2[i - 32];
254
255       if (first == -1)
256         {
257           first = i;
258           cat = pam;
259           continue;
260         }
261
262       if (!EQ (cat, pam))
263         {
264           if (row == -1)
265             print_chartab_range (MAKE_CHAR (charset, first, 0),
266                                  MAKE_CHAR (charset, i - 1, 0),
267                                  cat, printcharfun);
268           else
269             print_chartab_range (MAKE_CHAR (charset, row, first),
270                                  MAKE_CHAR (charset, row, i - 1),
271                                  cat, printcharfun);
272           first = -1;
273           i--;
274         }
275     }
276
277   if (first != -1)
278     {
279       if (row == -1)
280         print_chartab_range (MAKE_CHAR (charset, first, 0),
281                              MAKE_CHAR (charset, i - 1, 0),
282                              cat, printcharfun);
283       else
284         print_chartab_range (MAKE_CHAR (charset, row, first),
285                              MAKE_CHAR (charset, row, i - 1),
286                              cat, printcharfun);
287     }
288 }
289
290 static void
291 print_chartab_two_byte_charset (Lisp_Object charset,
292                                 Lisp_Char_Table_Entry *cte,
293                                 Lisp_Object printcharfun)
294 {
295   int i;
296
297   for (i = 32; i < 128; i++)
298     {
299       Lisp_Object jen = cte->level2[i - 32];
300
301       if (!CHAR_TABLE_ENTRYP (jen))
302         {
303           char buf[100];
304
305           write_c_string (" [", printcharfun);
306           print_internal (XCHARSET_NAME (charset), printcharfun, 0);
307           sprintf (buf, " %d] ", i);
308           write_c_string (buf, printcharfun);
309           print_internal (jen, printcharfun, 0);
310         }
311       else
312         print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
313                                    printcharfun);
314     }
315 }
316
317 #endif /* MULE */
318
319 static void
320 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
321 {
322   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
323   char buf[200];
324
325   sprintf (buf, "#s(char-table type %s data (",
326            string_data (symbol_name (XSYMBOL
327                                      (char_table_type_to_symbol (ct->type)))));
328   write_c_string (buf, printcharfun);
329
330   /* Now write out the ASCII/Control-1 stuff. */
331   {
332     int i;
333     int first = -1;
334     Lisp_Object val = Qunbound;
335
336     for (i = 0; i < NUM_ASCII_CHARS; i++)
337       {
338         if (first == -1)
339           {
340             first = i;
341             val = ct->ascii[i];
342             continue;
343           }
344
345         if (!EQ (ct->ascii[i], val))
346           {
347             print_chartab_range (first, i - 1, val, printcharfun);
348             first = -1;
349             i--;
350           }
351       }
352
353     if (first != -1)
354       print_chartab_range (first, i - 1, val, printcharfun);
355   }
356
357 #ifdef MULE
358   {
359     int i;
360
361     for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
362          i++)
363       {
364         Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
365         Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
366
367         if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
368             || i == LEADING_BYTE_CONTROL_1)
369           continue;
370         if (!CHAR_TABLE_ENTRYP (ann))
371           {
372             write_c_string (" ", printcharfun);
373             print_internal (XCHARSET_NAME (charset),
374                             printcharfun, 0);
375             write_c_string (" ", printcharfun);
376             print_internal (ann, printcharfun, 0);
377           }
378         else
379           {
380             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
381             if (XCHARSET_DIMENSION (charset) == 1)
382               print_chartab_charset_row (charset, -1, cte, printcharfun);
383             else
384               print_chartab_two_byte_charset (charset, cte, printcharfun);
385           }
386       }
387   }
388 #endif /* MULE */
389
390   write_c_string ("))", printcharfun);
391 }
392
393 static int
394 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
395 {
396   Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
397   Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
398   int i;
399
400   if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
401     return 0;
402
403   for (i = 0; i < NUM_ASCII_CHARS; i++)
404     if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
405       return 0;
406
407 #ifdef MULE
408   for (i = 0; i < NUM_LEADING_BYTES; i++)
409     if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
410       return 0;
411 #endif /* MULE */
412
413   return 1;
414 }
415
416 static unsigned long
417 char_table_hash (Lisp_Object obj, int depth)
418 {
419   Lisp_Char_Table *ct = XCHAR_TABLE (obj);
420   unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
421                                                depth);
422 #ifdef MULE
423   hashval = HASH2 (hashval,
424                    internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
425 #endif /* MULE */
426   return hashval;
427 }
428
429 static const struct lrecord_description char_table_description[] = {
430   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
431 #ifdef MULE
432   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
433 #endif
434   { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
435   { XD_LO_LINK,     offsetof (Lisp_Char_Table, next_table) },
436   { XD_END }
437 };
438
439 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
440                                mark_char_table, print_char_table, 0,
441                                char_table_equal, char_table_hash,
442                                char_table_description,
443                                Lisp_Char_Table);
444
445 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
446 Return non-nil if OBJECT is a char table.
447
448 A char table is a table that maps characters (or ranges of characters)
449 to values.  Char tables are specialized for characters, only allowing
450 particular sorts of ranges to be assigned values.  Although this
451 loses in generality, it makes for extremely fast (constant-time)
452 lookups, and thus is feasible for applications that do an extremely
453 large number of lookups (e.g. scanning a buffer for a character in
454 a particular syntax, where a lookup in the syntax table must occur
455 once per character).
456
457 When Mule support exists, the types of ranges that can be assigned
458 values are
459
460 -- all characters
461 -- an entire charset
462 -- a single row in a two-octet charset
463 -- a single character
464
465 When Mule support is not present, the types of ranges that can be
466 assigned values are
467
468 -- all characters
469 -- a single character
470
471 To create a char table, use `make-char-table'.
472 To modify a char table, use `put-char-table' or `remove-char-table'.
473 To retrieve the value for a particular character, use `get-char-table'.
474 See also `map-char-table', `clear-char-table', `copy-char-table',
475 `valid-char-table-type-p', `char-table-type-list',
476 `valid-char-table-value-p', and `check-char-table-value'.
477 */
478        (object))
479 {
480   return CHAR_TABLEP (object) ? Qt : Qnil;
481 }
482
483 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
484 Return a list of the recognized char table types.
485 See `valid-char-table-type-p'.
486 */
487        ())
488 {
489 #ifdef MULE
490   return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
491 #else
492   return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
493 #endif
494 }
495
496 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
497 Return t if TYPE if a recognized char table type.
498
499 Each char table type is used for a different purpose and allows different
500 sorts of values.  The different char table types are
501
502 `category'
503         Used for category tables, which specify the regexp categories
504         that a character is in.  The valid values are nil or a
505         bit vector of 95 elements.  Higher-level Lisp functions are
506         provided for working with category tables.  Currently categories
507         and category tables only exist when Mule support is present.
508 `char'
509         A generalized char table, for mapping from one character to
510         another.  Used for case tables, syntax matching tables,
511         `keyboard-translate-table', etc.  The valid values are characters.
512 `generic'
513         An even more generalized char table, for mapping from a
514         character to anything.
515 `display'
516         Used for display tables, which specify how a particular character
517         is to appear when displayed.  #### Not yet implemented.
518 `syntax'
519         Used for syntax tables, which specify the syntax of a particular
520         character.  Higher-level Lisp functions are provided for
521         working with syntax tables.  The valid values are integers.
522
523 */
524        (type))
525 {
526   return (EQ (type, Qchar)     ||
527 #ifdef MULE
528           EQ (type, Qcategory) ||
529 #endif
530           EQ (type, Qdisplay)  ||
531           EQ (type, Qgeneric)  ||
532           EQ (type, Qsyntax)) ? Qt : Qnil;
533 }
534
535 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
536 Return the type of CHAR-TABLE.
537 See `valid-char-table-type-p'.
538 */
539        (char_table))
540 {
541   CHECK_CHAR_TABLE (char_table);
542   return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
543 }
544
545 void
546 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
547 {
548   int i;
549
550   for (i = 0; i < NUM_ASCII_CHARS; i++)
551     ct->ascii[i] = value;
552 #ifdef MULE
553   for (i = 0; i < NUM_LEADING_BYTES; i++)
554     ct->level1[i] = value;
555 #endif /* MULE */
556
557   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
558     update_syntax_table (ct);
559 }
560
561 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
562 Reset CHAR-TABLE to its default state.
563 */
564        (char_table))
565 {
566   Lisp_Char_Table *ct;
567
568   CHECK_CHAR_TABLE (char_table);
569   ct = XCHAR_TABLE (char_table);
570
571   switch (ct->type)
572     {
573     case CHAR_TABLE_TYPE_CHAR:
574       fill_char_table (ct, make_char (0));
575       break;
576     case CHAR_TABLE_TYPE_DISPLAY:
577     case CHAR_TABLE_TYPE_GENERIC:
578 #ifdef MULE
579     case CHAR_TABLE_TYPE_CATEGORY:
580 #endif /* MULE */
581       fill_char_table (ct, Qnil);
582       break;
583
584     case CHAR_TABLE_TYPE_SYNTAX:
585       fill_char_table (ct, make_int (Sinherit));
586       break;
587
588     default:
589       abort ();
590     }
591
592   return Qnil;
593 }
594
595 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
596 Return a new, empty char table of type TYPE.
597 Currently recognized types are 'char, 'category, 'display, 'generic,
598 and 'syntax.  See `valid-char-table-type-p'.
599 */
600        (type))
601 {
602   Lisp_Char_Table *ct;
603   Lisp_Object obj;
604   enum char_table_type ty = symbol_to_char_table_type (type);
605
606   ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
607   ct->type = ty;
608   if (ty == CHAR_TABLE_TYPE_SYNTAX)
609     {
610       ct->mirror_table = Fmake_char_table (Qgeneric);
611       fill_char_table (XCHAR_TABLE (ct->mirror_table),
612                        make_int (Spunct));
613     }
614   else
615     ct->mirror_table = Qnil;
616   ct->next_table = Qnil;
617   XSETCHAR_TABLE (obj, ct);
618   if (ty == CHAR_TABLE_TYPE_SYNTAX)
619     {
620       ct->next_table = Vall_syntax_tables;
621       Vall_syntax_tables = obj;
622     }
623   Freset_char_table (obj);
624   return obj;
625 }
626
627 #ifdef MULE
628
629 static Lisp_Object
630 make_char_table_entry (Lisp_Object initval)
631 {
632   Lisp_Object obj;
633   int i;
634   Lisp_Char_Table_Entry *cte =
635     alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
636
637   for (i = 0; i < 96; i++)
638     cte->level2[i] = initval;
639
640   XSETCHAR_TABLE_ENTRY (obj, cte);
641   return obj;
642 }
643
644 static Lisp_Object
645 copy_char_table_entry (Lisp_Object entry)
646 {
647   Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
648   Lisp_Object obj;
649   int i;
650   Lisp_Char_Table_Entry *ctenew =
651     alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
652
653   for (i = 0; i < 96; i++)
654     {
655       Lisp_Object new = cte->level2[i];
656       if (CHAR_TABLE_ENTRYP (new))
657         ctenew->level2[i] = copy_char_table_entry (new);
658       else
659         ctenew->level2[i] = new;
660     }
661
662   XSETCHAR_TABLE_ENTRY (obj, ctenew);
663   return obj;
664 }
665
666 #endif /* MULE */
667
668 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
669 Return a new char table which is a copy of CHAR-TABLE.
670 It will contain the same values for the same characters and ranges
671 as CHAR-TABLE.  The values will not themselves be copied.
672 */
673        (char_table))
674 {
675   Lisp_Char_Table *ct, *ctnew;
676   Lisp_Object obj;
677   int i;
678
679   CHECK_CHAR_TABLE (char_table);
680   ct = XCHAR_TABLE (char_table);
681   ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
682   ctnew->type = ct->type;
683
684   for (i = 0; i < NUM_ASCII_CHARS; i++)
685     {
686       Lisp_Object new = ct->ascii[i];
687 #ifdef MULE
688       assert (! (CHAR_TABLE_ENTRYP (new)));
689 #endif /* MULE */
690       ctnew->ascii[i] = new;
691     }
692
693 #ifdef MULE
694
695   for (i = 0; i < NUM_LEADING_BYTES; i++)
696     {
697       Lisp_Object new = ct->level1[i];
698       if (CHAR_TABLE_ENTRYP (new))
699         ctnew->level1[i] = copy_char_table_entry (new);
700       else
701         ctnew->level1[i] = new;
702     }
703
704 #endif /* MULE */
705
706   if (CHAR_TABLEP (ct->mirror_table))
707     ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
708   else
709     ctnew->mirror_table = ct->mirror_table;
710   ctnew->next_table = Qnil;
711   XSETCHAR_TABLE (obj, ctnew);
712   if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
713     {
714       ctnew->next_table = Vall_syntax_tables;
715       Vall_syntax_tables = obj;
716     }
717   return obj;
718 }
719
720 static void
721 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
722 {
723   if (EQ (range, Qt))
724     outrange->type = CHARTAB_RANGE_ALL;
725   else if (CHAR_OR_CHAR_INTP (range))
726     {
727       outrange->type = CHARTAB_RANGE_CHAR;
728       outrange->ch = XCHAR_OR_CHAR_INT (range);
729     }
730 #ifndef MULE
731   else
732     signal_simple_error ("Range must be t or a character", range);
733 #else /* MULE */
734   else if (VECTORP (range))
735     {
736       Lisp_Vector *vec = XVECTOR (range);
737       Lisp_Object *elts = vector_data (vec);
738       if (vector_length (vec) != 2)
739         signal_simple_error ("Length of charset row vector must be 2",
740                              range);
741       outrange->type = CHARTAB_RANGE_ROW;
742       outrange->charset = Fget_charset (elts[0]);
743       CHECK_INT (elts[1]);
744       outrange->row = XINT (elts[1]);
745       switch (XCHARSET_TYPE (outrange->charset))
746         {
747         case CHARSET_TYPE_94:
748         case CHARSET_TYPE_96:
749           signal_simple_error ("Charset in row vector must be multi-byte",
750                                outrange->charset);
751         case CHARSET_TYPE_94X94:
752           check_int_range (outrange->row, 33, 126);
753           break;
754         case CHARSET_TYPE_96X96:
755           check_int_range (outrange->row, 32, 127);
756           break;
757         default:
758           abort ();
759         }
760     }
761   else
762     {
763       if (!CHARSETP (range) && !SYMBOLP (range))
764         signal_simple_error
765           ("Char table range must be t, charset, char, or vector", range);
766       outrange->type = CHARTAB_RANGE_CHARSET;
767       outrange->charset = Fget_charset (range);
768     }
769 #endif /* MULE */
770 }
771
772 #ifdef MULE
773
774 /* called from CHAR_TABLE_VALUE(). */
775 Lisp_Object
776 get_non_ascii_char_table_value (Lisp_Char_Table *ct, int leading_byte,
777                                Emchar c)
778 {
779   Lisp_Object val;
780   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
781   int byte1, byte2;
782
783   BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
784   val = ct->level1[leading_byte - MIN_LEADING_BYTE];
785   if (CHAR_TABLE_ENTRYP (val))
786     {
787       Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
788       val = cte->level2[byte1 - 32];
789       if (CHAR_TABLE_ENTRYP (val))
790         {
791           cte = XCHAR_TABLE_ENTRY (val);
792           assert (byte2 >= 32);
793           val = cte->level2[byte2 - 32];
794           assert (!CHAR_TABLE_ENTRYP (val));
795         }
796     }
797
798   return val;
799 }
800
801 #endif /* MULE */
802
803 Lisp_Object
804 get_char_table (Emchar ch, Lisp_Char_Table *ct)
805 {
806 #ifdef MULE
807   {
808     Lisp_Object charset;
809     int byte1, byte2;
810     Lisp_Object val;
811
812     BREAKUP_CHAR (ch, charset, byte1, byte2);
813
814     if (EQ (charset, Vcharset_ascii))
815       val = ct->ascii[byte1];
816     else if (EQ (charset, Vcharset_control_1))
817       val = ct->ascii[byte1 + 128];
818     else
819       {
820         int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
821         val = ct->level1[lb];
822         if (CHAR_TABLE_ENTRYP (val))
823           {
824             Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
825             val = cte->level2[byte1 - 32];
826             if (CHAR_TABLE_ENTRYP (val))
827               {
828                 cte = XCHAR_TABLE_ENTRY (val);
829                 assert (byte2 >= 32);
830                 val = cte->level2[byte2 - 32];
831                 assert (!CHAR_TABLE_ENTRYP (val));
832               }
833           }
834       }
835
836     return val;
837   }
838 #else /* not MULE */
839   return ct->ascii[(unsigned char)ch];
840 #endif /* not MULE */
841 }
842
843
844 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
845 Find value for CHARACTER in CHAR-TABLE.
846 */
847        (character, char_table))
848 {
849   CHECK_CHAR_TABLE (char_table);
850   CHECK_CHAR_COERCE_INT (character);
851
852   return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
853 }
854
855 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
856 Find value for a range in CHAR-TABLE.
857 If there is more than one value, return MULTI (defaults to nil).
858 */
859        (range, char_table, multi))
860 {
861   Lisp_Char_Table *ct;
862   struct chartab_range rainj;
863
864   if (CHAR_OR_CHAR_INTP (range))
865     return Fget_char_table (range, char_table);
866   CHECK_CHAR_TABLE (char_table);
867   ct = XCHAR_TABLE (char_table);
868
869   decode_char_table_range (range, &rainj);
870   switch (rainj.type)
871     {
872     case CHARTAB_RANGE_ALL:
873       {
874         int i;
875         Lisp_Object first = ct->ascii[0];
876
877         for (i = 1; i < NUM_ASCII_CHARS; i++)
878           if (!EQ (first, ct->ascii[i]))
879             return multi;
880
881 #ifdef MULE
882         for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
883              i++)
884           {
885             if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
886                 || i == LEADING_BYTE_ASCII
887                 || i == LEADING_BYTE_CONTROL_1)
888               continue;
889             if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
890               return multi;
891           }
892 #endif /* MULE */
893
894         return first;
895       }
896
897 #ifdef MULE
898     case CHARTAB_RANGE_CHARSET:
899       if (EQ (rainj.charset, Vcharset_ascii))
900         {
901           int i;
902           Lisp_Object first = ct->ascii[0];
903
904           for (i = 1; i < 128; i++)
905             if (!EQ (first, ct->ascii[i]))
906               return multi;
907           return first;
908         }
909
910       if (EQ (rainj.charset, Vcharset_control_1))
911         {
912           int i;
913           Lisp_Object first = ct->ascii[128];
914
915           for (i = 129; i < 160; i++)
916             if (!EQ (first, ct->ascii[i]))
917               return multi;
918           return first;
919         }
920
921       {
922         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
923                                      MIN_LEADING_BYTE];
924         if (CHAR_TABLE_ENTRYP (val))
925           return multi;
926         return val;
927       }
928
929     case CHARTAB_RANGE_ROW:
930       {
931         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
932                                      MIN_LEADING_BYTE];
933         if (!CHAR_TABLE_ENTRYP (val))
934           return val;
935         val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
936         if (CHAR_TABLE_ENTRYP (val))
937           return multi;
938         return val;
939       }
940 #endif /* not MULE */
941
942     default:
943       abort ();
944     }
945
946   return Qnil; /* not reached */
947 }
948
949 static int
950 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
951                               Error_behavior errb)
952 {
953   switch (type)
954     {
955     case CHAR_TABLE_TYPE_SYNTAX:
956       if (!ERRB_EQ (errb, ERROR_ME))
957         return INTP (value) || (CONSP (value) && INTP (XCAR (value))
958                                 && CHAR_OR_CHAR_INTP (XCDR (value)));
959       if (CONSP (value))
960         {
961           Lisp_Object cdr = XCDR (value);
962           CHECK_INT (XCAR (value));
963           CHECK_CHAR_COERCE_INT (cdr);
964          }
965       else
966         CHECK_INT (value);
967       break;
968
969 #ifdef MULE
970     case CHAR_TABLE_TYPE_CATEGORY:
971       if (!ERRB_EQ (errb, ERROR_ME))
972         return CATEGORY_TABLE_VALUEP (value);
973       CHECK_CATEGORY_TABLE_VALUE (value);
974       break;
975 #endif /* MULE */
976
977     case CHAR_TABLE_TYPE_GENERIC:
978       return 1;
979
980     case CHAR_TABLE_TYPE_DISPLAY:
981       /* #### fix this */
982       maybe_signal_simple_error ("Display char tables not yet implemented",
983                                  value, Qchar_table, errb);
984       return 0;
985
986     case CHAR_TABLE_TYPE_CHAR:
987       if (!ERRB_EQ (errb, ERROR_ME))
988         return CHAR_OR_CHAR_INTP (value);
989       CHECK_CHAR_COERCE_INT (value);
990       break;
991
992     default:
993       abort ();
994     }
995
996   return 0; /* not reached */
997 }
998
999 static Lisp_Object
1000 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
1001 {
1002   switch (type)
1003     {
1004     case CHAR_TABLE_TYPE_SYNTAX:
1005       if (CONSP (value))
1006         {
1007           Lisp_Object car = XCAR (value);
1008           Lisp_Object cdr = XCDR (value);
1009           CHECK_CHAR_COERCE_INT (cdr);
1010           return Fcons (car, cdr);
1011         }
1012       break;
1013     case CHAR_TABLE_TYPE_CHAR:
1014       CHECK_CHAR_COERCE_INT (value);
1015       break;
1016     default:
1017       break;
1018     }
1019   return value;
1020 }
1021
1022 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
1023 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
1024 */
1025        (value, char_table_type))
1026 {
1027   enum char_table_type type = symbol_to_char_table_type (char_table_type);
1028
1029   return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
1030 }
1031
1032 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
1033 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
1034 */
1035        (value, char_table_type))
1036 {
1037   enum char_table_type type = symbol_to_char_table_type (char_table_type);
1038
1039   check_valid_char_table_value (value, type, ERROR_ME);
1040   return Qnil;
1041 }
1042
1043 /* Assign VAL to all characters in RANGE in char table CT. */
1044
1045 void
1046 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
1047                 Lisp_Object val)
1048 {
1049   switch (range->type)
1050     {
1051     case CHARTAB_RANGE_ALL:
1052       fill_char_table (ct, val);
1053       return; /* avoid the duplicate call to update_syntax_table() below,
1054                  since fill_char_table() also did that. */
1055
1056 #ifdef MULE
1057     case CHARTAB_RANGE_CHARSET:
1058       if (EQ (range->charset, Vcharset_ascii))
1059         {
1060           int i;
1061           for (i = 0; i < 128; i++)
1062             ct->ascii[i] = val;
1063         }
1064       else if (EQ (range->charset, Vcharset_control_1))
1065         {
1066           int i;
1067           for (i = 128; i < 160; i++)
1068             ct->ascii[i] = val;
1069         }
1070       else
1071         {
1072           int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1073           ct->level1[lb] = val;
1074         }
1075       break;
1076
1077     case CHARTAB_RANGE_ROW:
1078       {
1079         Lisp_Char_Table_Entry *cte;
1080         int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1081         /* make sure that there is a separate entry for the row. */
1082         if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1083           ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1084         cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1085         cte->level2[range->row - 32] = val;
1086       }
1087       break;
1088 #endif /* MULE */
1089
1090     case CHARTAB_RANGE_CHAR:
1091 #ifdef MULE
1092       {
1093         Lisp_Object charset;
1094         int byte1, byte2;
1095
1096         BREAKUP_CHAR (range->ch, charset, byte1, byte2);
1097         if (EQ (charset, Vcharset_ascii))
1098           ct->ascii[byte1] = val;
1099         else if (EQ (charset, Vcharset_control_1))
1100           ct->ascii[byte1 + 128] = val;
1101         else
1102           {
1103             Lisp_Char_Table_Entry *cte;
1104             int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1105             /* make sure that there is a separate entry for the row. */
1106             if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1107               ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1108             cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1109             /* now CTE is a char table entry for the charset;
1110                each entry is for a single row (or character of
1111                a one-octet charset). */
1112             if (XCHARSET_DIMENSION (charset) == 1)
1113               cte->level2[byte1 - 32] = val;
1114             else
1115               {
1116                 /* assigning to one character in a two-octet charset. */
1117                 /* make sure that the charset row contains a separate
1118                    entry for each character. */
1119                 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
1120                   cte->level2[byte1 - 32] =
1121                     make_char_table_entry (cte->level2[byte1 - 32]);
1122                 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
1123                 cte->level2[byte2 - 32] = val;
1124               }
1125           }
1126       }
1127 #else /* not MULE */
1128       ct->ascii[(unsigned char) (range->ch)] = val;
1129       break;
1130 #endif /* not MULE */
1131     }
1132
1133   if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1134     update_syntax_table (ct);
1135 }
1136
1137 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
1138 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
1139
1140 RANGE specifies one or more characters to be affected and should be
1141 one of the following:
1142
1143 -- t (all characters are affected)
1144 -- A charset (only allowed when Mule support is present)
1145 -- A vector of two elements: a two-octet charset and a row number
1146    (only allowed when Mule support is present)
1147 -- A single character
1148
1149 VALUE must be a value appropriate for the type of CHAR-TABLE.
1150 See `valid-char-table-type-p'.
1151 */
1152        (range, value, char_table))
1153 {
1154   Lisp_Char_Table *ct;
1155   struct chartab_range rainj;
1156
1157   CHECK_CHAR_TABLE (char_table);
1158   ct = XCHAR_TABLE (char_table);
1159   check_valid_char_table_value (value, ct->type, ERROR_ME);
1160   decode_char_table_range (range, &rainj);
1161   value = canonicalize_char_table_value (value, ct->type);
1162   put_char_table (ct, &rainj, value);
1163   return Qnil;
1164 }
1165
1166 /* Map FN over the ASCII chars in CT. */
1167
1168 static int
1169 map_over_charset_ascii (Lisp_Char_Table *ct,
1170                         int (*fn) (struct chartab_range *range,
1171                                    Lisp_Object val, void *arg),
1172                         void *arg)
1173 {
1174   struct chartab_range rainj;
1175   int i, retval;
1176   int start = 0;
1177 #ifdef MULE
1178   int stop = 128;
1179 #else
1180   int stop = 256;
1181 #endif
1182
1183   rainj.type = CHARTAB_RANGE_CHAR;
1184
1185   for (i = start, retval = 0; i < stop && retval == 0; i++)
1186     {
1187       rainj.ch = (Emchar) i;
1188       retval = (fn) (&rainj, ct->ascii[i], arg);
1189     }
1190
1191   return retval;
1192 }
1193
1194 #ifdef MULE
1195
1196 /* Map FN over the Control-1 chars in CT. */
1197
1198 static int
1199 map_over_charset_control_1 (Lisp_Char_Table *ct,
1200                             int (*fn) (struct chartab_range *range,
1201                                        Lisp_Object val, void *arg),
1202                             void *arg)
1203 {
1204   struct chartab_range rainj;
1205   int i, retval;
1206   int start = 128;
1207   int stop  = start + 32;
1208
1209   rainj.type = CHARTAB_RANGE_CHAR;
1210
1211   for (i = start, retval = 0; i < stop && retval == 0; i++)
1212     {
1213       rainj.ch = (Emchar) (i);
1214       retval = (fn) (&rainj, ct->ascii[i], arg);
1215     }
1216
1217   return retval;
1218 }
1219
1220 /* Map FN over the row ROW of two-byte charset CHARSET.
1221    There must be a separate value for that row in the char table.
1222    CTE specifies the char table entry for CHARSET. */
1223
1224 static int
1225 map_over_charset_row (Lisp_Char_Table_Entry *cte,
1226                       Lisp_Object charset, int row,
1227                       int (*fn) (struct chartab_range *range,
1228                                  Lisp_Object val, void *arg),
1229                       void *arg)
1230 {
1231   Lisp_Object val = cte->level2[row - 32];
1232
1233   if (!CHAR_TABLE_ENTRYP (val))
1234     {
1235       struct chartab_range rainj;
1236
1237       rainj.type = CHARTAB_RANGE_ROW;
1238       rainj.charset = charset;
1239       rainj.row = row;
1240       return (fn) (&rainj, val, arg);
1241     }
1242   else
1243     {
1244       struct chartab_range rainj;
1245       int i, retval;
1246       int charset94_p = (XCHARSET_CHARS (charset) == 94);
1247       int start = charset94_p ?  33 :  32;
1248       int stop  = charset94_p ? 127 : 128;
1249
1250       cte = XCHAR_TABLE_ENTRY (val);
1251
1252       rainj.type = CHARTAB_RANGE_CHAR;
1253
1254       for (i = start, retval = 0; i < stop && retval == 0; i++)
1255         {
1256           rainj.ch = MAKE_CHAR (charset, row, i);
1257           retval = (fn) (&rainj, cte->level2[i - 32], arg);
1258         }
1259       return retval;
1260     }
1261 }
1262
1263
1264 static int
1265 map_over_other_charset (Lisp_Char_Table *ct, int lb,
1266                         int (*fn) (struct chartab_range *range,
1267                                    Lisp_Object val, void *arg),
1268                         void *arg)
1269 {
1270   Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
1271   Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
1272
1273   if (!CHARSETP (charset)
1274       || lb == LEADING_BYTE_ASCII
1275       || lb == LEADING_BYTE_CONTROL_1)
1276     return 0;
1277
1278   if (!CHAR_TABLE_ENTRYP (val))
1279     {
1280       struct chartab_range rainj;
1281
1282       rainj.type = CHARTAB_RANGE_CHARSET;
1283       rainj.charset = charset;
1284       return (fn) (&rainj, val, arg);
1285     }
1286
1287   {
1288     Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1289     int charset94_p = (XCHARSET_CHARS (charset) == 94);
1290     int start = charset94_p ?  33 :  32;
1291     int stop  = charset94_p ? 127 : 128;
1292     int i, retval;
1293
1294     if (XCHARSET_DIMENSION (charset) == 1)
1295       {
1296         struct chartab_range rainj;
1297         rainj.type = CHARTAB_RANGE_CHAR;
1298
1299         for (i = start, retval = 0; i < stop && retval == 0; i++)
1300           {
1301             rainj.ch = MAKE_CHAR (charset, i, 0);
1302             retval = (fn) (&rainj, cte->level2[i - 32], arg);
1303           }
1304       }
1305     else
1306       {
1307         for (i = start, retval = 0; i < stop && retval == 0; i++)
1308           retval = map_over_charset_row (cte, charset, i, fn, arg);
1309       }
1310
1311     return retval;
1312   }
1313 }
1314
1315 #endif /* MULE */
1316
1317 /* Map FN (with client data ARG) over range RANGE in char table CT.
1318    Mapping stops the first time FN returns non-zero, and that value
1319    becomes the return value of map_char_table(). */
1320
1321 int
1322 map_char_table (Lisp_Char_Table *ct,
1323                 struct chartab_range *range,
1324                 int (*fn) (struct chartab_range *range,
1325                            Lisp_Object val, void *arg),
1326                 void *arg)
1327 {
1328   switch (range->type)
1329     {
1330     case CHARTAB_RANGE_ALL:
1331       {
1332         int retval;
1333
1334         retval = map_over_charset_ascii (ct, fn, arg);
1335         if (retval)
1336           return retval;
1337 #ifdef MULE
1338         retval = map_over_charset_control_1 (ct, fn, arg);
1339         if (retval)
1340           return retval;
1341         {
1342           int i;
1343           int start = MIN_LEADING_BYTE;
1344           int stop  = start + NUM_LEADING_BYTES;
1345
1346           for (i = start, retval = 0; i < stop && retval == 0; i++)
1347             {
1348               retval = map_over_other_charset (ct, i, fn, arg);
1349             }
1350         }
1351 #endif /* MULE */
1352         return retval;
1353       }
1354
1355 #ifdef MULE
1356     case CHARTAB_RANGE_CHARSET:
1357       return map_over_other_charset (ct,
1358                                      XCHARSET_LEADING_BYTE (range->charset),
1359                                      fn, arg);
1360
1361     case CHARTAB_RANGE_ROW:
1362       {
1363         Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE];
1364         if (!CHAR_TABLE_ENTRYP (val))
1365           {
1366             struct chartab_range rainj;
1367
1368             rainj.type = CHARTAB_RANGE_ROW;
1369             rainj.charset = range->charset;
1370             rainj.row = range->row;
1371             return (fn) (&rainj, val, arg);
1372           }
1373         else
1374           return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
1375                                        range->charset, range->row,
1376                                        fn, arg);
1377       }
1378 #endif /* MULE */
1379
1380     case CHARTAB_RANGE_CHAR:
1381       {
1382         Emchar ch = range->ch;
1383         Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
1384         struct chartab_range rainj;
1385
1386         rainj.type = CHARTAB_RANGE_CHAR;
1387         rainj.ch = ch;
1388         return (fn) (&rainj, val, arg);
1389       }
1390
1391     default:
1392       abort ();
1393     }
1394
1395   return 0;
1396 }
1397
1398 struct slow_map_char_table_arg
1399 {
1400   Lisp_Object function;
1401   Lisp_Object retval;
1402 };
1403
1404 static int
1405 slow_map_char_table_fun (struct chartab_range *range,
1406                          Lisp_Object val, void *arg)
1407 {
1408   Lisp_Object ranjarg = Qnil;
1409   struct slow_map_char_table_arg *closure =
1410     (struct slow_map_char_table_arg *) arg;
1411
1412   switch (range->type)
1413     {
1414     case CHARTAB_RANGE_ALL:
1415       ranjarg = Qt;
1416       break;
1417
1418 #ifdef MULE
1419     case CHARTAB_RANGE_CHARSET:
1420       ranjarg = XCHARSET_NAME (range->charset);
1421       break;
1422
1423     case CHARTAB_RANGE_ROW:
1424       ranjarg = vector2 (XCHARSET_NAME (range->charset),
1425                          make_int (range->row));
1426       break;
1427 #endif /* MULE */
1428     case CHARTAB_RANGE_CHAR:
1429       ranjarg = make_char (range->ch);
1430       break;
1431     default:
1432       abort ();
1433     }
1434
1435   closure->retval = call2 (closure->function, ranjarg, val);
1436   return !NILP (closure->retval);
1437 }
1438
1439 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
1440 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
1441 each key and value in the table.
1442
1443 RANGE specifies a subrange to map over and is in the same format as
1444 the RANGE argument to `put-range-table'.  If omitted or t, it defaults to
1445 the entire table.
1446 */
1447        (function, char_table, range))
1448 {
1449   Lisp_Char_Table *ct;
1450   struct slow_map_char_table_arg slarg;
1451   struct gcpro gcpro1, gcpro2;
1452   struct chartab_range rainj;
1453
1454   CHECK_CHAR_TABLE (char_table);
1455   ct = XCHAR_TABLE (char_table);
1456   if (NILP (range))
1457     range = Qt;
1458   decode_char_table_range (range, &rainj);
1459   slarg.function = function;
1460   slarg.retval = Qnil;
1461   GCPRO2 (slarg.function, slarg.retval);
1462   map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
1463   UNGCPRO;
1464
1465   return slarg.retval;
1466 }
1467
1468
1469 \f
1470 /************************************************************************/
1471 /*                         Char table read syntax                       */
1472 /************************************************************************/
1473
1474 static int
1475 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
1476                        Error_behavior errb)
1477 {
1478   /* #### should deal with ERRB */
1479   symbol_to_char_table_type (value);
1480   return 1;
1481 }
1482
1483 static int
1484 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
1485                        Error_behavior errb)
1486 {
1487   Lisp_Object rest;
1488
1489   /* #### should deal with ERRB */
1490   EXTERNAL_LIST_LOOP (rest, value)
1491     {
1492       Lisp_Object range = XCAR (rest);
1493       struct chartab_range dummy;
1494
1495       rest = XCDR (rest);
1496       if (!CONSP (rest))
1497         signal_simple_error ("Invalid list format", value);
1498       if (CONSP (range))
1499         {
1500           if (!CONSP (XCDR (range))
1501               || !NILP (XCDR (XCDR (range))))
1502             signal_simple_error ("Invalid range format", range);
1503           decode_char_table_range (XCAR (range), &dummy);
1504           decode_char_table_range (XCAR (XCDR (range)), &dummy);
1505         }
1506       else
1507         decode_char_table_range (range, &dummy);
1508     }
1509
1510   return 1;
1511 }
1512
1513 static Lisp_Object
1514 chartab_instantiate (Lisp_Object data)
1515 {
1516   Lisp_Object chartab;
1517   Lisp_Object type = Qgeneric;
1518   Lisp_Object dataval = Qnil;
1519
1520   while (!NILP (data))
1521     {
1522       Lisp_Object keyw = Fcar (data);
1523       Lisp_Object valw;
1524
1525       data = Fcdr (data);
1526       valw = Fcar (data);
1527       data = Fcdr (data);
1528       if (EQ (keyw, Qtype))
1529         type = valw;
1530       else if (EQ (keyw, Qdata))
1531         dataval = valw;
1532     }
1533
1534   chartab = Fmake_char_table (type);
1535
1536   data = dataval;
1537   while (!NILP (data))
1538     {
1539       Lisp_Object range = Fcar (data);
1540       Lisp_Object val = Fcar (Fcdr (data));
1541
1542       data = Fcdr (Fcdr (data));
1543       if (CONSP (range))
1544         {
1545           if (CHAR_OR_CHAR_INTP (XCAR (range)))
1546             {
1547               Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
1548               Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
1549               Emchar i;
1550
1551               for (i = first; i <= last; i++)
1552                  Fput_char_table (make_char (i), val, chartab);
1553             }
1554           else
1555             abort ();
1556         }
1557       else
1558         Fput_char_table (range, val, chartab);
1559     }
1560
1561   return chartab;
1562 }
1563
1564 #ifdef MULE
1565
1566 \f
1567 /************************************************************************/
1568 /*                     Category Tables, specifically                    */
1569 /************************************************************************/
1570
1571 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
1572 Return t if OBJECT is a category table.
1573 A category table is a type of char table used for keeping track of
1574 categories.  Categories are used for classifying characters for use
1575 in regexps -- you can refer to a category rather than having to use
1576 a complicated [] expression (and category lookups are significantly
1577 faster).
1578
1579 There are 95 different categories available, one for each printable
1580 character (including space) in the ASCII charset.  Each category
1581 is designated by one such character, called a "category designator".
1582 They are specified in a regexp using the syntax "\\cX", where X is
1583 a category designator.
1584
1585 A category table specifies, for each character, the categories that
1586 the character is in.  Note that a character can be in more than one
1587 category.  More specifically, a category table maps from a character
1588 to either the value nil (meaning the character is in no categories)
1589 or a 95-element bit vector, specifying for each of the 95 categories
1590 whether the character is in that category.
1591
1592 Special Lisp functions are provided that abstract this, so you do not
1593 have to directly manipulate bit vectors.
1594 */
1595        (object))
1596 {
1597   return (CHAR_TABLEP (object) &&
1598           XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
1599     Qt : Qnil;
1600 }
1601
1602 static Lisp_Object
1603 check_category_table (Lisp_Object object, Lisp_Object default_)
1604 {
1605   if (NILP (object))
1606     object = default_;
1607   while (NILP (Fcategory_table_p (object)))
1608     object = wrong_type_argument (Qcategory_table_p, object);
1609   return object;
1610 }
1611
1612 int
1613 check_category_char (Emchar ch, Lisp_Object table,
1614                      unsigned int designator, unsigned int not)
1615 {
1616   REGISTER Lisp_Object temp;
1617   Lisp_Char_Table *ctbl;
1618 #ifdef ERROR_CHECK_TYPECHECK
1619   if (NILP (Fcategory_table_p (table)))
1620     signal_simple_error ("Expected category table", table);
1621 #endif
1622   ctbl = XCHAR_TABLE (table);
1623   temp = get_char_table (ch, ctbl);
1624   if (NILP (temp))
1625     return not;
1626
1627   designator -= ' ';
1628   return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
1629 }
1630
1631 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
1632 Return t if category of the character at POSITION includes DESIGNATOR.
1633 Optional third arg BUFFER specifies which buffer to use, and defaults
1634 to the current buffer.
1635 Optional fourth arg CATEGORY-TABLE specifies the category table to
1636 use, and defaults to BUFFER's category table.
1637 */
1638        (position, designator, buffer, category_table))
1639 {
1640   Lisp_Object ctbl;
1641   Emchar ch;
1642   unsigned int des;
1643   struct buffer *buf = decode_buffer (buffer, 0);
1644
1645   CHECK_INT (position);
1646   CHECK_CATEGORY_DESIGNATOR (designator);
1647   des = XCHAR (designator);
1648   ctbl = check_category_table (category_table, Vstandard_category_table);
1649   ch = BUF_FETCH_CHAR (buf, XINT (position));
1650   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1651 }
1652
1653 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
1654 Return t if category of CHARACTER includes DESIGNATOR, else nil.
1655 Optional third arg CATEGORY-TABLE specifies the category table to use,
1656 and defaults to the standard category table.
1657 */
1658        (character, designator, category_table))
1659 {
1660   Lisp_Object ctbl;
1661   Emchar ch;
1662   unsigned int des;
1663
1664   CHECK_CATEGORY_DESIGNATOR (designator);
1665   des = XCHAR (designator);
1666   CHECK_CHAR (character);
1667   ch = XCHAR (character);
1668   ctbl = check_category_table (category_table, Vstandard_category_table);
1669   return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1670 }
1671
1672 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
1673 Return BUFFER's current category table.
1674 BUFFER defaults to the current buffer.
1675 */
1676        (buffer))
1677 {
1678   return decode_buffer (buffer, 0)->category_table;
1679 }
1680
1681 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
1682 Return the standard category table.
1683 This is the one used for new buffers.
1684 */
1685        ())
1686 {
1687   return Vstandard_category_table;
1688 }
1689
1690 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
1691 Return a new category table which is a copy of CATEGORY-TABLE.
1692 CATEGORY-TABLE defaults to the standard category table.
1693 */
1694        (category_table))
1695 {
1696   if (NILP (Vstandard_category_table))
1697     return Fmake_char_table (Qcategory);
1698
1699   category_table =
1700     check_category_table (category_table, Vstandard_category_table);
1701   return Fcopy_char_table (category_table);
1702 }
1703
1704 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
1705 Select CATEGORY-TABLE as the new category table for BUFFER.
1706 BUFFER defaults to the current buffer if omitted.
1707 */
1708        (category_table, buffer))
1709 {
1710   struct buffer *buf = decode_buffer (buffer, 0);
1711   category_table = check_category_table (category_table, Qnil);
1712   buf->category_table = category_table;
1713   /* Indicate that this buffer now has a specified category table.  */
1714   buf->local_var_flags |= XINT (buffer_local_flags.category_table);
1715   return category_table;
1716 }
1717
1718 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
1719 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
1720 */
1721        (object))
1722 {
1723   return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
1724 }
1725
1726 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
1727 Return t if OBJECT is a category table value.
1728 Valid values are nil or a bit vector of size 95.
1729 */
1730        (object))
1731 {
1732   return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
1733 }
1734
1735
1736 #define CATEGORYP(x) \
1737   (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
1738
1739 #define CATEGORY_SET(c)                                         \
1740   (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
1741
1742 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
1743    The faster version of `!NILP (Faref (category_set, category))'.  */
1744 #define CATEGORY_MEMBER(category, category_set)                 \
1745   (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
1746
1747 /* Return 1 if there is a word boundary between two word-constituent
1748    characters C1 and C2 if they appear in this order, else return 0.
1749    Use the macro WORD_BOUNDARY_P instead of calling this function
1750    directly.  */
1751
1752 int word_boundary_p (Emchar c1, Emchar c2);
1753 int
1754 word_boundary_p (Emchar c1, Emchar c2)
1755 {
1756   Lisp_Object category_set1, category_set2;
1757   Lisp_Object tail;
1758   int default_result;
1759
1760 #if 0
1761   if (COMPOSITE_CHAR_P (c1))
1762     c1 = cmpchar_component (c1, 0, 1);
1763   if (COMPOSITE_CHAR_P (c2))
1764     c2 = cmpchar_component (c2, 0, 1);
1765 #endif
1766
1767   if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
1768     {
1769       tail = Vword_separating_categories;
1770       default_result = 0;
1771     }
1772   else
1773     {
1774       tail = Vword_combining_categories;
1775       default_result = 1;
1776     }
1777
1778   category_set1 = CATEGORY_SET (c1);
1779   if (NILP (category_set1))
1780     return default_result;
1781   category_set2 = CATEGORY_SET (c2);
1782   if (NILP (category_set2))
1783     return default_result;
1784
1785   for (; CONSP (tail); tail = XCONS (tail)->cdr)
1786     {
1787       Lisp_Object elt = XCONS(tail)->car;
1788
1789       if (CONSP (elt)
1790           && CATEGORYP (XCONS (elt)->car)
1791           && CATEGORYP (XCONS (elt)->cdr)
1792           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
1793           && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
1794         return !default_result;
1795     }
1796   return default_result;
1797 }
1798 #endif /* MULE */
1799
1800 \f
1801 void
1802 syms_of_chartab (void)
1803 {
1804   INIT_LRECORD_IMPLEMENTATION (char_table);
1805
1806 #ifdef MULE
1807   INIT_LRECORD_IMPLEMENTATION (char_table_entry);
1808
1809   defsymbol (&Qcategory_table_p, "category-table-p");
1810   defsymbol (&Qcategory_designator_p, "category-designator-p");
1811   defsymbol (&Qcategory_table_value_p, "category-table-value-p");
1812 #endif /* MULE */
1813
1814   defsymbol (&Qchar_table, "char-table");
1815   defsymbol (&Qchar_tablep, "char-table-p");
1816
1817   DEFSUBR (Fchar_table_p);
1818   DEFSUBR (Fchar_table_type_list);
1819   DEFSUBR (Fvalid_char_table_type_p);
1820   DEFSUBR (Fchar_table_type);
1821   DEFSUBR (Freset_char_table);
1822   DEFSUBR (Fmake_char_table);
1823   DEFSUBR (Fcopy_char_table);
1824   DEFSUBR (Fget_char_table);
1825   DEFSUBR (Fget_range_char_table);
1826   DEFSUBR (Fvalid_char_table_value_p);
1827   DEFSUBR (Fcheck_valid_char_table_value);
1828   DEFSUBR (Fput_char_table);
1829   DEFSUBR (Fmap_char_table);
1830
1831 #ifdef MULE
1832   DEFSUBR (Fcategory_table_p);
1833   DEFSUBR (Fcategory_table);
1834   DEFSUBR (Fstandard_category_table);
1835   DEFSUBR (Fcopy_category_table);
1836   DEFSUBR (Fset_category_table);
1837   DEFSUBR (Fcheck_category_at);
1838   DEFSUBR (Fchar_in_category_p);
1839   DEFSUBR (Fcategory_designator_p);
1840   DEFSUBR (Fcategory_table_value_p);
1841 #endif /* MULE */
1842
1843 }
1844
1845 void
1846 vars_of_chartab (void)
1847 {
1848   /* DO NOT staticpro this.  It works just like Vweak_hash_tables. */
1849   Vall_syntax_tables = Qnil;
1850   dump_add_weak_object_chain (&Vall_syntax_tables);
1851 }
1852
1853 void
1854 structure_type_create_chartab (void)
1855 {
1856   struct structure_type *st;
1857
1858   st = define_structure_type (Qchar_table, 0, chartab_instantiate);
1859
1860   define_structure_type_keyword (st, Qtype, chartab_type_validate);
1861   define_structure_type_keyword (st, Qdata, chartab_data_validate);
1862 }
1863
1864 void
1865 complex_vars_of_chartab (void)
1866 {
1867 #ifdef MULE
1868   /* Set this now, so first buffer creation can refer to it. */
1869   /* Make it nil before calling copy-category-table
1870      so that copy-category-table will know not to try to copy from garbage */
1871   Vstandard_category_table = Qnil;
1872   Vstandard_category_table = Fcopy_category_table (Qnil);
1873   staticpro (&Vstandard_category_table);
1874
1875   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
1876 List of pair (cons) of categories to determine word boundary.
1877
1878 Emacs treats a sequence of word constituent characters as a single
1879 word (i.e. finds no word boundary between them) iff they belongs to
1880 the same charset.  But, exceptions are allowed in the following cases.
1881
1882 \(1) The case that characters are in different charsets is controlled
1883 by the variable `word-combining-categories'.
1884
1885 Emacs finds no word boundary between characters of different charsets
1886 if they have categories matching some element of this list.
1887
1888 More precisely, if an element of this list is a cons of category CAT1
1889 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1890 C2 which has CAT2, there's no word boundary between C1 and C2.
1891
1892 For instance, to tell that ASCII characters and Latin-1 characters can
1893 form a single word, the element `(?l . ?l)' should be in this list
1894 because both characters have the category `l' (Latin characters).
1895
1896 \(2) The case that character are in the same charset is controlled by
1897 the variable `word-separating-categories'.
1898
1899 Emacs find a word boundary between characters of the same charset
1900 if they have categories matching some element of this list.
1901
1902 More precisely, if an element of this list is a cons of category CAT1
1903 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1904 C2 which has CAT2, there's a word boundary between C1 and C2.
1905
1906 For instance, to tell that there's a word boundary between Japanese
1907 Hiragana and Japanese Kanji (both are in the same charset), the
1908 element `(?H . ?C) should be in this list.
1909 */ );
1910
1911   Vword_combining_categories = Qnil;
1912
1913   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
1914 List of pair (cons) of categories to determine word boundary.
1915 See the documentation of the variable `word-combining-categories'.
1916 */ );
1917
1918   Vword_separating_categories = Qnil;
1919 #endif /* MULE */
1920 }