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 static 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 static 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 /* Preamble for uniprop (Unicode character property) tables. See the
58 comment of "Unicode character property tables". */
60 /* Purpose of uniprop tables. */
61 static Lisp_Object Qchar_code_property_table
;
63 /* Types of decoder and encoder functions for uniprop values. */
64 typedef Lisp_Object (*uniprop_decoder_t
) (Lisp_Object
, Lisp_Object
);
65 typedef Lisp_Object (*uniprop_encoder_t
) (Lisp_Object
, Lisp_Object
);
67 static Lisp_Object
uniprop_table_uncompress (Lisp_Object
, int);
68 static uniprop_decoder_t
uniprop_get_decoder (Lisp_Object
);
70 /* 1 iff TABLE is a uniprop table. */
71 #define UNIPROP_TABLE_P(TABLE) \
72 (EQ (XCHAR_TABLE (TABLE)->purpose, Qchar_code_property_table) \
73 && CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (TABLE)) == 5)
75 /* Return a decoder for values in the uniprop table TABLE. */
76 #define UNIPROP_GET_DECODER(TABLE) \
77 (UNIPROP_TABLE_P (TABLE) ? uniprop_get_decoder (TABLE) : NULL)
79 /* Nonzero iff OBJ is a string representing uniprop values of 128
80 succeeding characters (the bottom level of a char-table) by a
81 compressed format. We are sure that no property value has a string
82 starting with '\001' nor '\002'. */
83 #define UNIPROP_COMPRESSED_FORM_P(OBJ) \
84 (STRINGP (OBJ) && SCHARS (OBJ) > 0 \
85 && ((SREF (OBJ, 0) == 1 || (SREF (OBJ, 0) == 2))))
88 CHECK_CHAR_TABLE (Lisp_Object x
)
90 CHECK_TYPE (CHAR_TABLE_P (x
), Qchar_table_p
, x
);
94 set_char_table_ascii (Lisp_Object table
, Lisp_Object val
)
96 XCHAR_TABLE (table
)->ascii
= val
;
99 set_char_table_parent (Lisp_Object table
, Lisp_Object val
)
101 XCHAR_TABLE (table
)->parent
= val
;
104 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
105 doc
: /* Return a newly created char-table, with purpose PURPOSE.
106 Each element is initialized to INIT, which defaults to nil.
108 PURPOSE should be a symbol. If it has a `char-table-extra-slots'
109 property, the property's value should be an integer between 0 and 10
110 that specifies how many extra slots the char-table has. Otherwise,
111 the char-table has no extra slot. */)
112 (register Lisp_Object purpose
, Lisp_Object init
)
119 CHECK_SYMBOL (purpose
);
120 n
= Fget (purpose
, Qchar_table_extra_slots
);
127 args_out_of_range (n
, Qnil
);
131 size
= CHAR_TABLE_STANDARD_SLOTS
+ n_extras
;
132 vector
= Fmake_vector (make_number (size
), init
);
133 XSETPVECTYPE (XVECTOR (vector
), PVEC_CHAR_TABLE
);
134 set_char_table_parent (vector
, Qnil
);
135 set_char_table_purpose (vector
, purpose
);
136 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
141 make_sub_char_table (int depth
, int min_char
, Lisp_Object defalt
)
144 Lisp_Object table
= make_uninit_sub_char_table (depth
, min_char
);
146 for (i
= 0; i
< chartab_size
[depth
]; i
++)
147 XSUB_CHAR_TABLE (table
)->contents
[i
] = defalt
;
152 char_table_ascii (Lisp_Object table
)
154 Lisp_Object sub
, val
;
156 sub
= XCHAR_TABLE (table
)->contents
[0];
157 if (! SUB_CHAR_TABLE_P (sub
))
159 sub
= XSUB_CHAR_TABLE (sub
)->contents
[0];
160 if (! SUB_CHAR_TABLE_P (sub
))
162 val
= XSUB_CHAR_TABLE (sub
)->contents
[0];
163 if (UNIPROP_TABLE_P (table
) && UNIPROP_COMPRESSED_FORM_P (val
))
164 val
= uniprop_table_uncompress (sub
, 0);
169 copy_sub_char_table (Lisp_Object table
)
171 int depth
= XSUB_CHAR_TABLE (table
)->depth
;
172 int min_char
= XSUB_CHAR_TABLE (table
)->min_char
;
173 Lisp_Object copy
= make_sub_char_table (depth
, min_char
, Qnil
);
176 /* Recursively copy any sub char-tables. */
177 for (i
= 0; i
< chartab_size
[depth
]; i
++)
179 Lisp_Object val
= XSUB_CHAR_TABLE (table
)->contents
[i
];
180 set_sub_char_table_contents
181 (copy
, i
, SUB_CHAR_TABLE_P (val
) ? copy_sub_char_table (val
) : val
);
189 copy_char_table (Lisp_Object table
)
192 int size
= XCHAR_TABLE (table
)->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
195 copy
= Fmake_vector (make_number (size
), Qnil
);
196 XSETPVECTYPE (XVECTOR (copy
), PVEC_CHAR_TABLE
);
197 set_char_table_defalt (copy
, XCHAR_TABLE (table
)->defalt
);
198 set_char_table_parent (copy
, XCHAR_TABLE (table
)->parent
);
199 set_char_table_purpose (copy
, XCHAR_TABLE (table
)->purpose
);
200 for (i
= 0; i
< chartab_size
[0]; i
++)
201 set_char_table_contents
203 (SUB_CHAR_TABLE_P (XCHAR_TABLE (table
)->contents
[i
])
204 ? copy_sub_char_table (XCHAR_TABLE (table
)->contents
[i
])
205 : XCHAR_TABLE (table
)->contents
[i
]));
206 set_char_table_ascii (copy
, char_table_ascii (copy
));
207 size
-= CHAR_TABLE_STANDARD_SLOTS
;
208 for (i
= 0; i
< size
; i
++)
209 set_char_table_extras (copy
, i
, XCHAR_TABLE (table
)->extras
[i
]);
211 XSETCHAR_TABLE (copy
, XCHAR_TABLE (copy
));
216 sub_char_table_ref (Lisp_Object table
, int c
, bool is_uniprop
)
218 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
220 int idx
= CHARTAB_IDX (c
, tbl
->depth
, tbl
->min_char
);
222 val
= tbl
->contents
[idx
];
223 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
224 val
= uniprop_table_uncompress (table
, idx
);
225 if (SUB_CHAR_TABLE_P (val
))
226 val
= sub_char_table_ref (val
, c
, is_uniprop
);
231 char_table_ref (Lisp_Object table
, int c
)
233 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
236 if (ASCII_CHAR_P (c
))
239 if (SUB_CHAR_TABLE_P (val
))
240 val
= XSUB_CHAR_TABLE (val
)->contents
[c
];
244 val
= tbl
->contents
[CHARTAB_IDX (c
, 0, 0)];
245 if (SUB_CHAR_TABLE_P (val
))
246 val
= sub_char_table_ref (val
, c
, UNIPROP_TABLE_P (table
));
251 if (NILP (val
) && CHAR_TABLE_P (tbl
->parent
))
252 val
= char_table_ref (tbl
->parent
, c
);
258 sub_char_table_ref_and_range (Lisp_Object table
, int c
, int *from
, int *to
,
259 Lisp_Object defalt
, bool is_uniprop
)
261 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
262 int depth
= tbl
->depth
, min_char
= tbl
->min_char
;
263 int chartab_idx
= CHARTAB_IDX (c
, depth
, min_char
), idx
;
266 val
= tbl
->contents
[chartab_idx
];
267 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
268 val
= uniprop_table_uncompress (table
, chartab_idx
);
269 if (SUB_CHAR_TABLE_P (val
))
270 val
= sub_char_table_ref_and_range (val
, c
, from
, to
, defalt
, is_uniprop
);
275 while (idx
> 0 && *from
< min_char
+ idx
* chartab_chars
[depth
])
277 Lisp_Object this_val
;
279 c
= min_char
+ idx
* chartab_chars
[depth
] - 1;
281 this_val
= tbl
->contents
[idx
];
282 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
283 this_val
= uniprop_table_uncompress (table
, idx
);
284 if (SUB_CHAR_TABLE_P (this_val
))
285 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
, defalt
,
287 else if (NILP (this_val
))
290 if (! EQ (this_val
, val
))
296 while (((c
= (chartab_idx
+ 1) * chartab_chars
[depth
])
297 < chartab_chars
[depth
- 1])
298 && (c
+= min_char
) <= *to
)
300 Lisp_Object this_val
;
303 this_val
= tbl
->contents
[chartab_idx
];
304 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
305 this_val
= uniprop_table_uncompress (table
, chartab_idx
);
306 if (SUB_CHAR_TABLE_P (this_val
))
307 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
, defalt
,
309 else if (NILP (this_val
))
311 if (! EQ (this_val
, val
))
322 /* Return the value for C in char-table TABLE. Shrink the range *FROM
323 and *TO to cover characters (containing C) that have the same value
324 as C. It is not assured that the values of (*FROM - 1) and (*TO +
325 1) are different from that of C. */
328 char_table_ref_and_range (Lisp_Object table
, int c
, int *from
, int *to
)
330 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
331 int chartab_idx
= CHARTAB_IDX (c
, 0, 0), idx
;
333 bool is_uniprop
= UNIPROP_TABLE_P (table
);
335 val
= tbl
->contents
[chartab_idx
];
340 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
341 val
= uniprop_table_uncompress (table
, chartab_idx
);
342 if (SUB_CHAR_TABLE_P (val
))
343 val
= sub_char_table_ref_and_range (val
, c
, from
, to
, tbl
->defalt
,
348 while (*from
< idx
* chartab_chars
[0])
350 Lisp_Object this_val
;
352 c
= idx
* chartab_chars
[0] - 1;
354 this_val
= tbl
->contents
[idx
];
355 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
356 this_val
= uniprop_table_uncompress (table
, idx
);
357 if (SUB_CHAR_TABLE_P (this_val
))
358 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
,
359 tbl
->defalt
, is_uniprop
);
360 else if (NILP (this_val
))
361 this_val
= tbl
->defalt
;
363 if (! EQ (this_val
, val
))
369 while (*to
>= (chartab_idx
+ 1) * chartab_chars
[0])
371 Lisp_Object this_val
;
374 c
= chartab_idx
* chartab_chars
[0];
375 this_val
= tbl
->contents
[chartab_idx
];
376 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
377 this_val
= uniprop_table_uncompress (table
, chartab_idx
);
378 if (SUB_CHAR_TABLE_P (this_val
))
379 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
,
380 tbl
->defalt
, is_uniprop
);
381 else if (NILP (this_val
))
382 this_val
= tbl
->defalt
;
383 if (! EQ (this_val
, val
))
395 sub_char_table_set (Lisp_Object table
, int c
, Lisp_Object val
, bool is_uniprop
)
397 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
398 int depth
= tbl
->depth
, min_char
= tbl
->min_char
;
399 int i
= CHARTAB_IDX (c
, depth
, min_char
);
403 set_sub_char_table_contents (table
, i
, val
);
406 sub
= tbl
->contents
[i
];
407 if (! SUB_CHAR_TABLE_P (sub
))
409 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (sub
))
410 sub
= uniprop_table_uncompress (table
, i
);
413 sub
= make_sub_char_table (depth
+ 1,
414 min_char
+ i
* chartab_chars
[depth
],
416 set_sub_char_table_contents (table
, i
, sub
);
419 sub_char_table_set (sub
, c
, val
, is_uniprop
);
424 char_table_set (Lisp_Object table
, int c
, Lisp_Object val
)
426 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
429 && SUB_CHAR_TABLE_P (tbl
->ascii
))
430 set_sub_char_table_contents (tbl
->ascii
, c
, val
);
433 int i
= CHARTAB_IDX (c
, 0, 0);
436 sub
= tbl
->contents
[i
];
437 if (! SUB_CHAR_TABLE_P (sub
))
439 sub
= make_sub_char_table (1, i
* chartab_chars
[0], sub
);
440 set_char_table_contents (table
, i
, sub
);
442 sub_char_table_set (sub
, c
, val
, UNIPROP_TABLE_P (table
));
443 if (ASCII_CHAR_P (c
))
444 set_char_table_ascii (table
, char_table_ascii (table
));
449 sub_char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
,
452 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
453 int depth
= tbl
->depth
, min_char
= tbl
->min_char
;
454 int chars_in_block
= chartab_chars
[depth
];
455 int i
, c
, lim
= chartab_size
[depth
];
459 i
= CHARTAB_IDX (from
, depth
, min_char
);
460 c
= min_char
+ chars_in_block
* i
;
461 for (; i
< lim
; i
++, c
+= chars_in_block
)
465 if (from
<= c
&& c
+ chars_in_block
- 1 <= to
)
466 set_sub_char_table_contents (table
, i
, val
);
469 Lisp_Object sub
= tbl
->contents
[i
];
470 if (! SUB_CHAR_TABLE_P (sub
))
472 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (sub
))
473 sub
= uniprop_table_uncompress (table
, i
);
476 sub
= make_sub_char_table (depth
+ 1, c
, sub
);
477 set_sub_char_table_contents (table
, i
, sub
);
480 sub_char_table_set_range (sub
, from
, to
, val
, is_uniprop
);
487 char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
)
489 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
492 char_table_set (table
, from
, val
);
495 bool is_uniprop
= UNIPROP_TABLE_P (table
);
496 int lim
= CHARTAB_IDX (to
, 0, 0);
499 for (i
= CHARTAB_IDX (from
, 0, 0), c
= 0; i
<= lim
;
500 i
++, c
+= chartab_chars
[0])
504 if (from
<= c
&& c
+ chartab_chars
[0] - 1 <= to
)
505 set_char_table_contents (table
, i
, val
);
508 Lisp_Object sub
= tbl
->contents
[i
];
509 if (! SUB_CHAR_TABLE_P (sub
))
511 sub
= make_sub_char_table (1, i
* chartab_chars
[0], sub
);
512 set_char_table_contents (table
, i
, sub
);
514 sub_char_table_set_range (sub
, from
, to
, val
, is_uniprop
);
517 if (ASCII_CHAR_P (from
))
518 set_char_table_ascii (table
, char_table_ascii (table
));
523 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
526 Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
527 (Lisp_Object char_table
)
529 CHECK_CHAR_TABLE (char_table
);
531 return XCHAR_TABLE (char_table
)->purpose
;
534 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
536 doc
: /* Return the parent char-table of CHAR-TABLE.
537 The value is either nil or another char-table.
538 If CHAR-TABLE holds nil for a given character,
539 then the actual applicable value is inherited from the parent char-table
540 \(or from its parents, if necessary). */)
541 (Lisp_Object char_table
)
543 CHECK_CHAR_TABLE (char_table
);
545 return XCHAR_TABLE (char_table
)->parent
;
548 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
550 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
551 Return PARENT. PARENT must be either nil or another char-table. */)
552 (Lisp_Object char_table
, Lisp_Object parent
)
556 CHECK_CHAR_TABLE (char_table
);
560 CHECK_CHAR_TABLE (parent
);
562 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
563 if (EQ (temp
, char_table
))
564 error ("Attempt to make a chartable be its own parent");
567 set_char_table_parent (char_table
, parent
);
572 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
574 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
575 (Lisp_Object char_table
, Lisp_Object n
)
577 CHECK_CHAR_TABLE (char_table
);
580 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
581 args_out_of_range (char_table
, n
);
583 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
586 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
587 Sset_char_table_extra_slot
,
589 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
590 (Lisp_Object char_table
, Lisp_Object n
, Lisp_Object value
)
592 CHECK_CHAR_TABLE (char_table
);
595 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
596 args_out_of_range (char_table
, n
);
598 set_char_table_extras (char_table
, XINT (n
), value
);
602 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
604 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
605 RANGE should be nil (for the default value),
606 a cons of character codes (for characters in the range), or a character code. */)
607 (Lisp_Object char_table
, Lisp_Object range
)
610 CHECK_CHAR_TABLE (char_table
);
612 if (EQ (range
, Qnil
))
613 val
= XCHAR_TABLE (char_table
)->defalt
;
614 else if (CHARACTERP (range
))
615 val
= CHAR_TABLE_REF (char_table
, XFASTINT (range
));
616 else if (CONSP (range
))
620 CHECK_CHARACTER_CAR (range
);
621 CHECK_CHARACTER_CDR (range
);
622 from
= XFASTINT (XCAR (range
));
623 to
= XFASTINT (XCDR (range
));
624 val
= char_table_ref_and_range (char_table
, from
, &from
, &to
);
625 /* Not yet implemented. */
628 error ("Invalid RANGE argument to `char-table-range'");
632 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
634 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
635 RANGE should be t (for all characters), nil (for the default value),
636 a cons of character codes (for characters in the range),
637 or a character code. Return VALUE. */)
638 (Lisp_Object char_table
, Lisp_Object range
, Lisp_Object value
)
640 CHECK_CHAR_TABLE (char_table
);
645 set_char_table_ascii (char_table
, value
);
646 for (i
= 0; i
< chartab_size
[0]; i
++)
647 set_char_table_contents (char_table
, i
, value
);
649 else if (EQ (range
, Qnil
))
650 set_char_table_defalt (char_table
, value
);
651 else if (CHARACTERP (range
))
652 char_table_set (char_table
, XINT (range
), value
);
653 else if (CONSP (range
))
655 CHECK_CHARACTER_CAR (range
);
656 CHECK_CHARACTER_CDR (range
);
657 char_table_set_range (char_table
,
658 XINT (XCAR (range
)), XINT (XCDR (range
)), value
);
661 error ("Invalid RANGE argument to `set-char-table-range'");
667 optimize_sub_char_table (Lisp_Object table
, Lisp_Object test
)
669 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
670 int i
, depth
= tbl
->depth
;
671 Lisp_Object elt
, this;
674 elt
= XSUB_CHAR_TABLE (table
)->contents
[0];
675 if (SUB_CHAR_TABLE_P (elt
))
677 elt
= optimize_sub_char_table (elt
, test
);
678 set_sub_char_table_contents (table
, 0, elt
);
680 optimizable
= SUB_CHAR_TABLE_P (elt
) ? 0 : 1;
681 for (i
= 1; i
< chartab_size
[depth
]; i
++)
683 this = XSUB_CHAR_TABLE (table
)->contents
[i
];
684 if (SUB_CHAR_TABLE_P (this))
686 this = optimize_sub_char_table (this, test
);
687 set_sub_char_table_contents (table
, i
, this);
690 && (NILP (test
) ? NILP (Fequal (this, elt
)) /* defaults to `equal'. */
691 : EQ (test
, Qeq
) ? !EQ (this, elt
) /* Optimize `eq' case. */
692 : NILP (call2 (test
, this, elt
))))
696 return (optimizable
? elt
: table
);
699 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
701 doc
: /* Optimize CHAR-TABLE.
702 TEST is the comparison function used to decide whether two entries are
703 equivalent and can be merged. It defaults to `equal'. */)
704 (Lisp_Object char_table
, Lisp_Object test
)
709 CHECK_CHAR_TABLE (char_table
);
711 for (i
= 0; i
< chartab_size
[0]; i
++)
713 elt
= XCHAR_TABLE (char_table
)->contents
[i
];
714 if (SUB_CHAR_TABLE_P (elt
))
715 set_char_table_contents
716 (char_table
, i
, optimize_sub_char_table (elt
, test
));
718 /* Reset the `ascii' cache, in case it got optimized away. */
719 set_char_table_ascii (char_table
, char_table_ascii (char_table
));
725 /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
726 calling it for each character or group of characters that share a
727 value. RANGE is a cons (FROM . TO) specifying the range of target
728 characters, VAL is a value of FROM in TABLE, TOP is the top
731 ARG is passed to C_FUNCTION when that is called.
733 It returns the value of last character covered by TABLE (not the
734 value inherited from the parent), and by side-effect, the car part
735 of RANGE is updated to the minimum character C where C and all the
736 following characters in TABLE have the same value. */
739 map_sub_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
740 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
, Lisp_Object val
,
741 Lisp_Object range
, Lisp_Object top
)
743 /* Depth of TABLE. */
745 /* Minimum and maximum characters covered by TABLE. */
746 int min_char
, max_char
;
747 /* Number of characters covered by one element of TABLE. */
749 int from
= XINT (XCAR (range
)), to
= XINT (XCDR (range
));
751 bool is_uniprop
= UNIPROP_TABLE_P (top
);
752 uniprop_decoder_t decoder
= UNIPROP_GET_DECODER (top
);
754 if (SUB_CHAR_TABLE_P (table
))
756 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
759 min_char
= tbl
->min_char
;
760 max_char
= min_char
+ chartab_chars
[depth
- 1] - 1;
768 chars_in_block
= chartab_chars
[depth
];
772 /* Set I to the index of the first element to check. */
773 if (from
<= min_char
)
776 i
= (from
- min_char
) / chars_in_block
;
777 for (c
= min_char
+ chars_in_block
* i
; c
<= max_char
;
778 i
++, c
+= chars_in_block
)
780 Lisp_Object
this = (SUB_CHAR_TABLE_P (table
)
781 ? XSUB_CHAR_TABLE (table
)->contents
[i
]
782 : XCHAR_TABLE (table
)->contents
[i
]);
783 int nextc
= c
+ chars_in_block
;
785 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this))
786 this = uniprop_table_uncompress (table
, i
);
787 if (SUB_CHAR_TABLE_P (this))
790 XSETCDR (range
, make_number (nextc
- 1));
791 val
= map_sub_char_table (c_function
, function
, this, arg
,
797 this = XCHAR_TABLE (top
)->defalt
;
800 bool different_value
= 1;
804 if (! NILP (XCHAR_TABLE (top
)->parent
))
806 Lisp_Object parent
= XCHAR_TABLE (top
)->parent
;
807 Lisp_Object temp
= XCHAR_TABLE (parent
)->parent
;
809 /* This is to get a value of FROM in PARENT
810 without checking the parent of PARENT. */
811 set_char_table_parent (parent
, Qnil
);
812 val
= CHAR_TABLE_REF (parent
, from
);
813 set_char_table_parent (parent
, temp
);
814 XSETCDR (range
, make_number (c
- 1));
815 val
= map_sub_char_table (c_function
, function
,
816 parent
, arg
, val
, range
,
822 if (! NILP (val
) && different_value
)
824 XSETCDR (range
, make_number (c
- 1));
825 if (EQ (XCAR (range
), XCDR (range
)))
828 (*c_function
) (arg
, XCAR (range
), val
);
832 val
= decoder (top
, val
);
833 call2 (function
, XCAR (range
), val
);
839 (*c_function
) (arg
, range
, val
);
843 val
= decoder (top
, val
);
844 call2 (function
, range
, val
);
850 XSETCAR (range
, make_number (c
));
853 XSETCDR (range
, make_number (to
));
859 /* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
860 character or group of characters that share a value.
862 ARG is passed to C_FUNCTION when that is called. */
865 map_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
866 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
)
868 Lisp_Object range
, val
, parent
;
869 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
870 uniprop_decoder_t decoder
= UNIPROP_GET_DECODER (table
);
872 range
= Fcons (make_number (0), make_number (MAX_CHAR
));
873 parent
= XCHAR_TABLE (table
)->parent
;
875 GCPRO4 (table
, arg
, range
, parent
);
876 val
= XCHAR_TABLE (table
)->ascii
;
877 if (SUB_CHAR_TABLE_P (val
))
878 val
= XSUB_CHAR_TABLE (val
)->contents
[0];
879 val
= map_sub_char_table (c_function
, function
, table
, arg
, val
, range
,
882 /* If VAL is nil and TABLE has a parent, we must consult the parent
884 while (NILP (val
) && ! NILP (XCHAR_TABLE (table
)->parent
))
887 int from
= XINT (XCAR (range
));
889 parent
= XCHAR_TABLE (table
)->parent
;
890 temp
= XCHAR_TABLE (parent
)->parent
;
891 /* This is to get a value of FROM in PARENT without checking the
893 set_char_table_parent (parent
, Qnil
);
894 val
= CHAR_TABLE_REF (parent
, from
);
895 set_char_table_parent (parent
, temp
);
896 val
= map_sub_char_table (c_function
, function
, parent
, arg
, val
, range
,
903 if (EQ (XCAR (range
), XCDR (range
)))
906 (*c_function
) (arg
, XCAR (range
), val
);
910 val
= decoder (table
, val
);
911 call2 (function
, XCAR (range
), val
);
917 (*c_function
) (arg
, range
, val
);
921 val
= decoder (table
, val
);
922 call2 (function
, range
, val
);
930 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
932 doc
: /* Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
933 FUNCTION is called with two arguments, KEY and VALUE.
934 KEY is a character code or a cons of character codes specifying a
935 range of characters that have the same value.
936 VALUE is what (char-table-range CHAR-TABLE KEY) returns. */)
937 (Lisp_Object function
, Lisp_Object char_table
)
939 CHECK_CHAR_TABLE (char_table
);
941 map_char_table (NULL
, function
, char_table
, char_table
);
947 map_sub_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
948 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
949 Lisp_Object range
, struct charset
*charset
,
950 unsigned from
, unsigned to
)
952 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
953 int i
, c
= tbl
->min_char
, depth
= tbl
->depth
;
956 for (i
= 0; i
< chartab_size
[depth
]; i
++, c
+= chartab_chars
[depth
])
960 this = tbl
->contents
[i
];
961 if (SUB_CHAR_TABLE_P (this))
962 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
963 range
, charset
, from
, to
);
966 if (! NILP (XCAR (range
)))
968 XSETCDR (range
, make_number (c
- 1));
970 (*c_function
) (arg
, range
);
972 call2 (function
, range
, arg
);
974 XSETCAR (range
, Qnil
);
978 for (i
= 0; i
< chartab_size
[depth
]; i
++, c
++)
983 this = tbl
->contents
[i
];
986 && (code
= ENCODE_CHAR (charset
, c
),
987 (code
< from
|| code
> to
))))
989 if (! NILP (XCAR (range
)))
991 XSETCDR (range
, make_number (c
- 1));
993 (*c_function
) (arg
, range
);
995 call2 (function
, range
, arg
);
996 XSETCAR (range
, Qnil
);
1001 if (NILP (XCAR (range
)))
1002 XSETCAR (range
, make_number (c
));
1008 /* Support function for `map-charset-chars'. Map C_FUNCTION or
1009 FUNCTION over TABLE, calling it for each character or a group of
1010 succeeding characters that have non-nil value in TABLE. TABLE is a
1011 "mapping table" or a "deunifier table" of a certain charset.
1013 If CHARSET is not NULL (this is the case that `map-charset-chars'
1014 is called with non-nil FROM-CODE and TO-CODE), it is a charset who
1015 owns TABLE, and the function is called only on a character in the
1016 range FROM and TO. FROM and TO are not character codes, but code
1017 points of a character in CHARSET.
1019 This function is called in these two cases:
1021 (1) A charset has a mapping file name in :map property.
1023 (2) A charset has an upper code space in :offset property and a
1024 mapping file name in :unify-map property. In this case, this
1025 function is called only for characters in the Unicode code space.
1026 Characters in upper code space are handled directly in
1027 map_charset_chars. */
1030 map_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
1031 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
1032 struct charset
*charset
,
1033 unsigned from
, unsigned to
)
1037 struct gcpro gcpro1
;
1039 range
= Fcons (Qnil
, Qnil
);
1042 for (i
= 0, c
= 0; i
< chartab_size
[0]; i
++, c
+= chartab_chars
[0])
1046 this = XCHAR_TABLE (table
)->contents
[i
];
1047 if (SUB_CHAR_TABLE_P (this))
1048 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
1049 range
, charset
, from
, to
);
1052 if (! NILP (XCAR (range
)))
1054 XSETCDR (range
, make_number (c
- 1));
1056 (*c_function
) (arg
, range
);
1058 call2 (function
, range
, arg
);
1060 XSETCAR (range
, Qnil
);
1063 if (! NILP (XCAR (range
)))
1065 XSETCDR (range
, make_number (c
- 1));
1067 (*c_function
) (arg
, range
);
1069 call2 (function
, range
, arg
);
1076 /* Unicode character property tables.
1078 This section provides a convenient and efficient way to get Unicode
1079 character properties of characters from C code (from Lisp, you must
1080 use get-char-code-property).
1082 The typical usage is to get a char-table object for a specific
1083 property like this (use of the "bidi-class" property below is just
1086 Lisp_Object bidi_class_table = uniprop_table (intern ("bidi-class"));
1088 (uniprop_table can return nil if it fails to find data for the
1089 named property, or if it fails to load the appropriate Lisp support
1090 file, so the return value should be tested to be non-nil, before it
1093 To get a property value for character CH use CHAR_TABLE_REF:
1095 Lisp_Object bidi_class = CHAR_TABLE_REF (bidi_class_table, CH);
1097 In this case, what you actually get is an index number to the
1098 vector of property values (symbols nil, L, R, etc).
1100 The full list of Unicode character properties supported by Emacs is
1101 documented in the ELisp manual, in the node "Character Properties".
1103 A table for Unicode character property has these characteristics:
1105 o The purpose is `char-code-property-table', which implies that the
1106 table has 5 extra slots.
1108 o The second extra slot is a Lisp function, an index (integer) to
1109 the array uniprop_decoder[], or nil. If it is a Lisp function, we
1110 can't use such a table from C (at the moment). If it is nil, it
1111 means that we don't have to decode values.
1113 o The third extra slot is a Lisp function, an index (integer) to
1114 the array uniprop_encoder[], or nil. If it is a Lisp function, we
1115 can't use such a table from C (at the moment). If it is nil, it
1116 means that we don't have to encode values. */
1119 /* Uncompress the IDXth element of sub-char-table TABLE. */
1122 uniprop_table_uncompress (Lisp_Object table
, int idx
)
1124 Lisp_Object val
= XSUB_CHAR_TABLE (table
)->contents
[idx
];
1125 int min_char
= XSUB_CHAR_TABLE (table
)->min_char
+ chartab_chars
[2] * idx
;
1126 Lisp_Object sub
= make_sub_char_table (3, min_char
, Qnil
);
1127 const unsigned char *p
, *pend
;
1129 set_sub_char_table_contents (table
, idx
, sub
);
1130 p
= SDATA (val
), pend
= p
+ SBYTES (val
);
1135 idx
= STRING_CHAR_ADVANCE (p
);
1136 while (p
< pend
&& idx
< chartab_chars
[2])
1138 int v
= STRING_CHAR_ADVANCE (p
);
1139 set_sub_char_table_contents
1140 (sub
, idx
++, v
> 0 ? make_number (v
) : Qnil
);
1145 /* RUN-LENGTH TABLE */
1147 for (idx
= 0; p
< pend
; )
1149 int v
= STRING_CHAR_ADVANCE (p
);
1155 count
= STRING_CHAR_AND_LENGTH (p
, len
);
1165 set_sub_char_table_contents (sub
, idx
++, make_number (v
));
1168 /* It seems that we don't need this function because C code won't need
1169 to get a property that is compressed in this form. */
1173 /* WORD-LIST TABLE */
1180 /* Decode VALUE as an element of char-table TABLE. */
1183 uniprop_decode_value_run_length (Lisp_Object table
, Lisp_Object value
)
1185 if (VECTORP (XCHAR_TABLE (table
)->extras
[4]))
1187 Lisp_Object valvec
= XCHAR_TABLE (table
)->extras
[4];
1189 if (XINT (value
) >= 0 && XINT (value
) < ASIZE (valvec
))
1190 value
= AREF (valvec
, XINT (value
));
1195 static uniprop_decoder_t uniprop_decoder
[] =
1196 { uniprop_decode_value_run_length
};
1198 static const int uniprop_decoder_count
= ARRAYELTS (uniprop_decoder
);
1200 /* Return the decoder of char-table TABLE or nil if none. */
1202 static uniprop_decoder_t
1203 uniprop_get_decoder (Lisp_Object table
)
1207 if (! INTEGERP (XCHAR_TABLE (table
)->extras
[1]))
1209 i
= XINT (XCHAR_TABLE (table
)->extras
[1]);
1210 if (i
< 0 || i
>= uniprop_decoder_count
)
1212 return uniprop_decoder
[i
];
1216 /* Encode VALUE as an element of char-table TABLE which contains
1217 characters as elements. */
1220 uniprop_encode_value_character (Lisp_Object table
, Lisp_Object value
)
1222 if (! NILP (value
) && ! CHARACTERP (value
))
1223 wrong_type_argument (Qintegerp
, value
);
1228 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
1232 uniprop_encode_value_run_length (Lisp_Object table
, Lisp_Object value
)
1234 Lisp_Object
*value_table
= XVECTOR (XCHAR_TABLE (table
)->extras
[4])->contents
;
1235 int i
, size
= ASIZE (XCHAR_TABLE (table
)->extras
[4]);
1237 for (i
= 0; i
< size
; i
++)
1238 if (EQ (value
, value_table
[i
]))
1241 wrong_type_argument (build_string ("Unicode property value"), value
);
1242 return make_number (i
);
1246 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
1247 compression and contains numbers as elements. */
1250 uniprop_encode_value_numeric (Lisp_Object table
, Lisp_Object value
)
1252 Lisp_Object
*value_table
= XVECTOR (XCHAR_TABLE (table
)->extras
[4])->contents
;
1253 int i
, size
= ASIZE (XCHAR_TABLE (table
)->extras
[4]);
1255 CHECK_NUMBER (value
);
1256 for (i
= 0; i
< size
; i
++)
1257 if (EQ (value
, value_table
[i
]))
1259 value
= make_number (i
);
1262 Lisp_Object args
[2];
1264 args
[0] = XCHAR_TABLE (table
)->extras
[4];
1265 args
[1] = Fmake_vector (make_number (1), value
);
1266 set_char_table_extras (table
, 4, Fvconcat (2, args
));
1268 return make_number (i
);
1271 static uniprop_encoder_t uniprop_encoder
[] =
1272 { uniprop_encode_value_character
,
1273 uniprop_encode_value_run_length
,
1274 uniprop_encode_value_numeric
};
1276 static const int uniprop_encoder_count
= ARRAYELTS (uniprop_encoder
);
1278 /* Return the encoder of char-table TABLE or nil if none. */
1280 static uniprop_decoder_t
1281 uniprop_get_encoder (Lisp_Object table
)
1285 if (! INTEGERP (XCHAR_TABLE (table
)->extras
[2]))
1287 i
= XINT (XCHAR_TABLE (table
)->extras
[2]);
1288 if (i
< 0 || i
>= uniprop_encoder_count
)
1290 return uniprop_encoder
[i
];
1293 /* Return a char-table for Unicode character property PROP. This
1294 function may load a Lisp file and thus may cause
1295 garbage-collection. */
1298 uniprop_table (Lisp_Object prop
)
1300 Lisp_Object val
, table
, result
;
1302 val
= Fassq (prop
, Vchar_code_property_alist
);
1306 if (STRINGP (table
))
1308 struct gcpro gcpro1
;
1310 result
= Fload (concat2 (build_local_string ("international/"), table
),
1317 if (! CHAR_TABLE_P (table
)
1318 || ! UNIPROP_TABLE_P (table
))
1320 val
= XCHAR_TABLE (table
)->extras
[1];
1322 ? (XINT (val
) < 0 || XINT (val
) >= uniprop_decoder_count
)
1325 /* Prepare ASCII values in advance for CHAR_TABLE_REF. */
1326 set_char_table_ascii (table
, char_table_ascii (table
));
1330 DEFUN ("unicode-property-table-internal", Funicode_property_table_internal
,
1331 Sunicode_property_table_internal
, 1, 1, 0,
1332 doc
: /* Return a char-table for Unicode character property PROP.
1333 Use `get-unicode-property-internal' and
1334 `put-unicode-property-internal' instead of `aref' and `aset' to get
1335 and put an element value. */)
1338 Lisp_Object table
= uniprop_table (prop
);
1340 if (CHAR_TABLE_P (table
))
1342 return Fcdr (Fassq (prop
, Vchar_code_property_alist
));
1345 DEFUN ("get-unicode-property-internal", Fget_unicode_property_internal
,
1346 Sget_unicode_property_internal
, 2, 2, 0,
1347 doc
: /* Return an element of CHAR-TABLE for character CH.
1348 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
1349 (Lisp_Object char_table
, Lisp_Object ch
)
1352 uniprop_decoder_t decoder
;
1354 CHECK_CHAR_TABLE (char_table
);
1355 CHECK_CHARACTER (ch
);
1356 if (! UNIPROP_TABLE_P (char_table
))
1357 error ("Invalid Unicode property table");
1358 val
= CHAR_TABLE_REF (char_table
, XINT (ch
));
1359 decoder
= uniprop_get_decoder (char_table
);
1360 return (decoder
? decoder (char_table
, val
) : val
);
1363 DEFUN ("put-unicode-property-internal", Fput_unicode_property_internal
,
1364 Sput_unicode_property_internal
, 3, 3, 0,
1365 doc
: /* Set an element of CHAR-TABLE for character CH to VALUE.
1366 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
1367 (Lisp_Object char_table
, Lisp_Object ch
, Lisp_Object value
)
1369 uniprop_encoder_t encoder
;
1371 CHECK_CHAR_TABLE (char_table
);
1372 CHECK_CHARACTER (ch
);
1373 if (! UNIPROP_TABLE_P (char_table
))
1374 error ("Invalid Unicode property table");
1375 encoder
= uniprop_get_encoder (char_table
);
1377 value
= encoder (char_table
, value
);
1378 CHAR_TABLE_SET (char_table
, XINT (ch
), value
);
1384 syms_of_chartab (void)
1386 DEFSYM (Qchar_code_property_table
, "char-code-property-table");
1388 defsubr (&Smake_char_table
);
1389 defsubr (&Schar_table_parent
);
1390 defsubr (&Schar_table_subtype
);
1391 defsubr (&Sset_char_table_parent
);
1392 defsubr (&Schar_table_extra_slot
);
1393 defsubr (&Sset_char_table_extra_slot
);
1394 defsubr (&Schar_table_range
);
1395 defsubr (&Sset_char_table_range
);
1396 defsubr (&Soptimize_char_table
);
1397 defsubr (&Smap_char_table
);
1398 defsubr (&Sunicode_property_table_internal
);
1399 defsubr (&Sget_unicode_property_internal
);
1400 defsubr (&Sput_unicode_property_internal
);
1402 /* Each element has the form (PROP . TABLE).
1403 PROP is a symbol representing a character property.
1404 TABLE is a char-table containing the property value for each character.
1405 TABLE may be a name of file to load to build a char-table.
1406 This variable should be modified only through
1407 `define-char-code-property'. */
1409 DEFVAR_LISP ("char-code-property-alist", Vchar_code_property_alist
,
1410 doc
: /* Alist of character property name vs char-table containing property values.
1411 Internal use only. */);
1412 Vchar_code_property_alist
= Qnil
;