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
37 MORIOKA Tomohiko: Rewritten for XEmacs UTF-2000
50 Lisp_Object Qchar_tablep, Qchar_table;
52 Lisp_Object Vall_syntax_tables;
55 Lisp_Object Qcategory_table_p;
56 Lisp_Object Qcategory_designator_p;
57 Lisp_Object Qcategory_table_value_p;
59 Lisp_Object Vstandard_category_table;
61 /* Variables to determine word boundary. */
62 Lisp_Object Vword_combining_categories, Vword_separating_categories;
68 #if defined(HAVE_DATABASE)
69 EXFUN (Fload_char_attribute_table, 1);
70 EXFUN (Fmap_char_attribute, 3);
72 Lisp_Object Vchar_db_stingy_mode;
75 #define BT_UINT8_MIN 0
76 #define BT_UINT8_MAX (UCHAR_MAX - 4)
77 #define BT_UINT8_t (UCHAR_MAX - 3)
78 #define BT_UINT8_nil (UCHAR_MAX - 2)
79 #define BT_UINT8_unbound (UCHAR_MAX - 1)
80 #define BT_UINT8_unloaded UCHAR_MAX
82 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
83 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
84 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
85 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
86 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
89 INT_UINT8_P (Lisp_Object obj)
95 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
102 UINT8_VALUE_P (Lisp_Object obj)
104 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
105 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
108 INLINE_HEADER unsigned char
109 UINT8_ENCODE (Lisp_Object obj)
111 if (EQ (obj, Qunloaded))
112 return BT_UINT8_unloaded;
113 else if (EQ (obj, Qunbound))
114 return BT_UINT8_unbound;
115 else if (EQ (obj, Qnil))
117 else if (EQ (obj, Qt))
123 INLINE_HEADER Lisp_Object
124 UINT8_DECODE (unsigned char n)
126 if (n == BT_UINT8_unloaded)
128 else if (n == BT_UINT8_unbound)
130 else if (n == BT_UINT8_nil)
132 else if (n == BT_UINT8_t)
139 mark_uint8_byte_table (Lisp_Object obj)
145 print_uint8_byte_table (Lisp_Object obj,
146 Lisp_Object printcharfun, int escapeflag)
148 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
150 struct gcpro gcpro1, gcpro2;
151 GCPRO2 (obj, printcharfun);
153 write_c_string ("\n#<uint8-byte-table", printcharfun);
154 for (i = 0; i < 256; i++)
156 unsigned char n = bte->property[i];
158 write_c_string ("\n ", printcharfun);
159 write_c_string (" ", printcharfun);
160 if (n == BT_UINT8_unbound)
161 write_c_string ("void", printcharfun);
162 else if (n == BT_UINT8_nil)
163 write_c_string ("nil", printcharfun);
164 else if (n == BT_UINT8_t)
165 write_c_string ("t", printcharfun);
170 sprintf (buf, "%hd", n);
171 write_c_string (buf, printcharfun);
175 write_c_string (">", printcharfun);
179 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
181 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
182 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
185 for (i = 0; i < 256; i++)
186 if (te1->property[i] != te2->property[i])
192 uint8_byte_table_hash (Lisp_Object obj, int depth)
194 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
198 for (i = 0; i < 256; i++)
199 hash = HASH2 (hash, te->property[i]);
203 static const struct lrecord_description uint8_byte_table_description[] = {
207 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
208 mark_uint8_byte_table,
209 print_uint8_byte_table,
210 0, uint8_byte_table_equal,
211 uint8_byte_table_hash,
212 uint8_byte_table_description,
213 Lisp_Uint8_Byte_Table);
216 make_uint8_byte_table (unsigned char initval)
220 Lisp_Uint8_Byte_Table *cte;
222 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
223 &lrecord_uint8_byte_table);
225 for (i = 0; i < 256; i++)
226 cte->property[i] = initval;
228 XSETUINT8_BYTE_TABLE (obj, cte);
233 copy_uint8_byte_table (Lisp_Object entry)
235 Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
238 Lisp_Uint8_Byte_Table *ctenew
239 = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
240 &lrecord_uint8_byte_table);
242 for (i = 0; i < 256; i++)
244 ctenew->property[i] = cte->property[i];
247 XSETUINT8_BYTE_TABLE (obj, ctenew);
252 uint8_byte_table_same_value_p (Lisp_Object obj)
254 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
255 unsigned char v0 = bte->property[0];
258 for (i = 1; i < 256; i++)
260 if (bte->property[i] != v0)
267 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
268 Emchar ofs, int place,
269 int (*fn) (struct chartab_range *range,
270 Lisp_Object val, void *arg),
273 struct chartab_range rainj;
275 int unit = 1 << (8 * place);
279 rainj.type = CHARTAB_RANGE_CHAR;
281 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
283 if (ct->property[i] == BT_UINT8_unloaded)
287 for (; c < c1 && retval == 0; c++)
289 Lisp_Object ret = get_char_id_table (root, c);
294 retval = (fn) (&rainj, ret, arg);
298 ct->property[i] = BT_UINT8_unbound;
302 else if (ct->property[i] != BT_UINT8_unbound)
305 for (; c < c1 && retval == 0; c++)
308 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
319 save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
321 Emchar ofs, int place)
323 struct chartab_range rainj;
325 int unit = 1 << (8 * place);
329 rainj.type = CHARTAB_RANGE_CHAR;
331 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
333 if (ct->property[i] == BT_UINT8_unloaded)
337 else if (ct->property[i] != BT_UINT8_unbound)
340 for (; c < c1 && retval == 0; c++)
342 Fput_database (Fprin1_to_string (make_char (c), Qnil),
343 Fprin1_to_string (UINT8_DECODE (ct->property[i]),
354 #define BT_UINT16_MIN 0
355 #define BT_UINT16_MAX (USHRT_MAX - 4)
356 #define BT_UINT16_t (USHRT_MAX - 3)
357 #define BT_UINT16_nil (USHRT_MAX - 2)
358 #define BT_UINT16_unbound (USHRT_MAX - 1)
359 #define BT_UINT16_unloaded USHRT_MAX
361 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
362 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
363 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
364 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
367 INT_UINT16_P (Lisp_Object obj)
371 int num = XINT (obj);
373 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
380 UINT16_VALUE_P (Lisp_Object obj)
382 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
383 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
386 INLINE_HEADER unsigned short
387 UINT16_ENCODE (Lisp_Object obj)
389 if (EQ (obj, Qunloaded))
390 return BT_UINT16_unloaded;
391 else if (EQ (obj, Qunbound))
392 return BT_UINT16_unbound;
393 else if (EQ (obj, Qnil))
394 return BT_UINT16_nil;
395 else if (EQ (obj, Qt))
401 INLINE_HEADER Lisp_Object
402 UINT16_DECODE (unsigned short n)
404 if (n == BT_UINT16_unloaded)
406 else if (n == BT_UINT16_unbound)
408 else if (n == BT_UINT16_nil)
410 else if (n == BT_UINT16_t)
416 INLINE_HEADER unsigned short
417 UINT8_TO_UINT16 (unsigned char n)
419 if (n == BT_UINT8_unloaded)
420 return BT_UINT16_unloaded;
421 else if (n == BT_UINT8_unbound)
422 return BT_UINT16_unbound;
423 else if (n == BT_UINT8_nil)
424 return BT_UINT16_nil;
425 else if (n == BT_UINT8_t)
432 mark_uint16_byte_table (Lisp_Object obj)
438 print_uint16_byte_table (Lisp_Object obj,
439 Lisp_Object printcharfun, int escapeflag)
441 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
443 struct gcpro gcpro1, gcpro2;
444 GCPRO2 (obj, printcharfun);
446 write_c_string ("\n#<uint16-byte-table", printcharfun);
447 for (i = 0; i < 256; i++)
449 unsigned short n = bte->property[i];
451 write_c_string ("\n ", printcharfun);
452 write_c_string (" ", printcharfun);
453 if (n == BT_UINT16_unbound)
454 write_c_string ("void", printcharfun);
455 else if (n == BT_UINT16_nil)
456 write_c_string ("nil", printcharfun);
457 else if (n == BT_UINT16_t)
458 write_c_string ("t", printcharfun);
463 sprintf (buf, "%hd", n);
464 write_c_string (buf, printcharfun);
468 write_c_string (">", printcharfun);
472 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
474 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
475 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
478 for (i = 0; i < 256; i++)
479 if (te1->property[i] != te2->property[i])
485 uint16_byte_table_hash (Lisp_Object obj, int depth)
487 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
491 for (i = 0; i < 256; i++)
492 hash = HASH2 (hash, te->property[i]);
496 static const struct lrecord_description uint16_byte_table_description[] = {
500 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
501 mark_uint16_byte_table,
502 print_uint16_byte_table,
503 0, uint16_byte_table_equal,
504 uint16_byte_table_hash,
505 uint16_byte_table_description,
506 Lisp_Uint16_Byte_Table);
509 make_uint16_byte_table (unsigned short initval)
513 Lisp_Uint16_Byte_Table *cte;
515 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
516 &lrecord_uint16_byte_table);
518 for (i = 0; i < 256; i++)
519 cte->property[i] = initval;
521 XSETUINT16_BYTE_TABLE (obj, cte);
526 copy_uint16_byte_table (Lisp_Object entry)
528 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
531 Lisp_Uint16_Byte_Table *ctenew
532 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
533 &lrecord_uint16_byte_table);
535 for (i = 0; i < 256; i++)
537 ctenew->property[i] = cte->property[i];
540 XSETUINT16_BYTE_TABLE (obj, ctenew);
545 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
549 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
550 Lisp_Uint16_Byte_Table* cte;
552 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
553 &lrecord_uint16_byte_table);
554 for (i = 0; i < 256; i++)
556 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
558 XSETUINT16_BYTE_TABLE (obj, cte);
563 uint16_byte_table_same_value_p (Lisp_Object obj)
565 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
566 unsigned short v0 = bte->property[0];
569 for (i = 1; i < 256; i++)
571 if (bte->property[i] != v0)
578 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
579 Emchar ofs, int place,
580 int (*fn) (struct chartab_range *range,
581 Lisp_Object val, void *arg),
584 struct chartab_range rainj;
586 int unit = 1 << (8 * place);
590 rainj.type = CHARTAB_RANGE_CHAR;
592 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
594 if (ct->property[i] == BT_UINT16_unloaded)
598 for (; c < c1 && retval == 0; c++)
600 Lisp_Object ret = get_char_id_table (root, c);
605 retval = (fn) (&rainj, ret, arg);
609 ct->property[i] = BT_UINT16_unbound;
613 else if (ct->property[i] != BT_UINT16_unbound)
616 for (; c < c1 && retval == 0; c++)
619 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
630 save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
632 Emchar ofs, int place)
634 struct chartab_range rainj;
636 int unit = 1 << (8 * place);
640 rainj.type = CHARTAB_RANGE_CHAR;
642 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
644 if (ct->property[i] == BT_UINT16_unloaded)
648 else if (ct->property[i] != BT_UINT16_unbound)
651 for (; c < c1 && retval == 0; c++)
653 Fput_database (Fprin1_to_string (make_char (c), Qnil),
654 Fprin1_to_string (UINT16_DECODE (ct->property[i]),
667 mark_byte_table (Lisp_Object obj)
669 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
672 for (i = 0; i < 256; i++)
674 mark_object (cte->property[i]);
680 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
682 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
684 struct gcpro gcpro1, gcpro2;
685 GCPRO2 (obj, printcharfun);
687 write_c_string ("\n#<byte-table", printcharfun);
688 for (i = 0; i < 256; i++)
690 Lisp_Object elt = bte->property[i];
692 write_c_string ("\n ", printcharfun);
693 write_c_string (" ", printcharfun);
694 if (EQ (elt, Qunbound))
695 write_c_string ("void", printcharfun);
697 print_internal (elt, printcharfun, escapeflag);
700 write_c_string (">", printcharfun);
704 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
706 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
707 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
710 for (i = 0; i < 256; i++)
711 if (BYTE_TABLE_P (cte1->property[i]))
713 if (BYTE_TABLE_P (cte2->property[i]))
715 if (!byte_table_equal (cte1->property[i],
716 cte2->property[i], depth + 1))
723 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
729 byte_table_hash (Lisp_Object obj, int depth)
731 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
733 return internal_array_hash (cte->property, 256, depth);
736 static const struct lrecord_description byte_table_description[] = {
737 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
741 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
746 byte_table_description,
750 make_byte_table (Lisp_Object initval)
754 Lisp_Byte_Table *cte;
756 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
758 for (i = 0; i < 256; i++)
759 cte->property[i] = initval;
761 XSETBYTE_TABLE (obj, cte);
766 copy_byte_table (Lisp_Object entry)
768 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
771 Lisp_Byte_Table *ctnew
772 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
774 for (i = 0; i < 256; i++)
776 if (UINT8_BYTE_TABLE_P (cte->property[i]))
778 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
780 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
782 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
784 else if (BYTE_TABLE_P (cte->property[i]))
786 ctnew->property[i] = copy_byte_table (cte->property[i]);
789 ctnew->property[i] = cte->property[i];
792 XSETBYTE_TABLE (obj, ctnew);
797 byte_table_same_value_p (Lisp_Object obj)
799 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
800 Lisp_Object v0 = bte->property[0];
803 for (i = 1; i < 256; i++)
805 if (!internal_equal (bte->property[i], v0, 0))
812 map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
813 Emchar ofs, int place,
814 int (*fn) (struct chartab_range *range,
815 Lisp_Object val, void *arg),
820 int unit = 1 << (8 * place);
823 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
826 if (UINT8_BYTE_TABLE_P (v))
829 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
830 c, place - 1, fn, arg);
833 else if (UINT16_BYTE_TABLE_P (v))
836 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
837 c, place - 1, fn, arg);
840 else if (BYTE_TABLE_P (v))
842 retval = map_over_byte_table (XBYTE_TABLE(v), root,
843 c, place - 1, fn, arg);
846 else if (EQ (v, Qunloaded))
849 struct chartab_range rainj;
850 Emchar c1 = c + unit;
852 rainj.type = CHARTAB_RANGE_CHAR;
854 for (; c < c1 && retval == 0; c++)
856 Lisp_Object ret = get_char_id_table (root, c);
861 retval = (fn) (&rainj, ret, arg);
865 ct->property[i] = Qunbound;
869 else if (!UNBOUNDP (v))
871 struct chartab_range rainj;
872 Emchar c1 = c + unit;
874 rainj.type = CHARTAB_RANGE_CHAR;
876 for (; c < c1 && retval == 0; c++)
879 retval = (fn) (&rainj, v, arg);
890 save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
892 Emchar ofs, int place)
896 int unit = 1 << (8 * place);
899 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
902 if (UINT8_BYTE_TABLE_P (v))
904 save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db,
908 else if (UINT16_BYTE_TABLE_P (v))
910 save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db,
914 else if (BYTE_TABLE_P (v))
916 save_byte_table (XBYTE_TABLE(v), root, db,
920 else if (EQ (v, Qunloaded))
924 else if (!UNBOUNDP (v))
926 struct chartab_range rainj;
927 Emchar c1 = c + unit;
929 rainj.type = CHARTAB_RANGE_CHAR;
931 for (; c < c1 && retval == 0; c++)
933 Fput_database (Fprin1_to_string (make_char (c), Qnil),
934 Fprin1_to_string (v, Qnil),
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 ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3404 Mount database file on char-attribute-table ATTRIBUTE.
3408 #ifdef HAVE_DATABASE
3409 Lisp_Object table = Fgethash (attribute,
3410 Vchar_attribute_hash_table, Qunbound);
3412 if (UNBOUNDP (table))
3414 Lisp_Char_Table *ct;
3416 table = make_char_id_table (Qunbound);
3417 Fputhash (attribute, table, Vchar_attribute_hash_table);
3418 XCHAR_TABLE_NAME(table) = attribute;
3419 ct = XCHAR_TABLE (table);
3420 ct->table = Qunloaded;
3421 XCHAR_TABLE_UNLOADED(table) = 1;
3429 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3430 Close database of ATTRIBUTE.
3434 #ifdef HAVE_DATABASE
3435 Lisp_Object table = Fgethash (attribute,
3436 Vchar_attribute_hash_table, Qunbound);
3437 Lisp_Char_Table *ct;
3439 if (CHAR_TABLEP (table))
3440 ct = XCHAR_TABLE (table);
3446 if (!NILP (Fdatabase_live_p (ct->db)))
3447 Fclose_database (ct->db);
3454 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3455 Reset values of ATTRIBUTE with database file.
3459 #ifdef HAVE_DATABASE
3460 Lisp_Object table = Fgethash (attribute,
3461 Vchar_attribute_hash_table, Qunbound);
3462 Lisp_Char_Table *ct;
3464 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3466 if (!NILP (Ffile_exists_p (db_file)))
3468 if (UNBOUNDP (table))
3470 table = make_char_id_table (Qunbound);
3471 Fputhash (attribute, table, Vchar_attribute_hash_table);
3472 XCHAR_TABLE_NAME(table) = attribute;
3474 ct = XCHAR_TABLE (table);
3475 ct->table = Qunloaded;
3476 if (!NILP (Fdatabase_live_p (ct->db)))
3477 Fclose_database (ct->db);
3479 XCHAR_TABLE_UNLOADED(table) = 1;
3486 #ifdef HAVE_DATABASE
3488 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3490 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3492 if (!NILP (attribute))
3494 if (NILP (Fdatabase_live_p (cit->db)))
3497 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3499 cit->db = Fopen_database (db_file, Qnil, Qnil,
3500 build_string ("r"), Qnil);
3502 if (!NILP (cit->db))
3505 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3507 if (!UNBOUNDP (val))
3511 if (!NILP (Vchar_db_stingy_mode))
3513 Fclose_database (cit->db);
3522 Lisp_Char_Table* char_attribute_table_to_load;
3524 Lisp_Object Qload_char_attribute_table_map_function;
3526 DEFUN ("load-char-attribute-table-map-function",
3527 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3528 For internal use. Don't use it.
3532 Lisp_Object c = Fread (key);
3533 Emchar code = XCHAR (c);
3534 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3536 if (EQ (ret, Qunloaded))
3537 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3542 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3543 Load values of ATTRIBUTE into database file.
3547 #ifdef HAVE_DATABASE
3548 Lisp_Object table = Fgethash (attribute,
3549 Vchar_attribute_hash_table,
3551 if (CHAR_TABLEP (table))
3553 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3555 if (NILP (Fdatabase_live_p (ct->db)))
3558 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3560 ct->db = Fopen_database (db_file, Qnil, Qnil,
3561 build_string ("r"), Qnil);
3565 struct gcpro gcpro1;
3567 char_attribute_table_to_load = XCHAR_TABLE (table);
3569 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3571 Fclose_database (ct->db);
3573 XCHAR_TABLE_UNLOADED(table) = 0;
3581 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3582 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3583 each key and value in the table.
3585 RANGE specifies a subrange to map over and is in the same format as
3586 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3589 (function, attribute, range))
3592 Lisp_Char_Table *ct;
3593 struct slow_map_char_table_arg slarg;
3594 struct gcpro gcpro1, gcpro2;
3595 struct chartab_range rainj;
3597 if (!NILP (ccs = Ffind_charset (attribute)))
3599 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3601 if (CHAR_TABLEP (encoding_table))
3602 ct = XCHAR_TABLE (encoding_table);
3608 Lisp_Object table = Fgethash (attribute,
3609 Vchar_attribute_hash_table,
3611 if (CHAR_TABLEP (table))
3612 ct = XCHAR_TABLE (table);
3618 decode_char_table_range (range, &rainj);
3619 #ifdef HAVE_DATABASE
3620 if (CHAR_TABLE_UNLOADED(ct))
3621 Fload_char_attribute_table (attribute);
3623 slarg.function = function;
3624 slarg.retval = Qnil;
3625 GCPRO2 (slarg.function, slarg.retval);
3626 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3629 return slarg.retval;
3632 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3633 Store character's ATTRIBUTES.
3637 Lisp_Object rest = attributes;
3638 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3639 Lisp_Object character;
3643 while (CONSP (rest))
3645 Lisp_Object cell = Fcar (rest);
3649 signal_simple_error ("Invalid argument", attributes);
3650 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3651 && ((XCHARSET_FINAL (ccs) != 0) ||
3652 (XCHARSET_MAX_CODE (ccs) > 0) ||
3653 (EQ (ccs, Vcharset_chinese_big5))) )
3657 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3659 character = Fdecode_char (ccs, cell, Qnil);
3660 if (!NILP (character))
3661 goto setup_attributes;
3665 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3666 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3670 signal_simple_error ("Invalid argument", attributes);
3672 character = make_char (XINT (code) + 0x100000);
3673 goto setup_attributes;
3677 else if (!INTP (code))
3678 signal_simple_error ("Invalid argument", attributes);
3680 character = make_char (XINT (code));
3684 while (CONSP (rest))
3686 Lisp_Object cell = Fcar (rest);
3689 signal_simple_error ("Invalid argument", attributes);
3691 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3697 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3698 Retrieve the character of the given ATTRIBUTES.
3702 Lisp_Object rest = attributes;
3705 while (CONSP (rest))
3707 Lisp_Object cell = Fcar (rest);
3711 signal_simple_error ("Invalid argument", attributes);
3712 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3716 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3718 return Fdecode_char (ccs, cell, Qnil);
3722 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3723 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3726 signal_simple_error ("Invalid argument", attributes);
3728 return make_char (XINT (code) + 0x100000);
3736 /************************************************************************/
3737 /* Char table read syntax */
3738 /************************************************************************/
3741 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3742 Error_behavior errb)
3744 /* #### should deal with ERRB */
3745 symbol_to_char_table_type (value);
3750 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3751 Error_behavior errb)
3755 /* #### should deal with ERRB */
3756 EXTERNAL_LIST_LOOP (rest, value)
3758 Lisp_Object range = XCAR (rest);
3759 struct chartab_range dummy;
3763 signal_simple_error ("Invalid list format", value);
3766 if (!CONSP (XCDR (range))
3767 || !NILP (XCDR (XCDR (range))))
3768 signal_simple_error ("Invalid range format", range);
3769 decode_char_table_range (XCAR (range), &dummy);
3770 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3773 decode_char_table_range (range, &dummy);
3780 chartab_instantiate (Lisp_Object data)
3782 Lisp_Object chartab;
3783 Lisp_Object type = Qgeneric;
3784 Lisp_Object dataval = Qnil;
3786 while (!NILP (data))
3788 Lisp_Object keyw = Fcar (data);
3794 if (EQ (keyw, Qtype))
3796 else if (EQ (keyw, Qdata))
3800 chartab = Fmake_char_table (type);
3803 while (!NILP (data))
3805 Lisp_Object range = Fcar (data);
3806 Lisp_Object val = Fcar (Fcdr (data));
3808 data = Fcdr (Fcdr (data));
3811 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3813 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3814 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3817 for (i = first; i <= last; i++)
3818 Fput_char_table (make_char (i), val, chartab);
3824 Fput_char_table (range, val, chartab);
3833 /************************************************************************/
3834 /* Category Tables, specifically */
3835 /************************************************************************/
3837 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3838 Return t if OBJECT is a category table.
3839 A category table is a type of char table used for keeping track of
3840 categories. Categories are used for classifying characters for use
3841 in regexps -- you can refer to a category rather than having to use
3842 a complicated [] expression (and category lookups are significantly
3845 There are 95 different categories available, one for each printable
3846 character (including space) in the ASCII charset. Each category
3847 is designated by one such character, called a "category designator".
3848 They are specified in a regexp using the syntax "\\cX", where X is
3849 a category designator.
3851 A category table specifies, for each character, the categories that
3852 the character is in. Note that a character can be in more than one
3853 category. More specifically, a category table maps from a character
3854 to either the value nil (meaning the character is in no categories)
3855 or a 95-element bit vector, specifying for each of the 95 categories
3856 whether the character is in that category.
3858 Special Lisp functions are provided that abstract this, so you do not
3859 have to directly manipulate bit vectors.
3863 return (CHAR_TABLEP (object) &&
3864 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3869 check_category_table (Lisp_Object object, Lisp_Object default_)
3873 while (NILP (Fcategory_table_p (object)))
3874 object = wrong_type_argument (Qcategory_table_p, object);
3879 check_category_char (Emchar ch, Lisp_Object table,
3880 unsigned int designator, unsigned int not_p)
3882 REGISTER Lisp_Object temp;
3883 Lisp_Char_Table *ctbl;
3884 #ifdef ERROR_CHECK_TYPECHECK
3885 if (NILP (Fcategory_table_p (table)))
3886 signal_simple_error ("Expected category table", table);
3888 ctbl = XCHAR_TABLE (table);
3889 temp = get_char_table (ch, ctbl);
3894 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3897 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3898 Return t if category of the character at POSITION includes DESIGNATOR.
3899 Optional third arg BUFFER specifies which buffer to use, and defaults
3900 to the current buffer.
3901 Optional fourth arg CATEGORY-TABLE specifies the category table to
3902 use, and defaults to BUFFER's category table.
3904 (position, designator, buffer, category_table))
3909 struct buffer *buf = decode_buffer (buffer, 0);
3911 CHECK_INT (position);
3912 CHECK_CATEGORY_DESIGNATOR (designator);
3913 des = XCHAR (designator);
3914 ctbl = check_category_table (category_table, Vstandard_category_table);
3915 ch = BUF_FETCH_CHAR (buf, XINT (position));
3916 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3919 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3920 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3921 Optional third arg CATEGORY-TABLE specifies the category table to use,
3922 and defaults to the standard category table.
3924 (character, designator, category_table))
3930 CHECK_CATEGORY_DESIGNATOR (designator);
3931 des = XCHAR (designator);
3932 CHECK_CHAR (character);
3933 ch = XCHAR (character);
3934 ctbl = check_category_table (category_table, Vstandard_category_table);
3935 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3938 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3939 Return BUFFER's current category table.
3940 BUFFER defaults to the current buffer.
3944 return decode_buffer (buffer, 0)->category_table;
3947 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3948 Return the standard category table.
3949 This is the one used for new buffers.
3953 return Vstandard_category_table;
3956 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3957 Return a new category table which is a copy of CATEGORY-TABLE.
3958 CATEGORY-TABLE defaults to the standard category table.
3962 if (NILP (Vstandard_category_table))
3963 return Fmake_char_table (Qcategory);
3966 check_category_table (category_table, Vstandard_category_table);
3967 return Fcopy_char_table (category_table);
3970 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3971 Select CATEGORY-TABLE as the new category table for BUFFER.
3972 BUFFER defaults to the current buffer if omitted.
3974 (category_table, buffer))
3976 struct buffer *buf = decode_buffer (buffer, 0);
3977 category_table = check_category_table (category_table, Qnil);
3978 buf->category_table = category_table;
3979 /* Indicate that this buffer now has a specified category table. */
3980 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3981 return category_table;
3984 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3985 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3989 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3992 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3993 Return t if OBJECT is a category table value.
3994 Valid values are nil or a bit vector of size 95.
3998 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
4002 #define CATEGORYP(x) \
4003 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
4005 #define CATEGORY_SET(c) \
4006 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
4008 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
4009 The faster version of `!NILP (Faref (category_set, category))'. */
4010 #define CATEGORY_MEMBER(category, category_set) \
4011 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
4013 /* Return 1 if there is a word boundary between two word-constituent
4014 characters C1 and C2 if they appear in this order, else return 0.
4015 Use the macro WORD_BOUNDARY_P instead of calling this function
4018 int word_boundary_p (Emchar c1, Emchar c2);
4020 word_boundary_p (Emchar c1, Emchar c2)
4022 Lisp_Object category_set1, category_set2;
4027 if (COMPOSITE_CHAR_P (c1))
4028 c1 = cmpchar_component (c1, 0, 1);
4029 if (COMPOSITE_CHAR_P (c2))
4030 c2 = cmpchar_component (c2, 0, 1);
4033 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4035 tail = Vword_separating_categories;
4040 tail = Vword_combining_categories;
4044 category_set1 = CATEGORY_SET (c1);
4045 if (NILP (category_set1))
4046 return default_result;
4047 category_set2 = CATEGORY_SET (c2);
4048 if (NILP (category_set2))
4049 return default_result;
4051 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4053 Lisp_Object elt = XCONS(tail)->car;
4056 && CATEGORYP (XCONS (elt)->car)
4057 && CATEGORYP (XCONS (elt)->cdr)
4058 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4059 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4060 return !default_result;
4062 return default_result;
4068 syms_of_chartab (void)
4071 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4072 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4073 INIT_LRECORD_IMPLEMENTATION (byte_table);
4075 defsymbol (&Qsystem_char_id, "system-char-id");
4077 defsymbol (&Qto_ucs, "=>ucs");
4078 defsymbol (&Q_ucs, "->ucs");
4079 defsymbol (&Q_ucs_variants, "->ucs-variants");
4080 defsymbol (&Q_decomposition, "->decomposition");
4081 defsymbol (&Qcompat, "compat");
4082 defsymbol (&Qisolated, "isolated");
4083 defsymbol (&Qinitial, "initial");
4084 defsymbol (&Qmedial, "medial");
4085 defsymbol (&Qfinal, "final");
4086 defsymbol (&Qvertical, "vertical");
4087 defsymbol (&QnoBreak, "noBreak");
4088 defsymbol (&Qfraction, "fraction");
4089 defsymbol (&Qsuper, "super");
4090 defsymbol (&Qsub, "sub");
4091 defsymbol (&Qcircle, "circle");
4092 defsymbol (&Qsquare, "square");
4093 defsymbol (&Qwide, "wide");
4094 defsymbol (&Qnarrow, "narrow");
4095 defsymbol (&Qsmall, "small");
4096 defsymbol (&Qfont, "font");
4098 DEFSUBR (Fchar_attribute_list);
4099 DEFSUBR (Ffind_char_attribute_table);
4100 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4101 DEFSUBR (Fput_char_table_map_function);
4102 DEFSUBR (Fsave_char_attribute_table);
4103 DEFSUBR (Fmount_char_attribute_table);
4104 DEFSUBR (Freset_char_attribute_table);
4105 DEFSUBR (Fclose_char_attribute_table);
4106 #ifdef HAVE_DATABASE
4107 defsymbol (&Qload_char_attribute_table_map_function,
4108 "load-char-attribute-table-map-function");
4109 DEFSUBR (Fload_char_attribute_table_map_function);
4111 DEFSUBR (Fload_char_attribute_table);
4112 DEFSUBR (Fchar_attribute_alist);
4113 DEFSUBR (Fget_char_attribute);
4114 DEFSUBR (Fput_char_attribute);
4115 DEFSUBR (Fremove_char_attribute);
4116 DEFSUBR (Fmap_char_attribute);
4117 DEFSUBR (Fdefine_char);
4118 DEFSUBR (Ffind_char);
4119 DEFSUBR (Fchar_variants);
4121 DEFSUBR (Fget_composite_char);
4124 INIT_LRECORD_IMPLEMENTATION (char_table);
4128 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4131 defsymbol (&Qcategory_table_p, "category-table-p");
4132 defsymbol (&Qcategory_designator_p, "category-designator-p");
4133 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4136 defsymbol (&Qchar_table, "char-table");
4137 defsymbol (&Qchar_tablep, "char-table-p");
4139 DEFSUBR (Fchar_table_p);
4140 DEFSUBR (Fchar_table_type_list);
4141 DEFSUBR (Fvalid_char_table_type_p);
4142 DEFSUBR (Fchar_table_type);
4143 DEFSUBR (Freset_char_table);
4144 DEFSUBR (Fmake_char_table);
4145 DEFSUBR (Fcopy_char_table);
4146 DEFSUBR (Fget_char_table);
4147 DEFSUBR (Fget_range_char_table);
4148 DEFSUBR (Fvalid_char_table_value_p);
4149 DEFSUBR (Fcheck_valid_char_table_value);
4150 DEFSUBR (Fput_char_table);
4151 DEFSUBR (Fmap_char_table);
4154 DEFSUBR (Fcategory_table_p);
4155 DEFSUBR (Fcategory_table);
4156 DEFSUBR (Fstandard_category_table);
4157 DEFSUBR (Fcopy_category_table);
4158 DEFSUBR (Fset_category_table);
4159 DEFSUBR (Fcheck_category_at);
4160 DEFSUBR (Fchar_in_category_p);
4161 DEFSUBR (Fcategory_designator_p);
4162 DEFSUBR (Fcategory_table_value_p);
4168 vars_of_chartab (void)
4171 staticpro (&Vcharacter_composition_table);
4172 Vcharacter_composition_table = make_char_id_table (Qnil);
4174 staticpro (&Vcharacter_variant_table);
4175 Vcharacter_variant_table = make_char_id_table (Qunbound);
4177 #ifdef HAVE_DATABASE
4178 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4180 Vchar_db_stingy_mode = Qt;
4181 #endif /* HAVE_DATABASE */
4183 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4184 Vall_syntax_tables = Qnil;
4185 dump_add_weak_object_chain (&Vall_syntax_tables);
4189 structure_type_create_chartab (void)
4191 struct structure_type *st;
4193 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4195 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4196 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4200 complex_vars_of_chartab (void)
4203 staticpro (&Vchar_attribute_hash_table);
4204 Vchar_attribute_hash_table
4205 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4206 #ifdef HAVE_DATABASE
4207 Fputhash (Q_ucs_variants, Vcharacter_variant_table,
4208 Vchar_attribute_hash_table);
4209 XCHAR_TABLE_NAME (Vcharacter_variant_table) = Q_ucs_variants;
4210 #endif /* HAVE_DATABASE */
4211 #endif /* UTF2000 */
4213 /* Set this now, so first buffer creation can refer to it. */
4214 /* Make it nil before calling copy-category-table
4215 so that copy-category-table will know not to try to copy from garbage */
4216 Vstandard_category_table = Qnil;
4217 Vstandard_category_table = Fcopy_category_table (Qnil);
4218 staticpro (&Vstandard_category_table);
4220 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4221 List of pair (cons) of categories to determine word boundary.
4223 Emacs treats a sequence of word constituent characters as a single
4224 word (i.e. finds no word boundary between them) iff they belongs to
4225 the same charset. But, exceptions are allowed in the following cases.
4227 \(1) The case that characters are in different charsets is controlled
4228 by the variable `word-combining-categories'.
4230 Emacs finds no word boundary between characters of different charsets
4231 if they have categories matching some element of this list.
4233 More precisely, if an element of this list is a cons of category CAT1
4234 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4235 C2 which has CAT2, there's no word boundary between C1 and C2.
4237 For instance, to tell that ASCII characters and Latin-1 characters can
4238 form a single word, the element `(?l . ?l)' should be in this list
4239 because both characters have the category `l' (Latin characters).
4241 \(2) The case that character are in the same charset is controlled by
4242 the variable `word-separating-categories'.
4244 Emacs find a word boundary between characters of the same charset
4245 if they have categories matching some element of this list.
4247 More precisely, if an element of this list is a cons of category CAT1
4248 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4249 C2 which has CAT2, there's a word boundary between C1 and C2.
4251 For instance, to tell that there's a word boundary between Japanese
4252 Hiragana and Japanese Kanji (both are in the same charset), the
4253 element `(?H . ?C) should be in this list.
4256 Vword_combining_categories = Qnil;
4258 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4259 List of pair (cons) of categories to determine word boundary.
4260 See the documentation of the variable `word-combining-categories'.
4263 Vword_separating_categories = Qnil;