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 EXFUN (Fmap_char_attribute, 3);
70 #if defined(HAVE_DATABASE)
71 EXFUN (Fload_char_attribute_table, 1);
73 Lisp_Object Vchar_db_stingy_mode;
76 #define BT_UINT8_MIN 0
77 #define BT_UINT8_MAX (UCHAR_MAX - 4)
78 #define BT_UINT8_t (UCHAR_MAX - 3)
79 #define BT_UINT8_nil (UCHAR_MAX - 2)
80 #define BT_UINT8_unbound (UCHAR_MAX - 1)
81 #define BT_UINT8_unloaded UCHAR_MAX
83 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
84 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
85 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
86 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
87 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
90 INT_UINT8_P (Lisp_Object obj)
96 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
103 UINT8_VALUE_P (Lisp_Object obj)
105 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
106 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
109 INLINE_HEADER unsigned char
110 UINT8_ENCODE (Lisp_Object obj)
112 if (EQ (obj, Qunloaded))
113 return BT_UINT8_unloaded;
114 else if (EQ (obj, Qunbound))
115 return BT_UINT8_unbound;
116 else if (EQ (obj, Qnil))
118 else if (EQ (obj, Qt))
124 INLINE_HEADER Lisp_Object
125 UINT8_DECODE (unsigned char n)
127 if (n == BT_UINT8_unloaded)
129 else if (n == BT_UINT8_unbound)
131 else if (n == BT_UINT8_nil)
133 else if (n == BT_UINT8_t)
140 mark_uint8_byte_table (Lisp_Object obj)
146 print_uint8_byte_table (Lisp_Object obj,
147 Lisp_Object printcharfun, int escapeflag)
149 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
151 struct gcpro gcpro1, gcpro2;
152 GCPRO2 (obj, printcharfun);
154 write_c_string ("\n#<uint8-byte-table", printcharfun);
155 for (i = 0; i < 256; i++)
157 unsigned char n = bte->property[i];
159 write_c_string ("\n ", printcharfun);
160 write_c_string (" ", printcharfun);
161 if (n == BT_UINT8_unbound)
162 write_c_string ("void", printcharfun);
163 else if (n == BT_UINT8_nil)
164 write_c_string ("nil", printcharfun);
165 else if (n == BT_UINT8_t)
166 write_c_string ("t", printcharfun);
171 sprintf (buf, "%hd", n);
172 write_c_string (buf, printcharfun);
176 write_c_string (">", printcharfun);
180 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
182 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
183 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
186 for (i = 0; i < 256; i++)
187 if (te1->property[i] != te2->property[i])
193 uint8_byte_table_hash (Lisp_Object obj, int depth)
195 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
199 for (i = 0; i < 256; i++)
200 hash = HASH2 (hash, te->property[i]);
204 static const struct lrecord_description uint8_byte_table_description[] = {
208 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
209 mark_uint8_byte_table,
210 print_uint8_byte_table,
211 0, uint8_byte_table_equal,
212 uint8_byte_table_hash,
213 uint8_byte_table_description,
214 Lisp_Uint8_Byte_Table);
217 make_uint8_byte_table (unsigned char initval)
221 Lisp_Uint8_Byte_Table *cte;
223 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
224 &lrecord_uint8_byte_table);
226 for (i = 0; i < 256; i++)
227 cte->property[i] = initval;
229 XSETUINT8_BYTE_TABLE (obj, cte);
234 copy_uint8_byte_table (Lisp_Object entry)
236 Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
239 Lisp_Uint8_Byte_Table *ctenew
240 = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
241 &lrecord_uint8_byte_table);
243 for (i = 0; i < 256; i++)
245 ctenew->property[i] = cte->property[i];
248 XSETUINT8_BYTE_TABLE (obj, ctenew);
253 uint8_byte_table_same_value_p (Lisp_Object obj)
255 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
256 unsigned char v0 = bte->property[0];
259 for (i = 1; i < 256; i++)
261 if (bte->property[i] != v0)
268 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
269 Emchar ofs, int place,
270 int (*fn) (struct chartab_range *range,
271 Lisp_Object val, void *arg),
274 struct chartab_range rainj;
276 int unit = 1 << (8 * place);
280 rainj.type = CHARTAB_RANGE_CHAR;
282 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
284 if (ct->property[i] == BT_UINT8_unloaded)
288 for (; c < c1 && retval == 0; c++)
290 Lisp_Object ret = get_char_id_table (root, c);
295 retval = (fn) (&rainj, ret, arg);
299 ct->property[i] = BT_UINT8_unbound;
303 else if (ct->property[i] != BT_UINT8_unbound)
306 for (; c < c1 && retval == 0; c++)
309 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
320 save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
322 Emchar ofs, int place)
324 struct chartab_range rainj;
326 int unit = 1 << (8 * place);
330 rainj.type = CHARTAB_RANGE_CHAR;
332 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
334 if (ct->property[i] == BT_UINT8_unloaded)
338 else if (ct->property[i] != BT_UINT8_unbound)
341 for (; c < c1 && retval == 0; c++)
343 Fput_database (Fprin1_to_string (make_char (c), Qnil),
344 Fprin1_to_string (UINT8_DECODE (ct->property[i]),
355 #define BT_UINT16_MIN 0
356 #define BT_UINT16_MAX (USHRT_MAX - 4)
357 #define BT_UINT16_t (USHRT_MAX - 3)
358 #define BT_UINT16_nil (USHRT_MAX - 2)
359 #define BT_UINT16_unbound (USHRT_MAX - 1)
360 #define BT_UINT16_unloaded USHRT_MAX
362 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
363 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
364 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
365 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
368 INT_UINT16_P (Lisp_Object obj)
372 int num = XINT (obj);
374 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
381 UINT16_VALUE_P (Lisp_Object obj)
383 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
384 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
387 INLINE_HEADER unsigned short
388 UINT16_ENCODE (Lisp_Object obj)
390 if (EQ (obj, Qunloaded))
391 return BT_UINT16_unloaded;
392 else if (EQ (obj, Qunbound))
393 return BT_UINT16_unbound;
394 else if (EQ (obj, Qnil))
395 return BT_UINT16_nil;
396 else if (EQ (obj, Qt))
402 INLINE_HEADER Lisp_Object
403 UINT16_DECODE (unsigned short n)
405 if (n == BT_UINT16_unloaded)
407 else if (n == BT_UINT16_unbound)
409 else if (n == BT_UINT16_nil)
411 else if (n == BT_UINT16_t)
417 INLINE_HEADER unsigned short
418 UINT8_TO_UINT16 (unsigned char n)
420 if (n == BT_UINT8_unloaded)
421 return BT_UINT16_unloaded;
422 else if (n == BT_UINT8_unbound)
423 return BT_UINT16_unbound;
424 else if (n == BT_UINT8_nil)
425 return BT_UINT16_nil;
426 else if (n == BT_UINT8_t)
433 mark_uint16_byte_table (Lisp_Object obj)
439 print_uint16_byte_table (Lisp_Object obj,
440 Lisp_Object printcharfun, int escapeflag)
442 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
444 struct gcpro gcpro1, gcpro2;
445 GCPRO2 (obj, printcharfun);
447 write_c_string ("\n#<uint16-byte-table", printcharfun);
448 for (i = 0; i < 256; i++)
450 unsigned short n = bte->property[i];
452 write_c_string ("\n ", printcharfun);
453 write_c_string (" ", printcharfun);
454 if (n == BT_UINT16_unbound)
455 write_c_string ("void", printcharfun);
456 else if (n == BT_UINT16_nil)
457 write_c_string ("nil", printcharfun);
458 else if (n == BT_UINT16_t)
459 write_c_string ("t", printcharfun);
464 sprintf (buf, "%hd", n);
465 write_c_string (buf, printcharfun);
469 write_c_string (">", printcharfun);
473 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
475 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
476 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
479 for (i = 0; i < 256; i++)
480 if (te1->property[i] != te2->property[i])
486 uint16_byte_table_hash (Lisp_Object obj, int depth)
488 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
492 for (i = 0; i < 256; i++)
493 hash = HASH2 (hash, te->property[i]);
497 static const struct lrecord_description uint16_byte_table_description[] = {
501 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
502 mark_uint16_byte_table,
503 print_uint16_byte_table,
504 0, uint16_byte_table_equal,
505 uint16_byte_table_hash,
506 uint16_byte_table_description,
507 Lisp_Uint16_Byte_Table);
510 make_uint16_byte_table (unsigned short initval)
514 Lisp_Uint16_Byte_Table *cte;
516 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
517 &lrecord_uint16_byte_table);
519 for (i = 0; i < 256; i++)
520 cte->property[i] = initval;
522 XSETUINT16_BYTE_TABLE (obj, cte);
527 copy_uint16_byte_table (Lisp_Object entry)
529 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
532 Lisp_Uint16_Byte_Table *ctenew
533 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
534 &lrecord_uint16_byte_table);
536 for (i = 0; i < 256; i++)
538 ctenew->property[i] = cte->property[i];
541 XSETUINT16_BYTE_TABLE (obj, ctenew);
546 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
550 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
551 Lisp_Uint16_Byte_Table* cte;
553 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
554 &lrecord_uint16_byte_table);
555 for (i = 0; i < 256; i++)
557 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
559 XSETUINT16_BYTE_TABLE (obj, cte);
564 uint16_byte_table_same_value_p (Lisp_Object obj)
566 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
567 unsigned short v0 = bte->property[0];
570 for (i = 1; i < 256; i++)
572 if (bte->property[i] != v0)
579 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
580 Emchar ofs, int place,
581 int (*fn) (struct chartab_range *range,
582 Lisp_Object val, void *arg),
585 struct chartab_range rainj;
587 int unit = 1 << (8 * place);
591 rainj.type = CHARTAB_RANGE_CHAR;
593 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
595 if (ct->property[i] == BT_UINT16_unloaded)
599 for (; c < c1 && retval == 0; c++)
601 Lisp_Object ret = get_char_id_table (root, c);
606 retval = (fn) (&rainj, ret, arg);
610 ct->property[i] = BT_UINT16_unbound;
614 else if (ct->property[i] != BT_UINT16_unbound)
617 for (; c < c1 && retval == 0; c++)
620 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
631 save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
633 Emchar ofs, int place)
635 struct chartab_range rainj;
637 int unit = 1 << (8 * place);
641 rainj.type = CHARTAB_RANGE_CHAR;
643 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
645 if (ct->property[i] == BT_UINT16_unloaded)
649 else if (ct->property[i] != BT_UINT16_unbound)
652 for (; c < c1 && retval == 0; c++)
654 Fput_database (Fprin1_to_string (make_char (c), Qnil),
655 Fprin1_to_string (UINT16_DECODE (ct->property[i]),
668 mark_byte_table (Lisp_Object obj)
670 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
673 for (i = 0; i < 256; i++)
675 mark_object (cte->property[i]);
681 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
683 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
685 struct gcpro gcpro1, gcpro2;
686 GCPRO2 (obj, printcharfun);
688 write_c_string ("\n#<byte-table", printcharfun);
689 for (i = 0; i < 256; i++)
691 Lisp_Object elt = bte->property[i];
693 write_c_string ("\n ", printcharfun);
694 write_c_string (" ", printcharfun);
695 if (EQ (elt, Qunbound))
696 write_c_string ("void", printcharfun);
698 print_internal (elt, printcharfun, escapeflag);
701 write_c_string (">", printcharfun);
705 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
707 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
708 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
711 for (i = 0; i < 256; i++)
712 if (BYTE_TABLE_P (cte1->property[i]))
714 if (BYTE_TABLE_P (cte2->property[i]))
716 if (!byte_table_equal (cte1->property[i],
717 cte2->property[i], depth + 1))
724 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
730 byte_table_hash (Lisp_Object obj, int depth)
732 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
734 return internal_array_hash (cte->property, 256, depth);
737 static const struct lrecord_description byte_table_description[] = {
738 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
742 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
747 byte_table_description,
751 make_byte_table (Lisp_Object initval)
755 Lisp_Byte_Table *cte;
757 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
759 for (i = 0; i < 256; i++)
760 cte->property[i] = initval;
762 XSETBYTE_TABLE (obj, cte);
767 copy_byte_table (Lisp_Object entry)
769 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
772 Lisp_Byte_Table *ctnew
773 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
775 for (i = 0; i < 256; i++)
777 if (UINT8_BYTE_TABLE_P (cte->property[i]))
779 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
781 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
783 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
785 else if (BYTE_TABLE_P (cte->property[i]))
787 ctnew->property[i] = copy_byte_table (cte->property[i]);
790 ctnew->property[i] = cte->property[i];
793 XSETBYTE_TABLE (obj, ctnew);
798 byte_table_same_value_p (Lisp_Object obj)
800 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
801 Lisp_Object v0 = bte->property[0];
804 for (i = 1; i < 256; i++)
806 if (!internal_equal (bte->property[i], v0, 0))
813 map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
814 Emchar ofs, int place,
815 int (*fn) (struct chartab_range *range,
816 Lisp_Object val, void *arg),
821 int unit = 1 << (8 * place);
824 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
827 if (UINT8_BYTE_TABLE_P (v))
830 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
831 c, place - 1, fn, arg);
834 else if (UINT16_BYTE_TABLE_P (v))
837 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
838 c, place - 1, fn, arg);
841 else if (BYTE_TABLE_P (v))
843 retval = map_over_byte_table (XBYTE_TABLE(v), root,
844 c, place - 1, fn, arg);
847 else if (EQ (v, Qunloaded))
850 struct chartab_range rainj;
851 Emchar c1 = c + unit;
853 rainj.type = CHARTAB_RANGE_CHAR;
855 for (; c < c1 && retval == 0; c++)
857 Lisp_Object ret = get_char_id_table (root, c);
862 retval = (fn) (&rainj, ret, arg);
866 ct->property[i] = Qunbound;
870 else if (!UNBOUNDP (v))
872 struct chartab_range rainj;
873 Emchar c1 = c + unit;
875 rainj.type = CHARTAB_RANGE_CHAR;
877 for (; c < c1 && retval == 0; c++)
880 retval = (fn) (&rainj, v, arg);
891 save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
893 Emchar ofs, int place)
897 int unit = 1 << (8 * place);
900 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
903 if (UINT8_BYTE_TABLE_P (v))
905 save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db,
909 else if (UINT16_BYTE_TABLE_P (v))
911 save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db,
915 else if (BYTE_TABLE_P (v))
917 save_byte_table (XBYTE_TABLE(v), root, db,
921 else if (EQ (v, Qunloaded))
925 else if (!UNBOUNDP (v))
927 struct chartab_range rainj;
928 Emchar c1 = c + unit;
930 rainj.type = CHARTAB_RANGE_CHAR;
932 for (; c < c1 && retval == 0; c++)
934 Fput_database (Fprin1_to_string (make_char (c), Qnil),
935 Fprin1_to_string (v, Qnil),
946 get_byte_table (Lisp_Object table, unsigned char idx)
948 if (UINT8_BYTE_TABLE_P (table))
949 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
950 else if (UINT16_BYTE_TABLE_P (table))
951 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
952 else if (BYTE_TABLE_P (table))
953 return XBYTE_TABLE(table)->property[idx];
959 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
961 if (UINT8_BYTE_TABLE_P (table))
963 if (UINT8_VALUE_P (value))
965 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
966 if (!UINT8_BYTE_TABLE_P (value) &&
967 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
968 && uint8_byte_table_same_value_p (table))
973 else if (UINT16_VALUE_P (value))
975 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
977 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
982 Lisp_Object new = make_byte_table (Qnil);
985 for (i = 0; i < 256; i++)
987 XBYTE_TABLE(new)->property[i]
988 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
990 XBYTE_TABLE(new)->property[idx] = value;
994 else if (UINT16_BYTE_TABLE_P (table))
996 if (UINT16_VALUE_P (value))
998 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
999 if (!UINT8_BYTE_TABLE_P (value) &&
1000 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1001 && uint16_byte_table_same_value_p (table))
1008 Lisp_Object new = make_byte_table (Qnil);
1011 for (i = 0; i < 256; i++)
1013 XBYTE_TABLE(new)->property[i]
1014 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
1016 XBYTE_TABLE(new)->property[idx] = value;
1020 else if (BYTE_TABLE_P (table))
1022 XBYTE_TABLE(table)->property[idx] = value;
1023 if (!UINT8_BYTE_TABLE_P (value) &&
1024 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1025 && byte_table_same_value_p (table))
1030 else if (!internal_equal (table, value, 0))
1032 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
1034 table = make_uint8_byte_table (UINT8_ENCODE (table));
1035 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
1037 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
1039 table = make_uint16_byte_table (UINT16_ENCODE (table));
1040 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1044 table = make_byte_table (table);
1045 XBYTE_TABLE(table)->property[idx] = value;
1053 make_char_id_table (Lisp_Object initval)
1056 obj = Fmake_char_table (Qgeneric);
1057 fill_char_table (XCHAR_TABLE (obj), initval);
1062 Lisp_Object Vcharacter_variant_table;
1064 Lisp_Object Qsystem_char_id;
1066 Lisp_Object Qcomposition;
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 base, modifier;
1142 signal_simple_error ("Invalid value for composition", list);
1145 while (!NILP (rest))
1150 signal_simple_error ("Invalid value for composition", list);
1151 modifier = Fcar (rest);
1153 base = Fcdr (Fassq (modifier,
1154 Fget_char_attribute (base, Qcomposition, Qnil)));
1159 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1160 Return variants of CHARACTER.
1166 CHECK_CHAR (character);
1167 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
1170 return Fcopy_list (ret);
1178 /* A char table maps from ranges of characters to values.
1180 Implementing a general data structure that maps from arbitrary
1181 ranges of numbers to values is tricky to do efficiently. As it
1182 happens, it should suffice (and is usually more convenient, anyway)
1183 when dealing with characters to restrict the sorts of ranges that
1184 can be assigned values, as follows:
1187 2) All characters in a charset.
1188 3) All characters in a particular row of a charset, where a "row"
1189 means all characters with the same first byte.
1190 4) A particular character in a charset.
1192 We use char tables to generalize the 256-element vectors now
1193 littering the Emacs code.
1195 Possible uses (all should be converted at some point):
1201 5) keyboard-translate-table?
1204 abstract type to generalize the Emacs vectors and Mule
1205 vectors-of-vectors goo.
1208 /************************************************************************/
1209 /* Char Table object */
1210 /************************************************************************/
1212 #if defined(MULE)&&!defined(UTF2000)
1215 mark_char_table_entry (Lisp_Object obj)
1217 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1220 for (i = 0; i < 96; i++)
1222 mark_object (cte->level2[i]);
1228 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1230 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1231 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1234 for (i = 0; i < 96; i++)
1235 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1241 static unsigned long
1242 char_table_entry_hash (Lisp_Object obj, int depth)
1244 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1246 return internal_array_hash (cte->level2, 96, depth);
1249 static const struct lrecord_description char_table_entry_description[] = {
1250 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1254 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1255 mark_char_table_entry, internal_object_printer,
1256 0, char_table_entry_equal,
1257 char_table_entry_hash,
1258 char_table_entry_description,
1259 Lisp_Char_Table_Entry);
1263 mark_char_table (Lisp_Object obj)
1265 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1268 mark_object (ct->table);
1269 mark_object (ct->name);
1270 mark_object (ct->db);
1274 for (i = 0; i < NUM_ASCII_CHARS; i++)
1275 mark_object (ct->ascii[i]);
1277 for (i = 0; i < NUM_LEADING_BYTES; i++)
1278 mark_object (ct->level1[i]);
1282 return ct->default_value;
1284 return ct->mirror_table;
1288 /* WARNING: All functions of this nature need to be written extremely
1289 carefully to avoid crashes during GC. Cf. prune_specifiers()
1290 and prune_weak_hash_tables(). */
1293 prune_syntax_tables (void)
1295 Lisp_Object rest, prev = Qnil;
1297 for (rest = Vall_syntax_tables;
1299 rest = XCHAR_TABLE (rest)->next_table)
1301 if (! marked_p (rest))
1303 /* This table is garbage. Remove it from the list. */
1305 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1307 XCHAR_TABLE (prev)->next_table =
1308 XCHAR_TABLE (rest)->next_table;
1314 char_table_type_to_symbol (enum char_table_type type)
1319 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1320 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1321 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1322 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1324 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1329 static enum char_table_type
1330 symbol_to_char_table_type (Lisp_Object symbol)
1332 CHECK_SYMBOL (symbol);
1334 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1335 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1336 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1337 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1339 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1342 signal_simple_error ("Unrecognized char table type", symbol);
1343 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1347 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1348 Lisp_Object printcharfun)
1352 write_c_string (" (", printcharfun);
1353 print_internal (make_char (first), printcharfun, 0);
1354 write_c_string (" ", printcharfun);
1355 print_internal (make_char (last), printcharfun, 0);
1356 write_c_string (") ", printcharfun);
1360 write_c_string (" ", printcharfun);
1361 print_internal (make_char (first), printcharfun, 0);
1362 write_c_string (" ", printcharfun);
1364 print_internal (val, printcharfun, 1);
1367 #if defined(MULE)&&!defined(UTF2000)
1370 print_chartab_charset_row (Lisp_Object charset,
1372 Lisp_Char_Table_Entry *cte,
1373 Lisp_Object printcharfun)
1376 Lisp_Object cat = Qunbound;
1379 for (i = 32; i < 128; i++)
1381 Lisp_Object pam = cte->level2[i - 32];
1393 print_chartab_range (MAKE_CHAR (charset, first, 0),
1394 MAKE_CHAR (charset, i - 1, 0),
1397 print_chartab_range (MAKE_CHAR (charset, row, first),
1398 MAKE_CHAR (charset, row, i - 1),
1408 print_chartab_range (MAKE_CHAR (charset, first, 0),
1409 MAKE_CHAR (charset, i - 1, 0),
1412 print_chartab_range (MAKE_CHAR (charset, row, first),
1413 MAKE_CHAR (charset, row, i - 1),
1419 print_chartab_two_byte_charset (Lisp_Object charset,
1420 Lisp_Char_Table_Entry *cte,
1421 Lisp_Object printcharfun)
1425 for (i = 32; i < 128; i++)
1427 Lisp_Object jen = cte->level2[i - 32];
1429 if (!CHAR_TABLE_ENTRYP (jen))
1433 write_c_string (" [", printcharfun);
1434 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1435 sprintf (buf, " %d] ", i);
1436 write_c_string (buf, printcharfun);
1437 print_internal (jen, printcharfun, 0);
1440 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1448 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1450 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1453 struct gcpro gcpro1, gcpro2;
1454 GCPRO2 (obj, printcharfun);
1456 write_c_string ("#s(char-table ", printcharfun);
1457 write_c_string (" ", printcharfun);
1458 write_c_string (string_data
1460 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1462 write_c_string ("\n ", printcharfun);
1463 print_internal (ct->default_value, printcharfun, escapeflag);
1464 for (i = 0; i < 256; i++)
1466 Lisp_Object elt = get_byte_table (ct->table, i);
1467 if (i != 0) write_c_string ("\n ", printcharfun);
1468 if (EQ (elt, Qunbound))
1469 write_c_string ("void", printcharfun);
1471 print_internal (elt, printcharfun, escapeflag);
1474 #else /* non UTF2000 */
1477 sprintf (buf, "#s(char-table type %s data (",
1478 string_data (symbol_name (XSYMBOL
1479 (char_table_type_to_symbol (ct->type)))));
1480 write_c_string (buf, printcharfun);
1482 /* Now write out the ASCII/Control-1 stuff. */
1486 Lisp_Object val = Qunbound;
1488 for (i = 0; i < NUM_ASCII_CHARS; i++)
1497 if (!EQ (ct->ascii[i], val))
1499 print_chartab_range (first, i - 1, val, printcharfun);
1506 print_chartab_range (first, i - 1, val, printcharfun);
1513 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1516 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1517 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1519 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1520 || i == LEADING_BYTE_CONTROL_1)
1522 if (!CHAR_TABLE_ENTRYP (ann))
1524 write_c_string (" ", printcharfun);
1525 print_internal (XCHARSET_NAME (charset),
1527 write_c_string (" ", printcharfun);
1528 print_internal (ann, printcharfun, 0);
1532 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1533 if (XCHARSET_DIMENSION (charset) == 1)
1534 print_chartab_charset_row (charset, -1, cte, printcharfun);
1536 print_chartab_two_byte_charset (charset, cte, printcharfun);
1541 #endif /* non UTF2000 */
1543 write_c_string ("))", printcharfun);
1547 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1549 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1550 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1553 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1557 for (i = 0; i < 256; i++)
1559 if (!internal_equal (get_byte_table (ct1->table, i),
1560 get_byte_table (ct2->table, i), 0))
1564 for (i = 0; i < NUM_ASCII_CHARS; i++)
1565 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1569 for (i = 0; i < NUM_LEADING_BYTES; i++)
1570 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1573 #endif /* non UTF2000 */
1578 static unsigned long
1579 char_table_hash (Lisp_Object obj, int depth)
1581 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1583 return byte_table_hash (ct->table, depth + 1);
1585 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1588 hashval = HASH2 (hashval,
1589 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1595 static const struct lrecord_description char_table_description[] = {
1597 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1598 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1599 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1600 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1602 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1604 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1608 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1610 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1614 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1615 mark_char_table, print_char_table, 0,
1616 char_table_equal, char_table_hash,
1617 char_table_description,
1620 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1621 Return non-nil if OBJECT is a char table.
1623 A char table is a table that maps characters (or ranges of characters)
1624 to values. Char tables are specialized for characters, only allowing
1625 particular sorts of ranges to be assigned values. Although this
1626 loses in generality, it makes for extremely fast (constant-time)
1627 lookups, and thus is feasible for applications that do an extremely
1628 large number of lookups (e.g. scanning a buffer for a character in
1629 a particular syntax, where a lookup in the syntax table must occur
1630 once per character).
1632 When Mule support exists, the types of ranges that can be assigned
1636 -- an entire charset
1637 -- a single row in a two-octet charset
1638 -- a single character
1640 When Mule support is not present, the types of ranges that can be
1644 -- a single character
1646 To create a char table, use `make-char-table'.
1647 To modify a char table, use `put-char-table' or `remove-char-table'.
1648 To retrieve the value for a particular character, use `get-char-table'.
1649 See also `map-char-table', `clear-char-table', `copy-char-table',
1650 `valid-char-table-type-p', `char-table-type-list',
1651 `valid-char-table-value-p', and `check-char-table-value'.
1655 return CHAR_TABLEP (object) ? Qt : Qnil;
1658 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1659 Return a list of the recognized char table types.
1660 See `valid-char-table-type-p'.
1665 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1667 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1671 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1672 Return t if TYPE if a recognized char table type.
1674 Each char table type is used for a different purpose and allows different
1675 sorts of values. The different char table types are
1678 Used for category tables, which specify the regexp categories
1679 that a character is in. The valid values are nil or a
1680 bit vector of 95 elements. Higher-level Lisp functions are
1681 provided for working with category tables. Currently categories
1682 and category tables only exist when Mule support is present.
1684 A generalized char table, for mapping from one character to
1685 another. Used for case tables, syntax matching tables,
1686 `keyboard-translate-table', etc. The valid values are characters.
1688 An even more generalized char table, for mapping from a
1689 character to anything.
1691 Used for display tables, which specify how a particular character
1692 is to appear when displayed. #### Not yet implemented.
1694 Used for syntax tables, which specify the syntax of a particular
1695 character. Higher-level Lisp functions are provided for
1696 working with syntax tables. The valid values are integers.
1701 return (EQ (type, Qchar) ||
1703 EQ (type, Qcategory) ||
1705 EQ (type, Qdisplay) ||
1706 EQ (type, Qgeneric) ||
1707 EQ (type, Qsyntax)) ? Qt : Qnil;
1710 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1711 Return the type of CHAR-TABLE.
1712 See `valid-char-table-type-p'.
1716 CHECK_CHAR_TABLE (char_table);
1717 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1721 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1724 ct->table = Qunbound;
1725 ct->default_value = value;
1730 for (i = 0; i < NUM_ASCII_CHARS; i++)
1731 ct->ascii[i] = value;
1733 for (i = 0; i < NUM_LEADING_BYTES; i++)
1734 ct->level1[i] = value;
1739 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1740 update_syntax_table (ct);
1744 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1745 Reset CHAR-TABLE to its default state.
1749 Lisp_Char_Table *ct;
1751 CHECK_CHAR_TABLE (char_table);
1752 ct = XCHAR_TABLE (char_table);
1756 case CHAR_TABLE_TYPE_CHAR:
1757 fill_char_table (ct, make_char (0));
1759 case CHAR_TABLE_TYPE_DISPLAY:
1760 case CHAR_TABLE_TYPE_GENERIC:
1762 case CHAR_TABLE_TYPE_CATEGORY:
1764 fill_char_table (ct, Qnil);
1767 case CHAR_TABLE_TYPE_SYNTAX:
1768 fill_char_table (ct, make_int (Sinherit));
1778 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1779 Return a new, empty char table of type TYPE.
1780 Currently recognized types are 'char, 'category, 'display, 'generic,
1781 and 'syntax. See `valid-char-table-type-p'.
1785 Lisp_Char_Table *ct;
1787 enum char_table_type ty = symbol_to_char_table_type (type);
1789 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1792 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1794 ct->mirror_table = Fmake_char_table (Qgeneric);
1795 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1799 ct->mirror_table = Qnil;
1804 ct->next_table = Qnil;
1805 XSETCHAR_TABLE (obj, ct);
1806 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1808 ct->next_table = Vall_syntax_tables;
1809 Vall_syntax_tables = obj;
1811 Freset_char_table (obj);
1815 #if defined(MULE)&&!defined(UTF2000)
1818 make_char_table_entry (Lisp_Object initval)
1822 Lisp_Char_Table_Entry *cte =
1823 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1825 for (i = 0; i < 96; i++)
1826 cte->level2[i] = initval;
1828 XSETCHAR_TABLE_ENTRY (obj, cte);
1833 copy_char_table_entry (Lisp_Object entry)
1835 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1838 Lisp_Char_Table_Entry *ctenew =
1839 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1841 for (i = 0; i < 96; i++)
1843 Lisp_Object new = cte->level2[i];
1844 if (CHAR_TABLE_ENTRYP (new))
1845 ctenew->level2[i] = copy_char_table_entry (new);
1847 ctenew->level2[i] = new;
1850 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1856 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1857 Return a new char table which is a copy of CHAR-TABLE.
1858 It will contain the same values for the same characters and ranges
1859 as CHAR-TABLE. The values will not themselves be copied.
1863 Lisp_Char_Table *ct, *ctnew;
1869 CHECK_CHAR_TABLE (char_table);
1870 ct = XCHAR_TABLE (char_table);
1871 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1872 ctnew->type = ct->type;
1874 ctnew->default_value = ct->default_value;
1875 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1876 ctnew->name = ct->name;
1879 if (UINT8_BYTE_TABLE_P (ct->table))
1881 ctnew->table = copy_uint8_byte_table (ct->table);
1883 else if (UINT16_BYTE_TABLE_P (ct->table))
1885 ctnew->table = copy_uint16_byte_table (ct->table);
1887 else if (BYTE_TABLE_P (ct->table))
1889 ctnew->table = copy_byte_table (ct->table);
1891 else if (!UNBOUNDP (ct->table))
1892 ctnew->table = ct->table;
1893 #else /* non UTF2000 */
1895 for (i = 0; i < NUM_ASCII_CHARS; i++)
1897 Lisp_Object new = ct->ascii[i];
1899 assert (! (CHAR_TABLE_ENTRYP (new)));
1901 ctnew->ascii[i] = new;
1906 for (i = 0; i < NUM_LEADING_BYTES; i++)
1908 Lisp_Object new = ct->level1[i];
1909 if (CHAR_TABLE_ENTRYP (new))
1910 ctnew->level1[i] = copy_char_table_entry (new);
1912 ctnew->level1[i] = new;
1916 #endif /* non UTF2000 */
1919 if (CHAR_TABLEP (ct->mirror_table))
1920 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1922 ctnew->mirror_table = ct->mirror_table;
1924 ctnew->next_table = Qnil;
1925 XSETCHAR_TABLE (obj, ctnew);
1926 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1928 ctnew->next_table = Vall_syntax_tables;
1929 Vall_syntax_tables = obj;
1934 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1936 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1938 switch (XCHARSET_CHARS (ccs))
1941 return (33 << 8) | 126;
1943 return (32 << 8) | 127;
1946 return (0 << 8) | 127;
1948 return (0 << 8) | 255;
1960 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1963 outrange->type = CHARTAB_RANGE_ALL;
1964 else if (EQ (range, Qnil))
1965 outrange->type = CHARTAB_RANGE_DEFAULT;
1966 else if (CHAR_OR_CHAR_INTP (range))
1968 outrange->type = CHARTAB_RANGE_CHAR;
1969 outrange->ch = XCHAR_OR_CHAR_INT (range);
1973 signal_simple_error ("Range must be t or a character", range);
1975 else if (VECTORP (range))
1977 Lisp_Vector *vec = XVECTOR (range);
1978 Lisp_Object *elts = vector_data (vec);
1979 int cell_min, cell_max;
1981 outrange->type = CHARTAB_RANGE_ROW;
1982 outrange->charset = Fget_charset (elts[0]);
1983 CHECK_INT (elts[1]);
1984 outrange->row = XINT (elts[1]);
1985 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1986 signal_simple_error ("Charset in row vector must be multi-byte",
1990 int ret = XCHARSET_CELL_RANGE (outrange->charset);
1992 cell_min = ret >> 8;
1993 cell_max = ret & 0xFF;
1995 if (XCHARSET_DIMENSION (outrange->charset) == 2)
1996 check_int_range (outrange->row, cell_min, cell_max);
1998 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2000 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2001 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2003 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2005 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2006 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2007 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2015 if (!CHARSETP (range) && !SYMBOLP (range))
2017 ("Char table range must be t, charset, char, or vector", range);
2018 outrange->type = CHARTAB_RANGE_CHARSET;
2019 outrange->charset = Fget_charset (range);
2024 #if defined(MULE)&&!defined(UTF2000)
2026 /* called from CHAR_TABLE_VALUE(). */
2028 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2033 Lisp_Object charset;
2035 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2040 BREAKUP_CHAR (c, charset, byte1, byte2);
2042 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2044 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2045 if (CHAR_TABLE_ENTRYP (val))
2047 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2048 val = cte->level2[byte1 - 32];
2049 if (CHAR_TABLE_ENTRYP (val))
2051 cte = XCHAR_TABLE_ENTRY (val);
2052 assert (byte2 >= 32);
2053 val = cte->level2[byte2 - 32];
2054 assert (!CHAR_TABLE_ENTRYP (val));
2064 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2067 return get_char_id_table (ct, ch);
2070 Lisp_Object charset;
2074 BREAKUP_CHAR (ch, charset, byte1, byte2);
2076 if (EQ (charset, Vcharset_ascii))
2077 val = ct->ascii[byte1];
2078 else if (EQ (charset, Vcharset_control_1))
2079 val = ct->ascii[byte1 + 128];
2082 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2083 val = ct->level1[lb];
2084 if (CHAR_TABLE_ENTRYP (val))
2086 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2087 val = cte->level2[byte1 - 32];
2088 if (CHAR_TABLE_ENTRYP (val))
2090 cte = XCHAR_TABLE_ENTRY (val);
2091 assert (byte2 >= 32);
2092 val = cte->level2[byte2 - 32];
2093 assert (!CHAR_TABLE_ENTRYP (val));
2100 #else /* not MULE */
2101 return ct->ascii[(unsigned char)ch];
2102 #endif /* not MULE */
2106 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2107 Find value for CHARACTER in CHAR-TABLE.
2109 (character, char_table))
2111 CHECK_CHAR_TABLE (char_table);
2112 CHECK_CHAR_COERCE_INT (character);
2114 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2117 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2118 Find value for a range in CHAR-TABLE.
2119 If there is more than one value, return MULTI (defaults to nil).
2121 (range, char_table, multi))
2123 Lisp_Char_Table *ct;
2124 struct chartab_range rainj;
2126 if (CHAR_OR_CHAR_INTP (range))
2127 return Fget_char_table (range, char_table);
2128 CHECK_CHAR_TABLE (char_table);
2129 ct = XCHAR_TABLE (char_table);
2131 decode_char_table_range (range, &rainj);
2134 case CHARTAB_RANGE_ALL:
2137 if (UINT8_BYTE_TABLE_P (ct->table))
2139 else if (UINT16_BYTE_TABLE_P (ct->table))
2141 else if (BYTE_TABLE_P (ct->table))
2145 #else /* non UTF2000 */
2147 Lisp_Object first = ct->ascii[0];
2149 for (i = 1; i < NUM_ASCII_CHARS; i++)
2150 if (!EQ (first, ct->ascii[i]))
2154 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2157 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2158 || i == LEADING_BYTE_ASCII
2159 || i == LEADING_BYTE_CONTROL_1)
2161 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2167 #endif /* non UTF2000 */
2171 case CHARTAB_RANGE_CHARSET:
2175 if (EQ (rainj.charset, Vcharset_ascii))
2178 Lisp_Object first = ct->ascii[0];
2180 for (i = 1; i < 128; i++)
2181 if (!EQ (first, ct->ascii[i]))
2186 if (EQ (rainj.charset, Vcharset_control_1))
2189 Lisp_Object first = ct->ascii[128];
2191 for (i = 129; i < 160; i++)
2192 if (!EQ (first, ct->ascii[i]))
2198 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2200 if (CHAR_TABLE_ENTRYP (val))
2206 case CHARTAB_RANGE_ROW:
2211 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2213 if (!CHAR_TABLE_ENTRYP (val))
2215 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2216 if (CHAR_TABLE_ENTRYP (val))
2220 #endif /* not UTF2000 */
2221 #endif /* not MULE */
2227 return Qnil; /* not reached */
2231 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2232 Error_behavior errb)
2236 case CHAR_TABLE_TYPE_SYNTAX:
2237 if (!ERRB_EQ (errb, ERROR_ME))
2238 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2239 && CHAR_OR_CHAR_INTP (XCDR (value)));
2242 Lisp_Object cdr = XCDR (value);
2243 CHECK_INT (XCAR (value));
2244 CHECK_CHAR_COERCE_INT (cdr);
2251 case CHAR_TABLE_TYPE_CATEGORY:
2252 if (!ERRB_EQ (errb, ERROR_ME))
2253 return CATEGORY_TABLE_VALUEP (value);
2254 CHECK_CATEGORY_TABLE_VALUE (value);
2258 case CHAR_TABLE_TYPE_GENERIC:
2261 case CHAR_TABLE_TYPE_DISPLAY:
2263 maybe_signal_simple_error ("Display char tables not yet implemented",
2264 value, Qchar_table, errb);
2267 case CHAR_TABLE_TYPE_CHAR:
2268 if (!ERRB_EQ (errb, ERROR_ME))
2269 return CHAR_OR_CHAR_INTP (value);
2270 CHECK_CHAR_COERCE_INT (value);
2277 return 0; /* not reached */
2281 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2285 case CHAR_TABLE_TYPE_SYNTAX:
2288 Lisp_Object car = XCAR (value);
2289 Lisp_Object cdr = XCDR (value);
2290 CHECK_CHAR_COERCE_INT (cdr);
2291 return Fcons (car, cdr);
2294 case CHAR_TABLE_TYPE_CHAR:
2295 CHECK_CHAR_COERCE_INT (value);
2303 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2304 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2306 (value, char_table_type))
2308 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2310 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2313 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2314 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2316 (value, char_table_type))
2318 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2320 check_valid_char_table_value (value, type, ERROR_ME);
2325 Lisp_Char_Table* char_attribute_table_to_put;
2326 Lisp_Object Qput_char_table_map_function;
2327 Lisp_Object value_to_put;
2329 DEFUN ("put-char-table-map-function",
2330 Fput_char_table_map_function, 2, 2, 0, /*
2331 For internal use. Don't use it.
2335 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2340 /* Assign VAL to all characters in RANGE in char table CT. */
2343 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2346 switch (range->type)
2348 case CHARTAB_RANGE_ALL:
2349 /* printf ("put-char-table: range = all\n"); */
2350 fill_char_table (ct, val);
2351 return; /* avoid the duplicate call to update_syntax_table() below,
2352 since fill_char_table() also did that. */
2355 case CHARTAB_RANGE_DEFAULT:
2356 ct->default_value = val;
2361 case CHARTAB_RANGE_CHARSET:
2365 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2367 /* printf ("put-char-table: range = charset: %d\n",
2368 XCHARSET_LEADING_BYTE (range->charset));
2370 if ( CHAR_TABLEP (encoding_table) )
2373 char_attribute_table_to_put = ct;
2375 Fmap_char_attribute (Qput_char_table_map_function,
2376 XCHAR_TABLE_NAME (encoding_table),
2379 for (c = 0; c < 1 << 24; c++)
2381 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2383 put_char_id_table_0 (ct, c, val);
2389 for (c = 0; c < 1 << 24; c++)
2391 if ( charset_code_point (range->charset, c) >= 0 )
2392 put_char_id_table_0 (ct, c, val);
2397 if (EQ (range->charset, Vcharset_ascii))
2400 for (i = 0; i < 128; i++)
2403 else if (EQ (range->charset, Vcharset_control_1))
2406 for (i = 128; i < 160; i++)
2411 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2412 ct->level1[lb] = val;
2417 case CHARTAB_RANGE_ROW:
2420 int cell_min, cell_max, i;
2422 i = XCHARSET_CELL_RANGE (range->charset);
2424 cell_max = i & 0xFF;
2425 for (i = cell_min; i <= cell_max; i++)
2427 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2429 if ( charset_code_point (range->charset, ch) >= 0 )
2430 put_char_id_table_0 (ct, ch, val);
2435 Lisp_Char_Table_Entry *cte;
2436 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2437 /* make sure that there is a separate entry for the row. */
2438 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2439 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2440 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2441 cte->level2[range->row - 32] = val;
2443 #endif /* not UTF2000 */
2447 case CHARTAB_RANGE_CHAR:
2449 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2450 put_char_id_table_0 (ct, range->ch, val);
2454 Lisp_Object charset;
2457 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2458 if (EQ (charset, Vcharset_ascii))
2459 ct->ascii[byte1] = val;
2460 else if (EQ (charset, Vcharset_control_1))
2461 ct->ascii[byte1 + 128] = val;
2464 Lisp_Char_Table_Entry *cte;
2465 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2466 /* make sure that there is a separate entry for the row. */
2467 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2468 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2469 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2470 /* now CTE is a char table entry for the charset;
2471 each entry is for a single row (or character of
2472 a one-octet charset). */
2473 if (XCHARSET_DIMENSION (charset) == 1)
2474 cte->level2[byte1 - 32] = val;
2477 /* assigning to one character in a two-octet charset. */
2478 /* make sure that the charset row contains a separate
2479 entry for each character. */
2480 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2481 cte->level2[byte1 - 32] =
2482 make_char_table_entry (cte->level2[byte1 - 32]);
2483 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2484 cte->level2[byte2 - 32] = val;
2488 #else /* not MULE */
2489 ct->ascii[(unsigned char) (range->ch)] = val;
2491 #endif /* not MULE */
2495 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2496 update_syntax_table (ct);
2500 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2501 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2503 RANGE specifies one or more characters to be affected and should be
2504 one of the following:
2506 -- t (all characters are affected)
2507 -- A charset (only allowed when Mule support is present)
2508 -- A vector of two elements: a two-octet charset and a row number
2509 (only allowed when Mule support is present)
2510 -- A single character
2512 VALUE must be a value appropriate for the type of CHAR-TABLE.
2513 See `valid-char-table-type-p'.
2515 (range, value, char_table))
2517 Lisp_Char_Table *ct;
2518 struct chartab_range rainj;
2520 CHECK_CHAR_TABLE (char_table);
2521 ct = XCHAR_TABLE (char_table);
2522 check_valid_char_table_value (value, ct->type, ERROR_ME);
2523 decode_char_table_range (range, &rainj);
2524 value = canonicalize_char_table_value (value, ct->type);
2525 put_char_table (ct, &rainj, value);
2530 /* Map FN over the ASCII chars in CT. */
2533 map_over_charset_ascii (Lisp_Char_Table *ct,
2534 int (*fn) (struct chartab_range *range,
2535 Lisp_Object val, void *arg),
2538 struct chartab_range rainj;
2547 rainj.type = CHARTAB_RANGE_CHAR;
2549 for (i = start, retval = 0; i < stop && retval == 0; i++)
2551 rainj.ch = (Emchar) i;
2552 retval = (fn) (&rainj, ct->ascii[i], arg);
2560 /* Map FN over the Control-1 chars in CT. */
2563 map_over_charset_control_1 (Lisp_Char_Table *ct,
2564 int (*fn) (struct chartab_range *range,
2565 Lisp_Object val, void *arg),
2568 struct chartab_range rainj;
2571 int stop = start + 32;
2573 rainj.type = CHARTAB_RANGE_CHAR;
2575 for (i = start, retval = 0; i < stop && retval == 0; i++)
2577 rainj.ch = (Emchar) (i);
2578 retval = (fn) (&rainj, ct->ascii[i], arg);
2584 /* Map FN over the row ROW of two-byte charset CHARSET.
2585 There must be a separate value for that row in the char table.
2586 CTE specifies the char table entry for CHARSET. */
2589 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2590 Lisp_Object charset, int row,
2591 int (*fn) (struct chartab_range *range,
2592 Lisp_Object val, void *arg),
2595 Lisp_Object val = cte->level2[row - 32];
2597 if (!CHAR_TABLE_ENTRYP (val))
2599 struct chartab_range rainj;
2601 rainj.type = CHARTAB_RANGE_ROW;
2602 rainj.charset = charset;
2604 return (fn) (&rainj, val, arg);
2608 struct chartab_range rainj;
2610 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2611 int start = charset94_p ? 33 : 32;
2612 int stop = charset94_p ? 127 : 128;
2614 cte = XCHAR_TABLE_ENTRY (val);
2616 rainj.type = CHARTAB_RANGE_CHAR;
2618 for (i = start, retval = 0; i < stop && retval == 0; i++)
2620 rainj.ch = MAKE_CHAR (charset, row, i);
2621 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2629 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2630 int (*fn) (struct chartab_range *range,
2631 Lisp_Object val, void *arg),
2634 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2635 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2637 if (!CHARSETP (charset)
2638 || lb == LEADING_BYTE_ASCII
2639 || lb == LEADING_BYTE_CONTROL_1)
2642 if (!CHAR_TABLE_ENTRYP (val))
2644 struct chartab_range rainj;
2646 rainj.type = CHARTAB_RANGE_CHARSET;
2647 rainj.charset = charset;
2648 return (fn) (&rainj, val, arg);
2652 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2653 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2654 int start = charset94_p ? 33 : 32;
2655 int stop = charset94_p ? 127 : 128;
2658 if (XCHARSET_DIMENSION (charset) == 1)
2660 struct chartab_range rainj;
2661 rainj.type = CHARTAB_RANGE_CHAR;
2663 for (i = start, retval = 0; i < stop && retval == 0; i++)
2665 rainj.ch = MAKE_CHAR (charset, i, 0);
2666 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2671 for (i = start, retval = 0; i < stop && retval == 0; i++)
2672 retval = map_over_charset_row (cte, charset, i, fn, arg);
2680 #endif /* not UTF2000 */
2683 struct map_char_table_for_charset_arg
2685 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2686 Lisp_Char_Table *ct;
2691 map_char_table_for_charset_fun (struct chartab_range *range,
2692 Lisp_Object val, void *arg)
2694 struct map_char_table_for_charset_arg *closure =
2695 (struct map_char_table_for_charset_arg *) arg;
2698 switch (range->type)
2700 case CHARTAB_RANGE_ALL:
2703 case CHARTAB_RANGE_DEFAULT:
2706 case CHARTAB_RANGE_CHARSET:
2709 case CHARTAB_RANGE_ROW:
2712 case CHARTAB_RANGE_CHAR:
2713 ret = get_char_table (range->ch, closure->ct);
2714 if (!UNBOUNDP (ret))
2715 return (closure->fn) (range, ret, closure->arg);
2727 /* Map FN (with client data ARG) over range RANGE in char table CT.
2728 Mapping stops the first time FN returns non-zero, and that value
2729 becomes the return value of map_char_table(). */
2732 map_char_table (Lisp_Char_Table *ct,
2733 struct chartab_range *range,
2734 int (*fn) (struct chartab_range *range,
2735 Lisp_Object val, void *arg),
2738 switch (range->type)
2740 case CHARTAB_RANGE_ALL:
2742 if (!UNBOUNDP (ct->default_value))
2744 struct chartab_range rainj;
2747 rainj.type = CHARTAB_RANGE_DEFAULT;
2748 retval = (fn) (&rainj, ct->default_value, arg);
2752 if (UINT8_BYTE_TABLE_P (ct->table))
2753 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2755 else if (UINT16_BYTE_TABLE_P (ct->table))
2756 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2758 else if (BYTE_TABLE_P (ct->table))
2759 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2761 else if (EQ (ct->table, Qunloaded))
2764 struct chartab_range rainj;
2767 Emchar c1 = c + unit;
2770 rainj.type = CHARTAB_RANGE_CHAR;
2772 for (retval = 0; c < c1 && retval == 0; c++)
2774 Lisp_Object ret = get_char_id_table (ct, c);
2776 if (!UNBOUNDP (ret))
2779 retval = (fn) (&rainj, ct->table, arg);
2784 ct->table = Qunbound;
2787 else if (!UNBOUNDP (ct->table))
2788 return (fn) (range, ct->table, arg);
2794 retval = map_over_charset_ascii (ct, fn, arg);
2798 retval = map_over_charset_control_1 (ct, fn, arg);
2803 Charset_ID start = MIN_LEADING_BYTE;
2804 Charset_ID stop = start + NUM_LEADING_BYTES;
2806 for (i = start, retval = 0; i < stop && retval == 0; i++)
2808 retval = map_over_other_charset (ct, i, fn, arg);
2817 case CHARTAB_RANGE_DEFAULT:
2818 if (!UNBOUNDP (ct->default_value))
2819 return (fn) (range, ct->default_value, arg);
2824 case CHARTAB_RANGE_CHARSET:
2827 Lisp_Object encoding_table
2828 = XCHARSET_ENCODING_TABLE (range->charset);
2830 if (!NILP (encoding_table))
2832 struct chartab_range rainj;
2833 struct map_char_table_for_charset_arg mcarg;
2835 #ifdef HAVE_DATABASE
2836 if (XCHAR_TABLE_UNLOADED(encoding_table))
2837 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2842 rainj.type = CHARTAB_RANGE_ALL;
2843 return map_char_table (XCHAR_TABLE(encoding_table),
2845 &map_char_table_for_charset_fun,
2851 return map_over_other_charset (ct,
2852 XCHARSET_LEADING_BYTE (range->charset),
2856 case CHARTAB_RANGE_ROW:
2859 int cell_min, cell_max, i;
2861 struct chartab_range rainj;
2863 i = XCHARSET_CELL_RANGE (range->charset);
2865 cell_max = i & 0xFF;
2866 rainj.type = CHARTAB_RANGE_CHAR;
2867 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2869 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2871 if ( charset_code_point (range->charset, ch) >= 0 )
2874 = get_byte_table (get_byte_table
2878 (unsigned char)(ch >> 24)),
2879 (unsigned char) (ch >> 16)),
2880 (unsigned char) (ch >> 8)),
2881 (unsigned char) ch);
2884 val = ct->default_value;
2886 retval = (fn) (&rainj, val, arg);
2893 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2894 - MIN_LEADING_BYTE];
2895 if (!CHAR_TABLE_ENTRYP (val))
2897 struct chartab_range rainj;
2899 rainj.type = CHARTAB_RANGE_ROW;
2900 rainj.charset = range->charset;
2901 rainj.row = range->row;
2902 return (fn) (&rainj, val, arg);
2905 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2906 range->charset, range->row,
2909 #endif /* not UTF2000 */
2912 case CHARTAB_RANGE_CHAR:
2914 Emchar ch = range->ch;
2915 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2917 if (!UNBOUNDP (val))
2919 struct chartab_range rainj;
2921 rainj.type = CHARTAB_RANGE_CHAR;
2923 return (fn) (&rainj, val, arg);
2935 struct slow_map_char_table_arg
2937 Lisp_Object function;
2942 slow_map_char_table_fun (struct chartab_range *range,
2943 Lisp_Object val, void *arg)
2945 Lisp_Object ranjarg = Qnil;
2946 struct slow_map_char_table_arg *closure =
2947 (struct slow_map_char_table_arg *) arg;
2949 switch (range->type)
2951 case CHARTAB_RANGE_ALL:
2956 case CHARTAB_RANGE_DEFAULT:
2962 case CHARTAB_RANGE_CHARSET:
2963 ranjarg = XCHARSET_NAME (range->charset);
2966 case CHARTAB_RANGE_ROW:
2967 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2968 make_int (range->row));
2971 case CHARTAB_RANGE_CHAR:
2972 ranjarg = make_char (range->ch);
2978 closure->retval = call2 (closure->function, ranjarg, val);
2979 return !NILP (closure->retval);
2982 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2983 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2984 each key and value in the table.
2986 RANGE specifies a subrange to map over and is in the same format as
2987 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2990 (function, char_table, range))
2992 Lisp_Char_Table *ct;
2993 struct slow_map_char_table_arg slarg;
2994 struct gcpro gcpro1, gcpro2;
2995 struct chartab_range rainj;
2997 CHECK_CHAR_TABLE (char_table);
2998 ct = XCHAR_TABLE (char_table);
3001 decode_char_table_range (range, &rainj);
3002 slarg.function = function;
3003 slarg.retval = Qnil;
3004 GCPRO2 (slarg.function, slarg.retval);
3005 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3008 return slarg.retval;
3012 /************************************************************************/
3013 /* Character Attributes */
3014 /************************************************************************/
3018 Lisp_Object Vchar_attribute_hash_table;
3020 /* We store the char-attributes in hash tables with the names as the
3021 key and the actual char-id-table object as the value. Occasionally
3022 we need to use them in a list format. These routines provide us
3024 struct char_attribute_list_closure
3026 Lisp_Object *char_attribute_list;
3030 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3031 void *char_attribute_list_closure)
3033 /* This function can GC */
3034 struct char_attribute_list_closure *calcl
3035 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3036 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3038 *char_attribute_list = Fcons (key, *char_attribute_list);
3042 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3043 Return the list of all existing character attributes except coded-charsets.
3047 Lisp_Object char_attribute_list = Qnil;
3048 struct gcpro gcpro1;
3049 struct char_attribute_list_closure char_attribute_list_closure;
3051 GCPRO1 (char_attribute_list);
3052 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3053 elisp_maphash (add_char_attribute_to_list_mapper,
3054 Vchar_attribute_hash_table,
3055 &char_attribute_list_closure);
3057 return char_attribute_list;
3060 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3061 Return char-id-table corresponding to ATTRIBUTE.
3065 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3069 /* We store the char-id-tables in hash tables with the attributes as
3070 the key and the actual char-id-table object as the value. Each
3071 char-id-table stores values of an attribute corresponding with
3072 characters. Occasionally we need to get attributes of a character
3073 in a association-list format. These routines provide us with
3075 struct char_attribute_alist_closure
3078 Lisp_Object *char_attribute_alist;
3082 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3083 void *char_attribute_alist_closure)
3085 /* This function can GC */
3086 struct char_attribute_alist_closure *caacl =
3087 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3089 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3090 if (!UNBOUNDP (ret))
3092 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3093 *char_attribute_alist
3094 = Fcons (Fcons (key, ret), *char_attribute_alist);
3099 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3100 Return the alist of attributes of CHARACTER.
3104 struct gcpro gcpro1;
3105 struct char_attribute_alist_closure char_attribute_alist_closure;
3106 Lisp_Object alist = Qnil;
3108 CHECK_CHAR (character);
3111 char_attribute_alist_closure.char_id = XCHAR (character);
3112 char_attribute_alist_closure.char_attribute_alist = &alist;
3113 elisp_maphash (add_char_attribute_alist_mapper,
3114 Vchar_attribute_hash_table,
3115 &char_attribute_alist_closure);
3121 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3122 Return the value of CHARACTER's ATTRIBUTE.
3123 Return DEFAULT-VALUE if the value is not exist.
3125 (character, attribute, default_value))
3129 CHECK_CHAR (character);
3131 if (CHARSETP (attribute))
3132 attribute = XCHARSET_NAME (attribute);
3134 table = Fgethash (attribute, Vchar_attribute_hash_table,
3136 if (!UNBOUNDP (table))
3138 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3140 if (!UNBOUNDP (ret))
3143 return default_value;
3146 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3147 Store CHARACTER's ATTRIBUTE with VALUE.
3149 (character, attribute, value))
3151 Lisp_Object ccs = Ffind_charset (attribute);
3155 CHECK_CHAR (character);
3156 value = put_char_ccs_code_point (character, ccs, value);
3158 else if (EQ (attribute, Q_decomposition))
3160 CHECK_CHAR (character);
3162 signal_simple_error ("Invalid value for ->decomposition",
3165 if (CONSP (Fcdr (value)))
3167 if (NILP (Fcdr (Fcdr (value))))
3169 Lisp_Object base = Fcar (value);
3170 Lisp_Object modifier = Fcar (Fcdr (value));
3174 base = make_char (XINT (base));
3175 Fsetcar (value, base);
3177 if (INTP (modifier))
3179 modifier = make_char (XINT (modifier));
3180 Fsetcar (Fcdr (value), modifier);
3184 Lisp_Object alist = Fget_char_attribute (base, Qcomposition, Qnil);
3185 Lisp_Object ret = Fassq (modifier, alist);
3188 Fput_char_attribute (base, Qcomposition,
3189 Fcons (Fcons (modifier, character), alist));
3191 Fsetcdr (ret, character);
3197 Lisp_Object v = Fcar (value);
3201 Emchar c = XINT (v);
3203 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3208 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3209 make_char (c), Fcons (character, Qnil));
3211 else if (NILP (Fmemq (v, ret)))
3213 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3214 make_char (c), Fcons (character, ret));
3219 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3224 CHECK_CHAR (character);
3226 signal_simple_error ("Invalid value for ->ucs", value);
3230 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
3233 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3234 make_char (c), Fcons (character, Qnil));
3236 else if (NILP (Fmemq (character, ret)))
3238 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3239 make_char (c), Fcons (character, ret));
3242 if (EQ (attribute, Q_ucs))
3243 attribute = Qto_ucs;
3247 Lisp_Object table = Fgethash (attribute,
3248 Vchar_attribute_hash_table,
3253 table = make_char_id_table (Qunbound);
3254 Fputhash (attribute, table, Vchar_attribute_hash_table);
3255 #ifdef HAVE_DATABASE
3256 XCHAR_TABLE_NAME (table) = attribute;
3259 put_char_id_table (XCHAR_TABLE(table), character, value);
3264 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3265 Remove CHARACTER's ATTRIBUTE.
3267 (character, attribute))
3271 CHECK_CHAR (character);
3272 ccs = Ffind_charset (attribute);
3275 return remove_char_ccs (character, ccs);
3279 Lisp_Object table = Fgethash (attribute,
3280 Vchar_attribute_hash_table,
3282 if (!UNBOUNDP (table))
3284 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3291 #ifdef HAVE_DATABASE
3293 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3296 Lisp_Object db_dir = Vexec_directory;
3299 db_dir = build_string ("../lib-src");
3301 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3302 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3303 Fmake_directory_internal (db_dir);
3305 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3306 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3307 Fmake_directory_internal (db_dir);
3310 Lisp_Object attribute_name = Fsymbol_name (attribute);
3311 Lisp_Object dest = Qnil, ret;
3313 struct gcpro gcpro1, gcpro2;
3314 int len = XSTRING_CHAR_LENGTH (attribute_name);
3318 for (i = 0; i < len; i++)
3320 Emchar c = string_char (XSTRING (attribute_name), i);
3322 if ( (c == '/') || (c == '%') )
3326 sprintf (str, "%%%02X", c);
3327 dest = concat3 (dest,
3328 Fsubstring (attribute_name,
3329 make_int (base), make_int (i)),
3330 build_string (str));
3334 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3335 dest = concat2 (dest, ret);
3337 return Fexpand_file_name (dest, db_dir);
3340 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3344 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3345 Save values of ATTRIBUTE into database file.
3349 #ifdef HAVE_DATABASE
3350 Lisp_Object table = Fgethash (attribute,
3351 Vchar_attribute_hash_table, Qunbound);
3352 Lisp_Char_Table *ct;
3353 Lisp_Object db_file;
3356 if (CHAR_TABLEP (table))
3357 ct = XCHAR_TABLE (table);
3361 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3362 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3365 if (UINT8_BYTE_TABLE_P (ct->table))
3366 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db, 0, 3);
3367 else if (UINT16_BYTE_TABLE_P (ct->table))
3368 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db, 0, 3);
3369 else if (BYTE_TABLE_P (ct->table))
3370 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3);
3371 Fclose_database (db);
3381 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3382 Mount database file on char-attribute-table ATTRIBUTE.
3386 #ifdef HAVE_DATABASE
3387 Lisp_Object table = Fgethash (attribute,
3388 Vchar_attribute_hash_table, Qunbound);
3390 if (UNBOUNDP (table))
3392 Lisp_Char_Table *ct;
3394 table = make_char_id_table (Qunbound);
3395 Fputhash (attribute, table, Vchar_attribute_hash_table);
3396 XCHAR_TABLE_NAME(table) = attribute;
3397 ct = XCHAR_TABLE (table);
3398 ct->table = Qunloaded;
3399 XCHAR_TABLE_UNLOADED(table) = 1;
3407 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3408 Close database of ATTRIBUTE.
3412 #ifdef HAVE_DATABASE
3413 Lisp_Object table = Fgethash (attribute,
3414 Vchar_attribute_hash_table, Qunbound);
3415 Lisp_Char_Table *ct;
3417 if (CHAR_TABLEP (table))
3418 ct = XCHAR_TABLE (table);
3424 if (!NILP (Fdatabase_live_p (ct->db)))
3425 Fclose_database (ct->db);
3432 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3433 Reset values of ATTRIBUTE with database file.
3437 #ifdef HAVE_DATABASE
3438 Lisp_Object table = Fgethash (attribute,
3439 Vchar_attribute_hash_table, Qunbound);
3440 Lisp_Char_Table *ct;
3442 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3444 if (!NILP (Ffile_exists_p (db_file)))
3446 if (UNBOUNDP (table))
3448 table = make_char_id_table (Qunbound);
3449 Fputhash (attribute, table, Vchar_attribute_hash_table);
3450 XCHAR_TABLE_NAME(table) = attribute;
3452 ct = XCHAR_TABLE (table);
3453 ct->table = Qunloaded;
3454 if (!NILP (Fdatabase_live_p (ct->db)))
3455 Fclose_database (ct->db);
3457 XCHAR_TABLE_UNLOADED(table) = 1;
3465 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3467 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3469 if (!NILP (attribute))
3471 if (NILP (Fdatabase_live_p (cit->db)))
3474 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3476 cit->db = Fopen_database (db_file, Qnil, Qnil,
3477 build_string ("r"), Qnil);
3479 if (!NILP (cit->db))
3482 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3484 if (!UNBOUNDP (val))
3488 if (!NILP (Vchar_db_stingy_mode))
3490 Fclose_database (cit->db);
3499 Lisp_Char_Table* char_attribute_table_to_load;
3501 Lisp_Object Qload_char_attribute_table_map_function;
3503 DEFUN ("load-char-attribute-table-map-function",
3504 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3505 For internal use. Don't use it.
3509 Lisp_Object c = Fread (key);
3510 Emchar code = XCHAR (c);
3511 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3513 if (EQ (ret, Qunloaded))
3514 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3518 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3519 Load values of ATTRIBUTE into database file.
3523 Lisp_Object table = Fgethash (attribute,
3524 Vchar_attribute_hash_table,
3526 if (CHAR_TABLEP (table))
3528 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3530 if (NILP (Fdatabase_live_p (ct->db)))
3533 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3535 ct->db = Fopen_database (db_file, Qnil, Qnil,
3536 build_string ("r"), Qnil);
3540 struct gcpro gcpro1;
3542 char_attribute_table_to_load = XCHAR_TABLE (table);
3544 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3546 Fclose_database (ct->db);
3548 XCHAR_TABLE_UNLOADED(table) = 0;
3556 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3557 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3558 each key and value in the table.
3560 RANGE specifies a subrange to map over and is in the same format as
3561 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3564 (function, attribute, range))
3567 Lisp_Char_Table *ct;
3568 struct slow_map_char_table_arg slarg;
3569 struct gcpro gcpro1, gcpro2;
3570 struct chartab_range rainj;
3572 if (!NILP (ccs = Ffind_charset (attribute)))
3574 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3576 if (CHAR_TABLEP (encoding_table))
3577 ct = XCHAR_TABLE (encoding_table);
3583 Lisp_Object table = Fgethash (attribute,
3584 Vchar_attribute_hash_table,
3586 if (CHAR_TABLEP (table))
3587 ct = XCHAR_TABLE (table);
3593 decode_char_table_range (range, &rainj);
3594 #ifdef HAVE_DATABASE
3595 if (CHAR_TABLE_UNLOADED(ct))
3596 Fload_char_attribute_table (attribute);
3598 slarg.function = function;
3599 slarg.retval = Qnil;
3600 GCPRO2 (slarg.function, slarg.retval);
3601 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3604 return slarg.retval;
3607 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3608 Store character's ATTRIBUTES.
3612 Lisp_Object rest = attributes;
3613 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3614 Lisp_Object character;
3618 while (CONSP (rest))
3620 Lisp_Object cell = Fcar (rest);
3624 signal_simple_error ("Invalid argument", attributes);
3625 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3626 && ((XCHARSET_FINAL (ccs) != 0) ||
3627 (XCHARSET_MAX_CODE (ccs) > 0) ||
3628 (EQ (ccs, Vcharset_chinese_big5))) )
3632 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3634 character = Fdecode_char (ccs, cell, Qnil);
3635 if (!NILP (character))
3636 goto setup_attributes;
3640 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3641 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3645 signal_simple_error ("Invalid argument", attributes);
3647 character = make_char (XINT (code) + 0x100000);
3648 goto setup_attributes;
3652 else if (!INTP (code))
3653 signal_simple_error ("Invalid argument", attributes);
3655 character = make_char (XINT (code));
3659 while (CONSP (rest))
3661 Lisp_Object cell = Fcar (rest);
3664 signal_simple_error ("Invalid argument", attributes);
3666 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3672 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3673 Retrieve the character of the given ATTRIBUTES.
3677 Lisp_Object rest = attributes;
3680 while (CONSP (rest))
3682 Lisp_Object cell = Fcar (rest);
3686 signal_simple_error ("Invalid argument", attributes);
3687 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3691 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3693 return Fdecode_char (ccs, cell, Qnil);
3697 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3698 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3701 signal_simple_error ("Invalid argument", attributes);
3703 return make_char (XINT (code) + 0x100000);
3711 /************************************************************************/
3712 /* Char table read syntax */
3713 /************************************************************************/
3716 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3717 Error_behavior errb)
3719 /* #### should deal with ERRB */
3720 symbol_to_char_table_type (value);
3725 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3726 Error_behavior errb)
3730 /* #### should deal with ERRB */
3731 EXTERNAL_LIST_LOOP (rest, value)
3733 Lisp_Object range = XCAR (rest);
3734 struct chartab_range dummy;
3738 signal_simple_error ("Invalid list format", value);
3741 if (!CONSP (XCDR (range))
3742 || !NILP (XCDR (XCDR (range))))
3743 signal_simple_error ("Invalid range format", range);
3744 decode_char_table_range (XCAR (range), &dummy);
3745 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3748 decode_char_table_range (range, &dummy);
3755 chartab_instantiate (Lisp_Object data)
3757 Lisp_Object chartab;
3758 Lisp_Object type = Qgeneric;
3759 Lisp_Object dataval = Qnil;
3761 while (!NILP (data))
3763 Lisp_Object keyw = Fcar (data);
3769 if (EQ (keyw, Qtype))
3771 else if (EQ (keyw, Qdata))
3775 chartab = Fmake_char_table (type);
3778 while (!NILP (data))
3780 Lisp_Object range = Fcar (data);
3781 Lisp_Object val = Fcar (Fcdr (data));
3783 data = Fcdr (Fcdr (data));
3786 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3788 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3789 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3792 for (i = first; i <= last; i++)
3793 Fput_char_table (make_char (i), val, chartab);
3799 Fput_char_table (range, val, chartab);
3808 /************************************************************************/
3809 /* Category Tables, specifically */
3810 /************************************************************************/
3812 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3813 Return t if OBJECT is a category table.
3814 A category table is a type of char table used for keeping track of
3815 categories. Categories are used for classifying characters for use
3816 in regexps -- you can refer to a category rather than having to use
3817 a complicated [] expression (and category lookups are significantly
3820 There are 95 different categories available, one for each printable
3821 character (including space) in the ASCII charset. Each category
3822 is designated by one such character, called a "category designator".
3823 They are specified in a regexp using the syntax "\\cX", where X is
3824 a category designator.
3826 A category table specifies, for each character, the categories that
3827 the character is in. Note that a character can be in more than one
3828 category. More specifically, a category table maps from a character
3829 to either the value nil (meaning the character is in no categories)
3830 or a 95-element bit vector, specifying for each of the 95 categories
3831 whether the character is in that category.
3833 Special Lisp functions are provided that abstract this, so you do not
3834 have to directly manipulate bit vectors.
3838 return (CHAR_TABLEP (object) &&
3839 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3844 check_category_table (Lisp_Object object, Lisp_Object default_)
3848 while (NILP (Fcategory_table_p (object)))
3849 object = wrong_type_argument (Qcategory_table_p, object);
3854 check_category_char (Emchar ch, Lisp_Object table,
3855 unsigned int designator, unsigned int not_p)
3857 REGISTER Lisp_Object temp;
3858 Lisp_Char_Table *ctbl;
3859 #ifdef ERROR_CHECK_TYPECHECK
3860 if (NILP (Fcategory_table_p (table)))
3861 signal_simple_error ("Expected category table", table);
3863 ctbl = XCHAR_TABLE (table);
3864 temp = get_char_table (ch, ctbl);
3869 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3872 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3873 Return t if category of the character at POSITION includes DESIGNATOR.
3874 Optional third arg BUFFER specifies which buffer to use, and defaults
3875 to the current buffer.
3876 Optional fourth arg CATEGORY-TABLE specifies the category table to
3877 use, and defaults to BUFFER's category table.
3879 (position, designator, buffer, category_table))
3884 struct buffer *buf = decode_buffer (buffer, 0);
3886 CHECK_INT (position);
3887 CHECK_CATEGORY_DESIGNATOR (designator);
3888 des = XCHAR (designator);
3889 ctbl = check_category_table (category_table, Vstandard_category_table);
3890 ch = BUF_FETCH_CHAR (buf, XINT (position));
3891 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3894 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3895 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3896 Optional third arg CATEGORY-TABLE specifies the category table to use,
3897 and defaults to the standard category table.
3899 (character, designator, category_table))
3905 CHECK_CATEGORY_DESIGNATOR (designator);
3906 des = XCHAR (designator);
3907 CHECK_CHAR (character);
3908 ch = XCHAR (character);
3909 ctbl = check_category_table (category_table, Vstandard_category_table);
3910 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3913 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3914 Return BUFFER's current category table.
3915 BUFFER defaults to the current buffer.
3919 return decode_buffer (buffer, 0)->category_table;
3922 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3923 Return the standard category table.
3924 This is the one used for new buffers.
3928 return Vstandard_category_table;
3931 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3932 Return a new category table which is a copy of CATEGORY-TABLE.
3933 CATEGORY-TABLE defaults to the standard category table.
3937 if (NILP (Vstandard_category_table))
3938 return Fmake_char_table (Qcategory);
3941 check_category_table (category_table, Vstandard_category_table);
3942 return Fcopy_char_table (category_table);
3945 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3946 Select CATEGORY-TABLE as the new category table for BUFFER.
3947 BUFFER defaults to the current buffer if omitted.
3949 (category_table, buffer))
3951 struct buffer *buf = decode_buffer (buffer, 0);
3952 category_table = check_category_table (category_table, Qnil);
3953 buf->category_table = category_table;
3954 /* Indicate that this buffer now has a specified category table. */
3955 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3956 return category_table;
3959 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3960 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3964 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3967 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3968 Return t if OBJECT is a category table value.
3969 Valid values are nil or a bit vector of size 95.
3973 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3977 #define CATEGORYP(x) \
3978 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3980 #define CATEGORY_SET(c) \
3981 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3983 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3984 The faster version of `!NILP (Faref (category_set, category))'. */
3985 #define CATEGORY_MEMBER(category, category_set) \
3986 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3988 /* Return 1 if there is a word boundary between two word-constituent
3989 characters C1 and C2 if they appear in this order, else return 0.
3990 Use the macro WORD_BOUNDARY_P instead of calling this function
3993 int word_boundary_p (Emchar c1, Emchar c2);
3995 word_boundary_p (Emchar c1, Emchar c2)
3997 Lisp_Object category_set1, category_set2;
4002 if (COMPOSITE_CHAR_P (c1))
4003 c1 = cmpchar_component (c1, 0, 1);
4004 if (COMPOSITE_CHAR_P (c2))
4005 c2 = cmpchar_component (c2, 0, 1);
4008 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4010 tail = Vword_separating_categories;
4015 tail = Vword_combining_categories;
4019 category_set1 = CATEGORY_SET (c1);
4020 if (NILP (category_set1))
4021 return default_result;
4022 category_set2 = CATEGORY_SET (c2);
4023 if (NILP (category_set2))
4024 return default_result;
4026 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4028 Lisp_Object elt = XCONS(tail)->car;
4031 && CATEGORYP (XCONS (elt)->car)
4032 && CATEGORYP (XCONS (elt)->cdr)
4033 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4034 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4035 return !default_result;
4037 return default_result;
4043 syms_of_chartab (void)
4046 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4047 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4048 INIT_LRECORD_IMPLEMENTATION (byte_table);
4050 defsymbol (&Qsystem_char_id, "system-char-id");
4052 defsymbol (&Qto_ucs, "=>ucs");
4053 defsymbol (&Q_ucs, "->ucs");
4054 defsymbol (&Q_ucs_variants, "->ucs-variants");
4055 defsymbol (&Qcomposition, "composition");
4056 defsymbol (&Q_decomposition, "->decomposition");
4057 defsymbol (&Qcompat, "compat");
4058 defsymbol (&Qisolated, "isolated");
4059 defsymbol (&Qinitial, "initial");
4060 defsymbol (&Qmedial, "medial");
4061 defsymbol (&Qfinal, "final");
4062 defsymbol (&Qvertical, "vertical");
4063 defsymbol (&QnoBreak, "noBreak");
4064 defsymbol (&Qfraction, "fraction");
4065 defsymbol (&Qsuper, "super");
4066 defsymbol (&Qsub, "sub");
4067 defsymbol (&Qcircle, "circle");
4068 defsymbol (&Qsquare, "square");
4069 defsymbol (&Qwide, "wide");
4070 defsymbol (&Qnarrow, "narrow");
4071 defsymbol (&Qsmall, "small");
4072 defsymbol (&Qfont, "font");
4074 DEFSUBR (Fchar_attribute_list);
4075 DEFSUBR (Ffind_char_attribute_table);
4076 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4077 DEFSUBR (Fput_char_table_map_function);
4078 #ifdef HAVE_DATABASE
4079 DEFSUBR (Fsave_char_attribute_table);
4080 DEFSUBR (Fmount_char_attribute_table);
4081 DEFSUBR (Freset_char_attribute_table);
4082 DEFSUBR (Fclose_char_attribute_table);
4083 defsymbol (&Qload_char_attribute_table_map_function,
4084 "load-char-attribute-table-map-function");
4085 DEFSUBR (Fload_char_attribute_table_map_function);
4086 DEFSUBR (Fload_char_attribute_table);
4088 DEFSUBR (Fchar_attribute_alist);
4089 DEFSUBR (Fget_char_attribute);
4090 DEFSUBR (Fput_char_attribute);
4091 DEFSUBR (Fremove_char_attribute);
4092 DEFSUBR (Fmap_char_attribute);
4093 DEFSUBR (Fdefine_char);
4094 DEFSUBR (Ffind_char);
4095 DEFSUBR (Fchar_variants);
4097 DEFSUBR (Fget_composite_char);
4100 INIT_LRECORD_IMPLEMENTATION (char_table);
4104 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4107 defsymbol (&Qcategory_table_p, "category-table-p");
4108 defsymbol (&Qcategory_designator_p, "category-designator-p");
4109 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4112 defsymbol (&Qchar_table, "char-table");
4113 defsymbol (&Qchar_tablep, "char-table-p");
4115 DEFSUBR (Fchar_table_p);
4116 DEFSUBR (Fchar_table_type_list);
4117 DEFSUBR (Fvalid_char_table_type_p);
4118 DEFSUBR (Fchar_table_type);
4119 DEFSUBR (Freset_char_table);
4120 DEFSUBR (Fmake_char_table);
4121 DEFSUBR (Fcopy_char_table);
4122 DEFSUBR (Fget_char_table);
4123 DEFSUBR (Fget_range_char_table);
4124 DEFSUBR (Fvalid_char_table_value_p);
4125 DEFSUBR (Fcheck_valid_char_table_value);
4126 DEFSUBR (Fput_char_table);
4127 DEFSUBR (Fmap_char_table);
4130 DEFSUBR (Fcategory_table_p);
4131 DEFSUBR (Fcategory_table);
4132 DEFSUBR (Fstandard_category_table);
4133 DEFSUBR (Fcopy_category_table);
4134 DEFSUBR (Fset_category_table);
4135 DEFSUBR (Fcheck_category_at);
4136 DEFSUBR (Fchar_in_category_p);
4137 DEFSUBR (Fcategory_designator_p);
4138 DEFSUBR (Fcategory_table_value_p);
4144 vars_of_chartab (void)
4147 staticpro (&Vcharacter_variant_table);
4148 Vcharacter_variant_table = make_char_id_table (Qunbound);
4150 #ifdef HAVE_DATABASE
4151 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4153 Vchar_db_stingy_mode = Qt;
4154 #endif /* HAVE_DATABASE */
4156 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4157 Vall_syntax_tables = Qnil;
4158 dump_add_weak_object_chain (&Vall_syntax_tables);
4162 structure_type_create_chartab (void)
4164 struct structure_type *st;
4166 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4168 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4169 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4173 complex_vars_of_chartab (void)
4176 staticpro (&Vchar_attribute_hash_table);
4177 Vchar_attribute_hash_table
4178 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4179 #ifdef HAVE_DATABASE
4180 Fputhash (Q_ucs_variants, Vcharacter_variant_table,
4181 Vchar_attribute_hash_table);
4182 XCHAR_TABLE_NAME (Vcharacter_variant_table) = Q_ucs_variants;
4183 #endif /* HAVE_DATABASE */
4184 #endif /* UTF2000 */
4186 /* Set this now, so first buffer creation can refer to it. */
4187 /* Make it nil before calling copy-category-table
4188 so that copy-category-table will know not to try to copy from garbage */
4189 Vstandard_category_table = Qnil;
4190 Vstandard_category_table = Fcopy_category_table (Qnil);
4191 staticpro (&Vstandard_category_table);
4193 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4194 List of pair (cons) of categories to determine word boundary.
4196 Emacs treats a sequence of word constituent characters as a single
4197 word (i.e. finds no word boundary between them) iff they belongs to
4198 the same charset. But, exceptions are allowed in the following cases.
4200 \(1) The case that characters are in different charsets is controlled
4201 by the variable `word-combining-categories'.
4203 Emacs finds no word boundary between characters of different charsets
4204 if they have categories matching some element of this list.
4206 More precisely, if an element of this list is a cons of category CAT1
4207 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4208 C2 which has CAT2, there's no word boundary between C1 and C2.
4210 For instance, to tell that ASCII characters and Latin-1 characters can
4211 form a single word, the element `(?l . ?l)' should be in this list
4212 because both characters have the category `l' (Latin characters).
4214 \(2) The case that character are in the same charset is controlled by
4215 the variable `word-separating-categories'.
4217 Emacs find a word boundary between characters of the same charset
4218 if they have categories matching some element of this list.
4220 More precisely, if an element of this list is a cons of category CAT1
4221 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4222 C2 which has CAT2, there's a word boundary between C1 and C2.
4224 For instance, to tell that there's a word boundary between Japanese
4225 Hiragana and Japanese Kanji (both are in the same charset), the
4226 element `(?H . ?C) should be in this list.
4229 Vword_combining_categories = Qnil;
4231 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4232 List of pair (cons) of categories to determine word boundary.
4233 See the documentation of the variable `word-combining-categories'.
4236 Vword_separating_categories = Qnil;