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);
1282 for (i = 0; i < NUM_ASCII_CHARS; i++)
1283 mark_object (ct->ascii[i]);
1285 for (i = 0; i < NUM_LEADING_BYTES; i++)
1286 mark_object (ct->level1[i]);
1290 return ct->default_value;
1292 return ct->mirror_table;
1296 /* WARNING: All functions of this nature need to be written extremely
1297 carefully to avoid crashes during GC. Cf. prune_specifiers()
1298 and prune_weak_hash_tables(). */
1301 prune_syntax_tables (void)
1303 Lisp_Object rest, prev = Qnil;
1305 for (rest = Vall_syntax_tables;
1307 rest = XCHAR_TABLE (rest)->next_table)
1309 if (! marked_p (rest))
1311 /* This table is garbage. Remove it from the list. */
1313 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1315 XCHAR_TABLE (prev)->next_table =
1316 XCHAR_TABLE (rest)->next_table;
1322 char_table_type_to_symbol (enum char_table_type type)
1327 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1328 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1329 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1330 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1332 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1337 static enum char_table_type
1338 symbol_to_char_table_type (Lisp_Object symbol)
1340 CHECK_SYMBOL (symbol);
1342 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1343 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1344 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1345 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1347 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1350 signal_simple_error ("Unrecognized char table type", symbol);
1351 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1355 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1356 Lisp_Object printcharfun)
1360 write_c_string (" (", printcharfun);
1361 print_internal (make_char (first), printcharfun, 0);
1362 write_c_string (" ", printcharfun);
1363 print_internal (make_char (last), printcharfun, 0);
1364 write_c_string (") ", printcharfun);
1368 write_c_string (" ", printcharfun);
1369 print_internal (make_char (first), printcharfun, 0);
1370 write_c_string (" ", printcharfun);
1372 print_internal (val, printcharfun, 1);
1375 #if defined(MULE)&&!defined(UTF2000)
1378 print_chartab_charset_row (Lisp_Object charset,
1380 Lisp_Char_Table_Entry *cte,
1381 Lisp_Object printcharfun)
1384 Lisp_Object cat = Qunbound;
1387 for (i = 32; i < 128; i++)
1389 Lisp_Object pam = cte->level2[i - 32];
1401 print_chartab_range (MAKE_CHAR (charset, first, 0),
1402 MAKE_CHAR (charset, i - 1, 0),
1405 print_chartab_range (MAKE_CHAR (charset, row, first),
1406 MAKE_CHAR (charset, row, i - 1),
1416 print_chartab_range (MAKE_CHAR (charset, first, 0),
1417 MAKE_CHAR (charset, i - 1, 0),
1420 print_chartab_range (MAKE_CHAR (charset, row, first),
1421 MAKE_CHAR (charset, row, i - 1),
1427 print_chartab_two_byte_charset (Lisp_Object charset,
1428 Lisp_Char_Table_Entry *cte,
1429 Lisp_Object printcharfun)
1433 for (i = 32; i < 128; i++)
1435 Lisp_Object jen = cte->level2[i - 32];
1437 if (!CHAR_TABLE_ENTRYP (jen))
1441 write_c_string (" [", printcharfun);
1442 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1443 sprintf (buf, " %d] ", i);
1444 write_c_string (buf, printcharfun);
1445 print_internal (jen, printcharfun, 0);
1448 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1456 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1458 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1461 struct gcpro gcpro1, gcpro2;
1462 GCPRO2 (obj, printcharfun);
1464 write_c_string ("#s(char-table ", printcharfun);
1465 write_c_string (" ", printcharfun);
1466 write_c_string (string_data
1468 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1470 write_c_string ("\n ", printcharfun);
1471 print_internal (ct->default_value, printcharfun, escapeflag);
1472 for (i = 0; i < 256; i++)
1474 Lisp_Object elt = get_byte_table (ct->table, i);
1475 if (i != 0) write_c_string ("\n ", printcharfun);
1476 if (EQ (elt, Qunbound))
1477 write_c_string ("void", printcharfun);
1479 print_internal (elt, printcharfun, escapeflag);
1482 #else /* non UTF2000 */
1485 sprintf (buf, "#s(char-table type %s data (",
1486 string_data (symbol_name (XSYMBOL
1487 (char_table_type_to_symbol (ct->type)))));
1488 write_c_string (buf, printcharfun);
1490 /* Now write out the ASCII/Control-1 stuff. */
1494 Lisp_Object val = Qunbound;
1496 for (i = 0; i < NUM_ASCII_CHARS; i++)
1505 if (!EQ (ct->ascii[i], val))
1507 print_chartab_range (first, i - 1, val, printcharfun);
1514 print_chartab_range (first, i - 1, val, printcharfun);
1521 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1524 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1525 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1527 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1528 || i == LEADING_BYTE_CONTROL_1)
1530 if (!CHAR_TABLE_ENTRYP (ann))
1532 write_c_string (" ", printcharfun);
1533 print_internal (XCHARSET_NAME (charset),
1535 write_c_string (" ", printcharfun);
1536 print_internal (ann, printcharfun, 0);
1540 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1541 if (XCHARSET_DIMENSION (charset) == 1)
1542 print_chartab_charset_row (charset, -1, cte, printcharfun);
1544 print_chartab_two_byte_charset (charset, cte, printcharfun);
1549 #endif /* non UTF2000 */
1551 write_c_string ("))", printcharfun);
1555 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1557 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1558 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1561 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1565 for (i = 0; i < 256; i++)
1567 if (!internal_equal (get_byte_table (ct1->table, i),
1568 get_byte_table (ct2->table, i), 0))
1572 for (i = 0; i < NUM_ASCII_CHARS; i++)
1573 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1577 for (i = 0; i < NUM_LEADING_BYTES; i++)
1578 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1581 #endif /* non UTF2000 */
1586 static unsigned long
1587 char_table_hash (Lisp_Object obj, int depth)
1589 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1591 return byte_table_hash (ct->table, depth + 1);
1593 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1596 hashval = HASH2 (hashval,
1597 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1603 static const struct lrecord_description char_table_description[] = {
1605 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1606 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1607 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1608 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1610 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1612 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1616 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1618 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1622 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1623 mark_char_table, print_char_table, 0,
1624 char_table_equal, char_table_hash,
1625 char_table_description,
1628 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1629 Return non-nil if OBJECT is a char table.
1631 A char table is a table that maps characters (or ranges of characters)
1632 to values. Char tables are specialized for characters, only allowing
1633 particular sorts of ranges to be assigned values. Although this
1634 loses in generality, it makes for extremely fast (constant-time)
1635 lookups, and thus is feasible for applications that do an extremely
1636 large number of lookups (e.g. scanning a buffer for a character in
1637 a particular syntax, where a lookup in the syntax table must occur
1638 once per character).
1640 When Mule support exists, the types of ranges that can be assigned
1644 -- an entire charset
1645 -- a single row in a two-octet charset
1646 -- a single character
1648 When Mule support is not present, the types of ranges that can be
1652 -- a single character
1654 To create a char table, use `make-char-table'.
1655 To modify a char table, use `put-char-table' or `remove-char-table'.
1656 To retrieve the value for a particular character, use `get-char-table'.
1657 See also `map-char-table', `clear-char-table', `copy-char-table',
1658 `valid-char-table-type-p', `char-table-type-list',
1659 `valid-char-table-value-p', and `check-char-table-value'.
1663 return CHAR_TABLEP (object) ? Qt : Qnil;
1666 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1667 Return a list of the recognized char table types.
1668 See `valid-char-table-type-p'.
1673 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1675 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1679 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1680 Return t if TYPE if a recognized char table type.
1682 Each char table type is used for a different purpose and allows different
1683 sorts of values. The different char table types are
1686 Used for category tables, which specify the regexp categories
1687 that a character is in. The valid values are nil or a
1688 bit vector of 95 elements. Higher-level Lisp functions are
1689 provided for working with category tables. Currently categories
1690 and category tables only exist when Mule support is present.
1692 A generalized char table, for mapping from one character to
1693 another. Used for case tables, syntax matching tables,
1694 `keyboard-translate-table', etc. The valid values are characters.
1696 An even more generalized char table, for mapping from a
1697 character to anything.
1699 Used for display tables, which specify how a particular character
1700 is to appear when displayed. #### Not yet implemented.
1702 Used for syntax tables, which specify the syntax of a particular
1703 character. Higher-level Lisp functions are provided for
1704 working with syntax tables. The valid values are integers.
1709 return (EQ (type, Qchar) ||
1711 EQ (type, Qcategory) ||
1713 EQ (type, Qdisplay) ||
1714 EQ (type, Qgeneric) ||
1715 EQ (type, Qsyntax)) ? Qt : Qnil;
1718 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1719 Return the type of CHAR-TABLE.
1720 See `valid-char-table-type-p'.
1724 CHECK_CHAR_TABLE (char_table);
1725 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1729 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1732 ct->table = Qunbound;
1733 ct->default_value = value;
1738 for (i = 0; i < NUM_ASCII_CHARS; i++)
1739 ct->ascii[i] = value;
1741 for (i = 0; i < NUM_LEADING_BYTES; i++)
1742 ct->level1[i] = value;
1747 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1748 update_syntax_table (ct);
1752 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1753 Reset CHAR-TABLE to its default state.
1757 Lisp_Char_Table *ct;
1759 CHECK_CHAR_TABLE (char_table);
1760 ct = XCHAR_TABLE (char_table);
1764 case CHAR_TABLE_TYPE_CHAR:
1765 fill_char_table (ct, make_char (0));
1767 case CHAR_TABLE_TYPE_DISPLAY:
1768 case CHAR_TABLE_TYPE_GENERIC:
1770 case CHAR_TABLE_TYPE_CATEGORY:
1772 fill_char_table (ct, Qnil);
1775 case CHAR_TABLE_TYPE_SYNTAX:
1776 fill_char_table (ct, make_int (Sinherit));
1786 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1787 Return a new, empty char table of type TYPE.
1788 Currently recognized types are 'char, 'category, 'display, 'generic,
1789 and 'syntax. See `valid-char-table-type-p'.
1793 Lisp_Char_Table *ct;
1795 enum char_table_type ty = symbol_to_char_table_type (type);
1797 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1800 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1802 ct->mirror_table = Fmake_char_table (Qgeneric);
1803 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1807 ct->mirror_table = Qnil;
1812 ct->next_table = Qnil;
1813 XSETCHAR_TABLE (obj, ct);
1814 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1816 ct->next_table = Vall_syntax_tables;
1817 Vall_syntax_tables = obj;
1819 Freset_char_table (obj);
1823 #if defined(MULE)&&!defined(UTF2000)
1826 make_char_table_entry (Lisp_Object initval)
1830 Lisp_Char_Table_Entry *cte =
1831 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1833 for (i = 0; i < 96; i++)
1834 cte->level2[i] = initval;
1836 XSETCHAR_TABLE_ENTRY (obj, cte);
1841 copy_char_table_entry (Lisp_Object entry)
1843 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1846 Lisp_Char_Table_Entry *ctenew =
1847 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1849 for (i = 0; i < 96; i++)
1851 Lisp_Object new = cte->level2[i];
1852 if (CHAR_TABLE_ENTRYP (new))
1853 ctenew->level2[i] = copy_char_table_entry (new);
1855 ctenew->level2[i] = new;
1858 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1864 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1865 Return a new char table which is a copy of CHAR-TABLE.
1866 It will contain the same values for the same characters and ranges
1867 as CHAR-TABLE. The values will not themselves be copied.
1871 Lisp_Char_Table *ct, *ctnew;
1877 CHECK_CHAR_TABLE (char_table);
1878 ct = XCHAR_TABLE (char_table);
1879 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1880 ctnew->type = ct->type;
1882 ctnew->default_value = ct->default_value;
1883 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1884 ctnew->name = ct->name;
1887 if (UINT8_BYTE_TABLE_P (ct->table))
1889 ctnew->table = copy_uint8_byte_table (ct->table);
1891 else if (UINT16_BYTE_TABLE_P (ct->table))
1893 ctnew->table = copy_uint16_byte_table (ct->table);
1895 else if (BYTE_TABLE_P (ct->table))
1897 ctnew->table = copy_byte_table (ct->table);
1899 else if (!UNBOUNDP (ct->table))
1900 ctnew->table = ct->table;
1901 #else /* non UTF2000 */
1903 for (i = 0; i < NUM_ASCII_CHARS; i++)
1905 Lisp_Object new = ct->ascii[i];
1907 assert (! (CHAR_TABLE_ENTRYP (new)));
1909 ctnew->ascii[i] = new;
1914 for (i = 0; i < NUM_LEADING_BYTES; i++)
1916 Lisp_Object new = ct->level1[i];
1917 if (CHAR_TABLE_ENTRYP (new))
1918 ctnew->level1[i] = copy_char_table_entry (new);
1920 ctnew->level1[i] = new;
1924 #endif /* non UTF2000 */
1927 if (CHAR_TABLEP (ct->mirror_table))
1928 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1930 ctnew->mirror_table = ct->mirror_table;
1932 ctnew->next_table = Qnil;
1933 XSETCHAR_TABLE (obj, ctnew);
1934 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1936 ctnew->next_table = Vall_syntax_tables;
1937 Vall_syntax_tables = obj;
1942 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1944 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1946 switch (XCHARSET_CHARS (ccs))
1949 return (33 << 8) | 126;
1951 return (32 << 8) | 127;
1954 return (0 << 8) | 127;
1956 return (0 << 8) | 255;
1968 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1971 outrange->type = CHARTAB_RANGE_ALL;
1972 else if (EQ (range, Qnil))
1973 outrange->type = CHARTAB_RANGE_DEFAULT;
1974 else if (CHAR_OR_CHAR_INTP (range))
1976 outrange->type = CHARTAB_RANGE_CHAR;
1977 outrange->ch = XCHAR_OR_CHAR_INT (range);
1981 signal_simple_error ("Range must be t or a character", range);
1983 else if (VECTORP (range))
1985 Lisp_Vector *vec = XVECTOR (range);
1986 Lisp_Object *elts = vector_data (vec);
1987 int cell_min, cell_max;
1989 outrange->type = CHARTAB_RANGE_ROW;
1990 outrange->charset = Fget_charset (elts[0]);
1991 CHECK_INT (elts[1]);
1992 outrange->row = XINT (elts[1]);
1993 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1994 signal_simple_error ("Charset in row vector must be multi-byte",
1998 int ret = XCHARSET_CELL_RANGE (outrange->charset);
2000 cell_min = ret >> 8;
2001 cell_max = ret & 0xFF;
2003 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2004 check_int_range (outrange->row, cell_min, cell_max);
2006 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2008 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2009 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2011 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2013 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2014 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2015 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2023 if (!CHARSETP (range) && !SYMBOLP (range))
2025 ("Char table range must be t, charset, char, or vector", range);
2026 outrange->type = CHARTAB_RANGE_CHARSET;
2027 outrange->charset = Fget_charset (range);
2032 #if defined(MULE)&&!defined(UTF2000)
2034 /* called from CHAR_TABLE_VALUE(). */
2036 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2041 Lisp_Object charset;
2043 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2048 BREAKUP_CHAR (c, charset, byte1, byte2);
2050 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2052 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2053 if (CHAR_TABLE_ENTRYP (val))
2055 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2056 val = cte->level2[byte1 - 32];
2057 if (CHAR_TABLE_ENTRYP (val))
2059 cte = XCHAR_TABLE_ENTRY (val);
2060 assert (byte2 >= 32);
2061 val = cte->level2[byte2 - 32];
2062 assert (!CHAR_TABLE_ENTRYP (val));
2072 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2075 return get_char_id_table (ct, ch);
2078 Lisp_Object charset;
2082 BREAKUP_CHAR (ch, charset, byte1, byte2);
2084 if (EQ (charset, Vcharset_ascii))
2085 val = ct->ascii[byte1];
2086 else if (EQ (charset, Vcharset_control_1))
2087 val = ct->ascii[byte1 + 128];
2090 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2091 val = ct->level1[lb];
2092 if (CHAR_TABLE_ENTRYP (val))
2094 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2095 val = cte->level2[byte1 - 32];
2096 if (CHAR_TABLE_ENTRYP (val))
2098 cte = XCHAR_TABLE_ENTRY (val);
2099 assert (byte2 >= 32);
2100 val = cte->level2[byte2 - 32];
2101 assert (!CHAR_TABLE_ENTRYP (val));
2108 #else /* not MULE */
2109 return ct->ascii[(unsigned char)ch];
2110 #endif /* not MULE */
2114 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2115 Find value for CHARACTER in CHAR-TABLE.
2117 (character, char_table))
2119 CHECK_CHAR_TABLE (char_table);
2120 CHECK_CHAR_COERCE_INT (character);
2122 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2125 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2126 Find value for a range in CHAR-TABLE.
2127 If there is more than one value, return MULTI (defaults to nil).
2129 (range, char_table, multi))
2131 Lisp_Char_Table *ct;
2132 struct chartab_range rainj;
2134 if (CHAR_OR_CHAR_INTP (range))
2135 return Fget_char_table (range, char_table);
2136 CHECK_CHAR_TABLE (char_table);
2137 ct = XCHAR_TABLE (char_table);
2139 decode_char_table_range (range, &rainj);
2142 case CHARTAB_RANGE_ALL:
2145 if (UINT8_BYTE_TABLE_P (ct->table))
2147 else if (UINT16_BYTE_TABLE_P (ct->table))
2149 else if (BYTE_TABLE_P (ct->table))
2153 #else /* non UTF2000 */
2155 Lisp_Object first = ct->ascii[0];
2157 for (i = 1; i < NUM_ASCII_CHARS; i++)
2158 if (!EQ (first, ct->ascii[i]))
2162 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2165 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2166 || i == LEADING_BYTE_ASCII
2167 || i == LEADING_BYTE_CONTROL_1)
2169 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2175 #endif /* non UTF2000 */
2179 case CHARTAB_RANGE_CHARSET:
2183 if (EQ (rainj.charset, Vcharset_ascii))
2186 Lisp_Object first = ct->ascii[0];
2188 for (i = 1; i < 128; i++)
2189 if (!EQ (first, ct->ascii[i]))
2194 if (EQ (rainj.charset, Vcharset_control_1))
2197 Lisp_Object first = ct->ascii[128];
2199 for (i = 129; i < 160; i++)
2200 if (!EQ (first, ct->ascii[i]))
2206 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2208 if (CHAR_TABLE_ENTRYP (val))
2214 case CHARTAB_RANGE_ROW:
2219 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2221 if (!CHAR_TABLE_ENTRYP (val))
2223 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2224 if (CHAR_TABLE_ENTRYP (val))
2228 #endif /* not UTF2000 */
2229 #endif /* not MULE */
2235 return Qnil; /* not reached */
2239 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2240 Error_behavior errb)
2244 case CHAR_TABLE_TYPE_SYNTAX:
2245 if (!ERRB_EQ (errb, ERROR_ME))
2246 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2247 && CHAR_OR_CHAR_INTP (XCDR (value)));
2250 Lisp_Object cdr = XCDR (value);
2251 CHECK_INT (XCAR (value));
2252 CHECK_CHAR_COERCE_INT (cdr);
2259 case CHAR_TABLE_TYPE_CATEGORY:
2260 if (!ERRB_EQ (errb, ERROR_ME))
2261 return CATEGORY_TABLE_VALUEP (value);
2262 CHECK_CATEGORY_TABLE_VALUE (value);
2266 case CHAR_TABLE_TYPE_GENERIC:
2269 case CHAR_TABLE_TYPE_DISPLAY:
2271 maybe_signal_simple_error ("Display char tables not yet implemented",
2272 value, Qchar_table, errb);
2275 case CHAR_TABLE_TYPE_CHAR:
2276 if (!ERRB_EQ (errb, ERROR_ME))
2277 return CHAR_OR_CHAR_INTP (value);
2278 CHECK_CHAR_COERCE_INT (value);
2285 return 0; /* not reached */
2289 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2293 case CHAR_TABLE_TYPE_SYNTAX:
2296 Lisp_Object car = XCAR (value);
2297 Lisp_Object cdr = XCDR (value);
2298 CHECK_CHAR_COERCE_INT (cdr);
2299 return Fcons (car, cdr);
2302 case CHAR_TABLE_TYPE_CHAR:
2303 CHECK_CHAR_COERCE_INT (value);
2311 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2312 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2314 (value, char_table_type))
2316 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2318 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2321 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2322 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2324 (value, char_table_type))
2326 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2328 check_valid_char_table_value (value, type, ERROR_ME);
2333 Lisp_Char_Table* char_attribute_table_to_put;
2334 Lisp_Object Qput_char_table_map_function;
2335 Lisp_Object value_to_put;
2337 DEFUN ("put-char-table-map-function",
2338 Fput_char_table_map_function, 2, 2, 0, /*
2339 For internal use. Don't use it.
2343 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2348 /* Assign VAL to all characters in RANGE in char table CT. */
2351 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2354 switch (range->type)
2356 case CHARTAB_RANGE_ALL:
2357 /* printf ("put-char-table: range = all\n"); */
2358 fill_char_table (ct, val);
2359 return; /* avoid the duplicate call to update_syntax_table() below,
2360 since fill_char_table() also did that. */
2363 case CHARTAB_RANGE_DEFAULT:
2364 ct->default_value = val;
2369 case CHARTAB_RANGE_CHARSET:
2373 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2375 /* printf ("put-char-table: range = charset: %d\n",
2376 XCHARSET_LEADING_BYTE (range->charset));
2378 if ( CHAR_TABLEP (encoding_table) )
2381 char_attribute_table_to_put = ct;
2383 Fmap_char_attribute (Qput_char_table_map_function,
2384 XCHAR_TABLE_NAME (encoding_table),
2387 for (c = 0; c < 1 << 24; c++)
2389 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2391 put_char_id_table_0 (ct, c, val);
2397 for (c = 0; c < 1 << 24; c++)
2399 if ( charset_code_point (range->charset, c) >= 0 )
2400 put_char_id_table_0 (ct, c, val);
2405 if (EQ (range->charset, Vcharset_ascii))
2408 for (i = 0; i < 128; i++)
2411 else if (EQ (range->charset, Vcharset_control_1))
2414 for (i = 128; i < 160; i++)
2419 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2420 ct->level1[lb] = val;
2425 case CHARTAB_RANGE_ROW:
2428 int cell_min, cell_max, i;
2430 i = XCHARSET_CELL_RANGE (range->charset);
2432 cell_max = i & 0xFF;
2433 for (i = cell_min; i <= cell_max; i++)
2435 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2437 if ( charset_code_point (range->charset, ch) >= 0 )
2438 put_char_id_table_0 (ct, ch, val);
2443 Lisp_Char_Table_Entry *cte;
2444 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2445 /* make sure that there is a separate entry for the row. */
2446 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2447 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2448 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2449 cte->level2[range->row - 32] = val;
2451 #endif /* not UTF2000 */
2455 case CHARTAB_RANGE_CHAR:
2457 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2458 put_char_id_table_0 (ct, range->ch, val);
2462 Lisp_Object charset;
2465 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2466 if (EQ (charset, Vcharset_ascii))
2467 ct->ascii[byte1] = val;
2468 else if (EQ (charset, Vcharset_control_1))
2469 ct->ascii[byte1 + 128] = val;
2472 Lisp_Char_Table_Entry *cte;
2473 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2474 /* make sure that there is a separate entry for the row. */
2475 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2476 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2477 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2478 /* now CTE is a char table entry for the charset;
2479 each entry is for a single row (or character of
2480 a one-octet charset). */
2481 if (XCHARSET_DIMENSION (charset) == 1)
2482 cte->level2[byte1 - 32] = val;
2485 /* assigning to one character in a two-octet charset. */
2486 /* make sure that the charset row contains a separate
2487 entry for each character. */
2488 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2489 cte->level2[byte1 - 32] =
2490 make_char_table_entry (cte->level2[byte1 - 32]);
2491 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2492 cte->level2[byte2 - 32] = val;
2496 #else /* not MULE */
2497 ct->ascii[(unsigned char) (range->ch)] = val;
2499 #endif /* not MULE */
2503 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2504 update_syntax_table (ct);
2508 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2509 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2511 RANGE specifies one or more characters to be affected and should be
2512 one of the following:
2514 -- t (all characters are affected)
2515 -- A charset (only allowed when Mule support is present)
2516 -- A vector of two elements: a two-octet charset and a row number
2517 (only allowed when Mule support is present)
2518 -- A single character
2520 VALUE must be a value appropriate for the type of CHAR-TABLE.
2521 See `valid-char-table-type-p'.
2523 (range, value, char_table))
2525 Lisp_Char_Table *ct;
2526 struct chartab_range rainj;
2528 CHECK_CHAR_TABLE (char_table);
2529 ct = XCHAR_TABLE (char_table);
2530 check_valid_char_table_value (value, ct->type, ERROR_ME);
2531 decode_char_table_range (range, &rainj);
2532 value = canonicalize_char_table_value (value, ct->type);
2533 put_char_table (ct, &rainj, value);
2538 /* Map FN over the ASCII chars in CT. */
2541 map_over_charset_ascii (Lisp_Char_Table *ct,
2542 int (*fn) (struct chartab_range *range,
2543 Lisp_Object val, void *arg),
2546 struct chartab_range rainj;
2555 rainj.type = CHARTAB_RANGE_CHAR;
2557 for (i = start, retval = 0; i < stop && retval == 0; i++)
2559 rainj.ch = (Emchar) i;
2560 retval = (fn) (&rainj, ct->ascii[i], arg);
2568 /* Map FN over the Control-1 chars in CT. */
2571 map_over_charset_control_1 (Lisp_Char_Table *ct,
2572 int (*fn) (struct chartab_range *range,
2573 Lisp_Object val, void *arg),
2576 struct chartab_range rainj;
2579 int stop = start + 32;
2581 rainj.type = CHARTAB_RANGE_CHAR;
2583 for (i = start, retval = 0; i < stop && retval == 0; i++)
2585 rainj.ch = (Emchar) (i);
2586 retval = (fn) (&rainj, ct->ascii[i], arg);
2592 /* Map FN over the row ROW of two-byte charset CHARSET.
2593 There must be a separate value for that row in the char table.
2594 CTE specifies the char table entry for CHARSET. */
2597 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2598 Lisp_Object charset, int row,
2599 int (*fn) (struct chartab_range *range,
2600 Lisp_Object val, void *arg),
2603 Lisp_Object val = cte->level2[row - 32];
2605 if (!CHAR_TABLE_ENTRYP (val))
2607 struct chartab_range rainj;
2609 rainj.type = CHARTAB_RANGE_ROW;
2610 rainj.charset = charset;
2612 return (fn) (&rainj, val, arg);
2616 struct chartab_range rainj;
2618 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2619 int start = charset94_p ? 33 : 32;
2620 int stop = charset94_p ? 127 : 128;
2622 cte = XCHAR_TABLE_ENTRY (val);
2624 rainj.type = CHARTAB_RANGE_CHAR;
2626 for (i = start, retval = 0; i < stop && retval == 0; i++)
2628 rainj.ch = MAKE_CHAR (charset, row, i);
2629 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2637 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2638 int (*fn) (struct chartab_range *range,
2639 Lisp_Object val, void *arg),
2642 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2643 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2645 if (!CHARSETP (charset)
2646 || lb == LEADING_BYTE_ASCII
2647 || lb == LEADING_BYTE_CONTROL_1)
2650 if (!CHAR_TABLE_ENTRYP (val))
2652 struct chartab_range rainj;
2654 rainj.type = CHARTAB_RANGE_CHARSET;
2655 rainj.charset = charset;
2656 return (fn) (&rainj, val, arg);
2660 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2661 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2662 int start = charset94_p ? 33 : 32;
2663 int stop = charset94_p ? 127 : 128;
2666 if (XCHARSET_DIMENSION (charset) == 1)
2668 struct chartab_range rainj;
2669 rainj.type = CHARTAB_RANGE_CHAR;
2671 for (i = start, retval = 0; i < stop && retval == 0; i++)
2673 rainj.ch = MAKE_CHAR (charset, i, 0);
2674 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2679 for (i = start, retval = 0; i < stop && retval == 0; i++)
2680 retval = map_over_charset_row (cte, charset, i, fn, arg);
2688 #endif /* not UTF2000 */
2691 struct map_char_table_for_charset_arg
2693 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2694 Lisp_Char_Table *ct;
2699 map_char_table_for_charset_fun (struct chartab_range *range,
2700 Lisp_Object val, void *arg)
2702 struct map_char_table_for_charset_arg *closure =
2703 (struct map_char_table_for_charset_arg *) arg;
2706 switch (range->type)
2708 case CHARTAB_RANGE_ALL:
2711 case CHARTAB_RANGE_DEFAULT:
2714 case CHARTAB_RANGE_CHARSET:
2717 case CHARTAB_RANGE_ROW:
2720 case CHARTAB_RANGE_CHAR:
2721 ret = get_char_table (range->ch, closure->ct);
2722 if (!UNBOUNDP (ret))
2723 return (closure->fn) (range, ret, closure->arg);
2735 /* Map FN (with client data ARG) over range RANGE in char table CT.
2736 Mapping stops the first time FN returns non-zero, and that value
2737 becomes the return value of map_char_table(). */
2740 map_char_table (Lisp_Char_Table *ct,
2741 struct chartab_range *range,
2742 int (*fn) (struct chartab_range *range,
2743 Lisp_Object val, void *arg),
2746 switch (range->type)
2748 case CHARTAB_RANGE_ALL:
2750 if (!UNBOUNDP (ct->default_value))
2752 struct chartab_range rainj;
2755 rainj.type = CHARTAB_RANGE_DEFAULT;
2756 retval = (fn) (&rainj, ct->default_value, arg);
2760 if (UINT8_BYTE_TABLE_P (ct->table))
2761 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2763 else if (UINT16_BYTE_TABLE_P (ct->table))
2764 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2766 else if (BYTE_TABLE_P (ct->table))
2767 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2769 else if (EQ (ct->table, Qunloaded))
2772 struct chartab_range rainj;
2775 Emchar c1 = c + unit;
2778 rainj.type = CHARTAB_RANGE_CHAR;
2780 for (retval = 0; c < c1 && retval == 0; c++)
2782 Lisp_Object ret = get_char_id_table (ct, c);
2784 if (!UNBOUNDP (ret))
2787 retval = (fn) (&rainj, ct->table, arg);
2792 ct->table = Qunbound;
2795 else if (!UNBOUNDP (ct->table))
2796 return (fn) (range, ct->table, arg);
2802 retval = map_over_charset_ascii (ct, fn, arg);
2806 retval = map_over_charset_control_1 (ct, fn, arg);
2811 Charset_ID start = MIN_LEADING_BYTE;
2812 Charset_ID stop = start + NUM_LEADING_BYTES;
2814 for (i = start, retval = 0; i < stop && retval == 0; i++)
2816 retval = map_over_other_charset (ct, i, fn, arg);
2825 case CHARTAB_RANGE_DEFAULT:
2826 if (!UNBOUNDP (ct->default_value))
2827 return (fn) (range, ct->default_value, arg);
2832 case CHARTAB_RANGE_CHARSET:
2835 Lisp_Object encoding_table
2836 = XCHARSET_ENCODING_TABLE (range->charset);
2838 if (!NILP (encoding_table))
2840 struct chartab_range rainj;
2841 struct map_char_table_for_charset_arg mcarg;
2843 #ifdef HAVE_DATABASE
2844 if (XCHAR_TABLE_UNLOADED(encoding_table))
2845 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2850 rainj.type = CHARTAB_RANGE_ALL;
2851 return map_char_table (XCHAR_TABLE(encoding_table),
2853 &map_char_table_for_charset_fun,
2859 return map_over_other_charset (ct,
2860 XCHARSET_LEADING_BYTE (range->charset),
2864 case CHARTAB_RANGE_ROW:
2867 int cell_min, cell_max, i;
2869 struct chartab_range rainj;
2871 i = XCHARSET_CELL_RANGE (range->charset);
2873 cell_max = i & 0xFF;
2874 rainj.type = CHARTAB_RANGE_CHAR;
2875 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2877 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2879 if ( charset_code_point (range->charset, ch) >= 0 )
2882 = get_byte_table (get_byte_table
2886 (unsigned char)(ch >> 24)),
2887 (unsigned char) (ch >> 16)),
2888 (unsigned char) (ch >> 8)),
2889 (unsigned char) ch);
2892 val = ct->default_value;
2894 retval = (fn) (&rainj, val, arg);
2901 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2902 - MIN_LEADING_BYTE];
2903 if (!CHAR_TABLE_ENTRYP (val))
2905 struct chartab_range rainj;
2907 rainj.type = CHARTAB_RANGE_ROW;
2908 rainj.charset = range->charset;
2909 rainj.row = range->row;
2910 return (fn) (&rainj, val, arg);
2913 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2914 range->charset, range->row,
2917 #endif /* not UTF2000 */
2920 case CHARTAB_RANGE_CHAR:
2922 Emchar ch = range->ch;
2923 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2925 if (!UNBOUNDP (val))
2927 struct chartab_range rainj;
2929 rainj.type = CHARTAB_RANGE_CHAR;
2931 return (fn) (&rainj, val, arg);
2943 struct slow_map_char_table_arg
2945 Lisp_Object function;
2950 slow_map_char_table_fun (struct chartab_range *range,
2951 Lisp_Object val, void *arg)
2953 Lisp_Object ranjarg = Qnil;
2954 struct slow_map_char_table_arg *closure =
2955 (struct slow_map_char_table_arg *) arg;
2957 switch (range->type)
2959 case CHARTAB_RANGE_ALL:
2964 case CHARTAB_RANGE_DEFAULT:
2970 case CHARTAB_RANGE_CHARSET:
2971 ranjarg = XCHARSET_NAME (range->charset);
2974 case CHARTAB_RANGE_ROW:
2975 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2976 make_int (range->row));
2979 case CHARTAB_RANGE_CHAR:
2980 ranjarg = make_char (range->ch);
2986 closure->retval = call2 (closure->function, ranjarg, val);
2987 return !NILP (closure->retval);
2990 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2991 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2992 each key and value in the table.
2994 RANGE specifies a subrange to map over and is in the same format as
2995 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2998 (function, char_table, range))
3000 Lisp_Char_Table *ct;
3001 struct slow_map_char_table_arg slarg;
3002 struct gcpro gcpro1, gcpro2;
3003 struct chartab_range rainj;
3005 CHECK_CHAR_TABLE (char_table);
3006 ct = XCHAR_TABLE (char_table);
3009 decode_char_table_range (range, &rainj);
3010 slarg.function = function;
3011 slarg.retval = Qnil;
3012 GCPRO2 (slarg.function, slarg.retval);
3013 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3016 return slarg.retval;
3020 /************************************************************************/
3021 /* Character Attributes */
3022 /************************************************************************/
3026 Lisp_Object Vchar_attribute_hash_table;
3028 /* We store the char-attributes in hash tables with the names as the
3029 key and the actual char-id-table object as the value. Occasionally
3030 we need to use them in a list format. These routines provide us
3032 struct char_attribute_list_closure
3034 Lisp_Object *char_attribute_list;
3038 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3039 void *char_attribute_list_closure)
3041 /* This function can GC */
3042 struct char_attribute_list_closure *calcl
3043 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3044 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3046 *char_attribute_list = Fcons (key, *char_attribute_list);
3050 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3051 Return the list of all existing character attributes except coded-charsets.
3055 Lisp_Object char_attribute_list = Qnil;
3056 struct gcpro gcpro1;
3057 struct char_attribute_list_closure char_attribute_list_closure;
3059 GCPRO1 (char_attribute_list);
3060 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3061 elisp_maphash (add_char_attribute_to_list_mapper,
3062 Vchar_attribute_hash_table,
3063 &char_attribute_list_closure);
3065 return char_attribute_list;
3068 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3069 Return char-id-table corresponding to ATTRIBUTE.
3073 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3077 /* We store the char-id-tables in hash tables with the attributes as
3078 the key and the actual char-id-table object as the value. Each
3079 char-id-table stores values of an attribute corresponding with
3080 characters. Occasionally we need to get attributes of a character
3081 in a association-list format. These routines provide us with
3083 struct char_attribute_alist_closure
3086 Lisp_Object *char_attribute_alist;
3090 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3091 void *char_attribute_alist_closure)
3093 /* This function can GC */
3094 struct char_attribute_alist_closure *caacl =
3095 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3097 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3098 if (!UNBOUNDP (ret))
3100 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3101 *char_attribute_alist
3102 = Fcons (Fcons (key, ret), *char_attribute_alist);
3107 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3108 Return the alist of attributes of CHARACTER.
3112 struct gcpro gcpro1;
3113 struct char_attribute_alist_closure char_attribute_alist_closure;
3114 Lisp_Object alist = Qnil;
3116 CHECK_CHAR (character);
3119 char_attribute_alist_closure.char_id = XCHAR (character);
3120 char_attribute_alist_closure.char_attribute_alist = &alist;
3121 elisp_maphash (add_char_attribute_alist_mapper,
3122 Vchar_attribute_hash_table,
3123 &char_attribute_alist_closure);
3129 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3130 Return the value of CHARACTER's ATTRIBUTE.
3131 Return DEFAULT-VALUE if the value is not exist.
3133 (character, attribute, default_value))
3137 CHECK_CHAR (character);
3139 if (CHARSETP (attribute))
3140 attribute = XCHARSET_NAME (attribute);
3142 table = Fgethash (attribute, Vchar_attribute_hash_table,
3144 if (!UNBOUNDP (table))
3146 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3148 if (!UNBOUNDP (ret))
3151 return default_value;
3154 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3155 Store CHARACTER's ATTRIBUTE with VALUE.
3157 (character, attribute, value))
3159 Lisp_Object ccs = Ffind_charset (attribute);
3163 CHECK_CHAR (character);
3164 value = put_char_ccs_code_point (character, ccs, value);
3166 else if (EQ (attribute, Q_decomposition))
3170 CHECK_CHAR (character);
3172 signal_simple_error ("Invalid value for ->decomposition",
3175 if (CONSP (Fcdr (value)))
3177 Lisp_Object rest = value;
3178 Lisp_Object table = Vcharacter_composition_table;
3182 GET_EXTERNAL_LIST_LENGTH (rest, len);
3183 seq = make_vector (len, Qnil);
3185 while (CONSP (rest))
3187 Lisp_Object v = Fcar (rest);
3190 = to_char_id (v, "Invalid value for ->decomposition", value);
3193 XVECTOR_DATA(seq)[i++] = v;
3195 XVECTOR_DATA(seq)[i++] = make_char (c);
3199 put_char_id_table (XCHAR_TABLE(table),
3200 make_char (c), character);
3205 ntable = get_char_id_table (XCHAR_TABLE(table), c);
3206 if (!CHAR_TABLEP (ntable))
3208 ntable = make_char_id_table (Qnil);
3209 put_char_id_table (XCHAR_TABLE(table),
3210 make_char (c), ntable);
3218 Lisp_Object v = Fcar (value);
3222 Emchar c = XINT (v);
3224 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3229 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3230 make_char (c), Fcons (character, Qnil));
3232 else if (NILP (Fmemq (v, ret)))
3234 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3235 make_char (c), Fcons (character, ret));
3238 seq = make_vector (1, v);
3242 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3247 CHECK_CHAR (character);
3249 signal_simple_error ("Invalid value for ->ucs", value);
3253 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
3256 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3257 make_char (c), Fcons (character, Qnil));
3259 else if (NILP (Fmemq (character, ret)))
3261 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3262 make_char (c), Fcons (character, ret));
3265 if (EQ (attribute, Q_ucs))
3266 attribute = Qto_ucs;
3270 Lisp_Object table = Fgethash (attribute,
3271 Vchar_attribute_hash_table,
3276 table = make_char_id_table (Qunbound);
3277 Fputhash (attribute, table, Vchar_attribute_hash_table);
3278 #ifdef HAVE_DATABASE
3279 XCHAR_TABLE_NAME (table) = attribute;
3282 put_char_id_table (XCHAR_TABLE(table), character, value);
3287 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3288 Remove CHARACTER's ATTRIBUTE.
3290 (character, attribute))
3294 CHECK_CHAR (character);
3295 ccs = Ffind_charset (attribute);
3298 return remove_char_ccs (character, ccs);
3302 Lisp_Object table = Fgethash (attribute,
3303 Vchar_attribute_hash_table,
3305 if (!UNBOUNDP (table))
3307 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3315 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3318 Lisp_Object db_dir = Vexec_directory;
3321 db_dir = build_string ("../lib-src");
3323 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3324 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3325 Fmake_directory_internal (db_dir);
3327 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3328 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3329 Fmake_directory_internal (db_dir);
3332 Lisp_Object attribute_name = Fsymbol_name (attribute);
3333 Lisp_Object dest = Qnil, ret;
3335 struct gcpro gcpro1, gcpro2;
3336 int len = XSTRING_CHAR_LENGTH (attribute_name);
3340 for (i = 0; i < len; i++)
3342 Emchar c = string_char (XSTRING (attribute_name), i);
3344 if ( (c == '/') || (c == '%') )
3348 sprintf (str, "%%%02X", c);
3349 dest = concat3 (dest,
3350 Fsubstring (attribute_name,
3351 make_int (base), make_int (i)),
3352 build_string (str));
3356 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3357 dest = concat2 (dest, ret);
3359 return Fexpand_file_name (dest, db_dir);
3362 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3366 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3367 Save values of ATTRIBUTE into database file.
3371 #ifdef HAVE_DATABASE
3372 Lisp_Object table = Fgethash (attribute,
3373 Vchar_attribute_hash_table, Qunbound);
3374 Lisp_Char_Table *ct;
3375 Lisp_Object db_file;
3378 if (CHAR_TABLEP (table))
3379 ct = XCHAR_TABLE (table);
3383 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3384 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3387 if (UINT8_BYTE_TABLE_P (ct->table))
3388 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db, 0, 3);
3389 else if (UINT16_BYTE_TABLE_P (ct->table))
3390 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db, 0, 3);
3391 else if (BYTE_TABLE_P (ct->table))
3392 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3);
3393 Fclose_database (db);
3403 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3404 Close database of ATTRIBUTE.
3408 #ifdef HAVE_DATABASE
3409 Lisp_Object table = Fgethash (attribute,
3410 Vchar_attribute_hash_table, Qunbound);
3411 Lisp_Char_Table *ct;
3413 if (CHAR_TABLEP (table))
3414 ct = XCHAR_TABLE (table);
3420 if (!NILP (Fdatabase_live_p (ct->db)))
3421 Fclose_database (ct->db);
3428 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3429 Reset values of ATTRIBUTE with database file.
3433 #ifdef HAVE_DATABASE
3434 Lisp_Object table = Fgethash (attribute,
3435 Vchar_attribute_hash_table, Qunbound);
3436 Lisp_Char_Table *ct;
3438 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3440 if (!NILP (Ffile_exists_p (db_file)))
3442 if (UNBOUNDP (table))
3444 table = make_char_id_table (Qunbound);
3445 Fputhash (attribute, table, Vchar_attribute_hash_table);
3446 XCHAR_TABLE_NAME(table) = attribute;
3448 ct = XCHAR_TABLE (table);
3449 ct->table = Qunloaded;
3450 if (!NILP (Fdatabase_live_p (ct->db)))
3451 Fclose_database (ct->db);
3453 XCHAR_TABLE_UNLOADED(table) = 1;
3460 #ifdef HAVE_DATABASE
3462 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3464 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3466 if (!NILP (attribute))
3468 if (NILP (Fdatabase_live_p (cit->db)))
3471 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3473 cit->db = Fopen_database (db_file, Qnil, Qnil, build_string ("r"), Qnil);
3475 if (!NILP (cit->db))
3478 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3480 if (!UNBOUNDP (val))
3490 Lisp_Char_Table* char_attribute_table_to_load;
3492 Lisp_Object Qload_char_attribute_table_map_function;
3494 DEFUN ("load-char-attribute-table-map-function",
3495 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3496 For internal use. Don't use it.
3500 Lisp_Object c = Fread (key);
3501 Emchar code = XCHAR (c);
3502 Lisp_Object ret = get_char_id_table (char_attribute_table_to_load, code);
3504 if (EQ (ret, Qunloaded))
3505 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3510 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3511 Load values of ATTRIBUTE into database file.
3515 #ifdef HAVE_DATABASE
3516 Lisp_Object table = Fgethash (attribute,
3517 Vchar_attribute_hash_table,
3519 if (CHAR_TABLEP (table))
3521 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3523 if (NILP (Fdatabase_live_p (ct->db)))
3526 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3528 ct->db = Fopen_database (db_file, Qnil, Qnil, build_string ("r"), Qnil);
3532 struct gcpro gcpro1;
3534 char_attribute_table_to_load = XCHAR_TABLE (table);
3536 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3538 Fclose_database (ct->db);
3540 XCHAR_TABLE_UNLOADED(table) = 0;
3548 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3549 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3550 each key and value in the table.
3552 RANGE specifies a subrange to map over and is in the same format as
3553 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3556 (function, attribute, range))
3559 Lisp_Char_Table *ct;
3560 struct slow_map_char_table_arg slarg;
3561 struct gcpro gcpro1, gcpro2;
3562 struct chartab_range rainj;
3564 if (!NILP (ccs = Ffind_charset (attribute)))
3566 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3568 if (CHAR_TABLEP (encoding_table))
3569 ct = XCHAR_TABLE (encoding_table);
3575 Lisp_Object table = Fgethash (attribute,
3576 Vchar_attribute_hash_table,
3578 if (CHAR_TABLEP (table))
3579 ct = XCHAR_TABLE (table);
3585 decode_char_table_range (range, &rainj);
3586 #ifdef HAVE_DATABASE
3587 if (CHAR_TABLE_UNLOADED(ct))
3588 Fload_char_attribute_table (attribute);
3590 slarg.function = function;
3591 slarg.retval = Qnil;
3592 GCPRO2 (slarg.function, slarg.retval);
3593 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3596 return slarg.retval;
3599 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3600 Store character's ATTRIBUTES.
3604 Lisp_Object rest = attributes;
3605 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3606 Lisp_Object character;
3610 while (CONSP (rest))
3612 Lisp_Object cell = Fcar (rest);
3616 signal_simple_error ("Invalid argument", attributes);
3617 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3618 && ((XCHARSET_FINAL (ccs) != 0) ||
3619 (XCHARSET_MAX_CODE (ccs) > 0) ||
3620 (EQ (ccs, Vcharset_chinese_big5))) )
3624 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3626 character = Fdecode_char (ccs, cell, Qnil);
3627 if (!NILP (character))
3628 goto setup_attributes;
3632 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3633 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3637 signal_simple_error ("Invalid argument", attributes);
3639 character = make_char (XINT (code) + 0x100000);
3640 goto setup_attributes;
3644 else if (!INTP (code))
3645 signal_simple_error ("Invalid argument", attributes);
3647 character = make_char (XINT (code));
3651 while (CONSP (rest))
3653 Lisp_Object cell = Fcar (rest);
3656 signal_simple_error ("Invalid argument", attributes);
3658 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3664 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3665 Retrieve the character of the given ATTRIBUTES.
3669 Lisp_Object rest = attributes;
3672 while (CONSP (rest))
3674 Lisp_Object cell = Fcar (rest);
3678 signal_simple_error ("Invalid argument", attributes);
3679 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3683 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3685 return Fdecode_char (ccs, cell, Qnil);
3689 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3690 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3693 signal_simple_error ("Invalid argument", attributes);
3695 return make_char (XINT (code) + 0x100000);
3703 /************************************************************************/
3704 /* Char table read syntax */
3705 /************************************************************************/
3708 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3709 Error_behavior errb)
3711 /* #### should deal with ERRB */
3712 symbol_to_char_table_type (value);
3717 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3718 Error_behavior errb)
3722 /* #### should deal with ERRB */
3723 EXTERNAL_LIST_LOOP (rest, value)
3725 Lisp_Object range = XCAR (rest);
3726 struct chartab_range dummy;
3730 signal_simple_error ("Invalid list format", value);
3733 if (!CONSP (XCDR (range))
3734 || !NILP (XCDR (XCDR (range))))
3735 signal_simple_error ("Invalid range format", range);
3736 decode_char_table_range (XCAR (range), &dummy);
3737 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3740 decode_char_table_range (range, &dummy);
3747 chartab_instantiate (Lisp_Object data)
3749 Lisp_Object chartab;
3750 Lisp_Object type = Qgeneric;
3751 Lisp_Object dataval = Qnil;
3753 while (!NILP (data))
3755 Lisp_Object keyw = Fcar (data);
3761 if (EQ (keyw, Qtype))
3763 else if (EQ (keyw, Qdata))
3767 chartab = Fmake_char_table (type);
3770 while (!NILP (data))
3772 Lisp_Object range = Fcar (data);
3773 Lisp_Object val = Fcar (Fcdr (data));
3775 data = Fcdr (Fcdr (data));
3778 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3780 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3781 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3784 for (i = first; i <= last; i++)
3785 Fput_char_table (make_char (i), val, chartab);
3791 Fput_char_table (range, val, chartab);
3800 /************************************************************************/
3801 /* Category Tables, specifically */
3802 /************************************************************************/
3804 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3805 Return t if OBJECT is a category table.
3806 A category table is a type of char table used for keeping track of
3807 categories. Categories are used for classifying characters for use
3808 in regexps -- you can refer to a category rather than having to use
3809 a complicated [] expression (and category lookups are significantly
3812 There are 95 different categories available, one for each printable
3813 character (including space) in the ASCII charset. Each category
3814 is designated by one such character, called a "category designator".
3815 They are specified in a regexp using the syntax "\\cX", where X is
3816 a category designator.
3818 A category table specifies, for each character, the categories that
3819 the character is in. Note that a character can be in more than one
3820 category. More specifically, a category table maps from a character
3821 to either the value nil (meaning the character is in no categories)
3822 or a 95-element bit vector, specifying for each of the 95 categories
3823 whether the character is in that category.
3825 Special Lisp functions are provided that abstract this, so you do not
3826 have to directly manipulate bit vectors.
3830 return (CHAR_TABLEP (object) &&
3831 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3836 check_category_table (Lisp_Object object, Lisp_Object default_)
3840 while (NILP (Fcategory_table_p (object)))
3841 object = wrong_type_argument (Qcategory_table_p, object);
3846 check_category_char (Emchar ch, Lisp_Object table,
3847 unsigned int designator, unsigned int not_p)
3849 REGISTER Lisp_Object temp;
3850 Lisp_Char_Table *ctbl;
3851 #ifdef ERROR_CHECK_TYPECHECK
3852 if (NILP (Fcategory_table_p (table)))
3853 signal_simple_error ("Expected category table", table);
3855 ctbl = XCHAR_TABLE (table);
3856 temp = get_char_table (ch, ctbl);
3861 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3864 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3865 Return t if category of the character at POSITION includes DESIGNATOR.
3866 Optional third arg BUFFER specifies which buffer to use, and defaults
3867 to the current buffer.
3868 Optional fourth arg CATEGORY-TABLE specifies the category table to
3869 use, and defaults to BUFFER's category table.
3871 (position, designator, buffer, category_table))
3876 struct buffer *buf = decode_buffer (buffer, 0);
3878 CHECK_INT (position);
3879 CHECK_CATEGORY_DESIGNATOR (designator);
3880 des = XCHAR (designator);
3881 ctbl = check_category_table (category_table, Vstandard_category_table);
3882 ch = BUF_FETCH_CHAR (buf, XINT (position));
3883 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3886 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3887 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3888 Optional third arg CATEGORY-TABLE specifies the category table to use,
3889 and defaults to the standard category table.
3891 (character, designator, category_table))
3897 CHECK_CATEGORY_DESIGNATOR (designator);
3898 des = XCHAR (designator);
3899 CHECK_CHAR (character);
3900 ch = XCHAR (character);
3901 ctbl = check_category_table (category_table, Vstandard_category_table);
3902 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3905 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3906 Return BUFFER's current category table.
3907 BUFFER defaults to the current buffer.
3911 return decode_buffer (buffer, 0)->category_table;
3914 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3915 Return the standard category table.
3916 This is the one used for new buffers.
3920 return Vstandard_category_table;
3923 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3924 Return a new category table which is a copy of CATEGORY-TABLE.
3925 CATEGORY-TABLE defaults to the standard category table.
3929 if (NILP (Vstandard_category_table))
3930 return Fmake_char_table (Qcategory);
3933 check_category_table (category_table, Vstandard_category_table);
3934 return Fcopy_char_table (category_table);
3937 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3938 Select CATEGORY-TABLE as the new category table for BUFFER.
3939 BUFFER defaults to the current buffer if omitted.
3941 (category_table, buffer))
3943 struct buffer *buf = decode_buffer (buffer, 0);
3944 category_table = check_category_table (category_table, Qnil);
3945 buf->category_table = category_table;
3946 /* Indicate that this buffer now has a specified category table. */
3947 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3948 return category_table;
3951 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3952 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3956 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3959 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3960 Return t if OBJECT is a category table value.
3961 Valid values are nil or a bit vector of size 95.
3965 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3969 #define CATEGORYP(x) \
3970 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3972 #define CATEGORY_SET(c) \
3973 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3975 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3976 The faster version of `!NILP (Faref (category_set, category))'. */
3977 #define CATEGORY_MEMBER(category, category_set) \
3978 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3980 /* Return 1 if there is a word boundary between two word-constituent
3981 characters C1 and C2 if they appear in this order, else return 0.
3982 Use the macro WORD_BOUNDARY_P instead of calling this function
3985 int word_boundary_p (Emchar c1, Emchar c2);
3987 word_boundary_p (Emchar c1, Emchar c2)
3989 Lisp_Object category_set1, category_set2;
3994 if (COMPOSITE_CHAR_P (c1))
3995 c1 = cmpchar_component (c1, 0, 1);
3996 if (COMPOSITE_CHAR_P (c2))
3997 c2 = cmpchar_component (c2, 0, 1);
4000 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4002 tail = Vword_separating_categories;
4007 tail = Vword_combining_categories;
4011 category_set1 = CATEGORY_SET (c1);
4012 if (NILP (category_set1))
4013 return default_result;
4014 category_set2 = CATEGORY_SET (c2);
4015 if (NILP (category_set2))
4016 return default_result;
4018 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4020 Lisp_Object elt = XCONS(tail)->car;
4023 && CATEGORYP (XCONS (elt)->car)
4024 && CATEGORYP (XCONS (elt)->cdr)
4025 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4026 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4027 return !default_result;
4029 return default_result;
4035 syms_of_chartab (void)
4038 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4039 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4040 INIT_LRECORD_IMPLEMENTATION (byte_table);
4042 defsymbol (&Qsystem_char_id, "system-char-id");
4044 defsymbol (&Qto_ucs, "=>ucs");
4045 defsymbol (&Q_ucs, "->ucs");
4046 defsymbol (&Q_ucs_variants, "->ucs-variants");
4047 defsymbol (&Q_decomposition, "->decomposition");
4048 defsymbol (&Qcompat, "compat");
4049 defsymbol (&Qisolated, "isolated");
4050 defsymbol (&Qinitial, "initial");
4051 defsymbol (&Qmedial, "medial");
4052 defsymbol (&Qfinal, "final");
4053 defsymbol (&Qvertical, "vertical");
4054 defsymbol (&QnoBreak, "noBreak");
4055 defsymbol (&Qfraction, "fraction");
4056 defsymbol (&Qsuper, "super");
4057 defsymbol (&Qsub, "sub");
4058 defsymbol (&Qcircle, "circle");
4059 defsymbol (&Qsquare, "square");
4060 defsymbol (&Qwide, "wide");
4061 defsymbol (&Qnarrow, "narrow");
4062 defsymbol (&Qsmall, "small");
4063 defsymbol (&Qfont, "font");
4065 DEFSUBR (Fchar_attribute_list);
4066 DEFSUBR (Ffind_char_attribute_table);
4067 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4068 DEFSUBR (Fput_char_table_map_function);
4069 DEFSUBR (Fsave_char_attribute_table);
4070 DEFSUBR (Freset_char_attribute_table);
4071 DEFSUBR (Fclose_char_attribute_table);
4072 #ifdef HAVE_DATABASE
4073 defsymbol (&Qload_char_attribute_table_map_function,
4074 "load-char-attribute-table-map-function");
4075 DEFSUBR (Fload_char_attribute_table_map_function);
4077 DEFSUBR (Fload_char_attribute_table);
4078 DEFSUBR (Fchar_attribute_alist);
4079 DEFSUBR (Fget_char_attribute);
4080 DEFSUBR (Fput_char_attribute);
4081 DEFSUBR (Fremove_char_attribute);
4082 DEFSUBR (Fmap_char_attribute);
4083 DEFSUBR (Fdefine_char);
4084 DEFSUBR (Ffind_char);
4085 DEFSUBR (Fchar_variants);
4087 DEFSUBR (Fget_composite_char);
4090 INIT_LRECORD_IMPLEMENTATION (char_table);
4094 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4097 defsymbol (&Qcategory_table_p, "category-table-p");
4098 defsymbol (&Qcategory_designator_p, "category-designator-p");
4099 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4102 defsymbol (&Qchar_table, "char-table");
4103 defsymbol (&Qchar_tablep, "char-table-p");
4105 DEFSUBR (Fchar_table_p);
4106 DEFSUBR (Fchar_table_type_list);
4107 DEFSUBR (Fvalid_char_table_type_p);
4108 DEFSUBR (Fchar_table_type);
4109 DEFSUBR (Freset_char_table);
4110 DEFSUBR (Fmake_char_table);
4111 DEFSUBR (Fcopy_char_table);
4112 DEFSUBR (Fget_char_table);
4113 DEFSUBR (Fget_range_char_table);
4114 DEFSUBR (Fvalid_char_table_value_p);
4115 DEFSUBR (Fcheck_valid_char_table_value);
4116 DEFSUBR (Fput_char_table);
4117 DEFSUBR (Fmap_char_table);
4120 DEFSUBR (Fcategory_table_p);
4121 DEFSUBR (Fcategory_table);
4122 DEFSUBR (Fstandard_category_table);
4123 DEFSUBR (Fcopy_category_table);
4124 DEFSUBR (Fset_category_table);
4125 DEFSUBR (Fcheck_category_at);
4126 DEFSUBR (Fchar_in_category_p);
4127 DEFSUBR (Fcategory_designator_p);
4128 DEFSUBR (Fcategory_table_value_p);
4134 vars_of_chartab (void)
4137 staticpro (&Vcharacter_composition_table);
4138 Vcharacter_composition_table = make_char_id_table (Qnil);
4140 staticpro (&Vcharacter_variant_table);
4141 Vcharacter_variant_table = make_char_id_table (Qunbound);
4143 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4144 Vall_syntax_tables = Qnil;
4145 dump_add_weak_object_chain (&Vall_syntax_tables);
4149 structure_type_create_chartab (void)
4151 struct structure_type *st;
4153 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4155 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4156 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4160 complex_vars_of_chartab (void)
4163 staticpro (&Vchar_attribute_hash_table);
4164 Vchar_attribute_hash_table
4165 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4166 #ifdef HAVE_DATABASE
4167 Fputhash (Q_ucs_variants, Vcharacter_variant_table,
4168 Vchar_attribute_hash_table);
4169 XCHAR_TABLE_NAME (Vcharacter_variant_table) = Q_ucs_variants;
4170 #endif /* HAVE_DATABASE */
4171 #endif /* UTF2000 */
4173 /* Set this now, so first buffer creation can refer to it. */
4174 /* Make it nil before calling copy-category-table
4175 so that copy-category-table will know not to try to copy from garbage */
4176 Vstandard_category_table = Qnil;
4177 Vstandard_category_table = Fcopy_category_table (Qnil);
4178 staticpro (&Vstandard_category_table);
4180 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4181 List of pair (cons) of categories to determine word boundary.
4183 Emacs treats a sequence of word constituent characters as a single
4184 word (i.e. finds no word boundary between them) iff they belongs to
4185 the same charset. But, exceptions are allowed in the following cases.
4187 \(1) The case that characters are in different charsets is controlled
4188 by the variable `word-combining-categories'.
4190 Emacs finds no word boundary between characters of different charsets
4191 if they have categories matching some element of this list.
4193 More precisely, if an element of this list is a cons of category CAT1
4194 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4195 C2 which has CAT2, there's no word boundary between C1 and C2.
4197 For instance, to tell that ASCII characters and Latin-1 characters can
4198 form a single word, the element `(?l . ?l)' should be in this list
4199 because both characters have the category `l' (Latin characters).
4201 \(2) The case that character are in the same charset is controlled by
4202 the variable `word-separating-categories'.
4204 Emacs find a word boundary between characters of the same charset
4205 if they have categories matching some element of this list.
4207 More precisely, if an element of this list is a cons of category CAT1
4208 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4209 C2 which has CAT2, there's a word boundary between C1 and C2.
4211 For instance, to tell that there's a word boundary between Japanese
4212 Hiragana and Japanese Kanji (both are in the same charset), the
4213 element `(?H . ?C) should be in this list.
4216 Vword_combining_categories = Qnil;
4218 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4219 List of pair (cons) of categories to determine word boundary.
4220 See the documentation of the variable `word-combining-categories'.
4223 Vword_separating_categories = Qnil;