1 /* XEmacs routines to deal with char tables.
2 Copyright (C) 1992, 1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
5 Copyright (C) 1995, 1997, 1999 Electrotechnical Laboratory, JAPAN.
6 Licensed to the Free Software Foundation.
8 This file is part of XEmacs.
10 XEmacs is free software; you can redistribute it and/or modify it
11 under the terms of the GNU General Public License as published by the
12 Free Software Foundation; either version 2, or (at your option) any
15 XEmacs is distributed in the hope that it will be useful, but WITHOUT
16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with XEmacs; see the file COPYING. If not, write to
22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 Boston, MA 02111-1307, USA. */
25 /* Synched up with: Mule 2.3. Not synched with FSF.
27 This file was written independently of the FSF implementation,
28 and is not compatible. */
32 Ben Wing: wrote, for 19.13 (Mule). Some category table stuff
33 loosely based on the original Mule.
34 Jareth Hein: fixed a couple of bugs in the implementation, and
35 added regex support for categories with check_category_at
48 Lisp_Object Vutf_2000_version;
51 Lisp_Object Qchar_tablep, Qchar_table;
53 Lisp_Object Vall_syntax_tables;
56 Lisp_Object Qcategory_table_p;
57 Lisp_Object Qcategory_designator_p;
58 Lisp_Object Qcategory_table_value_p;
60 Lisp_Object Vstandard_category_table;
62 /* Variables to determine word boundary. */
63 Lisp_Object Vword_combining_categories, Vword_separating_categories;
69 #define BT_UINT8_MIN 0
70 #define BT_UINT8_MAX (UCHAR_MAX - 3)
71 #define BT_UINT8_t (UCHAR_MAX - 2)
72 #define BT_UINT8_nil (UCHAR_MAX - 1)
73 #define BT_UINT8_unbound UCHAR_MAX
75 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
76 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
77 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
78 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
79 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
82 INT_UINT8_P (Lisp_Object obj)
88 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
95 UINT8_VALUE_P (Lisp_Object obj)
97 return EQ (obj, Qunbound)
98 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
101 INLINE_HEADER unsigned char
102 UINT8_ENCODE (Lisp_Object obj)
104 if (EQ (obj, Qunbound))
105 return BT_UINT8_unbound;
106 else if (EQ (obj, Qnil))
108 else if (EQ (obj, Qt))
114 INLINE_HEADER Lisp_Object
115 UINT8_DECODE (unsigned char n)
117 if (n == BT_UINT8_unbound)
119 else if (n == BT_UINT8_nil)
121 else if (n == BT_UINT8_t)
128 mark_uint8_byte_table (Lisp_Object obj)
134 print_uint8_byte_table (Lisp_Object obj,
135 Lisp_Object printcharfun, int escapeflag)
137 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
139 struct gcpro gcpro1, gcpro2;
140 GCPRO2 (obj, printcharfun);
142 write_c_string ("\n#<uint8-byte-table", printcharfun);
143 for (i = 0; i < 256; i++)
145 unsigned char n = bte->property[i];
147 write_c_string ("\n ", printcharfun);
148 write_c_string (" ", printcharfun);
149 if (n == BT_UINT8_unbound)
150 write_c_string ("void", printcharfun);
151 else if (n == BT_UINT8_nil)
152 write_c_string ("nil", printcharfun);
153 else if (n == BT_UINT8_t)
154 write_c_string ("t", printcharfun);
159 sprintf (buf, "%hd", n);
160 write_c_string (buf, printcharfun);
164 write_c_string (">", printcharfun);
168 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
170 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
171 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
174 for (i = 0; i < 256; i++)
175 if (te1->property[i] != te2->property[i])
181 uint8_byte_table_hash (Lisp_Object obj, int depth)
183 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
187 for (i = 0; i < 256; i++)
188 hash = HASH2 (hash, te->property[i]);
192 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
193 mark_uint8_byte_table,
194 print_uint8_byte_table,
195 0, uint8_byte_table_equal,
196 uint8_byte_table_hash,
197 0 /* uint8_byte_table_description */,
198 Lisp_Uint8_Byte_Table);
201 make_uint8_byte_table (unsigned char initval)
205 Lisp_Uint8_Byte_Table *cte;
207 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
208 &lrecord_uint8_byte_table);
210 for (i = 0; i < 256; i++)
211 cte->property[i] = initval;
213 XSETUINT8_BYTE_TABLE (obj, cte);
218 uint8_byte_table_same_value_p (Lisp_Object obj)
220 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
221 unsigned char v0 = bte->property[0];
224 for (i = 1; i < 256; i++)
226 if (bte->property[i] != v0)
233 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct,
234 int (*fn) (Emchar c, Lisp_Object val, void *arg),
235 void *arg, Emchar ofs, int place)
238 int unit = 1 << (8 * place);
242 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
244 if (ct->property[i] != BT_UINT8_unbound)
247 for (; c < c1 && retval == 0; c++)
248 retval = (fn) (c, UINT8_DECODE (ct->property[i]), arg);
256 #define BT_UINT16_MIN 0
257 #define BT_UINT16_MAX (USHRT_MAX - 3)
258 #define BT_UINT16_t (USHRT_MAX - 2)
259 #define BT_UINT16_nil (USHRT_MAX - 1)
260 #define BT_UINT16_unbound USHRT_MAX
262 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
263 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
264 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
265 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
268 INT_UINT16_P (Lisp_Object obj)
272 int num = XINT (obj);
274 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
281 UINT16_VALUE_P (Lisp_Object obj)
283 return EQ (obj, Qunbound)
284 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
287 INLINE_HEADER unsigned short
288 UINT16_ENCODE (Lisp_Object obj)
290 if (EQ (obj, Qunbound))
291 return BT_UINT16_unbound;
292 else if (EQ (obj, Qnil))
293 return BT_UINT16_nil;
294 else if (EQ (obj, Qt))
300 INLINE_HEADER Lisp_Object
301 UINT16_DECODE (unsigned short n)
303 if (n == BT_UINT16_unbound)
305 else if (n == BT_UINT16_nil)
307 else if (n == BT_UINT16_t)
313 INLINE_HEADER unsigned short
314 UINT8_TO_UINT16 (unsigned char n)
316 if (n == BT_UINT8_unbound)
317 return BT_UINT16_unbound;
318 else if (n == BT_UINT8_nil)
319 return BT_UINT16_nil;
320 else if (n == BT_UINT8_t)
327 mark_uint16_byte_table (Lisp_Object obj)
333 print_uint16_byte_table (Lisp_Object obj,
334 Lisp_Object printcharfun, int escapeflag)
336 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
338 struct gcpro gcpro1, gcpro2;
339 GCPRO2 (obj, printcharfun);
341 write_c_string ("\n#<uint16-byte-table", printcharfun);
342 for (i = 0; i < 256; i++)
344 unsigned short n = bte->property[i];
346 write_c_string ("\n ", printcharfun);
347 write_c_string (" ", printcharfun);
348 if (n == BT_UINT16_unbound)
349 write_c_string ("void", printcharfun);
350 else if (n == BT_UINT16_nil)
351 write_c_string ("nil", printcharfun);
352 else if (n == BT_UINT16_t)
353 write_c_string ("t", printcharfun);
358 sprintf (buf, "%hd", n);
359 write_c_string (buf, printcharfun);
363 write_c_string (">", printcharfun);
367 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
369 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
370 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
373 for (i = 0; i < 256; i++)
374 if (te1->property[i] != te2->property[i])
380 uint16_byte_table_hash (Lisp_Object obj, int depth)
382 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
386 for (i = 0; i < 256; i++)
387 hash = HASH2 (hash, te->property[i]);
391 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
392 mark_uint16_byte_table,
393 print_uint16_byte_table,
394 0, uint16_byte_table_equal,
395 uint16_byte_table_hash,
396 0 /* uint16_byte_table_description */,
397 Lisp_Uint16_Byte_Table);
400 make_uint16_byte_table (unsigned short initval)
404 Lisp_Uint16_Byte_Table *cte;
406 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
407 &lrecord_uint16_byte_table);
409 for (i = 0; i < 256; i++)
410 cte->property[i] = initval;
412 XSETUINT16_BYTE_TABLE (obj, cte);
417 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
421 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
422 Lisp_Uint16_Byte_Table* cte;
424 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
425 &lrecord_uint16_byte_table);
426 for (i = 0; i < 256; i++)
428 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
430 XSETUINT16_BYTE_TABLE (obj, cte);
435 uint16_byte_table_same_value_p (Lisp_Object obj)
437 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
438 unsigned short v0 = bte->property[0];
441 for (i = 1; i < 256; i++)
443 if (bte->property[i] != v0)
450 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct,
451 int (*fn) (Emchar c, Lisp_Object val, void *arg),
452 void *arg, Emchar ofs, int place)
455 int unit = 1 << (8 * place);
459 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
461 if (ct->property[i] != BT_UINT16_unbound)
464 for (; c < c1 && retval == 0; c++)
465 retval = (fn) (c, UINT16_DECODE (ct->property[i]), arg);
475 mark_byte_table (Lisp_Object obj)
477 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
480 for (i = 0; i < 256; i++)
482 mark_object (cte->property[i]);
488 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
490 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
492 struct gcpro gcpro1, gcpro2;
493 GCPRO2 (obj, printcharfun);
495 write_c_string ("\n#<byte-table", printcharfun);
496 for (i = 0; i < 256; i++)
498 Lisp_Object elt = bte->property[i];
500 write_c_string ("\n ", printcharfun);
501 write_c_string (" ", printcharfun);
502 if (EQ (elt, Qunbound))
503 write_c_string ("void", printcharfun);
505 print_internal (elt, printcharfun, escapeflag);
508 write_c_string (">", printcharfun);
512 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
514 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
515 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
518 for (i = 0; i < 256; i++)
519 if (BYTE_TABLE_P (cte1->property[i]))
521 if (BYTE_TABLE_P (cte2->property[i]))
523 if (!byte_table_equal (cte1->property[i],
524 cte2->property[i], depth + 1))
531 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
537 byte_table_hash (Lisp_Object obj, int depth)
539 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
541 return internal_array_hash (cte->property, 256, depth);
544 static const struct lrecord_description byte_table_description[] = {
545 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
549 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
554 byte_table_description,
558 make_byte_table (Lisp_Object initval)
562 Lisp_Byte_Table *cte;
564 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
566 for (i = 0; i < 256; i++)
567 cte->property[i] = initval;
569 XSETBYTE_TABLE (obj, cte);
574 byte_table_same_value_p (Lisp_Object obj)
576 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
577 Lisp_Object v0 = bte->property[0];
580 for (i = 1; i < 256; i++)
582 if (!internal_equal (bte->property[i], v0, 0))
589 map_over_byte_table (Lisp_Byte_Table *ct,
590 int (*fn) (Emchar c, Lisp_Object val, void *arg),
591 void *arg, Emchar ofs, int place)
595 int unit = 1 << (8 * place);
598 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
601 if (UINT8_BYTE_TABLE_P (v))
604 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v),
605 fn, arg, c, place - 1);
608 else if (UINT16_BYTE_TABLE_P (v))
611 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v),
612 fn, arg, c, place - 1);
615 else if (BYTE_TABLE_P (v))
617 retval = map_over_byte_table (XBYTE_TABLE(v),
618 fn, arg, c, place - 1);
621 else if (!UNBOUNDP (v))
623 Emchar c1 = c + unit;
625 for (; c < c1 && retval == 0; c++)
626 retval = (fn) (c, v, arg);
635 Lisp_Object get_byte_table (Lisp_Object table, unsigned char idx);
636 Lisp_Object put_byte_table (Lisp_Object table, unsigned char idx,
640 get_byte_table (Lisp_Object table, unsigned char idx)
642 if (UINT8_BYTE_TABLE_P (table))
643 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
644 else if (UINT16_BYTE_TABLE_P (table))
645 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
646 else if (BYTE_TABLE_P (table))
647 return XBYTE_TABLE(table)->property[idx];
653 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
655 if (UINT8_BYTE_TABLE_P (table))
657 if (UINT8_VALUE_P (value))
659 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
660 if (!UINT8_BYTE_TABLE_P (value) &&
661 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
662 && uint8_byte_table_same_value_p (table))
667 else if (UINT16_VALUE_P (value))
669 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
671 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
676 Lisp_Object new = make_byte_table (Qnil);
679 for (i = 0; i < 256; i++)
681 XBYTE_TABLE(new)->property[i]
682 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
684 XBYTE_TABLE(new)->property[idx] = value;
688 else if (UINT16_BYTE_TABLE_P (table))
690 if (UINT16_VALUE_P (value))
692 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
693 if (!UINT8_BYTE_TABLE_P (value) &&
694 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
695 && uint16_byte_table_same_value_p (table))
702 Lisp_Object new = make_byte_table (Qnil);
705 for (i = 0; i < 256; i++)
707 XBYTE_TABLE(new)->property[i]
708 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
710 XBYTE_TABLE(new)->property[idx] = value;
714 else if (BYTE_TABLE_P (table))
716 XBYTE_TABLE(table)->property[idx] = value;
717 if (!UINT8_BYTE_TABLE_P (value) &&
718 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
719 && byte_table_same_value_p (table))
724 else if (!internal_equal (table, value, 0))
726 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
728 table = make_uint8_byte_table (UINT8_ENCODE (table));
729 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
731 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
733 table = make_uint16_byte_table (UINT16_ENCODE (table));
734 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
738 table = make_byte_table (table);
739 XBYTE_TABLE(table)->property[idx] = value;
746 mark_char_id_table (Lisp_Object obj)
748 Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj);
754 print_char_id_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
756 Lisp_Object table = XCHAR_ID_TABLE (obj)->table;
758 struct gcpro gcpro1, gcpro2;
759 GCPRO2 (obj, printcharfun);
761 write_c_string ("#<char-id-table ", printcharfun);
762 for (i = 0; i < 256; i++)
764 Lisp_Object elt = get_byte_table (table, i);
765 if (i != 0) write_c_string ("\n ", printcharfun);
766 if (EQ (elt, Qunbound))
767 write_c_string ("void", printcharfun);
769 print_internal (elt, printcharfun, escapeflag);
772 write_c_string (">", printcharfun);
776 char_id_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
778 Lisp_Object table1 = XCHAR_ID_TABLE (obj1)->table;
779 Lisp_Object table2 = XCHAR_ID_TABLE (obj2)->table;
782 for (i = 0; i < 256; i++)
784 if (!internal_equal (get_byte_table (table1, i),
785 get_byte_table (table2, i), 0))
792 char_id_table_hash (Lisp_Object obj, int depth)
794 Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj);
796 return char_id_table_hash (cte->table, depth + 1);
799 static const struct lrecord_description char_id_table_description[] = {
800 { XD_LISP_OBJECT, offsetof(Lisp_Char_ID_Table, table) },
804 DEFINE_LRECORD_IMPLEMENTATION ("char-id-table", char_id_table,
807 0, char_id_table_equal,
809 char_id_table_description,
813 make_char_id_table (Lisp_Object initval)
816 Lisp_Char_ID_Table *cte;
818 cte = alloc_lcrecord_type (Lisp_Char_ID_Table, &lrecord_char_id_table);
820 cte->table = make_byte_table (initval);
822 XSETCHAR_ID_TABLE (obj, cte);
828 get_char_id_table (Emchar ch, Lisp_Object table)
830 unsigned int code = ch;
837 (XCHAR_ID_TABLE (table)->table,
838 (unsigned char)(code >> 24)),
839 (unsigned char) (code >> 16)),
840 (unsigned char) (code >> 8)),
841 (unsigned char) code);
845 put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table)
847 unsigned int code = ch;
848 Lisp_Object table1, table2, table3, table4;
850 table1 = XCHAR_ID_TABLE (table)->table;
851 table2 = get_byte_table (table1, (unsigned char)(code >> 24));
852 table3 = get_byte_table (table2, (unsigned char)(code >> 16));
853 table4 = get_byte_table (table3, (unsigned char)(code >> 8));
855 table4 = put_byte_table (table4, (unsigned char)code, value);
856 table3 = put_byte_table (table3, (unsigned char)(code >> 8), table4);
857 table2 = put_byte_table (table2, (unsigned char)(code >> 16), table3);
858 XCHAR_ID_TABLE (table)->table
859 = put_byte_table (table1, (unsigned char)(code >> 24), table2);
862 /* Map FN (with client data ARG) in char table CT.
863 Mapping stops the first time FN returns non-zero, and that value
864 becomes the return value of map_char_id_table(). */
866 map_char_id_table (Lisp_Char_ID_Table *ct,
867 int (*fn) (Emchar c, Lisp_Object val, void *arg),
870 map_char_id_table (Lisp_Char_ID_Table *ct,
871 int (*fn) (Emchar c, Lisp_Object val, void *arg),
874 Lisp_Object v = ct->table;
876 if (UINT8_BYTE_TABLE_P (v))
877 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), fn, arg, 0, 3);
878 else if (UINT16_BYTE_TABLE_P (v))
879 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), fn, arg, 0, 3);
880 else if (BYTE_TABLE_P (v))
881 return map_over_byte_table (XBYTE_TABLE(v), fn, arg, 0, 3);
882 else if (!UNBOUNDP (v))
886 Emchar c1 = c + unit;
889 for (retval = 0; c < c1 && retval == 0; c++)
890 retval = (fn) (c, v, arg);
895 struct slow_map_char_id_table_arg
897 Lisp_Object function;
902 slow_map_char_id_table_fun (Emchar c, Lisp_Object val, void *arg)
904 struct slow_map_char_id_table_arg *closure =
905 (struct slow_map_char_id_table_arg *) arg;
907 closure->retval = call2 (closure->function, make_char (c), val);
908 return !NILP (closure->retval);
912 Lisp_Object Vchar_attribute_hash_table;
913 Lisp_Object Vcharacter_composition_table;
914 Lisp_Object Vcharacter_variant_table;
917 Lisp_Object Q_decomposition;
921 Lisp_Object Qisolated;
922 Lisp_Object Qinitial;
925 Lisp_Object Qvertical;
926 Lisp_Object QnoBreak;
927 Lisp_Object Qfraction;
937 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
940 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
946 else if (EQ (v, Qcompat))
948 else if (EQ (v, Qisolated))
950 else if (EQ (v, Qinitial))
952 else if (EQ (v, Qmedial))
954 else if (EQ (v, Qfinal))
956 else if (EQ (v, Qvertical))
958 else if (EQ (v, QnoBreak))
960 else if (EQ (v, Qfraction))
962 else if (EQ (v, Qsuper))
964 else if (EQ (v, Qsub))
966 else if (EQ (v, Qcircle))
968 else if (EQ (v, Qsquare))
970 else if (EQ (v, Qwide))
972 else if (EQ (v, Qnarrow))
974 else if (EQ (v, Qsmall))
976 else if (EQ (v, Qfont))
979 signal_simple_error (err_msg, err_arg);
982 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
983 Return character corresponding with list.
987 Lisp_Object table = Vcharacter_composition_table;
988 Lisp_Object rest = list;
992 Lisp_Object v = Fcar (rest);
994 Emchar c = to_char_id (v, "Invalid value for composition", list);
996 ret = get_char_id_table (c, table);
1001 if (!CHAR_ID_TABLE_P (ret))
1006 else if (!CONSP (rest))
1008 else if (CHAR_ID_TABLE_P (ret))
1011 signal_simple_error ("Invalid table is found with", list);
1013 signal_simple_error ("Invalid value for composition", list);
1016 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1017 Return variants of CHARACTER.
1021 CHECK_CHAR (character);
1022 return Fcopy_list (get_char_id_table (XCHAR (character),
1023 Vcharacter_variant_table));
1027 /* We store the char-attributes in hash tables with the names as the
1028 key and the actual char-id-table object as the value. Occasionally
1029 we need to use them in a list format. These routines provide us
1031 struct char_attribute_list_closure
1033 Lisp_Object *char_attribute_list;
1037 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
1038 void *char_attribute_list_closure)
1040 /* This function can GC */
1041 struct char_attribute_list_closure *calcl
1042 = (struct char_attribute_list_closure*) char_attribute_list_closure;
1043 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
1045 *char_attribute_list = Fcons (key, *char_attribute_list);
1049 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
1050 Return the list of all existing character attributes except coded-charsets.
1054 Lisp_Object char_attribute_list = Qnil;
1055 struct gcpro gcpro1;
1056 struct char_attribute_list_closure char_attribute_list_closure;
1058 GCPRO1 (char_attribute_list);
1059 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
1060 elisp_maphash (add_char_attribute_to_list_mapper,
1061 Vchar_attribute_hash_table,
1062 &char_attribute_list_closure);
1064 return char_attribute_list;
1067 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
1068 Return char-id-table corresponding to ATTRIBUTE.
1072 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
1076 /* We store the char-id-tables in hash tables with the attributes as
1077 the key and the actual char-id-table object as the value. Each
1078 char-id-table stores values of an attribute corresponding with
1079 characters. Occasionally we need to get attributes of a character
1080 in a association-list format. These routines provide us with
1082 struct char_attribute_alist_closure
1085 Lisp_Object *char_attribute_alist;
1089 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
1090 void *char_attribute_alist_closure)
1092 /* This function can GC */
1093 struct char_attribute_alist_closure *caacl =
1094 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
1095 Lisp_Object ret = get_char_id_table (caacl->char_id, value);
1096 if (!UNBOUNDP (ret))
1098 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
1099 *char_attribute_alist
1100 = Fcons (Fcons (key, ret), *char_attribute_alist);
1105 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
1106 Return the alist of attributes of CHARACTER.
1110 Lisp_Object alist = Qnil;
1113 CHECK_CHAR (character);
1115 struct gcpro gcpro1;
1116 struct char_attribute_alist_closure char_attribute_alist_closure;
1119 char_attribute_alist_closure.char_id = XCHAR (character);
1120 char_attribute_alist_closure.char_attribute_alist = &alist;
1121 elisp_maphash (add_char_attribute_alist_mapper,
1122 Vchar_attribute_hash_table,
1123 &char_attribute_alist_closure);
1127 for (i = 0; i < countof (chlook->charset_by_leading_byte); i++)
1129 Lisp_Object ccs = chlook->charset_by_leading_byte[i];
1133 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
1136 if ( CHAR_ID_TABLE_P (encoding_table)
1137 && INTP (cpos = get_char_id_table (XCHAR (character),
1140 alist = Fcons (Fcons (ccs, cpos), alist);
1147 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
1148 Return the value of CHARACTER's ATTRIBUTE.
1149 Return DEFAULT-VALUE if the value is not exist.
1151 (character, attribute, default_value))
1155 CHECK_CHAR (character);
1156 if (!NILP (ccs = Ffind_charset (attribute)))
1158 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
1160 if (CHAR_ID_TABLE_P (encoding_table))
1161 return get_char_id_table (XCHAR (character), encoding_table);
1165 Lisp_Object table = Fgethash (attribute,
1166 Vchar_attribute_hash_table,
1168 if (!UNBOUNDP (table))
1170 Lisp_Object ret = get_char_id_table (XCHAR (character), table);
1171 if (!UNBOUNDP (ret))
1175 return default_value;
1178 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
1179 Store CHARACTER's ATTRIBUTE with VALUE.
1181 (character, attribute, value))
1185 CHECK_CHAR (character);
1186 ccs = Ffind_charset (attribute);
1189 return put_char_ccs_code_point (character, ccs, value);
1191 else if (EQ (attribute, Q_decomposition))
1196 signal_simple_error ("Invalid value for ->decomposition",
1199 if (CONSP (Fcdr (value)))
1201 Lisp_Object rest = value;
1202 Lisp_Object table = Vcharacter_composition_table;
1206 GET_EXTERNAL_LIST_LENGTH (rest, len);
1207 seq = make_vector (len, Qnil);
1209 while (CONSP (rest))
1211 Lisp_Object v = Fcar (rest);
1214 = to_char_id (v, "Invalid value for ->decomposition", value);
1217 XVECTOR_DATA(seq)[i++] = v;
1219 XVECTOR_DATA(seq)[i++] = make_char (c);
1223 put_char_id_table (c, character, table);
1228 ntable = get_char_id_table (c, table);
1229 if (!CHAR_ID_TABLE_P (ntable))
1231 ntable = make_char_id_table (Qnil);
1232 put_char_id_table (c, ntable, table);
1240 Lisp_Object v = Fcar (value);
1244 Emchar c = XINT (v);
1246 = get_char_id_table (c, Vcharacter_variant_table);
1248 if (NILP (Fmemq (v, ret)))
1250 put_char_id_table (c, Fcons (character, ret),
1251 Vcharacter_variant_table);
1254 seq = make_vector (1, v);
1258 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
1264 signal_simple_error ("Invalid value for ->ucs", value);
1268 ret = get_char_id_table (c, Vcharacter_variant_table);
1269 if (NILP (Fmemq (character, ret)))
1271 put_char_id_table (c, Fcons (character, ret),
1272 Vcharacter_variant_table);
1275 if (EQ (attribute, Q_ucs))
1276 attribute = Qto_ucs;
1280 Lisp_Object table = Fgethash (attribute,
1281 Vchar_attribute_hash_table,
1286 table = make_char_id_table (Qunbound);
1287 Fputhash (attribute, table, Vchar_attribute_hash_table);
1289 put_char_id_table (XCHAR (character), value, table);
1294 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
1295 Remove CHARACTER's ATTRIBUTE.
1297 (character, attribute))
1301 CHECK_CHAR (character);
1302 ccs = Ffind_charset (attribute);
1305 return remove_char_ccs (character, ccs);
1309 Lisp_Object table = Fgethash (attribute,
1310 Vchar_attribute_hash_table,
1312 if (!UNBOUNDP (table))
1314 put_char_id_table (XCHAR (character), Qunbound, table);
1321 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 2, 0, /*
1322 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
1323 each key and value in the table.
1325 (function, attribute))
1328 Lisp_Char_ID_Table *ct;
1329 struct slow_map_char_id_table_arg slarg;
1330 struct gcpro gcpro1, gcpro2;
1332 if (!NILP (ccs = Ffind_charset (attribute)))
1334 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
1336 if (CHAR_ID_TABLE_P (encoding_table))
1337 ct = XCHAR_ID_TABLE (encoding_table);
1343 Lisp_Object table = Fgethash (attribute,
1344 Vchar_attribute_hash_table,
1346 if (CHAR_ID_TABLE_P (table))
1347 ct = XCHAR_ID_TABLE (table);
1351 slarg.function = function;
1352 slarg.retval = Qnil;
1353 GCPRO2 (slarg.function, slarg.retval);
1354 map_char_id_table (ct, slow_map_char_id_table_fun, &slarg);
1357 return slarg.retval;
1360 EXFUN (Fmake_char, 3);
1361 EXFUN (Fdecode_char, 2);
1363 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
1364 Store character's ATTRIBUTES.
1368 Lisp_Object rest = attributes;
1369 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
1370 Lisp_Object character;
1374 while (CONSP (rest))
1376 Lisp_Object cell = Fcar (rest);
1380 signal_simple_error ("Invalid argument", attributes);
1381 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
1382 && ((XCHARSET_FINAL (ccs) != 0) ||
1383 (XCHARSET_UCS_MAX (ccs) > 0)) )
1387 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
1389 character = Fdecode_char (ccs, cell);
1390 if (!NILP (character))
1391 goto setup_attributes;
1395 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
1396 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
1400 signal_simple_error ("Invalid argument", attributes);
1402 character = make_char (XINT (code) + 0x100000);
1403 goto setup_attributes;
1407 else if (!INTP (code))
1408 signal_simple_error ("Invalid argument", attributes);
1410 character = make_char (XINT (code));
1414 while (CONSP (rest))
1416 Lisp_Object cell = Fcar (rest);
1419 signal_simple_error ("Invalid argument", attributes);
1421 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
1427 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
1428 Retrieve the character of the given ATTRIBUTES.
1432 Lisp_Object rest = attributes;
1435 while (CONSP (rest))
1437 Lisp_Object cell = Fcar (rest);
1441 signal_simple_error ("Invalid argument", attributes);
1442 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
1446 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
1448 return Fdecode_char (ccs, cell);
1452 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
1453 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
1456 signal_simple_error ("Invalid argument", attributes);
1458 return make_char (XINT (code) + 0x100000);
1466 /* A char table maps from ranges of characters to values.
1468 Implementing a general data structure that maps from arbitrary
1469 ranges of numbers to values is tricky to do efficiently. As it
1470 happens, it should suffice (and is usually more convenient, anyway)
1471 when dealing with characters to restrict the sorts of ranges that
1472 can be assigned values, as follows:
1475 2) All characters in a charset.
1476 3) All characters in a particular row of a charset, where a "row"
1477 means all characters with the same first byte.
1478 4) A particular character in a charset.
1480 We use char tables to generalize the 256-element vectors now
1481 littering the Emacs code.
1483 Possible uses (all should be converted at some point):
1489 5) keyboard-translate-table?
1492 abstract type to generalize the Emacs vectors and Mule
1493 vectors-of-vectors goo.
1496 /************************************************************************/
1497 /* Char Table object */
1498 /************************************************************************/
1503 mark_char_table_entry (Lisp_Object obj)
1505 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1508 for (i = 0; i < 96; i++)
1510 mark_object (cte->level2[i]);
1516 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1518 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1519 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1522 for (i = 0; i < 96; i++)
1523 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1529 static unsigned long
1530 char_table_entry_hash (Lisp_Object obj, int depth)
1532 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1534 return internal_array_hash (cte->level2, 96, depth);
1537 static const struct lrecord_description char_table_entry_description[] = {
1538 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1542 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1543 mark_char_table_entry, internal_object_printer,
1544 0, char_table_entry_equal,
1545 char_table_entry_hash,
1546 char_table_entry_description,
1547 Lisp_Char_Table_Entry);
1551 mark_char_table (Lisp_Object obj)
1553 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1556 for (i = 0; i < NUM_ASCII_CHARS; i++)
1557 mark_object (ct->ascii[i]);
1559 for (i = 0; i < NUM_LEADING_BYTES; i++)
1560 mark_object (ct->level1[i]);
1562 return ct->mirror_table;
1565 /* WARNING: All functions of this nature need to be written extremely
1566 carefully to avoid crashes during GC. Cf. prune_specifiers()
1567 and prune_weak_hash_tables(). */
1570 prune_syntax_tables (void)
1572 Lisp_Object rest, prev = Qnil;
1574 for (rest = Vall_syntax_tables;
1576 rest = XCHAR_TABLE (rest)->next_table)
1578 if (! marked_p (rest))
1580 /* This table is garbage. Remove it from the list. */
1582 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1584 XCHAR_TABLE (prev)->next_table =
1585 XCHAR_TABLE (rest)->next_table;
1591 char_table_type_to_symbol (enum char_table_type type)
1596 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1597 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1598 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1599 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1601 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1606 static enum char_table_type
1607 symbol_to_char_table_type (Lisp_Object symbol)
1609 CHECK_SYMBOL (symbol);
1611 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1612 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1613 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1614 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1616 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1619 signal_simple_error ("Unrecognized char table type", symbol);
1620 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1624 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1625 Lisp_Object printcharfun)
1629 write_c_string (" (", printcharfun);
1630 print_internal (make_char (first), printcharfun, 0);
1631 write_c_string (" ", printcharfun);
1632 print_internal (make_char (last), printcharfun, 0);
1633 write_c_string (") ", printcharfun);
1637 write_c_string (" ", printcharfun);
1638 print_internal (make_char (first), printcharfun, 0);
1639 write_c_string (" ", printcharfun);
1641 print_internal (val, printcharfun, 1);
1647 print_chartab_charset_row (Lisp_Object charset,
1649 Lisp_Char_Table_Entry *cte,
1650 Lisp_Object printcharfun)
1653 Lisp_Object cat = Qunbound;
1656 for (i = 32; i < 128; i++)
1658 Lisp_Object pam = cte->level2[i - 32];
1670 print_chartab_range (MAKE_CHAR (charset, first, 0),
1671 MAKE_CHAR (charset, i - 1, 0),
1674 print_chartab_range (MAKE_CHAR (charset, row, first),
1675 MAKE_CHAR (charset, row, i - 1),
1685 print_chartab_range (MAKE_CHAR (charset, first, 0),
1686 MAKE_CHAR (charset, i - 1, 0),
1689 print_chartab_range (MAKE_CHAR (charset, row, first),
1690 MAKE_CHAR (charset, row, i - 1),
1696 print_chartab_two_byte_charset (Lisp_Object charset,
1697 Lisp_Char_Table_Entry *cte,
1698 Lisp_Object printcharfun)
1702 for (i = 32; i < 128; i++)
1704 Lisp_Object jen = cte->level2[i - 32];
1706 if (!CHAR_TABLE_ENTRYP (jen))
1710 write_c_string (" [", printcharfun);
1711 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1712 sprintf (buf, " %d] ", i);
1713 write_c_string (buf, printcharfun);
1714 print_internal (jen, printcharfun, 0);
1717 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1725 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1727 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1730 sprintf (buf, "#s(char-table type %s data (",
1731 string_data (symbol_name (XSYMBOL
1732 (char_table_type_to_symbol (ct->type)))));
1733 write_c_string (buf, printcharfun);
1735 /* Now write out the ASCII/Control-1 stuff. */
1739 Lisp_Object val = Qunbound;
1741 for (i = 0; i < NUM_ASCII_CHARS; i++)
1750 if (!EQ (ct->ascii[i], val))
1752 print_chartab_range (first, i - 1, val, printcharfun);
1759 print_chartab_range (first, i - 1, val, printcharfun);
1766 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1769 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1770 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1772 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1773 || i == LEADING_BYTE_CONTROL_1)
1775 if (!CHAR_TABLE_ENTRYP (ann))
1777 write_c_string (" ", printcharfun);
1778 print_internal (XCHARSET_NAME (charset),
1780 write_c_string (" ", printcharfun);
1781 print_internal (ann, printcharfun, 0);
1785 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1786 if (XCHARSET_DIMENSION (charset) == 1)
1787 print_chartab_charset_row (charset, -1, cte, printcharfun);
1789 print_chartab_two_byte_charset (charset, cte, printcharfun);
1795 write_c_string ("))", printcharfun);
1799 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1801 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1802 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1805 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1808 for (i = 0; i < NUM_ASCII_CHARS; i++)
1809 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1813 for (i = 0; i < NUM_LEADING_BYTES; i++)
1814 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1821 static unsigned long
1822 char_table_hash (Lisp_Object obj, int depth)
1824 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1825 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1828 hashval = HASH2 (hashval,
1829 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1834 static const struct lrecord_description char_table_description[] = {
1835 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1837 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1839 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1840 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1844 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1845 mark_char_table, print_char_table, 0,
1846 char_table_equal, char_table_hash,
1847 char_table_description,
1850 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1851 Return non-nil if OBJECT is a char table.
1853 A char table is a table that maps characters (or ranges of characters)
1854 to values. Char tables are specialized for characters, only allowing
1855 particular sorts of ranges to be assigned values. Although this
1856 loses in generality, it makes for extremely fast (constant-time)
1857 lookups, and thus is feasible for applications that do an extremely
1858 large number of lookups (e.g. scanning a buffer for a character in
1859 a particular syntax, where a lookup in the syntax table must occur
1860 once per character).
1862 When Mule support exists, the types of ranges that can be assigned
1866 -- an entire charset
1867 -- a single row in a two-octet charset
1868 -- a single character
1870 When Mule support is not present, the types of ranges that can be
1874 -- a single character
1876 To create a char table, use `make-char-table'.
1877 To modify a char table, use `put-char-table' or `remove-char-table'.
1878 To retrieve the value for a particular character, use `get-char-table'.
1879 See also `map-char-table', `clear-char-table', `copy-char-table',
1880 `valid-char-table-type-p', `char-table-type-list',
1881 `valid-char-table-value-p', and `check-char-table-value'.
1885 return CHAR_TABLEP (object) ? Qt : Qnil;
1888 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1889 Return a list of the recognized char table types.
1890 See `valid-char-table-type-p'.
1895 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1897 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1901 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1902 Return t if TYPE if a recognized char table type.
1904 Each char table type is used for a different purpose and allows different
1905 sorts of values. The different char table types are
1908 Used for category tables, which specify the regexp categories
1909 that a character is in. The valid values are nil or a
1910 bit vector of 95 elements. Higher-level Lisp functions are
1911 provided for working with category tables. Currently categories
1912 and category tables only exist when Mule support is present.
1914 A generalized char table, for mapping from one character to
1915 another. Used for case tables, syntax matching tables,
1916 `keyboard-translate-table', etc. The valid values are characters.
1918 An even more generalized char table, for mapping from a
1919 character to anything.
1921 Used for display tables, which specify how a particular character
1922 is to appear when displayed. #### Not yet implemented.
1924 Used for syntax tables, which specify the syntax of a particular
1925 character. Higher-level Lisp functions are provided for
1926 working with syntax tables. The valid values are integers.
1931 return (EQ (type, Qchar) ||
1933 EQ (type, Qcategory) ||
1935 EQ (type, Qdisplay) ||
1936 EQ (type, Qgeneric) ||
1937 EQ (type, Qsyntax)) ? Qt : Qnil;
1940 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1941 Return the type of CHAR-TABLE.
1942 See `valid-char-table-type-p'.
1946 CHECK_CHAR_TABLE (char_table);
1947 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1951 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1955 for (i = 0; i < NUM_ASCII_CHARS; i++)
1956 ct->ascii[i] = value;
1958 for (i = 0; i < NUM_LEADING_BYTES; i++)
1959 ct->level1[i] = value;
1962 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1963 update_syntax_table (ct);
1966 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1967 Reset CHAR-TABLE to its default state.
1971 Lisp_Char_Table *ct;
1973 CHECK_CHAR_TABLE (char_table);
1974 ct = XCHAR_TABLE (char_table);
1978 case CHAR_TABLE_TYPE_CHAR:
1979 fill_char_table (ct, make_char (0));
1981 case CHAR_TABLE_TYPE_DISPLAY:
1982 case CHAR_TABLE_TYPE_GENERIC:
1984 case CHAR_TABLE_TYPE_CATEGORY:
1986 fill_char_table (ct, Qnil);
1989 case CHAR_TABLE_TYPE_SYNTAX:
1990 fill_char_table (ct, make_int (Sinherit));
2000 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
2001 Return a new, empty char table of type TYPE.
2002 Currently recognized types are 'char, 'category, 'display, 'generic,
2003 and 'syntax. See `valid-char-table-type-p'.
2007 Lisp_Char_Table *ct;
2009 enum char_table_type ty = symbol_to_char_table_type (type);
2011 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
2013 if (ty == CHAR_TABLE_TYPE_SYNTAX)
2015 ct->mirror_table = Fmake_char_table (Qgeneric);
2016 fill_char_table (XCHAR_TABLE (ct->mirror_table),
2020 ct->mirror_table = Qnil;
2021 ct->next_table = Qnil;
2022 XSETCHAR_TABLE (obj, ct);
2023 if (ty == CHAR_TABLE_TYPE_SYNTAX)
2025 ct->next_table = Vall_syntax_tables;
2026 Vall_syntax_tables = obj;
2028 Freset_char_table (obj);
2035 make_char_table_entry (Lisp_Object initval)
2039 Lisp_Char_Table_Entry *cte =
2040 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
2042 for (i = 0; i < 96; i++)
2043 cte->level2[i] = initval;
2045 XSETCHAR_TABLE_ENTRY (obj, cte);
2050 copy_char_table_entry (Lisp_Object entry)
2052 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
2055 Lisp_Char_Table_Entry *ctenew =
2056 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
2058 for (i = 0; i < 96; i++)
2060 Lisp_Object new = cte->level2[i];
2061 if (CHAR_TABLE_ENTRYP (new))
2062 ctenew->level2[i] = copy_char_table_entry (new);
2064 ctenew->level2[i] = new;
2067 XSETCHAR_TABLE_ENTRY (obj, ctenew);
2073 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
2074 Return a new char table which is a copy of CHAR-TABLE.
2075 It will contain the same values for the same characters and ranges
2076 as CHAR-TABLE. The values will not themselves be copied.
2080 Lisp_Char_Table *ct, *ctnew;
2084 CHECK_CHAR_TABLE (char_table);
2085 ct = XCHAR_TABLE (char_table);
2086 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
2087 ctnew->type = ct->type;
2089 for (i = 0; i < NUM_ASCII_CHARS; i++)
2091 Lisp_Object new = ct->ascii[i];
2093 assert (! (CHAR_TABLE_ENTRYP (new)));
2095 ctnew->ascii[i] = new;
2100 for (i = 0; i < NUM_LEADING_BYTES; i++)
2102 Lisp_Object new = ct->level1[i];
2103 if (CHAR_TABLE_ENTRYP (new))
2104 ctnew->level1[i] = copy_char_table_entry (new);
2106 ctnew->level1[i] = new;
2111 if (CHAR_TABLEP (ct->mirror_table))
2112 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
2114 ctnew->mirror_table = ct->mirror_table;
2115 ctnew->next_table = Qnil;
2116 XSETCHAR_TABLE (obj, ctnew);
2117 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
2119 ctnew->next_table = Vall_syntax_tables;
2120 Vall_syntax_tables = obj;
2126 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
2129 outrange->type = CHARTAB_RANGE_ALL;
2130 else if (CHAR_OR_CHAR_INTP (range))
2132 outrange->type = CHARTAB_RANGE_CHAR;
2133 outrange->ch = XCHAR_OR_CHAR_INT (range);
2137 signal_simple_error ("Range must be t or a character", range);
2139 else if (VECTORP (range))
2141 Lisp_Vector *vec = XVECTOR (range);
2142 Lisp_Object *elts = vector_data (vec);
2143 if (vector_length (vec) != 2)
2144 signal_simple_error ("Length of charset row vector must be 2",
2146 outrange->type = CHARTAB_RANGE_ROW;
2147 outrange->charset = Fget_charset (elts[0]);
2148 CHECK_INT (elts[1]);
2149 outrange->row = XINT (elts[1]);
2150 if (XCHARSET_DIMENSION (outrange->charset) >= 2)
2152 switch (XCHARSET_CHARS (outrange->charset))
2155 check_int_range (outrange->row, 33, 126);
2158 check_int_range (outrange->row, 32, 127);
2165 signal_simple_error ("Charset in row vector must be multi-byte",
2170 if (!CHARSETP (range) && !SYMBOLP (range))
2172 ("Char table range must be t, charset, char, or vector", range);
2173 outrange->type = CHARTAB_RANGE_CHARSET;
2174 outrange->charset = Fget_charset (range);
2181 /* called from CHAR_TABLE_VALUE(). */
2183 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2188 Lisp_Object charset;
2190 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2195 BREAKUP_CHAR (c, charset, byte1, byte2);
2197 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2199 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2200 if (CHAR_TABLE_ENTRYP (val))
2202 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2203 val = cte->level2[byte1 - 32];
2204 if (CHAR_TABLE_ENTRYP (val))
2206 cte = XCHAR_TABLE_ENTRY (val);
2207 assert (byte2 >= 32);
2208 val = cte->level2[byte2 - 32];
2209 assert (!CHAR_TABLE_ENTRYP (val));
2219 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2223 Lisp_Object charset;
2227 BREAKUP_CHAR (ch, charset, byte1, byte2);
2229 if (EQ (charset, Vcharset_ascii))
2230 val = ct->ascii[byte1];
2231 else if (EQ (charset, Vcharset_control_1))
2232 val = ct->ascii[byte1 + 128];
2235 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2236 val = ct->level1[lb];
2237 if (CHAR_TABLE_ENTRYP (val))
2239 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2240 val = cte->level2[byte1 - 32];
2241 if (CHAR_TABLE_ENTRYP (val))
2243 cte = XCHAR_TABLE_ENTRY (val);
2244 assert (byte2 >= 32);
2245 val = cte->level2[byte2 - 32];
2246 assert (!CHAR_TABLE_ENTRYP (val));
2253 #else /* not MULE */
2254 return ct->ascii[(unsigned char)ch];
2255 #endif /* not MULE */
2259 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2260 Find value for CHARACTER in CHAR-TABLE.
2262 (character, char_table))
2264 CHECK_CHAR_TABLE (char_table);
2265 CHECK_CHAR_COERCE_INT (character);
2267 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2270 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2271 Find value for a range in CHAR-TABLE.
2272 If there is more than one value, return MULTI (defaults to nil).
2274 (range, char_table, multi))
2276 Lisp_Char_Table *ct;
2277 struct chartab_range rainj;
2279 if (CHAR_OR_CHAR_INTP (range))
2280 return Fget_char_table (range, char_table);
2281 CHECK_CHAR_TABLE (char_table);
2282 ct = XCHAR_TABLE (char_table);
2284 decode_char_table_range (range, &rainj);
2287 case CHARTAB_RANGE_ALL:
2290 Lisp_Object first = ct->ascii[0];
2292 for (i = 1; i < NUM_ASCII_CHARS; i++)
2293 if (!EQ (first, ct->ascii[i]))
2297 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2300 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2301 || i == LEADING_BYTE_ASCII
2302 || i == LEADING_BYTE_CONTROL_1)
2304 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2313 case CHARTAB_RANGE_CHARSET:
2314 if (EQ (rainj.charset, Vcharset_ascii))
2317 Lisp_Object first = ct->ascii[0];
2319 for (i = 1; i < 128; i++)
2320 if (!EQ (first, ct->ascii[i]))
2325 if (EQ (rainj.charset, Vcharset_control_1))
2328 Lisp_Object first = ct->ascii[128];
2330 for (i = 129; i < 160; i++)
2331 if (!EQ (first, ct->ascii[i]))
2337 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2339 if (CHAR_TABLE_ENTRYP (val))
2344 case CHARTAB_RANGE_ROW:
2346 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2348 if (!CHAR_TABLE_ENTRYP (val))
2350 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2351 if (CHAR_TABLE_ENTRYP (val))
2355 #endif /* not MULE */
2361 return Qnil; /* not reached */
2365 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2366 Error_behavior errb)
2370 case CHAR_TABLE_TYPE_SYNTAX:
2371 if (!ERRB_EQ (errb, ERROR_ME))
2372 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2373 && CHAR_OR_CHAR_INTP (XCDR (value)));
2376 Lisp_Object cdr = XCDR (value);
2377 CHECK_INT (XCAR (value));
2378 CHECK_CHAR_COERCE_INT (cdr);
2385 case CHAR_TABLE_TYPE_CATEGORY:
2386 if (!ERRB_EQ (errb, ERROR_ME))
2387 return CATEGORY_TABLE_VALUEP (value);
2388 CHECK_CATEGORY_TABLE_VALUE (value);
2392 case CHAR_TABLE_TYPE_GENERIC:
2395 case CHAR_TABLE_TYPE_DISPLAY:
2397 maybe_signal_simple_error ("Display char tables not yet implemented",
2398 value, Qchar_table, errb);
2401 case CHAR_TABLE_TYPE_CHAR:
2402 if (!ERRB_EQ (errb, ERROR_ME))
2403 return CHAR_OR_CHAR_INTP (value);
2404 CHECK_CHAR_COERCE_INT (value);
2411 return 0; /* not reached */
2415 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2419 case CHAR_TABLE_TYPE_SYNTAX:
2422 Lisp_Object car = XCAR (value);
2423 Lisp_Object cdr = XCDR (value);
2424 CHECK_CHAR_COERCE_INT (cdr);
2425 return Fcons (car, cdr);
2428 case CHAR_TABLE_TYPE_CHAR:
2429 CHECK_CHAR_COERCE_INT (value);
2437 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2438 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2440 (value, char_table_type))
2442 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2444 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2447 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2448 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2450 (value, char_table_type))
2452 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2454 check_valid_char_table_value (value, type, ERROR_ME);
2458 /* Assign VAL to all characters in RANGE in char table CT. */
2461 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2464 switch (range->type)
2466 case CHARTAB_RANGE_ALL:
2467 fill_char_table (ct, val);
2468 return; /* avoid the duplicate call to update_syntax_table() below,
2469 since fill_char_table() also did that. */
2472 case CHARTAB_RANGE_CHARSET:
2473 if (EQ (range->charset, Vcharset_ascii))
2476 for (i = 0; i < 128; i++)
2479 else if (EQ (range->charset, Vcharset_control_1))
2482 for (i = 128; i < 160; i++)
2487 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2488 ct->level1[lb] = val;
2492 case CHARTAB_RANGE_ROW:
2494 Lisp_Char_Table_Entry *cte;
2495 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2496 /* make sure that there is a separate entry for the row. */
2497 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2498 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2499 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2500 cte->level2[range->row - 32] = val;
2505 case CHARTAB_RANGE_CHAR:
2508 Lisp_Object charset;
2511 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2512 if (EQ (charset, Vcharset_ascii))
2513 ct->ascii[byte1] = val;
2514 else if (EQ (charset, Vcharset_control_1))
2515 ct->ascii[byte1 + 128] = val;
2518 Lisp_Char_Table_Entry *cte;
2519 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2520 /* make sure that there is a separate entry for the row. */
2521 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2522 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2523 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2524 /* now CTE is a char table entry for the charset;
2525 each entry is for a single row (or character of
2526 a one-octet charset). */
2527 if (XCHARSET_DIMENSION (charset) == 1)
2528 cte->level2[byte1 - 32] = val;
2531 /* assigning to one character in a two-octet charset. */
2532 /* make sure that the charset row contains a separate
2533 entry for each character. */
2534 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2535 cte->level2[byte1 - 32] =
2536 make_char_table_entry (cte->level2[byte1 - 32]);
2537 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2538 cte->level2[byte2 - 32] = val;
2542 #else /* not MULE */
2543 ct->ascii[(unsigned char) (range->ch)] = val;
2545 #endif /* not MULE */
2548 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2549 update_syntax_table (ct);
2552 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2553 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2555 RANGE specifies one or more characters to be affected and should be
2556 one of the following:
2558 -- t (all characters are affected)
2559 -- A charset (only allowed when Mule support is present)
2560 -- A vector of two elements: a two-octet charset and a row number
2561 (only allowed when Mule support is present)
2562 -- A single character
2564 VALUE must be a value appropriate for the type of CHAR-TABLE.
2565 See `valid-char-table-type-p'.
2567 (range, value, char_table))
2569 Lisp_Char_Table *ct;
2570 struct chartab_range rainj;
2572 CHECK_CHAR_TABLE (char_table);
2573 ct = XCHAR_TABLE (char_table);
2574 check_valid_char_table_value (value, ct->type, ERROR_ME);
2575 decode_char_table_range (range, &rainj);
2576 value = canonicalize_char_table_value (value, ct->type);
2577 put_char_table (ct, &rainj, value);
2581 /* Map FN over the ASCII chars in CT. */
2584 map_over_charset_ascii (Lisp_Char_Table *ct,
2585 int (*fn) (struct chartab_range *range,
2586 Lisp_Object val, void *arg),
2589 struct chartab_range rainj;
2598 rainj.type = CHARTAB_RANGE_CHAR;
2600 for (i = start, retval = 0; i < stop && retval == 0; i++)
2602 rainj.ch = (Emchar) i;
2603 retval = (fn) (&rainj, ct->ascii[i], arg);
2611 /* Map FN over the Control-1 chars in CT. */
2614 map_over_charset_control_1 (Lisp_Char_Table *ct,
2615 int (*fn) (struct chartab_range *range,
2616 Lisp_Object val, void *arg),
2619 struct chartab_range rainj;
2622 int stop = start + 32;
2624 rainj.type = CHARTAB_RANGE_CHAR;
2626 for (i = start, retval = 0; i < stop && retval == 0; i++)
2628 rainj.ch = (Emchar) (i);
2629 retval = (fn) (&rainj, ct->ascii[i], arg);
2635 /* Map FN over the row ROW of two-byte charset CHARSET.
2636 There must be a separate value for that row in the char table.
2637 CTE specifies the char table entry for CHARSET. */
2640 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2641 Lisp_Object charset, int row,
2642 int (*fn) (struct chartab_range *range,
2643 Lisp_Object val, void *arg),
2646 Lisp_Object val = cte->level2[row - 32];
2648 if (!CHAR_TABLE_ENTRYP (val))
2650 struct chartab_range rainj;
2652 rainj.type = CHARTAB_RANGE_ROW;
2653 rainj.charset = charset;
2655 return (fn) (&rainj, val, arg);
2659 struct chartab_range rainj;
2661 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2662 int start = charset94_p ? 33 : 32;
2663 int stop = charset94_p ? 127 : 128;
2665 cte = XCHAR_TABLE_ENTRY (val);
2667 rainj.type = CHARTAB_RANGE_CHAR;
2669 for (i = start, retval = 0; i < stop && retval == 0; i++)
2671 rainj.ch = MAKE_CHAR (charset, row, i);
2672 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2680 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2681 int (*fn) (struct chartab_range *range,
2682 Lisp_Object val, void *arg),
2685 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2686 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2688 if (!CHARSETP (charset)
2689 || lb == LEADING_BYTE_ASCII
2690 || lb == LEADING_BYTE_CONTROL_1)
2693 if (!CHAR_TABLE_ENTRYP (val))
2695 struct chartab_range rainj;
2697 rainj.type = CHARTAB_RANGE_CHARSET;
2698 rainj.charset = charset;
2699 return (fn) (&rainj, val, arg);
2703 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2704 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2705 int start = charset94_p ? 33 : 32;
2706 int stop = charset94_p ? 127 : 128;
2709 if (XCHARSET_DIMENSION (charset) == 1)
2711 struct chartab_range rainj;
2712 rainj.type = CHARTAB_RANGE_CHAR;
2714 for (i = start, retval = 0; i < stop && retval == 0; i++)
2716 rainj.ch = MAKE_CHAR (charset, i, 0);
2717 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2722 for (i = start, retval = 0; i < stop && retval == 0; i++)
2723 retval = map_over_charset_row (cte, charset, i, fn, arg);
2732 /* Map FN (with client data ARG) over range RANGE in char table CT.
2733 Mapping stops the first time FN returns non-zero, and that value
2734 becomes the return value of map_char_table(). */
2737 map_char_table (Lisp_Char_Table *ct,
2738 struct chartab_range *range,
2739 int (*fn) (struct chartab_range *range,
2740 Lisp_Object val, void *arg),
2743 switch (range->type)
2745 case CHARTAB_RANGE_ALL:
2749 retval = map_over_charset_ascii (ct, fn, arg);
2753 retval = map_over_charset_control_1 (ct, fn, arg);
2758 Charset_ID start = MIN_LEADING_BYTE;
2759 Charset_ID stop = start + NUM_LEADING_BYTES;
2761 for (i = start, retval = 0; i < stop && retval == 0; i++)
2763 retval = map_over_other_charset (ct, i, fn, arg);
2771 case CHARTAB_RANGE_CHARSET:
2772 return map_over_other_charset (ct,
2773 XCHARSET_LEADING_BYTE (range->charset),
2776 case CHARTAB_RANGE_ROW:
2778 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2779 - MIN_LEADING_BYTE];
2780 if (!CHAR_TABLE_ENTRYP (val))
2782 struct chartab_range rainj;
2784 rainj.type = CHARTAB_RANGE_ROW;
2785 rainj.charset = range->charset;
2786 rainj.row = range->row;
2787 return (fn) (&rainj, val, arg);
2790 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2791 range->charset, range->row,
2796 case CHARTAB_RANGE_CHAR:
2798 Emchar ch = range->ch;
2799 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2800 struct chartab_range rainj;
2802 rainj.type = CHARTAB_RANGE_CHAR;
2804 return (fn) (&rainj, val, arg);
2814 struct slow_map_char_table_arg
2816 Lisp_Object function;
2821 slow_map_char_table_fun (struct chartab_range *range,
2822 Lisp_Object val, void *arg)
2824 Lisp_Object ranjarg = Qnil;
2825 struct slow_map_char_table_arg *closure =
2826 (struct slow_map_char_table_arg *) arg;
2828 switch (range->type)
2830 case CHARTAB_RANGE_ALL:
2835 case CHARTAB_RANGE_CHARSET:
2836 ranjarg = XCHARSET_NAME (range->charset);
2839 case CHARTAB_RANGE_ROW:
2840 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2841 make_int (range->row));
2844 case CHARTAB_RANGE_CHAR:
2845 ranjarg = make_char (range->ch);
2851 closure->retval = call2 (closure->function, ranjarg, val);
2852 return !NILP (closure->retval);
2855 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2856 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2857 each key and value in the table.
2859 RANGE specifies a subrange to map over and is in the same format as
2860 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2863 (function, char_table, range))
2865 Lisp_Char_Table *ct;
2866 struct slow_map_char_table_arg slarg;
2867 struct gcpro gcpro1, gcpro2;
2868 struct chartab_range rainj;
2870 CHECK_CHAR_TABLE (char_table);
2871 ct = XCHAR_TABLE (char_table);
2874 decode_char_table_range (range, &rainj);
2875 slarg.function = function;
2876 slarg.retval = Qnil;
2877 GCPRO2 (slarg.function, slarg.retval);
2878 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2881 return slarg.retval;
2886 /************************************************************************/
2887 /* Char table read syntax */
2888 /************************************************************************/
2891 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
2892 Error_behavior errb)
2894 /* #### should deal with ERRB */
2895 symbol_to_char_table_type (value);
2900 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
2901 Error_behavior errb)
2905 /* #### should deal with ERRB */
2906 EXTERNAL_LIST_LOOP (rest, value)
2908 Lisp_Object range = XCAR (rest);
2909 struct chartab_range dummy;
2913 signal_simple_error ("Invalid list format", value);
2916 if (!CONSP (XCDR (range))
2917 || !NILP (XCDR (XCDR (range))))
2918 signal_simple_error ("Invalid range format", range);
2919 decode_char_table_range (XCAR (range), &dummy);
2920 decode_char_table_range (XCAR (XCDR (range)), &dummy);
2923 decode_char_table_range (range, &dummy);
2930 chartab_instantiate (Lisp_Object data)
2932 Lisp_Object chartab;
2933 Lisp_Object type = Qgeneric;
2934 Lisp_Object dataval = Qnil;
2936 while (!NILP (data))
2938 Lisp_Object keyw = Fcar (data);
2944 if (EQ (keyw, Qtype))
2946 else if (EQ (keyw, Qdata))
2950 chartab = Fmake_char_table (type);
2953 while (!NILP (data))
2955 Lisp_Object range = Fcar (data);
2956 Lisp_Object val = Fcar (Fcdr (data));
2958 data = Fcdr (Fcdr (data));
2961 if (CHAR_OR_CHAR_INTP (XCAR (range)))
2963 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
2964 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
2967 for (i = first; i <= last; i++)
2968 Fput_char_table (make_char (i), val, chartab);
2974 Fput_char_table (range, val, chartab);
2983 /************************************************************************/
2984 /* Category Tables, specifically */
2985 /************************************************************************/
2987 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
2988 Return t if OBJECT is a category table.
2989 A category table is a type of char table used for keeping track of
2990 categories. Categories are used for classifying characters for use
2991 in regexps -- you can refer to a category rather than having to use
2992 a complicated [] expression (and category lookups are significantly
2995 There are 95 different categories available, one for each printable
2996 character (including space) in the ASCII charset. Each category
2997 is designated by one such character, called a "category designator".
2998 They are specified in a regexp using the syntax "\\cX", where X is
2999 a category designator.
3001 A category table specifies, for each character, the categories that
3002 the character is in. Note that a character can be in more than one
3003 category. More specifically, a category table maps from a character
3004 to either the value nil (meaning the character is in no categories)
3005 or a 95-element bit vector, specifying for each of the 95 categories
3006 whether the character is in that category.
3008 Special Lisp functions are provided that abstract this, so you do not
3009 have to directly manipulate bit vectors.
3013 return (CHAR_TABLEP (object) &&
3014 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3019 check_category_table (Lisp_Object object, Lisp_Object default_)
3023 while (NILP (Fcategory_table_p (object)))
3024 object = wrong_type_argument (Qcategory_table_p, object);
3029 check_category_char (Emchar ch, Lisp_Object table,
3030 unsigned int designator, unsigned int not)
3032 REGISTER Lisp_Object temp;
3033 Lisp_Char_Table *ctbl;
3034 #ifdef ERROR_CHECK_TYPECHECK
3035 if (NILP (Fcategory_table_p (table)))
3036 signal_simple_error ("Expected category table", table);
3038 ctbl = XCHAR_TABLE (table);
3039 temp = get_char_table (ch, ctbl);
3044 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
3047 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3048 Return t if category of the character at POSITION includes DESIGNATOR.
3049 Optional third arg BUFFER specifies which buffer to use, and defaults
3050 to the current buffer.
3051 Optional fourth arg CATEGORY-TABLE specifies the category table to
3052 use, and defaults to BUFFER's category table.
3054 (position, designator, buffer, category_table))
3059 struct buffer *buf = decode_buffer (buffer, 0);
3061 CHECK_INT (position);
3062 CHECK_CATEGORY_DESIGNATOR (designator);
3063 des = XCHAR (designator);
3064 ctbl = check_category_table (category_table, Vstandard_category_table);
3065 ch = BUF_FETCH_CHAR (buf, XINT (position));
3066 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3069 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3070 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3071 Optional third arg CATEGORY-TABLE specifies the category table to use,
3072 and defaults to the standard category table.
3074 (character, designator, category_table))
3080 CHECK_CATEGORY_DESIGNATOR (designator);
3081 des = XCHAR (designator);
3082 CHECK_CHAR (character);
3083 ch = XCHAR (character);
3084 ctbl = check_category_table (category_table, Vstandard_category_table);
3085 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3088 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3089 Return BUFFER's current category table.
3090 BUFFER defaults to the current buffer.
3094 return decode_buffer (buffer, 0)->category_table;
3097 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3098 Return the standard category table.
3099 This is the one used for new buffers.
3103 return Vstandard_category_table;
3106 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3107 Return a new category table which is a copy of CATEGORY-TABLE.
3108 CATEGORY-TABLE defaults to the standard category table.
3112 if (NILP (Vstandard_category_table))
3113 return Fmake_char_table (Qcategory);
3116 check_category_table (category_table, Vstandard_category_table);
3117 return Fcopy_char_table (category_table);
3120 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3121 Select CATEGORY-TABLE as the new category table for BUFFER.
3122 BUFFER defaults to the current buffer if omitted.
3124 (category_table, buffer))
3126 struct buffer *buf = decode_buffer (buffer, 0);
3127 category_table = check_category_table (category_table, Qnil);
3128 buf->category_table = category_table;
3129 /* Indicate that this buffer now has a specified category table. */
3130 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3131 return category_table;
3134 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3135 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3139 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3142 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3143 Return t if OBJECT is a category table value.
3144 Valid values are nil or a bit vector of size 95.
3148 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3152 #define CATEGORYP(x) \
3153 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3155 #define CATEGORY_SET(c) \
3156 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3158 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3159 The faster version of `!NILP (Faref (category_set, category))'. */
3160 #define CATEGORY_MEMBER(category, category_set) \
3161 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3163 /* Return 1 if there is a word boundary between two word-constituent
3164 characters C1 and C2 if they appear in this order, else return 0.
3165 Use the macro WORD_BOUNDARY_P instead of calling this function
3168 int word_boundary_p (Emchar c1, Emchar c2);
3170 word_boundary_p (Emchar c1, Emchar c2)
3172 Lisp_Object category_set1, category_set2;
3177 if (COMPOSITE_CHAR_P (c1))
3178 c1 = cmpchar_component (c1, 0, 1);
3179 if (COMPOSITE_CHAR_P (c2))
3180 c2 = cmpchar_component (c2, 0, 1);
3183 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3185 tail = Vword_separating_categories;
3190 tail = Vword_combining_categories;
3194 category_set1 = CATEGORY_SET (c1);
3195 if (NILP (category_set1))
3196 return default_result;
3197 category_set2 = CATEGORY_SET (c2);
3198 if (NILP (category_set2))
3199 return default_result;
3201 for (; CONSP (tail); tail = XCONS (tail)->cdr)
3203 Lisp_Object elt = XCONS(tail)->car;
3206 && CATEGORYP (XCONS (elt)->car)
3207 && CATEGORYP (XCONS (elt)->cdr)
3208 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3209 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3210 return !default_result;
3212 return default_result;
3218 syms_of_chartab (void)
3221 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3222 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3223 INIT_LRECORD_IMPLEMENTATION (byte_table);
3224 INIT_LRECORD_IMPLEMENTATION (char_id_table);
3226 defsymbol (&Qto_ucs, "=>ucs");
3227 defsymbol (&Q_ucs, "->ucs");
3228 defsymbol (&Q_decomposition, "->decomposition");
3229 defsymbol (&Qcompat, "compat");
3230 defsymbol (&Qisolated, "isolated");
3231 defsymbol (&Qinitial, "initial");
3232 defsymbol (&Qmedial, "medial");
3233 defsymbol (&Qfinal, "final");
3234 defsymbol (&Qvertical, "vertical");
3235 defsymbol (&QnoBreak, "noBreak");
3236 defsymbol (&Qfraction, "fraction");
3237 defsymbol (&Qsuper, "super");
3238 defsymbol (&Qsub, "sub");
3239 defsymbol (&Qcircle, "circle");
3240 defsymbol (&Qsquare, "square");
3241 defsymbol (&Qwide, "wide");
3242 defsymbol (&Qnarrow, "narrow");
3243 defsymbol (&Qsmall, "small");
3244 defsymbol (&Qfont, "font");
3246 DEFSUBR (Fchar_attribute_list);
3247 DEFSUBR (Ffind_char_attribute_table);
3248 DEFSUBR (Fchar_attribute_alist);
3249 DEFSUBR (Fget_char_attribute);
3250 DEFSUBR (Fput_char_attribute);
3251 DEFSUBR (Fremove_char_attribute);
3252 DEFSUBR (Fmap_char_attribute);
3253 DEFSUBR (Fdefine_char);
3254 DEFSUBR (Ffind_char);
3255 DEFSUBR (Fchar_variants);
3257 DEFSUBR (Fget_composite_char);
3260 INIT_LRECORD_IMPLEMENTATION (char_table);
3263 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3265 defsymbol (&Qcategory_table_p, "category-table-p");
3266 defsymbol (&Qcategory_designator_p, "category-designator-p");
3267 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3270 defsymbol (&Qchar_table, "char-table");
3271 defsymbol (&Qchar_tablep, "char-table-p");
3273 DEFSUBR (Fchar_table_p);
3274 DEFSUBR (Fchar_table_type_list);
3275 DEFSUBR (Fvalid_char_table_type_p);
3276 DEFSUBR (Fchar_table_type);
3277 DEFSUBR (Freset_char_table);
3278 DEFSUBR (Fmake_char_table);
3279 DEFSUBR (Fcopy_char_table);
3280 DEFSUBR (Fget_char_table);
3281 DEFSUBR (Fget_range_char_table);
3282 DEFSUBR (Fvalid_char_table_value_p);
3283 DEFSUBR (Fcheck_valid_char_table_value);
3284 DEFSUBR (Fput_char_table);
3285 DEFSUBR (Fmap_char_table);
3288 DEFSUBR (Fcategory_table_p);
3289 DEFSUBR (Fcategory_table);
3290 DEFSUBR (Fstandard_category_table);
3291 DEFSUBR (Fcopy_category_table);
3292 DEFSUBR (Fset_category_table);
3293 DEFSUBR (Fcheck_category_at);
3294 DEFSUBR (Fchar_in_category_p);
3295 DEFSUBR (Fcategory_designator_p);
3296 DEFSUBR (Fcategory_table_value_p);
3302 vars_of_chartab (void)
3305 Vutf_2000_version = build_string("0.17 (Hōryūji)");
3306 DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3307 Version number of XEmacs UTF-2000.
3310 staticpro (&Vcharacter_composition_table);
3311 Vcharacter_composition_table = make_char_id_table (Qnil);
3313 staticpro (&Vcharacter_variant_table);
3314 Vcharacter_variant_table = make_char_id_table (Qnil);
3316 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
3317 Vall_syntax_tables = Qnil;
3318 dump_add_weak_object_chain (&Vall_syntax_tables);
3322 structure_type_create_chartab (void)
3324 struct structure_type *st;
3326 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3328 define_structure_type_keyword (st, Qtype, chartab_type_validate);
3329 define_structure_type_keyword (st, Qdata, chartab_data_validate);
3333 complex_vars_of_chartab (void)
3336 staticpro (&Vchar_attribute_hash_table);
3337 Vchar_attribute_hash_table
3338 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3339 #endif /* UTF2000 */
3341 /* Set this now, so first buffer creation can refer to it. */
3342 /* Make it nil before calling copy-category-table
3343 so that copy-category-table will know not to try to copy from garbage */
3344 Vstandard_category_table = Qnil;
3345 Vstandard_category_table = Fcopy_category_table (Qnil);
3346 staticpro (&Vstandard_category_table);
3348 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3349 List of pair (cons) of categories to determine word boundary.
3351 Emacs treats a sequence of word constituent characters as a single
3352 word (i.e. finds no word boundary between them) iff they belongs to
3353 the same charset. But, exceptions are allowed in the following cases.
3355 \(1) The case that characters are in different charsets is controlled
3356 by the variable `word-combining-categories'.
3358 Emacs finds no word boundary between characters of different charsets
3359 if they have categories matching some element of this list.
3361 More precisely, if an element of this list is a cons of category CAT1
3362 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3363 C2 which has CAT2, there's no word boundary between C1 and C2.
3365 For instance, to tell that ASCII characters and Latin-1 characters can
3366 form a single word, the element `(?l . ?l)' should be in this list
3367 because both characters have the category `l' (Latin characters).
3369 \(2) The case that character are in the same charset is controlled by
3370 the variable `word-separating-categories'.
3372 Emacs find a word boundary between characters of the same charset
3373 if they have categories matching some element of this list.
3375 More precisely, if an element of this list is a cons of category CAT1
3376 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3377 C2 which has CAT2, there's a word boundary between C1 and C2.
3379 For instance, to tell that there's a word boundary between Japanese
3380 Hiragana and Japanese Kanji (both are in the same charset), the
3381 element `(?H . ?C) should be in this list.
3384 Vword_combining_categories = Qnil;
3386 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3387 List of pair (cons) of categories to determine word boundary.
3388 See the documentation of the variable `word-combining-categories'.
3391 Vword_separating_categories = Qnil;