1 /* chartab.c -- char-table support
2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
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/>. */
24 #include "character.h"
30 /* Number of elements in Nth level char-table. */
31 const int chartab_size
[4] =
32 { (1 << CHARTAB_SIZE_BITS_0
),
33 (1 << CHARTAB_SIZE_BITS_1
),
34 (1 << CHARTAB_SIZE_BITS_2
),
35 (1 << CHARTAB_SIZE_BITS_3
) };
37 /* Number of characters each element of Nth level char-table
39 const int chartab_chars
[4] =
40 { (1 << (CHARTAB_SIZE_BITS_1
+ CHARTAB_SIZE_BITS_2
+ CHARTAB_SIZE_BITS_3
)),
41 (1 << (CHARTAB_SIZE_BITS_2
+ CHARTAB_SIZE_BITS_3
)),
42 (1 << CHARTAB_SIZE_BITS_3
),
45 /* Number of characters (in bits) each element of Nth level char-table
47 const int chartab_bits
[4] =
48 { (CHARTAB_SIZE_BITS_1
+ CHARTAB_SIZE_BITS_2
+ CHARTAB_SIZE_BITS_3
),
49 (CHARTAB_SIZE_BITS_2
+ CHARTAB_SIZE_BITS_3
),
53 #define CHARTAB_IDX(c, depth, min_char) \
54 (((c) - (min_char)) >> chartab_bits[(depth)])
57 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
58 doc
: /* Return a newly created char-table, with purpose PURPOSE.
59 Each element is initialized to INIT, which defaults to nil.
61 PURPOSE should be a symbol. If it has a `char-table-extra-slots'
62 property, the property's value should be an integer between 0 and 10
63 that specifies how many extra slots the char-table has. Otherwise,
64 the char-table has no extra slot. */)
65 (register Lisp_Object purpose
, Lisp_Object init
)
72 CHECK_SYMBOL (purpose
);
73 n
= Fget (purpose
, Qchar_table_extra_slots
);
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
));
94 make_sub_char_table (int depth
, int min_char
, Lisp_Object defalt
)
97 int size
= VECSIZE (struct Lisp_Sub_Char_Table
) - 1 + chartab_size
[depth
];
99 table
= Fmake_vector (make_number (size
), defalt
);
100 XSETPVECTYPE (XVECTOR (table
), PVEC_SUB_CHAR_TABLE
);
101 XSUB_CHAR_TABLE (table
)->depth
= make_number (depth
);
102 XSUB_CHAR_TABLE (table
)->min_char
= make_number (min_char
);
108 char_table_ascii (Lisp_Object table
)
112 sub
= XCHAR_TABLE (table
)->contents
[0];
113 if (! SUB_CHAR_TABLE_P (sub
))
115 sub
= XSUB_CHAR_TABLE (sub
)->contents
[0];
116 if (! SUB_CHAR_TABLE_P (sub
))
118 return XSUB_CHAR_TABLE (sub
)->contents
[0];
122 copy_sub_char_table (Lisp_Object table
)
125 int depth
= XINT (XSUB_CHAR_TABLE (table
)->depth
);
126 int min_char
= XINT (XSUB_CHAR_TABLE (table
)->min_char
);
130 copy
= make_sub_char_table (depth
, min_char
, Qnil
);
131 /* Recursively copy any sub char-tables. */
132 for (i
= 0; i
< chartab_size
[depth
]; i
++)
134 val
= XSUB_CHAR_TABLE (table
)->contents
[i
];
135 if (SUB_CHAR_TABLE_P (val
))
136 XSUB_CHAR_TABLE (copy
)->contents
[i
] = copy_sub_char_table (val
);
138 XSUB_CHAR_TABLE (copy
)->contents
[i
] = val
;
146 copy_char_table (Lisp_Object table
)
149 int size
= XCHAR_TABLE (table
)->size
& PSEUDOVECTOR_SIZE_MASK
;
152 copy
= Fmake_vector (make_number (size
), Qnil
);
153 XSETPVECTYPE (XVECTOR (copy
), PVEC_CHAR_TABLE
);
154 XCHAR_TABLE (copy
)->defalt
= XCHAR_TABLE (table
)->defalt
;
155 XCHAR_TABLE (copy
)->parent
= XCHAR_TABLE (table
)->parent
;
156 XCHAR_TABLE (copy
)->purpose
= XCHAR_TABLE (table
)->purpose
;
157 for (i
= 0; i
< chartab_size
[0]; i
++)
158 XCHAR_TABLE (copy
)->contents
[i
]
159 = (SUB_CHAR_TABLE_P (XCHAR_TABLE (table
)->contents
[i
])
160 ? copy_sub_char_table (XCHAR_TABLE (table
)->contents
[i
])
161 : XCHAR_TABLE (table
)->contents
[i
]);
162 XCHAR_TABLE (copy
)->ascii
= char_table_ascii (copy
);
163 size
-= VECSIZE (struct Lisp_Char_Table
) - 1;
164 for (i
= 0; i
< size
; i
++)
165 XCHAR_TABLE (copy
)->extras
[i
] = XCHAR_TABLE (table
)->extras
[i
];
167 XSETCHAR_TABLE (copy
, XCHAR_TABLE (copy
));
172 sub_char_table_ref (Lisp_Object table
, int c
)
174 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
175 int depth
= XINT (tbl
->depth
);
176 int min_char
= XINT (tbl
->min_char
);
179 val
= tbl
->contents
[CHARTAB_IDX (c
, depth
, min_char
)];
180 if (SUB_CHAR_TABLE_P (val
))
181 val
= sub_char_table_ref (val
, c
);
186 char_table_ref (Lisp_Object table
, int c
)
188 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
191 if (ASCII_CHAR_P (c
))
194 if (SUB_CHAR_TABLE_P (val
))
195 val
= XSUB_CHAR_TABLE (val
)->contents
[c
];
199 val
= tbl
->contents
[CHARTAB_IDX (c
, 0, 0)];
200 if (SUB_CHAR_TABLE_P (val
))
201 val
= sub_char_table_ref (val
, c
);
206 if (NILP (val
) && CHAR_TABLE_P (tbl
->parent
))
207 val
= char_table_ref (tbl
->parent
, c
);
213 sub_char_table_ref_and_range (Lisp_Object table
, int c
, int *from
, int *to
, Lisp_Object defalt
)
215 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
216 int depth
= XINT (tbl
->depth
);
217 int min_char
= XINT (tbl
->min_char
);
218 int chartab_idx
= CHARTAB_IDX (c
, depth
, min_char
), idx
;
221 val
= tbl
->contents
[chartab_idx
];
222 if (SUB_CHAR_TABLE_P (val
))
223 val
= sub_char_table_ref_and_range (val
, c
, from
, to
, defalt
);
228 while (idx
> 0 && *from
< min_char
+ idx
* chartab_chars
[depth
])
230 Lisp_Object this_val
;
232 c
= min_char
+ idx
* chartab_chars
[depth
] - 1;
234 this_val
= tbl
->contents
[idx
];
235 if (SUB_CHAR_TABLE_P (this_val
))
236 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
, defalt
);
237 else if (NILP (this_val
))
240 if (! EQ (this_val
, val
))
246 while (((c
= (chartab_idx
+ 1) * chartab_chars
[depth
])
247 < chartab_chars
[depth
- 1])
248 && (c
+= min_char
) <= *to
)
250 Lisp_Object this_val
;
253 this_val
= tbl
->contents
[chartab_idx
];
254 if (SUB_CHAR_TABLE_P (this_val
))
255 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
, defalt
);
256 else if (NILP (this_val
))
258 if (! EQ (this_val
, val
))
269 /* Return the value for C in char-table TABLE. Shrink the range *FROM
270 and *TO to cover characters (containing C) that have the same value
271 as C. It is not assured that the values of (*FROM - 1) and (*TO +
272 1) are different from that of C. */
275 char_table_ref_and_range (Lisp_Object table
, int c
, int *from
, int *to
)
277 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
278 int chartab_idx
= CHARTAB_IDX (c
, 0, 0), idx
;
281 val
= tbl
->contents
[chartab_idx
];
286 if (SUB_CHAR_TABLE_P (val
))
287 val
= sub_char_table_ref_and_range (val
, c
, from
, to
, tbl
->defalt
);
292 while (*from
< idx
* chartab_chars
[0])
294 Lisp_Object this_val
;
296 c
= idx
* chartab_chars
[0] - 1;
298 this_val
= tbl
->contents
[idx
];
299 if (SUB_CHAR_TABLE_P (this_val
))
300 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
,
302 else if (NILP (this_val
))
303 this_val
= tbl
->defalt
;
305 if (! EQ (this_val
, val
))
311 while (*to
>= (chartab_idx
+ 1) * chartab_chars
[0])
313 Lisp_Object this_val
;
316 c
= chartab_idx
* chartab_chars
[0];
317 this_val
= tbl
->contents
[chartab_idx
];
318 if (SUB_CHAR_TABLE_P (this_val
))
319 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
,
321 else if (NILP (this_val
))
322 this_val
= tbl
->defalt
;
323 if (! EQ (this_val
, val
))
335 sub_char_table_set (Lisp_Object table
, int c
, Lisp_Object val
)
337 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
338 int depth
= XINT ((tbl
)->depth
);
339 int min_char
= XINT ((tbl
)->min_char
);
340 int i
= CHARTAB_IDX (c
, depth
, min_char
);
344 tbl
->contents
[i
] = val
;
347 sub
= tbl
->contents
[i
];
348 if (! SUB_CHAR_TABLE_P (sub
))
350 sub
= make_sub_char_table (depth
+ 1,
351 min_char
+ i
* chartab_chars
[depth
], sub
);
352 tbl
->contents
[i
] = sub
;
354 sub_char_table_set (sub
, c
, val
);
359 char_table_set (Lisp_Object table
, int c
, Lisp_Object val
)
361 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
364 && SUB_CHAR_TABLE_P (tbl
->ascii
))
366 XSUB_CHAR_TABLE (tbl
->ascii
)->contents
[c
] = val
;
370 int i
= CHARTAB_IDX (c
, 0, 0);
373 sub
= tbl
->contents
[i
];
374 if (! SUB_CHAR_TABLE_P (sub
))
376 sub
= make_sub_char_table (1, i
* chartab_chars
[0], sub
);
377 tbl
->contents
[i
] = sub
;
379 sub_char_table_set (sub
, c
, val
);
380 if (ASCII_CHAR_P (c
))
381 tbl
->ascii
= char_table_ascii (table
);
387 sub_char_table_set_range (Lisp_Object
*table
, int depth
, int min_char
, int from
, int to
, Lisp_Object val
)
389 int max_char
= min_char
+ chartab_chars
[depth
] - 1;
391 if (depth
== 3 || (from
<= min_char
&& to
>= max_char
))
398 if (! SUB_CHAR_TABLE_P (*table
))
399 *table
= make_sub_char_table (depth
, min_char
, *table
);
404 i
= CHARTAB_IDX (from
, depth
, min_char
);
405 j
= CHARTAB_IDX (to
, depth
, min_char
);
406 min_char
+= chartab_chars
[depth
] * i
;
407 for (; i
<= j
; i
++, min_char
+= chartab_chars
[depth
])
408 sub_char_table_set_range (XSUB_CHAR_TABLE (*table
)->contents
+ i
,
409 depth
, min_char
, from
, to
, val
);
415 char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
)
417 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
418 Lisp_Object
*contents
= tbl
->contents
;
422 char_table_set (table
, from
, val
);
425 for (i
= CHARTAB_IDX (from
, 0, 0), min_char
= i
* chartab_chars
[0];
427 i
++, min_char
+= chartab_chars
[0])
428 sub_char_table_set_range (contents
+ i
, 0, min_char
, from
, to
, val
);
429 if (ASCII_CHAR_P (from
))
430 tbl
->ascii
= char_table_ascii (table
);
436 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
439 Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
440 (Lisp_Object char_table
)
442 CHECK_CHAR_TABLE (char_table
);
444 return XCHAR_TABLE (char_table
)->purpose
;
447 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
449 doc
: /* Return the parent char-table of CHAR-TABLE.
450 The value is either nil or another char-table.
451 If CHAR-TABLE holds nil for a given character,
452 then the actual applicable value is inherited from the parent char-table
453 \(or from its parents, if necessary). */)
454 (Lisp_Object char_table
)
456 CHECK_CHAR_TABLE (char_table
);
458 return XCHAR_TABLE (char_table
)->parent
;
461 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
463 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
464 Return PARENT. PARENT must be either nil or another char-table. */)
465 (Lisp_Object char_table
, Lisp_Object parent
)
469 CHECK_CHAR_TABLE (char_table
);
473 CHECK_CHAR_TABLE (parent
);
475 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
476 if (EQ (temp
, char_table
))
477 error ("Attempt to make a chartable be its own parent");
480 XCHAR_TABLE (char_table
)->parent
= parent
;
485 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
487 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
488 (Lisp_Object char_table
, Lisp_Object n
)
490 CHECK_CHAR_TABLE (char_table
);
493 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
494 args_out_of_range (char_table
, n
);
496 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
499 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
500 Sset_char_table_extra_slot
,
502 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
503 (Lisp_Object char_table
, Lisp_Object n
, Lisp_Object value
)
505 CHECK_CHAR_TABLE (char_table
);
508 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
509 args_out_of_range (char_table
, n
);
511 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
514 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
516 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
517 RANGE should be nil (for the default value),
518 a cons of character codes (for characters in the range), or a character code. */)
519 (Lisp_Object char_table
, Lisp_Object range
)
522 CHECK_CHAR_TABLE (char_table
);
524 if (EQ (range
, Qnil
))
525 val
= XCHAR_TABLE (char_table
)->defalt
;
526 else if (INTEGERP (range
))
527 val
= CHAR_TABLE_REF (char_table
, XINT (range
));
528 else if (CONSP (range
))
532 CHECK_CHARACTER_CAR (range
);
533 CHECK_CHARACTER_CDR (range
);
534 val
= char_table_ref_and_range (char_table
, XINT (XCAR (range
)),
536 /* Not yet implemented. */
539 error ("Invalid RANGE argument to `char-table-range'");
543 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
545 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
546 RANGE should be t (for all characters), nil (for the default value),
547 a cons of character codes (for characters in the range),
548 or a character code. Return VALUE. */)
549 (Lisp_Object char_table
, Lisp_Object range
, Lisp_Object value
)
551 CHECK_CHAR_TABLE (char_table
);
556 XCHAR_TABLE (char_table
)->ascii
= value
;
557 for (i
= 0; i
< chartab_size
[0]; i
++)
558 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
560 else if (EQ (range
, Qnil
))
561 XCHAR_TABLE (char_table
)->defalt
= value
;
562 else if (INTEGERP (range
))
563 char_table_set (char_table
, XINT (range
), value
);
564 else if (CONSP (range
))
566 CHECK_CHARACTER_CAR (range
);
567 CHECK_CHARACTER_CDR (range
);
568 char_table_set_range (char_table
,
569 XINT (XCAR (range
)), XINT (XCDR (range
)), value
);
572 error ("Invalid RANGE argument to `set-char-table-range'");
577 DEFUN ("set-char-table-default", Fset_char_table_default
,
578 Sset_char_table_default
, 3, 3, 0,
580 This function is obsolete and has no effect. */)
581 (Lisp_Object char_table
, Lisp_Object ch
, Lisp_Object value
)
586 /* Look up the element in TABLE at index CH, and return it as an
587 integer. If the element is not a character, return CH itself. */
590 char_table_translate (Lisp_Object table
, int ch
)
593 value
= Faref (table
, make_number (ch
));
594 if (! CHARACTERP (value
))
600 optimize_sub_char_table (Lisp_Object table
, Lisp_Object test
)
602 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
603 int depth
= XINT (tbl
->depth
);
604 Lisp_Object elt
, this;
607 elt
= XSUB_CHAR_TABLE (table
)->contents
[0];
608 if (SUB_CHAR_TABLE_P (elt
))
609 elt
= XSUB_CHAR_TABLE (table
)->contents
[0]
610 = optimize_sub_char_table (elt
, test
);
611 optimizable
= SUB_CHAR_TABLE_P (elt
) ? 0 : 1;
612 for (i
= 1; i
< chartab_size
[depth
]; i
++)
614 this = XSUB_CHAR_TABLE (table
)->contents
[i
];
615 if (SUB_CHAR_TABLE_P (this))
616 this = XSUB_CHAR_TABLE (table
)->contents
[i
]
617 = optimize_sub_char_table (this, test
);
619 && (NILP (test
) ? NILP (Fequal (this, elt
)) /* defaults to `equal'. */
620 : EQ (test
, Qeq
) ? !EQ (this, elt
) /* Optimize `eq' case. */
621 : NILP (call2 (test
, this, elt
))))
625 return (optimizable
? elt
: table
);
628 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
630 doc
: /* Optimize CHAR-TABLE.
631 TEST is the comparison function used to decide whether two entries are
632 equivalent and can be merged. It defaults to `equal'. */)
633 (Lisp_Object char_table
, Lisp_Object test
)
638 CHECK_CHAR_TABLE (char_table
);
640 for (i
= 0; i
< chartab_size
[0]; i
++)
642 elt
= XCHAR_TABLE (char_table
)->contents
[i
];
643 if (SUB_CHAR_TABLE_P (elt
))
644 XCHAR_TABLE (char_table
)->contents
[i
]
645 = optimize_sub_char_table (elt
, test
);
647 /* Reset the `ascii' cache, in case it got optimized away. */
648 XCHAR_TABLE (char_table
)->ascii
= char_table_ascii (char_table
);
654 /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
655 calling it for each character or group of characters that share a
656 value. RANGE is a cons (FROM . TO) specifying the range of target
657 characters, VAL is a value of FROM in TABLE, DEFAULT_VAL is the
658 default value of the char-table, PARENT is the parent of the
661 ARG is passed to C_FUNCTION when that is called.
663 It returns the value of last character covered by TABLE (not the
664 value inheritted from the parent), and by side-effect, the car part
665 of RANGE is updated to the minimum character C where C and all the
666 following characters in TABLE have the same value. */
669 map_sub_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
670 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
, Lisp_Object val
,
671 Lisp_Object range
, Lisp_Object default_val
, Lisp_Object parent
)
673 /* Pointer to the elements of TABLE. */
674 Lisp_Object
*contents
;
675 /* Depth of TABLE. */
677 /* Minimum and maxinum characters covered by TABLE. */
678 int min_char
, max_char
;
679 /* Number of characters covered by one element of TABLE. */
681 int from
= XINT (XCAR (range
)), to
= XINT (XCDR (range
));
684 if (SUB_CHAR_TABLE_P (table
))
686 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
688 depth
= XINT (tbl
->depth
);
689 contents
= tbl
->contents
;
690 min_char
= XINT (tbl
->min_char
);
691 max_char
= min_char
+ chartab_chars
[depth
- 1] - 1;
696 contents
= XCHAR_TABLE (table
)->contents
;
700 chars_in_block
= chartab_chars
[depth
];
704 /* Set I to the index of the first element to check. */
705 if (from
<= min_char
)
708 i
= (from
- min_char
) / chars_in_block
;
709 for (c
= min_char
+ chars_in_block
* i
; c
<= max_char
;
710 i
++, c
+= chars_in_block
)
712 Lisp_Object
this = contents
[i
];
713 int nextc
= c
+ chars_in_block
;
715 if (SUB_CHAR_TABLE_P (this))
718 XSETCDR (range
, make_number (nextc
- 1));
719 val
= map_sub_char_table (c_function
, function
, this, arg
,
720 val
, range
, default_val
, parent
);
728 int different_value
= 1;
734 Lisp_Object temp
= XCHAR_TABLE (parent
)->parent
;
736 /* This is to get a value of FROM in PARENT
737 without checking the parent of PARENT. */
738 XCHAR_TABLE (parent
)->parent
= Qnil
;
739 val
= CHAR_TABLE_REF (parent
, from
);
740 XCHAR_TABLE (parent
)->parent
= temp
;
741 XSETCDR (range
, make_number (c
- 1));
742 val
= map_sub_char_table (c_function
, function
,
743 parent
, arg
, val
, range
,
744 XCHAR_TABLE (parent
)->defalt
,
745 XCHAR_TABLE (parent
)->parent
);
750 if (! NILP (val
) && different_value
)
752 XSETCDR (range
, make_number (c
- 1));
753 if (EQ (XCAR (range
), XCDR (range
)))
756 (*c_function
) (arg
, XCAR (range
), val
);
758 call2 (function
, XCAR (range
), val
);
763 (*c_function
) (arg
, range
, val
);
765 call2 (function
, range
, val
);
770 XSETCAR (range
, make_number (c
));
773 XSETCDR (range
, make_number (to
));
779 /* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
780 character or group of characters that share a value.
782 ARG is passed to C_FUNCTION when that is called. */
785 map_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
), Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
)
787 Lisp_Object range
, val
;
788 struct gcpro gcpro1
, gcpro2
, gcpro3
;
790 range
= Fcons (make_number (0), make_number (MAX_CHAR
));
791 GCPRO3 (table
, arg
, range
);
792 val
= XCHAR_TABLE (table
)->ascii
;
793 if (SUB_CHAR_TABLE_P (val
))
794 val
= XSUB_CHAR_TABLE (val
)->contents
[0];
795 val
= map_sub_char_table (c_function
, function
, table
, arg
, val
, range
,
796 XCHAR_TABLE (table
)->defalt
,
797 XCHAR_TABLE (table
)->parent
);
798 /* If VAL is nil and TABLE has a parent, we must consult the parent
800 while (NILP (val
) && ! NILP (XCHAR_TABLE (table
)->parent
))
802 Lisp_Object parent
= XCHAR_TABLE (table
)->parent
;
803 Lisp_Object temp
= XCHAR_TABLE (parent
)->parent
;
804 int from
= XINT (XCAR (range
));
806 /* This is to get a value of FROM in PARENT without checking the
808 XCHAR_TABLE (parent
)->parent
= Qnil
;
809 val
= CHAR_TABLE_REF (parent
, from
);
810 XCHAR_TABLE (parent
)->parent
= temp
;
811 val
= map_sub_char_table (c_function
, function
, parent
, arg
, val
, range
,
812 XCHAR_TABLE (parent
)->defalt
,
813 XCHAR_TABLE (parent
)->parent
);
819 if (EQ (XCAR (range
), XCDR (range
)))
822 (*c_function
) (arg
, XCAR (range
), val
);
824 call2 (function
, XCAR (range
), val
);
829 (*c_function
) (arg
, range
, val
);
831 call2 (function
, range
, val
);
838 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
841 Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
842 FUNCTION is called with two arguments--a key and a value.
843 The key is a character code or a cons of character codes specifying a
844 range of characters that have the same value. */)
845 (Lisp_Object function
, Lisp_Object char_table
)
847 CHECK_CHAR_TABLE (char_table
);
849 map_char_table (NULL
, function
, char_table
, char_table
);
855 map_sub_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
856 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
857 Lisp_Object range
, struct charset
*charset
,
858 unsigned from
, unsigned to
)
860 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
861 int depth
= XINT (tbl
->depth
);
865 for (i
= 0, c
= XINT (tbl
->min_char
); i
< chartab_size
[depth
];
866 i
++, c
+= chartab_chars
[depth
])
870 this = tbl
->contents
[i
];
871 if (SUB_CHAR_TABLE_P (this))
872 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
873 range
, charset
, from
, to
);
876 if (! NILP (XCAR (range
)))
878 XSETCDR (range
, make_number (c
- 1));
880 (*c_function
) (arg
, range
);
882 call2 (function
, range
, arg
);
884 XSETCAR (range
, Qnil
);
888 for (i
= 0, c
= XINT (tbl
->min_char
); i
< chartab_size
[depth
]; i
++, c
++)
893 this = tbl
->contents
[i
];
896 && (code
= ENCODE_CHAR (charset
, c
),
897 (code
< from
|| code
> to
))))
899 if (! NILP (XCAR (range
)))
901 XSETCDR (range
, make_number (c
- 1));
903 (*c_function
) (arg
, range
);
905 call2 (function
, range
, arg
);
906 XSETCAR (range
, Qnil
);
911 if (NILP (XCAR (range
)))
912 XSETCAR (range
, make_number (c
));
918 /* Support function for `map-charset-chars'. Map C_FUNCTION or
919 FUNCTION over TABLE, calling it for each character or a group of
920 succeeding characters that have non-nil value in TABLE. TABLE is a
921 "mapping table" or a "deunifier table" of a certain charset.
923 If CHARSET is not NULL (this is the case that `map-charset-chars'
924 is called with non-nil FROM-CODE and TO-CODE), it is a charset who
925 owns TABLE, and the function is called only on a character in the
926 range FROM and TO. FROM and TO are not character codes, but code
927 points of a character in CHARSET.
929 This function is called in these two cases:
931 (1) A charset has a mapping file name in :map property.
933 (2) A charset has an upper code space in :offset property and a
934 mapping file name in :unify-map property. In this case, this
935 function is called only for characters in the Unicode code space.
936 Characters in upper code space are handled directly in
937 map_charset_chars. */
940 map_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
941 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
942 struct charset
*charset
,
943 unsigned from
, unsigned to
)
949 range
= Fcons (Qnil
, Qnil
);
952 for (i
= 0, c
= 0; i
< chartab_size
[0]; i
++, c
+= chartab_chars
[0])
956 this = XCHAR_TABLE (table
)->contents
[i
];
957 if (SUB_CHAR_TABLE_P (this))
958 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
959 range
, charset
, from
, to
);
962 if (! NILP (XCAR (range
)))
964 XSETCDR (range
, make_number (c
- 1));
966 (*c_function
) (arg
, range
);
968 call2 (function
, range
, arg
);
970 XSETCAR (range
, Qnil
);
973 if (! NILP (XCAR (range
)))
975 XSETCDR (range
, make_number (c
- 1));
977 (*c_function
) (arg
, range
);
979 call2 (function
, range
, arg
);
987 syms_of_chartab (void)
989 defsubr (&Smake_char_table
);
990 defsubr (&Schar_table_parent
);
991 defsubr (&Schar_table_subtype
);
992 defsubr (&Sset_char_table_parent
);
993 defsubr (&Schar_table_extra_slot
);
994 defsubr (&Sset_char_table_extra_slot
);
995 defsubr (&Schar_table_range
);
996 defsubr (&Sset_char_table_range
);
997 defsubr (&Sset_char_table_default
);
998 defsubr (&Soptimize_char_table
);
999 defsubr (&Smap_char_table
);