Mercurial > hg > xemacs-beta

comparison src/chartab.c @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children 8de8e3f6228a
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
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
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 struct 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 struct Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
114 struct 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 struct 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, offsetof(struct 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 struct Lisp_Char_Table_Entry);
143 #endif /* MULE */
144
145 static Lisp_Object
146 mark_char_table (Lisp_Object obj)
147 {
148 struct 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 struct 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 struct 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 struct 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 struct 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 struct Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
397 struct 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 struct 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, offsetof(struct Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
431 #ifdef MULE
432 { XD_LISP_OBJECT, offsetof(struct Lisp_Char_Table, level1), NUM_LEADING_BYTES },
433 #endif
434 { XD_LISP_OBJECT, offsetof(struct Lisp_Char_Table, mirror_table), 1 },
435 { XD_LO_LINK, offsetof(struct 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 struct 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'. To modify a char
472 table, use `put-char-table' or `remove-char-table'. To retrieve the
473 value for a particular character, use `get-char-table'. See also
474 `map-char-table', `clear-char-table', `copy-char-table',
475 `valid-char-table-type-p', `char-table-type-list', `valid-char-table-value-p',
476 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 TABLE.
537 See `valid-char-table-type-p'.
538 */
539 (table))
540 {
541 CHECK_CHAR_TABLE (table);
542 return char_table_type_to_symbol (XCHAR_TABLE (table)->type);
543 }
544
545 void
546 fill_char_table (struct 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 a char table to its default state.
563 */
564 (table))
565 {
566 struct Lisp_Char_Table *ct;
567
568 CHECK_CHAR_TABLE (table);
569 ct = XCHAR_TABLE (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 struct 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 (struct 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 struct Lisp_Char_Table_Entry *cte =
635 alloc_lcrecord_type (struct Lisp_Char_Table_Entry,
636 &lrecord_char_table_entry);
637
638 for (i = 0; i < 96; i++)
639 cte->level2[i] = initval;
640
641 XSETCHAR_TABLE_ENTRY (obj, cte);
642 return obj;
643 }
644
645 static Lisp_Object
646 copy_char_table_entry (Lisp_Object entry)
647 {
648 struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
649 Lisp_Object obj;
650 int i;
651 struct Lisp_Char_Table_Entry *ctenew =
652 alloc_lcrecord_type (struct Lisp_Char_Table_Entry,
653 &lrecord_char_table_entry);
654
655 for (i = 0; i < 96; i++)
656 {
657 Lisp_Object new = cte->level2[i];
658 if (CHAR_TABLE_ENTRYP (new))
659 ctenew->level2[i] = copy_char_table_entry (new);
660 else
661 ctenew->level2[i] = new;
662 }
663
664 XSETCHAR_TABLE_ENTRY (obj, ctenew);
665 return obj;
666 }
667
668 #endif /* MULE */
669
670 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
671 Make a new char table which is a copy of OLD-TABLE.
672 It will contain the same values for the same characters and ranges
673 as OLD-TABLE. The values will not themselves be copied.
674 */
675 (old_table))
676 {
677 struct Lisp_Char_Table *ct, *ctnew;
678 Lisp_Object obj;
679 int i;
680
681 CHECK_CHAR_TABLE (old_table);
682 ct = XCHAR_TABLE (old_table);
683 ctnew = alloc_lcrecord_type (struct Lisp_Char_Table, &lrecord_char_table);
684 ctnew->type = ct->type;
685
686 for (i = 0; i < NUM_ASCII_CHARS; i++)
687 {
688 Lisp_Object new = ct->ascii[i];
689 #ifdef MULE
690 assert (! (CHAR_TABLE_ENTRYP (new)));
691 #endif /* MULE */
692 ctnew->ascii[i] = new;
693 }
694
695 #ifdef MULE
696
697 for (i = 0; i < NUM_LEADING_BYTES; i++)
698 {
699 Lisp_Object new = ct->level1[i];
700 if (CHAR_TABLE_ENTRYP (new))
701 ctnew->level1[i] = copy_char_table_entry (new);
702 else
703 ctnew->level1[i] = new;
704 }
705
706 #endif /* MULE */
707
708 if (CHAR_TABLEP (ct->mirror_table))
709 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
710 else
711 ctnew->mirror_table = ct->mirror_table;
712 ctnew->next_table = Qnil;
713 XSETCHAR_TABLE (obj, ctnew);
714 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
715 {
716 ctnew->next_table = Vall_syntax_tables;
717 Vall_syntax_tables = obj;
718 }
719 return obj;
720 }
721
722 static void
723 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
724 {
725 if (EQ (range, Qt))
726 outrange->type = CHARTAB_RANGE_ALL;
727 else if (CHAR_OR_CHAR_INTP (range))
728 {
729 outrange->type = CHARTAB_RANGE_CHAR;
730 outrange->ch = XCHAR_OR_CHAR_INT (range);
731 }
732 #ifndef MULE
733 else
734 signal_simple_error ("Range must be t or a character", range);
735 #else /* MULE */
736 else if (VECTORP (range))
737 {
738 struct Lisp_Vector *vec = XVECTOR (range);
739 Lisp_Object *elts = vector_data (vec);
740 if (vector_length (vec) != 2)
741 signal_simple_error ("Length of charset row vector must be 2",
742 range);
743 outrange->type = CHARTAB_RANGE_ROW;
744 outrange->charset = Fget_charset (elts[0]);
745 CHECK_INT (elts[1]);
746 outrange->row = XINT (elts[1]);
747 switch (XCHARSET_TYPE (outrange->charset))
748 {
749 case CHARSET_TYPE_94:
750 case CHARSET_TYPE_96:
751 signal_simple_error ("Charset in row vector must be multi-byte",
752 outrange->charset);
753 case CHARSET_TYPE_94X94:
754 check_int_range (outrange->row, 33, 126);
755 break;
756 case CHARSET_TYPE_96X96:
757 check_int_range (outrange->row, 32, 127);
758 break;
759 default:
760 abort ();
761 }
762 }
763 else
764 {
765 if (!CHARSETP (range) && !SYMBOLP (range))
766 signal_simple_error
767 ("Char table range must be t, charset, char, or vector", range);
768 outrange->type = CHARTAB_RANGE_CHARSET;
769 outrange->charset = Fget_charset (range);
770 }
771 #endif /* MULE */
772 }
773
774 #ifdef MULE
775
776 /* called from CHAR_TABLE_VALUE(). */
777 Lisp_Object
778 get_non_ascii_char_table_value (struct Lisp_Char_Table *ct, int leading_byte,
779 Emchar c)
780 {
781 Lisp_Object val;
782 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
783 int byte1, byte2;
784
785 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
786 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
787 if (CHAR_TABLE_ENTRYP (val))
788 {
789 struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
790 val = cte->level2[byte1 - 32];
791 if (CHAR_TABLE_ENTRYP (val))
792 {
793 cte = XCHAR_TABLE_ENTRY (val);
794 assert (byte2 >= 32);
795 val = cte->level2[byte2 - 32];
796 assert (!CHAR_TABLE_ENTRYP (val));
797 }
798 }
799
800 return val;
801 }
802
803 #endif /* MULE */
804
805 Lisp_Object
806 get_char_table (Emchar ch, struct Lisp_Char_Table *ct)
807 {
808 #ifdef MULE
809 {
810 Lisp_Object charset;
811 int byte1, byte2;
812 Lisp_Object val;
813
814 BREAKUP_CHAR (ch, charset, byte1, byte2);
815
816 if (EQ (charset, Vcharset_ascii))
817 val = ct->ascii[byte1];
818 else if (EQ (charset, Vcharset_control_1))
819 val = ct->ascii[byte1 + 128];
820 else
821 {
822 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
823 val = ct->level1[lb];
824 if (CHAR_TABLE_ENTRYP (val))
825 {
826 struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
827 val = cte->level2[byte1 - 32];
828 if (CHAR_TABLE_ENTRYP (val))
829 {
830 cte = XCHAR_TABLE_ENTRY (val);
831 assert (byte2 >= 32);
832 val = cte->level2[byte2 - 32];
833 assert (!CHAR_TABLE_ENTRYP (val));
834 }
835 }
836 }
837
838 return val;
839 }
840 #else /* not MULE */
841 return ct->ascii[(unsigned char)ch];
842 #endif /* not MULE */
843 }
844
845
846 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
847 Find value for char CH in TABLE.
848 */
849 (ch, table))
850 {
851 struct Lisp_Char_Table *ct;
852
853 CHECK_CHAR_TABLE (table);
854 ct = XCHAR_TABLE (table);
855 CHECK_CHAR_COERCE_INT (ch);
856
857 return get_char_table (XCHAR (ch), ct);
858 }
859
860 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
861 Find value for a range in TABLE.
862 If there is more than one value, return MULTI (defaults to nil).
863 */
864 (range, table, multi))
865 {
866 struct Lisp_Char_Table *ct;
867 struct chartab_range rainj;
868
869 if (CHAR_OR_CHAR_INTP (range))
870 return Fget_char_table (range, table);
871 CHECK_CHAR_TABLE (table);
872 ct = XCHAR_TABLE (table);
873
874 decode_char_table_range (range, &rainj);
875 switch (rainj.type)
876 {
877 case CHARTAB_RANGE_ALL:
878 {
879 int i;
880 Lisp_Object first = ct->ascii[0];
881
882 for (i = 1; i < NUM_ASCII_CHARS; i++)
883 if (!EQ (first, ct->ascii[i]))
884 return multi;
885
886 #ifdef MULE
887 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
888 i++)
889 {
890 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
891 || i == LEADING_BYTE_ASCII
892 || i == LEADING_BYTE_CONTROL_1)
893 continue;
894 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
895 return multi;
896 }
897 #endif /* MULE */
898
899 return first;
900 }
901
902 #ifdef MULE
903 case CHARTAB_RANGE_CHARSET:
904 if (EQ (rainj.charset, Vcharset_ascii))
905 {
906 int i;
907 Lisp_Object first = ct->ascii[0];
908
909 for (i = 1; i < 128; i++)
910 if (!EQ (first, ct->ascii[i]))
911 return multi;
912 return first;
913 }
914
915 if (EQ (rainj.charset, Vcharset_control_1))
916 {
917 int i;
918 Lisp_Object first = ct->ascii[128];
919
920 for (i = 129; i < 160; i++)
921 if (!EQ (first, ct->ascii[i]))
922 return multi;
923 return first;
924 }
925
926 {
927 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
928 MIN_LEADING_BYTE];
929 if (CHAR_TABLE_ENTRYP (val))
930 return multi;
931 return val;
932 }
933
934 case CHARTAB_RANGE_ROW:
935 {
936 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
937 MIN_LEADING_BYTE];
938 if (!CHAR_TABLE_ENTRYP (val))
939 return val;
940 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
941 if (CHAR_TABLE_ENTRYP (val))
942 return multi;
943 return val;
944 }
945 #endif /* not MULE */
946
947 default:
948 abort ();
949 }
950
951 return Qnil; /* not reached */
952 }
953
954 static int
955 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
956 Error_behavior errb)
957 {
958 switch (type)
959 {
960 case CHAR_TABLE_TYPE_SYNTAX:
961 if (!ERRB_EQ (errb, ERROR_ME))
962 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
963 && CHAR_OR_CHAR_INTP (XCDR (value)));
964 if (CONSP (value))
965 {
966 Lisp_Object cdr = XCDR (value);
967 CHECK_INT (XCAR (value));
968 CHECK_CHAR_COERCE_INT (cdr);
969 }
970 else
971 CHECK_INT (value);
972 break;
973
974 #ifdef MULE
975 case CHAR_TABLE_TYPE_CATEGORY:
976 if (!ERRB_EQ (errb, ERROR_ME))
977 return CATEGORY_TABLE_VALUEP (value);
978 CHECK_CATEGORY_TABLE_VALUE (value);
979 break;
980 #endif /* MULE */
981
982 case CHAR_TABLE_TYPE_GENERIC:
983 return 1;
984
985 case CHAR_TABLE_TYPE_DISPLAY:
986 /* #### fix this */
987 maybe_signal_simple_error ("Display char tables not yet implemented",
988 value, Qchar_table, errb);
989 return 0;
990
991 case CHAR_TABLE_TYPE_CHAR:
992 if (!ERRB_EQ (errb, ERROR_ME))
993 return CHAR_OR_CHAR_INTP (value);
994 CHECK_CHAR_COERCE_INT (value);
995 break;
996
997 default:
998 abort ();
999 }
1000
1001 return 0; /* not reached */
1002 }
1003
1004 static Lisp_Object
1005 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
1006 {
1007 switch (type)
1008 {
1009 case CHAR_TABLE_TYPE_SYNTAX:
1010 if (CONSP (value))
1011 {
1012 Lisp_Object car = XCAR (value);
1013 Lisp_Object cdr = XCDR (value);
1014 CHECK_CHAR_COERCE_INT (cdr);
1015 return Fcons (car, cdr);
1016 }
1017 break;
1018 case CHAR_TABLE_TYPE_CHAR:
1019 CHECK_CHAR_COERCE_INT (value);
1020 break;
1021 default:
1022 break;
1023 }
1024 return value;
1025 }
1026
1027 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
1028 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
1029 */
1030 (value, char_table_type))
1031 {
1032 enum char_table_type type = symbol_to_char_table_type (char_table_type);
1033
1034 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
1035 }
1036
1037 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
1038 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
1039 */
1040 (value, char_table_type))
1041 {
1042 enum char_table_type type = symbol_to_char_table_type (char_table_type);
1043
1044 check_valid_char_table_value (value, type, ERROR_ME);
1045 return Qnil;
1046 }
1047
1048 /* Assign VAL to all characters in RANGE in char table CT. */
1049
1050 void
1051 put_char_table (struct Lisp_Char_Table *ct, struct chartab_range *range,
1052 Lisp_Object val)
1053 {
1054 switch (range->type)
1055 {
1056 case CHARTAB_RANGE_ALL:
1057 fill_char_table (ct, val);
1058 return; /* avoid the duplicate call to update_syntax_table() below,
1059 since fill_char_table() also did that. */
1060
1061 #ifdef MULE
1062 case CHARTAB_RANGE_CHARSET:
1063 if (EQ (range->charset, Vcharset_ascii))
1064 {
1065 int i;
1066 for (i = 0; i < 128; i++)
1067 ct->ascii[i] = val;
1068 }
1069 else if (EQ (range->charset, Vcharset_control_1))
1070 {
1071 int i;
1072 for (i = 128; i < 160; i++)
1073 ct->ascii[i] = val;
1074 }
1075 else
1076 {
1077 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1078 ct->level1[lb] = val;
1079 }
1080 break;
1081
1082 case CHARTAB_RANGE_ROW:
1083 {
1084 struct Lisp_Char_Table_Entry *cte;
1085 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
1086 /* make sure that there is a separate entry for the row. */
1087 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1088 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1089 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1090 cte->level2[range->row - 32] = val;
1091 }
1092 break;
1093 #endif /* MULE */
1094
1095 case CHARTAB_RANGE_CHAR:
1096 #ifdef MULE
1097 {
1098 Lisp_Object charset;
1099 int byte1, byte2;
1100
1101 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
1102 if (EQ (charset, Vcharset_ascii))
1103 ct->ascii[byte1] = val;
1104 else if (EQ (charset, Vcharset_control_1))
1105 ct->ascii[byte1 + 128] = val;
1106 else
1107 {
1108 struct Lisp_Char_Table_Entry *cte;
1109 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1110 /* make sure that there is a separate entry for the row. */
1111 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
1112 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
1113 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
1114 /* now CTE is a char table entry for the charset;
1115 each entry is for a single row (or character of
1116 a one-octet charset). */
1117 if (XCHARSET_DIMENSION (charset) == 1)
1118 cte->level2[byte1 - 32] = val;
1119 else
1120 {
1121 /* assigning to one character in a two-octet charset. */
1122 /* make sure that the charset row contains a separate
1123 entry for each character. */
1124 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
1125 cte->level2[byte1 - 32] =
1126 make_char_table_entry (cte->level2[byte1 - 32]);
1127 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
1128 cte->level2[byte2 - 32] = val;
1129 }
1130 }
1131 }
1132 #else /* not MULE */
1133 ct->ascii[(unsigned char) (range->ch)] = val;
1134 break;
1135 #endif /* not MULE */
1136 }
1137
1138 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1139 update_syntax_table (ct);
1140 }
1141
1142 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
1143 Set the value for chars in RANGE to be VAL in TABLE.
1144
1145 RANGE specifies one or more characters to be affected and should be
1146 one of the following:
1147
1148 -- t (all characters are affected)
1149 -- A charset (only allowed when Mule support is present)
1150 -- A vector of two elements: a two-octet charset and a row number
1151 (only allowed when Mule support is present)
1152 -- A single character
1153
1154 VAL must be a value appropriate for the type of TABLE.
1155 See `valid-char-table-type-p'.
1156 */
1157 (range, val, table))
1158 {
1159 struct Lisp_Char_Table *ct;
1160 struct chartab_range rainj;
1161
1162 CHECK_CHAR_TABLE (table);
1163 ct = XCHAR_TABLE (table);
1164 check_valid_char_table_value (val, ct->type, ERROR_ME);
1165 decode_char_table_range (range, &rainj);
1166 val = canonicalize_char_table_value (val, ct->type);
1167 put_char_table (ct, &rainj, val);
1168 return Qnil;
1169 }
1170
1171 /* Map FN over the ASCII chars in CT. */
1172
1173 static int
1174 map_over_charset_ascii (struct Lisp_Char_Table *ct,
1175 int (*fn) (struct chartab_range *range,
1176 Lisp_Object val, void *arg),
1177 void *arg)
1178 {
1179 struct chartab_range rainj;
1180 int i, retval;
1181 int start = 0;
1182 #ifdef MULE
1183 int stop = 128;
1184 #else
1185 int stop = 256;
1186 #endif
1187
1188 rainj.type = CHARTAB_RANGE_CHAR;
1189
1190 for (i = start, retval = 0; i < stop && retval == 0; i++)
1191 {
1192 rainj.ch = (Emchar) i;
1193 retval = (fn) (&rainj, ct->ascii[i], arg);
1194 }
1195
1196 return retval;
1197 }
1198
1199 #ifdef MULE
1200
1201 /* Map FN over the Control-1 chars in CT. */
1202
1203 static int
1204 map_over_charset_control_1 (struct Lisp_Char_Table *ct,
1205 int (*fn) (struct chartab_range *range,
1206 Lisp_Object val, void *arg),
1207 void *arg)
1208 {
1209 struct chartab_range rainj;
1210 int i, retval;
1211 int start = 128;
1212 int stop = start + 32;
1213
1214 rainj.type = CHARTAB_RANGE_CHAR;
1215
1216 for (i = start, retval = 0; i < stop && retval == 0; i++)
1217 {
1218 rainj.ch = (Emchar) (i);
1219 retval = (fn) (&rainj, ct->ascii[i], arg);
1220 }
1221
1222 return retval;
1223 }
1224
1225 /* Map FN over the row ROW of two-byte charset CHARSET.
1226 There must be a separate value for that row in the char table.
1227 CTE specifies the char table entry for CHARSET. */
1228
1229 static int
1230 map_over_charset_row (struct Lisp_Char_Table_Entry *cte,
1231 Lisp_Object charset, int row,
1232 int (*fn) (struct chartab_range *range,
1233 Lisp_Object val, void *arg),
1234 void *arg)
1235 {
1236 Lisp_Object val = cte->level2[row - 32];
1237
1238 if (!CHAR_TABLE_ENTRYP (val))
1239 {
1240 struct chartab_range rainj;
1241
1242 rainj.type = CHARTAB_RANGE_ROW;
1243 rainj.charset = charset;
1244 rainj.row = row;
1245 return (fn) (&rainj, val, arg);
1246 }
1247 else
1248 {
1249 struct chartab_range rainj;
1250 int i, retval;
1251 int charset94_p = (XCHARSET_CHARS (charset) == 94);
1252 int start = charset94_p ? 33 : 32;
1253 int stop = charset94_p ? 127 : 128;
1254
1255 cte = XCHAR_TABLE_ENTRY (val);
1256
1257 rainj.type = CHARTAB_RANGE_CHAR;
1258
1259 for (i = start, retval = 0; i < stop && retval == 0; i++)
1260 {
1261 rainj.ch = MAKE_CHAR (charset, row, i);
1262 retval = (fn) (&rainj, cte->level2[i - 32], arg);
1263 }
1264 return retval;
1265 }
1266 }
1267
1268
1269 static int
1270 map_over_other_charset (struct Lisp_Char_Table *ct, int lb,
1271 int (*fn) (struct chartab_range *range,
1272 Lisp_Object val, void *arg),
1273 void *arg)
1274 {
1275 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
1276 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
1277
1278 if (!CHARSETP (charset)
1279 || lb == LEADING_BYTE_ASCII
1280 || lb == LEADING_BYTE_CONTROL_1)
1281 return 0;
1282
1283 if (!CHAR_TABLE_ENTRYP (val))
1284 {
1285 struct chartab_range rainj;
1286
1287 rainj.type = CHARTAB_RANGE_CHARSET;
1288 rainj.charset = charset;
1289 return (fn) (&rainj, val, arg);
1290 }
1291
1292 {
1293 struct Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1294 int charset94_p = (XCHARSET_CHARS (charset) == 94);
1295 int start = charset94_p ? 33 : 32;
1296 int stop = charset94_p ? 127 : 128;
1297 int i, retval;
1298
1299 if (XCHARSET_DIMENSION (charset) == 1)
1300 {
1301 struct chartab_range rainj;
1302 rainj.type = CHARTAB_RANGE_CHAR;
1303
1304 for (i = start, retval = 0; i < stop && retval == 0; i++)
1305 {
1306 rainj.ch = MAKE_CHAR (charset, i, 0);
1307 retval = (fn) (&rainj, cte->level2[i - 32], arg);
1308 }
1309 }
1310 else
1311 {
1312 for (i = start, retval = 0; i < stop && retval == 0; i++)
1313 retval = map_over_charset_row (cte, charset, i, fn, arg);
1314 }
1315
1316 return retval;
1317 }
1318 }
1319
1320 #endif /* MULE */
1321
1322 /* Map FN (with client data ARG) over range RANGE in char table CT.
1323 Mapping stops the first time FN returns non-zero, and that value
1324 becomes the return value of map_char_table(). */
1325
1326 int
1327 map_char_table (struct Lisp_Char_Table *ct,
1328 struct chartab_range *range,
1329 int (*fn) (struct chartab_range *range,
1330 Lisp_Object val, void *arg),
1331 void *arg)
1332 {
1333 switch (range->type)
1334 {
1335 case CHARTAB_RANGE_ALL:
1336 {
1337 int retval;
1338
1339 retval = map_over_charset_ascii (ct, fn, arg);
1340 if (retval)
1341 return retval;
1342 #ifdef MULE
1343 retval = map_over_charset_control_1 (ct, fn, arg);
1344 if (retval)
1345 return retval;
1346 {
1347 int i;
1348 int start = MIN_LEADING_BYTE;
1349 int stop = start + NUM_LEADING_BYTES;
1350
1351 for (i = start, retval = 0; i < stop && retval == 0; i++)
1352 {
1353 retval = map_over_other_charset (ct, i, fn, arg);
1354 }
1355 }
1356 #endif /* MULE */
1357 return retval;
1358 }
1359
1360 #ifdef MULE
1361 case CHARTAB_RANGE_CHARSET:
1362 return map_over_other_charset (ct,
1363 XCHARSET_LEADING_BYTE (range->charset),
1364 fn, arg);
1365
1366 case CHARTAB_RANGE_ROW:
1367 {
1368 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE];
1369 if (!CHAR_TABLE_ENTRYP (val))
1370 {
1371 struct chartab_range rainj;
1372
1373 rainj.type = CHARTAB_RANGE_ROW;
1374 rainj.charset = range->charset;
1375 rainj.row = range->row;
1376 return (fn) (&rainj, val, arg);
1377 }
1378 else
1379 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
1380 range->charset, range->row,
1381 fn, arg);
1382 }
1383 #endif /* MULE */
1384
1385 case CHARTAB_RANGE_CHAR:
1386 {
1387 Emchar ch = range->ch;
1388 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
1389 struct chartab_range rainj;
1390
1391 rainj.type = CHARTAB_RANGE_CHAR;
1392 rainj.ch = ch;
1393 return (fn) (&rainj, val, arg);
1394 }
1395
1396 default:
1397 abort ();
1398 }
1399
1400 return 0;
1401 }
1402
1403 struct slow_map_char_table_arg
1404 {
1405 Lisp_Object function;
1406 Lisp_Object retval;
1407 };
1408
1409 static int
1410 slow_map_char_table_fun (struct chartab_range *range,
1411 Lisp_Object val, void *arg)
1412 {
1413 Lisp_Object ranjarg = Qnil;
1414 struct slow_map_char_table_arg *closure =
1415 (struct slow_map_char_table_arg *) arg;
1416
1417 switch (range->type)
1418 {
1419 case CHARTAB_RANGE_ALL:
1420 ranjarg = Qt;
1421 break;
1422
1423 #ifdef MULE
1424 case CHARTAB_RANGE_CHARSET:
1425 ranjarg = XCHARSET_NAME (range->charset);
1426 break;
1427
1428 case CHARTAB_RANGE_ROW:
1429 ranjarg = vector2 (XCHARSET_NAME (range->charset),
1430 make_int (range->row));
1431 break;
1432 #endif /* MULE */
1433 case CHARTAB_RANGE_CHAR:
1434 ranjarg = make_char (range->ch);
1435 break;
1436 default:
1437 abort ();
1438 }
1439
1440 closure->retval = call2 (closure->function, ranjarg, val);
1441 return !NILP (closure->retval);
1442 }
1443
1444 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
1445 Map FUNCTION over entries in TABLE, calling it with two args,
1446 each key and value in the table.
1447
1448 RANGE specifies a subrange to map over and is in the same format as
1449 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
1450 the entire table.
1451 */
1452 (function, table, range))
1453 {
1454 struct Lisp_Char_Table *ct;
1455 struct slow_map_char_table_arg slarg;
1456 struct gcpro gcpro1, gcpro2;
1457 struct chartab_range rainj;
1458
1459 CHECK_CHAR_TABLE (table);
1460 ct = XCHAR_TABLE (table);
1461 if (NILP (range))
1462 range = Qt;
1463 decode_char_table_range (range, &rainj);
1464 slarg.function = function;
1465 slarg.retval = Qnil;
1466 GCPRO2 (slarg.function, slarg.retval);
1467 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
1468 UNGCPRO;
1469
1470 return slarg.retval;
1471 }
1472
1473
1474
1475 /************************************************************************/
1476 /* Char table read syntax */
1477 /************************************************************************/
1478
1479 static int
1480 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
1481 Error_behavior errb)
1482 {
1483 /* #### should deal with ERRB */
1484 symbol_to_char_table_type (value);
1485 return 1;
1486 }
1487
1488 static int
1489 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
1490 Error_behavior errb)
1491 {
1492 Lisp_Object rest;
1493
1494 /* #### should deal with ERRB */
1495 EXTERNAL_LIST_LOOP (rest, value)
1496 {
1497 Lisp_Object range = XCAR (rest);
1498 struct chartab_range dummy;
1499
1500 rest = XCDR (rest);
1501 if (!CONSP (rest))
1502 signal_simple_error ("Invalid list format", value);
1503 if (CONSP (range))
1504 {
1505 if (!CONSP (XCDR (range))
1506 || !NILP (XCDR (XCDR (range))))
1507 signal_simple_error ("Invalid range format", range);
1508 decode_char_table_range (XCAR (range), &dummy);
1509 decode_char_table_range (XCAR (XCDR (range)), &dummy);
1510 }
1511 else
1512 decode_char_table_range (range, &dummy);
1513 }
1514
1515 return 1;
1516 }
1517
1518 static Lisp_Object
1519 chartab_instantiate (Lisp_Object data)
1520 {
1521 Lisp_Object chartab;
1522 Lisp_Object type = Qgeneric;
1523 Lisp_Object dataval = Qnil;
1524
1525 while (!NILP (data))
1526 {
1527 Lisp_Object keyw = Fcar (data);
1528 Lisp_Object valw;
1529
1530 data = Fcdr (data);
1531 valw = Fcar (data);
1532 data = Fcdr (data);
1533 if (EQ (keyw, Qtype))
1534 type = valw;
1535 else if (EQ (keyw, Qdata))
1536 dataval = valw;
1537 }
1538
1539 chartab = Fmake_char_table (type);
1540
1541 data = dataval;
1542 while (!NILP (data))
1543 {
1544 Lisp_Object range = Fcar (data);
1545 Lisp_Object val = Fcar (Fcdr (data));
1546
1547 data = Fcdr (Fcdr (data));
1548 if (CONSP (range))
1549 {
1550 if (CHAR_OR_CHAR_INTP (XCAR (range)))
1551 {
1552 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
1553 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
1554 Emchar i;
1555
1556 for (i = first; i <= last; i++)
1557 Fput_char_table (make_char (i), val, chartab);
1558 }
1559 else
1560 abort ();
1561 }
1562 else
1563 Fput_char_table (range, val, chartab);
1564 }
1565
1566 return chartab;
1567 }
1568
1569 #ifdef MULE
1570
1571
1572 /************************************************************************/
1573 /* Category Tables, specifically */
1574 /************************************************************************/
1575
1576 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
1577 Return t if ARG is a category table.
1578 A category table is a type of char table used for keeping track of
1579 categories. Categories are used for classifying characters for use
1580 in regexps -- you can refer to a category rather than having to use
1581 a complicated [] expression (and category lookups are significantly
1582 faster).
1583
1584 There are 95 different categories available, one for each printable
1585 character (including space) in the ASCII charset. Each category
1586 is designated by one such character, called a "category designator".
1587 They are specified in a regexp using the syntax "\\cX", where X is
1588 a category designator.
1589
1590 A category table specifies, for each character, the categories that
1591 the character is in. Note that a character can be in more than one
1592 category. More specifically, a category table maps from a character
1593 to either the value nil (meaning the character is in no categories)
1594 or a 95-element bit vector, specifying for each of the 95 categories
1595 whether the character is in that category.
1596
1597 Special Lisp functions are provided that abstract this, so you do not
1598 have to directly manipulate bit vectors.
1599 */
1600 (obj))
1601 {
1602 return (CHAR_TABLEP (obj) &&
1603 XCHAR_TABLE_TYPE (obj) == CHAR_TABLE_TYPE_CATEGORY) ?
1604 Qt : Qnil;
1605 }
1606
1607 static Lisp_Object
1608 check_category_table (Lisp_Object obj, Lisp_Object def)
1609 {
1610 if (NILP (obj))
1611 obj = def;
1612 while (NILP (Fcategory_table_p (obj)))
1613 obj = wrong_type_argument (Qcategory_table_p, obj);
1614 return obj;
1615 }
1616
1617 int
1618 check_category_char (Emchar ch, Lisp_Object table,
1619 unsigned int designator, unsigned int not)
1620 {
1621 REGISTER Lisp_Object temp;
1622 struct Lisp_Char_Table *ctbl;
1623 #ifdef ERROR_CHECK_TYPECHECK
1624 if (NILP (Fcategory_table_p (table)))
1625 signal_simple_error ("Expected category table", table);
1626 #endif
1627 ctbl = XCHAR_TABLE (table);
1628 temp = get_char_table (ch, ctbl);
1629 if (NILP (temp))
1630 return not;
1631
1632 designator -= ' ';
1633 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
1634 }
1635
1636 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
1637 Return t if category of a character at POS includes DESIGNATOR,
1638 else return nil. Optional third arg specifies which buffer
1639 \(defaulting to current), and fourth specifies the CATEGORY-TABLE,
1640 \(defaulting to the buffer's category table).
1641 */
1642 (pos, designator, buffer, category_table))
1643 {
1644 Lisp_Object ctbl;
1645 Emchar ch;
1646 unsigned int des;
1647 struct buffer *buf = decode_buffer (buffer, 0);
1648
1649 CHECK_INT (pos);
1650 CHECK_CATEGORY_DESIGNATOR (designator);
1651 des = XCHAR (designator);
1652 ctbl = check_category_table (category_table, Vstandard_category_table);
1653 ch = BUF_FETCH_CHAR (buf, XINT (pos));
1654 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1655 }
1656
1657 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
1658 Return t if category of character CHR includes DESIGNATOR, else nil.
1659 Optional third arg specifies the CATEGORY-TABLE to use,
1660 which defaults to the system default table.
1661 */
1662 (chr, designator, category_table))
1663 {
1664 Lisp_Object ctbl;
1665 Emchar ch;
1666 unsigned int des;
1667
1668 CHECK_CATEGORY_DESIGNATOR (designator);
1669 des = XCHAR (designator);
1670 CHECK_CHAR (chr);
1671 ch = XCHAR (chr);
1672 ctbl = check_category_table (category_table, Vstandard_category_table);
1673 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
1674 }
1675
1676 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
1677 Return the current category table.
1678 This is the one specified by the current buffer, or by BUFFER if it
1679 is non-nil.
1680 */
1681 (buffer))
1682 {
1683 return decode_buffer (buffer, 0)->category_table;
1684 }
1685
1686 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
1687 Return the standard category table.
1688 This is the one used for new buffers.
1689 */
1690 ())
1691 {
1692 return Vstandard_category_table;
1693 }
1694
1695 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
1696 Construct a new category table and return it.
1697 It is a copy of the TABLE, which defaults to the standard category table.
1698 */
1699 (table))
1700 {
1701 if (NILP (Vstandard_category_table))
1702 return Fmake_char_table (Qcategory);
1703
1704 table = check_category_table (table, Vstandard_category_table);
1705 return Fcopy_char_table (table);
1706 }
1707
1708 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
1709 Select a new category table for BUFFER.
1710 One argument, a category table.
1711 BUFFER defaults to the current buffer if omitted.
1712 */
1713 (table, buffer))
1714 {
1715 struct buffer *buf = decode_buffer (buffer, 0);
1716 table = check_category_table (table, Qnil);
1717 buf->category_table = table;
1718 /* Indicate that this buffer now has a specified category table. */
1719 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
1720 return table;
1721 }
1722
1723 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
1724 Return t if ARG is a category designator (a char in the range ' ' to '~').
1725 */
1726 (obj))
1727 {
1728 return CATEGORY_DESIGNATORP (obj) ? Qt : Qnil;
1729 }
1730
1731 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
1732 Return t if ARG is a category table value.
1733 Valid values are nil or a bit vector of size 95.
1734 */
1735 (obj))
1736 {
1737 return CATEGORY_TABLE_VALUEP (obj) ? Qt : Qnil;
1738 }
1739
1740
1741 #define CATEGORYP(x) \
1742 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
1743
1744 #define CATEGORY_SET(c) \
1745 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
1746
1747 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
1748 The faster version of `!NILP (Faref (category_set, category))'. */
1749 #define CATEGORY_MEMBER(category, category_set) \
1750 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
1751
1752 /* Return 1 if there is a word boundary between two word-constituent
1753 characters C1 and C2 if they appear in this order, else return 0.
1754 Use the macro WORD_BOUNDARY_P instead of calling this function
1755 directly. */
1756
1757 int word_boundary_p (Emchar c1, Emchar c2);
1758 int
1759 word_boundary_p (Emchar c1, Emchar c2)
1760 {
1761 Lisp_Object category_set1, category_set2;
1762 Lisp_Object tail;
1763 int default_result;
1764
1765 #if 0
1766 if (COMPOSITE_CHAR_P (c1))
1767 c1 = cmpchar_component (c1, 0, 1);
1768 if (COMPOSITE_CHAR_P (c2))
1769 c2 = cmpchar_component (c2, 0, 1);
1770 #endif
1771
1772 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
1773 {
1774 tail = Vword_separating_categories;
1775 default_result = 0;
1776 }
1777 else
1778 {
1779 tail = Vword_combining_categories;
1780 default_result = 1;
1781 }
1782
1783 category_set1 = CATEGORY_SET (c1);
1784 if (NILP (category_set1))
1785 return default_result;
1786 category_set2 = CATEGORY_SET (c2);
1787 if (NILP (category_set2))
1788 return default_result;
1789
1790 for (; CONSP (tail); tail = XCONS (tail)->cdr)
1791 {
1792 Lisp_Object elt = XCONS(tail)->car;
1793
1794 if (CONSP (elt)
1795 && CATEGORYP (XCONS (elt)->car)
1796 && CATEGORYP (XCONS (elt)->cdr)
1797 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
1798 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
1799 return !default_result;
1800 }
1801 return default_result;
1802 }
1803 #endif /* MULE */
1804
1805
1806 void
1807 syms_of_chartab (void)
1808 {
1809 #ifdef MULE
1810 defsymbol (&Qcategory_table_p, "category-table-p");
1811 defsymbol (&Qcategory_designator_p, "category-designator-p");
1812 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
1813 #endif /* MULE */
1814
1815 defsymbol (&Qchar_table, "char-table");
1816 defsymbol (&Qchar_tablep, "char-table-p");
1817
1818 DEFSUBR (Fchar_table_p);
1819 DEFSUBR (Fchar_table_type_list);
1820 DEFSUBR (Fvalid_char_table_type_p);
1821 DEFSUBR (Fchar_table_type);
1822 DEFSUBR (Freset_char_table);
1823 DEFSUBR (Fmake_char_table);
1824 DEFSUBR (Fcopy_char_table);
1825 DEFSUBR (Fget_char_table);
1826 DEFSUBR (Fget_range_char_table);
1827 DEFSUBR (Fvalid_char_table_value_p);
1828 DEFSUBR (Fcheck_valid_char_table_value);
1829 DEFSUBR (Fput_char_table);
1830 DEFSUBR (Fmap_char_table);
1831
1832 #ifdef MULE
1833 DEFSUBR (Fcategory_table_p);
1834 DEFSUBR (Fcategory_table);
1835 DEFSUBR (Fstandard_category_table);
1836 DEFSUBR (Fcopy_category_table);
1837 DEFSUBR (Fset_category_table);
1838 DEFSUBR (Fcheck_category_at);
1839 DEFSUBR (Fchar_in_category_p);
1840 DEFSUBR (Fcategory_designator_p);
1841 DEFSUBR (Fcategory_table_value_p);
1842 #endif /* MULE */
1843
1844 }
1845
1846 void
1847 vars_of_chartab (void)
1848 {
1849 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
1850 Vall_syntax_tables = Qnil;
1851 pdump_wire_list (&Vall_syntax_tables);
1852 }
1853
1854 void
1855 structure_type_create_chartab (void)
1856 {
1857 struct structure_type *st;
1858
1859 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
1860
1861 define_structure_type_keyword (st, Qtype, chartab_type_validate);
1862 define_structure_type_keyword (st, Qdata, chartab_data_validate);
1863 }
1864
1865 void
1866 complex_vars_of_chartab (void)
1867 {
1868 #ifdef MULE
1869 /* Set this now, so first buffer creation can refer to it. */
1870 /* Make it nil before calling copy-category-table
1871 so that copy-category-table will know not to try to copy from garbage */
1872 Vstandard_category_table = Qnil;
1873 Vstandard_category_table = Fcopy_category_table (Qnil);
1874 staticpro (&Vstandard_category_table);
1875
1876 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
1877 List of pair (cons) of categories to determine word boundary.
1878
1879 Emacs treats a sequence of word constituent characters as a single
1880 word (i.e. finds no word boundary between them) iff they belongs to
1881 the same charset. But, exceptions are allowed in the following cases.
1882
1883 (1) The case that characters are in different charsets is controlled
1884 by the variable `word-combining-categories'.
1885
1886 Emacs finds no word boundary between characters of different charsets
1887 if they have categories matching some element of this list.
1888
1889 More precisely, if an element of this list is a cons of category CAT1
1890 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1891 C2 which has CAT2, there's no word boundary between C1 and C2.
1892
1893 For instance, to tell that ASCII characters and Latin-1 characters can
1894 form a single word, the element `(?l . ?l)' should be in this list
1895 because both characters have the category `l' (Latin characters).
1896
1897 (2) The case that character are in the same charset is controlled by
1898 the variable `word-separating-categories'.
1899
1900 Emacs find a word boundary between characters of the same charset
1901 if they have categories matching some element of this list.
1902
1903 More precisely, if an element of this list is a cons of category CAT1
1904 and CAT2, and a multibyte character C1 which has CAT1 is followed by
1905 C2 which has CAT2, there's a word boundary between C1 and C2.
1906
1907 For instance, to tell that there's a word boundary between Japanese
1908 Hiragana and Japanese Kanji (both are in the same charset), the
1909 element `(?H . ?C) should be in this list.
1910 */ );
1911
1912 Vword_combining_categories = Qnil;
1913
1914 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
1915 List of pair (cons) of categories to determine word boundary.
1916 See the documentation of the variable `word-combining-categories'.
1917 */ );
1918
1919 Vword_separating_categories = Qnil;
1920 #endif /* MULE */
1921 }