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 CSET (XCHAR_TABLE (vector
), parent
, Qnil
);
119 CSET (XCHAR_TABLE (vector
), purpose
, 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
)
159 int depth
= XINT (XSUB_CHAR_TABLE (table
)->depth
);
160 int min_char
= XINT (XSUB_CHAR_TABLE (table
)->min_char
);
164 copy
= make_sub_char_table (depth
, min_char
, Qnil
);
165 /* Recursively copy any sub char-tables. */
166 for (i
= 0; i
< chartab_size
[depth
]; i
++)
168 val
= XSUB_CHAR_TABLE (table
)->contents
[i
];
169 if (SUB_CHAR_TABLE_P (val
))
170 sub_char_table_set_contents (copy
, i
, copy_sub_char_table (val
));
172 sub_char_table_set_contents (copy
, i
, val
);
180 copy_char_table (Lisp_Object table
)
183 int size
= XCHAR_TABLE (table
)->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
186 copy
= Fmake_vector (make_number (size
), Qnil
);
187 XSETPVECTYPE (XVECTOR (copy
), PVEC_CHAR_TABLE
);
188 CSET (XCHAR_TABLE (copy
), defalt
, XCHAR_TABLE (table
)->defalt
);
189 CSET (XCHAR_TABLE (copy
), parent
, XCHAR_TABLE (table
)->parent
);
190 CSET (XCHAR_TABLE (copy
), purpose
, XCHAR_TABLE (table
)->purpose
);
191 for (i
= 0; i
< chartab_size
[0]; i
++)
192 char_table_set_contents
194 (SUB_CHAR_TABLE_P (XCHAR_TABLE (table
)->contents
[i
])
195 ? copy_sub_char_table (XCHAR_TABLE (table
)->contents
[i
])
196 : XCHAR_TABLE (table
)->contents
[i
]));
197 CSET (XCHAR_TABLE (copy
), ascii
, char_table_ascii (copy
));
198 size
-= VECSIZE (struct Lisp_Char_Table
) - 1;
199 for (i
= 0; i
< size
; i
++)
200 char_table_set_extras (copy
, i
, XCHAR_TABLE (table
)->extras
[i
]);
202 XSETCHAR_TABLE (copy
, XCHAR_TABLE (copy
));
207 sub_char_table_ref (Lisp_Object table
, int c
, int is_uniprop
)
209 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
210 int depth
= XINT (tbl
->depth
);
211 int min_char
= XINT (tbl
->min_char
);
213 int idx
= CHARTAB_IDX (c
, depth
, min_char
);
215 val
= tbl
->contents
[idx
];
216 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
217 val
= uniprop_table_uncompress (table
, idx
);
218 if (SUB_CHAR_TABLE_P (val
))
219 val
= sub_char_table_ref (val
, c
, is_uniprop
);
224 char_table_ref (Lisp_Object table
, int c
)
226 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
229 if (ASCII_CHAR_P (c
))
232 if (SUB_CHAR_TABLE_P (val
))
233 val
= XSUB_CHAR_TABLE (val
)->contents
[c
];
237 val
= tbl
->contents
[CHARTAB_IDX (c
, 0, 0)];
238 if (SUB_CHAR_TABLE_P (val
))
239 val
= sub_char_table_ref (val
, c
, UNIPROP_TABLE_P (table
));
244 if (NILP (val
) && CHAR_TABLE_P (tbl
->parent
))
245 val
= char_table_ref (tbl
->parent
, c
);
251 sub_char_table_ref_and_range (Lisp_Object table
, int c
, int *from
, int *to
,
252 Lisp_Object defalt
, int is_uniprop
)
254 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
255 int depth
= XINT (tbl
->depth
);
256 int min_char
= XINT (tbl
->min_char
);
257 int chartab_idx
= CHARTAB_IDX (c
, depth
, min_char
), idx
;
260 val
= tbl
->contents
[chartab_idx
];
261 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
262 val
= uniprop_table_uncompress (table
, chartab_idx
);
263 if (SUB_CHAR_TABLE_P (val
))
264 val
= sub_char_table_ref_and_range (val
, c
, from
, to
, defalt
, is_uniprop
);
269 while (idx
> 0 && *from
< min_char
+ idx
* chartab_chars
[depth
])
271 Lisp_Object this_val
;
273 c
= min_char
+ idx
* chartab_chars
[depth
] - 1;
275 this_val
= tbl
->contents
[idx
];
276 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
277 this_val
= uniprop_table_uncompress (table
, idx
);
278 if (SUB_CHAR_TABLE_P (this_val
))
279 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
, defalt
,
281 else if (NILP (this_val
))
284 if (! EQ (this_val
, val
))
290 while (((c
= (chartab_idx
+ 1) * chartab_chars
[depth
])
291 < chartab_chars
[depth
- 1])
292 && (c
+= min_char
) <= *to
)
294 Lisp_Object this_val
;
297 this_val
= tbl
->contents
[chartab_idx
];
298 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
299 this_val
= uniprop_table_uncompress (table
, chartab_idx
);
300 if (SUB_CHAR_TABLE_P (this_val
))
301 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
, defalt
,
303 else if (NILP (this_val
))
305 if (! EQ (this_val
, val
))
316 /* Return the value for C in char-table TABLE. Shrink the range *FROM
317 and *TO to cover characters (containing C) that have the same value
318 as C. It is not assured that the values of (*FROM - 1) and (*TO +
319 1) are different from that of C. */
322 char_table_ref_and_range (Lisp_Object table
, int c
, int *from
, int *to
)
324 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
325 int chartab_idx
= CHARTAB_IDX (c
, 0, 0), idx
;
327 int is_uniprop
= UNIPROP_TABLE_P (table
);
329 val
= tbl
->contents
[chartab_idx
];
334 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (val
))
335 val
= uniprop_table_uncompress (table
, chartab_idx
);
336 if (SUB_CHAR_TABLE_P (val
))
337 val
= sub_char_table_ref_and_range (val
, c
, from
, to
, tbl
->defalt
,
342 while (*from
< idx
* chartab_chars
[0])
344 Lisp_Object this_val
;
346 c
= idx
* chartab_chars
[0] - 1;
348 this_val
= tbl
->contents
[idx
];
349 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
350 this_val
= uniprop_table_uncompress (table
, idx
);
351 if (SUB_CHAR_TABLE_P (this_val
))
352 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
,
353 tbl
->defalt
, is_uniprop
);
354 else if (NILP (this_val
))
355 this_val
= tbl
->defalt
;
357 if (! EQ (this_val
, val
))
363 while (*to
>= (chartab_idx
+ 1) * chartab_chars
[0])
365 Lisp_Object this_val
;
368 c
= chartab_idx
* chartab_chars
[0];
369 this_val
= tbl
->contents
[chartab_idx
];
370 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this_val
))
371 this_val
= uniprop_table_uncompress (table
, chartab_idx
);
372 if (SUB_CHAR_TABLE_P (this_val
))
373 this_val
= sub_char_table_ref_and_range (this_val
, c
, from
, to
,
374 tbl
->defalt
, is_uniprop
);
375 else if (NILP (this_val
))
376 this_val
= tbl
->defalt
;
377 if (! EQ (this_val
, val
))
389 sub_char_table_set (Lisp_Object table
, int c
, Lisp_Object val
, int is_uniprop
)
391 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
392 int depth
= XINT ((tbl
)->depth
);
393 int min_char
= XINT ((tbl
)->min_char
);
394 int i
= CHARTAB_IDX (c
, depth
, min_char
);
398 sub_char_table_set_contents (table
, i
, val
);
401 sub
= tbl
->contents
[i
];
402 if (! SUB_CHAR_TABLE_P (sub
))
404 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (sub
))
405 sub
= uniprop_table_uncompress (table
, i
);
408 sub
= make_sub_char_table (depth
+ 1,
409 min_char
+ i
* chartab_chars
[depth
],
411 sub_char_table_set_contents (table
, i
, sub
);
414 sub_char_table_set (sub
, c
, val
, is_uniprop
);
419 char_table_set (Lisp_Object table
, int c
, Lisp_Object val
)
421 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
424 && SUB_CHAR_TABLE_P (tbl
->ascii
))
425 sub_char_table_set_contents (tbl
->ascii
, c
, val
);
428 int i
= CHARTAB_IDX (c
, 0, 0);
431 sub
= tbl
->contents
[i
];
432 if (! SUB_CHAR_TABLE_P (sub
))
434 sub
= make_sub_char_table (1, i
* chartab_chars
[0], sub
);
435 char_table_set_contents (table
, i
, sub
);
437 sub_char_table_set (sub
, c
, val
, UNIPROP_TABLE_P (table
));
438 if (ASCII_CHAR_P (c
))
439 CSET (tbl
, ascii
, char_table_ascii (table
));
445 sub_char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
,
448 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
449 int depth
= XINT ((tbl
)->depth
);
450 int min_char
= XINT ((tbl
)->min_char
);
451 int chars_in_block
= chartab_chars
[depth
];
452 int i
, c
, lim
= chartab_size
[depth
];
456 i
= CHARTAB_IDX (from
, depth
, min_char
);
457 c
= min_char
+ chars_in_block
* i
;
458 for (; i
< lim
; i
++, c
+= chars_in_block
)
462 if (from
<= c
&& c
+ chars_in_block
- 1 <= to
)
463 sub_char_table_set_contents (table
, i
, val
);
466 Lisp_Object sub
= tbl
->contents
[i
];
467 if (! SUB_CHAR_TABLE_P (sub
))
469 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (sub
))
470 sub
= uniprop_table_uncompress (table
, i
);
473 sub
= make_sub_char_table (depth
+ 1, c
, sub
);
474 sub_char_table_set_contents (table
, i
, sub
);
477 sub_char_table_set_range (sub
, from
, to
, val
, is_uniprop
);
484 char_table_set_range (Lisp_Object table
, int from
, int to
, Lisp_Object val
)
486 struct Lisp_Char_Table
*tbl
= XCHAR_TABLE (table
);
489 char_table_set (table
, from
, val
);
492 int is_uniprop
= UNIPROP_TABLE_P (table
);
493 int lim
= CHARTAB_IDX (to
, 0, 0);
496 for (i
= CHARTAB_IDX (from
, 0, 0), c
= 0; i
<= lim
;
497 i
++, c
+= chartab_chars
[0])
501 if (from
<= c
&& c
+ chartab_chars
[0] - 1 <= to
)
502 char_table_set_contents (table
, i
, val
);
505 Lisp_Object sub
= tbl
->contents
[i
];
506 if (! SUB_CHAR_TABLE_P (sub
))
508 sub
= make_sub_char_table (1, i
* chartab_chars
[0], sub
);
509 char_table_set_contents (table
, i
, sub
);
511 sub_char_table_set_range (sub
, from
, to
, val
, is_uniprop
);
514 if (ASCII_CHAR_P (from
))
515 CSET (tbl
, ascii
, char_table_ascii (table
));
521 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
524 Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
525 (Lisp_Object char_table
)
527 CHECK_CHAR_TABLE (char_table
);
529 return XCHAR_TABLE (char_table
)->purpose
;
532 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
534 doc
: /* Return the parent char-table of CHAR-TABLE.
535 The value is either nil or another char-table.
536 If CHAR-TABLE holds nil for a given character,
537 then the actual applicable value is inherited from the parent char-table
538 \(or from its parents, if necessary). */)
539 (Lisp_Object char_table
)
541 CHECK_CHAR_TABLE (char_table
);
543 return XCHAR_TABLE (char_table
)->parent
;
546 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
548 doc
: /* Set the parent char-table of CHAR-TABLE to PARENT.
549 Return PARENT. PARENT must be either nil or another char-table. */)
550 (Lisp_Object char_table
, Lisp_Object parent
)
554 CHECK_CHAR_TABLE (char_table
);
558 CHECK_CHAR_TABLE (parent
);
560 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
561 if (EQ (temp
, char_table
))
562 error ("Attempt to make a chartable be its own parent");
565 CSET (XCHAR_TABLE (char_table
), parent
, parent
);
570 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
572 doc
: /* Return the value of CHAR-TABLE's extra-slot number N. */)
573 (Lisp_Object char_table
, Lisp_Object n
)
575 CHECK_CHAR_TABLE (char_table
);
578 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
579 args_out_of_range (char_table
, n
);
581 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
584 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
585 Sset_char_table_extra_slot
,
587 doc
: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
588 (Lisp_Object char_table
, Lisp_Object n
, Lisp_Object value
)
590 CHECK_CHAR_TABLE (char_table
);
593 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
594 args_out_of_range (char_table
, n
);
596 char_table_set_extras (char_table
, XINT (n
), value
);
600 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
602 doc
: /* Return the value in CHAR-TABLE for a range of characters RANGE.
603 RANGE should be nil (for the default value),
604 a cons of character codes (for characters in the range), or a character code. */)
605 (Lisp_Object char_table
, Lisp_Object range
)
608 CHECK_CHAR_TABLE (char_table
);
610 if (EQ (range
, Qnil
))
611 val
= XCHAR_TABLE (char_table
)->defalt
;
612 else if (CHARACTERP (range
))
613 val
= CHAR_TABLE_REF (char_table
, XFASTINT (range
));
614 else if (CONSP (range
))
618 CHECK_CHARACTER_CAR (range
);
619 CHECK_CHARACTER_CDR (range
);
620 from
= XFASTINT (XCAR (range
));
621 to
= XFASTINT (XCDR (range
));
622 val
= char_table_ref_and_range (char_table
, from
, &from
, &to
);
623 /* Not yet implemented. */
626 error ("Invalid RANGE argument to `char-table-range'");
630 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
632 doc
: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
633 RANGE should be t (for all characters), nil (for the default value),
634 a cons of character codes (for characters in the range),
635 or a character code. Return VALUE. */)
636 (Lisp_Object char_table
, Lisp_Object range
, Lisp_Object value
)
638 CHECK_CHAR_TABLE (char_table
);
643 CSET (XCHAR_TABLE (char_table
), ascii
, value
);
644 for (i
= 0; i
< chartab_size
[0]; i
++)
645 char_table_set_contents (char_table
, i
, value
);
647 else if (EQ (range
, Qnil
))
648 CSET (XCHAR_TABLE (char_table
), defalt
, value
);
649 else if (CHARACTERP (range
))
650 char_table_set (char_table
, XINT (range
), value
);
651 else if (CONSP (range
))
653 CHECK_CHARACTER_CAR (range
);
654 CHECK_CHARACTER_CDR (range
);
655 char_table_set_range (char_table
,
656 XINT (XCAR (range
)), XINT (XCDR (range
)), value
);
659 error ("Invalid RANGE argument to `set-char-table-range'");
664 DEFUN ("set-char-table-default", Fset_char_table_default
,
665 Sset_char_table_default
, 3, 3, 0,
667 This function is obsolete and has no effect. */)
668 (Lisp_Object char_table
, Lisp_Object ch
, Lisp_Object value
)
673 /* Look up the element in TABLE at index CH, and return it as an
674 integer. If the element is not a character, return CH itself. */
677 char_table_translate (Lisp_Object table
, int ch
)
680 value
= Faref (table
, make_number (ch
));
681 if (! CHARACTERP (value
))
687 optimize_sub_char_table (Lisp_Object table
, Lisp_Object test
)
689 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
690 int depth
= XINT (tbl
->depth
);
691 Lisp_Object elt
, this;
694 elt
= XSUB_CHAR_TABLE (table
)->contents
[0];
695 if (SUB_CHAR_TABLE_P (elt
))
697 elt
= optimize_sub_char_table (elt
, test
);
698 sub_char_table_set_contents (table
, 0, elt
);
700 optimizable
= SUB_CHAR_TABLE_P (elt
) ? 0 : 1;
701 for (i
= 1; i
< chartab_size
[depth
]; i
++)
703 this = XSUB_CHAR_TABLE (table
)->contents
[i
];
704 if (SUB_CHAR_TABLE_P (this))
706 this = optimize_sub_char_table (this, test
);
707 sub_char_table_set_contents (table
, i
, this);
710 && (NILP (test
) ? NILP (Fequal (this, elt
)) /* defaults to `equal'. */
711 : EQ (test
, Qeq
) ? !EQ (this, elt
) /* Optimize `eq' case. */
712 : NILP (call2 (test
, this, elt
))))
716 return (optimizable
? elt
: table
);
719 DEFUN ("optimize-char-table", Foptimize_char_table
, Soptimize_char_table
,
721 doc
: /* Optimize CHAR-TABLE.
722 TEST is the comparison function used to decide whether two entries are
723 equivalent and can be merged. It defaults to `equal'. */)
724 (Lisp_Object char_table
, Lisp_Object test
)
729 CHECK_CHAR_TABLE (char_table
);
731 for (i
= 0; i
< chartab_size
[0]; i
++)
733 elt
= XCHAR_TABLE (char_table
)->contents
[i
];
734 if (SUB_CHAR_TABLE_P (elt
))
735 char_table_set_contents
736 (char_table
, i
, optimize_sub_char_table (elt
, test
));
738 /* Reset the `ascii' cache, in case it got optimized away. */
739 CSET (XCHAR_TABLE (char_table
), ascii
, char_table_ascii (char_table
));
745 /* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
746 calling it for each character or group of characters that share a
747 value. RANGE is a cons (FROM . TO) specifying the range of target
748 characters, VAL is a value of FROM in TABLE, TOP is the top
751 ARG is passed to C_FUNCTION when that is called.
753 It returns the value of last character covered by TABLE (not the
754 value inherited from the parent), and by side-effect, the car part
755 of RANGE is updated to the minimum character C where C and all the
756 following characters in TABLE have the same value. */
759 map_sub_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
760 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
, Lisp_Object val
,
761 Lisp_Object range
, Lisp_Object top
)
763 /* Depth of TABLE. */
765 /* Minimum and maximum characters covered by TABLE. */
766 int min_char
, max_char
;
767 /* Number of characters covered by one element of TABLE. */
769 int from
= XINT (XCAR (range
)), to
= XINT (XCDR (range
));
771 int is_uniprop
= UNIPROP_TABLE_P (top
);
772 uniprop_decoder_t decoder
= UNIPROP_GET_DECODER (top
);
774 if (SUB_CHAR_TABLE_P (table
))
776 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
778 depth
= XINT (tbl
->depth
);
779 min_char
= XINT (tbl
->min_char
);
780 max_char
= min_char
+ chartab_chars
[depth
- 1] - 1;
788 chars_in_block
= chartab_chars
[depth
];
792 /* Set I to the index of the first element to check. */
793 if (from
<= min_char
)
796 i
= (from
- min_char
) / chars_in_block
;
797 for (c
= min_char
+ chars_in_block
* i
; c
<= max_char
;
798 i
++, c
+= chars_in_block
)
800 Lisp_Object
this = (SUB_CHAR_TABLE_P (table
)
801 ? XSUB_CHAR_TABLE (table
)->contents
[i
]
802 : XCHAR_TABLE (table
)->contents
[i
]);
803 int nextc
= c
+ chars_in_block
;
805 if (is_uniprop
&& UNIPROP_COMPRESSED_FORM_P (this))
806 this = uniprop_table_uncompress (table
, i
);
807 if (SUB_CHAR_TABLE_P (this))
810 XSETCDR (range
, make_number (nextc
- 1));
811 val
= map_sub_char_table (c_function
, function
, this, arg
,
817 this = XCHAR_TABLE (top
)->defalt
;
820 int different_value
= 1;
824 if (! NILP (XCHAR_TABLE (top
)->parent
))
826 Lisp_Object parent
= XCHAR_TABLE (top
)->parent
;
827 Lisp_Object temp
= XCHAR_TABLE (parent
)->parent
;
829 /* This is to get a value of FROM in PARENT
830 without checking the parent of PARENT. */
831 CSET (XCHAR_TABLE (parent
), parent
, Qnil
);
832 val
= CHAR_TABLE_REF (parent
, from
);
833 CSET (XCHAR_TABLE (parent
), parent
, temp
);
834 XSETCDR (range
, make_number (c
- 1));
835 val
= map_sub_char_table (c_function
, function
,
836 parent
, arg
, val
, range
,
842 if (! NILP (val
) && different_value
)
844 XSETCDR (range
, make_number (c
- 1));
845 if (EQ (XCAR (range
), XCDR (range
)))
848 (*c_function
) (arg
, XCAR (range
), val
);
852 val
= decoder (top
, val
);
853 call2 (function
, XCAR (range
), val
);
859 (*c_function
) (arg
, range
, val
);
863 val
= decoder (top
, val
);
864 call2 (function
, range
, val
);
870 XSETCAR (range
, make_number (c
));
873 XSETCDR (range
, make_number (to
));
879 /* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
880 character or group of characters that share a value.
882 ARG is passed to C_FUNCTION when that is called. */
885 map_char_table (void (*c_function
) (Lisp_Object
, Lisp_Object
, Lisp_Object
),
886 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
)
888 Lisp_Object range
, val
, parent
;
889 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
890 uniprop_decoder_t decoder
= UNIPROP_GET_DECODER (table
);
892 range
= Fcons (make_number (0), make_number (MAX_CHAR
));
893 parent
= XCHAR_TABLE (table
)->parent
;
895 GCPRO4 (table
, arg
, range
, parent
);
896 val
= XCHAR_TABLE (table
)->ascii
;
897 if (SUB_CHAR_TABLE_P (val
))
898 val
= XSUB_CHAR_TABLE (val
)->contents
[0];
899 val
= map_sub_char_table (c_function
, function
, table
, arg
, val
, range
,
902 /* If VAL is nil and TABLE has a parent, we must consult the parent
904 while (NILP (val
) && ! NILP (XCHAR_TABLE (table
)->parent
))
907 int from
= XINT (XCAR (range
));
909 parent
= XCHAR_TABLE (table
)->parent
;
910 temp
= XCHAR_TABLE (parent
)->parent
;
911 /* This is to get a value of FROM in PARENT without checking the
913 CSET (XCHAR_TABLE (parent
), parent
, Qnil
);
914 val
= CHAR_TABLE_REF (parent
, from
);
915 CSET (XCHAR_TABLE (parent
), parent
, temp
);
916 val
= map_sub_char_table (c_function
, function
, parent
, arg
, val
, range
,
923 if (EQ (XCAR (range
), XCDR (range
)))
926 (*c_function
) (arg
, XCAR (range
), val
);
930 val
= decoder (table
, val
);
931 call2 (function
, XCAR (range
), val
);
937 (*c_function
) (arg
, range
, val
);
941 val
= decoder (table
, val
);
942 call2 (function
, range
, val
);
950 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
952 doc
: /* Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
953 FUNCTION is called with two arguments, KEY and VALUE.
954 KEY is a character code or a cons of character codes specifying a
955 range of characters that have the same value.
956 VALUE is what (char-table-range CHAR-TABLE KEY) returns. */)
957 (Lisp_Object function
, Lisp_Object char_table
)
959 CHECK_CHAR_TABLE (char_table
);
961 map_char_table (NULL
, function
, char_table
, char_table
);
967 map_sub_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
968 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
969 Lisp_Object range
, struct charset
*charset
,
970 unsigned from
, unsigned to
)
972 struct Lisp_Sub_Char_Table
*tbl
= XSUB_CHAR_TABLE (table
);
973 int depth
= XINT (tbl
->depth
);
977 for (i
= 0, c
= XINT (tbl
->min_char
); i
< chartab_size
[depth
];
978 i
++, c
+= chartab_chars
[depth
])
982 this = tbl
->contents
[i
];
983 if (SUB_CHAR_TABLE_P (this))
984 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
985 range
, charset
, from
, to
);
988 if (! NILP (XCAR (range
)))
990 XSETCDR (range
, make_number (c
- 1));
992 (*c_function
) (arg
, range
);
994 call2 (function
, range
, arg
);
996 XSETCAR (range
, Qnil
);
1000 for (i
= 0, c
= XINT (tbl
->min_char
); i
< chartab_size
[depth
]; i
++, c
++)
1005 this = tbl
->contents
[i
];
1008 && (code
= ENCODE_CHAR (charset
, c
),
1009 (code
< from
|| code
> to
))))
1011 if (! NILP (XCAR (range
)))
1013 XSETCDR (range
, make_number (c
- 1));
1015 (*c_function
) (arg
, range
);
1017 call2 (function
, range
, arg
);
1018 XSETCAR (range
, Qnil
);
1023 if (NILP (XCAR (range
)))
1024 XSETCAR (range
, make_number (c
));
1030 /* Support function for `map-charset-chars'. Map C_FUNCTION or
1031 FUNCTION over TABLE, calling it for each character or a group of
1032 succeeding characters that have non-nil value in TABLE. TABLE is a
1033 "mapping table" or a "deunifier table" of a certain charset.
1035 If CHARSET is not NULL (this is the case that `map-charset-chars'
1036 is called with non-nil FROM-CODE and TO-CODE), it is a charset who
1037 owns TABLE, and the function is called only on a character in the
1038 range FROM and TO. FROM and TO are not character codes, but code
1039 points of a character in CHARSET.
1041 This function is called in these two cases:
1043 (1) A charset has a mapping file name in :map property.
1045 (2) A charset has an upper code space in :offset property and a
1046 mapping file name in :unify-map property. In this case, this
1047 function is called only for characters in the Unicode code space.
1048 Characters in upper code space are handled directly in
1049 map_charset_chars. */
1052 map_char_table_for_charset (void (*c_function
) (Lisp_Object
, Lisp_Object
),
1053 Lisp_Object function
, Lisp_Object table
, Lisp_Object arg
,
1054 struct charset
*charset
,
1055 unsigned from
, unsigned to
)
1059 struct gcpro gcpro1
;
1061 range
= Fcons (Qnil
, Qnil
);
1064 for (i
= 0, c
= 0; i
< chartab_size
[0]; i
++, c
+= chartab_chars
[0])
1068 this = XCHAR_TABLE (table
)->contents
[i
];
1069 if (SUB_CHAR_TABLE_P (this))
1070 map_sub_char_table_for_charset (c_function
, function
, this, arg
,
1071 range
, charset
, from
, to
);
1074 if (! NILP (XCAR (range
)))
1076 XSETCDR (range
, make_number (c
- 1));
1078 (*c_function
) (arg
, range
);
1080 call2 (function
, range
, arg
);
1082 XSETCAR (range
, Qnil
);
1085 if (! NILP (XCAR (range
)))
1087 XSETCDR (range
, make_number (c
- 1));
1089 (*c_function
) (arg
, range
);
1091 call2 (function
, range
, arg
);
1098 /* Unicode character property tables.
1100 This section provides a convenient and efficient way to get Unicode
1101 character properties of characters from C code (from Lisp, you must
1102 use get-char-code-property).
1104 The typical usage is to get a char-table object for a specific
1105 property like this (use of the "bidi-class" property below is just
1108 Lisp_Object bidi_class_table = uniprop_table (intern ("bidi-class"));
1110 (uniprop_table can return nil if it fails to find data for the
1111 named property, or if it fails to load the appropriate Lisp support
1112 file, so the return value should be tested to be non-nil, before it
1115 To get a property value for character CH use CHAR_TABLE_REF:
1117 Lisp_Object bidi_class = CHAR_TABLE_REF (bidi_class_table, CH);
1119 In this case, what you actually get is an index number to the
1120 vector of property values (symbols nil, L, R, etc).
1122 The full list of Unicode character properties supported by Emacs is
1123 documented in the ELisp manual, in the node "Character Properties".
1125 A table for Unicode character property has these characteristics:
1127 o The purpose is `char-code-property-table', which implies that the
1128 table has 5 extra slots.
1130 o The second extra slot is a Lisp function, an index (integer) to
1131 the array uniprop_decoder[], or nil. If it is a Lisp function, we
1132 can't use such a table from C (at the moment). If it is nil, it
1133 means that we don't have to decode values.
1135 o The third extra slot is a Lisp function, an index (integer) to
1136 the array uniprop_encoder[], or nil. If it is a Lisp function, we
1137 can't use such a table from C (at the moment). If it is nil, it
1138 means that we don't have to encode values. */
1141 /* Uncompress the IDXth element of sub-char-table TABLE. */
1144 uniprop_table_uncompress (Lisp_Object table
, int idx
)
1146 Lisp_Object val
= XSUB_CHAR_TABLE (table
)->contents
[idx
];
1147 int min_char
= (XINT (XSUB_CHAR_TABLE (table
)->min_char
)
1148 + chartab_chars
[2] * idx
);
1149 Lisp_Object sub
= make_sub_char_table (3, min_char
, Qnil
);
1150 const unsigned char *p
, *pend
;
1152 sub_char_table_set_contents (table
, idx
, sub
);
1153 p
= SDATA (val
), pend
= p
+ SBYTES (val
);
1158 idx
= STRING_CHAR_ADVANCE (p
);
1159 while (p
< pend
&& idx
< chartab_chars
[2])
1161 int v
= STRING_CHAR_ADVANCE (p
);
1162 sub_char_table_set_contents
1163 (sub
, idx
++, v
> 0 ? make_number (v
) : Qnil
);
1168 /* RUN-LENGTH TABLE */
1170 for (idx
= 0; p
< pend
; )
1172 int v
= STRING_CHAR_ADVANCE (p
);
1178 count
= STRING_CHAR_AND_LENGTH (p
, len
);
1188 sub_char_table_set_contents (sub
, idx
++, make_number (v
));
1191 /* It seems that we don't need this function because C code won't need
1192 to get a property that is compressed in this form. */
1196 /* WORD-LIST TABLE */
1203 /* Decode VALUE as an element of char-table TABLE. */
1206 uniprop_decode_value_run_length (Lisp_Object table
, Lisp_Object value
)
1208 if (VECTORP (XCHAR_TABLE (table
)->extras
[4]))
1210 Lisp_Object valvec
= XCHAR_TABLE (table
)->extras
[4];
1212 if (XINT (value
) >= 0 && XINT (value
) < ASIZE (valvec
))
1213 value
= AREF (valvec
, XINT (value
));
1218 static uniprop_decoder_t uniprop_decoder
[] =
1219 { uniprop_decode_value_run_length
};
1221 static int uniprop_decoder_count
1222 = (sizeof uniprop_decoder
) / sizeof (uniprop_decoder
[0]);
1225 /* Return the decoder of char-table TABLE or nil if none. */
1227 static uniprop_decoder_t
1228 uniprop_get_decoder (Lisp_Object table
)
1232 if (! INTEGERP (XCHAR_TABLE (table
)->extras
[1]))
1234 i
= XINT (XCHAR_TABLE (table
)->extras
[1]);
1235 if (i
< 0 || i
>= uniprop_decoder_count
)
1237 return uniprop_decoder
[i
];
1241 /* Encode VALUE as an element of char-table TABLE which contains
1242 characters as elements. */
1245 uniprop_encode_value_character (Lisp_Object table
, Lisp_Object value
)
1247 if (! NILP (value
) && ! CHARACTERP (value
))
1248 wrong_type_argument (Qintegerp
, value
);
1253 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
1257 uniprop_encode_value_run_length (Lisp_Object table
, Lisp_Object value
)
1259 Lisp_Object
*value_table
= XVECTOR (XCHAR_TABLE (table
)->extras
[4])->contents
;
1260 int i
, size
= ASIZE (XCHAR_TABLE (table
)->extras
[4]);
1262 for (i
= 0; i
< size
; i
++)
1263 if (EQ (value
, value_table
[i
]))
1266 wrong_type_argument (build_string ("Unicode property value"), value
);
1267 return make_number (i
);
1271 /* Encode VALUE as an element of char-table TABLE which adopts RUN-LENGTH
1272 compression and contains numbers as elements . */
1275 uniprop_encode_value_numeric (Lisp_Object table
, Lisp_Object value
)
1277 Lisp_Object
*value_table
= XVECTOR (XCHAR_TABLE (table
)->extras
[4])->contents
;
1278 int i
, size
= ASIZE (XCHAR_TABLE (table
)->extras
[4]);
1280 CHECK_NUMBER (value
);
1281 for (i
= 0; i
< size
; i
++)
1282 if (EQ (value
, value_table
[i
]))
1284 value
= make_number (i
);
1287 Lisp_Object args
[2];
1289 args
[0] = XCHAR_TABLE (table
)->extras
[4];
1290 args
[1] = Fmake_vector (make_number (1), value
);
1291 char_table_set_extras (table
, 4, Fvconcat (2, args
));
1293 return make_number (i
);
1296 static uniprop_encoder_t uniprop_encoder
[] =
1297 { uniprop_encode_value_character
,
1298 uniprop_encode_value_run_length
,
1299 uniprop_encode_value_numeric
};
1301 static int uniprop_encoder_count
1302 = (sizeof uniprop_encoder
) / sizeof (uniprop_encoder
[0]);
1305 /* Return the encoder of char-table TABLE or nil if none. */
1307 static uniprop_decoder_t
1308 uniprop_get_encoder (Lisp_Object table
)
1312 if (! INTEGERP (XCHAR_TABLE (table
)->extras
[2]))
1314 i
= XINT (XCHAR_TABLE (table
)->extras
[2]);
1315 if (i
< 0 || i
>= uniprop_encoder_count
)
1317 return uniprop_encoder
[i
];
1320 /* Return a char-table for Unicode character property PROP. This
1321 function may load a Lisp file and thus may cause
1322 garbage-collection. */
1325 uniprop_table (Lisp_Object prop
)
1327 Lisp_Object val
, table
, result
;
1329 val
= Fassq (prop
, Vchar_code_property_alist
);
1333 if (STRINGP (table
))
1335 struct gcpro gcpro1
;
1337 result
= Fload (concat2 (build_string ("international/"), table
),
1344 if (! CHAR_TABLE_P (table
)
1345 || ! UNIPROP_TABLE_P (table
))
1347 val
= XCHAR_TABLE (table
)->extras
[1];
1349 ? (XINT (val
) < 0 || XINT (val
) >= uniprop_decoder_count
)
1352 /* Prepare ASCII values in advance for CHAR_TABLE_REF. */
1353 CSET (XCHAR_TABLE (table
), ascii
, char_table_ascii (table
));
1357 DEFUN ("unicode-property-table-internal", Funicode_property_table_internal
,
1358 Sunicode_property_table_internal
, 1, 1, 0,
1359 doc
: /* Return a char-table for Unicode character property PROP.
1360 Use `get-unicode-property-internal' and
1361 `put-unicode-property-internal' instead of `aref' and `aset' to get
1362 and put an element value. */)
1365 Lisp_Object table
= uniprop_table (prop
);
1367 if (CHAR_TABLE_P (table
))
1369 return Fcdr (Fassq (prop
, Vchar_code_property_alist
));
1372 DEFUN ("get-unicode-property-internal", Fget_unicode_property_internal
,
1373 Sget_unicode_property_internal
, 2, 2, 0,
1374 doc
: /* Return an element of CHAR-TABLE for character CH.
1375 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
1376 (Lisp_Object char_table
, Lisp_Object ch
)
1379 uniprop_decoder_t decoder
;
1381 CHECK_CHAR_TABLE (char_table
);
1382 CHECK_CHARACTER (ch
);
1383 if (! UNIPROP_TABLE_P (char_table
))
1384 error ("Invalid Unicode property table");
1385 val
= CHAR_TABLE_REF (char_table
, XINT (ch
));
1386 decoder
= uniprop_get_decoder (char_table
);
1387 return (decoder
? decoder (char_table
, val
) : val
);
1390 DEFUN ("put-unicode-property-internal", Fput_unicode_property_internal
,
1391 Sput_unicode_property_internal
, 3, 3, 0,
1392 doc
: /* Set an element of CHAR-TABLE for character CH to VALUE.
1393 CHAR-TABLE must be what returned by `unicode-property-table-internal'. */)
1394 (Lisp_Object char_table
, Lisp_Object ch
, Lisp_Object value
)
1396 uniprop_encoder_t encoder
;
1398 CHECK_CHAR_TABLE (char_table
);
1399 CHECK_CHARACTER (ch
);
1400 if (! UNIPROP_TABLE_P (char_table
))
1401 error ("Invalid Unicode property table");
1402 encoder
= uniprop_get_encoder (char_table
);
1404 value
= encoder (char_table
, value
);
1405 CHAR_TABLE_SET (char_table
, XINT (ch
), value
);
1411 syms_of_chartab (void)
1413 DEFSYM (Qchar_code_property_table
, "char-code-property-table");
1415 defsubr (&Smake_char_table
);
1416 defsubr (&Schar_table_parent
);
1417 defsubr (&Schar_table_subtype
);
1418 defsubr (&Sset_char_table_parent
);
1419 defsubr (&Schar_table_extra_slot
);
1420 defsubr (&Sset_char_table_extra_slot
);
1421 defsubr (&Schar_table_range
);
1422 defsubr (&Sset_char_table_range
);
1423 defsubr (&Sset_char_table_default
);
1424 defsubr (&Soptimize_char_table
);
1425 defsubr (&Smap_char_table
);
1426 defsubr (&Sunicode_property_table_internal
);
1427 defsubr (&Sget_unicode_property_internal
);
1428 defsubr (&Sput_unicode_property_internal
);
1430 /* Each element has the form (PROP . TABLE).
1431 PROP is a symbol representing a character property.
1432 TABLE is a char-table containing the property value for each character.
1433 TABLE may be a name of file to load to build a char-table.
1434 This variable should be modified only through
1435 `define-char-code-property'. */
1437 DEFVAR_LISP ("char-code-property-alist", Vchar_code_property_alist
,
1438 doc
: /* Alist of character property name vs char-table containing property values.
1439 Internal use only. */);
1440 Vchar_code_property_alist
= Qnil
;