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 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
89 doc
: /* Return a newly created char-table, with purpose PURPOSE.
90 Each element is initialized to INIT, which defaults to nil.
92 PURPOSE should be a symbol. If it has a `char-table-extra-slots'
93 property, the property's value should be an integer between 0 and 10
94 that specifies how many extra slots the char-table has. Otherwise,
95 the char-table has no extra slot. */)
96 (register Lisp_Object purpose
, Lisp_Object init
)
103 CHECK_SYMBOL (purpose
);
104 n
= Fget (purpose
, Qchar_table_extra_slots
);
111 args_out_of_range (n
, Qnil
);
115 size
= VECSIZE (struct Lisp_Char_Table
) - 1 + n_extras
;
116 vector
= Fmake_vector (make_number (size
), init
);
117 XSETPVECTYPE (XVECTOR (vector
), PVEC_CHAR_TABLE
);
118 set_char_table_parent (vector
, Qnil
);
119 set_char_table_purpose (vector
, purpose
);
120 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
125 make_sub_char_table (int depth
, int min_char
, Lisp_Object defalt
)
128 int size
= VECSIZE (struct Lisp_Sub_Char_Table
) - 1 + chartab_size
[depth
];
130 table
= Fmake_vector (make_number (size
), defalt
);
131 XSETPVECTYPE (XVECTOR (table
), PVEC_SUB_CHAR_TABLE
);
132 XSUB_CHAR_TABLE (table
)->depth
= make_number (depth
);
133 XSUB_CHAR_TABLE (table
)->min_char
= make_number (min_char
);
139 char_table_ascii (Lisp_Object table
)
141 Lisp_Object sub
, val
;
143 sub
= XCHAR_TABLE (table
)->contents
[0];
144 if (! SUB_CHAR_TABLE_P (sub
))
146 sub
= XSUB_CHAR_TABLE (sub
)->contents
[0];
147 if (! SUB_CHAR_TABLE_P (sub
))
149 val
= XSUB_CHAR_TABLE (sub
)->contents
[0];
150 if (UNIPROP_TABLE_P (table
) && UNIPROP_COMPRESSED_FORM_P (val
))
151 val
= uniprop_table_uncompress (sub
, 0);
156 copy_sub_char_table (Lisp_Object table
)
158 int depth
= XINT (XSUB_CHAR_TABLE (table
)->depth
);
159 int min_char
= XINT (XSUB_CHAR_TABLE (table
)->min_char
);
160 Lisp_Object copy
= make_sub_char_table (depth
, min_char
, Qnil
);
163 /* Recursively copy any sub char-tables. */
164 for (i
= 0; i
< chartab_size
[depth
]; i
++)
166 Lisp_Object val
= XSUB_CHAR_TABLE (table
)->contents
[i
];
167 set_sub_char_table_contents
168 (copy
, i
, SUB_CHAR_TABLE_P (val
) ? copy_sub_char_table (val
) : val
);
176 copy_char_table (Lisp_Object table
)
179 int size
= XCHAR_TABLE (table
)->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
182 copy
= Fmake_vector (make_number (size
), Qnil
);
183 XSETPVECTYPE (XVECTOR (copy
), PVEC_CHAR_TABLE
);
184 set_char_table_defalt (copy
, XCHAR_TABLE (table
)->defalt
);
185 set_char_table_parent (copy
, XCHAR_TABLE (table
)->parent
);
186 set_char_table_purpose (copy
, XCHAR_TABLE (table
)->purpose
);
187 for (i
= 0; i
< chartab_size
[0]; i
++)
188 set_char_table_contents
190 (SUB_CHAR_TABLE_P (XCHAR_TABLE (table
)->contents
[i
])
191 ? copy_sub_char_table (XCHAR_TABLE (table
)->contents
[i
])
192 : XCHAR_TABLE (table
)->contents
[i
]));
193 set_char_table_ascii (copy
, char_table_ascii (copy
));
194 size
-= VECSIZE (struct Lisp_Char_Table
) - 1;
195 for (i
= 0; i
< size
; i
++)
196 set_char_table_extras (copy
, i
, XCHAR_TABLE (table
)->extras
[i
]);
198 XSETCHAR_TABLE (copy
, XCHAR_TABLE (copy
));
203 sub_char_table_ref (Lisp_Object table
, int c
, int is_uniprop
)
205 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
206 int depth
= XINT (tbl
->depth
);
207 int min_char
= XINT (tbl
->min_char
);
209 int idx
= CHARTAB_IDX (c
, depth
, min_char
);
211 val
= tbl
->contents
[idx
];
212 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
213 val
= uniprop_table_uncompress (table
, idx
);
214 if (SUB_CHAR_TABLE_P (val
))
215 val
= sub_char_table_ref (val
, c
, is_uniprop
);
220 char_table_ref (Lisp_Object table
, int c
)
222 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
225 if (ASCII_CHAR_P (c
))
228 if (SUB_CHAR_TABLE_P (val
))
229 val
= XSUB_CHAR_TABLE (val
)->contents
[c
];
233 val
= tbl
->contents
[CHARTAB_IDX (c
, 0, 0)];
234 if (SUB_CHAR_TABLE_P (val
))
235 val
= sub_char_table_ref (val
, c
, UNIPROP_TABLE_P (table
));
240 if (NILP (val
) && CHAR_TABLE_P (tbl
->parent
))
241 val
= char_table_ref (tbl
->parent
, c
);
247 sub_char_table_ref_and_range (Lisp_Object table
, int c
, int *from
, int *to
,
248 Lisp_Object defalt
, int is_uniprop
)
250 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
251 int depth
= XINT (tbl
->depth
);
252 int min_char
= XINT (tbl
->min_char
);
253 int chartab_idx
= CHARTAB_IDX (c
, depth
, min_char
), idx
;
256 val
= tbl
->contents
[chartab_idx
];
257 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
258 val
= uniprop_table_uncompress (table
, chartab_idx
);
259 if (SUB_CHAR_TABLE_P (val
))
260 val
= sub_char_table_ref_and_range (val
, c
, from
, to
, defalt
, is_uniprop
);
265 while (idx
> 0 && *from
< min_char
+ idx
* chartab_chars
[depth
])
267 Lisp_Object this_val
;
269 c
= min_char
+ idx
* chartab_chars
[depth
] - 1;
271 this_val
= tbl
->contents
[idx
];
272 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
273 this_val
= uniprop_table_uncompress (table
, idx
);
274 if (SUB_CHAR_TABLE_P (this_val
))
275 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
, defalt
,
277 else if (NILP (this_val
))
280 if (! EQ (this_val
, val
))
286 while (((c
= (chartab_idx
+ 1) * chartab_chars
[depth
])
287 < chartab_chars
[depth
- 1])
288 && (c
+= min_char
) <= *to
)
290 Lisp_Object this_val
;
293 this_val
= tbl
->contents
[chartab_idx
];
294 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
295 this_val
= uniprop_table_uncompress (table
, chartab_idx
);
296 if (SUB_CHAR_TABLE_P (this_val
))
297 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
, defalt
,
299 else if (NILP (this_val
))
301 if (! EQ (this_val
, val
))
312 /* Return the value for C in char-table TABLE. Shrink the range *FROM
313 and *TO to cover characters (containing C) that have the same value
314 as C. It is not assured that the values of (*FROM - 1) and (*TO +
315 1) are different from that of C. */
318 char_table_ref_and_range (Lisp_Object table
, int c
, int *from
, int *to
)
320 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
321 int chartab_idx
= CHARTAB_IDX (c
, 0, 0), idx
;
323 int is_uniprop
= UNIPROP_TABLE_P (table
);
325 val
= tbl
->contents
[chartab_idx
];
330 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
331 val
= uniprop_table_uncompress (table
, chartab_idx
);
332 if (SUB_CHAR_TABLE_P (val
))
333 val
= sub_char_table_ref_and_range (val
, c
, from
, to
, tbl
->defalt
,
338 while (*from
< idx
* chartab_chars
[0])
340 Lisp_Object this_val
;
342 c
= idx
* chartab_chars
[0] - 1;
344 this_val
= tbl
->contents
[idx
];
345 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
346 this_val
= uniprop_table_uncompress (table
, idx
);
347 if (SUB_CHAR_TABLE_P (this_val
))
348 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
,
349 tbl
->defalt
, is_uniprop
);
350 else if (NILP (this_val
))
351 this_val
= tbl
->defalt
;
353 if (! EQ (this_val
, val
))
359 while (*to
>= (chartab_idx
+ 1) * chartab_chars
[0])
361 Lisp_Object this_val
;
364 c
= chartab_idx
* chartab_chars
[0];
365 this_val
= tbl
->contents
[chartab_idx
];
366 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
367 this_val
= uniprop_table_uncompress (table
, chartab_idx
);
368 if (SUB_CHAR_TABLE_P (this_val
))
369 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
,
370 tbl
->defalt
, is_uniprop
);
371 else if (NILP (this_val
))
372 this_val
= tbl
->defalt
;
373 if (! EQ (this_val
, val
))
385 sub_char_table_set (Lisp_Object table
, int c
, Lisp_Object val
, int is_uniprop
)
387 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
388 int depth
= XINT ((tbl
)->depth
);
389 int min_char
= XINT ((tbl
)->min_char
);
390 int i
= CHARTAB_IDX (c
, depth
, min_char
);
394 set_sub_char_table_contents (table
, i
, val
);
397 sub
= tbl
->contents
[i
];
398 if (! SUB_CHAR_TABLE_P (sub
))
400 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (sub
))
401 sub
= uniprop_table_uncompress (table
, i
);
404 sub
= make_sub_char_table (depth
+ 1,
405 min_char
+ i
* chartab_chars
[depth
],
407 set_sub_char_table_contents (table
, i
, sub
);
410 sub_char_table_set (sub
, c
, val
, is_uniprop
);
415 char_table_set (Lisp_Object table
, int c
, Lisp_Object val
)
417 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
420 && SUB_CHAR_TABLE_P (tbl
->ascii
))
421 set_sub_char_table_contents (tbl
->ascii
, c
, val
);
424 int i
= CHARTAB_IDX (c
, 0, 0);
427 sub
= tbl
->contents
[i
];
428 if (! SUB_CHAR_TABLE_P (sub
))
430 sub
= make_sub_char_table (1, i
* chartab_chars
[0], sub
);
431 set_char_table_contents (table
, i
, sub
);
433 sub_char_table_set (sub
, c
, val
, UNIPROP_TABLE_P (table
));
434 if (ASCII_CHAR_P (c
))
435 set_char_table_ascii (table
, char_table_ascii (table
));
441 sub_char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
,
444 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
445 int depth
= XINT ((tbl
)->depth
);
446 int min_char
= XINT ((tbl
)->min_char
);
447 int chars_in_block
= chartab_chars
[depth
];
448 int i
, c
, lim
= chartab_size
[depth
];
452 i
= CHARTAB_IDX (from
, depth
, min_char
);
453 c
= min_char
+ chars_in_block
* i
;
454 for (; i
< lim
; i
++, c
+= chars_in_block
)
458 if (from
<= c
&& c
+ chars_in_block
- 1 <= to
)
459 set_sub_char_table_contents (table
, i
, val
);
462 Lisp_Object sub
= tbl
->contents
[i
];
463 if (! SUB_CHAR_TABLE_P (sub
))
465 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (sub
))
466 sub
= uniprop_table_uncompress (table
, i
);
469 sub
= make_sub_char_table (depth
+ 1, c
, sub
);
470 set_sub_char_table_contents (table
, i
, sub
);
473 sub_char_table_set_range (sub
, from
, to
, val
, is_uniprop
);
480 char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
)
482 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
485 char_table_set (table
, from
, val
);
488 int is_uniprop
= UNIPROP_TABLE_P (table
);
489 int lim
= CHARTAB_IDX (to
, 0, 0);
492 for (i
= CHARTAB_IDX (from
, 0, 0), c
= 0; i
<= lim
;
493 i
++, c
+= chartab_chars
[0])
497 if (from
<= c
&& c
+ chartab_chars
[0] - 1 <= to
)
498 set_char_table_contents (table
, i
, val
);
501 Lisp_Object sub
= tbl
->contents
[i
];
502 if (! SUB_CHAR_TABLE_P (sub
))
504 sub
= make_sub_char_table (1, i
* chartab_chars
[0], sub
);
505 set_char_table_contents (table
, i
, sub
);
507 sub_char_table_set_range (sub
, from
, to
, val
, is_uniprop
);
510 if (ASCII_CHAR_P (from
))
511 set_char_table_ascii (table
, char_table_ascii (table
));
517 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
520 Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
521 (Lisp_Object char_table
)
523 CHECK_CHAR_TABLE (char_table
);
525 return XCHAR_TABLE (char_table
)->purpose
;
528 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
530 doc
: /* Return the parent char-table of CHAR-TABLE.
531 The value is either nil or another char-table.
532 If CHAR-TABLE holds nil for a given character,
533 then the actual applicable value is inherited from the parent char-table
534 \(or from its parents, if necessary). */)
535 (Lisp_Object char_table
)
537 CHECK_CHAR_TABLE (char_table
);
539 return XCHAR_TABLE (char_table
)->parent
;
542 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
544 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
545 Return PARENT. PARENT must be either nil or another char-table. */)
546 (Lisp_Object char_table
, Lisp_Object parent
)
550 CHECK_CHAR_TABLE (char_table
);
554 CHECK_CHAR_TABLE (parent
);
556 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
557 if (EQ (temp
, char_table
))
558 error ("Attempt to make a chartable be its own parent");
561 set_char_table_parent (char_table
, parent
);
566 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
568 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
569 (Lisp_Object char_table
, Lisp_Object n
)
571 CHECK_CHAR_TABLE (char_table
);
574 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
575 args_out_of_range (char_table
, n
);
577 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
580 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
581 Sset_char_table_extra_slot
,
583 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
584 (Lisp_Object char_table
, Lisp_Object n
, Lisp_Object value
)
586 CHECK_CHAR_TABLE (char_table
);
589 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
590 args_out_of_range (char_table
, n
);
592 set_char_table_extras (char_table
, XINT (n
), value
);
596 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
598 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
599 RANGE should be nil (for the default value),
600 a cons of character codes (for characters in the range), or a character code. */)
601 (Lisp_Object char_table
, Lisp_Object range
)
604 CHECK_CHAR_TABLE (char_table
);
606 if (EQ (range
, Qnil
))
607 val
= XCHAR_TABLE (char_table
)->defalt
;
608 else if (CHARACTERP (range
))
609 val
= CHAR_TABLE_REF (char_table
, XFASTINT (range
));
610 else if (CONSP (range
))
614 CHECK_CHARACTER_CAR (range
);
615 CHECK_CHARACTER_CDR (range
);
616 from
= XFASTINT (XCAR (range
));
617 to
= XFASTINT (XCDR (range
));
618 val
= char_table_ref_and_range (char_table
, from
, &from
, &to
);
619 /* Not yet implemented. */
622 error ("Invalid RANGE argument to `char-table-range'");
626 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
628 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
629 RANGE should be t (for all characters), nil (for the default value),
630 a cons of character codes (for characters in the range),
631 or a character code. Return VALUE. */)
632 (Lisp_Object char_table
, Lisp_Object range
, Lisp_Object value
)
634 CHECK_CHAR_TABLE (char_table
);
639 set_char_table_ascii (char_table
, value
);
640 for (i
= 0; i
< chartab_size
[0]; i
++)
641 set_char_table_contents (char_table
, i
, value
);
643 else if (EQ (range
, Qnil
))
644 set_char_table_defalt (char_table
, value
);
645 else if (CHARACTERP (range
))
646 char_table_set (char_table
, XINT (range
), value
);
647 else if (CONSP (range
))
649 CHECK_CHARACTER_CAR (range
);
650 CHECK_CHARACTER_CDR (range
);
651 char_table_set_range (char_table
,
652 XINT (XCAR (range
)), XINT (XCDR (range
)), value
);
655 error ("Invalid RANGE argument to `set-char-table-range'");
660 DEFUN ("set-char-table-default", Fset_char_table_default
,
661 Sset_char_table_default
, 3, 3, 0,
663 This function is obsolete and has no effect. */)
664 (Lisp_Object char_table
, Lisp_Object ch
, Lisp_Object value
)
669 /* Look up the element in TABLE at index CH, and return it as an
670 integer. If the element is not a character, return CH itself. */
673 char_table_translate (Lisp_Object table
, int ch
)
676 value
= Faref (table
, make_number (ch
));
677 if (! CHARACTERP (value
))
683 optimize_sub_char_table (Lisp_Object table
, Lisp_Object test
)
685 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
686 int depth
= XINT (tbl
->depth
);
687 Lisp_Object elt
, this;
690 elt
= XSUB_CHAR_TABLE (table
)->contents
[0];
691 if (SUB_CHAR_TABLE_P (elt
))
693 elt
= optimize_sub_char_table (elt
, test
);
694 set_sub_char_table_contents (table
, 0, elt
);
696 optimizable
= SUB_CHAR_TABLE_P (elt
) ? 0 : 1;
697 for (i
= 1; i
< chartab_size
[depth
]; i
++)
699 this = XSUB_CHAR_TABLE (table
)->contents
[i
];
700 if (SUB_CHAR_TABLE_P (this))
702 this = optimize_sub_char_table (this, test
);
703 set_sub_char_table_contents (table
, i
, this);
706 && (NILP (test
) ? NILP (Fequal (this, elt
)) /* defaults to `equal'. */
707 : EQ (test
, Qeq
) ? !EQ (this, elt
) /* Optimize `eq' case. */
708 : NILP (call2 (test
, this, elt
))))
712 return (optimizable
? elt
: table
);
715 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
717 doc
: /* Optimize CHAR-TABLE.
718 TEST is the comparison function used to decide whether two entries are
719 equivalent and can be merged. It defaults to `equal'. */)
720 (Lisp_Object char_table
, Lisp_Object test
)
725 CHECK_CHAR_TABLE (char_table
);
727 for (i
= 0; i
< chartab_size
[0]; i
++)
729 elt
= XCHAR_TABLE (char_table
)->contents
[i
];
730 if (SUB_CHAR_TABLE_P (elt
))
731 set_char_table_contents
732 (char_table
, i
, optimize_sub_char_table (elt
, test
));
734 /* Reset the `ascii' cache, in case it got optimized away. */
735 set_char_table_ascii (char_table
, char_table_ascii (char_table
));
741 /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
742 calling it for each character or group of characters that share a
743 value. RANGE is a cons (FROM . TO) specifying the range of target
744 characters, VAL is a value of FROM in TABLE, TOP is the top
747 ARG is passed to C_FUNCTION when that is called.
749 It returns the value of last character covered by TABLE (not the
750 value inherited from the parent), and by side-effect, the car part
751 of RANGE is updated to the minimum character C where C and all the
752 following characters in TABLE have the same value. */
755 map_sub_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
756 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
, Lisp_Object val
,
757 Lisp_Object range
, Lisp_Object top
)
759 /* Depth of TABLE. */
761 /* Minimum and maximum characters covered by TABLE. */
762 int min_char
, max_char
;
763 /* Number of characters covered by one element of TABLE. */
765 int from
= XINT (XCAR (range
)), to
= XINT (XCDR (range
));
767 int is_uniprop
= UNIPROP_TABLE_P (top
);
768 uniprop_decoder_t decoder
= UNIPROP_GET_DECODER (top
);
770 if (SUB_CHAR_TABLE_P (table
))
772 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
774 depth
= XINT (tbl
->depth
);
775 min_char
= XINT (tbl
->min_char
);
776 max_char
= min_char
+ chartab_chars
[depth
- 1] - 1;
784 chars_in_block
= chartab_chars
[depth
];
788 /* Set I to the index of the first element to check. */
789 if (from
<= min_char
)
792 i
= (from
- min_char
) / chars_in_block
;
793 for (c
= min_char
+ chars_in_block
* i
; c
<= max_char
;
794 i
++, c
+= chars_in_block
)
796 Lisp_Object
this = (SUB_CHAR_TABLE_P (table
)
797 ? XSUB_CHAR_TABLE (table
)->contents
[i
]
798 : XCHAR_TABLE (table
)->contents
[i
]);
799 int nextc
= c
+ chars_in_block
;
801 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this))
802 this = uniprop_table_uncompress (table
, i
);
803 if (SUB_CHAR_TABLE_P (this))
806 XSETCDR (range
, make_number (nextc
- 1));
807 val
= map_sub_char_table (c_function
, function
, this, arg
,
813 this = XCHAR_TABLE (top
)->defalt
;
816 int different_value
= 1;
820 if (! NILP (XCHAR_TABLE (top
)->parent
))
822 Lisp_Object parent
= XCHAR_TABLE (top
)->parent
;
823 Lisp_Object temp
= XCHAR_TABLE (parent
)->parent
;
825 /* This is to get a value of FROM in PARENT
826 without checking the parent of PARENT. */
827 set_char_table_parent (parent
, Qnil
);
828 val
= CHAR_TABLE_REF (parent
, from
);
829 set_char_table_parent (parent
, temp
);
830 XSETCDR (range
, make_number (c
- 1));
831 val
= map_sub_char_table (c_function
, function
,
832 parent
, arg
, val
, range
,
838 if (! NILP (val
) && different_value
)
840 XSETCDR (range
, make_number (c
- 1));
841 if (EQ (XCAR (range
), XCDR (range
)))
844 (*c_function
) (arg
, XCAR (range
), val
);
848 val
= decoder (top
, val
);
849 call2 (function
, XCAR (range
), val
);
855 (*c_function
) (arg
, range
, val
);
859 val
= decoder (top
, val
);
860 call2 (function
, range
, val
);
866 XSETCAR (range
, make_number (c
));
869 XSETCDR (range
, make_number (to
));
875 /* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
876 character or group of characters that share a value.
878 ARG is passed to C_FUNCTION when that is called. */
881 map_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
882 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
)
884 Lisp_Object range
, val
, parent
;
885 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
886 uniprop_decoder_t decoder
= UNIPROP_GET_DECODER (table
);
888 range
= Fcons (make_number (0), make_number (MAX_CHAR
));
889 parent
= XCHAR_TABLE (table
)->parent
;
891 GCPRO4 (table
, arg
, range
, parent
);
892 val
= XCHAR_TABLE (table
)->ascii
;
893 if (SUB_CHAR_TABLE_P (val
))
894 val
= XSUB_CHAR_TABLE (val
)->contents
[0];
895 val
= map_sub_char_table (c_function
, function
, table
, arg
, val
, range
,
898 /* If VAL is nil and TABLE has a parent, we must consult the parent
900 while (NILP (val
) && ! NILP (XCHAR_TABLE (table
)->parent
))
903 int from
= XINT (XCAR (range
));
905 parent
= XCHAR_TABLE (table
)->parent
;
906 temp
= XCHAR_TABLE (parent
)->parent
;
907 /* This is to get a value of FROM in PARENT without checking the
909 set_char_table_parent (parent
, Qnil
);
910 val
= CHAR_TABLE_REF (parent
, from
);
911 set_char_table_parent (parent
, temp
);
912 val
= map_sub_char_table (c_function
, function
, parent
, arg
, val
, range
,
919 if (EQ (XCAR (range
), XCDR (range
)))
922 (*c_function
) (arg
, XCAR (range
), val
);
926 val
= decoder (table
, val
);
927 call2 (function
, XCAR (range
), val
);
933 (*c_function
) (arg
, range
, val
);
937 val
= decoder (table
, val
);
938 call2 (function
, range
, val
);
946 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
948 doc
: /* Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
949 FUNCTION is called with two arguments, KEY and VALUE.
950 KEY is a character code or a cons of character codes specifying a
951 range of characters that have the same value.
952 VALUE is what (char-table-range CHAR-TABLE KEY) returns. */)
953 (Lisp_Object function
, Lisp_Object char_table
)
955 CHECK_CHAR_TABLE (char_table
);
957 map_char_table (NULL
, function
, char_table
, char_table
);
963 map_sub_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
964 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
965 Lisp_Object range
, struct charset
*charset
,
966 unsigned from
, unsigned to
)
968 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
969 int depth
= XINT (tbl
->depth
);
973 for (i
= 0, c
= XINT (tbl
->min_char
); i
< chartab_size
[depth
];
974 i
++, c
+= chartab_chars
[depth
])
978 this = tbl
->contents
[i
];
979 if (SUB_CHAR_TABLE_P (this))
980 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
981 range
, charset
, from
, to
);
984 if (! NILP (XCAR (range
)))
986 XSETCDR (range
, make_number (c
- 1));
988 (*c_function
) (arg
, range
);
990 call2 (function
, range
, arg
);
992 XSETCAR (range
, Qnil
);
996 for (i
= 0, c
= XINT (tbl
->min_char
); i
< chartab_size
[depth
]; i
++, c
++)
1001 this = tbl
->contents
[i
];
1004 && (code
= ENCODE_CHAR (charset
, c
),
1005 (code
< from
|| code
> to
))))
1007 if (! NILP (XCAR (range
)))
1009 XSETCDR (range
, make_number (c
- 1));
1011 (*c_function
) (arg
, range
);
1013 call2 (function
, range
, arg
);
1014 XSETCAR (range
, Qnil
);
1019 if (NILP (XCAR (range
)))
1020 XSETCAR (range
, make_number (c
));
1026 /* Support function for `map-charset-chars'. Map C_FUNCTION or
1027 FUNCTION over TABLE, calling it for each character or a group of
1028 succeeding characters that have non-nil value in TABLE. TABLE is a
1029 "mapping table" or a "deunifier table" of a certain charset.
1031 If CHARSET is not NULL (this is the case that `map-charset-chars'
1032 is called with non-nil FROM-CODE and TO-CODE), it is a charset who
1033 owns TABLE, and the function is called only on a character in the
1034 range FROM and TO. FROM and TO are not character codes, but code
1035 points of a character in CHARSET.
1037 This function is called in these two cases:
1039 (1) A charset has a mapping file name in :map property.
1041 (2) A charset has an upper code space in :offset property and a
1042 mapping file name in :unify-map property. In this case, this
1043 function is called only for characters in the Unicode code space.
1044 Characters in upper code space are handled directly in
1045 map_charset_chars. */
1048 map_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
1049 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
1050 struct charset
*charset
,
1051 unsigned from
, unsigned to
)
1055 struct gcpro gcpro1
;
1057 range
= Fcons (Qnil
, Qnil
);
1060 for (i
= 0, c
= 0; i
< chartab_size
[0]; i
++, c
+= chartab_chars
[0])
1064 this = XCHAR_TABLE (table
)->contents
[i
];
1065 if (SUB_CHAR_TABLE_P (this))
1066 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
1067 range
, charset
, from
, to
);
1070 if (! NILP (XCAR (range
)))
1072 XSETCDR (range
, make_number (c
- 1));
1074 (*c_function
) (arg
, range
);
1076 call2 (function
, range
, arg
);
1078 XSETCAR (range
, Qnil
);
1081 if (! NILP (XCAR (range
)))
1083 XSETCDR (range
, make_number (c
- 1));
1085 (*c_function
) (arg
, range
);
1087 call2 (function
, range
, arg
);
1094 /* Unicode character property tables.
1096 This section provides a convenient and efficient way to get Unicode
1097 character properties of characters from C code (from Lisp, you must
1098 use get-char-code-property).
1100 The typical usage is to get a char-table object for a specific
1101 property like this (use of the "bidi-class" property below is just
1104 Lisp_Object bidi_class_table = uniprop_table (intern ("bidi-class"));
1106 (uniprop_table can return nil if it fails to find data for the
1107 named property, or if it fails to load the appropriate Lisp support
1108 file, so the return value should be tested to be non-nil, before it
1111 To get a property value for character CH use CHAR_TABLE_REF:
1113 Lisp_Object bidi_class = CHAR_TABLE_REF (bidi_class_table, CH);
1115 In this case, what you actually get is an index number to the
1116 vector of property values (symbols nil, L, R, etc).
1118 The full list of Unicode character properties supported by Emacs is
1119 documented in the ELisp manual, in the node "Character Properties".
1121 A table for Unicode character property has these characteristics:
1123 o The purpose is `char-code-property-table', which implies that the
1124 table has 5 extra slots.
1126 o The second extra slot is a Lisp function, an index (integer) to
1127 the array uniprop_decoder[], or nil. If it is a Lisp function, we
1128 can't use such a table from C (at the moment). If it is nil, it
1129 means that we don't have to decode values.
1131 o The third extra slot is a Lisp function, an index (integer) to
1132 the array uniprop_encoder[], or nil. If it is a Lisp function, we
1133 can't use such a table from C (at the moment). If it is nil, it
1134 means that we don't have to encode values. */
1137 /* Uncompress the IDXth element of sub-char-table TABLE. */
1140 uniprop_table_uncompress (Lisp_Object table
, int idx
)
1142 Lisp_Object val
= XSUB_CHAR_TABLE (table
)->contents
[idx
];
1143 int min_char
= (XINT (XSUB_CHAR_TABLE (table
)->min_char
)
1144 + chartab_chars
[2] * idx
);
1145 Lisp_Object sub
= make_sub_char_table (3, min_char
, Qnil
);
1146 const unsigned char *p
, *pend
;
1148 set_sub_char_table_contents (table
, idx
, sub
);
1149 p
= SDATA (val
), pend
= p
+ SBYTES (val
);
1154 idx
= STRING_CHAR_ADVANCE (p
);
1155 while (p
< pend
&& idx
< chartab_chars
[2])
1157 int v
= STRING_CHAR_ADVANCE (p
);
1158 set_sub_char_table_contents
1159 (sub
, idx
++, v
> 0 ? make_number (v
) : Qnil
);
1164 /* RUN-LENGTH TABLE */
1166 for (idx
= 0; p
< pend
; )
1168 int v
= STRING_CHAR_ADVANCE (p
);
1174 count
= STRING_CHAR_AND_LENGTH (p
, len
);
1184 set_sub_char_table_contents (sub
, idx
++, make_number (v
));
1187 /* It seems that we don't need this function because C code won't need
1188 to get a property that is compressed in this form. */
1192 /* WORD-LIST TABLE */
1199 /* Decode VALUE as an element of char-table TABLE. */
1202 uniprop_decode_value_run_length (Lisp_Object table
, Lisp_Object value
)
1204 if (VECTORP (XCHAR_TABLE (table
)->extras
[4]))
1206 Lisp_Object valvec
= XCHAR_TABLE (table
)->extras
[4];
1208 if (XINT (value
) >= 0 && XINT (value
) < ASIZE (valvec
))
1209 value
= AREF (valvec
, XINT (value
));
1214 static uniprop_decoder_t uniprop_decoder
[] =
1215 { uniprop_decode_value_run_length
};
1217 static int uniprop_decoder_count
1218 = (sizeof uniprop_decoder
) / sizeof (uniprop_decoder
[0]);
1221 /* Return the decoder of char-table TABLE or nil if none. */
1223 static uniprop_decoder_t
1224 uniprop_get_decoder (Lisp_Object table
)
1228 if (! INTEGERP (XCHAR_TABLE (table
)->extras
[1]))
1230 i
= XINT (XCHAR_TABLE (table
)->extras
[1]);
1231 if (i
< 0 || i
>= uniprop_decoder_count
)
1233 return uniprop_decoder
[i
];
1237 /* Encode VALUE as an element of char-table TABLE which contains
1238 characters as elements. */
1241 uniprop_encode_value_character (Lisp_Object table
, Lisp_Object value
)
1243 if (! NILP (value
) && ! CHARACTERP (value
))
1244 wrong_type_argument (Qintegerp
, value
);
1249 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
1253 uniprop_encode_value_run_length (Lisp_Object table
, Lisp_Object value
)
1255 Lisp_Object
*value_table
= XVECTOR (XCHAR_TABLE (table
)->extras
[4])->contents
;
1256 int i
, size
= ASIZE (XCHAR_TABLE (table
)->extras
[4]);
1258 for (i
= 0; i
< size
; i
++)
1259 if (EQ (value
, value_table
[i
]))
1262 wrong_type_argument (build_string ("Unicode property value"), value
);
1263 return make_number (i
);
1267 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
1268 compression and contains numbers as elements . */
1271 uniprop_encode_value_numeric (Lisp_Object table
, Lisp_Object value
)
1273 Lisp_Object
*value_table
= XVECTOR (XCHAR_TABLE (table
)->extras
[4])->contents
;
1274 int i
, size
= ASIZE (XCHAR_TABLE (table
)->extras
[4]);
1276 CHECK_NUMBER (value
);
1277 for (i
= 0; i
< size
; i
++)
1278 if (EQ (value
, value_table
[i
]))
1280 value
= make_number (i
);
1283 Lisp_Object args
[2];
1285 args
[0] = XCHAR_TABLE (table
)->extras
[4];
1286 args
[1] = Fmake_vector (make_number (1), value
);
1287 set_char_table_extras (table
, 4, Fvconcat (2, args
));
1289 return make_number (i
);
1292 static uniprop_encoder_t uniprop_encoder
[] =
1293 { uniprop_encode_value_character
,
1294 uniprop_encode_value_run_length
,
1295 uniprop_encode_value_numeric
};
1297 static int uniprop_encoder_count
1298 = (sizeof uniprop_encoder
) / sizeof (uniprop_encoder
[0]);
1301 /* Return the encoder of char-table TABLE or nil if none. */
1303 static uniprop_decoder_t
1304 uniprop_get_encoder (Lisp_Object table
)
1308 if (! INTEGERP (XCHAR_TABLE (table
)->extras
[2]))
1310 i
= XINT (XCHAR_TABLE (table
)->extras
[2]);
1311 if (i
< 0 || i
>= uniprop_encoder_count
)
1313 return uniprop_encoder
[i
];
1316 /* Return a char-table for Unicode character property PROP. This
1317 function may load a Lisp file and thus may cause
1318 garbage-collection. */
1321 uniprop_table (Lisp_Object prop
)
1323 Lisp_Object val
, table
, result
;
1325 val
= Fassq (prop
, Vchar_code_property_alist
);
1329 if (STRINGP (table
))
1331 struct gcpro gcpro1
;
1333 result
= Fload (concat2 (build_string ("international/"), table
),
1340 if (! CHAR_TABLE_P (table
)
1341 || ! UNIPROP_TABLE_P (table
))
1343 val
= XCHAR_TABLE (table
)->extras
[1];
1345 ? (XINT (val
) < 0 || XINT (val
) >= uniprop_decoder_count
)
1348 /* Prepare ASCII values in advance for CHAR_TABLE_REF. */
1349 set_char_table_ascii (table
, char_table_ascii (table
));
1353 DEFUN ("unicode-property-table-internal", Funicode_property_table_internal
,
1354 Sunicode_property_table_internal
, 1, 1, 0,
1355 doc
: /* Return a char-table for Unicode character property PROP.
1356 Use `get-unicode-property-internal' and
1357 `put-unicode-property-internal' instead of `aref' and `aset' to get
1358 and put an element value. */)
1361 Lisp_Object table
= uniprop_table (prop
);
1363 if (CHAR_TABLE_P (table
))
1365 return Fcdr (Fassq (prop
, Vchar_code_property_alist
));
1368 DEFUN ("get-unicode-property-internal", Fget_unicode_property_internal
,
1369 Sget_unicode_property_internal
, 2, 2, 0,
1370 doc
: /* Return an element of CHAR-TABLE for character CH.
1371 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
1372 (Lisp_Object char_table
, Lisp_Object ch
)
1375 uniprop_decoder_t decoder
;
1377 CHECK_CHAR_TABLE (char_table
);
1378 CHECK_CHARACTER (ch
);
1379 if (! UNIPROP_TABLE_P (char_table
))
1380 error ("Invalid Unicode property table");
1381 val
= CHAR_TABLE_REF (char_table
, XINT (ch
));
1382 decoder
= uniprop_get_decoder (char_table
);
1383 return (decoder
? decoder (char_table
, val
) : val
);
1386 DEFUN ("put-unicode-property-internal", Fput_unicode_property_internal
,
1387 Sput_unicode_property_internal
, 3, 3, 0,
1388 doc
: /* Set an element of CHAR-TABLE for character CH to VALUE.
1389 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
1390 (Lisp_Object char_table
, Lisp_Object ch
, Lisp_Object value
)
1392 uniprop_encoder_t encoder
;
1394 CHECK_CHAR_TABLE (char_table
);
1395 CHECK_CHARACTER (ch
);
1396 if (! UNIPROP_TABLE_P (char_table
))
1397 error ("Invalid Unicode property table");
1398 encoder
= uniprop_get_encoder (char_table
);
1400 value
= encoder (char_table
, value
);
1401 CHAR_TABLE_SET (char_table
, XINT (ch
), value
);
1407 syms_of_chartab (void)
1409 DEFSYM (Qchar_code_property_table
, "char-code-property-table");
1411 defsubr (&Smake_char_table
);
1412 defsubr (&Schar_table_parent
);
1413 defsubr (&Schar_table_subtype
);
1414 defsubr (&Sset_char_table_parent
);
1415 defsubr (&Schar_table_extra_slot
);
1416 defsubr (&Sset_char_table_extra_slot
);
1417 defsubr (&Schar_table_range
);
1418 defsubr (&Sset_char_table_range
);
1419 defsubr (&Sset_char_table_default
);
1420 defsubr (&Soptimize_char_table
);
1421 defsubr (&Smap_char_table
);
1422 defsubr (&Sunicode_property_table_internal
);
1423 defsubr (&Sget_unicode_property_internal
);
1424 defsubr (&Sput_unicode_property_internal
);
1426 /* Each element has the form (PROP . TABLE).
1427 PROP is a symbol representing a character property.
1428 TABLE is a char-table containing the property value for each character.
1429 TABLE may be a name of file to load to build a char-table.
1430 This variable should be modified only through
1431 `define-char-code-property'. */
1433 DEFVAR_LISP ("char-code-property-alist", Vchar_code_property_alist
,
1434 doc
: /* Alist of character property name vs char-table containing property values.
1435 Internal use only. */);
1436 Vchar_code_property_alist
= Qnil
;