Mercurial > hg > xemacs-beta

comparison src/chartab.c @ 70:131b0175ea99 r20-0b30

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