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
));
440 sub_char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
,
443 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
444 int depth
= XINT ((tbl
)->depth
);
445 int min_char
= XINT ((tbl
)->min_char
);
446 int chars_in_block
= chartab_chars
[depth
];
447 int i
, c
, lim
= chartab_size
[depth
];
451 i
= CHARTAB_IDX (from
, depth
, min_char
);
452 c
= min_char
+ chars_in_block
* i
;
453 for (; i
< lim
; i
++, c
+= chars_in_block
)
457 if (from
<= c
&& c
+ chars_in_block
- 1 <= to
)
458 set_sub_char_table_contents (table
, i
, val
);
461 Lisp_Object sub
= tbl
->contents
[i
];
462 if (! SUB_CHAR_TABLE_P (sub
))
464 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (sub
))
465 sub
= uniprop_table_uncompress (table
, i
);
468 sub
= make_sub_char_table (depth
+ 1, c
, sub
);
469 set_sub_char_table_contents (table
, i
, sub
);
472 sub_char_table_set_range (sub
, from
, to
, val
, is_uniprop
);
479 char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
)
481 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
484 char_table_set (table
, from
, val
);
487 int is_uniprop
= UNIPROP_TABLE_P (table
);
488 int lim
= CHARTAB_IDX (to
, 0, 0);
491 for (i
= CHARTAB_IDX (from
, 0, 0), c
= 0; i
<= lim
;
492 i
++, c
+= chartab_chars
[0])
496 if (from
<= c
&& c
+ chartab_chars
[0] - 1 <= to
)
497 set_char_table_contents (table
, i
, val
);
500 Lisp_Object sub
= tbl
->contents
[i
];
501 if (! SUB_CHAR_TABLE_P (sub
))
503 sub
= make_sub_char_table (1, i
* chartab_chars
[0], sub
);
504 set_char_table_contents (table
, i
, sub
);
506 sub_char_table_set_range (sub
, from
, to
, val
, is_uniprop
);
509 if (ASCII_CHAR_P (from
))
510 set_char_table_ascii (table
, char_table_ascii (table
));
515 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
518 Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
519 (Lisp_Object char_table
)
521 CHECK_CHAR_TABLE (char_table
);
523 return XCHAR_TABLE (char_table
)->purpose
;
526 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
528 doc
: /* Return the parent char-table of CHAR-TABLE.
529 The value is either nil or another char-table.
530 If CHAR-TABLE holds nil for a given character,
531 then the actual applicable value is inherited from the parent char-table
532 \(or from its parents, if necessary). */)
533 (Lisp_Object char_table
)
535 CHECK_CHAR_TABLE (char_table
);
537 return XCHAR_TABLE (char_table
)->parent
;
540 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
542 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
543 Return PARENT. PARENT must be either nil or another char-table. */)
544 (Lisp_Object char_table
, Lisp_Object parent
)
548 CHECK_CHAR_TABLE (char_table
);
552 CHECK_CHAR_TABLE (parent
);
554 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
555 if (EQ (temp
, char_table
))
556 error ("Attempt to make a chartable be its own parent");
559 set_char_table_parent (char_table
, parent
);
564 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
566 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
567 (Lisp_Object char_table
, Lisp_Object n
)
569 CHECK_CHAR_TABLE (char_table
);
572 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
573 args_out_of_range (char_table
, n
);
575 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
578 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
579 Sset_char_table_extra_slot
,
581 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
582 (Lisp_Object char_table
, Lisp_Object n
, Lisp_Object value
)
584 CHECK_CHAR_TABLE (char_table
);
587 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
588 args_out_of_range (char_table
, n
);
590 set_char_table_extras (char_table
, XINT (n
), value
);
594 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
596 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
597 RANGE should be nil (for the default value),
598 a cons of character codes (for characters in the range), or a character code. */)
599 (Lisp_Object char_table
, Lisp_Object range
)
602 CHECK_CHAR_TABLE (char_table
);
604 if (EQ (range
, Qnil
))
605 val
= XCHAR_TABLE (char_table
)->defalt
;
606 else if (CHARACTERP (range
))
607 val
= CHAR_TABLE_REF (char_table
, XFASTINT (range
));
608 else if (CONSP (range
))
612 CHECK_CHARACTER_CAR (range
);
613 CHECK_CHARACTER_CDR (range
);
614 from
= XFASTINT (XCAR (range
));
615 to
= XFASTINT (XCDR (range
));
616 val
= char_table_ref_and_range (char_table
, from
, &from
, &to
);
617 /* Not yet implemented. */
620 error ("Invalid RANGE argument to `char-table-range'");
624 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
626 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
627 RANGE should be t (for all characters), nil (for the default value),
628 a cons of character codes (for characters in the range),
629 or a character code. Return VALUE. */)
630 (Lisp_Object char_table
, Lisp_Object range
, Lisp_Object value
)
632 CHECK_CHAR_TABLE (char_table
);
637 set_char_table_ascii (char_table
, value
);
638 for (i
= 0; i
< chartab_size
[0]; i
++)
639 set_char_table_contents (char_table
, i
, value
);
641 else if (EQ (range
, Qnil
))
642 set_char_table_defalt (char_table
, value
);
643 else if (CHARACTERP (range
))
644 char_table_set (char_table
, XINT (range
), value
);
645 else if (CONSP (range
))
647 CHECK_CHARACTER_CAR (range
);
648 CHECK_CHARACTER_CDR (range
);
649 char_table_set_range (char_table
,
650 XINT (XCAR (range
)), XINT (XCDR (range
)), value
);
653 error ("Invalid RANGE argument to `set-char-table-range'");
658 DEFUN ("set-char-table-default", Fset_char_table_default
,
659 Sset_char_table_default
, 3, 3, 0,
661 This function is obsolete and has no effect. */)
662 (Lisp_Object char_table
, Lisp_Object ch
, Lisp_Object value
)
667 /* Look up the element in TABLE at index CH, and return it as an
668 integer. If the element is not a character, return CH itself. */
671 char_table_translate (Lisp_Object table
, int ch
)
674 value
= Faref (table
, make_number (ch
));
675 if (! CHARACTERP (value
))
681 optimize_sub_char_table (Lisp_Object table
, Lisp_Object test
)
683 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
684 int depth
= XINT (tbl
->depth
);
685 Lisp_Object elt
, this;
688 elt
= XSUB_CHAR_TABLE (table
)->contents
[0];
689 if (SUB_CHAR_TABLE_P (elt
))
691 elt
= optimize_sub_char_table (elt
, test
);
692 set_sub_char_table_contents (table
, 0, elt
);
694 optimizable
= SUB_CHAR_TABLE_P (elt
) ? 0 : 1;
695 for (i
= 1; i
< chartab_size
[depth
]; i
++)
697 this = XSUB_CHAR_TABLE (table
)->contents
[i
];
698 if (SUB_CHAR_TABLE_P (this))
700 this = optimize_sub_char_table (this, test
);
701 set_sub_char_table_contents (table
, i
, this);
704 && (NILP (test
) ? NILP (Fequal (this, elt
)) /* defaults to `equal'. */
705 : EQ (test
, Qeq
) ? !EQ (this, elt
) /* Optimize `eq' case. */
706 : NILP (call2 (test
, this, elt
))))
710 return (optimizable
? elt
: table
);
713 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
715 doc
: /* Optimize CHAR-TABLE.
716 TEST is the comparison function used to decide whether two entries are
717 equivalent and can be merged. It defaults to `equal'. */)
718 (Lisp_Object char_table
, Lisp_Object test
)
723 CHECK_CHAR_TABLE (char_table
);
725 for (i
= 0; i
< chartab_size
[0]; i
++)
727 elt
= XCHAR_TABLE (char_table
)->contents
[i
];
728 if (SUB_CHAR_TABLE_P (elt
))
729 set_char_table_contents
730 (char_table
, i
, optimize_sub_char_table (elt
, test
));
732 /* Reset the `ascii' cache, in case it got optimized away. */
733 set_char_table_ascii (char_table
, char_table_ascii (char_table
));
739 /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
740 calling it for each character or group of characters that share a
741 value. RANGE is a cons (FROM . TO) specifying the range of target
742 characters, VAL is a value of FROM in TABLE, TOP is the top
745 ARG is passed to C_FUNCTION when that is called.
747 It returns the value of last character covered by TABLE (not the
748 value inherited from the parent), and by side-effect, the car part
749 of RANGE is updated to the minimum character C where C and all the
750 following characters in TABLE have the same value. */
753 map_sub_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
754 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
, Lisp_Object val
,
755 Lisp_Object range
, Lisp_Object top
)
757 /* Depth of TABLE. */
759 /* Minimum and maximum characters covered by TABLE. */
760 int min_char
, max_char
;
761 /* Number of characters covered by one element of TABLE. */
763 int from
= XINT (XCAR (range
)), to
= XINT (XCDR (range
));
765 int is_uniprop
= UNIPROP_TABLE_P (top
);
766 uniprop_decoder_t decoder
= UNIPROP_GET_DECODER (top
);
768 if (SUB_CHAR_TABLE_P (table
))
770 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
772 depth
= XINT (tbl
->depth
);
773 min_char
= XINT (tbl
->min_char
);
774 max_char
= min_char
+ chartab_chars
[depth
- 1] - 1;
782 chars_in_block
= chartab_chars
[depth
];
786 /* Set I to the index of the first element to check. */
787 if (from
<= min_char
)
790 i
= (from
- min_char
) / chars_in_block
;
791 for (c
= min_char
+ chars_in_block
* i
; c
<= max_char
;
792 i
++, c
+= chars_in_block
)
794 Lisp_Object
this = (SUB_CHAR_TABLE_P (table
)
795 ? XSUB_CHAR_TABLE (table
)->contents
[i
]
796 : XCHAR_TABLE (table
)->contents
[i
]);
797 int nextc
= c
+ chars_in_block
;
799 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this))
800 this = uniprop_table_uncompress (table
, i
);
801 if (SUB_CHAR_TABLE_P (this))
804 XSETCDR (range
, make_number (nextc
- 1));
805 val
= map_sub_char_table (c_function
, function
, this, arg
,
811 this = XCHAR_TABLE (top
)->defalt
;
814 int different_value
= 1;
818 if (! NILP (XCHAR_TABLE (top
)->parent
))
820 Lisp_Object parent
= XCHAR_TABLE (top
)->parent
;
821 Lisp_Object temp
= XCHAR_TABLE (parent
)->parent
;
823 /* This is to get a value of FROM in PARENT
824 without checking the parent of PARENT. */
825 set_char_table_parent (parent
, Qnil
);
826 val
= CHAR_TABLE_REF (parent
, from
);
827 set_char_table_parent (parent
, temp
);
828 XSETCDR (range
, make_number (c
- 1));
829 val
= map_sub_char_table (c_function
, function
,
830 parent
, arg
, val
, range
,
836 if (! NILP (val
) && different_value
)
838 XSETCDR (range
, make_number (c
- 1));
839 if (EQ (XCAR (range
), XCDR (range
)))
842 (*c_function
) (arg
, XCAR (range
), val
);
846 val
= decoder (top
, val
);
847 call2 (function
, XCAR (range
), val
);
853 (*c_function
) (arg
, range
, val
);
857 val
= decoder (top
, val
);
858 call2 (function
, range
, val
);
864 XSETCAR (range
, make_number (c
));
867 XSETCDR (range
, make_number (to
));
873 /* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
874 character or group of characters that share a value.
876 ARG is passed to C_FUNCTION when that is called. */
879 map_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
880 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
)
882 Lisp_Object range
, val
, parent
;
883 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
884 uniprop_decoder_t decoder
= UNIPROP_GET_DECODER (table
);
886 range
= Fcons (make_number (0), make_number (MAX_CHAR
));
887 parent
= XCHAR_TABLE (table
)->parent
;
889 GCPRO4 (table
, arg
, range
, parent
);
890 val
= XCHAR_TABLE (table
)->ascii
;
891 if (SUB_CHAR_TABLE_P (val
))
892 val
= XSUB_CHAR_TABLE (val
)->contents
[0];
893 val
= map_sub_char_table (c_function
, function
, table
, arg
, val
, range
,
896 /* If VAL is nil and TABLE has a parent, we must consult the parent
898 while (NILP (val
) && ! NILP (XCHAR_TABLE (table
)->parent
))
901 int from
= XINT (XCAR (range
));
903 parent
= XCHAR_TABLE (table
)->parent
;
904 temp
= XCHAR_TABLE (parent
)->parent
;
905 /* This is to get a value of FROM in PARENT without checking the
907 set_char_table_parent (parent
, Qnil
);
908 val
= CHAR_TABLE_REF (parent
, from
);
909 set_char_table_parent (parent
, temp
);
910 val
= map_sub_char_table (c_function
, function
, parent
, arg
, val
, range
,
917 if (EQ (XCAR (range
), XCDR (range
)))
920 (*c_function
) (arg
, XCAR (range
), val
);
924 val
= decoder (table
, val
);
925 call2 (function
, XCAR (range
), val
);
931 (*c_function
) (arg
, range
, val
);
935 val
= decoder (table
, val
);
936 call2 (function
, range
, val
);
944 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
946 doc
: /* Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
947 FUNCTION is called with two arguments, KEY and VALUE.
948 KEY is a character code or a cons of character codes specifying a
949 range of characters that have the same value.
950 VALUE is what (char-table-range CHAR-TABLE KEY) returns. */)
951 (Lisp_Object function
, Lisp_Object char_table
)
953 CHECK_CHAR_TABLE (char_table
);
955 map_char_table (NULL
, function
, char_table
, char_table
);
961 map_sub_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
962 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
963 Lisp_Object range
, struct charset
*charset
,
964 unsigned from
, unsigned to
)
966 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
967 int depth
= XINT (tbl
->depth
);
971 for (i
= 0, c
= XINT (tbl
->min_char
); i
< chartab_size
[depth
];
972 i
++, c
+= chartab_chars
[depth
])
976 this = tbl
->contents
[i
];
977 if (SUB_CHAR_TABLE_P (this))
978 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
979 range
, charset
, from
, to
);
982 if (! NILP (XCAR (range
)))
984 XSETCDR (range
, make_number (c
- 1));
986 (*c_function
) (arg
, range
);
988 call2 (function
, range
, arg
);
990 XSETCAR (range
, Qnil
);
994 for (i
= 0, c
= XINT (tbl
->min_char
); i
< chartab_size
[depth
]; i
++, c
++)
999 this = tbl
->contents
[i
];
1002 && (code
= ENCODE_CHAR (charset
, c
),
1003 (code
< from
|| code
> to
))))
1005 if (! NILP (XCAR (range
)))
1007 XSETCDR (range
, make_number (c
- 1));
1009 (*c_function
) (arg
, range
);
1011 call2 (function
, range
, arg
);
1012 XSETCAR (range
, Qnil
);
1017 if (NILP (XCAR (range
)))
1018 XSETCAR (range
, make_number (c
));
1024 /* Support function for `map-charset-chars'. Map C_FUNCTION or
1025 FUNCTION over TABLE, calling it for each character or a group of
1026 succeeding characters that have non-nil value in TABLE. TABLE is a
1027 "mapping table" or a "deunifier table" of a certain charset.
1029 If CHARSET is not NULL (this is the case that `map-charset-chars'
1030 is called with non-nil FROM-CODE and TO-CODE), it is a charset who
1031 owns TABLE, and the function is called only on a character in the
1032 range FROM and TO. FROM and TO are not character codes, but code
1033 points of a character in CHARSET.
1035 This function is called in these two cases:
1037 (1) A charset has a mapping file name in :map property.
1039 (2) A charset has an upper code space in :offset property and a
1040 mapping file name in :unify-map property. In this case, this
1041 function is called only for characters in the Unicode code space.
1042 Characters in upper code space are handled directly in
1043 map_charset_chars. */
1046 map_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
1047 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
1048 struct charset
*charset
,
1049 unsigned from
, unsigned to
)
1053 struct gcpro gcpro1
;
1055 range
= Fcons (Qnil
, Qnil
);
1058 for (i
= 0, c
= 0; i
< chartab_size
[0]; i
++, c
+= chartab_chars
[0])
1062 this = XCHAR_TABLE (table
)->contents
[i
];
1063 if (SUB_CHAR_TABLE_P (this))
1064 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
1065 range
, charset
, from
, to
);
1068 if (! NILP (XCAR (range
)))
1070 XSETCDR (range
, make_number (c
- 1));
1072 (*c_function
) (arg
, range
);
1074 call2 (function
, range
, arg
);
1076 XSETCAR (range
, Qnil
);
1079 if (! NILP (XCAR (range
)))
1081 XSETCDR (range
, make_number (c
- 1));
1083 (*c_function
) (arg
, range
);
1085 call2 (function
, range
, arg
);
1092 /* Unicode character property tables.
1094 This section provides a convenient and efficient way to get Unicode
1095 character properties of characters from C code (from Lisp, you must
1096 use get-char-code-property).
1098 The typical usage is to get a char-table object for a specific
1099 property like this (use of the "bidi-class" property below is just
1102 Lisp_Object bidi_class_table = uniprop_table (intern ("bidi-class"));
1104 (uniprop_table can return nil if it fails to find data for the
1105 named property, or if it fails to load the appropriate Lisp support
1106 file, so the return value should be tested to be non-nil, before it
1109 To get a property value for character CH use CHAR_TABLE_REF:
1111 Lisp_Object bidi_class = CHAR_TABLE_REF (bidi_class_table, CH);
1113 In this case, what you actually get is an index number to the
1114 vector of property values (symbols nil, L, R, etc).
1116 The full list of Unicode character properties supported by Emacs is
1117 documented in the ELisp manual, in the node "Character Properties".
1119 A table for Unicode character property has these characteristics:
1121 o The purpose is `char-code-property-table', which implies that the
1122 table has 5 extra slots.
1124 o The second extra slot is a Lisp function, an index (integer) to
1125 the array uniprop_decoder[], or nil. If it is a Lisp function, we
1126 can't use such a table from C (at the moment). If it is nil, it
1127 means that we don't have to decode values.
1129 o The third extra slot is a Lisp function, an index (integer) to
1130 the array uniprop_encoder[], or nil. If it is a Lisp function, we
1131 can't use such a table from C (at the moment). If it is nil, it
1132 means that we don't have to encode values. */
1135 /* Uncompress the IDXth element of sub-char-table TABLE. */
1138 uniprop_table_uncompress (Lisp_Object table
, int idx
)
1140 Lisp_Object val
= XSUB_CHAR_TABLE (table
)->contents
[idx
];
1141 int min_char
= (XINT (XSUB_CHAR_TABLE (table
)->min_char
)
1142 + chartab_chars
[2] * idx
);
1143 Lisp_Object sub
= make_sub_char_table (3, min_char
, Qnil
);
1144 const unsigned char *p
, *pend
;
1146 set_sub_char_table_contents (table
, idx
, sub
);
1147 p
= SDATA (val
), pend
= p
+ SBYTES (val
);
1152 idx
= STRING_CHAR_ADVANCE (p
);
1153 while (p
< pend
&& idx
< chartab_chars
[2])
1155 int v
= STRING_CHAR_ADVANCE (p
);
1156 set_sub_char_table_contents
1157 (sub
, idx
++, v
> 0 ? make_number (v
) : Qnil
);
1162 /* RUN-LENGTH TABLE */
1164 for (idx
= 0; p
< pend
; )
1166 int v
= STRING_CHAR_ADVANCE (p
);
1172 count
= STRING_CHAR_AND_LENGTH (p
, len
);
1182 set_sub_char_table_contents (sub
, idx
++, make_number (v
));
1185 /* It seems that we don't need this function because C code won't need
1186 to get a property that is compressed in this form. */
1190 /* WORD-LIST TABLE */
1197 /* Decode VALUE as an element of char-table TABLE. */
1200 uniprop_decode_value_run_length (Lisp_Object table
, Lisp_Object value
)
1202 if (VECTORP (XCHAR_TABLE (table
)->extras
[4]))
1204 Lisp_Object valvec
= XCHAR_TABLE (table
)->extras
[4];
1206 if (XINT (value
) >= 0 && XINT (value
) < ASIZE (valvec
))
1207 value
= AREF (valvec
, XINT (value
));
1212 static uniprop_decoder_t uniprop_decoder
[] =
1213 { uniprop_decode_value_run_length
};
1215 static int uniprop_decoder_count
1216 = (sizeof uniprop_decoder
) / sizeof (uniprop_decoder
[0]);
1219 /* Return the decoder of char-table TABLE or nil if none. */
1221 static uniprop_decoder_t
1222 uniprop_get_decoder (Lisp_Object table
)
1226 if (! INTEGERP (XCHAR_TABLE (table
)->extras
[1]))
1228 i
= XINT (XCHAR_TABLE (table
)->extras
[1]);
1229 if (i
< 0 || i
>= uniprop_decoder_count
)
1231 return uniprop_decoder
[i
];
1235 /* Encode VALUE as an element of char-table TABLE which contains
1236 characters as elements. */
1239 uniprop_encode_value_character (Lisp_Object table
, Lisp_Object value
)
1241 if (! NILP (value
) && ! CHARACTERP (value
))
1242 wrong_type_argument (Qintegerp
, value
);
1247 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
1251 uniprop_encode_value_run_length (Lisp_Object table
, Lisp_Object value
)
1253 Lisp_Object
*value_table
= XVECTOR (XCHAR_TABLE (table
)->extras
[4])->contents
;
1254 int i
, size
= ASIZE (XCHAR_TABLE (table
)->extras
[4]);
1256 for (i
= 0; i
< size
; i
++)
1257 if (EQ (value
, value_table
[i
]))
1260 wrong_type_argument (build_string ("Unicode property value"), value
);
1261 return make_number (i
);
1265 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
1266 compression and contains numbers as elements . */
1269 uniprop_encode_value_numeric (Lisp_Object table
, Lisp_Object value
)
1271 Lisp_Object
*value_table
= XVECTOR (XCHAR_TABLE (table
)->extras
[4])->contents
;
1272 int i
, size
= ASIZE (XCHAR_TABLE (table
)->extras
[4]);
1274 CHECK_NUMBER (value
);
1275 for (i
= 0; i
< size
; i
++)
1276 if (EQ (value
, value_table
[i
]))
1278 value
= make_number (i
);
1281 Lisp_Object args
[2];
1283 args
[0] = XCHAR_TABLE (table
)->extras
[4];
1284 args
[1] = Fmake_vector (make_number (1), value
);
1285 set_char_table_extras (table
, 4, Fvconcat (2, args
));
1287 return make_number (i
);
1290 static uniprop_encoder_t uniprop_encoder
[] =
1291 { uniprop_encode_value_character
,
1292 uniprop_encode_value_run_length
,
1293 uniprop_encode_value_numeric
};
1295 static int uniprop_encoder_count
1296 = (sizeof uniprop_encoder
) / sizeof (uniprop_encoder
[0]);
1299 /* Return the encoder of char-table TABLE or nil if none. */
1301 static uniprop_decoder_t
1302 uniprop_get_encoder (Lisp_Object table
)
1306 if (! INTEGERP (XCHAR_TABLE (table
)->extras
[2]))
1308 i
= XINT (XCHAR_TABLE (table
)->extras
[2]);
1309 if (i
< 0 || i
>= uniprop_encoder_count
)
1311 return uniprop_encoder
[i
];
1314 /* Return a char-table for Unicode character property PROP. This
1315 function may load a Lisp file and thus may cause
1316 garbage-collection. */
1319 uniprop_table (Lisp_Object prop
)
1321 Lisp_Object val
, table
, result
;
1323 val
= Fassq (prop
, Vchar_code_property_alist
);
1327 if (STRINGP (table
))
1329 struct gcpro gcpro1
;
1331 result
= Fload (concat2 (build_string ("international/"), table
),
1338 if (! CHAR_TABLE_P (table
)
1339 || ! UNIPROP_TABLE_P (table
))
1341 val
= XCHAR_TABLE (table
)->extras
[1];
1343 ? (XINT (val
) < 0 || XINT (val
) >= uniprop_decoder_count
)
1346 /* Prepare ASCII values in advance for CHAR_TABLE_REF. */
1347 set_char_table_ascii (table
, char_table_ascii (table
));
1351 DEFUN ("unicode-property-table-internal", Funicode_property_table_internal
,
1352 Sunicode_property_table_internal
, 1, 1, 0,
1353 doc
: /* Return a char-table for Unicode character property PROP.
1354 Use `get-unicode-property-internal' and
1355 `put-unicode-property-internal' instead of `aref' and `aset' to get
1356 and put an element value. */)
1359 Lisp_Object table
= uniprop_table (prop
);
1361 if (CHAR_TABLE_P (table
))
1363 return Fcdr (Fassq (prop
, Vchar_code_property_alist
));
1366 DEFUN ("get-unicode-property-internal", Fget_unicode_property_internal
,
1367 Sget_unicode_property_internal
, 2, 2, 0,
1368 doc
: /* Return an element of CHAR-TABLE for character CH.
1369 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
1370 (Lisp_Object char_table
, Lisp_Object ch
)
1373 uniprop_decoder_t decoder
;
1375 CHECK_CHAR_TABLE (char_table
);
1376 CHECK_CHARACTER (ch
);
1377 if (! UNIPROP_TABLE_P (char_table
))
1378 error ("Invalid Unicode property table");
1379 val
= CHAR_TABLE_REF (char_table
, XINT (ch
));
1380 decoder
= uniprop_get_decoder (char_table
);
1381 return (decoder
? decoder (char_table
, val
) : val
);
1384 DEFUN ("put-unicode-property-internal", Fput_unicode_property_internal
,
1385 Sput_unicode_property_internal
, 3, 3, 0,
1386 doc
: /* Set an element of CHAR-TABLE for character CH to VALUE.
1387 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
1388 (Lisp_Object char_table
, Lisp_Object ch
, Lisp_Object value
)
1390 uniprop_encoder_t encoder
;
1392 CHECK_CHAR_TABLE (char_table
);
1393 CHECK_CHARACTER (ch
);
1394 if (! UNIPROP_TABLE_P (char_table
))
1395 error ("Invalid Unicode property table");
1396 encoder
= uniprop_get_encoder (char_table
);
1398 value
= encoder (char_table
, value
);
1399 CHAR_TABLE_SET (char_table
, XINT (ch
), value
);
1405 syms_of_chartab (void)
1407 DEFSYM (Qchar_code_property_table
, "char-code-property-table");
1409 defsubr (&Smake_char_table
);
1410 defsubr (&Schar_table_parent
);
1411 defsubr (&Schar_table_subtype
);
1412 defsubr (&Sset_char_table_parent
);
1413 defsubr (&Schar_table_extra_slot
);
1414 defsubr (&Sset_char_table_extra_slot
);
1415 defsubr (&Schar_table_range
);
1416 defsubr (&Sset_char_table_range
);
1417 defsubr (&Sset_char_table_default
);
1418 defsubr (&Soptimize_char_table
);
1419 defsubr (&Smap_char_table
);
1420 defsubr (&Sunicode_property_table_internal
);
1421 defsubr (&Sget_unicode_property_internal
);
1422 defsubr (&Sput_unicode_property_internal
);
1424 /* Each element has the form (PROP . TABLE).
1425 PROP is a symbol representing a character property.
1426 TABLE is a char-table containing the property value for each character.
1427 TABLE may be a name of file to load to build a char-table.
1428 This variable should be modified only through
1429 `define-char-code-property'. */
1431 DEFVAR_LISP ("char-code-property-alist", Vchar_code_property_alist
,
1432 doc
: /* Alist of character property name vs char-table containing property values.
1433 Internal use only. */);
1434 Vchar_code_property_alist
= Qnil
;