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]),
351 #define BT_UINT16_MIN 0
352 #define BT_UINT16_MAX (USHRT_MAX - 4)
353 #define BT_UINT16_t (USHRT_MAX - 3)
354 #define BT_UINT16_nil (USHRT_MAX - 2)
355 #define BT_UINT16_unbound (USHRT_MAX - 1)
356 #define BT_UINT16_unloaded USHRT_MAX
358 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
359 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
360 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
361 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
364 INT_UINT16_P (Lisp_Object obj)
368 int num = XINT (obj);
370 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
377 UINT16_VALUE_P (Lisp_Object obj)
379 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
380 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
383 INLINE_HEADER unsigned short
384 UINT16_ENCODE (Lisp_Object obj)
386 if (EQ (obj, Qunloaded))
387 return BT_UINT16_unloaded;
388 else if (EQ (obj, Qunbound))
389 return BT_UINT16_unbound;
390 else if (EQ (obj, Qnil))
391 return BT_UINT16_nil;
392 else if (EQ (obj, Qt))
398 INLINE_HEADER Lisp_Object
399 UINT16_DECODE (unsigned short n)
401 if (n == BT_UINT16_unloaded)
403 else if (n == BT_UINT16_unbound)
405 else if (n == BT_UINT16_nil)
407 else if (n == BT_UINT16_t)
413 INLINE_HEADER unsigned short
414 UINT8_TO_UINT16 (unsigned char n)
416 if (n == BT_UINT8_unloaded)
417 return BT_UINT16_unloaded;
418 else if (n == BT_UINT8_unbound)
419 return BT_UINT16_unbound;
420 else if (n == BT_UINT8_nil)
421 return BT_UINT16_nil;
422 else if (n == BT_UINT8_t)
429 mark_uint16_byte_table (Lisp_Object obj)
435 print_uint16_byte_table (Lisp_Object obj,
436 Lisp_Object printcharfun, int escapeflag)
438 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
440 struct gcpro gcpro1, gcpro2;
441 GCPRO2 (obj, printcharfun);
443 write_c_string ("\n#<uint16-byte-table", printcharfun);
444 for (i = 0; i < 256; i++)
446 unsigned short n = bte->property[i];
448 write_c_string ("\n ", printcharfun);
449 write_c_string (" ", printcharfun);
450 if (n == BT_UINT16_unbound)
451 write_c_string ("void", printcharfun);
452 else if (n == BT_UINT16_nil)
453 write_c_string ("nil", printcharfun);
454 else if (n == BT_UINT16_t)
455 write_c_string ("t", printcharfun);
460 sprintf (buf, "%hd", n);
461 write_c_string (buf, printcharfun);
465 write_c_string (">", printcharfun);
469 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
471 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
472 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
475 for (i = 0; i < 256; i++)
476 if (te1->property[i] != te2->property[i])
482 uint16_byte_table_hash (Lisp_Object obj, int depth)
484 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
488 for (i = 0; i < 256; i++)
489 hash = HASH2 (hash, te->property[i]);
493 static const struct lrecord_description uint16_byte_table_description[] = {
497 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
498 mark_uint16_byte_table,
499 print_uint16_byte_table,
500 0, uint16_byte_table_equal,
501 uint16_byte_table_hash,
502 uint16_byte_table_description,
503 Lisp_Uint16_Byte_Table);
506 make_uint16_byte_table (unsigned short initval)
510 Lisp_Uint16_Byte_Table *cte;
512 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
513 &lrecord_uint16_byte_table);
515 for (i = 0; i < 256; i++)
516 cte->property[i] = initval;
518 XSETUINT16_BYTE_TABLE (obj, cte);
523 copy_uint16_byte_table (Lisp_Object entry)
525 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
528 Lisp_Uint16_Byte_Table *ctenew
529 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
530 &lrecord_uint16_byte_table);
532 for (i = 0; i < 256; i++)
534 ctenew->property[i] = cte->property[i];
537 XSETUINT16_BYTE_TABLE (obj, ctenew);
542 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
546 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
547 Lisp_Uint16_Byte_Table* cte;
549 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
550 &lrecord_uint16_byte_table);
551 for (i = 0; i < 256; i++)
553 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
555 XSETUINT16_BYTE_TABLE (obj, cte);
560 uint16_byte_table_same_value_p (Lisp_Object obj)
562 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
563 unsigned short v0 = bte->property[0];
566 for (i = 1; i < 256; i++)
568 if (bte->property[i] != v0)
575 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
576 Emchar ofs, int place,
577 int (*fn) (struct chartab_range *range,
578 Lisp_Object val, void *arg),
581 struct chartab_range rainj;
583 int unit = 1 << (8 * place);
587 rainj.type = CHARTAB_RANGE_CHAR;
589 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
591 if (ct->property[i] == BT_UINT16_unloaded)
595 for (; c < c1 && retval == 0; c++)
597 Lisp_Object ret = get_char_id_table (root, c);
602 retval = (fn) (&rainj, ret, arg);
606 ct->property[i] = BT_UINT16_unbound;
610 else if (ct->property[i] != BT_UINT16_unbound)
613 for (; c < c1 && retval == 0; c++)
616 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
627 save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
629 Emchar ofs, int place)
631 struct chartab_range rainj;
633 int unit = 1 << (8 * place);
637 rainj.type = CHARTAB_RANGE_CHAR;
639 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
641 if (ct->property[i] == BT_UINT16_unloaded)
645 else if (ct->property[i] != BT_UINT16_unbound)
648 for (; c < c1 && retval == 0; c++)
650 Fput_database (Fprin1_to_string (make_char (c), Qnil),
651 Fprin1_to_string (UINT16_DECODE (ct->property[i]),
664 mark_byte_table (Lisp_Object obj)
666 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
669 for (i = 0; i < 256; i++)
671 mark_object (cte->property[i]);
677 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
679 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
681 struct gcpro gcpro1, gcpro2;
682 GCPRO2 (obj, printcharfun);
684 write_c_string ("\n#<byte-table", printcharfun);
685 for (i = 0; i < 256; i++)
687 Lisp_Object elt = bte->property[i];
689 write_c_string ("\n ", printcharfun);
690 write_c_string (" ", printcharfun);
691 if (EQ (elt, Qunbound))
692 write_c_string ("void", printcharfun);
694 print_internal (elt, printcharfun, escapeflag);
697 write_c_string (">", printcharfun);
701 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
703 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
704 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
707 for (i = 0; i < 256; i++)
708 if (BYTE_TABLE_P (cte1->property[i]))
710 if (BYTE_TABLE_P (cte2->property[i]))
712 if (!byte_table_equal (cte1->property[i],
713 cte2->property[i], depth + 1))
720 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
726 byte_table_hash (Lisp_Object obj, int depth)
728 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
730 return internal_array_hash (cte->property, 256, depth);
733 static const struct lrecord_description byte_table_description[] = {
734 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
738 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
743 byte_table_description,
747 make_byte_table (Lisp_Object initval)
751 Lisp_Byte_Table *cte;
753 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
755 for (i = 0; i < 256; i++)
756 cte->property[i] = initval;
758 XSETBYTE_TABLE (obj, cte);
763 copy_byte_table (Lisp_Object entry)
765 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
768 Lisp_Byte_Table *ctnew
769 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
771 for (i = 0; i < 256; i++)
773 if (UINT8_BYTE_TABLE_P (cte->property[i]))
775 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
777 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
779 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
781 else if (BYTE_TABLE_P (cte->property[i]))
783 ctnew->property[i] = copy_byte_table (cte->property[i]);
786 ctnew->property[i] = cte->property[i];
789 XSETBYTE_TABLE (obj, ctnew);
794 byte_table_same_value_p (Lisp_Object obj)
796 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
797 Lisp_Object v0 = bte->property[0];
800 for (i = 1; i < 256; i++)
802 if (!internal_equal (bte->property[i], v0, 0))
809 map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
810 Emchar ofs, int place,
811 int (*fn) (struct chartab_range *range,
812 Lisp_Object val, void *arg),
817 int unit = 1 << (8 * place);
820 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
823 if (UINT8_BYTE_TABLE_P (v))
826 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
827 c, place - 1, fn, arg);
830 else if (UINT16_BYTE_TABLE_P (v))
833 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
834 c, place - 1, fn, arg);
837 else if (BYTE_TABLE_P (v))
839 retval = map_over_byte_table (XBYTE_TABLE(v), root,
840 c, place - 1, fn, arg);
843 else if (EQ (v, Qunloaded))
846 struct chartab_range rainj;
847 Emchar c1 = c + unit;
849 rainj.type = CHARTAB_RANGE_CHAR;
851 for (; c < c1 && retval == 0; c++)
853 Lisp_Object ret = get_char_id_table (root, c);
858 retval = (fn) (&rainj, ret, arg);
862 ct->property[i] = Qunbound;
866 else if (!UNBOUNDP (v))
868 struct chartab_range rainj;
869 Emchar c1 = c + unit;
871 rainj.type = CHARTAB_RANGE_CHAR;
873 for (; c < c1 && retval == 0; c++)
876 retval = (fn) (&rainj, v, arg);
887 save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
889 Emchar ofs, int place)
893 int unit = 1 << (8 * place);
896 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
899 if (UINT8_BYTE_TABLE_P (v))
901 save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db,
905 else if (UINT16_BYTE_TABLE_P (v))
907 save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db,
911 else if (BYTE_TABLE_P (v))
913 save_byte_table (XBYTE_TABLE(v), root, db,
917 else if (EQ (v, Qunloaded))
921 else if (!UNBOUNDP (v))
923 struct chartab_range rainj;
924 Emchar c1 = c + unit;
926 rainj.type = CHARTAB_RANGE_CHAR;
928 for (; c < c1 && retval == 0; c++)
930 Fput_database (Fprin1_to_string (make_char (c), Qnil),
931 Fprin1_to_string (v, Qnil),
942 get_byte_table (Lisp_Object table, unsigned char idx)
944 if (UINT8_BYTE_TABLE_P (table))
945 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
946 else if (UINT16_BYTE_TABLE_P (table))
947 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
948 else if (BYTE_TABLE_P (table))
949 return XBYTE_TABLE(table)->property[idx];
955 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
957 if (UINT8_BYTE_TABLE_P (table))
959 if (UINT8_VALUE_P (value))
961 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
962 if (!UINT8_BYTE_TABLE_P (value) &&
963 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
964 && uint8_byte_table_same_value_p (table))
969 else if (UINT16_VALUE_P (value))
971 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
973 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
978 Lisp_Object new = make_byte_table (Qnil);
981 for (i = 0; i < 256; i++)
983 XBYTE_TABLE(new)->property[i]
984 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
986 XBYTE_TABLE(new)->property[idx] = value;
990 else if (UINT16_BYTE_TABLE_P (table))
992 if (UINT16_VALUE_P (value))
994 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
995 if (!UINT8_BYTE_TABLE_P (value) &&
996 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
997 && uint16_byte_table_same_value_p (table))
1004 Lisp_Object new = make_byte_table (Qnil);
1007 for (i = 0; i < 256; i++)
1009 XBYTE_TABLE(new)->property[i]
1010 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
1012 XBYTE_TABLE(new)->property[idx] = value;
1016 else if (BYTE_TABLE_P (table))
1018 XBYTE_TABLE(table)->property[idx] = value;
1019 if (!UINT8_BYTE_TABLE_P (value) &&
1020 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1021 && byte_table_same_value_p (table))
1026 else if (!internal_equal (table, value, 0))
1028 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
1030 table = make_uint8_byte_table (UINT8_ENCODE (table));
1031 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
1033 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
1035 table = make_uint16_byte_table (UINT16_ENCODE (table));
1036 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1040 table = make_byte_table (table);
1041 XBYTE_TABLE(table)->property[idx] = value;
1049 make_char_id_table (Lisp_Object initval)
1052 obj = Fmake_char_table (Qgeneric);
1053 fill_char_table (XCHAR_TABLE (obj), initval);
1058 Lisp_Object Vcharacter_composition_table;
1059 Lisp_Object Vcharacter_variant_table;
1062 Lisp_Object Qsystem_char_id;
1064 Lisp_Object Q_decomposition;
1065 Lisp_Object Qto_ucs;
1067 Lisp_Object Q_ucs_variants;
1068 Lisp_Object Qcompat;
1069 Lisp_Object Qisolated;
1070 Lisp_Object Qinitial;
1071 Lisp_Object Qmedial;
1073 Lisp_Object Qvertical;
1074 Lisp_Object QnoBreak;
1075 Lisp_Object Qfraction;
1078 Lisp_Object Qcircle;
1079 Lisp_Object Qsquare;
1081 Lisp_Object Qnarrow;
1085 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1088 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1094 else if (EQ (v, Qcompat))
1096 else if (EQ (v, Qisolated))
1098 else if (EQ (v, Qinitial))
1100 else if (EQ (v, Qmedial))
1102 else if (EQ (v, Qfinal))
1104 else if (EQ (v, Qvertical))
1106 else if (EQ (v, QnoBreak))
1108 else if (EQ (v, Qfraction))
1110 else if (EQ (v, Qsuper))
1112 else if (EQ (v, Qsub))
1114 else if (EQ (v, Qcircle))
1116 else if (EQ (v, Qsquare))
1118 else if (EQ (v, Qwide))
1120 else if (EQ (v, Qnarrow))
1122 else if (EQ (v, Qsmall))
1124 else if (EQ (v, Qfont))
1127 signal_simple_error (err_msg, err_arg);
1130 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1131 Return character corresponding with list.
1135 Lisp_Object table = Vcharacter_composition_table;
1136 Lisp_Object rest = list;
1138 while (CONSP (rest))
1140 Lisp_Object v = Fcar (rest);
1142 Emchar c = to_char_id (v, "Invalid value for composition", list);
1144 ret = get_char_id_table (XCHAR_TABLE(table), c);
1149 if (!CHAR_TABLEP (ret))
1154 else if (!CONSP (rest))
1156 else if (CHAR_TABLEP (ret))
1159 signal_simple_error ("Invalid table is found with", list);
1161 signal_simple_error ("Invalid value for composition", list);
1164 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1165 Return variants of CHARACTER.
1171 CHECK_CHAR (character);
1172 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
1175 return Fcopy_list (ret);
1183 /* A char table maps from ranges of characters to values.
1185 Implementing a general data structure that maps from arbitrary
1186 ranges of numbers to values is tricky to do efficiently. As it
1187 happens, it should suffice (and is usually more convenient, anyway)
1188 when dealing with characters to restrict the sorts of ranges that
1189 can be assigned values, as follows:
1192 2) All characters in a charset.
1193 3) All characters in a particular row of a charset, where a "row"
1194 means all characters with the same first byte.
1195 4) A particular character in a charset.
1197 We use char tables to generalize the 256-element vectors now
1198 littering the Emacs code.
1200 Possible uses (all should be converted at some point):
1206 5) keyboard-translate-table?
1209 abstract type to generalize the Emacs vectors and Mule
1210 vectors-of-vectors goo.
1213 /************************************************************************/
1214 /* Char Table object */
1215 /************************************************************************/
1217 #if defined(MULE)&&!defined(UTF2000)
1220 mark_char_table_entry (Lisp_Object obj)
1222 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1225 for (i = 0; i < 96; i++)
1227 mark_object (cte->level2[i]);
1233 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1235 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1236 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1239 for (i = 0; i < 96; i++)
1240 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1246 static unsigned long
1247 char_table_entry_hash (Lisp_Object obj, int depth)
1249 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1251 return internal_array_hash (cte->level2, 96, depth);
1254 static const struct lrecord_description char_table_entry_description[] = {
1255 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1259 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1260 mark_char_table_entry, internal_object_printer,
1261 0, char_table_entry_equal,
1262 char_table_entry_hash,
1263 char_table_entry_description,
1264 Lisp_Char_Table_Entry);
1268 mark_char_table (Lisp_Object obj)
1270 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1273 mark_object (ct->table);
1274 mark_object (ct->name);
1275 mark_object (ct->db);
1279 for (i = 0; i < NUM_ASCII_CHARS; i++)
1280 mark_object (ct->ascii[i]);
1282 for (i = 0; i < NUM_LEADING_BYTES; i++)
1283 mark_object (ct->level1[i]);
1287 return ct->default_value;
1289 return ct->mirror_table;
1293 /* WARNING: All functions of this nature need to be written extremely
1294 carefully to avoid crashes during GC. Cf. prune_specifiers()
1295 and prune_weak_hash_tables(). */
1298 prune_syntax_tables (void)
1300 Lisp_Object rest, prev = Qnil;
1302 for (rest = Vall_syntax_tables;
1304 rest = XCHAR_TABLE (rest)->next_table)
1306 if (! marked_p (rest))
1308 /* This table is garbage. Remove it from the list. */
1310 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1312 XCHAR_TABLE (prev)->next_table =
1313 XCHAR_TABLE (rest)->next_table;
1319 char_table_type_to_symbol (enum char_table_type type)
1324 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1325 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1326 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1327 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1329 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1334 static enum char_table_type
1335 symbol_to_char_table_type (Lisp_Object symbol)
1337 CHECK_SYMBOL (symbol);
1339 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1340 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1341 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1342 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1344 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1347 signal_simple_error ("Unrecognized char table type", symbol);
1348 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1352 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1353 Lisp_Object printcharfun)
1357 write_c_string (" (", printcharfun);
1358 print_internal (make_char (first), printcharfun, 0);
1359 write_c_string (" ", printcharfun);
1360 print_internal (make_char (last), printcharfun, 0);
1361 write_c_string (") ", printcharfun);
1365 write_c_string (" ", printcharfun);
1366 print_internal (make_char (first), printcharfun, 0);
1367 write_c_string (" ", printcharfun);
1369 print_internal (val, printcharfun, 1);
1372 #if defined(MULE)&&!defined(UTF2000)
1375 print_chartab_charset_row (Lisp_Object charset,
1377 Lisp_Char_Table_Entry *cte,
1378 Lisp_Object printcharfun)
1381 Lisp_Object cat = Qunbound;
1384 for (i = 32; i < 128; i++)
1386 Lisp_Object pam = cte->level2[i - 32];
1398 print_chartab_range (MAKE_CHAR (charset, first, 0),
1399 MAKE_CHAR (charset, i - 1, 0),
1402 print_chartab_range (MAKE_CHAR (charset, row, first),
1403 MAKE_CHAR (charset, row, i - 1),
1413 print_chartab_range (MAKE_CHAR (charset, first, 0),
1414 MAKE_CHAR (charset, i - 1, 0),
1417 print_chartab_range (MAKE_CHAR (charset, row, first),
1418 MAKE_CHAR (charset, row, i - 1),
1424 print_chartab_two_byte_charset (Lisp_Object charset,
1425 Lisp_Char_Table_Entry *cte,
1426 Lisp_Object printcharfun)
1430 for (i = 32; i < 128; i++)
1432 Lisp_Object jen = cte->level2[i - 32];
1434 if (!CHAR_TABLE_ENTRYP (jen))
1438 write_c_string (" [", printcharfun);
1439 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1440 sprintf (buf, " %d] ", i);
1441 write_c_string (buf, printcharfun);
1442 print_internal (jen, printcharfun, 0);
1445 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1453 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1455 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1458 struct gcpro gcpro1, gcpro2;
1459 GCPRO2 (obj, printcharfun);
1461 write_c_string ("#s(char-table ", printcharfun);
1462 write_c_string (" ", printcharfun);
1463 write_c_string (string_data
1465 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1467 write_c_string ("\n ", printcharfun);
1468 print_internal (ct->default_value, printcharfun, escapeflag);
1469 for (i = 0; i < 256; i++)
1471 Lisp_Object elt = get_byte_table (ct->table, i);
1472 if (i != 0) write_c_string ("\n ", printcharfun);
1473 if (EQ (elt, Qunbound))
1474 write_c_string ("void", printcharfun);
1476 print_internal (elt, printcharfun, escapeflag);
1479 #else /* non UTF2000 */
1482 sprintf (buf, "#s(char-table type %s data (",
1483 string_data (symbol_name (XSYMBOL
1484 (char_table_type_to_symbol (ct->type)))));
1485 write_c_string (buf, printcharfun);
1487 /* Now write out the ASCII/Control-1 stuff. */
1491 Lisp_Object val = Qunbound;
1493 for (i = 0; i < NUM_ASCII_CHARS; i++)
1502 if (!EQ (ct->ascii[i], val))
1504 print_chartab_range (first, i - 1, val, printcharfun);
1511 print_chartab_range (first, i - 1, val, printcharfun);
1518 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1521 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1522 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1524 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1525 || i == LEADING_BYTE_CONTROL_1)
1527 if (!CHAR_TABLE_ENTRYP (ann))
1529 write_c_string (" ", printcharfun);
1530 print_internal (XCHARSET_NAME (charset),
1532 write_c_string (" ", printcharfun);
1533 print_internal (ann, printcharfun, 0);
1537 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1538 if (XCHARSET_DIMENSION (charset) == 1)
1539 print_chartab_charset_row (charset, -1, cte, printcharfun);
1541 print_chartab_two_byte_charset (charset, cte, printcharfun);
1546 #endif /* non UTF2000 */
1548 write_c_string ("))", printcharfun);
1552 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1554 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1555 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1558 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1562 for (i = 0; i < 256; i++)
1564 if (!internal_equal (get_byte_table (ct1->table, i),
1565 get_byte_table (ct2->table, i), 0))
1569 for (i = 0; i < NUM_ASCII_CHARS; i++)
1570 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1574 for (i = 0; i < NUM_LEADING_BYTES; i++)
1575 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1578 #endif /* non UTF2000 */
1583 static unsigned long
1584 char_table_hash (Lisp_Object obj, int depth)
1586 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1588 return byte_table_hash (ct->table, depth + 1);
1590 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1593 hashval = HASH2 (hashval,
1594 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1600 static const struct lrecord_description char_table_description[] = {
1602 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1603 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1604 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1605 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1607 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1609 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1613 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1615 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1619 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1620 mark_char_table, print_char_table, 0,
1621 char_table_equal, char_table_hash,
1622 char_table_description,
1625 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1626 Return non-nil if OBJECT is a char table.
1628 A char table is a table that maps characters (or ranges of characters)
1629 to values. Char tables are specialized for characters, only allowing
1630 particular sorts of ranges to be assigned values. Although this
1631 loses in generality, it makes for extremely fast (constant-time)
1632 lookups, and thus is feasible for applications that do an extremely
1633 large number of lookups (e.g. scanning a buffer for a character in
1634 a particular syntax, where a lookup in the syntax table must occur
1635 once per character).
1637 When Mule support exists, the types of ranges that can be assigned
1641 -- an entire charset
1642 -- a single row in a two-octet charset
1643 -- a single character
1645 When Mule support is not present, the types of ranges that can be
1649 -- a single character
1651 To create a char table, use `make-char-table'.
1652 To modify a char table, use `put-char-table' or `remove-char-table'.
1653 To retrieve the value for a particular character, use `get-char-table'.
1654 See also `map-char-table', `clear-char-table', `copy-char-table',
1655 `valid-char-table-type-p', `char-table-type-list',
1656 `valid-char-table-value-p', and `check-char-table-value'.
1660 return CHAR_TABLEP (object) ? Qt : Qnil;
1663 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1664 Return a list of the recognized char table types.
1665 See `valid-char-table-type-p'.
1670 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1672 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1676 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1677 Return t if TYPE if a recognized char table type.
1679 Each char table type is used for a different purpose and allows different
1680 sorts of values. The different char table types are
1683 Used for category tables, which specify the regexp categories
1684 that a character is in. The valid values are nil or a
1685 bit vector of 95 elements. Higher-level Lisp functions are
1686 provided for working with category tables. Currently categories
1687 and category tables only exist when Mule support is present.
1689 A generalized char table, for mapping from one character to
1690 another. Used for case tables, syntax matching tables,
1691 `keyboard-translate-table', etc. The valid values are characters.
1693 An even more generalized char table, for mapping from a
1694 character to anything.
1696 Used for display tables, which specify how a particular character
1697 is to appear when displayed. #### Not yet implemented.
1699 Used for syntax tables, which specify the syntax of a particular
1700 character. Higher-level Lisp functions are provided for
1701 working with syntax tables. The valid values are integers.
1706 return (EQ (type, Qchar) ||
1708 EQ (type, Qcategory) ||
1710 EQ (type, Qdisplay) ||
1711 EQ (type, Qgeneric) ||
1712 EQ (type, Qsyntax)) ? Qt : Qnil;
1715 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1716 Return the type of CHAR-TABLE.
1717 See `valid-char-table-type-p'.
1721 CHECK_CHAR_TABLE (char_table);
1722 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1726 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1729 ct->table = Qunbound;
1730 ct->default_value = value;
1735 for (i = 0; i < NUM_ASCII_CHARS; i++)
1736 ct->ascii[i] = value;
1738 for (i = 0; i < NUM_LEADING_BYTES; i++)
1739 ct->level1[i] = value;
1744 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1745 update_syntax_table (ct);
1749 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1750 Reset CHAR-TABLE to its default state.
1754 Lisp_Char_Table *ct;
1756 CHECK_CHAR_TABLE (char_table);
1757 ct = XCHAR_TABLE (char_table);
1761 case CHAR_TABLE_TYPE_CHAR:
1762 fill_char_table (ct, make_char (0));
1764 case CHAR_TABLE_TYPE_DISPLAY:
1765 case CHAR_TABLE_TYPE_GENERIC:
1767 case CHAR_TABLE_TYPE_CATEGORY:
1769 fill_char_table (ct, Qnil);
1772 case CHAR_TABLE_TYPE_SYNTAX:
1773 fill_char_table (ct, make_int (Sinherit));
1783 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1784 Return a new, empty char table of type TYPE.
1785 Currently recognized types are 'char, 'category, 'display, 'generic,
1786 and 'syntax. See `valid-char-table-type-p'.
1790 Lisp_Char_Table *ct;
1792 enum char_table_type ty = symbol_to_char_table_type (type);
1794 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1797 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1799 ct->mirror_table = Fmake_char_table (Qgeneric);
1800 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1804 ct->mirror_table = Qnil;
1809 ct->next_table = Qnil;
1810 XSETCHAR_TABLE (obj, ct);
1811 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1813 ct->next_table = Vall_syntax_tables;
1814 Vall_syntax_tables = obj;
1816 Freset_char_table (obj);
1820 #if defined(MULE)&&!defined(UTF2000)
1823 make_char_table_entry (Lisp_Object initval)
1827 Lisp_Char_Table_Entry *cte =
1828 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1830 for (i = 0; i < 96; i++)
1831 cte->level2[i] = initval;
1833 XSETCHAR_TABLE_ENTRY (obj, cte);
1838 copy_char_table_entry (Lisp_Object entry)
1840 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1843 Lisp_Char_Table_Entry *ctenew =
1844 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1846 for (i = 0; i < 96; i++)
1848 Lisp_Object new = cte->level2[i];
1849 if (CHAR_TABLE_ENTRYP (new))
1850 ctenew->level2[i] = copy_char_table_entry (new);
1852 ctenew->level2[i] = new;
1855 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1861 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1862 Return a new char table which is a copy of CHAR-TABLE.
1863 It will contain the same values for the same characters and ranges
1864 as CHAR-TABLE. The values will not themselves be copied.
1868 Lisp_Char_Table *ct, *ctnew;
1874 CHECK_CHAR_TABLE (char_table);
1875 ct = XCHAR_TABLE (char_table);
1876 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1877 ctnew->type = ct->type;
1879 ctnew->default_value = ct->default_value;
1880 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1881 ctnew->name = ct->name;
1884 if (UINT8_BYTE_TABLE_P (ct->table))
1886 ctnew->table = copy_uint8_byte_table (ct->table);
1888 else if (UINT16_BYTE_TABLE_P (ct->table))
1890 ctnew->table = copy_uint16_byte_table (ct->table);
1892 else if (BYTE_TABLE_P (ct->table))
1894 ctnew->table = copy_byte_table (ct->table);
1896 else if (!UNBOUNDP (ct->table))
1897 ctnew->table = ct->table;
1898 #else /* non UTF2000 */
1900 for (i = 0; i < NUM_ASCII_CHARS; i++)
1902 Lisp_Object new = ct->ascii[i];
1904 assert (! (CHAR_TABLE_ENTRYP (new)));
1906 ctnew->ascii[i] = new;
1911 for (i = 0; i < NUM_LEADING_BYTES; i++)
1913 Lisp_Object new = ct->level1[i];
1914 if (CHAR_TABLE_ENTRYP (new))
1915 ctnew->level1[i] = copy_char_table_entry (new);
1917 ctnew->level1[i] = new;
1921 #endif /* non UTF2000 */
1924 if (CHAR_TABLEP (ct->mirror_table))
1925 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1927 ctnew->mirror_table = ct->mirror_table;
1929 ctnew->next_table = Qnil;
1930 XSETCHAR_TABLE (obj, ctnew);
1931 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1933 ctnew->next_table = Vall_syntax_tables;
1934 Vall_syntax_tables = obj;
1939 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1941 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1943 switch (XCHARSET_CHARS (ccs))
1946 return (33 << 8) | 126;
1948 return (32 << 8) | 127;
1951 return (0 << 8) | 127;
1953 return (0 << 8) | 255;
1965 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1968 outrange->type = CHARTAB_RANGE_ALL;
1969 else if (EQ (range, Qnil))
1970 outrange->type = CHARTAB_RANGE_DEFAULT;
1971 else if (CHAR_OR_CHAR_INTP (range))
1973 outrange->type = CHARTAB_RANGE_CHAR;
1974 outrange->ch = XCHAR_OR_CHAR_INT (range);
1978 signal_simple_error ("Range must be t or a character", range);
1980 else if (VECTORP (range))
1982 Lisp_Vector *vec = XVECTOR (range);
1983 Lisp_Object *elts = vector_data (vec);
1984 int cell_min, cell_max;
1986 outrange->type = CHARTAB_RANGE_ROW;
1987 outrange->charset = Fget_charset (elts[0]);
1988 CHECK_INT (elts[1]);
1989 outrange->row = XINT (elts[1]);
1990 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1991 signal_simple_error ("Charset in row vector must be multi-byte",
1995 int ret = XCHARSET_CELL_RANGE (outrange->charset);
1997 cell_min = ret >> 8;
1998 cell_max = ret & 0xFF;
2000 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2001 check_int_range (outrange->row, cell_min, cell_max);
2003 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2005 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2006 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2008 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2010 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2011 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2012 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2020 if (!CHARSETP (range) && !SYMBOLP (range))
2022 ("Char table range must be t, charset, char, or vector", range);
2023 outrange->type = CHARTAB_RANGE_CHARSET;
2024 outrange->charset = Fget_charset (range);
2029 #if defined(MULE)&&!defined(UTF2000)
2031 /* called from CHAR_TABLE_VALUE(). */
2033 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2038 Lisp_Object charset;
2040 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2045 BREAKUP_CHAR (c, charset, byte1, byte2);
2047 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2049 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2050 if (CHAR_TABLE_ENTRYP (val))
2052 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2053 val = cte->level2[byte1 - 32];
2054 if (CHAR_TABLE_ENTRYP (val))
2056 cte = XCHAR_TABLE_ENTRY (val);
2057 assert (byte2 >= 32);
2058 val = cte->level2[byte2 - 32];
2059 assert (!CHAR_TABLE_ENTRYP (val));
2069 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2072 return get_char_id_table (ct, ch);
2075 Lisp_Object charset;
2079 BREAKUP_CHAR (ch, charset, byte1, byte2);
2081 if (EQ (charset, Vcharset_ascii))
2082 val = ct->ascii[byte1];
2083 else if (EQ (charset, Vcharset_control_1))
2084 val = ct->ascii[byte1 + 128];
2087 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2088 val = ct->level1[lb];
2089 if (CHAR_TABLE_ENTRYP (val))
2091 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2092 val = cte->level2[byte1 - 32];
2093 if (CHAR_TABLE_ENTRYP (val))
2095 cte = XCHAR_TABLE_ENTRY (val);
2096 assert (byte2 >= 32);
2097 val = cte->level2[byte2 - 32];
2098 assert (!CHAR_TABLE_ENTRYP (val));
2105 #else /* not MULE */
2106 return ct->ascii[(unsigned char)ch];
2107 #endif /* not MULE */
2111 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2112 Find value for CHARACTER in CHAR-TABLE.
2114 (character, char_table))
2116 CHECK_CHAR_TABLE (char_table);
2117 CHECK_CHAR_COERCE_INT (character);
2119 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2122 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2123 Find value for a range in CHAR-TABLE.
2124 If there is more than one value, return MULTI (defaults to nil).
2126 (range, char_table, multi))
2128 Lisp_Char_Table *ct;
2129 struct chartab_range rainj;
2131 if (CHAR_OR_CHAR_INTP (range))
2132 return Fget_char_table (range, char_table);
2133 CHECK_CHAR_TABLE (char_table);
2134 ct = XCHAR_TABLE (char_table);
2136 decode_char_table_range (range, &rainj);
2139 case CHARTAB_RANGE_ALL:
2142 if (UINT8_BYTE_TABLE_P (ct->table))
2144 else if (UINT16_BYTE_TABLE_P (ct->table))
2146 else if (BYTE_TABLE_P (ct->table))
2150 #else /* non UTF2000 */
2152 Lisp_Object first = ct->ascii[0];
2154 for (i = 1; i < NUM_ASCII_CHARS; i++)
2155 if (!EQ (first, ct->ascii[i]))
2159 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2162 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2163 || i == LEADING_BYTE_ASCII
2164 || i == LEADING_BYTE_CONTROL_1)
2166 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2172 #endif /* non UTF2000 */
2176 case CHARTAB_RANGE_CHARSET:
2180 if (EQ (rainj.charset, Vcharset_ascii))
2183 Lisp_Object first = ct->ascii[0];
2185 for (i = 1; i < 128; i++)
2186 if (!EQ (first, ct->ascii[i]))
2191 if (EQ (rainj.charset, Vcharset_control_1))
2194 Lisp_Object first = ct->ascii[128];
2196 for (i = 129; i < 160; i++)
2197 if (!EQ (first, ct->ascii[i]))
2203 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2205 if (CHAR_TABLE_ENTRYP (val))
2211 case CHARTAB_RANGE_ROW:
2216 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2218 if (!CHAR_TABLE_ENTRYP (val))
2220 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2221 if (CHAR_TABLE_ENTRYP (val))
2225 #endif /* not UTF2000 */
2226 #endif /* not MULE */
2232 return Qnil; /* not reached */
2236 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2237 Error_behavior errb)
2241 case CHAR_TABLE_TYPE_SYNTAX:
2242 if (!ERRB_EQ (errb, ERROR_ME))
2243 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2244 && CHAR_OR_CHAR_INTP (XCDR (value)));
2247 Lisp_Object cdr = XCDR (value);
2248 CHECK_INT (XCAR (value));
2249 CHECK_CHAR_COERCE_INT (cdr);
2256 case CHAR_TABLE_TYPE_CATEGORY:
2257 if (!ERRB_EQ (errb, ERROR_ME))
2258 return CATEGORY_TABLE_VALUEP (value);
2259 CHECK_CATEGORY_TABLE_VALUE (value);
2263 case CHAR_TABLE_TYPE_GENERIC:
2266 case CHAR_TABLE_TYPE_DISPLAY:
2268 maybe_signal_simple_error ("Display char tables not yet implemented",
2269 value, Qchar_table, errb);
2272 case CHAR_TABLE_TYPE_CHAR:
2273 if (!ERRB_EQ (errb, ERROR_ME))
2274 return CHAR_OR_CHAR_INTP (value);
2275 CHECK_CHAR_COERCE_INT (value);
2282 return 0; /* not reached */
2286 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2290 case CHAR_TABLE_TYPE_SYNTAX:
2293 Lisp_Object car = XCAR (value);
2294 Lisp_Object cdr = XCDR (value);
2295 CHECK_CHAR_COERCE_INT (cdr);
2296 return Fcons (car, cdr);
2299 case CHAR_TABLE_TYPE_CHAR:
2300 CHECK_CHAR_COERCE_INT (value);
2308 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2309 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2311 (value, char_table_type))
2313 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2315 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2318 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2319 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2321 (value, char_table_type))
2323 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2325 check_valid_char_table_value (value, type, ERROR_ME);
2330 Lisp_Char_Table* char_attribute_table_to_put;
2331 Lisp_Object Qput_char_table_map_function;
2332 Lisp_Object value_to_put;
2334 DEFUN ("put-char-table-map-function",
2335 Fput_char_table_map_function, 2, 2, 0, /*
2336 For internal use. Don't use it.
2340 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2345 /* Assign VAL to all characters in RANGE in char table CT. */
2348 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2351 switch (range->type)
2353 case CHARTAB_RANGE_ALL:
2354 /* printf ("put-char-table: range = all\n"); */
2355 fill_char_table (ct, val);
2356 return; /* avoid the duplicate call to update_syntax_table() below,
2357 since fill_char_table() also did that. */
2360 case CHARTAB_RANGE_DEFAULT:
2361 ct->default_value = val;
2366 case CHARTAB_RANGE_CHARSET:
2370 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2372 /* printf ("put-char-table: range = charset: %d\n",
2373 XCHARSET_LEADING_BYTE (range->charset));
2375 if ( CHAR_TABLEP (encoding_table) )
2378 char_attribute_table_to_put = ct;
2380 Fmap_char_attribute (Qput_char_table_map_function,
2381 XCHAR_TABLE_NAME (encoding_table),
2384 for (c = 0; c < 1 << 24; c++)
2386 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2388 put_char_id_table_0 (ct, c, val);
2394 for (c = 0; c < 1 << 24; c++)
2396 if ( charset_code_point (range->charset, c) >= 0 )
2397 put_char_id_table_0 (ct, c, val);
2402 if (EQ (range->charset, Vcharset_ascii))
2405 for (i = 0; i < 128; i++)
2408 else if (EQ (range->charset, Vcharset_control_1))
2411 for (i = 128; i < 160; i++)
2416 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2417 ct->level1[lb] = val;
2422 case CHARTAB_RANGE_ROW:
2425 int cell_min, cell_max, i;
2427 i = XCHARSET_CELL_RANGE (range->charset);
2429 cell_max = i & 0xFF;
2430 for (i = cell_min; i <= cell_max; i++)
2432 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2434 if ( charset_code_point (range->charset, ch) >= 0 )
2435 put_char_id_table_0 (ct, ch, val);
2440 Lisp_Char_Table_Entry *cte;
2441 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2442 /* make sure that there is a separate entry for the row. */
2443 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2444 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2445 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2446 cte->level2[range->row - 32] = val;
2448 #endif /* not UTF2000 */
2452 case CHARTAB_RANGE_CHAR:
2454 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2455 put_char_id_table_0 (ct, range->ch, val);
2459 Lisp_Object charset;
2462 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2463 if (EQ (charset, Vcharset_ascii))
2464 ct->ascii[byte1] = val;
2465 else if (EQ (charset, Vcharset_control_1))
2466 ct->ascii[byte1 + 128] = val;
2469 Lisp_Char_Table_Entry *cte;
2470 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2471 /* make sure that there is a separate entry for the row. */
2472 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2473 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2474 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2475 /* now CTE is a char table entry for the charset;
2476 each entry is for a single row (or character of
2477 a one-octet charset). */
2478 if (XCHARSET_DIMENSION (charset) == 1)
2479 cte->level2[byte1 - 32] = val;
2482 /* assigning to one character in a two-octet charset. */
2483 /* make sure that the charset row contains a separate
2484 entry for each character. */
2485 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2486 cte->level2[byte1 - 32] =
2487 make_char_table_entry (cte->level2[byte1 - 32]);
2488 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2489 cte->level2[byte2 - 32] = val;
2493 #else /* not MULE */
2494 ct->ascii[(unsigned char) (range->ch)] = val;
2496 #endif /* not MULE */
2500 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2501 update_syntax_table (ct);
2505 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2506 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2508 RANGE specifies one or more characters to be affected and should be
2509 one of the following:
2511 -- t (all characters are affected)
2512 -- A charset (only allowed when Mule support is present)
2513 -- A vector of two elements: a two-octet charset and a row number
2514 (only allowed when Mule support is present)
2515 -- A single character
2517 VALUE must be a value appropriate for the type of CHAR-TABLE.
2518 See `valid-char-table-type-p'.
2520 (range, value, char_table))
2522 Lisp_Char_Table *ct;
2523 struct chartab_range rainj;
2525 CHECK_CHAR_TABLE (char_table);
2526 ct = XCHAR_TABLE (char_table);
2527 check_valid_char_table_value (value, ct->type, ERROR_ME);
2528 decode_char_table_range (range, &rainj);
2529 value = canonicalize_char_table_value (value, ct->type);
2530 put_char_table (ct, &rainj, value);
2535 /* Map FN over the ASCII chars in CT. */
2538 map_over_charset_ascii (Lisp_Char_Table *ct,
2539 int (*fn) (struct chartab_range *range,
2540 Lisp_Object val, void *arg),
2543 struct chartab_range rainj;
2552 rainj.type = CHARTAB_RANGE_CHAR;
2554 for (i = start, retval = 0; i < stop && retval == 0; i++)
2556 rainj.ch = (Emchar) i;
2557 retval = (fn) (&rainj, ct->ascii[i], arg);
2565 /* Map FN over the Control-1 chars in CT. */
2568 map_over_charset_control_1 (Lisp_Char_Table *ct,
2569 int (*fn) (struct chartab_range *range,
2570 Lisp_Object val, void *arg),
2573 struct chartab_range rainj;
2576 int stop = start + 32;
2578 rainj.type = CHARTAB_RANGE_CHAR;
2580 for (i = start, retval = 0; i < stop && retval == 0; i++)
2582 rainj.ch = (Emchar) (i);
2583 retval = (fn) (&rainj, ct->ascii[i], arg);
2589 /* Map FN over the row ROW of two-byte charset CHARSET.
2590 There must be a separate value for that row in the char table.
2591 CTE specifies the char table entry for CHARSET. */
2594 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2595 Lisp_Object charset, int row,
2596 int (*fn) (struct chartab_range *range,
2597 Lisp_Object val, void *arg),
2600 Lisp_Object val = cte->level2[row - 32];
2602 if (!CHAR_TABLE_ENTRYP (val))
2604 struct chartab_range rainj;
2606 rainj.type = CHARTAB_RANGE_ROW;
2607 rainj.charset = charset;
2609 return (fn) (&rainj, val, arg);
2613 struct chartab_range rainj;
2615 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2616 int start = charset94_p ? 33 : 32;
2617 int stop = charset94_p ? 127 : 128;
2619 cte = XCHAR_TABLE_ENTRY (val);
2621 rainj.type = CHARTAB_RANGE_CHAR;
2623 for (i = start, retval = 0; i < stop && retval == 0; i++)
2625 rainj.ch = MAKE_CHAR (charset, row, i);
2626 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2634 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2635 int (*fn) (struct chartab_range *range,
2636 Lisp_Object val, void *arg),
2639 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2640 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2642 if (!CHARSETP (charset)
2643 || lb == LEADING_BYTE_ASCII
2644 || lb == LEADING_BYTE_CONTROL_1)
2647 if (!CHAR_TABLE_ENTRYP (val))
2649 struct chartab_range rainj;
2651 rainj.type = CHARTAB_RANGE_CHARSET;
2652 rainj.charset = charset;
2653 return (fn) (&rainj, val, arg);
2657 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2658 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2659 int start = charset94_p ? 33 : 32;
2660 int stop = charset94_p ? 127 : 128;
2663 if (XCHARSET_DIMENSION (charset) == 1)
2665 struct chartab_range rainj;
2666 rainj.type = CHARTAB_RANGE_CHAR;
2668 for (i = start, retval = 0; i < stop && retval == 0; i++)
2670 rainj.ch = MAKE_CHAR (charset, i, 0);
2671 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2676 for (i = start, retval = 0; i < stop && retval == 0; i++)
2677 retval = map_over_charset_row (cte, charset, i, fn, arg);
2685 #endif /* not UTF2000 */
2688 struct map_char_table_for_charset_arg
2690 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2691 Lisp_Char_Table *ct;
2696 map_char_table_for_charset_fun (struct chartab_range *range,
2697 Lisp_Object val, void *arg)
2699 struct map_char_table_for_charset_arg *closure =
2700 (struct map_char_table_for_charset_arg *) arg;
2703 switch (range->type)
2705 case CHARTAB_RANGE_ALL:
2708 case CHARTAB_RANGE_DEFAULT:
2711 case CHARTAB_RANGE_CHARSET:
2714 case CHARTAB_RANGE_ROW:
2717 case CHARTAB_RANGE_CHAR:
2718 ret = get_char_table (range->ch, closure->ct);
2719 if (!UNBOUNDP (ret))
2720 return (closure->fn) (range, ret, closure->arg);
2732 /* Map FN (with client data ARG) over range RANGE in char table CT.
2733 Mapping stops the first time FN returns non-zero, and that value
2734 becomes the return value of map_char_table(). */
2737 map_char_table (Lisp_Char_Table *ct,
2738 struct chartab_range *range,
2739 int (*fn) (struct chartab_range *range,
2740 Lisp_Object val, void *arg),
2743 switch (range->type)
2745 case CHARTAB_RANGE_ALL:
2747 if (!UNBOUNDP (ct->default_value))
2749 struct chartab_range rainj;
2752 rainj.type = CHARTAB_RANGE_DEFAULT;
2753 retval = (fn) (&rainj, ct->default_value, arg);
2757 if (UINT8_BYTE_TABLE_P (ct->table))
2758 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2760 else if (UINT16_BYTE_TABLE_P (ct->table))
2761 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2763 else if (BYTE_TABLE_P (ct->table))
2764 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2766 else if (EQ (ct->table, Qunloaded))
2769 struct chartab_range rainj;
2772 Emchar c1 = c + unit;
2775 rainj.type = CHARTAB_RANGE_CHAR;
2777 for (retval = 0; c < c1 && retval == 0; c++)
2779 Lisp_Object ret = get_char_id_table (ct, c);
2781 if (!UNBOUNDP (ret))
2784 retval = (fn) (&rainj, ct->table, arg);
2789 ct->table = Qunbound;
2792 else if (!UNBOUNDP (ct->table))
2793 return (fn) (range, ct->table, arg);
2799 retval = map_over_charset_ascii (ct, fn, arg);
2803 retval = map_over_charset_control_1 (ct, fn, arg);
2808 Charset_ID start = MIN_LEADING_BYTE;
2809 Charset_ID stop = start + NUM_LEADING_BYTES;
2811 for (i = start, retval = 0; i < stop && retval == 0; i++)
2813 retval = map_over_other_charset (ct, i, fn, arg);
2822 case CHARTAB_RANGE_DEFAULT:
2823 if (!UNBOUNDP (ct->default_value))
2824 return (fn) (range, ct->default_value, arg);
2829 case CHARTAB_RANGE_CHARSET:
2832 Lisp_Object encoding_table
2833 = XCHARSET_ENCODING_TABLE (range->charset);
2835 if (!NILP (encoding_table))
2837 struct chartab_range rainj;
2838 struct map_char_table_for_charset_arg mcarg;
2840 #ifdef HAVE_DATABASE
2841 if (XCHAR_TABLE_UNLOADED(encoding_table))
2842 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2847 rainj.type = CHARTAB_RANGE_ALL;
2848 return map_char_table (XCHAR_TABLE(encoding_table),
2850 &map_char_table_for_charset_fun,
2856 return map_over_other_charset (ct,
2857 XCHARSET_LEADING_BYTE (range->charset),
2861 case CHARTAB_RANGE_ROW:
2864 int cell_min, cell_max, i;
2866 struct chartab_range rainj;
2868 i = XCHARSET_CELL_RANGE (range->charset);
2870 cell_max = i & 0xFF;
2871 rainj.type = CHARTAB_RANGE_CHAR;
2872 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2874 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2876 if ( charset_code_point (range->charset, ch) >= 0 )
2879 = get_byte_table (get_byte_table
2883 (unsigned char)(ch >> 24)),
2884 (unsigned char) (ch >> 16)),
2885 (unsigned char) (ch >> 8)),
2886 (unsigned char) ch);
2889 val = ct->default_value;
2891 retval = (fn) (&rainj, val, arg);
2898 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2899 - MIN_LEADING_BYTE];
2900 if (!CHAR_TABLE_ENTRYP (val))
2902 struct chartab_range rainj;
2904 rainj.type = CHARTAB_RANGE_ROW;
2905 rainj.charset = range->charset;
2906 rainj.row = range->row;
2907 return (fn) (&rainj, val, arg);
2910 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2911 range->charset, range->row,
2914 #endif /* not UTF2000 */
2917 case CHARTAB_RANGE_CHAR:
2919 Emchar ch = range->ch;
2920 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2922 if (!UNBOUNDP (val))
2924 struct chartab_range rainj;
2926 rainj.type = CHARTAB_RANGE_CHAR;
2928 return (fn) (&rainj, val, arg);
2940 struct slow_map_char_table_arg
2942 Lisp_Object function;
2947 slow_map_char_table_fun (struct chartab_range *range,
2948 Lisp_Object val, void *arg)
2950 Lisp_Object ranjarg = Qnil;
2951 struct slow_map_char_table_arg *closure =
2952 (struct slow_map_char_table_arg *) arg;
2954 switch (range->type)
2956 case CHARTAB_RANGE_ALL:
2961 case CHARTAB_RANGE_DEFAULT:
2967 case CHARTAB_RANGE_CHARSET:
2968 ranjarg = XCHARSET_NAME (range->charset);
2971 case CHARTAB_RANGE_ROW:
2972 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2973 make_int (range->row));
2976 case CHARTAB_RANGE_CHAR:
2977 ranjarg = make_char (range->ch);
2983 closure->retval = call2 (closure->function, ranjarg, val);
2984 return !NILP (closure->retval);
2987 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2988 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2989 each key and value in the table.
2991 RANGE specifies a subrange to map over and is in the same format as
2992 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2995 (function, char_table, range))
2997 Lisp_Char_Table *ct;
2998 struct slow_map_char_table_arg slarg;
2999 struct gcpro gcpro1, gcpro2;
3000 struct chartab_range rainj;
3002 CHECK_CHAR_TABLE (char_table);
3003 ct = XCHAR_TABLE (char_table);
3006 decode_char_table_range (range, &rainj);
3007 slarg.function = function;
3008 slarg.retval = Qnil;
3009 GCPRO2 (slarg.function, slarg.retval);
3010 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3013 return slarg.retval;
3017 /************************************************************************/
3018 /* Character Attributes */
3019 /************************************************************************/
3023 Lisp_Object Vchar_attribute_hash_table;
3025 /* We store the char-attributes in hash tables with the names as the
3026 key and the actual char-id-table object as the value. Occasionally
3027 we need to use them in a list format. These routines provide us
3029 struct char_attribute_list_closure
3031 Lisp_Object *char_attribute_list;
3035 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3036 void *char_attribute_list_closure)
3038 /* This function can GC */
3039 struct char_attribute_list_closure *calcl
3040 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3041 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3043 *char_attribute_list = Fcons (key, *char_attribute_list);
3047 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3048 Return the list of all existing character attributes except coded-charsets.
3052 Lisp_Object char_attribute_list = Qnil;
3053 struct gcpro gcpro1;
3054 struct char_attribute_list_closure char_attribute_list_closure;
3056 GCPRO1 (char_attribute_list);
3057 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3058 elisp_maphash (add_char_attribute_to_list_mapper,
3059 Vchar_attribute_hash_table,
3060 &char_attribute_list_closure);
3062 return char_attribute_list;
3065 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3066 Return char-id-table corresponding to ATTRIBUTE.
3070 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3074 /* We store the char-id-tables in hash tables with the attributes as
3075 the key and the actual char-id-table object as the value. Each
3076 char-id-table stores values of an attribute corresponding with
3077 characters. Occasionally we need to get attributes of a character
3078 in a association-list format. These routines provide us with
3080 struct char_attribute_alist_closure
3083 Lisp_Object *char_attribute_alist;
3087 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3088 void *char_attribute_alist_closure)
3090 /* This function can GC */
3091 struct char_attribute_alist_closure *caacl =
3092 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3094 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3095 if (!UNBOUNDP (ret))
3097 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3098 *char_attribute_alist
3099 = Fcons (Fcons (key, ret), *char_attribute_alist);
3104 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3105 Return the alist of attributes of CHARACTER.
3109 struct gcpro gcpro1;
3110 struct char_attribute_alist_closure char_attribute_alist_closure;
3111 Lisp_Object alist = Qnil;
3113 CHECK_CHAR (character);
3116 char_attribute_alist_closure.char_id = XCHAR (character);
3117 char_attribute_alist_closure.char_attribute_alist = &alist;
3118 elisp_maphash (add_char_attribute_alist_mapper,
3119 Vchar_attribute_hash_table,
3120 &char_attribute_alist_closure);
3126 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3127 Return the value of CHARACTER's ATTRIBUTE.
3128 Return DEFAULT-VALUE if the value is not exist.
3130 (character, attribute, default_value))
3134 CHECK_CHAR (character);
3136 if (CHARSETP (attribute))
3137 attribute = XCHARSET_NAME (attribute);
3139 table = Fgethash (attribute, Vchar_attribute_hash_table,
3141 if (!UNBOUNDP (table))
3143 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3145 if (!UNBOUNDP (ret))
3148 return default_value;
3151 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3152 Store CHARACTER's ATTRIBUTE with VALUE.
3154 (character, attribute, value))
3156 Lisp_Object ccs = Ffind_charset (attribute);
3160 CHECK_CHAR (character);
3161 value = put_char_ccs_code_point (character, ccs, value);
3163 else if (EQ (attribute, Q_decomposition))
3167 CHECK_CHAR (character);
3169 signal_simple_error ("Invalid value for ->decomposition",
3172 if (CONSP (Fcdr (value)))
3174 Lisp_Object rest = value;
3175 Lisp_Object table = Vcharacter_composition_table;
3179 GET_EXTERNAL_LIST_LENGTH (rest, len);
3180 seq = make_vector (len, Qnil);
3182 while (CONSP (rest))
3184 Lisp_Object v = Fcar (rest);
3187 = to_char_id (v, "Invalid value for ->decomposition", value);
3190 XVECTOR_DATA(seq)[i++] = v;
3192 XVECTOR_DATA(seq)[i++] = make_char (c);
3196 put_char_id_table (XCHAR_TABLE(table),
3197 make_char (c), character);
3202 ntable = get_char_id_table (XCHAR_TABLE(table), c);
3203 if (!CHAR_TABLEP (ntable))
3205 ntable = make_char_id_table (Qnil);
3206 put_char_id_table (XCHAR_TABLE(table),
3207 make_char (c), ntable);
3215 Lisp_Object v = Fcar (value);
3219 Emchar c = XINT (v);
3221 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3226 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3227 make_char (c), Fcons (character, Qnil));
3229 else if (NILP (Fmemq (v, ret)))
3231 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3232 make_char (c), Fcons (character, ret));
3235 seq = make_vector (1, v);
3239 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3244 CHECK_CHAR (character);
3246 signal_simple_error ("Invalid value for ->ucs", value);
3250 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
3253 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3254 make_char (c), Fcons (character, Qnil));
3256 else if (NILP (Fmemq (character, ret)))
3258 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3259 make_char (c), Fcons (character, ret));
3262 if (EQ (attribute, Q_ucs))
3263 attribute = Qto_ucs;
3267 Lisp_Object table = Fgethash (attribute,
3268 Vchar_attribute_hash_table,
3273 table = make_char_id_table (Qunbound);
3274 Fputhash (attribute, table, Vchar_attribute_hash_table);
3275 #ifdef HAVE_DATABASE
3276 XCHAR_TABLE_NAME (table) = attribute;
3279 put_char_id_table (XCHAR_TABLE(table), character, value);
3284 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3285 Remove CHARACTER's ATTRIBUTE.
3287 (character, attribute))
3291 CHECK_CHAR (character);
3292 ccs = Ffind_charset (attribute);
3295 return remove_char_ccs (character, ccs);
3299 Lisp_Object table = Fgethash (attribute,
3300 Vchar_attribute_hash_table,
3302 if (!UNBOUNDP (table))
3304 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3312 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3315 Lisp_Object db_dir = Vexec_directory;
3318 db_dir = build_string ("../lib-src");
3320 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3321 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3322 Fmake_directory_internal (db_dir);
3324 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3325 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3326 Fmake_directory_internal (db_dir);
3329 Lisp_Object attribute_name = Fsymbol_name (attribute);
3330 Lisp_Object dest = Qnil, ret;
3332 struct gcpro gcpro1, gcpro2;
3333 int len = XSTRING_CHAR_LENGTH (attribute_name);
3337 for (i = 0; i < len; i++)
3339 Emchar c = string_char (XSTRING (attribute_name), i);
3341 if ( (c == '/') || (c == '%') )
3345 sprintf (str, "%%%02X", c);
3346 dest = concat3 (dest,
3347 Fsubstring (attribute_name,
3348 make_int (base), make_int (i)),
3349 build_string (str));
3353 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3354 dest = concat2 (dest, ret);
3356 return Fexpand_file_name (dest, db_dir);
3359 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3363 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3364 Save values of ATTRIBUTE into database file.
3368 #ifdef HAVE_DATABASE
3369 Lisp_Object table = Fgethash (attribute,
3370 Vchar_attribute_hash_table, Qunbound);
3371 Lisp_Char_Table *ct;
3372 Lisp_Object db_file;
3375 if (CHAR_TABLEP (table))
3376 ct = XCHAR_TABLE (table);
3380 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3381 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3384 if (UINT8_BYTE_TABLE_P (ct->table))
3385 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db, 0, 3);
3386 else if (UINT16_BYTE_TABLE_P (ct->table))
3387 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db, 0, 3);
3388 else if (BYTE_TABLE_P (ct->table))
3389 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3);
3390 Fclose_database (db);
3400 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3401 Mount database file on char-attribute-table ATTRIBUTE.
3405 #ifdef HAVE_DATABASE
3406 Lisp_Object table = Fgethash (attribute,
3407 Vchar_attribute_hash_table, Qunbound);
3409 if (UNBOUNDP (table))
3411 Lisp_Char_Table *ct;
3413 table = make_char_id_table (Qunbound);
3414 Fputhash (attribute, table, Vchar_attribute_hash_table);
3415 XCHAR_TABLE_NAME(table) = attribute;
3416 ct = XCHAR_TABLE (table);
3417 ct->table = Qunloaded;
3418 XCHAR_TABLE_UNLOADED(table) = 1;
3426 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3427 Close database of ATTRIBUTE.
3431 #ifdef HAVE_DATABASE
3432 Lisp_Object table = Fgethash (attribute,
3433 Vchar_attribute_hash_table, Qunbound);
3434 Lisp_Char_Table *ct;
3436 if (CHAR_TABLEP (table))
3437 ct = XCHAR_TABLE (table);
3443 if (!NILP (Fdatabase_live_p (ct->db)))
3444 Fclose_database (ct->db);
3451 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3452 Reset values of ATTRIBUTE with database file.
3456 #ifdef HAVE_DATABASE
3457 Lisp_Object table = Fgethash (attribute,
3458 Vchar_attribute_hash_table, Qunbound);
3459 Lisp_Char_Table *ct;
3461 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3463 if (!NILP (Ffile_exists_p (db_file)))
3465 if (UNBOUNDP (table))
3467 table = make_char_id_table (Qunbound);
3468 Fputhash (attribute, table, Vchar_attribute_hash_table);
3469 XCHAR_TABLE_NAME(table) = attribute;
3471 ct = XCHAR_TABLE (table);
3472 ct->table = Qunloaded;
3473 if (!NILP (Fdatabase_live_p (ct->db)))
3474 Fclose_database (ct->db);
3476 XCHAR_TABLE_UNLOADED(table) = 1;
3483 #ifdef HAVE_DATABASE
3485 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3487 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3489 if (!NILP (attribute))
3491 if (NILP (Fdatabase_live_p (cit->db)))
3494 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3496 cit->db = Fopen_database (db_file, Qnil, Qnil, build_string ("r"), Qnil);
3498 if (!NILP (cit->db))
3501 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3503 if (!UNBOUNDP (val))
3513 Lisp_Char_Table* char_attribute_table_to_load;
3515 Lisp_Object Qload_char_attribute_table_map_function;
3517 DEFUN ("load-char-attribute-table-map-function",
3518 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3519 For internal use. Don't use it.
3523 Lisp_Object c = Fread (key);
3524 Emchar code = XCHAR (c);
3525 Lisp_Object ret = get_char_id_table (char_attribute_table_to_load, code);
3527 if (EQ (ret, Qunloaded))
3528 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3533 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3534 Load values of ATTRIBUTE into database file.
3538 #ifdef HAVE_DATABASE
3539 Lisp_Object table = Fgethash (attribute,
3540 Vchar_attribute_hash_table,
3542 if (CHAR_TABLEP (table))
3544 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3546 if (NILP (Fdatabase_live_p (ct->db)))
3549 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3551 ct->db = Fopen_database (db_file, Qnil, Qnil, build_string ("r"), Qnil);
3555 struct gcpro gcpro1;
3557 char_attribute_table_to_load = XCHAR_TABLE (table);
3559 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3561 Fclose_database (ct->db);
3563 XCHAR_TABLE_UNLOADED(table) = 0;
3571 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3572 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3573 each key and value in the table.
3575 RANGE specifies a subrange to map over and is in the same format as
3576 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3579 (function, attribute, range))
3582 Lisp_Char_Table *ct;
3583 struct slow_map_char_table_arg slarg;
3584 struct gcpro gcpro1, gcpro2;
3585 struct chartab_range rainj;
3587 if (!NILP (ccs = Ffind_charset (attribute)))
3589 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3591 if (CHAR_TABLEP (encoding_table))
3592 ct = XCHAR_TABLE (encoding_table);
3598 Lisp_Object table = Fgethash (attribute,
3599 Vchar_attribute_hash_table,
3601 if (CHAR_TABLEP (table))
3602 ct = XCHAR_TABLE (table);
3608 decode_char_table_range (range, &rainj);
3609 #ifdef HAVE_DATABASE
3610 if (CHAR_TABLE_UNLOADED(ct))
3611 Fload_char_attribute_table (attribute);
3613 slarg.function = function;
3614 slarg.retval = Qnil;
3615 GCPRO2 (slarg.function, slarg.retval);
3616 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3619 return slarg.retval;
3622 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3623 Store character's ATTRIBUTES.
3627 Lisp_Object rest = attributes;
3628 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3629 Lisp_Object character;
3633 while (CONSP (rest))
3635 Lisp_Object cell = Fcar (rest);
3639 signal_simple_error ("Invalid argument", attributes);
3640 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3641 && ((XCHARSET_FINAL (ccs) != 0) ||
3642 (XCHARSET_MAX_CODE (ccs) > 0) ||
3643 (EQ (ccs, Vcharset_chinese_big5))) )
3647 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3649 character = Fdecode_char (ccs, cell, Qnil);
3650 if (!NILP (character))
3651 goto setup_attributes;
3655 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3656 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3660 signal_simple_error ("Invalid argument", attributes);
3662 character = make_char (XINT (code) + 0x100000);
3663 goto setup_attributes;
3667 else if (!INTP (code))
3668 signal_simple_error ("Invalid argument", attributes);
3670 character = make_char (XINT (code));
3674 while (CONSP (rest))
3676 Lisp_Object cell = Fcar (rest);
3679 signal_simple_error ("Invalid argument", attributes);
3681 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3687 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3688 Retrieve the character of the given ATTRIBUTES.
3692 Lisp_Object rest = attributes;
3695 while (CONSP (rest))
3697 Lisp_Object cell = Fcar (rest);
3701 signal_simple_error ("Invalid argument", attributes);
3702 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3706 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3708 return Fdecode_char (ccs, cell, Qnil);
3712 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3713 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3716 signal_simple_error ("Invalid argument", attributes);
3718 return make_char (XINT (code) + 0x100000);
3726 /************************************************************************/
3727 /* Char table read syntax */
3728 /************************************************************************/
3731 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3732 Error_behavior errb)
3734 /* #### should deal with ERRB */
3735 symbol_to_char_table_type (value);
3740 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3741 Error_behavior errb)
3745 /* #### should deal with ERRB */
3746 EXTERNAL_LIST_LOOP (rest, value)
3748 Lisp_Object range = XCAR (rest);
3749 struct chartab_range dummy;
3753 signal_simple_error ("Invalid list format", value);
3756 if (!CONSP (XCDR (range))
3757 || !NILP (XCDR (XCDR (range))))
3758 signal_simple_error ("Invalid range format", range);
3759 decode_char_table_range (XCAR (range), &dummy);
3760 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3763 decode_char_table_range (range, &dummy);
3770 chartab_instantiate (Lisp_Object data)
3772 Lisp_Object chartab;
3773 Lisp_Object type = Qgeneric;
3774 Lisp_Object dataval = Qnil;
3776 while (!NILP (data))
3778 Lisp_Object keyw = Fcar (data);
3784 if (EQ (keyw, Qtype))
3786 else if (EQ (keyw, Qdata))
3790 chartab = Fmake_char_table (type);
3793 while (!NILP (data))
3795 Lisp_Object range = Fcar (data);
3796 Lisp_Object val = Fcar (Fcdr (data));
3798 data = Fcdr (Fcdr (data));
3801 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3803 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3804 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3807 for (i = first; i <= last; i++)
3808 Fput_char_table (make_char (i), val, chartab);
3814 Fput_char_table (range, val, chartab);
3823 /************************************************************************/
3824 /* Category Tables, specifically */
3825 /************************************************************************/
3827 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3828 Return t if OBJECT is a category table.
3829 A category table is a type of char table used for keeping track of
3830 categories. Categories are used for classifying characters for use
3831 in regexps -- you can refer to a category rather than having to use
3832 a complicated [] expression (and category lookups are significantly
3835 There are 95 different categories available, one for each printable
3836 character (including space) in the ASCII charset. Each category
3837 is designated by one such character, called a "category designator".
3838 They are specified in a regexp using the syntax "\\cX", where X is
3839 a category designator.
3841 A category table specifies, for each character, the categories that
3842 the character is in. Note that a character can be in more than one
3843 category. More specifically, a category table maps from a character
3844 to either the value nil (meaning the character is in no categories)
3845 or a 95-element bit vector, specifying for each of the 95 categories
3846 whether the character is in that category.
3848 Special Lisp functions are provided that abstract this, so you do not
3849 have to directly manipulate bit vectors.
3853 return (CHAR_TABLEP (object) &&
3854 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3859 check_category_table (Lisp_Object object, Lisp_Object default_)
3863 while (NILP (Fcategory_table_p (object)))
3864 object = wrong_type_argument (Qcategory_table_p, object);
3869 check_category_char (Emchar ch, Lisp_Object table,
3870 unsigned int designator, unsigned int not_p)
3872 REGISTER Lisp_Object temp;
3873 Lisp_Char_Table *ctbl;
3874 #ifdef ERROR_CHECK_TYPECHECK
3875 if (NILP (Fcategory_table_p (table)))
3876 signal_simple_error ("Expected category table", table);
3878 ctbl = XCHAR_TABLE (table);
3879 temp = get_char_table (ch, ctbl);
3884 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3887 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3888 Return t if category of the character at POSITION includes DESIGNATOR.
3889 Optional third arg BUFFER specifies which buffer to use, and defaults
3890 to the current buffer.
3891 Optional fourth arg CATEGORY-TABLE specifies the category table to
3892 use, and defaults to BUFFER's category table.
3894 (position, designator, buffer, category_table))
3899 struct buffer *buf = decode_buffer (buffer, 0);
3901 CHECK_INT (position);
3902 CHECK_CATEGORY_DESIGNATOR (designator);
3903 des = XCHAR (designator);
3904 ctbl = check_category_table (category_table, Vstandard_category_table);
3905 ch = BUF_FETCH_CHAR (buf, XINT (position));
3906 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3909 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3910 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3911 Optional third arg CATEGORY-TABLE specifies the category table to use,
3912 and defaults to the standard category table.
3914 (character, designator, category_table))
3920 CHECK_CATEGORY_DESIGNATOR (designator);
3921 des = XCHAR (designator);
3922 CHECK_CHAR (character);
3923 ch = XCHAR (character);
3924 ctbl = check_category_table (category_table, Vstandard_category_table);
3925 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3928 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3929 Return BUFFER's current category table.
3930 BUFFER defaults to the current buffer.
3934 return decode_buffer (buffer, 0)->category_table;
3937 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3938 Return the standard category table.
3939 This is the one used for new buffers.
3943 return Vstandard_category_table;
3946 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3947 Return a new category table which is a copy of CATEGORY-TABLE.
3948 CATEGORY-TABLE defaults to the standard category table.
3952 if (NILP (Vstandard_category_table))
3953 return Fmake_char_table (Qcategory);
3956 check_category_table (category_table, Vstandard_category_table);
3957 return Fcopy_char_table (category_table);
3960 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3961 Select CATEGORY-TABLE as the new category table for BUFFER.
3962 BUFFER defaults to the current buffer if omitted.
3964 (category_table, buffer))
3966 struct buffer *buf = decode_buffer (buffer, 0);
3967 category_table = check_category_table (category_table, Qnil);
3968 buf->category_table = category_table;
3969 /* Indicate that this buffer now has a specified category table. */
3970 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3971 return category_table;
3974 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3975 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3979 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3982 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3983 Return t if OBJECT is a category table value.
3984 Valid values are nil or a bit vector of size 95.
3988 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3992 #define CATEGORYP(x) \
3993 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3995 #define CATEGORY_SET(c) \
3996 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3998 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3999 The faster version of `!NILP (Faref (category_set, category))'. */
4000 #define CATEGORY_MEMBER(category, category_set) \
4001 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
4003 /* Return 1 if there is a word boundary between two word-constituent
4004 characters C1 and C2 if they appear in this order, else return 0.
4005 Use the macro WORD_BOUNDARY_P instead of calling this function
4008 int word_boundary_p (Emchar c1, Emchar c2);
4010 word_boundary_p (Emchar c1, Emchar c2)
4012 Lisp_Object category_set1, category_set2;
4017 if (COMPOSITE_CHAR_P (c1))
4018 c1 = cmpchar_component (c1, 0, 1);
4019 if (COMPOSITE_CHAR_P (c2))
4020 c2 = cmpchar_component (c2, 0, 1);
4023 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4025 tail = Vword_separating_categories;
4030 tail = Vword_combining_categories;
4034 category_set1 = CATEGORY_SET (c1);
4035 if (NILP (category_set1))
4036 return default_result;
4037 category_set2 = CATEGORY_SET (c2);
4038 if (NILP (category_set2))
4039 return default_result;
4041 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4043 Lisp_Object elt = XCONS(tail)->car;
4046 && CATEGORYP (XCONS (elt)->car)
4047 && CATEGORYP (XCONS (elt)->cdr)
4048 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4049 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4050 return !default_result;
4052 return default_result;
4058 syms_of_chartab (void)
4061 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4062 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4063 INIT_LRECORD_IMPLEMENTATION (byte_table);
4065 defsymbol (&Qsystem_char_id, "system-char-id");
4067 defsymbol (&Qto_ucs, "=>ucs");
4068 defsymbol (&Q_ucs, "->ucs");
4069 defsymbol (&Q_ucs_variants, "->ucs-variants");
4070 defsymbol (&Q_decomposition, "->decomposition");
4071 defsymbol (&Qcompat, "compat");
4072 defsymbol (&Qisolated, "isolated");
4073 defsymbol (&Qinitial, "initial");
4074 defsymbol (&Qmedial, "medial");
4075 defsymbol (&Qfinal, "final");
4076 defsymbol (&Qvertical, "vertical");
4077 defsymbol (&QnoBreak, "noBreak");
4078 defsymbol (&Qfraction, "fraction");
4079 defsymbol (&Qsuper, "super");
4080 defsymbol (&Qsub, "sub");
4081 defsymbol (&Qcircle, "circle");
4082 defsymbol (&Qsquare, "square");
4083 defsymbol (&Qwide, "wide");
4084 defsymbol (&Qnarrow, "narrow");
4085 defsymbol (&Qsmall, "small");
4086 defsymbol (&Qfont, "font");
4088 DEFSUBR (Fchar_attribute_list);
4089 DEFSUBR (Ffind_char_attribute_table);
4090 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4091 DEFSUBR (Fput_char_table_map_function);
4092 DEFSUBR (Fsave_char_attribute_table);
4093 DEFSUBR (Fmount_char_attribute_table);
4094 DEFSUBR (Freset_char_attribute_table);
4095 DEFSUBR (Fclose_char_attribute_table);
4096 #ifdef HAVE_DATABASE
4097 defsymbol (&Qload_char_attribute_table_map_function,
4098 "load-char-attribute-table-map-function");
4099 DEFSUBR (Fload_char_attribute_table_map_function);
4101 DEFSUBR (Fload_char_attribute_table);
4102 DEFSUBR (Fchar_attribute_alist);
4103 DEFSUBR (Fget_char_attribute);
4104 DEFSUBR (Fput_char_attribute);
4105 DEFSUBR (Fremove_char_attribute);
4106 DEFSUBR (Fmap_char_attribute);
4107 DEFSUBR (Fdefine_char);
4108 DEFSUBR (Ffind_char);
4109 DEFSUBR (Fchar_variants);
4111 DEFSUBR (Fget_composite_char);
4114 INIT_LRECORD_IMPLEMENTATION (char_table);
4118 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4121 defsymbol (&Qcategory_table_p, "category-table-p");
4122 defsymbol (&Qcategory_designator_p, "category-designator-p");
4123 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4126 defsymbol (&Qchar_table, "char-table");
4127 defsymbol (&Qchar_tablep, "char-table-p");
4129 DEFSUBR (Fchar_table_p);
4130 DEFSUBR (Fchar_table_type_list);
4131 DEFSUBR (Fvalid_char_table_type_p);
4132 DEFSUBR (Fchar_table_type);
4133 DEFSUBR (Freset_char_table);
4134 DEFSUBR (Fmake_char_table);
4135 DEFSUBR (Fcopy_char_table);
4136 DEFSUBR (Fget_char_table);
4137 DEFSUBR (Fget_range_char_table);
4138 DEFSUBR (Fvalid_char_table_value_p);
4139 DEFSUBR (Fcheck_valid_char_table_value);
4140 DEFSUBR (Fput_char_table);
4141 DEFSUBR (Fmap_char_table);
4144 DEFSUBR (Fcategory_table_p);
4145 DEFSUBR (Fcategory_table);
4146 DEFSUBR (Fstandard_category_table);
4147 DEFSUBR (Fcopy_category_table);
4148 DEFSUBR (Fset_category_table);
4149 DEFSUBR (Fcheck_category_at);
4150 DEFSUBR (Fchar_in_category_p);
4151 DEFSUBR (Fcategory_designator_p);
4152 DEFSUBR (Fcategory_table_value_p);
4158 vars_of_chartab (void)
4161 staticpro (&Vcharacter_composition_table);
4162 Vcharacter_composition_table = make_char_id_table (Qnil);
4164 staticpro (&Vcharacter_variant_table);
4165 Vcharacter_variant_table = make_char_id_table (Qunbound);
4167 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4168 Vall_syntax_tables = Qnil;
4169 dump_add_weak_object_chain (&Vall_syntax_tables);
4173 structure_type_create_chartab (void)
4175 struct structure_type *st;
4177 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4179 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4180 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4184 complex_vars_of_chartab (void)
4187 staticpro (&Vchar_attribute_hash_table);
4188 Vchar_attribute_hash_table
4189 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4190 #ifdef HAVE_DATABASE
4191 Fputhash (Q_ucs_variants, Vcharacter_variant_table,
4192 Vchar_attribute_hash_table);
4193 XCHAR_TABLE_NAME (Vcharacter_variant_table) = Q_ucs_variants;
4194 #endif /* HAVE_DATABASE */
4195 #endif /* UTF2000 */
4197 /* Set this now, so first buffer creation can refer to it. */
4198 /* Make it nil before calling copy-category-table
4199 so that copy-category-table will know not to try to copy from garbage */
4200 Vstandard_category_table = Qnil;
4201 Vstandard_category_table = Fcopy_category_table (Qnil);
4202 staticpro (&Vstandard_category_table);
4204 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4205 List of pair (cons) of categories to determine word boundary.
4207 Emacs treats a sequence of word constituent characters as a single
4208 word (i.e. finds no word boundary between them) iff they belongs to
4209 the same charset. But, exceptions are allowed in the following cases.
4211 \(1) The case that characters are in different charsets is controlled
4212 by the variable `word-combining-categories'.
4214 Emacs finds no word boundary between characters of different charsets
4215 if they have categories matching some element of this list.
4217 More precisely, if an element of this list is a cons of category CAT1
4218 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4219 C2 which has CAT2, there's no word boundary between C1 and C2.
4221 For instance, to tell that ASCII characters and Latin-1 characters can
4222 form a single word, the element `(?l . ?l)' should be in this list
4223 because both characters have the category `l' (Latin characters).
4225 \(2) The case that character are in the same charset is controlled by
4226 the variable `word-separating-categories'.
4228 Emacs find a word boundary between characters of the same charset
4229 if they have categories matching some element of this list.
4231 More precisely, if an element of this list is a cons of category CAT1
4232 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4233 C2 which has CAT2, there's a word boundary between C1 and C2.
4235 For instance, to tell that there's a word boundary between Japanese
4236 Hiragana and Japanese Kanji (both are in the same charset), the
4237 element `(?H . ?C) should be in this list.
4240 Vword_combining_categories = Qnil;
4242 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4243 List of pair (cons) of categories to determine word boundary.
4244 See the documentation of the variable `word-combining-categories'.
4247 Vword_separating_categories = Qnil;