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.
7 Copyright (C) 1999,2000,2001,2002 MORIOKA Tomohiko
9 This file is part of XEmacs.
11 XEmacs is free software; you can redistribute it and/or modify it
12 under the terms of the GNU General Public License as published by the
13 Free Software Foundation; either version 2, or (at your option) any
16 XEmacs is distributed in the hope that it will be useful, but WITHOUT
17 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
18 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
21 You should have received a copy of the GNU General Public License
22 along with XEmacs; see the file COPYING. If not, write to
23 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 Boston, MA 02111-1307, USA. */
26 /* Synched up with: Mule 2.3. Not synched with FSF.
28 This file was written independently of the FSF implementation,
29 and is not compatible. */
33 Ben Wing: wrote, for 19.13 (Mule). Some category table stuff
34 loosely based on the original Mule.
35 Jareth Hein: fixed a couple of bugs in the implementation, and
36 added regex support for categories with check_category_at
49 Lisp_Object Qchar_tablep, Qchar_table;
51 Lisp_Object Vall_syntax_tables;
54 Lisp_Object Qcategory_table_p;
55 Lisp_Object Qcategory_designator_p;
56 Lisp_Object Qcategory_table_value_p;
58 Lisp_Object Vstandard_category_table;
60 /* Variables to determine word boundary. */
61 Lisp_Object Vword_combining_categories, Vword_separating_categories;
67 #if defined(HAVE_DATABASE)
68 EXFUN (Fload_char_attribute_table, 1);
69 EXFUN (Fmap_char_attribute, 3);
72 #define BT_UINT8_MIN 0
73 #define BT_UINT8_MAX (UCHAR_MAX - 4)
74 #define BT_UINT8_t (UCHAR_MAX - 3)
75 #define BT_UINT8_nil (UCHAR_MAX - 2)
76 #define BT_UINT8_unbound (UCHAR_MAX - 1)
77 #define BT_UINT8_unloaded UCHAR_MAX
79 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
80 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
81 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
82 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
83 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
86 INT_UINT8_P (Lisp_Object obj)
92 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
99 UINT8_VALUE_P (Lisp_Object obj)
101 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
102 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
105 INLINE_HEADER unsigned char
106 UINT8_ENCODE (Lisp_Object obj)
108 if (EQ (obj, Qunloaded))
109 return BT_UINT8_unloaded;
110 else if (EQ (obj, Qunbound))
111 return BT_UINT8_unbound;
112 else if (EQ (obj, Qnil))
114 else if (EQ (obj, Qt))
120 INLINE_HEADER Lisp_Object
121 UINT8_DECODE (unsigned char n)
123 if (n == BT_UINT8_unloaded)
125 else if (n == BT_UINT8_unbound)
127 else if (n == BT_UINT8_nil)
129 else if (n == BT_UINT8_t)
136 mark_uint8_byte_table (Lisp_Object obj)
142 print_uint8_byte_table (Lisp_Object obj,
143 Lisp_Object printcharfun, int escapeflag)
145 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
147 struct gcpro gcpro1, gcpro2;
148 GCPRO2 (obj, printcharfun);
150 write_c_string ("\n#<uint8-byte-table", printcharfun);
151 for (i = 0; i < 256; i++)
153 unsigned char n = bte->property[i];
155 write_c_string ("\n ", printcharfun);
156 write_c_string (" ", printcharfun);
157 if (n == BT_UINT8_unbound)
158 write_c_string ("void", printcharfun);
159 else if (n == BT_UINT8_nil)
160 write_c_string ("nil", printcharfun);
161 else if (n == BT_UINT8_t)
162 write_c_string ("t", printcharfun);
167 sprintf (buf, "%hd", n);
168 write_c_string (buf, printcharfun);
172 write_c_string (">", printcharfun);
176 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
178 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
179 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
182 for (i = 0; i < 256; i++)
183 if (te1->property[i] != te2->property[i])
189 uint8_byte_table_hash (Lisp_Object obj, int depth)
191 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
195 for (i = 0; i < 256; i++)
196 hash = HASH2 (hash, te->property[i]);
200 static const struct lrecord_description uint8_byte_table_description[] = {
204 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
205 mark_uint8_byte_table,
206 print_uint8_byte_table,
207 0, uint8_byte_table_equal,
208 uint8_byte_table_hash,
209 uint8_byte_table_description,
210 Lisp_Uint8_Byte_Table);
213 make_uint8_byte_table (unsigned char initval)
217 Lisp_Uint8_Byte_Table *cte;
219 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
220 &lrecord_uint8_byte_table);
222 for (i = 0; i < 256; i++)
223 cte->property[i] = initval;
225 XSETUINT8_BYTE_TABLE (obj, cte);
230 copy_uint8_byte_table (Lisp_Object entry)
232 Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
235 Lisp_Uint8_Byte_Table *ctenew
236 = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
237 &lrecord_uint8_byte_table);
239 for (i = 0; i < 256; i++)
241 ctenew->property[i] = cte->property[i];
244 XSETUINT8_BYTE_TABLE (obj, ctenew);
249 uint8_byte_table_same_value_p (Lisp_Object obj)
251 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
252 unsigned char v0 = bte->property[0];
255 for (i = 1; i < 256; i++)
257 if (bte->property[i] != v0)
264 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
265 Emchar ofs, int place,
266 int (*fn) (struct chartab_range *range,
267 Lisp_Object val, void *arg),
270 struct chartab_range rainj;
272 int unit = 1 << (8 * place);
276 rainj.type = CHARTAB_RANGE_CHAR;
278 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
280 if (ct->property[i] == BT_UINT8_unloaded)
284 for (; c < c1 && retval == 0; c++)
286 Lisp_Object ret = get_char_id_table (root, c);
291 retval = (fn) (&rainj, ret, arg);
295 ct->property[i] = BT_UINT8_unbound;
299 else if (ct->property[i] != BT_UINT8_unbound)
302 for (; c < c1 && retval == 0; c++)
305 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
316 save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
318 Emchar ofs, int place)
320 struct chartab_range rainj;
322 int unit = 1 << (8 * place);
326 rainj.type = CHARTAB_RANGE_CHAR;
328 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
330 if (ct->property[i] == BT_UINT8_unloaded)
334 else if (ct->property[i] != BT_UINT8_unbound)
337 for (; c < c1 && retval == 0; c++)
339 Fput_database (Fprin1_to_string (make_char (c), Qnil),
340 Fprin1_to_string (UINT8_DECODE (ct->property[i]),
343 put_char_id_table (root, make_char (c), Qunloaded);
352 #define BT_UINT16_MIN 0
353 #define BT_UINT16_MAX (USHRT_MAX - 4)
354 #define BT_UINT16_t (USHRT_MAX - 3)
355 #define BT_UINT16_nil (USHRT_MAX - 2)
356 #define BT_UINT16_unbound (USHRT_MAX - 1)
357 #define BT_UINT16_unloaded USHRT_MAX
359 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
360 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
361 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
362 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
365 INT_UINT16_P (Lisp_Object obj)
369 int num = XINT (obj);
371 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
378 UINT16_VALUE_P (Lisp_Object obj)
380 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
381 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
384 INLINE_HEADER unsigned short
385 UINT16_ENCODE (Lisp_Object obj)
387 if (EQ (obj, Qunloaded))
388 return BT_UINT16_unloaded;
389 else if (EQ (obj, Qunbound))
390 return BT_UINT16_unbound;
391 else if (EQ (obj, Qnil))
392 return BT_UINT16_nil;
393 else if (EQ (obj, Qt))
399 INLINE_HEADER Lisp_Object
400 UINT16_DECODE (unsigned short n)
402 if (n == BT_UINT16_unloaded)
404 else if (n == BT_UINT16_unbound)
406 else if (n == BT_UINT16_nil)
408 else if (n == BT_UINT16_t)
414 INLINE_HEADER unsigned short
415 UINT8_TO_UINT16 (unsigned char n)
417 if (n == BT_UINT8_unloaded)
418 return BT_UINT16_unloaded;
419 else if (n == BT_UINT8_unbound)
420 return BT_UINT16_unbound;
421 else if (n == BT_UINT8_nil)
422 return BT_UINT16_nil;
423 else if (n == BT_UINT8_t)
430 mark_uint16_byte_table (Lisp_Object obj)
436 print_uint16_byte_table (Lisp_Object obj,
437 Lisp_Object printcharfun, int escapeflag)
439 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
441 struct gcpro gcpro1, gcpro2;
442 GCPRO2 (obj, printcharfun);
444 write_c_string ("\n#<uint16-byte-table", printcharfun);
445 for (i = 0; i < 256; i++)
447 unsigned short n = bte->property[i];
449 write_c_string ("\n ", printcharfun);
450 write_c_string (" ", printcharfun);
451 if (n == BT_UINT16_unbound)
452 write_c_string ("void", printcharfun);
453 else if (n == BT_UINT16_nil)
454 write_c_string ("nil", printcharfun);
455 else if (n == BT_UINT16_t)
456 write_c_string ("t", printcharfun);
461 sprintf (buf, "%hd", n);
462 write_c_string (buf, printcharfun);
466 write_c_string (">", printcharfun);
470 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
472 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
473 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
476 for (i = 0; i < 256; i++)
477 if (te1->property[i] != te2->property[i])
483 uint16_byte_table_hash (Lisp_Object obj, int depth)
485 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
489 for (i = 0; i < 256; i++)
490 hash = HASH2 (hash, te->property[i]);
494 static const struct lrecord_description uint16_byte_table_description[] = {
498 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
499 mark_uint16_byte_table,
500 print_uint16_byte_table,
501 0, uint16_byte_table_equal,
502 uint16_byte_table_hash,
503 uint16_byte_table_description,
504 Lisp_Uint16_Byte_Table);
507 make_uint16_byte_table (unsigned short initval)
511 Lisp_Uint16_Byte_Table *cte;
513 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
514 &lrecord_uint16_byte_table);
516 for (i = 0; i < 256; i++)
517 cte->property[i] = initval;
519 XSETUINT16_BYTE_TABLE (obj, cte);
524 copy_uint16_byte_table (Lisp_Object entry)
526 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
529 Lisp_Uint16_Byte_Table *ctenew
530 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
531 &lrecord_uint16_byte_table);
533 for (i = 0; i < 256; i++)
535 ctenew->property[i] = cte->property[i];
538 XSETUINT16_BYTE_TABLE (obj, ctenew);
543 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
547 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
548 Lisp_Uint16_Byte_Table* cte;
550 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
551 &lrecord_uint16_byte_table);
552 for (i = 0; i < 256; i++)
554 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
556 XSETUINT16_BYTE_TABLE (obj, cte);
561 uint16_byte_table_same_value_p (Lisp_Object obj)
563 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
564 unsigned short v0 = bte->property[0];
567 for (i = 1; i < 256; i++)
569 if (bte->property[i] != v0)
576 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
577 Emchar ofs, int place,
578 int (*fn) (struct chartab_range *range,
579 Lisp_Object val, void *arg),
582 struct chartab_range rainj;
584 int unit = 1 << (8 * place);
588 rainj.type = CHARTAB_RANGE_CHAR;
590 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
592 if (ct->property[i] == BT_UINT16_unloaded)
596 for (; c < c1 && retval == 0; c++)
598 Lisp_Object ret = get_char_id_table (root, c);
603 retval = (fn) (&rainj, ret, arg);
607 ct->property[i] = BT_UINT16_unbound;
611 else if (ct->property[i] != BT_UINT16_unbound)
614 for (; c < c1 && retval == 0; c++)
617 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
628 save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
630 Emchar ofs, int place)
632 struct chartab_range rainj;
634 int unit = 1 << (8 * place);
638 rainj.type = CHARTAB_RANGE_CHAR;
640 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
642 if (ct->property[i] == BT_UINT16_unloaded)
646 else if (ct->property[i] != BT_UINT16_unbound)
649 for (; c < c1 && retval == 0; c++)
651 Fput_database (Fprin1_to_string (make_char (c), Qnil),
652 Fprin1_to_string (UINT16_DECODE (ct->property[i]),
655 put_char_id_table (root, make_char (c), Qunloaded);
666 mark_byte_table (Lisp_Object obj)
668 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
671 for (i = 0; i < 256; i++)
673 mark_object (cte->property[i]);
679 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
681 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
683 struct gcpro gcpro1, gcpro2;
684 GCPRO2 (obj, printcharfun);
686 write_c_string ("\n#<byte-table", printcharfun);
687 for (i = 0; i < 256; i++)
689 Lisp_Object elt = bte->property[i];
691 write_c_string ("\n ", printcharfun);
692 write_c_string (" ", printcharfun);
693 if (EQ (elt, Qunbound))
694 write_c_string ("void", printcharfun);
696 print_internal (elt, printcharfun, escapeflag);
699 write_c_string (">", printcharfun);
703 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
705 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
706 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
709 for (i = 0; i < 256; i++)
710 if (BYTE_TABLE_P (cte1->property[i]))
712 if (BYTE_TABLE_P (cte2->property[i]))
714 if (!byte_table_equal (cte1->property[i],
715 cte2->property[i], depth + 1))
722 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
728 byte_table_hash (Lisp_Object obj, int depth)
730 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
732 return internal_array_hash (cte->property, 256, depth);
735 static const struct lrecord_description byte_table_description[] = {
736 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
740 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
745 byte_table_description,
749 make_byte_table (Lisp_Object initval)
753 Lisp_Byte_Table *cte;
755 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
757 for (i = 0; i < 256; i++)
758 cte->property[i] = initval;
760 XSETBYTE_TABLE (obj, cte);
765 copy_byte_table (Lisp_Object entry)
767 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
770 Lisp_Byte_Table *ctnew
771 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
773 for (i = 0; i < 256; i++)
775 if (UINT8_BYTE_TABLE_P (cte->property[i]))
777 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
779 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
781 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
783 else if (BYTE_TABLE_P (cte->property[i]))
785 ctnew->property[i] = copy_byte_table (cte->property[i]);
788 ctnew->property[i] = cte->property[i];
791 XSETBYTE_TABLE (obj, ctnew);
796 byte_table_same_value_p (Lisp_Object obj)
798 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
799 Lisp_Object v0 = bte->property[0];
802 for (i = 1; i < 256; i++)
804 if (!internal_equal (bte->property[i], v0, 0))
811 map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
812 Emchar ofs, int place,
813 int (*fn) (struct chartab_range *range,
814 Lisp_Object val, void *arg),
819 int unit = 1 << (8 * place);
822 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
825 if (UINT8_BYTE_TABLE_P (v))
828 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
829 c, place - 1, fn, arg);
832 else if (UINT16_BYTE_TABLE_P (v))
835 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
836 c, place - 1, fn, arg);
839 else if (BYTE_TABLE_P (v))
841 retval = map_over_byte_table (XBYTE_TABLE(v), root,
842 c, place - 1, fn, arg);
845 else if (EQ (v, Qunloaded))
848 struct chartab_range rainj;
849 Emchar c1 = c + unit;
851 rainj.type = CHARTAB_RANGE_CHAR;
853 for (; c < c1 && retval == 0; c++)
855 Lisp_Object ret = get_char_id_table (root, c);
860 retval = (fn) (&rainj, ret, arg);
864 ct->property[i] = Qunbound;
868 else if (!UNBOUNDP (v))
870 struct chartab_range rainj;
871 Emchar c1 = c + unit;
873 rainj.type = CHARTAB_RANGE_CHAR;
875 for (; c < c1 && retval == 0; c++)
878 retval = (fn) (&rainj, v, arg);
889 save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
891 Emchar ofs, int place)
895 int unit = 1 << (8 * place);
898 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
901 if (UINT8_BYTE_TABLE_P (v))
903 save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db,
907 else if (UINT16_BYTE_TABLE_P (v))
909 save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db,
913 else if (BYTE_TABLE_P (v))
915 save_byte_table (XBYTE_TABLE(v), root, db,
919 else if (EQ (v, Qunloaded))
923 else if (!UNBOUNDP (v))
925 struct chartab_range rainj;
926 Emchar c1 = c + unit;
928 rainj.type = CHARTAB_RANGE_CHAR;
930 for (; c < c1 && retval == 0; c++)
932 Fput_database (Fprin1_to_string (make_char (c), Qnil),
933 Fprin1_to_string (v, Qnil),
935 put_char_id_table (root, make_char (c), Qunloaded);
945 get_byte_table (Lisp_Object table, unsigned char idx)
947 if (UINT8_BYTE_TABLE_P (table))
948 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
949 else if (UINT16_BYTE_TABLE_P (table))
950 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
951 else if (BYTE_TABLE_P (table))
952 return XBYTE_TABLE(table)->property[idx];
958 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
960 if (UINT8_BYTE_TABLE_P (table))
962 if (UINT8_VALUE_P (value))
964 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
965 if (!UINT8_BYTE_TABLE_P (value) &&
966 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
967 && uint8_byte_table_same_value_p (table))
972 else if (UINT16_VALUE_P (value))
974 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
976 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
981 Lisp_Object new = make_byte_table (Qnil);
984 for (i = 0; i < 256; i++)
986 XBYTE_TABLE(new)->property[i]
987 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
989 XBYTE_TABLE(new)->property[idx] = value;
993 else if (UINT16_BYTE_TABLE_P (table))
995 if (UINT16_VALUE_P (value))
997 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
998 if (!UINT8_BYTE_TABLE_P (value) &&
999 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1000 && uint16_byte_table_same_value_p (table))
1007 Lisp_Object new = make_byte_table (Qnil);
1010 for (i = 0; i < 256; i++)
1012 XBYTE_TABLE(new)->property[i]
1013 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
1015 XBYTE_TABLE(new)->property[idx] = value;
1019 else if (BYTE_TABLE_P (table))
1021 XBYTE_TABLE(table)->property[idx] = value;
1022 if (!UINT8_BYTE_TABLE_P (value) &&
1023 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1024 && byte_table_same_value_p (table))
1029 else if (!internal_equal (table, value, 0))
1031 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
1033 table = make_uint8_byte_table (UINT8_ENCODE (table));
1034 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
1036 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
1038 table = make_uint16_byte_table (UINT16_ENCODE (table));
1039 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1043 table = make_byte_table (table);
1044 XBYTE_TABLE(table)->property[idx] = value;
1052 make_char_id_table (Lisp_Object initval)
1055 obj = Fmake_char_table (Qgeneric);
1056 fill_char_table (XCHAR_TABLE (obj), initval);
1061 Lisp_Object Vcharacter_composition_table;
1062 Lisp_Object Vcharacter_variant_table;
1065 Lisp_Object Qsystem_char_id;
1067 Lisp_Object Q_decomposition;
1068 Lisp_Object Qto_ucs;
1070 Lisp_Object Q_ucs_variants;
1071 Lisp_Object Qcompat;
1072 Lisp_Object Qisolated;
1073 Lisp_Object Qinitial;
1074 Lisp_Object Qmedial;
1076 Lisp_Object Qvertical;
1077 Lisp_Object QnoBreak;
1078 Lisp_Object Qfraction;
1081 Lisp_Object Qcircle;
1082 Lisp_Object Qsquare;
1084 Lisp_Object Qnarrow;
1088 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1091 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1097 else if (EQ (v, Qcompat))
1099 else if (EQ (v, Qisolated))
1101 else if (EQ (v, Qinitial))
1103 else if (EQ (v, Qmedial))
1105 else if (EQ (v, Qfinal))
1107 else if (EQ (v, Qvertical))
1109 else if (EQ (v, QnoBreak))
1111 else if (EQ (v, Qfraction))
1113 else if (EQ (v, Qsuper))
1115 else if (EQ (v, Qsub))
1117 else if (EQ (v, Qcircle))
1119 else if (EQ (v, Qsquare))
1121 else if (EQ (v, Qwide))
1123 else if (EQ (v, Qnarrow))
1125 else if (EQ (v, Qsmall))
1127 else if (EQ (v, Qfont))
1130 signal_simple_error (err_msg, err_arg);
1133 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1134 Return character corresponding with list.
1138 Lisp_Object table = Vcharacter_composition_table;
1139 Lisp_Object rest = list;
1141 while (CONSP (rest))
1143 Lisp_Object v = Fcar (rest);
1145 Emchar c = to_char_id (v, "Invalid value for composition", list);
1147 ret = get_char_id_table (XCHAR_TABLE(table), c);
1152 if (!CHAR_TABLEP (ret))
1157 else if (!CONSP (rest))
1159 else if (CHAR_TABLEP (ret))
1162 signal_simple_error ("Invalid table is found with", list);
1164 signal_simple_error ("Invalid value for composition", list);
1167 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1168 Return variants of CHARACTER.
1174 CHECK_CHAR (character);
1175 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
1178 return Fcopy_list (ret);
1186 /* A char table maps from ranges of characters to values.
1188 Implementing a general data structure that maps from arbitrary
1189 ranges of numbers to values is tricky to do efficiently. As it
1190 happens, it should suffice (and is usually more convenient, anyway)
1191 when dealing with characters to restrict the sorts of ranges that
1192 can be assigned values, as follows:
1195 2) All characters in a charset.
1196 3) All characters in a particular row of a charset, where a "row"
1197 means all characters with the same first byte.
1198 4) A particular character in a charset.
1200 We use char tables to generalize the 256-element vectors now
1201 littering the Emacs code.
1203 Possible uses (all should be converted at some point):
1209 5) keyboard-translate-table?
1212 abstract type to generalize the Emacs vectors and Mule
1213 vectors-of-vectors goo.
1216 /************************************************************************/
1217 /* Char Table object */
1218 /************************************************************************/
1220 #if defined(MULE)&&!defined(UTF2000)
1223 mark_char_table_entry (Lisp_Object obj)
1225 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1228 for (i = 0; i < 96; i++)
1230 mark_object (cte->level2[i]);
1236 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1238 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1239 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1242 for (i = 0; i < 96; i++)
1243 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1249 static unsigned long
1250 char_table_entry_hash (Lisp_Object obj, int depth)
1252 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1254 return internal_array_hash (cte->level2, 96, depth);
1257 static const struct lrecord_description char_table_entry_description[] = {
1258 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1262 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1263 mark_char_table_entry, internal_object_printer,
1264 0, char_table_entry_equal,
1265 char_table_entry_hash,
1266 char_table_entry_description,
1267 Lisp_Char_Table_Entry);
1271 mark_char_table (Lisp_Object obj)
1273 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1276 mark_object (ct->table);
1277 mark_object (ct->name);
1278 mark_object (ct->db_file);
1279 mark_object (ct->db);
1283 for (i = 0; i < NUM_ASCII_CHARS; i++)
1284 mark_object (ct->ascii[i]);
1286 for (i = 0; i < NUM_LEADING_BYTES; i++)
1287 mark_object (ct->level1[i]);
1291 return ct->default_value;
1293 return ct->mirror_table;
1297 /* WARNING: All functions of this nature need to be written extremely
1298 carefully to avoid crashes during GC. Cf. prune_specifiers()
1299 and prune_weak_hash_tables(). */
1302 prune_syntax_tables (void)
1304 Lisp_Object rest, prev = Qnil;
1306 for (rest = Vall_syntax_tables;
1308 rest = XCHAR_TABLE (rest)->next_table)
1310 if (! marked_p (rest))
1312 /* This table is garbage. Remove it from the list. */
1314 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1316 XCHAR_TABLE (prev)->next_table =
1317 XCHAR_TABLE (rest)->next_table;
1323 char_table_type_to_symbol (enum char_table_type type)
1328 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1329 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1330 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1331 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1333 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1338 static enum char_table_type
1339 symbol_to_char_table_type (Lisp_Object symbol)
1341 CHECK_SYMBOL (symbol);
1343 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1344 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1345 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1346 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1348 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1351 signal_simple_error ("Unrecognized char table type", symbol);
1352 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1356 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1357 Lisp_Object printcharfun)
1361 write_c_string (" (", printcharfun);
1362 print_internal (make_char (first), printcharfun, 0);
1363 write_c_string (" ", printcharfun);
1364 print_internal (make_char (last), printcharfun, 0);
1365 write_c_string (") ", printcharfun);
1369 write_c_string (" ", printcharfun);
1370 print_internal (make_char (first), printcharfun, 0);
1371 write_c_string (" ", printcharfun);
1373 print_internal (val, printcharfun, 1);
1376 #if defined(MULE)&&!defined(UTF2000)
1379 print_chartab_charset_row (Lisp_Object charset,
1381 Lisp_Char_Table_Entry *cte,
1382 Lisp_Object printcharfun)
1385 Lisp_Object cat = Qunbound;
1388 for (i = 32; i < 128; i++)
1390 Lisp_Object pam = cte->level2[i - 32];
1402 print_chartab_range (MAKE_CHAR (charset, first, 0),
1403 MAKE_CHAR (charset, i - 1, 0),
1406 print_chartab_range (MAKE_CHAR (charset, row, first),
1407 MAKE_CHAR (charset, row, i - 1),
1417 print_chartab_range (MAKE_CHAR (charset, first, 0),
1418 MAKE_CHAR (charset, i - 1, 0),
1421 print_chartab_range (MAKE_CHAR (charset, row, first),
1422 MAKE_CHAR (charset, row, i - 1),
1428 print_chartab_two_byte_charset (Lisp_Object charset,
1429 Lisp_Char_Table_Entry *cte,
1430 Lisp_Object printcharfun)
1434 for (i = 32; i < 128; i++)
1436 Lisp_Object jen = cte->level2[i - 32];
1438 if (!CHAR_TABLE_ENTRYP (jen))
1442 write_c_string (" [", printcharfun);
1443 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1444 sprintf (buf, " %d] ", i);
1445 write_c_string (buf, printcharfun);
1446 print_internal (jen, printcharfun, 0);
1449 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1457 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1459 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1462 struct gcpro gcpro1, gcpro2;
1463 GCPRO2 (obj, printcharfun);
1465 write_c_string ("#s(char-table ", printcharfun);
1466 write_c_string (" ", printcharfun);
1467 write_c_string (string_data
1469 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1471 write_c_string ("\n ", printcharfun);
1472 print_internal (ct->default_value, printcharfun, escapeflag);
1473 for (i = 0; i < 256; i++)
1475 Lisp_Object elt = get_byte_table (ct->table, i);
1476 if (i != 0) write_c_string ("\n ", printcharfun);
1477 if (EQ (elt, Qunbound))
1478 write_c_string ("void", printcharfun);
1480 print_internal (elt, printcharfun, escapeflag);
1483 #else /* non UTF2000 */
1486 sprintf (buf, "#s(char-table type %s data (",
1487 string_data (symbol_name (XSYMBOL
1488 (char_table_type_to_symbol (ct->type)))));
1489 write_c_string (buf, printcharfun);
1491 /* Now write out the ASCII/Control-1 stuff. */
1495 Lisp_Object val = Qunbound;
1497 for (i = 0; i < NUM_ASCII_CHARS; i++)
1506 if (!EQ (ct->ascii[i], val))
1508 print_chartab_range (first, i - 1, val, printcharfun);
1515 print_chartab_range (first, i - 1, val, printcharfun);
1522 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1525 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1526 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1528 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1529 || i == LEADING_BYTE_CONTROL_1)
1531 if (!CHAR_TABLE_ENTRYP (ann))
1533 write_c_string (" ", printcharfun);
1534 print_internal (XCHARSET_NAME (charset),
1536 write_c_string (" ", printcharfun);
1537 print_internal (ann, printcharfun, 0);
1541 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1542 if (XCHARSET_DIMENSION (charset) == 1)
1543 print_chartab_charset_row (charset, -1, cte, printcharfun);
1545 print_chartab_two_byte_charset (charset, cte, printcharfun);
1550 #endif /* non UTF2000 */
1552 write_c_string ("))", printcharfun);
1556 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1558 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1559 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1562 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1566 for (i = 0; i < 256; i++)
1568 if (!internal_equal (get_byte_table (ct1->table, i),
1569 get_byte_table (ct2->table, i), 0))
1573 for (i = 0; i < NUM_ASCII_CHARS; i++)
1574 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1578 for (i = 0; i < NUM_LEADING_BYTES; i++)
1579 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1582 #endif /* non UTF2000 */
1587 static unsigned long
1588 char_table_hash (Lisp_Object obj, int depth)
1590 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1592 return byte_table_hash (ct->table, depth + 1);
1594 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1597 hashval = HASH2 (hashval,
1598 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1604 static const struct lrecord_description char_table_description[] = {
1606 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1607 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1608 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1609 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db_file) },
1610 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1612 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1614 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1618 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1620 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1624 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1625 mark_char_table, print_char_table, 0,
1626 char_table_equal, char_table_hash,
1627 char_table_description,
1630 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1631 Return non-nil if OBJECT is a char table.
1633 A char table is a table that maps characters (or ranges of characters)
1634 to values. Char tables are specialized for characters, only allowing
1635 particular sorts of ranges to be assigned values. Although this
1636 loses in generality, it makes for extremely fast (constant-time)
1637 lookups, and thus is feasible for applications that do an extremely
1638 large number of lookups (e.g. scanning a buffer for a character in
1639 a particular syntax, where a lookup in the syntax table must occur
1640 once per character).
1642 When Mule support exists, the types of ranges that can be assigned
1646 -- an entire charset
1647 -- a single row in a two-octet charset
1648 -- a single character
1650 When Mule support is not present, the types of ranges that can be
1654 -- a single character
1656 To create a char table, use `make-char-table'.
1657 To modify a char table, use `put-char-table' or `remove-char-table'.
1658 To retrieve the value for a particular character, use `get-char-table'.
1659 See also `map-char-table', `clear-char-table', `copy-char-table',
1660 `valid-char-table-type-p', `char-table-type-list',
1661 `valid-char-table-value-p', and `check-char-table-value'.
1665 return CHAR_TABLEP (object) ? Qt : Qnil;
1668 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1669 Return a list of the recognized char table types.
1670 See `valid-char-table-type-p'.
1675 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1677 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1681 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1682 Return t if TYPE if a recognized char table type.
1684 Each char table type is used for a different purpose and allows different
1685 sorts of values. The different char table types are
1688 Used for category tables, which specify the regexp categories
1689 that a character is in. The valid values are nil or a
1690 bit vector of 95 elements. Higher-level Lisp functions are
1691 provided for working with category tables. Currently categories
1692 and category tables only exist when Mule support is present.
1694 A generalized char table, for mapping from one character to
1695 another. Used for case tables, syntax matching tables,
1696 `keyboard-translate-table', etc. The valid values are characters.
1698 An even more generalized char table, for mapping from a
1699 character to anything.
1701 Used for display tables, which specify how a particular character
1702 is to appear when displayed. #### Not yet implemented.
1704 Used for syntax tables, which specify the syntax of a particular
1705 character. Higher-level Lisp functions are provided for
1706 working with syntax tables. The valid values are integers.
1711 return (EQ (type, Qchar) ||
1713 EQ (type, Qcategory) ||
1715 EQ (type, Qdisplay) ||
1716 EQ (type, Qgeneric) ||
1717 EQ (type, Qsyntax)) ? Qt : Qnil;
1720 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1721 Return the type of CHAR-TABLE.
1722 See `valid-char-table-type-p'.
1726 CHECK_CHAR_TABLE (char_table);
1727 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1731 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1734 ct->table = Qunbound;
1735 ct->default_value = value;
1740 for (i = 0; i < NUM_ASCII_CHARS; i++)
1741 ct->ascii[i] = value;
1743 for (i = 0; i < NUM_LEADING_BYTES; i++)
1744 ct->level1[i] = value;
1749 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1750 update_syntax_table (ct);
1754 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1755 Reset CHAR-TABLE to its default state.
1759 Lisp_Char_Table *ct;
1761 CHECK_CHAR_TABLE (char_table);
1762 ct = XCHAR_TABLE (char_table);
1766 case CHAR_TABLE_TYPE_CHAR:
1767 fill_char_table (ct, make_char (0));
1769 case CHAR_TABLE_TYPE_DISPLAY:
1770 case CHAR_TABLE_TYPE_GENERIC:
1772 case CHAR_TABLE_TYPE_CATEGORY:
1774 fill_char_table (ct, Qnil);
1777 case CHAR_TABLE_TYPE_SYNTAX:
1778 fill_char_table (ct, make_int (Sinherit));
1788 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1789 Return a new, empty char table of type TYPE.
1790 Currently recognized types are 'char, 'category, 'display, 'generic,
1791 and 'syntax. See `valid-char-table-type-p'.
1795 Lisp_Char_Table *ct;
1797 enum char_table_type ty = symbol_to_char_table_type (type);
1799 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1802 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1804 ct->mirror_table = Fmake_char_table (Qgeneric);
1805 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1809 ct->mirror_table = Qnil;
1815 ct->next_table = Qnil;
1816 XSETCHAR_TABLE (obj, ct);
1817 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1819 ct->next_table = Vall_syntax_tables;
1820 Vall_syntax_tables = obj;
1822 Freset_char_table (obj);
1826 #if defined(MULE)&&!defined(UTF2000)
1829 make_char_table_entry (Lisp_Object initval)
1833 Lisp_Char_Table_Entry *cte =
1834 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1836 for (i = 0; i < 96; i++)
1837 cte->level2[i] = initval;
1839 XSETCHAR_TABLE_ENTRY (obj, cte);
1844 copy_char_table_entry (Lisp_Object entry)
1846 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1849 Lisp_Char_Table_Entry *ctenew =
1850 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1852 for (i = 0; i < 96; i++)
1854 Lisp_Object new = cte->level2[i];
1855 if (CHAR_TABLE_ENTRYP (new))
1856 ctenew->level2[i] = copy_char_table_entry (new);
1858 ctenew->level2[i] = new;
1861 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1867 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1868 Return a new char table which is a copy of CHAR-TABLE.
1869 It will contain the same values for the same characters and ranges
1870 as CHAR-TABLE. The values will not themselves be copied.
1874 Lisp_Char_Table *ct, *ctnew;
1880 CHECK_CHAR_TABLE (char_table);
1881 ct = XCHAR_TABLE (char_table);
1882 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1883 ctnew->type = ct->type;
1885 ctnew->default_value = ct->default_value;
1886 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1887 ctnew->name = ct->name;
1888 ctnew->db_file = ct->db_file;
1891 if (UINT8_BYTE_TABLE_P (ct->table))
1893 ctnew->table = copy_uint8_byte_table (ct->table);
1895 else if (UINT16_BYTE_TABLE_P (ct->table))
1897 ctnew->table = copy_uint16_byte_table (ct->table);
1899 else if (BYTE_TABLE_P (ct->table))
1901 ctnew->table = copy_byte_table (ct->table);
1903 else if (!UNBOUNDP (ct->table))
1904 ctnew->table = ct->table;
1905 #else /* non UTF2000 */
1907 for (i = 0; i < NUM_ASCII_CHARS; i++)
1909 Lisp_Object new = ct->ascii[i];
1911 assert (! (CHAR_TABLE_ENTRYP (new)));
1913 ctnew->ascii[i] = new;
1918 for (i = 0; i < NUM_LEADING_BYTES; i++)
1920 Lisp_Object new = ct->level1[i];
1921 if (CHAR_TABLE_ENTRYP (new))
1922 ctnew->level1[i] = copy_char_table_entry (new);
1924 ctnew->level1[i] = new;
1928 #endif /* non UTF2000 */
1931 if (CHAR_TABLEP (ct->mirror_table))
1932 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1934 ctnew->mirror_table = ct->mirror_table;
1936 ctnew->next_table = Qnil;
1937 XSETCHAR_TABLE (obj, ctnew);
1938 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1940 ctnew->next_table = Vall_syntax_tables;
1941 Vall_syntax_tables = obj;
1946 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1948 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1950 switch (XCHARSET_CHARS (ccs))
1953 return (33 << 8) | 126;
1955 return (32 << 8) | 127;
1958 return (0 << 8) | 127;
1960 return (0 << 8) | 255;
1972 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1975 outrange->type = CHARTAB_RANGE_ALL;
1976 else if (EQ (range, Qnil))
1977 outrange->type = CHARTAB_RANGE_DEFAULT;
1978 else if (CHAR_OR_CHAR_INTP (range))
1980 outrange->type = CHARTAB_RANGE_CHAR;
1981 outrange->ch = XCHAR_OR_CHAR_INT (range);
1985 signal_simple_error ("Range must be t or a character", range);
1987 else if (VECTORP (range))
1989 Lisp_Vector *vec = XVECTOR (range);
1990 Lisp_Object *elts = vector_data (vec);
1991 int cell_min, cell_max;
1993 outrange->type = CHARTAB_RANGE_ROW;
1994 outrange->charset = Fget_charset (elts[0]);
1995 CHECK_INT (elts[1]);
1996 outrange->row = XINT (elts[1]);
1997 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1998 signal_simple_error ("Charset in row vector must be multi-byte",
2002 int ret = XCHARSET_CELL_RANGE (outrange->charset);
2004 cell_min = ret >> 8;
2005 cell_max = ret & 0xFF;
2007 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2008 check_int_range (outrange->row, cell_min, cell_max);
2010 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2012 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2013 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2015 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2017 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2018 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2019 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2027 if (!CHARSETP (range) && !SYMBOLP (range))
2029 ("Char table range must be t, charset, char, or vector", range);
2030 outrange->type = CHARTAB_RANGE_CHARSET;
2031 outrange->charset = Fget_charset (range);
2036 #if defined(MULE)&&!defined(UTF2000)
2038 /* called from CHAR_TABLE_VALUE(). */
2040 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2045 Lisp_Object charset;
2047 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2052 BREAKUP_CHAR (c, charset, byte1, byte2);
2054 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2056 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2057 if (CHAR_TABLE_ENTRYP (val))
2059 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2060 val = cte->level2[byte1 - 32];
2061 if (CHAR_TABLE_ENTRYP (val))
2063 cte = XCHAR_TABLE_ENTRY (val);
2064 assert (byte2 >= 32);
2065 val = cte->level2[byte2 - 32];
2066 assert (!CHAR_TABLE_ENTRYP (val));
2076 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2079 return get_char_id_table (ct, ch);
2082 Lisp_Object charset;
2086 BREAKUP_CHAR (ch, charset, byte1, byte2);
2088 if (EQ (charset, Vcharset_ascii))
2089 val = ct->ascii[byte1];
2090 else if (EQ (charset, Vcharset_control_1))
2091 val = ct->ascii[byte1 + 128];
2094 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2095 val = ct->level1[lb];
2096 if (CHAR_TABLE_ENTRYP (val))
2098 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2099 val = cte->level2[byte1 - 32];
2100 if (CHAR_TABLE_ENTRYP (val))
2102 cte = XCHAR_TABLE_ENTRY (val);
2103 assert (byte2 >= 32);
2104 val = cte->level2[byte2 - 32];
2105 assert (!CHAR_TABLE_ENTRYP (val));
2112 #else /* not MULE */
2113 return ct->ascii[(unsigned char)ch];
2114 #endif /* not MULE */
2118 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2119 Find value for CHARACTER in CHAR-TABLE.
2121 (character, char_table))
2123 CHECK_CHAR_TABLE (char_table);
2124 CHECK_CHAR_COERCE_INT (character);
2126 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2129 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2130 Find value for a range in CHAR-TABLE.
2131 If there is more than one value, return MULTI (defaults to nil).
2133 (range, char_table, multi))
2135 Lisp_Char_Table *ct;
2136 struct chartab_range rainj;
2138 if (CHAR_OR_CHAR_INTP (range))
2139 return Fget_char_table (range, char_table);
2140 CHECK_CHAR_TABLE (char_table);
2141 ct = XCHAR_TABLE (char_table);
2143 decode_char_table_range (range, &rainj);
2146 case CHARTAB_RANGE_ALL:
2149 if (UINT8_BYTE_TABLE_P (ct->table))
2151 else if (UINT16_BYTE_TABLE_P (ct->table))
2153 else if (BYTE_TABLE_P (ct->table))
2157 #else /* non UTF2000 */
2159 Lisp_Object first = ct->ascii[0];
2161 for (i = 1; i < NUM_ASCII_CHARS; i++)
2162 if (!EQ (first, ct->ascii[i]))
2166 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2169 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2170 || i == LEADING_BYTE_ASCII
2171 || i == LEADING_BYTE_CONTROL_1)
2173 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2179 #endif /* non UTF2000 */
2183 case CHARTAB_RANGE_CHARSET:
2187 if (EQ (rainj.charset, Vcharset_ascii))
2190 Lisp_Object first = ct->ascii[0];
2192 for (i = 1; i < 128; i++)
2193 if (!EQ (first, ct->ascii[i]))
2198 if (EQ (rainj.charset, Vcharset_control_1))
2201 Lisp_Object first = ct->ascii[128];
2203 for (i = 129; i < 160; i++)
2204 if (!EQ (first, ct->ascii[i]))
2210 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2212 if (CHAR_TABLE_ENTRYP (val))
2218 case CHARTAB_RANGE_ROW:
2223 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2225 if (!CHAR_TABLE_ENTRYP (val))
2227 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2228 if (CHAR_TABLE_ENTRYP (val))
2232 #endif /* not UTF2000 */
2233 #endif /* not MULE */
2239 return Qnil; /* not reached */
2243 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2244 Error_behavior errb)
2248 case CHAR_TABLE_TYPE_SYNTAX:
2249 if (!ERRB_EQ (errb, ERROR_ME))
2250 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2251 && CHAR_OR_CHAR_INTP (XCDR (value)));
2254 Lisp_Object cdr = XCDR (value);
2255 CHECK_INT (XCAR (value));
2256 CHECK_CHAR_COERCE_INT (cdr);
2263 case CHAR_TABLE_TYPE_CATEGORY:
2264 if (!ERRB_EQ (errb, ERROR_ME))
2265 return CATEGORY_TABLE_VALUEP (value);
2266 CHECK_CATEGORY_TABLE_VALUE (value);
2270 case CHAR_TABLE_TYPE_GENERIC:
2273 case CHAR_TABLE_TYPE_DISPLAY:
2275 maybe_signal_simple_error ("Display char tables not yet implemented",
2276 value, Qchar_table, errb);
2279 case CHAR_TABLE_TYPE_CHAR:
2280 if (!ERRB_EQ (errb, ERROR_ME))
2281 return CHAR_OR_CHAR_INTP (value);
2282 CHECK_CHAR_COERCE_INT (value);
2289 return 0; /* not reached */
2293 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2297 case CHAR_TABLE_TYPE_SYNTAX:
2300 Lisp_Object car = XCAR (value);
2301 Lisp_Object cdr = XCDR (value);
2302 CHECK_CHAR_COERCE_INT (cdr);
2303 return Fcons (car, cdr);
2306 case CHAR_TABLE_TYPE_CHAR:
2307 CHECK_CHAR_COERCE_INT (value);
2315 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2316 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2318 (value, char_table_type))
2320 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2322 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2325 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2326 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2328 (value, char_table_type))
2330 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2332 check_valid_char_table_value (value, type, ERROR_ME);
2337 Lisp_Char_Table* char_attribute_table_to_put;
2338 Lisp_Object Qput_char_table_map_function;
2339 Lisp_Object value_to_put;
2341 DEFUN ("put-char-table-map-function",
2342 Fput_char_table_map_function, 2, 2, 0, /*
2343 For internal use. Don't use it.
2347 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2352 /* Assign VAL to all characters in RANGE in char table CT. */
2355 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2358 switch (range->type)
2360 case CHARTAB_RANGE_ALL:
2361 /* printf ("put-char-table: range = all\n"); */
2362 fill_char_table (ct, val);
2363 return; /* avoid the duplicate call to update_syntax_table() below,
2364 since fill_char_table() also did that. */
2367 case CHARTAB_RANGE_DEFAULT:
2368 ct->default_value = val;
2373 case CHARTAB_RANGE_CHARSET:
2377 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2379 /* printf ("put-char-table: range = charset: %d\n",
2380 XCHARSET_LEADING_BYTE (range->charset));
2382 if ( CHAR_TABLEP (encoding_table) )
2385 char_attribute_table_to_put = ct;
2387 Fmap_char_attribute (Qput_char_table_map_function,
2388 XCHAR_TABLE_NAME (encoding_table),
2391 for (c = 0; c < 1 << 24; c++)
2393 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2395 put_char_id_table_0 (ct, c, val);
2401 for (c = 0; c < 1 << 24; c++)
2403 if ( charset_code_point (range->charset, c) >= 0 )
2404 put_char_id_table_0 (ct, c, val);
2409 if (EQ (range->charset, Vcharset_ascii))
2412 for (i = 0; i < 128; i++)
2415 else if (EQ (range->charset, Vcharset_control_1))
2418 for (i = 128; i < 160; i++)
2423 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2424 ct->level1[lb] = val;
2429 case CHARTAB_RANGE_ROW:
2432 int cell_min, cell_max, i;
2434 i = XCHARSET_CELL_RANGE (range->charset);
2436 cell_max = i & 0xFF;
2437 for (i = cell_min; i <= cell_max; i++)
2439 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2441 if ( charset_code_point (range->charset, ch) >= 0 )
2442 put_char_id_table_0 (ct, ch, val);
2447 Lisp_Char_Table_Entry *cte;
2448 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2449 /* make sure that there is a separate entry for the row. */
2450 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2451 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2452 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2453 cte->level2[range->row - 32] = val;
2455 #endif /* not UTF2000 */
2459 case CHARTAB_RANGE_CHAR:
2461 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2462 put_char_id_table_0 (ct, range->ch, val);
2466 Lisp_Object charset;
2469 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2470 if (EQ (charset, Vcharset_ascii))
2471 ct->ascii[byte1] = val;
2472 else if (EQ (charset, Vcharset_control_1))
2473 ct->ascii[byte1 + 128] = val;
2476 Lisp_Char_Table_Entry *cte;
2477 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2478 /* make sure that there is a separate entry for the row. */
2479 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2480 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2481 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2482 /* now CTE is a char table entry for the charset;
2483 each entry is for a single row (or character of
2484 a one-octet charset). */
2485 if (XCHARSET_DIMENSION (charset) == 1)
2486 cte->level2[byte1 - 32] = val;
2489 /* assigning to one character in a two-octet charset. */
2490 /* make sure that the charset row contains a separate
2491 entry for each character. */
2492 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2493 cte->level2[byte1 - 32] =
2494 make_char_table_entry (cte->level2[byte1 - 32]);
2495 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2496 cte->level2[byte2 - 32] = val;
2500 #else /* not MULE */
2501 ct->ascii[(unsigned char) (range->ch)] = val;
2503 #endif /* not MULE */
2507 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2508 update_syntax_table (ct);
2512 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2513 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2515 RANGE specifies one or more characters to be affected and should be
2516 one of the following:
2518 -- t (all characters are affected)
2519 -- A charset (only allowed when Mule support is present)
2520 -- A vector of two elements: a two-octet charset and a row number
2521 (only allowed when Mule support is present)
2522 -- A single character
2524 VALUE must be a value appropriate for the type of CHAR-TABLE.
2525 See `valid-char-table-type-p'.
2527 (range, value, char_table))
2529 Lisp_Char_Table *ct;
2530 struct chartab_range rainj;
2532 CHECK_CHAR_TABLE (char_table);
2533 ct = XCHAR_TABLE (char_table);
2534 check_valid_char_table_value (value, ct->type, ERROR_ME);
2535 decode_char_table_range (range, &rainj);
2536 value = canonicalize_char_table_value (value, ct->type);
2537 put_char_table (ct, &rainj, value);
2542 /* Map FN over the ASCII chars in CT. */
2545 map_over_charset_ascii (Lisp_Char_Table *ct,
2546 int (*fn) (struct chartab_range *range,
2547 Lisp_Object val, void *arg),
2550 struct chartab_range rainj;
2559 rainj.type = CHARTAB_RANGE_CHAR;
2561 for (i = start, retval = 0; i < stop && retval == 0; i++)
2563 rainj.ch = (Emchar) i;
2564 retval = (fn) (&rainj, ct->ascii[i], arg);
2572 /* Map FN over the Control-1 chars in CT. */
2575 map_over_charset_control_1 (Lisp_Char_Table *ct,
2576 int (*fn) (struct chartab_range *range,
2577 Lisp_Object val, void *arg),
2580 struct chartab_range rainj;
2583 int stop = start + 32;
2585 rainj.type = CHARTAB_RANGE_CHAR;
2587 for (i = start, retval = 0; i < stop && retval == 0; i++)
2589 rainj.ch = (Emchar) (i);
2590 retval = (fn) (&rainj, ct->ascii[i], arg);
2596 /* Map FN over the row ROW of two-byte charset CHARSET.
2597 There must be a separate value for that row in the char table.
2598 CTE specifies the char table entry for CHARSET. */
2601 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2602 Lisp_Object charset, int row,
2603 int (*fn) (struct chartab_range *range,
2604 Lisp_Object val, void *arg),
2607 Lisp_Object val = cte->level2[row - 32];
2609 if (!CHAR_TABLE_ENTRYP (val))
2611 struct chartab_range rainj;
2613 rainj.type = CHARTAB_RANGE_ROW;
2614 rainj.charset = charset;
2616 return (fn) (&rainj, val, arg);
2620 struct chartab_range rainj;
2622 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2623 int start = charset94_p ? 33 : 32;
2624 int stop = charset94_p ? 127 : 128;
2626 cte = XCHAR_TABLE_ENTRY (val);
2628 rainj.type = CHARTAB_RANGE_CHAR;
2630 for (i = start, retval = 0; i < stop && retval == 0; i++)
2632 rainj.ch = MAKE_CHAR (charset, row, i);
2633 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2641 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2642 int (*fn) (struct chartab_range *range,
2643 Lisp_Object val, void *arg),
2646 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2647 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2649 if (!CHARSETP (charset)
2650 || lb == LEADING_BYTE_ASCII
2651 || lb == LEADING_BYTE_CONTROL_1)
2654 if (!CHAR_TABLE_ENTRYP (val))
2656 struct chartab_range rainj;
2658 rainj.type = CHARTAB_RANGE_CHARSET;
2659 rainj.charset = charset;
2660 return (fn) (&rainj, val, arg);
2664 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2665 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2666 int start = charset94_p ? 33 : 32;
2667 int stop = charset94_p ? 127 : 128;
2670 if (XCHARSET_DIMENSION (charset) == 1)
2672 struct chartab_range rainj;
2673 rainj.type = CHARTAB_RANGE_CHAR;
2675 for (i = start, retval = 0; i < stop && retval == 0; i++)
2677 rainj.ch = MAKE_CHAR (charset, i, 0);
2678 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2683 for (i = start, retval = 0; i < stop && retval == 0; i++)
2684 retval = map_over_charset_row (cte, charset, i, fn, arg);
2692 #endif /* not UTF2000 */
2695 struct map_char_table_for_charset_arg
2697 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2698 Lisp_Char_Table *ct;
2703 map_char_table_for_charset_fun (struct chartab_range *range,
2704 Lisp_Object val, void *arg)
2706 struct map_char_table_for_charset_arg *closure =
2707 (struct map_char_table_for_charset_arg *) arg;
2710 switch (range->type)
2712 case CHARTAB_RANGE_ALL:
2715 case CHARTAB_RANGE_DEFAULT:
2718 case CHARTAB_RANGE_CHARSET:
2721 case CHARTAB_RANGE_ROW:
2724 case CHARTAB_RANGE_CHAR:
2725 ret = get_char_table (range->ch, closure->ct);
2726 if (!UNBOUNDP (ret))
2727 return (closure->fn) (range, ret, closure->arg);
2739 /* Map FN (with client data ARG) over range RANGE in char table CT.
2740 Mapping stops the first time FN returns non-zero, and that value
2741 becomes the return value of map_char_table(). */
2744 map_char_table (Lisp_Char_Table *ct,
2745 struct chartab_range *range,
2746 int (*fn) (struct chartab_range *range,
2747 Lisp_Object val, void *arg),
2750 switch (range->type)
2752 case CHARTAB_RANGE_ALL:
2754 if (!UNBOUNDP (ct->default_value))
2756 struct chartab_range rainj;
2759 rainj.type = CHARTAB_RANGE_DEFAULT;
2760 retval = (fn) (&rainj, ct->default_value, arg);
2764 if (UINT8_BYTE_TABLE_P (ct->table))
2765 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2767 else if (UINT16_BYTE_TABLE_P (ct->table))
2768 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2770 else if (BYTE_TABLE_P (ct->table))
2771 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2773 else if (EQ (ct->table, Qunloaded))
2776 struct chartab_range rainj;
2779 Emchar c1 = c + unit;
2782 rainj.type = CHARTAB_RANGE_CHAR;
2784 for (retval = 0; c < c1 && retval == 0; c++)
2786 Lisp_Object ret = get_char_id_table (ct, c);
2788 if (!UNBOUNDP (ret))
2791 retval = (fn) (&rainj, ct->table, arg);
2796 ct->table = Qunbound;
2799 else if (!UNBOUNDP (ct->table))
2800 return (fn) (range, ct->table, arg);
2806 retval = map_over_charset_ascii (ct, fn, arg);
2810 retval = map_over_charset_control_1 (ct, fn, arg);
2815 Charset_ID start = MIN_LEADING_BYTE;
2816 Charset_ID stop = start + NUM_LEADING_BYTES;
2818 for (i = start, retval = 0; i < stop && retval == 0; i++)
2820 retval = map_over_other_charset (ct, i, fn, arg);
2829 case CHARTAB_RANGE_DEFAULT:
2830 if (!UNBOUNDP (ct->default_value))
2831 return (fn) (range, ct->default_value, arg);
2836 case CHARTAB_RANGE_CHARSET:
2839 Lisp_Object encoding_table
2840 = XCHARSET_ENCODING_TABLE (range->charset);
2842 if (!NILP (encoding_table))
2844 struct chartab_range rainj;
2845 struct map_char_table_for_charset_arg mcarg;
2847 #ifdef HAVE_DATABASE
2848 if (XCHAR_TABLE_UNLOADED(encoding_table))
2849 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2854 rainj.type = CHARTAB_RANGE_ALL;
2855 return map_char_table (XCHAR_TABLE(encoding_table),
2857 &map_char_table_for_charset_fun,
2863 return map_over_other_charset (ct,
2864 XCHARSET_LEADING_BYTE (range->charset),
2868 case CHARTAB_RANGE_ROW:
2871 int cell_min, cell_max, i;
2873 struct chartab_range rainj;
2875 i = XCHARSET_CELL_RANGE (range->charset);
2877 cell_max = i & 0xFF;
2878 rainj.type = CHARTAB_RANGE_CHAR;
2879 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2881 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2883 if ( charset_code_point (range->charset, ch) >= 0 )
2886 = get_byte_table (get_byte_table
2890 (unsigned char)(ch >> 24)),
2891 (unsigned char) (ch >> 16)),
2892 (unsigned char) (ch >> 8)),
2893 (unsigned char) ch);
2896 val = ct->default_value;
2898 retval = (fn) (&rainj, val, arg);
2905 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2906 - MIN_LEADING_BYTE];
2907 if (!CHAR_TABLE_ENTRYP (val))
2909 struct chartab_range rainj;
2911 rainj.type = CHARTAB_RANGE_ROW;
2912 rainj.charset = range->charset;
2913 rainj.row = range->row;
2914 return (fn) (&rainj, val, arg);
2917 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2918 range->charset, range->row,
2921 #endif /* not UTF2000 */
2924 case CHARTAB_RANGE_CHAR:
2926 Emchar ch = range->ch;
2927 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2929 if (!UNBOUNDP (val))
2931 struct chartab_range rainj;
2933 rainj.type = CHARTAB_RANGE_CHAR;
2935 return (fn) (&rainj, val, arg);
2947 struct slow_map_char_table_arg
2949 Lisp_Object function;
2954 slow_map_char_table_fun (struct chartab_range *range,
2955 Lisp_Object val, void *arg)
2957 Lisp_Object ranjarg = Qnil;
2958 struct slow_map_char_table_arg *closure =
2959 (struct slow_map_char_table_arg *) arg;
2961 switch (range->type)
2963 case CHARTAB_RANGE_ALL:
2968 case CHARTAB_RANGE_DEFAULT:
2974 case CHARTAB_RANGE_CHARSET:
2975 ranjarg = XCHARSET_NAME (range->charset);
2978 case CHARTAB_RANGE_ROW:
2979 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2980 make_int (range->row));
2983 case CHARTAB_RANGE_CHAR:
2984 ranjarg = make_char (range->ch);
2990 closure->retval = call2 (closure->function, ranjarg, val);
2991 return !NILP (closure->retval);
2994 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2995 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2996 each key and value in the table.
2998 RANGE specifies a subrange to map over and is in the same format as
2999 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3002 (function, char_table, range))
3004 Lisp_Char_Table *ct;
3005 struct slow_map_char_table_arg slarg;
3006 struct gcpro gcpro1, gcpro2;
3007 struct chartab_range rainj;
3009 CHECK_CHAR_TABLE (char_table);
3010 ct = XCHAR_TABLE (char_table);
3013 decode_char_table_range (range, &rainj);
3014 slarg.function = function;
3015 slarg.retval = Qnil;
3016 GCPRO2 (slarg.function, slarg.retval);
3017 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3020 return slarg.retval;
3024 /************************************************************************/
3025 /* Character Attributes */
3026 /************************************************************************/
3030 Lisp_Object Vchar_attribute_hash_table;
3032 /* We store the char-attributes in hash tables with the names as the
3033 key and the actual char-id-table object as the value. Occasionally
3034 we need to use them in a list format. These routines provide us
3036 struct char_attribute_list_closure
3038 Lisp_Object *char_attribute_list;
3042 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3043 void *char_attribute_list_closure)
3045 /* This function can GC */
3046 struct char_attribute_list_closure *calcl
3047 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3048 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3050 *char_attribute_list = Fcons (key, *char_attribute_list);
3054 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3055 Return the list of all existing character attributes except coded-charsets.
3059 Lisp_Object char_attribute_list = Qnil;
3060 struct gcpro gcpro1;
3061 struct char_attribute_list_closure char_attribute_list_closure;
3063 GCPRO1 (char_attribute_list);
3064 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3065 elisp_maphash (add_char_attribute_to_list_mapper,
3066 Vchar_attribute_hash_table,
3067 &char_attribute_list_closure);
3069 return char_attribute_list;
3072 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3073 Return char-id-table corresponding to ATTRIBUTE.
3077 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3081 /* We store the char-id-tables in hash tables with the attributes as
3082 the key and the actual char-id-table object as the value. Each
3083 char-id-table stores values of an attribute corresponding with
3084 characters. Occasionally we need to get attributes of a character
3085 in a association-list format. These routines provide us with
3087 struct char_attribute_alist_closure
3090 Lisp_Object *char_attribute_alist;
3094 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3095 void *char_attribute_alist_closure)
3097 /* This function can GC */
3098 struct char_attribute_alist_closure *caacl =
3099 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3101 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3102 if (!UNBOUNDP (ret))
3104 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3105 *char_attribute_alist
3106 = Fcons (Fcons (key, ret), *char_attribute_alist);
3111 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3112 Return the alist of attributes of CHARACTER.
3116 struct gcpro gcpro1;
3117 struct char_attribute_alist_closure char_attribute_alist_closure;
3118 Lisp_Object alist = Qnil;
3120 CHECK_CHAR (character);
3123 char_attribute_alist_closure.char_id = XCHAR (character);
3124 char_attribute_alist_closure.char_attribute_alist = &alist;
3125 elisp_maphash (add_char_attribute_alist_mapper,
3126 Vchar_attribute_hash_table,
3127 &char_attribute_alist_closure);
3133 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3134 Return the value of CHARACTER's ATTRIBUTE.
3135 Return DEFAULT-VALUE if the value is not exist.
3137 (character, attribute, default_value))
3141 CHECK_CHAR (character);
3143 if (CHARSETP (attribute))
3144 attribute = XCHARSET_NAME (attribute);
3146 table = Fgethash (attribute, Vchar_attribute_hash_table,
3148 if (!UNBOUNDP (table))
3150 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3152 if (!UNBOUNDP (ret))
3155 return default_value;
3158 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3159 Store CHARACTER's ATTRIBUTE with VALUE.
3161 (character, attribute, value))
3163 Lisp_Object ccs = Ffind_charset (attribute);
3167 CHECK_CHAR (character);
3168 value = put_char_ccs_code_point (character, ccs, value);
3170 else if (EQ (attribute, Q_decomposition))
3174 CHECK_CHAR (character);
3176 signal_simple_error ("Invalid value for ->decomposition",
3179 if (CONSP (Fcdr (value)))
3181 Lisp_Object rest = value;
3182 Lisp_Object table = Vcharacter_composition_table;
3186 GET_EXTERNAL_LIST_LENGTH (rest, len);
3187 seq = make_vector (len, Qnil);
3189 while (CONSP (rest))
3191 Lisp_Object v = Fcar (rest);
3194 = to_char_id (v, "Invalid value for ->decomposition", value);
3197 XVECTOR_DATA(seq)[i++] = v;
3199 XVECTOR_DATA(seq)[i++] = make_char (c);
3203 put_char_id_table (XCHAR_TABLE(table),
3204 make_char (c), character);
3209 ntable = get_char_id_table (XCHAR_TABLE(table), c);
3210 if (!CHAR_TABLEP (ntable))
3212 ntable = make_char_id_table (Qnil);
3213 put_char_id_table (XCHAR_TABLE(table),
3214 make_char (c), ntable);
3222 Lisp_Object v = Fcar (value);
3226 Emchar c = XINT (v);
3228 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3233 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3234 make_char (c), Fcons (character, Qnil));
3236 else if (NILP (Fmemq (v, ret)))
3238 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3239 make_char (c), Fcons (character, ret));
3242 seq = make_vector (1, v);
3246 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3251 CHECK_CHAR (character);
3253 signal_simple_error ("Invalid value for ->ucs", value);
3257 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
3260 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3261 make_char (c), Fcons (character, Qnil));
3263 else if (NILP (Fmemq (character, ret)))
3265 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3266 make_char (c), Fcons (character, ret));
3269 if (EQ (attribute, Q_ucs))
3270 attribute = Qto_ucs;
3274 Lisp_Object table = Fgethash (attribute,
3275 Vchar_attribute_hash_table,
3280 table = make_char_id_table (Qunbound);
3281 Fputhash (attribute, table, Vchar_attribute_hash_table);
3282 #ifdef HAVE_DATABASE
3283 XCHAR_TABLE_NAME (table) = attribute;
3286 put_char_id_table (XCHAR_TABLE(table), character, value);
3291 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3292 Remove CHARACTER's ATTRIBUTE.
3294 (character, attribute))
3298 CHECK_CHAR (character);
3299 ccs = Ffind_charset (attribute);
3302 return remove_char_ccs (character, ccs);
3306 Lisp_Object table = Fgethash (attribute,
3307 Vchar_attribute_hash_table,
3309 if (!UNBOUNDP (table))
3311 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3319 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3322 Lisp_Object db_dir = Vexec_directory;
3325 db_dir = build_string ("../lib-src");
3327 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3328 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3329 Fmake_directory_internal (db_dir);
3331 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3332 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3333 Fmake_directory_internal (db_dir);
3336 Lisp_Object attribute_name = Fsymbol_name (attribute);
3337 Lisp_Object dest = Qnil, ret;
3339 struct gcpro gcpro1, gcpro2;
3340 int len = XSTRING_CHAR_LENGTH (attribute_name);
3344 for (i = 0; i < len; i++)
3346 Emchar c = string_char (XSTRING (attribute_name), i);
3348 if ( (c == '/') || (c == '%') )
3352 sprintf (str, "%%%02X", c);
3353 dest = concat3 (dest,
3354 Fsubstring (attribute_name,
3355 make_int (base), make_int (i)),
3356 build_string (str));
3360 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3361 dest = concat2 (dest, ret);
3363 return Fexpand_file_name (dest, db_dir);
3366 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3370 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3371 Save values of ATTRIBUTE into database file.
3375 #ifdef HAVE_DATABASE
3376 Lisp_Object table = Fgethash (attribute,
3377 Vchar_attribute_hash_table, Qunbound);
3378 Lisp_Char_Table *ct;
3380 if (CHAR_TABLEP (table))
3381 ct = XCHAR_TABLE (table);
3385 if (NILP (Fdatabase_live_p (ct->db)))
3387 if (NILP (ct->db_file))
3389 = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3390 ct->db = Fopen_database (ct->db_file, Qnil, Qnil, Qnil, Qnil);
3394 if (UINT8_BYTE_TABLE_P (ct->table))
3395 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, ct->db, 0, 3);
3396 else if (UINT16_BYTE_TABLE_P (ct->table))
3397 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, ct->db, 0, 3);
3398 else if (BYTE_TABLE_P (ct->table))
3399 save_byte_table (XBYTE_TABLE(ct->table), ct, ct->db, 0, 3);
3400 Fclose_database (ct->db);
3411 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3412 Close database of ATTRIBUTE.
3416 #ifdef HAVE_DATABASE
3417 Lisp_Object table = Fgethash (attribute,
3418 Vchar_attribute_hash_table, Qunbound);
3419 Lisp_Char_Table *ct;
3421 if (CHAR_TABLEP (table))
3422 ct = XCHAR_TABLE (table);
3428 if (!NILP (Fdatabase_live_p (ct->db)))
3429 Fclose_database (ct->db);
3437 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3438 Reset values of ATTRIBUTE with database file.
3442 #ifdef HAVE_DATABASE
3443 Lisp_Object table = Fgethash (attribute,
3444 Vchar_attribute_hash_table, Qunbound);
3445 Lisp_Char_Table *ct;
3447 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3449 if (!NILP (Ffile_exists_p (db_file)))
3451 if (UNBOUNDP (table))
3453 table = make_char_id_table (Qunbound);
3454 Fputhash (attribute, table, Vchar_attribute_hash_table);
3455 XCHAR_TABLE_NAME(table) = attribute;
3457 ct = XCHAR_TABLE (table);
3458 ct->table = Qunloaded;
3459 ct->db_file = db_file;
3460 if (!NILP (Fdatabase_live_p (ct->db)))
3461 Fclose_database (ct->db);
3463 XCHAR_TABLE_UNLOADED(table) = 1;
3470 #ifdef HAVE_DATABASE
3472 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3474 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3476 if (!NILP (attribute))
3478 if (NILP (Fdatabase_live_p (cit->db)))
3480 if (NILP (cit->db_file))
3482 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3483 cit->db = Fopen_database (cit->db_file, Qnil, Qnil, Qnil, Qnil);
3484 cit->db_file = Qnil;
3486 if (!NILP (cit->db))
3489 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3491 if (!UNBOUNDP (val))
3501 Lisp_Char_Table* char_attribute_table_to_load;
3503 Lisp_Object Qload_char_attribute_table_map_function;
3505 DEFUN ("load-char-attribute-table-map-function",
3506 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3507 For internal use. Don't use it.
3511 Lisp_Object c = Fread (key);
3512 Emchar code = XCHAR (c);
3513 Lisp_Object ret = get_char_id_table (char_attribute_table_to_load, code);
3515 if (EQ (ret, Qunloaded))
3516 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3521 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3522 Load values of ATTRIBUTE into database file.
3526 #ifdef HAVE_DATABASE
3527 Lisp_Object table = Fgethash (attribute,
3528 Vchar_attribute_hash_table,
3530 if (CHAR_TABLEP (table))
3532 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3534 if (NILP (Fdatabase_live_p (ct->db)))
3536 if (NILP (ct->db_file))
3538 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3539 ct->db = Fopen_database (ct->db_file, Qnil, Qnil, Qnil, Qnil);
3544 struct gcpro gcpro1;
3546 char_attribute_table_to_load = XCHAR_TABLE (table);
3548 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3550 Fclose_database (ct->db);
3552 XCHAR_TABLE_UNLOADED(table) = 0;
3560 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3561 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3562 each key and value in the table.
3564 RANGE specifies a subrange to map over and is in the same format as
3565 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3568 (function, attribute, range))
3571 Lisp_Char_Table *ct;
3572 struct slow_map_char_table_arg slarg;
3573 struct gcpro gcpro1, gcpro2;
3574 struct chartab_range rainj;
3576 if (!NILP (ccs = Ffind_charset (attribute)))
3578 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3580 if (CHAR_TABLEP (encoding_table))
3581 ct = XCHAR_TABLE (encoding_table);
3587 Lisp_Object table = Fgethash (attribute,
3588 Vchar_attribute_hash_table,
3590 if (CHAR_TABLEP (table))
3591 ct = XCHAR_TABLE (table);
3597 decode_char_table_range (range, &rainj);
3598 #ifdef HAVE_DATABASE
3599 if (CHAR_TABLE_UNLOADED(ct))
3600 Fload_char_attribute_table (attribute);
3602 slarg.function = function;
3603 slarg.retval = Qnil;
3604 GCPRO2 (slarg.function, slarg.retval);
3605 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3608 return slarg.retval;
3611 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3612 Store character's ATTRIBUTES.
3616 Lisp_Object rest = attributes;
3617 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3618 Lisp_Object character;
3622 while (CONSP (rest))
3624 Lisp_Object cell = Fcar (rest);
3628 signal_simple_error ("Invalid argument", attributes);
3629 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3630 && ((XCHARSET_FINAL (ccs) != 0) ||
3631 (XCHARSET_MAX_CODE (ccs) > 0) ||
3632 (EQ (ccs, Vcharset_chinese_big5))) )
3636 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3638 character = Fdecode_char (ccs, cell, Qnil);
3639 if (!NILP (character))
3640 goto setup_attributes;
3644 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3645 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3649 signal_simple_error ("Invalid argument", attributes);
3651 character = make_char (XINT (code) + 0x100000);
3652 goto setup_attributes;
3656 else if (!INTP (code))
3657 signal_simple_error ("Invalid argument", attributes);
3659 character = make_char (XINT (code));
3663 while (CONSP (rest))
3665 Lisp_Object cell = Fcar (rest);
3668 signal_simple_error ("Invalid argument", attributes);
3670 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3676 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3677 Retrieve the character of the given ATTRIBUTES.
3681 Lisp_Object rest = attributes;
3684 while (CONSP (rest))
3686 Lisp_Object cell = Fcar (rest);
3690 signal_simple_error ("Invalid argument", attributes);
3691 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3695 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3697 return Fdecode_char (ccs, cell, Qnil);
3701 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3702 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3705 signal_simple_error ("Invalid argument", attributes);
3707 return make_char (XINT (code) + 0x100000);
3715 /************************************************************************/
3716 /* Char table read syntax */
3717 /************************************************************************/
3720 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3721 Error_behavior errb)
3723 /* #### should deal with ERRB */
3724 symbol_to_char_table_type (value);
3729 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3730 Error_behavior errb)
3734 /* #### should deal with ERRB */
3735 EXTERNAL_LIST_LOOP (rest, value)
3737 Lisp_Object range = XCAR (rest);
3738 struct chartab_range dummy;
3742 signal_simple_error ("Invalid list format", value);
3745 if (!CONSP (XCDR (range))
3746 || !NILP (XCDR (XCDR (range))))
3747 signal_simple_error ("Invalid range format", range);
3748 decode_char_table_range (XCAR (range), &dummy);
3749 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3752 decode_char_table_range (range, &dummy);
3759 chartab_instantiate (Lisp_Object data)
3761 Lisp_Object chartab;
3762 Lisp_Object type = Qgeneric;
3763 Lisp_Object dataval = Qnil;
3765 while (!NILP (data))
3767 Lisp_Object keyw = Fcar (data);
3773 if (EQ (keyw, Qtype))
3775 else if (EQ (keyw, Qdata))
3779 chartab = Fmake_char_table (type);
3782 while (!NILP (data))
3784 Lisp_Object range = Fcar (data);
3785 Lisp_Object val = Fcar (Fcdr (data));
3787 data = Fcdr (Fcdr (data));
3790 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3792 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3793 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3796 for (i = first; i <= last; i++)
3797 Fput_char_table (make_char (i), val, chartab);
3803 Fput_char_table (range, val, chartab);
3812 /************************************************************************/
3813 /* Category Tables, specifically */
3814 /************************************************************************/
3816 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3817 Return t if OBJECT is a category table.
3818 A category table is a type of char table used for keeping track of
3819 categories. Categories are used for classifying characters for use
3820 in regexps -- you can refer to a category rather than having to use
3821 a complicated [] expression (and category lookups are significantly
3824 There are 95 different categories available, one for each printable
3825 character (including space) in the ASCII charset. Each category
3826 is designated by one such character, called a "category designator".
3827 They are specified in a regexp using the syntax "\\cX", where X is
3828 a category designator.
3830 A category table specifies, for each character, the categories that
3831 the character is in. Note that a character can be in more than one
3832 category. More specifically, a category table maps from a character
3833 to either the value nil (meaning the character is in no categories)
3834 or a 95-element bit vector, specifying for each of the 95 categories
3835 whether the character is in that category.
3837 Special Lisp functions are provided that abstract this, so you do not
3838 have to directly manipulate bit vectors.
3842 return (CHAR_TABLEP (object) &&
3843 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3848 check_category_table (Lisp_Object object, Lisp_Object default_)
3852 while (NILP (Fcategory_table_p (object)))
3853 object = wrong_type_argument (Qcategory_table_p, object);
3858 check_category_char (Emchar ch, Lisp_Object table,
3859 unsigned int designator, unsigned int not_p)
3861 REGISTER Lisp_Object temp;
3862 Lisp_Char_Table *ctbl;
3863 #ifdef ERROR_CHECK_TYPECHECK
3864 if (NILP (Fcategory_table_p (table)))
3865 signal_simple_error ("Expected category table", table);
3867 ctbl = XCHAR_TABLE (table);
3868 temp = get_char_table (ch, ctbl);
3873 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3876 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3877 Return t if category of the character at POSITION includes DESIGNATOR.
3878 Optional third arg BUFFER specifies which buffer to use, and defaults
3879 to the current buffer.
3880 Optional fourth arg CATEGORY-TABLE specifies the category table to
3881 use, and defaults to BUFFER's category table.
3883 (position, designator, buffer, category_table))
3888 struct buffer *buf = decode_buffer (buffer, 0);
3890 CHECK_INT (position);
3891 CHECK_CATEGORY_DESIGNATOR (designator);
3892 des = XCHAR (designator);
3893 ctbl = check_category_table (category_table, Vstandard_category_table);
3894 ch = BUF_FETCH_CHAR (buf, XINT (position));
3895 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3898 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3899 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3900 Optional third arg CATEGORY-TABLE specifies the category table to use,
3901 and defaults to the standard category table.
3903 (character, designator, category_table))
3909 CHECK_CATEGORY_DESIGNATOR (designator);
3910 des = XCHAR (designator);
3911 CHECK_CHAR (character);
3912 ch = XCHAR (character);
3913 ctbl = check_category_table (category_table, Vstandard_category_table);
3914 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3917 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3918 Return BUFFER's current category table.
3919 BUFFER defaults to the current buffer.
3923 return decode_buffer (buffer, 0)->category_table;
3926 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3927 Return the standard category table.
3928 This is the one used for new buffers.
3932 return Vstandard_category_table;
3935 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3936 Return a new category table which is a copy of CATEGORY-TABLE.
3937 CATEGORY-TABLE defaults to the standard category table.
3941 if (NILP (Vstandard_category_table))
3942 return Fmake_char_table (Qcategory);
3945 check_category_table (category_table, Vstandard_category_table);
3946 return Fcopy_char_table (category_table);
3949 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3950 Select CATEGORY-TABLE as the new category table for BUFFER.
3951 BUFFER defaults to the current buffer if omitted.
3953 (category_table, buffer))
3955 struct buffer *buf = decode_buffer (buffer, 0);
3956 category_table = check_category_table (category_table, Qnil);
3957 buf->category_table = category_table;
3958 /* Indicate that this buffer now has a specified category table. */
3959 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3960 return category_table;
3963 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3964 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3968 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3971 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3972 Return t if OBJECT is a category table value.
3973 Valid values are nil or a bit vector of size 95.
3977 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3981 #define CATEGORYP(x) \
3982 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3984 #define CATEGORY_SET(c) \
3985 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3987 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3988 The faster version of `!NILP (Faref (category_set, category))'. */
3989 #define CATEGORY_MEMBER(category, category_set) \
3990 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3992 /* Return 1 if there is a word boundary between two word-constituent
3993 characters C1 and C2 if they appear in this order, else return 0.
3994 Use the macro WORD_BOUNDARY_P instead of calling this function
3997 int word_boundary_p (Emchar c1, Emchar c2);
3999 word_boundary_p (Emchar c1, Emchar c2)
4001 Lisp_Object category_set1, category_set2;
4006 if (COMPOSITE_CHAR_P (c1))
4007 c1 = cmpchar_component (c1, 0, 1);
4008 if (COMPOSITE_CHAR_P (c2))
4009 c2 = cmpchar_component (c2, 0, 1);
4012 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4014 tail = Vword_separating_categories;
4019 tail = Vword_combining_categories;
4023 category_set1 = CATEGORY_SET (c1);
4024 if (NILP (category_set1))
4025 return default_result;
4026 category_set2 = CATEGORY_SET (c2);
4027 if (NILP (category_set2))
4028 return default_result;
4030 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4032 Lisp_Object elt = XCONS(tail)->car;
4035 && CATEGORYP (XCONS (elt)->car)
4036 && CATEGORYP (XCONS (elt)->cdr)
4037 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4038 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4039 return !default_result;
4041 return default_result;
4047 syms_of_chartab (void)
4050 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4051 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4052 INIT_LRECORD_IMPLEMENTATION (byte_table);
4054 defsymbol (&Qsystem_char_id, "system-char-id");
4056 defsymbol (&Qto_ucs, "=>ucs");
4057 defsymbol (&Q_ucs, "->ucs");
4058 defsymbol (&Q_ucs_variants, "->ucs-variants");
4059 defsymbol (&Q_decomposition, "->decomposition");
4060 defsymbol (&Qcompat, "compat");
4061 defsymbol (&Qisolated, "isolated");
4062 defsymbol (&Qinitial, "initial");
4063 defsymbol (&Qmedial, "medial");
4064 defsymbol (&Qfinal, "final");
4065 defsymbol (&Qvertical, "vertical");
4066 defsymbol (&QnoBreak, "noBreak");
4067 defsymbol (&Qfraction, "fraction");
4068 defsymbol (&Qsuper, "super");
4069 defsymbol (&Qsub, "sub");
4070 defsymbol (&Qcircle, "circle");
4071 defsymbol (&Qsquare, "square");
4072 defsymbol (&Qwide, "wide");
4073 defsymbol (&Qnarrow, "narrow");
4074 defsymbol (&Qsmall, "small");
4075 defsymbol (&Qfont, "font");
4077 DEFSUBR (Fchar_attribute_list);
4078 DEFSUBR (Ffind_char_attribute_table);
4079 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4080 DEFSUBR (Fput_char_table_map_function);
4081 DEFSUBR (Fsave_char_attribute_table);
4082 DEFSUBR (Freset_char_attribute_table);
4083 DEFSUBR (Fclose_char_attribute_table);
4084 #ifdef HAVE_DATABASE
4085 defsymbol (&Qload_char_attribute_table_map_function,
4086 "load-char-attribute-table-map-function");
4087 DEFSUBR (Fload_char_attribute_table_map_function);
4089 DEFSUBR (Fload_char_attribute_table);
4090 DEFSUBR (Fchar_attribute_alist);
4091 DEFSUBR (Fget_char_attribute);
4092 DEFSUBR (Fput_char_attribute);
4093 DEFSUBR (Fremove_char_attribute);
4094 DEFSUBR (Fmap_char_attribute);
4095 DEFSUBR (Fdefine_char);
4096 DEFSUBR (Ffind_char);
4097 DEFSUBR (Fchar_variants);
4099 DEFSUBR (Fget_composite_char);
4102 INIT_LRECORD_IMPLEMENTATION (char_table);
4106 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4109 defsymbol (&Qcategory_table_p, "category-table-p");
4110 defsymbol (&Qcategory_designator_p, "category-designator-p");
4111 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4114 defsymbol (&Qchar_table, "char-table");
4115 defsymbol (&Qchar_tablep, "char-table-p");
4117 DEFSUBR (Fchar_table_p);
4118 DEFSUBR (Fchar_table_type_list);
4119 DEFSUBR (Fvalid_char_table_type_p);
4120 DEFSUBR (Fchar_table_type);
4121 DEFSUBR (Freset_char_table);
4122 DEFSUBR (Fmake_char_table);
4123 DEFSUBR (Fcopy_char_table);
4124 DEFSUBR (Fget_char_table);
4125 DEFSUBR (Fget_range_char_table);
4126 DEFSUBR (Fvalid_char_table_value_p);
4127 DEFSUBR (Fcheck_valid_char_table_value);
4128 DEFSUBR (Fput_char_table);
4129 DEFSUBR (Fmap_char_table);
4132 DEFSUBR (Fcategory_table_p);
4133 DEFSUBR (Fcategory_table);
4134 DEFSUBR (Fstandard_category_table);
4135 DEFSUBR (Fcopy_category_table);
4136 DEFSUBR (Fset_category_table);
4137 DEFSUBR (Fcheck_category_at);
4138 DEFSUBR (Fchar_in_category_p);
4139 DEFSUBR (Fcategory_designator_p);
4140 DEFSUBR (Fcategory_table_value_p);
4146 vars_of_chartab (void)
4149 staticpro (&Vcharacter_composition_table);
4150 Vcharacter_composition_table = make_char_id_table (Qnil);
4152 staticpro (&Vcharacter_variant_table);
4153 Vcharacter_variant_table = make_char_id_table (Qunbound);
4155 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4156 Vall_syntax_tables = Qnil;
4157 dump_add_weak_object_chain (&Vall_syntax_tables);
4161 structure_type_create_chartab (void)
4163 struct structure_type *st;
4165 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4167 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4168 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4172 complex_vars_of_chartab (void)
4175 staticpro (&Vchar_attribute_hash_table);
4176 Vchar_attribute_hash_table
4177 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4178 #ifdef HAVE_DATABASE
4179 Fputhash (Q_ucs_variants, Vcharacter_variant_table,
4180 Vchar_attribute_hash_table);
4181 XCHAR_TABLE_NAME (Vcharacter_variant_table) = Q_ucs_variants;
4182 #endif /* HAVE_DATABASE */
4183 #endif /* UTF2000 */
4185 /* Set this now, so first buffer creation can refer to it. */
4186 /* Make it nil before calling copy-category-table
4187 so that copy-category-table will know not to try to copy from garbage */
4188 Vstandard_category_table = Qnil;
4189 Vstandard_category_table = Fcopy_category_table (Qnil);
4190 staticpro (&Vstandard_category_table);
4192 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4193 List of pair (cons) of categories to determine word boundary.
4195 Emacs treats a sequence of word constituent characters as a single
4196 word (i.e. finds no word boundary between them) iff they belongs to
4197 the same charset. But, exceptions are allowed in the following cases.
4199 \(1) The case that characters are in different charsets is controlled
4200 by the variable `word-combining-categories'.
4202 Emacs finds no word boundary between characters of different charsets
4203 if they have categories matching some element of this list.
4205 More precisely, if an element of this list is a cons of category CAT1
4206 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4207 C2 which has CAT2, there's no word boundary between C1 and C2.
4209 For instance, to tell that ASCII characters and Latin-1 characters can
4210 form a single word, the element `(?l . ?l)' should be in this list
4211 because both characters have the category `l' (Latin characters).
4213 \(2) The case that character are in the same charset is controlled by
4214 the variable `word-separating-categories'.
4216 Emacs find a word boundary between characters of the same charset
4217 if they have categories matching some element of this list.
4219 More precisely, if an element of this list is a cons of category CAT1
4220 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4221 C2 which has CAT2, there's a word boundary between C1 and C2.
4223 For instance, to tell that there's a word boundary between Japanese
4224 Hiragana and Japanese Kanji (both are in the same charset), the
4225 element `(?H . ?C) should be in this list.
4228 Vword_combining_categories = Qnil;
4230 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4231 List of pair (cons) of categories to determine word boundary.
4232 See the documentation of the variable `word-combining-categories'.
4235 Vword_separating_categories = Qnil;