New function `locate-user-emacs-file'.
[emacs.git] / src / chartab.c
blobfdce932993f8809bd344b24cdd493ba5cbf47020
1 /* chartab.c -- char-table support
2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008
3 National Institute of Advanced Industrial Science and Technology (AIST)
4 Registration Number H13PRO009
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
21 #include <config.h>
22 #include "lisp.h"
23 #include "character.h"
24 #include "charset.h"
25 #include "ccl.h"
27 /* 64/16/32/128 */
29 /* Number of elements in Nth level char-table. */
30 const int chartab_size[4] =
31 { (1 << CHARTAB_SIZE_BITS_0),
32 (1 << CHARTAB_SIZE_BITS_1),
33 (1 << CHARTAB_SIZE_BITS_2),
34 (1 << CHARTAB_SIZE_BITS_3) };
36 /* Number of characters each element of Nth level char-table
37 covers. */
38 const int chartab_chars[4] =
39 { (1 << (CHARTAB_SIZE_BITS_1 + CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3)),
40 (1 << (CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3)),
41 (1 << CHARTAB_SIZE_BITS_3),
42 1 };
44 /* Number of characters (in bits) each element of Nth level char-table
45 covers. */
46 const int chartab_bits[4] =
47 { (CHARTAB_SIZE_BITS_1 + CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3),
48 (CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3),
49 CHARTAB_SIZE_BITS_3,
50 0 };
52 #define CHARTAB_IDX(c, depth, min_char) \
53 (((c) - (min_char)) >> chartab_bits[(depth)])
56 DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
57 doc: /* Return a newly created char-table, with purpose PURPOSE.
58 Each element is initialized to INIT, which defaults to nil.
60 PURPOSE should be a symbol. If it has a `char-table-extra-slots'
61 property, the property's value should be an integer between 0 and 10
62 that specifies how many extra slots the char-table has. Otherwise,
63 the char-table has no extra slot. */)
64 (purpose, init)
65 register Lisp_Object purpose, init;
67 Lisp_Object vector;
68 Lisp_Object n;
69 int n_extras;
70 int size;
72 CHECK_SYMBOL (purpose);
73 n = Fget (purpose, Qchar_table_extra_slots);
74 if (NILP (n))
75 n_extras = 0;
76 else
78 CHECK_NATNUM (n);
79 n_extras = XINT (n);
80 if (n_extras > 10)
81 args_out_of_range (n, Qnil);
84 size = VECSIZE (struct Lisp_Char_Table) - 1 + n_extras;
85 vector = Fmake_vector (make_number (size), init);
86 XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
87 XCHAR_TABLE (vector)->parent = Qnil;
88 XCHAR_TABLE (vector)->purpose = purpose;
89 XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
90 return vector;
93 static Lisp_Object
94 make_sub_char_table (depth, min_char, defalt)
95 int depth, min_char;
96 Lisp_Object defalt;
98 Lisp_Object table;
99 int size = VECSIZE (struct Lisp_Sub_Char_Table) - 1 + chartab_size[depth];
101 table = Fmake_vector (make_number (size), defalt);
102 XSETPVECTYPE (XVECTOR (table), PVEC_SUB_CHAR_TABLE);
103 XSUB_CHAR_TABLE (table)->depth = make_number (depth);
104 XSUB_CHAR_TABLE (table)->min_char = make_number (min_char);
106 return table;
109 static Lisp_Object
110 char_table_ascii (table)
111 Lisp_Object table;
113 Lisp_Object sub;
115 sub = XCHAR_TABLE (table)->contents[0];
116 if (! SUB_CHAR_TABLE_P (sub))
117 return sub;
118 sub = XSUB_CHAR_TABLE (sub)->contents[0];
119 if (! SUB_CHAR_TABLE_P (sub))
120 return sub;
121 return XSUB_CHAR_TABLE (sub)->contents[0];
124 Lisp_Object
125 copy_sub_char_table (table)
126 Lisp_Object table;
128 Lisp_Object copy;
129 int depth = XINT (XSUB_CHAR_TABLE (table)->depth);
130 int min_char = XINT (XSUB_CHAR_TABLE (table)->min_char);
131 Lisp_Object val;
132 int i;
134 copy = make_sub_char_table (depth, min_char, Qnil);
135 /* Recursively copy any sub char-tables. */
136 for (i = 0; i < chartab_size[depth]; i++)
138 val = XSUB_CHAR_TABLE (table)->contents[i];
139 if (SUB_CHAR_TABLE_P (val))
140 XSUB_CHAR_TABLE (copy)->contents[i] = copy_sub_char_table (val);
141 else
142 XSUB_CHAR_TABLE (copy)->contents[i] = val;
145 return copy;
149 Lisp_Object
150 copy_char_table (table)
151 Lisp_Object table;
153 Lisp_Object copy;
154 int size = XCHAR_TABLE (table)->size & PSEUDOVECTOR_SIZE_MASK;
155 int i;
157 copy = Fmake_vector (make_number (size), Qnil);
158 XSETPVECTYPE (XVECTOR (copy), PVEC_CHAR_TABLE);
159 XCHAR_TABLE (copy)->defalt = XCHAR_TABLE (table)->defalt;
160 XCHAR_TABLE (copy)->parent = XCHAR_TABLE (table)->parent;
161 XCHAR_TABLE (copy)->purpose = XCHAR_TABLE (table)->purpose;
162 for (i = 0; i < chartab_size[0]; i++)
163 XCHAR_TABLE (copy)->contents[i]
164 = (SUB_CHAR_TABLE_P (XCHAR_TABLE (table)->contents[i])
165 ? copy_sub_char_table (XCHAR_TABLE (table)->contents[i])
166 : XCHAR_TABLE (table)->contents[i]);
167 XCHAR_TABLE (copy)->ascii = char_table_ascii (copy);
168 size -= VECSIZE (struct Lisp_Char_Table) - 1;
169 for (i = 0; i < size; i++)
170 XCHAR_TABLE (copy)->extras[i] = XCHAR_TABLE (table)->extras[i];
172 XSETCHAR_TABLE (copy, XCHAR_TABLE (copy));
173 return copy;
176 Lisp_Object
177 sub_char_table_ref (table, c)
178 Lisp_Object table;
179 int c;
181 struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
182 int depth = XINT (tbl->depth);
183 int min_char = XINT (tbl->min_char);
184 Lisp_Object val;
186 val = tbl->contents[CHARTAB_IDX (c, depth, min_char)];
187 if (SUB_CHAR_TABLE_P (val))
188 val = sub_char_table_ref (val, c);
189 return val;
192 Lisp_Object
193 char_table_ref (table, c)
194 Lisp_Object table;
195 int c;
197 struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
198 Lisp_Object val;
200 if (ASCII_CHAR_P (c))
202 val = tbl->ascii;
203 if (SUB_CHAR_TABLE_P (val))
204 val = XSUB_CHAR_TABLE (val)->contents[c];
206 else
208 val = tbl->contents[CHARTAB_IDX (c, 0, 0)];
209 if (SUB_CHAR_TABLE_P (val))
210 val = sub_char_table_ref (val, c);
212 if (NILP (val))
214 val = tbl->defalt;
215 if (NILP (val) && CHAR_TABLE_P (tbl->parent))
216 val = char_table_ref (tbl->parent, c);
218 return val;
221 static Lisp_Object
222 sub_char_table_ref_and_range (table, c, from, to, defalt)
223 Lisp_Object table;
224 int c;
225 int *from, *to;
226 Lisp_Object defalt;
228 struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
229 int depth = XINT (tbl->depth);
230 int min_char = XINT (tbl->min_char);
231 int max_char = min_char + chartab_chars[depth - 1] - 1;
232 int index = CHARTAB_IDX (c, depth, min_char);
233 Lisp_Object val;
235 val = tbl->contents[index];
236 *from = min_char + index * chartab_chars[depth];
237 *to = *from + chartab_chars[depth] - 1;
238 if (SUB_CHAR_TABLE_P (val))
239 val = sub_char_table_ref_and_range (val, c, from, to, defalt);
240 else if (NILP (val))
241 val = defalt;
243 while (*from > min_char
244 && *from == min_char + index * chartab_chars[depth])
246 Lisp_Object this_val;
247 int this_from = *from - chartab_chars[depth];
248 int this_to = *from - 1;
250 index--;
251 this_val = tbl->contents[index];
252 if (SUB_CHAR_TABLE_P (this_val))
253 this_val = sub_char_table_ref_and_range (this_val, this_to,
254 &this_from, &this_to,
255 defalt);
256 else if (NILP (this_val))
257 this_val = defalt;
259 if (! EQ (this_val, val))
260 break;
261 *from = this_from;
263 index = CHARTAB_IDX (c, depth, min_char);
264 while (*to < max_char
265 && *to == min_char + (index + 1) * chartab_chars[depth] - 1)
267 Lisp_Object this_val;
268 int this_from = *to + 1;
269 int this_to = this_from + chartab_chars[depth] - 1;
271 index++;
272 this_val = tbl->contents[index];
273 if (SUB_CHAR_TABLE_P (this_val))
274 this_val = sub_char_table_ref_and_range (this_val, this_from,
275 &this_from, &this_to,
276 defalt);
277 else if (NILP (this_val))
278 this_val = defalt;
279 if (! EQ (this_val, val))
280 break;
281 *to = this_to;
284 return val;
288 /* Return the value for C in char-table TABLE. Set *FROM and *TO to
289 the range of characters (containing C) that have the same value as
290 C. It is not assured that the value of (*FROM - 1) and (*TO + 1)
291 is different from that of C. */
293 Lisp_Object
294 char_table_ref_and_range (table, c, from, to)
295 Lisp_Object table;
296 int c;
297 int *from, *to;
299 struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
300 int index = CHARTAB_IDX (c, 0, 0);
301 Lisp_Object val;
303 val = tbl->contents[index];
304 *from = index * chartab_chars[0];
305 *to = *from + chartab_chars[0] - 1;
306 if (SUB_CHAR_TABLE_P (val))
307 val = sub_char_table_ref_and_range (val, c, from, to, tbl->defalt);
308 else if (NILP (val))
309 val = tbl->defalt;
311 while (*from > 0 && *from == index * chartab_chars[0])
313 Lisp_Object this_val;
314 int this_from = *from - chartab_chars[0];
315 int this_to = *from - 1;
317 index--;
318 this_val = tbl->contents[index];
319 if (SUB_CHAR_TABLE_P (this_val))
320 this_val = sub_char_table_ref_and_range (this_val, this_to,
321 &this_from, &this_to,
322 tbl->defalt);
323 else if (NILP (this_val))
324 this_val = tbl->defalt;
326 if (! EQ (this_val, val))
327 break;
328 *from = this_from;
330 while (*to < MAX_CHAR && *to == (index + 1) * chartab_chars[0] - 1)
332 Lisp_Object this_val;
333 int this_from = *to + 1;
334 int this_to = this_from + chartab_chars[0] - 1;
336 index++;
337 this_val = tbl->contents[index];
338 if (SUB_CHAR_TABLE_P (this_val))
339 this_val = sub_char_table_ref_and_range (this_val, this_from,
340 &this_from, &this_to,
341 tbl->defalt);
342 else if (NILP (this_val))
343 this_val = tbl->defalt;
344 if (! EQ (this_val, val))
345 break;
346 *to = this_to;
349 return val;
353 #define ASET_RANGE(ARRAY, FROM, TO, LIMIT, VAL) \
354 do { \
355 int limit = (TO) < (LIMIT) ? (TO) : (LIMIT); \
356 for (; (FROM) < limit; (FROM)++) (ARRAY)->contents[(FROM)] = (VAL); \
357 } while (0)
359 #define GET_SUB_CHAR_TABLE(TABLE, SUBTABLE, IDX, DEPTH, MIN_CHAR) \
360 do { \
361 (SUBTABLE) = (TABLE)->contents[(IDX)]; \
362 if (!SUB_CHAR_TABLE_P (SUBTABLE)) \
363 (SUBTABLE) = make_sub_char_table ((DEPTH), (MIN_CHAR), (SUBTABLE)); \
364 } while (0)
367 static void
368 sub_char_table_set (table, c, val)
369 Lisp_Object table;
370 int c;
371 Lisp_Object val;
373 struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
374 int depth = XINT ((tbl)->depth);
375 int min_char = XINT ((tbl)->min_char);
376 int i = CHARTAB_IDX (c, depth, min_char);
377 Lisp_Object sub;
379 if (depth == 3)
380 tbl->contents[i] = val;
381 else
383 sub = tbl->contents[i];
384 if (! SUB_CHAR_TABLE_P (sub))
386 sub = make_sub_char_table (depth + 1,
387 min_char + i * chartab_chars[depth], sub);
388 tbl->contents[i] = sub;
390 sub_char_table_set (sub, c, val);
394 Lisp_Object
395 char_table_set (table, c, val)
396 Lisp_Object table;
397 int c;
398 Lisp_Object val;
400 struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
402 if (ASCII_CHAR_P (c)
403 && SUB_CHAR_TABLE_P (tbl->ascii))
405 XSUB_CHAR_TABLE (tbl->ascii)->contents[c] = val;
407 else
409 int i = CHARTAB_IDX (c, 0, 0);
410 Lisp_Object sub;
412 sub = tbl->contents[i];
413 if (! SUB_CHAR_TABLE_P (sub))
415 sub = make_sub_char_table (1, i * chartab_chars[0], sub);
416 tbl->contents[i] = sub;
418 sub_char_table_set (sub, c, val);
419 if (ASCII_CHAR_P (c))
420 tbl->ascii = char_table_ascii (table);
422 return val;
425 static void
426 sub_char_table_set_range (table, depth, min_char, from, to, val)
427 Lisp_Object *table;
428 int depth;
429 int min_char;
430 int from, to;
431 Lisp_Object val;
433 int max_char = min_char + chartab_chars[depth] - 1;
435 if (depth == 3 || (from <= min_char && to >= max_char))
436 *table = val;
437 else
439 int i, j;
441 depth++;
442 if (! SUB_CHAR_TABLE_P (*table))
443 *table = make_sub_char_table (depth, min_char, *table);
444 if (from < min_char)
445 from = min_char;
446 if (to > max_char)
447 to = max_char;
448 i = CHARTAB_IDX (from, depth, min_char);
449 j = CHARTAB_IDX (to, depth, min_char);
450 min_char += chartab_chars[depth] * i;
451 for (; i <= j; i++, min_char += chartab_chars[depth])
452 sub_char_table_set_range (XSUB_CHAR_TABLE (*table)->contents + i,
453 depth, min_char, from, to, val);
458 Lisp_Object
459 char_table_set_range (table, from, to, val)
460 Lisp_Object table;
461 int from, to;
462 Lisp_Object val;
464 struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
465 Lisp_Object *contents = tbl->contents;
466 int i, min_char;
468 if (from == to)
469 char_table_set (table, from, val);
470 else
472 for (i = CHARTAB_IDX (from, 0, 0), min_char = i * chartab_chars[0];
473 min_char <= to;
474 i++, min_char += chartab_chars[0])
475 sub_char_table_set_range (contents + i, 0, min_char, from, to, val);
476 if (ASCII_CHAR_P (from))
477 tbl->ascii = char_table_ascii (table);
479 return val;
483 DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
484 1, 1, 0,
485 doc: /*
486 Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
487 (char_table)
488 Lisp_Object char_table;
490 CHECK_CHAR_TABLE (char_table);
492 return XCHAR_TABLE (char_table)->purpose;
495 DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
496 1, 1, 0,
497 doc: /* Return the parent char-table of CHAR-TABLE.
498 The value is either nil or another char-table.
499 If CHAR-TABLE holds nil for a given character,
500 then the actual applicable value is inherited from the parent char-table
501 \(or from its parents, if necessary). */)
502 (char_table)
503 Lisp_Object char_table;
505 CHECK_CHAR_TABLE (char_table);
507 return XCHAR_TABLE (char_table)->parent;
510 DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
511 2, 2, 0,
512 doc: /* Set the parent char-table of CHAR-TABLE to PARENT.
513 Return PARENT. PARENT must be either nil or another char-table. */)
514 (char_table, parent)
515 Lisp_Object char_table, parent;
517 Lisp_Object temp;
519 CHECK_CHAR_TABLE (char_table);
521 if (!NILP (parent))
523 CHECK_CHAR_TABLE (parent);
525 for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
526 if (EQ (temp, char_table))
527 error ("Attempt to make a chartable be its own parent");
530 XCHAR_TABLE (char_table)->parent = parent;
532 return parent;
535 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
536 2, 2, 0,
537 doc: /* Return the value of CHAR-TABLE's extra-slot number N. */)
538 (char_table, n)
539 Lisp_Object char_table, n;
541 CHECK_CHAR_TABLE (char_table);
542 CHECK_NUMBER (n);
543 if (XINT (n) < 0
544 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
545 args_out_of_range (char_table, n);
547 return XCHAR_TABLE (char_table)->extras[XINT (n)];
550 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
551 Sset_char_table_extra_slot,
552 3, 3, 0,
553 doc: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
554 (char_table, n, value)
555 Lisp_Object char_table, n, value;
557 CHECK_CHAR_TABLE (char_table);
558 CHECK_NUMBER (n);
559 if (XINT (n) < 0
560 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
561 args_out_of_range (char_table, n);
563 return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
566 DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
567 2, 2, 0,
568 doc: /* Return the value in CHAR-TABLE for a range of characters RANGE.
569 RANGE should be nil (for the default value),
570 a cons of character codes (for characters in the range), or a character code. */)
571 (char_table, range)
572 Lisp_Object char_table, range;
574 Lisp_Object val;
575 CHECK_CHAR_TABLE (char_table);
577 if (EQ (range, Qnil))
578 val = XCHAR_TABLE (char_table)->defalt;
579 else if (INTEGERP (range))
580 val = CHAR_TABLE_REF (char_table, XINT (range));
581 else if (CONSP (range))
583 int from, to;
585 CHECK_CHARACTER_CAR (range);
586 CHECK_CHARACTER_CDR (range);
587 val = char_table_ref_and_range (char_table, XINT (XCAR (range)),
588 &from, &to);
589 /* Not yet implemented. */
591 else
592 error ("Invalid RANGE argument to `char-table-range'");
593 return val;
596 DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
597 3, 3, 0,
598 doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
599 RANGE should be t (for all characters), nil (for the default value),
600 a cons of character codes (for characters in the range),
601 or a character code. Return VALUE. */)
602 (char_table, range, value)
603 Lisp_Object char_table, range, value;
605 CHECK_CHAR_TABLE (char_table);
606 if (EQ (range, Qt))
608 int i;
610 XCHAR_TABLE (char_table)->ascii = value;
611 for (i = 0; i < chartab_size[0]; i++)
612 XCHAR_TABLE (char_table)->contents[i] = value;
614 else if (EQ (range, Qnil))
615 XCHAR_TABLE (char_table)->defalt = value;
616 else if (INTEGERP (range))
617 char_table_set (char_table, XINT (range), value);
618 else if (CONSP (range))
620 CHECK_CHARACTER_CAR (range);
621 CHECK_CHARACTER_CDR (range);
622 char_table_set_range (char_table,
623 XINT (XCAR (range)), XINT (XCDR (range)), value);
625 else
626 error ("Invalid RANGE argument to `set-char-table-range'");
628 return value;
631 DEFUN ("set-char-table-default", Fset_char_table_default,
632 Sset_char_table_default, 3, 3, 0,
633 doc: /*
634 This function is obsolete and has no effect. */)
635 (char_table, ch, value)
636 Lisp_Object char_table, ch, value;
638 return Qnil;
641 /* Look up the element in TABLE at index CH, and return it as an
642 integer. If the element is not a character, return CH itself. */
645 char_table_translate (table, ch)
646 Lisp_Object table;
647 int ch;
649 Lisp_Object value;
650 value = Faref (table, make_number (ch));
651 if (! CHARACTERP (value))
652 return ch;
653 return XINT (value);
656 static Lisp_Object
657 optimize_sub_char_table (table, test)
658 Lisp_Object table, test;
660 struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
661 int depth = XINT (tbl->depth);
662 Lisp_Object elt, this;
663 int i, optimizable;
665 elt = XSUB_CHAR_TABLE (table)->contents[0];
666 if (SUB_CHAR_TABLE_P (elt))
667 elt = XSUB_CHAR_TABLE (table)->contents[0]
668 = optimize_sub_char_table (elt, test);
669 optimizable = SUB_CHAR_TABLE_P (elt) ? 0 : 1;
670 for (i = 1; i < chartab_size[depth]; i++)
672 this = XSUB_CHAR_TABLE (table)->contents[i];
673 if (SUB_CHAR_TABLE_P (this))
674 this = XSUB_CHAR_TABLE (table)->contents[i]
675 = optimize_sub_char_table (this, test);
676 if (optimizable
677 && (NILP (test) ? NILP (Fequal (this, elt)) /* defaults to `equal'. */
678 : EQ (test, Qeq) ? !EQ (this, elt) /* Optimize `eq' case. */
679 : NILP (call2 (test, this, elt))))
680 optimizable = 0;
683 return (optimizable ? elt : table);
686 DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
687 1, 2, 0,
688 doc: /* Optimize CHAR-TABLE.
689 TEST is the comparison function used to decide whether two entries are
690 equivalent and can be merged. It defaults to `equal'. */)
691 (char_table, test)
692 Lisp_Object char_table, test;
694 Lisp_Object elt;
695 int i;
697 CHECK_CHAR_TABLE (char_table);
699 for (i = 0; i < chartab_size[0]; i++)
701 elt = XCHAR_TABLE (char_table)->contents[i];
702 if (SUB_CHAR_TABLE_P (elt))
703 XCHAR_TABLE (char_table)->contents[i]
704 = optimize_sub_char_table (elt, test);
706 return Qnil;
710 /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
711 calling it for each character or group of characters that share a
712 value. RANGE is a cons (FROM . TO) specifying the range of target
713 characters, VAL is a value of FROM in TABLE, DEFAULT_VAL is the
714 default value of the char-table, PARENT is the parent of the
715 char-table.
717 ARG is passed to C_FUNCTION when that is called.
719 It returns the value of last character covered by TABLE (not the
720 value inheritted from the parent), and by side-effect, the car part
721 of RANGE is updated to the minimum character C where C and all the
722 following characters in TABLE have the same value. */
724 static Lisp_Object
725 map_sub_char_table (c_function, function, table, arg, val, range,
726 default_val, parent)
727 void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
728 Lisp_Object function, table, arg, val, range, default_val, parent;
730 /* Pointer to the elements of TABLE. */
731 Lisp_Object *contents;
732 /* Depth of TABLE. */
733 int depth;
734 /* Minimum and maxinum characters covered by TABLE. */
735 int min_char, max_char;
736 /* Number of characters covered by one element of TABLE. */
737 int chars_in_block;
738 int from = XINT (XCAR (range)), to = XINT (XCDR (range));
739 int i, c;
741 if (SUB_CHAR_TABLE_P (table))
743 struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
745 depth = XINT (tbl->depth);
746 contents = tbl->contents;
747 min_char = XINT (tbl->min_char);
748 max_char = min_char + chartab_chars[depth - 1] - 1;
750 else
752 depth = 0;
753 contents = XCHAR_TABLE (table)->contents;
754 min_char = 0;
755 max_char = MAX_CHAR;
757 chars_in_block = chartab_chars[depth];
759 if (to < max_char)
760 max_char = to;
761 /* Set I to the index of the first element to check. */
762 if (from <= min_char)
763 i = 0;
764 else
765 i = (from - min_char) / chars_in_block;
766 for (c = min_char + chars_in_block * i; c <= max_char;
767 i++, c += chars_in_block)
769 Lisp_Object this = contents[i];
770 int nextc = c + chars_in_block;
772 if (SUB_CHAR_TABLE_P (this))
774 if (to >= nextc)
775 XSETCDR (range, make_number (nextc - 1));
776 val = map_sub_char_table (c_function, function, this, arg,
777 val, range, default_val, parent);
779 else
781 if (NILP (this))
782 this = default_val;
783 if (!EQ (val, this))
785 int different_value = 1;
787 if (NILP (val))
789 if (! NILP (parent))
791 Lisp_Object temp = XCHAR_TABLE (parent)->parent;
793 /* This is to get a value of FROM in PARENT
794 without checking the parent of PARENT. */
795 XCHAR_TABLE (parent)->parent = Qnil;
796 val = CHAR_TABLE_REF (parent, from);
797 XCHAR_TABLE (parent)->parent = temp;
798 XSETCDR (range, make_number (c - 1));
799 val = map_sub_char_table (c_function, function,
800 parent, arg, val, range,
801 XCHAR_TABLE (parent)->defalt,
802 XCHAR_TABLE (parent)->parent);
803 if (EQ (val, this))
804 different_value = 0;
807 if (! NILP (val) && different_value)
809 XSETCDR (range, make_number (c - 1));
810 if (EQ (XCAR (range), XCDR (range)))
812 if (c_function)
813 (*c_function) (arg, XCAR (range), val);
814 else
815 call2 (function, XCAR (range), val);
817 else
819 if (c_function)
820 (*c_function) (arg, range, val);
821 else
822 call2 (function, range, val);
825 val = this;
826 from = c;
827 XSETCAR (range, make_number (c));
830 XSETCDR (range, make_number (to));
832 return val;
836 /* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
837 character or group of characters that share a value.
839 ARG is passed to C_FUNCTION when that is called. */
841 void
842 map_char_table (c_function, function, table, arg)
843 void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
844 Lisp_Object function, table, arg;
846 Lisp_Object range, val;
847 struct gcpro gcpro1, gcpro2, gcpro3;
849 range = Fcons (make_number (0), make_number (MAX_CHAR));
850 GCPRO3 (table, arg, range);
851 val = XCHAR_TABLE (table)->ascii;
852 if (SUB_CHAR_TABLE_P (val))
853 val = XSUB_CHAR_TABLE (val)->contents[0];
854 val = map_sub_char_table (c_function, function, table, arg, val, range,
855 XCHAR_TABLE (table)->defalt,
856 XCHAR_TABLE (table)->parent);
857 /* If VAL is nil and TABLE has a parent, we must consult the parent
858 recursively. */
859 while (NILP (val) && ! NILP (XCHAR_TABLE (table)->parent))
861 Lisp_Object parent = XCHAR_TABLE (table)->parent;
862 Lisp_Object temp = XCHAR_TABLE (parent)->parent;
863 int from = XINT (XCAR (range));
865 /* This is to get a value of FROM in PARENT without checking the
866 parent of PARENT. */
867 XCHAR_TABLE (parent)->parent = Qnil;
868 val = CHAR_TABLE_REF (parent, from);
869 XCHAR_TABLE (parent)->parent = temp;
870 val = map_sub_char_table (c_function, function, parent, arg, val, range,
871 XCHAR_TABLE (parent)->defalt,
872 XCHAR_TABLE (parent)->parent);
873 table = parent;
876 if (! NILP (val))
878 if (EQ (XCAR (range), XCDR (range)))
880 if (c_function)
881 (*c_function) (arg, XCAR (range), val);
882 else
883 call2 (function, XCAR (range), val);
885 else
887 if (c_function)
888 (*c_function) (arg, range, val);
889 else
890 call2 (function, range, val);
894 UNGCPRO;
897 DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
898 2, 2, 0,
899 doc: /*
900 Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
901 FUNCTION is called with two arguments--a key and a value.
902 The key is a character code or a cons of character codes specifying a
903 range of characters that have the same value. */)
904 (function, char_table)
905 Lisp_Object function, char_table;
907 CHECK_CHAR_TABLE (char_table);
909 map_char_table (NULL, function, char_table, char_table);
910 return Qnil;
914 static void
915 map_sub_char_table_for_charset (c_function, function, table, arg, range,
916 charset, from, to)
917 void (*c_function) P_ ((Lisp_Object, Lisp_Object));
918 Lisp_Object function, table, arg, range;
919 struct charset *charset;
920 unsigned from, to;
922 struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
923 int depth = XINT (tbl->depth);
924 int c, i;
926 if (depth < 3)
927 for (i = 0, c = XINT (tbl->min_char); i < chartab_size[depth];
928 i++, c += chartab_chars[depth])
930 Lisp_Object this;
932 this = tbl->contents[i];
933 if (SUB_CHAR_TABLE_P (this))
934 map_sub_char_table_for_charset (c_function, function, this, arg,
935 range, charset, from, to);
936 else
938 if (! NILP (XCAR (range)))
940 XSETCDR (range, make_number (c - 1));
941 if (c_function)
942 (*c_function) (arg, range);
943 else
944 call2 (function, range, arg);
946 XSETCAR (range, Qnil);
949 else
950 for (i = 0, c = XINT (tbl->min_char); i < chartab_size[depth]; i++, c ++)
952 Lisp_Object this;
953 unsigned code;
955 this = tbl->contents[i];
956 if (NILP (this)
957 || (charset
958 && (code = ENCODE_CHAR (charset, c),
959 (code < from || code > to))))
961 if (! NILP (XCAR (range)))
963 XSETCDR (range, make_number (c - 1));
964 if (c_function)
965 (*c_function) (arg, range);
966 else
967 call2 (function, range, arg);
968 XSETCAR (range, Qnil);
971 else
973 if (NILP (XCAR (range)))
974 XSETCAR (range, make_number (c));
980 void
981 map_char_table_for_charset (c_function, function, table, arg,
982 charset, from, to)
983 void (*c_function) P_ ((Lisp_Object, Lisp_Object));
984 Lisp_Object function, table, arg;
985 struct charset *charset;
986 unsigned from, to;
988 Lisp_Object range;
989 int c, i;
990 struct gcpro gcpro1;
992 range = Fcons (Qnil, Qnil);
993 GCPRO1 (range);
995 for (i = 0, c = 0; i < chartab_size[0]; i++, c += chartab_chars[0])
997 Lisp_Object this;
999 this = XCHAR_TABLE (table)->contents[i];
1000 if (SUB_CHAR_TABLE_P (this))
1001 map_sub_char_table_for_charset (c_function, function, this, arg,
1002 range, charset, from, to);
1003 else
1005 if (! NILP (XCAR (range)))
1007 XSETCDR (range, make_number (c - 1));
1008 if (c_function)
1009 (*c_function) (arg, range);
1010 else
1011 call2 (function, range, arg);
1013 XSETCAR (range, Qnil);
1016 if (! NILP (XCAR (range)))
1018 XSETCDR (range, make_number (c - 1));
1019 if (c_function)
1020 (*c_function) (arg, range);
1021 else
1022 call2 (function, range, arg);
1025 UNGCPRO;
1029 void
1030 syms_of_chartab ()
1032 defsubr (&Smake_char_table);
1033 defsubr (&Schar_table_parent);
1034 defsubr (&Schar_table_subtype);
1035 defsubr (&Sset_char_table_parent);
1036 defsubr (&Schar_table_extra_slot);
1037 defsubr (&Sset_char_table_extra_slot);
1038 defsubr (&Schar_table_range);
1039 defsubr (&Sset_char_table_range);
1040 defsubr (&Sset_char_table_default);
1041 defsubr (&Soptimize_char_table);
1042 defsubr (&Smap_char_table);
1045 /* arch-tag: 18b5b560-7ab5-4108-b09e-d5dd65dc6fda
1046 (do not change this comment) */