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 Qsystem_char_id;
1064 Lisp_Object Qcomposition;
1065 Lisp_Object Q_decomposition;
1066 Lisp_Object Qto_ucs;
1068 Lisp_Object Q_ucs_variants;
1069 Lisp_Object Qcompat;
1070 Lisp_Object Qisolated;
1071 Lisp_Object Qinitial;
1072 Lisp_Object Qmedial;
1074 Lisp_Object Qvertical;
1075 Lisp_Object QnoBreak;
1076 Lisp_Object Qfraction;
1079 Lisp_Object Qcircle;
1080 Lisp_Object Qsquare;
1082 Lisp_Object Qnarrow;
1086 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1089 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1095 else if (EQ (v, Qcompat))
1097 else if (EQ (v, Qisolated))
1099 else if (EQ (v, Qinitial))
1101 else if (EQ (v, Qmedial))
1103 else if (EQ (v, Qfinal))
1105 else if (EQ (v, Qvertical))
1107 else if (EQ (v, QnoBreak))
1109 else if (EQ (v, Qfraction))
1111 else if (EQ (v, Qsuper))
1113 else if (EQ (v, Qsub))
1115 else if (EQ (v, Qcircle))
1117 else if (EQ (v, Qsquare))
1119 else if (EQ (v, Qwide))
1121 else if (EQ (v, Qnarrow))
1123 else if (EQ (v, Qsmall))
1125 else if (EQ (v, Qfont))
1128 signal_simple_error (err_msg, err_arg);
1131 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1132 Return character corresponding with list.
1136 Lisp_Object base, modifier;
1140 signal_simple_error ("Invalid value for composition", list);
1143 while (!NILP (rest))
1148 signal_simple_error ("Invalid value for composition", list);
1149 modifier = Fcar (rest);
1151 base = Fcdr (Fassq (modifier,
1152 Fget_char_attribute (base, Qcomposition, Qnil)));
1157 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1158 Return variants of CHARACTER.
1164 CHECK_CHAR (character);
1165 ret = Fget_char_attribute (character, Q_ucs_variants, Qnil);
1167 return Fcopy_list (ret);
1175 /* A char table maps from ranges of characters to values.
1177 Implementing a general data structure that maps from arbitrary
1178 ranges of numbers to values is tricky to do efficiently. As it
1179 happens, it should suffice (and is usually more convenient, anyway)
1180 when dealing with characters to restrict the sorts of ranges that
1181 can be assigned values, as follows:
1184 2) All characters in a charset.
1185 3) All characters in a particular row of a charset, where a "row"
1186 means all characters with the same first byte.
1187 4) A particular character in a charset.
1189 We use char tables to generalize the 256-element vectors now
1190 littering the Emacs code.
1192 Possible uses (all should be converted at some point):
1198 5) keyboard-translate-table?
1201 abstract type to generalize the Emacs vectors and Mule
1202 vectors-of-vectors goo.
1205 /************************************************************************/
1206 /* Char Table object */
1207 /************************************************************************/
1209 #if defined(MULE)&&!defined(UTF2000)
1212 mark_char_table_entry (Lisp_Object obj)
1214 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1217 for (i = 0; i < 96; i++)
1219 mark_object (cte->level2[i]);
1225 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1227 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1228 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1231 for (i = 0; i < 96; i++)
1232 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1238 static unsigned long
1239 char_table_entry_hash (Lisp_Object obj, int depth)
1241 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1243 return internal_array_hash (cte->level2, 96, depth);
1246 static const struct lrecord_description char_table_entry_description[] = {
1247 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1251 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1252 mark_char_table_entry, internal_object_printer,
1253 0, char_table_entry_equal,
1254 char_table_entry_hash,
1255 char_table_entry_description,
1256 Lisp_Char_Table_Entry);
1260 mark_char_table (Lisp_Object obj)
1262 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1265 mark_object (ct->table);
1266 mark_object (ct->name);
1267 mark_object (ct->db);
1271 for (i = 0; i < NUM_ASCII_CHARS; i++)
1272 mark_object (ct->ascii[i]);
1274 for (i = 0; i < NUM_LEADING_BYTES; i++)
1275 mark_object (ct->level1[i]);
1279 return ct->default_value;
1281 return ct->mirror_table;
1285 /* WARNING: All functions of this nature need to be written extremely
1286 carefully to avoid crashes during GC. Cf. prune_specifiers()
1287 and prune_weak_hash_tables(). */
1290 prune_syntax_tables (void)
1292 Lisp_Object rest, prev = Qnil;
1294 for (rest = Vall_syntax_tables;
1296 rest = XCHAR_TABLE (rest)->next_table)
1298 if (! marked_p (rest))
1300 /* This table is garbage. Remove it from the list. */
1302 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1304 XCHAR_TABLE (prev)->next_table =
1305 XCHAR_TABLE (rest)->next_table;
1311 char_table_type_to_symbol (enum char_table_type type)
1316 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1317 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1318 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1319 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1321 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1326 static enum char_table_type
1327 symbol_to_char_table_type (Lisp_Object symbol)
1329 CHECK_SYMBOL (symbol);
1331 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1332 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1333 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1334 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1336 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1339 signal_simple_error ("Unrecognized char table type", symbol);
1340 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1344 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1345 Lisp_Object printcharfun)
1349 write_c_string (" (", printcharfun);
1350 print_internal (make_char (first), printcharfun, 0);
1351 write_c_string (" ", printcharfun);
1352 print_internal (make_char (last), printcharfun, 0);
1353 write_c_string (") ", printcharfun);
1357 write_c_string (" ", printcharfun);
1358 print_internal (make_char (first), printcharfun, 0);
1359 write_c_string (" ", printcharfun);
1361 print_internal (val, printcharfun, 1);
1364 #if defined(MULE)&&!defined(UTF2000)
1367 print_chartab_charset_row (Lisp_Object charset,
1369 Lisp_Char_Table_Entry *cte,
1370 Lisp_Object printcharfun)
1373 Lisp_Object cat = Qunbound;
1376 for (i = 32; i < 128; i++)
1378 Lisp_Object pam = cte->level2[i - 32];
1390 print_chartab_range (MAKE_CHAR (charset, first, 0),
1391 MAKE_CHAR (charset, i - 1, 0),
1394 print_chartab_range (MAKE_CHAR (charset, row, first),
1395 MAKE_CHAR (charset, row, i - 1),
1405 print_chartab_range (MAKE_CHAR (charset, first, 0),
1406 MAKE_CHAR (charset, i - 1, 0),
1409 print_chartab_range (MAKE_CHAR (charset, row, first),
1410 MAKE_CHAR (charset, row, i - 1),
1416 print_chartab_two_byte_charset (Lisp_Object charset,
1417 Lisp_Char_Table_Entry *cte,
1418 Lisp_Object printcharfun)
1422 for (i = 32; i < 128; i++)
1424 Lisp_Object jen = cte->level2[i - 32];
1426 if (!CHAR_TABLE_ENTRYP (jen))
1430 write_c_string (" [", printcharfun);
1431 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1432 sprintf (buf, " %d] ", i);
1433 write_c_string (buf, printcharfun);
1434 print_internal (jen, printcharfun, 0);
1437 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1445 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1447 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1450 struct gcpro gcpro1, gcpro2;
1451 GCPRO2 (obj, printcharfun);
1453 write_c_string ("#s(char-table ", printcharfun);
1454 write_c_string (" ", printcharfun);
1455 write_c_string (string_data
1457 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1459 write_c_string ("\n ", printcharfun);
1460 print_internal (ct->default_value, printcharfun, escapeflag);
1461 for (i = 0; i < 256; i++)
1463 Lisp_Object elt = get_byte_table (ct->table, i);
1464 if (i != 0) write_c_string ("\n ", printcharfun);
1465 if (EQ (elt, Qunbound))
1466 write_c_string ("void", printcharfun);
1468 print_internal (elt, printcharfun, escapeflag);
1471 #else /* non UTF2000 */
1474 sprintf (buf, "#s(char-table type %s data (",
1475 string_data (symbol_name (XSYMBOL
1476 (char_table_type_to_symbol (ct->type)))));
1477 write_c_string (buf, printcharfun);
1479 /* Now write out the ASCII/Control-1 stuff. */
1483 Lisp_Object val = Qunbound;
1485 for (i = 0; i < NUM_ASCII_CHARS; i++)
1494 if (!EQ (ct->ascii[i], val))
1496 print_chartab_range (first, i - 1, val, printcharfun);
1503 print_chartab_range (first, i - 1, val, printcharfun);
1510 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1513 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1514 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1516 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1517 || i == LEADING_BYTE_CONTROL_1)
1519 if (!CHAR_TABLE_ENTRYP (ann))
1521 write_c_string (" ", printcharfun);
1522 print_internal (XCHARSET_NAME (charset),
1524 write_c_string (" ", printcharfun);
1525 print_internal (ann, printcharfun, 0);
1529 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1530 if (XCHARSET_DIMENSION (charset) == 1)
1531 print_chartab_charset_row (charset, -1, cte, printcharfun);
1533 print_chartab_two_byte_charset (charset, cte, printcharfun);
1538 #endif /* non UTF2000 */
1540 write_c_string ("))", printcharfun);
1544 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1546 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1547 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1550 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1554 for (i = 0; i < 256; i++)
1556 if (!internal_equal (get_byte_table (ct1->table, i),
1557 get_byte_table (ct2->table, i), 0))
1561 for (i = 0; i < NUM_ASCII_CHARS; i++)
1562 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1566 for (i = 0; i < NUM_LEADING_BYTES; i++)
1567 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1570 #endif /* non UTF2000 */
1575 static unsigned long
1576 char_table_hash (Lisp_Object obj, int depth)
1578 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1580 return byte_table_hash (ct->table, depth + 1);
1582 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1585 hashval = HASH2 (hashval,
1586 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1592 static const struct lrecord_description char_table_description[] = {
1594 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1595 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1596 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1597 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1599 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1601 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1605 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1607 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1611 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1612 mark_char_table, print_char_table, 0,
1613 char_table_equal, char_table_hash,
1614 char_table_description,
1617 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1618 Return non-nil if OBJECT is a char table.
1620 A char table is a table that maps characters (or ranges of characters)
1621 to values. Char tables are specialized for characters, only allowing
1622 particular sorts of ranges to be assigned values. Although this
1623 loses in generality, it makes for extremely fast (constant-time)
1624 lookups, and thus is feasible for applications that do an extremely
1625 large number of lookups (e.g. scanning a buffer for a character in
1626 a particular syntax, where a lookup in the syntax table must occur
1627 once per character).
1629 When Mule support exists, the types of ranges that can be assigned
1633 -- an entire charset
1634 -- a single row in a two-octet charset
1635 -- a single character
1637 When Mule support is not present, the types of ranges that can be
1641 -- a single character
1643 To create a char table, use `make-char-table'.
1644 To modify a char table, use `put-char-table' or `remove-char-table'.
1645 To retrieve the value for a particular character, use `get-char-table'.
1646 See also `map-char-table', `clear-char-table', `copy-char-table',
1647 `valid-char-table-type-p', `char-table-type-list',
1648 `valid-char-table-value-p', and `check-char-table-value'.
1652 return CHAR_TABLEP (object) ? Qt : Qnil;
1655 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1656 Return a list of the recognized char table types.
1657 See `valid-char-table-type-p'.
1662 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1664 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1668 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1669 Return t if TYPE if a recognized char table type.
1671 Each char table type is used for a different purpose and allows different
1672 sorts of values. The different char table types are
1675 Used for category tables, which specify the regexp categories
1676 that a character is in. The valid values are nil or a
1677 bit vector of 95 elements. Higher-level Lisp functions are
1678 provided for working with category tables. Currently categories
1679 and category tables only exist when Mule support is present.
1681 A generalized char table, for mapping from one character to
1682 another. Used for case tables, syntax matching tables,
1683 `keyboard-translate-table', etc. The valid values are characters.
1685 An even more generalized char table, for mapping from a
1686 character to anything.
1688 Used for display tables, which specify how a particular character
1689 is to appear when displayed. #### Not yet implemented.
1691 Used for syntax tables, which specify the syntax of a particular
1692 character. Higher-level Lisp functions are provided for
1693 working with syntax tables. The valid values are integers.
1698 return (EQ (type, Qchar) ||
1700 EQ (type, Qcategory) ||
1702 EQ (type, Qdisplay) ||
1703 EQ (type, Qgeneric) ||
1704 EQ (type, Qsyntax)) ? Qt : Qnil;
1707 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1708 Return the type of CHAR-TABLE.
1709 See `valid-char-table-type-p'.
1713 CHECK_CHAR_TABLE (char_table);
1714 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1718 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1721 ct->table = Qunbound;
1722 ct->default_value = value;
1727 for (i = 0; i < NUM_ASCII_CHARS; i++)
1728 ct->ascii[i] = value;
1730 for (i = 0; i < NUM_LEADING_BYTES; i++)
1731 ct->level1[i] = value;
1736 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1737 update_syntax_table (ct);
1741 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1742 Reset CHAR-TABLE to its default state.
1746 Lisp_Char_Table *ct;
1748 CHECK_CHAR_TABLE (char_table);
1749 ct = XCHAR_TABLE (char_table);
1753 case CHAR_TABLE_TYPE_CHAR:
1754 fill_char_table (ct, make_char (0));
1756 case CHAR_TABLE_TYPE_DISPLAY:
1757 case CHAR_TABLE_TYPE_GENERIC:
1759 case CHAR_TABLE_TYPE_CATEGORY:
1761 fill_char_table (ct, Qnil);
1764 case CHAR_TABLE_TYPE_SYNTAX:
1765 fill_char_table (ct, make_int (Sinherit));
1775 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1776 Return a new, empty char table of type TYPE.
1777 Currently recognized types are 'char, 'category, 'display, 'generic,
1778 and 'syntax. See `valid-char-table-type-p'.
1782 Lisp_Char_Table *ct;
1784 enum char_table_type ty = symbol_to_char_table_type (type);
1786 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1789 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1791 ct->mirror_table = Fmake_char_table (Qgeneric);
1792 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1796 ct->mirror_table = Qnil;
1801 ct->next_table = Qnil;
1802 XSETCHAR_TABLE (obj, ct);
1803 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1805 ct->next_table = Vall_syntax_tables;
1806 Vall_syntax_tables = obj;
1808 Freset_char_table (obj);
1812 #if defined(MULE)&&!defined(UTF2000)
1815 make_char_table_entry (Lisp_Object initval)
1819 Lisp_Char_Table_Entry *cte =
1820 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1822 for (i = 0; i < 96; i++)
1823 cte->level2[i] = initval;
1825 XSETCHAR_TABLE_ENTRY (obj, cte);
1830 copy_char_table_entry (Lisp_Object entry)
1832 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1835 Lisp_Char_Table_Entry *ctenew =
1836 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1838 for (i = 0; i < 96; i++)
1840 Lisp_Object new = cte->level2[i];
1841 if (CHAR_TABLE_ENTRYP (new))
1842 ctenew->level2[i] = copy_char_table_entry (new);
1844 ctenew->level2[i] = new;
1847 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1853 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1854 Return a new char table which is a copy of CHAR-TABLE.
1855 It will contain the same values for the same characters and ranges
1856 as CHAR-TABLE. The values will not themselves be copied.
1860 Lisp_Char_Table *ct, *ctnew;
1866 CHECK_CHAR_TABLE (char_table);
1867 ct = XCHAR_TABLE (char_table);
1868 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1869 ctnew->type = ct->type;
1871 ctnew->default_value = ct->default_value;
1872 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1873 ctnew->name = ct->name;
1876 if (UINT8_BYTE_TABLE_P (ct->table))
1878 ctnew->table = copy_uint8_byte_table (ct->table);
1880 else if (UINT16_BYTE_TABLE_P (ct->table))
1882 ctnew->table = copy_uint16_byte_table (ct->table);
1884 else if (BYTE_TABLE_P (ct->table))
1886 ctnew->table = copy_byte_table (ct->table);
1888 else if (!UNBOUNDP (ct->table))
1889 ctnew->table = ct->table;
1890 #else /* non UTF2000 */
1892 for (i = 0; i < NUM_ASCII_CHARS; i++)
1894 Lisp_Object new = ct->ascii[i];
1896 assert (! (CHAR_TABLE_ENTRYP (new)));
1898 ctnew->ascii[i] = new;
1903 for (i = 0; i < NUM_LEADING_BYTES; i++)
1905 Lisp_Object new = ct->level1[i];
1906 if (CHAR_TABLE_ENTRYP (new))
1907 ctnew->level1[i] = copy_char_table_entry (new);
1909 ctnew->level1[i] = new;
1913 #endif /* non UTF2000 */
1916 if (CHAR_TABLEP (ct->mirror_table))
1917 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1919 ctnew->mirror_table = ct->mirror_table;
1921 ctnew->next_table = Qnil;
1922 XSETCHAR_TABLE (obj, ctnew);
1923 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1925 ctnew->next_table = Vall_syntax_tables;
1926 Vall_syntax_tables = obj;
1931 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1933 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1935 switch (XCHARSET_CHARS (ccs))
1938 return (33 << 8) | 126;
1940 return (32 << 8) | 127;
1943 return (0 << 8) | 127;
1945 return (0 << 8) | 255;
1957 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1960 outrange->type = CHARTAB_RANGE_ALL;
1961 else if (EQ (range, Qnil))
1962 outrange->type = CHARTAB_RANGE_DEFAULT;
1963 else if (CHAR_OR_CHAR_INTP (range))
1965 outrange->type = CHARTAB_RANGE_CHAR;
1966 outrange->ch = XCHAR_OR_CHAR_INT (range);
1970 signal_simple_error ("Range must be t or a character", range);
1972 else if (VECTORP (range))
1974 Lisp_Vector *vec = XVECTOR (range);
1975 Lisp_Object *elts = vector_data (vec);
1976 int cell_min, cell_max;
1978 outrange->type = CHARTAB_RANGE_ROW;
1979 outrange->charset = Fget_charset (elts[0]);
1980 CHECK_INT (elts[1]);
1981 outrange->row = XINT (elts[1]);
1982 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1983 signal_simple_error ("Charset in row vector must be multi-byte",
1987 int ret = XCHARSET_CELL_RANGE (outrange->charset);
1989 cell_min = ret >> 8;
1990 cell_max = ret & 0xFF;
1992 if (XCHARSET_DIMENSION (outrange->charset) == 2)
1993 check_int_range (outrange->row, cell_min, cell_max);
1995 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
1997 check_int_range (outrange->row >> 8 , cell_min, cell_max);
1998 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2000 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2002 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2003 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2004 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2012 if (!CHARSETP (range) && !SYMBOLP (range))
2014 ("Char table range must be t, charset, char, or vector", range);
2015 outrange->type = CHARTAB_RANGE_CHARSET;
2016 outrange->charset = Fget_charset (range);
2021 #if defined(MULE)&&!defined(UTF2000)
2023 /* called from CHAR_TABLE_VALUE(). */
2025 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2030 Lisp_Object charset;
2032 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2037 BREAKUP_CHAR (c, charset, byte1, byte2);
2039 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2041 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2042 if (CHAR_TABLE_ENTRYP (val))
2044 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2045 val = cte->level2[byte1 - 32];
2046 if (CHAR_TABLE_ENTRYP (val))
2048 cte = XCHAR_TABLE_ENTRY (val);
2049 assert (byte2 >= 32);
2050 val = cte->level2[byte2 - 32];
2051 assert (!CHAR_TABLE_ENTRYP (val));
2061 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2064 return get_char_id_table (ct, ch);
2067 Lisp_Object charset;
2071 BREAKUP_CHAR (ch, charset, byte1, byte2);
2073 if (EQ (charset, Vcharset_ascii))
2074 val = ct->ascii[byte1];
2075 else if (EQ (charset, Vcharset_control_1))
2076 val = ct->ascii[byte1 + 128];
2079 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2080 val = ct->level1[lb];
2081 if (CHAR_TABLE_ENTRYP (val))
2083 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2084 val = cte->level2[byte1 - 32];
2085 if (CHAR_TABLE_ENTRYP (val))
2087 cte = XCHAR_TABLE_ENTRY (val);
2088 assert (byte2 >= 32);
2089 val = cte->level2[byte2 - 32];
2090 assert (!CHAR_TABLE_ENTRYP (val));
2097 #else /* not MULE */
2098 return ct->ascii[(unsigned char)ch];
2099 #endif /* not MULE */
2103 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2104 Find value for CHARACTER in CHAR-TABLE.
2106 (character, char_table))
2108 CHECK_CHAR_TABLE (char_table);
2109 CHECK_CHAR_COERCE_INT (character);
2111 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2114 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2115 Find value for a range in CHAR-TABLE.
2116 If there is more than one value, return MULTI (defaults to nil).
2118 (range, char_table, multi))
2120 Lisp_Char_Table *ct;
2121 struct chartab_range rainj;
2123 if (CHAR_OR_CHAR_INTP (range))
2124 return Fget_char_table (range, char_table);
2125 CHECK_CHAR_TABLE (char_table);
2126 ct = XCHAR_TABLE (char_table);
2128 decode_char_table_range (range, &rainj);
2131 case CHARTAB_RANGE_ALL:
2134 if (UINT8_BYTE_TABLE_P (ct->table))
2136 else if (UINT16_BYTE_TABLE_P (ct->table))
2138 else if (BYTE_TABLE_P (ct->table))
2142 #else /* non UTF2000 */
2144 Lisp_Object first = ct->ascii[0];
2146 for (i = 1; i < NUM_ASCII_CHARS; i++)
2147 if (!EQ (first, ct->ascii[i]))
2151 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2154 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2155 || i == LEADING_BYTE_ASCII
2156 || i == LEADING_BYTE_CONTROL_1)
2158 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2164 #endif /* non UTF2000 */
2168 case CHARTAB_RANGE_CHARSET:
2172 if (EQ (rainj.charset, Vcharset_ascii))
2175 Lisp_Object first = ct->ascii[0];
2177 for (i = 1; i < 128; i++)
2178 if (!EQ (first, ct->ascii[i]))
2183 if (EQ (rainj.charset, Vcharset_control_1))
2186 Lisp_Object first = ct->ascii[128];
2188 for (i = 129; i < 160; i++)
2189 if (!EQ (first, ct->ascii[i]))
2195 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2197 if (CHAR_TABLE_ENTRYP (val))
2203 case CHARTAB_RANGE_ROW:
2208 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2210 if (!CHAR_TABLE_ENTRYP (val))
2212 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2213 if (CHAR_TABLE_ENTRYP (val))
2217 #endif /* not UTF2000 */
2218 #endif /* not MULE */
2224 return Qnil; /* not reached */
2228 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2229 Error_behavior errb)
2233 case CHAR_TABLE_TYPE_SYNTAX:
2234 if (!ERRB_EQ (errb, ERROR_ME))
2235 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2236 && CHAR_OR_CHAR_INTP (XCDR (value)));
2239 Lisp_Object cdr = XCDR (value);
2240 CHECK_INT (XCAR (value));
2241 CHECK_CHAR_COERCE_INT (cdr);
2248 case CHAR_TABLE_TYPE_CATEGORY:
2249 if (!ERRB_EQ (errb, ERROR_ME))
2250 return CATEGORY_TABLE_VALUEP (value);
2251 CHECK_CATEGORY_TABLE_VALUE (value);
2255 case CHAR_TABLE_TYPE_GENERIC:
2258 case CHAR_TABLE_TYPE_DISPLAY:
2260 maybe_signal_simple_error ("Display char tables not yet implemented",
2261 value, Qchar_table, errb);
2264 case CHAR_TABLE_TYPE_CHAR:
2265 if (!ERRB_EQ (errb, ERROR_ME))
2266 return CHAR_OR_CHAR_INTP (value);
2267 CHECK_CHAR_COERCE_INT (value);
2274 return 0; /* not reached */
2278 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2282 case CHAR_TABLE_TYPE_SYNTAX:
2285 Lisp_Object car = XCAR (value);
2286 Lisp_Object cdr = XCDR (value);
2287 CHECK_CHAR_COERCE_INT (cdr);
2288 return Fcons (car, cdr);
2291 case CHAR_TABLE_TYPE_CHAR:
2292 CHECK_CHAR_COERCE_INT (value);
2300 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2301 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2303 (value, char_table_type))
2305 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2307 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2310 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2311 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2313 (value, char_table_type))
2315 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2317 check_valid_char_table_value (value, type, ERROR_ME);
2322 Lisp_Char_Table* char_attribute_table_to_put;
2323 Lisp_Object Qput_char_table_map_function;
2324 Lisp_Object value_to_put;
2326 DEFUN ("put-char-table-map-function",
2327 Fput_char_table_map_function, 2, 2, 0, /*
2328 For internal use. Don't use it.
2332 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2337 /* Assign VAL to all characters in RANGE in char table CT. */
2340 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2343 switch (range->type)
2345 case CHARTAB_RANGE_ALL:
2346 /* printf ("put-char-table: range = all\n"); */
2347 fill_char_table (ct, val);
2348 return; /* avoid the duplicate call to update_syntax_table() below,
2349 since fill_char_table() also did that. */
2352 case CHARTAB_RANGE_DEFAULT:
2353 ct->default_value = val;
2358 case CHARTAB_RANGE_CHARSET:
2362 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2364 /* printf ("put-char-table: range = charset: %d\n",
2365 XCHARSET_LEADING_BYTE (range->charset));
2367 if ( CHAR_TABLEP (encoding_table) )
2370 char_attribute_table_to_put = ct;
2372 Fmap_char_attribute (Qput_char_table_map_function,
2373 XCHAR_TABLE_NAME (encoding_table),
2376 for (c = 0; c < 1 << 24; c++)
2378 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2380 put_char_id_table_0 (ct, c, val);
2386 for (c = 0; c < 1 << 24; c++)
2388 if ( charset_code_point (range->charset, c) >= 0 )
2389 put_char_id_table_0 (ct, c, val);
2394 if (EQ (range->charset, Vcharset_ascii))
2397 for (i = 0; i < 128; i++)
2400 else if (EQ (range->charset, Vcharset_control_1))
2403 for (i = 128; i < 160; i++)
2408 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2409 ct->level1[lb] = val;
2414 case CHARTAB_RANGE_ROW:
2417 int cell_min, cell_max, i;
2419 i = XCHARSET_CELL_RANGE (range->charset);
2421 cell_max = i & 0xFF;
2422 for (i = cell_min; i <= cell_max; i++)
2424 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2426 if ( charset_code_point (range->charset, ch) >= 0 )
2427 put_char_id_table_0 (ct, ch, val);
2432 Lisp_Char_Table_Entry *cte;
2433 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2434 /* make sure that there is a separate entry for the row. */
2435 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2436 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2437 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2438 cte->level2[range->row - 32] = val;
2440 #endif /* not UTF2000 */
2444 case CHARTAB_RANGE_CHAR:
2446 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2447 put_char_id_table_0 (ct, range->ch, val);
2451 Lisp_Object charset;
2454 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2455 if (EQ (charset, Vcharset_ascii))
2456 ct->ascii[byte1] = val;
2457 else if (EQ (charset, Vcharset_control_1))
2458 ct->ascii[byte1 + 128] = val;
2461 Lisp_Char_Table_Entry *cte;
2462 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2463 /* make sure that there is a separate entry for the row. */
2464 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2465 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2466 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2467 /* now CTE is a char table entry for the charset;
2468 each entry is for a single row (or character of
2469 a one-octet charset). */
2470 if (XCHARSET_DIMENSION (charset) == 1)
2471 cte->level2[byte1 - 32] = val;
2474 /* assigning to one character in a two-octet charset. */
2475 /* make sure that the charset row contains a separate
2476 entry for each character. */
2477 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2478 cte->level2[byte1 - 32] =
2479 make_char_table_entry (cte->level2[byte1 - 32]);
2480 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2481 cte->level2[byte2 - 32] = val;
2485 #else /* not MULE */
2486 ct->ascii[(unsigned char) (range->ch)] = val;
2488 #endif /* not MULE */
2492 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2493 update_syntax_table (ct);
2497 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2498 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2500 RANGE specifies one or more characters to be affected and should be
2501 one of the following:
2503 -- t (all characters are affected)
2504 -- A charset (only allowed when Mule support is present)
2505 -- A vector of two elements: a two-octet charset and a row number
2506 (only allowed when Mule support is present)
2507 -- A single character
2509 VALUE must be a value appropriate for the type of CHAR-TABLE.
2510 See `valid-char-table-type-p'.
2512 (range, value, char_table))
2514 Lisp_Char_Table *ct;
2515 struct chartab_range rainj;
2517 CHECK_CHAR_TABLE (char_table);
2518 ct = XCHAR_TABLE (char_table);
2519 check_valid_char_table_value (value, ct->type, ERROR_ME);
2520 decode_char_table_range (range, &rainj);
2521 value = canonicalize_char_table_value (value, ct->type);
2522 put_char_table (ct, &rainj, value);
2527 /* Map FN over the ASCII chars in CT. */
2530 map_over_charset_ascii (Lisp_Char_Table *ct,
2531 int (*fn) (struct chartab_range *range,
2532 Lisp_Object val, void *arg),
2535 struct chartab_range rainj;
2544 rainj.type = CHARTAB_RANGE_CHAR;
2546 for (i = start, retval = 0; i < stop && retval == 0; i++)
2548 rainj.ch = (Emchar) i;
2549 retval = (fn) (&rainj, ct->ascii[i], arg);
2557 /* Map FN over the Control-1 chars in CT. */
2560 map_over_charset_control_1 (Lisp_Char_Table *ct,
2561 int (*fn) (struct chartab_range *range,
2562 Lisp_Object val, void *arg),
2565 struct chartab_range rainj;
2568 int stop = start + 32;
2570 rainj.type = CHARTAB_RANGE_CHAR;
2572 for (i = start, retval = 0; i < stop && retval == 0; i++)
2574 rainj.ch = (Emchar) (i);
2575 retval = (fn) (&rainj, ct->ascii[i], arg);
2581 /* Map FN over the row ROW of two-byte charset CHARSET.
2582 There must be a separate value for that row in the char table.
2583 CTE specifies the char table entry for CHARSET. */
2586 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2587 Lisp_Object charset, int row,
2588 int (*fn) (struct chartab_range *range,
2589 Lisp_Object val, void *arg),
2592 Lisp_Object val = cte->level2[row - 32];
2594 if (!CHAR_TABLE_ENTRYP (val))
2596 struct chartab_range rainj;
2598 rainj.type = CHARTAB_RANGE_ROW;
2599 rainj.charset = charset;
2601 return (fn) (&rainj, val, arg);
2605 struct chartab_range rainj;
2607 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2608 int start = charset94_p ? 33 : 32;
2609 int stop = charset94_p ? 127 : 128;
2611 cte = XCHAR_TABLE_ENTRY (val);
2613 rainj.type = CHARTAB_RANGE_CHAR;
2615 for (i = start, retval = 0; i < stop && retval == 0; i++)
2617 rainj.ch = MAKE_CHAR (charset, row, i);
2618 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2626 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2627 int (*fn) (struct chartab_range *range,
2628 Lisp_Object val, void *arg),
2631 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2632 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2634 if (!CHARSETP (charset)
2635 || lb == LEADING_BYTE_ASCII
2636 || lb == LEADING_BYTE_CONTROL_1)
2639 if (!CHAR_TABLE_ENTRYP (val))
2641 struct chartab_range rainj;
2643 rainj.type = CHARTAB_RANGE_CHARSET;
2644 rainj.charset = charset;
2645 return (fn) (&rainj, val, arg);
2649 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2650 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2651 int start = charset94_p ? 33 : 32;
2652 int stop = charset94_p ? 127 : 128;
2655 if (XCHARSET_DIMENSION (charset) == 1)
2657 struct chartab_range rainj;
2658 rainj.type = CHARTAB_RANGE_CHAR;
2660 for (i = start, retval = 0; i < stop && retval == 0; i++)
2662 rainj.ch = MAKE_CHAR (charset, i, 0);
2663 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2668 for (i = start, retval = 0; i < stop && retval == 0; i++)
2669 retval = map_over_charset_row (cte, charset, i, fn, arg);
2677 #endif /* not UTF2000 */
2680 struct map_char_table_for_charset_arg
2682 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2683 Lisp_Char_Table *ct;
2688 map_char_table_for_charset_fun (struct chartab_range *range,
2689 Lisp_Object val, void *arg)
2691 struct map_char_table_for_charset_arg *closure =
2692 (struct map_char_table_for_charset_arg *) arg;
2695 switch (range->type)
2697 case CHARTAB_RANGE_ALL:
2700 case CHARTAB_RANGE_DEFAULT:
2703 case CHARTAB_RANGE_CHARSET:
2706 case CHARTAB_RANGE_ROW:
2709 case CHARTAB_RANGE_CHAR:
2710 ret = get_char_table (range->ch, closure->ct);
2711 if (!UNBOUNDP (ret))
2712 return (closure->fn) (range, ret, closure->arg);
2724 /* Map FN (with client data ARG) over range RANGE in char table CT.
2725 Mapping stops the first time FN returns non-zero, and that value
2726 becomes the return value of map_char_table(). */
2729 map_char_table (Lisp_Char_Table *ct,
2730 struct chartab_range *range,
2731 int (*fn) (struct chartab_range *range,
2732 Lisp_Object val, void *arg),
2735 switch (range->type)
2737 case CHARTAB_RANGE_ALL:
2739 if (!UNBOUNDP (ct->default_value))
2741 struct chartab_range rainj;
2744 rainj.type = CHARTAB_RANGE_DEFAULT;
2745 retval = (fn) (&rainj, ct->default_value, arg);
2749 if (UINT8_BYTE_TABLE_P (ct->table))
2750 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2752 else if (UINT16_BYTE_TABLE_P (ct->table))
2753 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2755 else if (BYTE_TABLE_P (ct->table))
2756 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2758 else if (EQ (ct->table, Qunloaded))
2761 struct chartab_range rainj;
2764 Emchar c1 = c + unit;
2767 rainj.type = CHARTAB_RANGE_CHAR;
2769 for (retval = 0; c < c1 && retval == 0; c++)
2771 Lisp_Object ret = get_char_id_table (ct, c);
2773 if (!UNBOUNDP (ret))
2776 retval = (fn) (&rainj, ct->table, arg);
2781 ct->table = Qunbound;
2784 else if (!UNBOUNDP (ct->table))
2785 return (fn) (range, ct->table, arg);
2791 retval = map_over_charset_ascii (ct, fn, arg);
2795 retval = map_over_charset_control_1 (ct, fn, arg);
2800 Charset_ID start = MIN_LEADING_BYTE;
2801 Charset_ID stop = start + NUM_LEADING_BYTES;
2803 for (i = start, retval = 0; i < stop && retval == 0; i++)
2805 retval = map_over_other_charset (ct, i, fn, arg);
2814 case CHARTAB_RANGE_DEFAULT:
2815 if (!UNBOUNDP (ct->default_value))
2816 return (fn) (range, ct->default_value, arg);
2821 case CHARTAB_RANGE_CHARSET:
2824 Lisp_Object encoding_table
2825 = XCHARSET_ENCODING_TABLE (range->charset);
2827 if (!NILP (encoding_table))
2829 struct chartab_range rainj;
2830 struct map_char_table_for_charset_arg mcarg;
2832 #ifdef HAVE_DATABASE
2833 if (XCHAR_TABLE_UNLOADED(encoding_table))
2834 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2839 rainj.type = CHARTAB_RANGE_ALL;
2840 return map_char_table (XCHAR_TABLE(encoding_table),
2842 &map_char_table_for_charset_fun,
2848 return map_over_other_charset (ct,
2849 XCHARSET_LEADING_BYTE (range->charset),
2853 case CHARTAB_RANGE_ROW:
2856 int cell_min, cell_max, i;
2858 struct chartab_range rainj;
2860 i = XCHARSET_CELL_RANGE (range->charset);
2862 cell_max = i & 0xFF;
2863 rainj.type = CHARTAB_RANGE_CHAR;
2864 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2866 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2868 if ( charset_code_point (range->charset, ch) >= 0 )
2871 = get_byte_table (get_byte_table
2875 (unsigned char)(ch >> 24)),
2876 (unsigned char) (ch >> 16)),
2877 (unsigned char) (ch >> 8)),
2878 (unsigned char) ch);
2881 val = ct->default_value;
2883 retval = (fn) (&rainj, val, arg);
2890 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2891 - MIN_LEADING_BYTE];
2892 if (!CHAR_TABLE_ENTRYP (val))
2894 struct chartab_range rainj;
2896 rainj.type = CHARTAB_RANGE_ROW;
2897 rainj.charset = range->charset;
2898 rainj.row = range->row;
2899 return (fn) (&rainj, val, arg);
2902 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2903 range->charset, range->row,
2906 #endif /* not UTF2000 */
2909 case CHARTAB_RANGE_CHAR:
2911 Emchar ch = range->ch;
2912 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2914 if (!UNBOUNDP (val))
2916 struct chartab_range rainj;
2918 rainj.type = CHARTAB_RANGE_CHAR;
2920 return (fn) (&rainj, val, arg);
2932 struct slow_map_char_table_arg
2934 Lisp_Object function;
2939 slow_map_char_table_fun (struct chartab_range *range,
2940 Lisp_Object val, void *arg)
2942 Lisp_Object ranjarg = Qnil;
2943 struct slow_map_char_table_arg *closure =
2944 (struct slow_map_char_table_arg *) arg;
2946 switch (range->type)
2948 case CHARTAB_RANGE_ALL:
2953 case CHARTAB_RANGE_DEFAULT:
2959 case CHARTAB_RANGE_CHARSET:
2960 ranjarg = XCHARSET_NAME (range->charset);
2963 case CHARTAB_RANGE_ROW:
2964 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2965 make_int (range->row));
2968 case CHARTAB_RANGE_CHAR:
2969 ranjarg = make_char (range->ch);
2975 closure->retval = call2 (closure->function, ranjarg, val);
2976 return !NILP (closure->retval);
2979 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2980 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2981 each key and value in the table.
2983 RANGE specifies a subrange to map over and is in the same format as
2984 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2987 (function, char_table, range))
2989 Lisp_Char_Table *ct;
2990 struct slow_map_char_table_arg slarg;
2991 struct gcpro gcpro1, gcpro2;
2992 struct chartab_range rainj;
2994 CHECK_CHAR_TABLE (char_table);
2995 ct = XCHAR_TABLE (char_table);
2998 decode_char_table_range (range, &rainj);
2999 slarg.function = function;
3000 slarg.retval = Qnil;
3001 GCPRO2 (slarg.function, slarg.retval);
3002 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3005 return slarg.retval;
3009 /************************************************************************/
3010 /* Character Attributes */
3011 /************************************************************************/
3015 Lisp_Object Vchar_attribute_hash_table;
3017 /* We store the char-attributes in hash tables with the names as the
3018 key and the actual char-id-table object as the value. Occasionally
3019 we need to use them in a list format. These routines provide us
3021 struct char_attribute_list_closure
3023 Lisp_Object *char_attribute_list;
3027 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3028 void *char_attribute_list_closure)
3030 /* This function can GC */
3031 struct char_attribute_list_closure *calcl
3032 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3033 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3035 *char_attribute_list = Fcons (key, *char_attribute_list);
3039 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3040 Return the list of all existing character attributes except coded-charsets.
3044 Lisp_Object char_attribute_list = Qnil;
3045 struct gcpro gcpro1;
3046 struct char_attribute_list_closure char_attribute_list_closure;
3048 GCPRO1 (char_attribute_list);
3049 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3050 elisp_maphash (add_char_attribute_to_list_mapper,
3051 Vchar_attribute_hash_table,
3052 &char_attribute_list_closure);
3054 return char_attribute_list;
3057 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3058 Return char-id-table corresponding to ATTRIBUTE.
3062 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3066 /* We store the char-id-tables in hash tables with the attributes as
3067 the key and the actual char-id-table object as the value. Each
3068 char-id-table stores values of an attribute corresponding with
3069 characters. Occasionally we need to get attributes of a character
3070 in a association-list format. These routines provide us with
3072 struct char_attribute_alist_closure
3075 Lisp_Object *char_attribute_alist;
3079 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3080 void *char_attribute_alist_closure)
3082 /* This function can GC */
3083 struct char_attribute_alist_closure *caacl =
3084 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3086 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3087 if (!UNBOUNDP (ret))
3089 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3090 *char_attribute_alist
3091 = Fcons (Fcons (key, ret), *char_attribute_alist);
3096 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3097 Return the alist of attributes of CHARACTER.
3101 struct gcpro gcpro1;
3102 struct char_attribute_alist_closure char_attribute_alist_closure;
3103 Lisp_Object alist = Qnil;
3105 CHECK_CHAR (character);
3108 char_attribute_alist_closure.char_id = XCHAR (character);
3109 char_attribute_alist_closure.char_attribute_alist = &alist;
3110 elisp_maphash (add_char_attribute_alist_mapper,
3111 Vchar_attribute_hash_table,
3112 &char_attribute_alist_closure);
3118 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3119 Return the value of CHARACTER's ATTRIBUTE.
3120 Return DEFAULT-VALUE if the value is not exist.
3122 (character, attribute, default_value))
3126 CHECK_CHAR (character);
3128 if (CHARSETP (attribute))
3129 attribute = XCHARSET_NAME (attribute);
3131 table = Fgethash (attribute, Vchar_attribute_hash_table,
3133 if (!UNBOUNDP (table))
3135 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3137 if (!UNBOUNDP (ret))
3140 return default_value;
3143 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3144 Store CHARACTER's ATTRIBUTE with VALUE.
3146 (character, attribute, value))
3148 Lisp_Object ccs = Ffind_charset (attribute);
3152 CHECK_CHAR (character);
3153 value = put_char_ccs_code_point (character, ccs, value);
3155 else if (EQ (attribute, Q_decomposition))
3157 CHECK_CHAR (character);
3159 signal_simple_error ("Invalid value for ->decomposition",
3162 if (CONSP (Fcdr (value)))
3164 if (NILP (Fcdr (Fcdr (value))))
3166 Lisp_Object base = Fcar (value);
3167 Lisp_Object modifier = Fcar (Fcdr (value));
3171 base = make_char (XINT (base));
3172 Fsetcar (value, base);
3174 if (INTP (modifier))
3176 modifier = make_char (XINT (modifier));
3177 Fsetcar (Fcdr (value), modifier);
3181 Lisp_Object alist = Fget_char_attribute (base, Qcomposition, Qnil);
3182 Lisp_Object ret = Fassq (modifier, alist);
3185 Fput_char_attribute (base, Qcomposition,
3186 Fcons (Fcons (modifier, character), alist));
3188 Fsetcdr (ret, character);
3194 Lisp_Object v = Fcar (value);
3198 Emchar c = XINT (v);
3200 = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil);
3204 Fput_char_attribute (make_char (c), Q_ucs_variants,
3205 Fcons (character, Qnil));
3207 else if (NILP (Fmemq (character, ret)))
3209 Fput_char_attribute (make_char (c), Q_ucs_variants,
3210 Fcons (character, ret));
3215 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3220 CHECK_CHAR (character);
3222 signal_simple_error ("Invalid value for ->ucs", value);
3226 ret = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil);
3229 Fput_char_attribute (make_char (c), Q_ucs_variants,
3230 Fcons (character, Qnil));
3232 else if (NILP (Fmemq (character, ret)))
3234 Fput_char_attribute (make_char (c), Q_ucs_variants,
3235 Fcons (character, ret));
3238 if (EQ (attribute, Q_ucs))
3239 attribute = Qto_ucs;
3243 Lisp_Object table = Fgethash (attribute,
3244 Vchar_attribute_hash_table,
3249 table = make_char_id_table (Qunbound);
3250 Fputhash (attribute, table, Vchar_attribute_hash_table);
3251 #ifdef HAVE_DATABASE
3252 XCHAR_TABLE_NAME (table) = attribute;
3255 put_char_id_table (XCHAR_TABLE(table), character, value);
3260 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3261 Remove CHARACTER's ATTRIBUTE.
3263 (character, attribute))
3267 CHECK_CHAR (character);
3268 ccs = Ffind_charset (attribute);
3271 return remove_char_ccs (character, ccs);
3275 Lisp_Object table = Fgethash (attribute,
3276 Vchar_attribute_hash_table,
3278 if (!UNBOUNDP (table))
3280 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3287 #ifdef HAVE_DATABASE
3289 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3292 Lisp_Object db_dir = Vexec_directory;
3295 db_dir = build_string ("../lib-src");
3297 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3298 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3299 Fmake_directory_internal (db_dir);
3301 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3302 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3303 Fmake_directory_internal (db_dir);
3306 Lisp_Object attribute_name = Fsymbol_name (attribute);
3307 Lisp_Object dest = Qnil, ret;
3309 struct gcpro gcpro1, gcpro2;
3310 int len = XSTRING_CHAR_LENGTH (attribute_name);
3314 for (i = 0; i < len; i++)
3316 Emchar c = string_char (XSTRING (attribute_name), i);
3318 if ( (c == '/') || (c == '%') )
3322 sprintf (str, "%%%02X", c);
3323 dest = concat3 (dest,
3324 Fsubstring (attribute_name,
3325 make_int (base), make_int (i)),
3326 build_string (str));
3330 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3331 dest = concat2 (dest, ret);
3333 return Fexpand_file_name (dest, db_dir);
3336 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3340 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3341 Save values of ATTRIBUTE into database file.
3345 #ifdef HAVE_DATABASE
3346 Lisp_Object table = Fgethash (attribute,
3347 Vchar_attribute_hash_table, Qunbound);
3348 Lisp_Char_Table *ct;
3349 Lisp_Object db_file;
3352 if (CHAR_TABLEP (table))
3353 ct = XCHAR_TABLE (table);
3357 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3358 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3361 if (UINT8_BYTE_TABLE_P (ct->table))
3362 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db, 0, 3);
3363 else if (UINT16_BYTE_TABLE_P (ct->table))
3364 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db, 0, 3);
3365 else if (BYTE_TABLE_P (ct->table))
3366 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3);
3367 Fclose_database (db);
3377 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3378 Mount database file on char-attribute-table ATTRIBUTE.
3382 #ifdef HAVE_DATABASE
3383 Lisp_Object table = Fgethash (attribute,
3384 Vchar_attribute_hash_table, Qunbound);
3386 if (UNBOUNDP (table))
3388 Lisp_Char_Table *ct;
3390 table = make_char_id_table (Qunbound);
3391 Fputhash (attribute, table, Vchar_attribute_hash_table);
3392 XCHAR_TABLE_NAME(table) = attribute;
3393 ct = XCHAR_TABLE (table);
3394 ct->table = Qunloaded;
3395 XCHAR_TABLE_UNLOADED(table) = 1;
3403 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3404 Close database of ATTRIBUTE.
3408 #ifdef HAVE_DATABASE
3409 Lisp_Object table = Fgethash (attribute,
3410 Vchar_attribute_hash_table, Qunbound);
3411 Lisp_Char_Table *ct;
3413 if (CHAR_TABLEP (table))
3414 ct = XCHAR_TABLE (table);
3420 if (!NILP (Fdatabase_live_p (ct->db)))
3421 Fclose_database (ct->db);
3428 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3429 Reset values of ATTRIBUTE with database file.
3433 #ifdef HAVE_DATABASE
3434 Lisp_Object table = Fgethash (attribute,
3435 Vchar_attribute_hash_table, Qunbound);
3436 Lisp_Char_Table *ct;
3438 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3440 if (!NILP (Ffile_exists_p (db_file)))
3442 if (UNBOUNDP (table))
3444 table = make_char_id_table (Qunbound);
3445 Fputhash (attribute, table, Vchar_attribute_hash_table);
3446 XCHAR_TABLE_NAME(table) = attribute;
3448 ct = XCHAR_TABLE (table);
3449 ct->table = Qunloaded;
3450 if (!NILP (Fdatabase_live_p (ct->db)))
3451 Fclose_database (ct->db);
3453 XCHAR_TABLE_UNLOADED(table) = 1;
3461 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3463 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3465 if (!NILP (attribute))
3467 if (NILP (Fdatabase_live_p (cit->db)))
3470 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3472 cit->db = Fopen_database (db_file, Qnil, Qnil,
3473 build_string ("r"), Qnil);
3475 if (!NILP (cit->db))
3478 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3480 if (!UNBOUNDP (val))
3484 if (!NILP (Vchar_db_stingy_mode))
3486 Fclose_database (cit->db);
3495 Lisp_Char_Table* char_attribute_table_to_load;
3497 Lisp_Object Qload_char_attribute_table_map_function;
3499 DEFUN ("load-char-attribute-table-map-function",
3500 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3501 For internal use. Don't use it.
3505 Lisp_Object c = Fread (key);
3506 Emchar code = XCHAR (c);
3507 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3509 if (EQ (ret, Qunloaded))
3510 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3514 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3515 Load values of ATTRIBUTE into database file.
3519 Lisp_Object table = Fgethash (attribute,
3520 Vchar_attribute_hash_table,
3522 if (CHAR_TABLEP (table))
3524 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3526 if (NILP (Fdatabase_live_p (ct->db)))
3529 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3531 ct->db = Fopen_database (db_file, Qnil, Qnil,
3532 build_string ("r"), Qnil);
3536 struct gcpro gcpro1;
3538 char_attribute_table_to_load = XCHAR_TABLE (table);
3540 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3542 Fclose_database (ct->db);
3544 XCHAR_TABLE_UNLOADED(table) = 0;
3552 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3553 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3554 each key and value in the table.
3556 RANGE specifies a subrange to map over and is in the same format as
3557 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3560 (function, attribute, range))
3563 Lisp_Char_Table *ct;
3564 struct slow_map_char_table_arg slarg;
3565 struct gcpro gcpro1, gcpro2;
3566 struct chartab_range rainj;
3568 if (!NILP (ccs = Ffind_charset (attribute)))
3570 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3572 if (CHAR_TABLEP (encoding_table))
3573 ct = XCHAR_TABLE (encoding_table);
3579 Lisp_Object table = Fgethash (attribute,
3580 Vchar_attribute_hash_table,
3582 if (CHAR_TABLEP (table))
3583 ct = XCHAR_TABLE (table);
3589 decode_char_table_range (range, &rainj);
3590 #ifdef HAVE_DATABASE
3591 if (CHAR_TABLE_UNLOADED(ct))
3592 Fload_char_attribute_table (attribute);
3594 slarg.function = function;
3595 slarg.retval = Qnil;
3596 GCPRO2 (slarg.function, slarg.retval);
3597 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3600 return slarg.retval;
3603 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3604 Store character's ATTRIBUTES.
3608 Lisp_Object rest = attributes;
3609 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3610 Lisp_Object character;
3614 while (CONSP (rest))
3616 Lisp_Object cell = Fcar (rest);
3620 signal_simple_error ("Invalid argument", attributes);
3621 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3622 && ((XCHARSET_FINAL (ccs) != 0) ||
3623 (XCHARSET_MAX_CODE (ccs) > 0) ||
3624 (EQ (ccs, Vcharset_chinese_big5))) )
3628 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3630 character = Fdecode_char (ccs, cell, Qnil);
3631 if (!NILP (character))
3632 goto setup_attributes;
3636 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3637 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3641 signal_simple_error ("Invalid argument", attributes);
3643 character = make_char (XINT (code) + 0x100000);
3644 goto setup_attributes;
3648 else if (!INTP (code))
3649 signal_simple_error ("Invalid argument", attributes);
3651 character = make_char (XINT (code));
3655 while (CONSP (rest))
3657 Lisp_Object cell = Fcar (rest);
3660 signal_simple_error ("Invalid argument", attributes);
3662 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3668 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3669 Retrieve the character of the given ATTRIBUTES.
3673 Lisp_Object rest = attributes;
3676 while (CONSP (rest))
3678 Lisp_Object cell = Fcar (rest);
3682 signal_simple_error ("Invalid argument", attributes);
3683 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3687 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3689 return Fdecode_char (ccs, cell, Qnil);
3693 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3694 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3697 signal_simple_error ("Invalid argument", attributes);
3699 return make_char (XINT (code) + 0x100000);
3707 /************************************************************************/
3708 /* Char table read syntax */
3709 /************************************************************************/
3712 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3713 Error_behavior errb)
3715 /* #### should deal with ERRB */
3716 symbol_to_char_table_type (value);
3721 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3722 Error_behavior errb)
3726 /* #### should deal with ERRB */
3727 EXTERNAL_LIST_LOOP (rest, value)
3729 Lisp_Object range = XCAR (rest);
3730 struct chartab_range dummy;
3734 signal_simple_error ("Invalid list format", value);
3737 if (!CONSP (XCDR (range))
3738 || !NILP (XCDR (XCDR (range))))
3739 signal_simple_error ("Invalid range format", range);
3740 decode_char_table_range (XCAR (range), &dummy);
3741 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3744 decode_char_table_range (range, &dummy);
3751 chartab_instantiate (Lisp_Object data)
3753 Lisp_Object chartab;
3754 Lisp_Object type = Qgeneric;
3755 Lisp_Object dataval = Qnil;
3757 while (!NILP (data))
3759 Lisp_Object keyw = Fcar (data);
3765 if (EQ (keyw, Qtype))
3767 else if (EQ (keyw, Qdata))
3771 chartab = Fmake_char_table (type);
3774 while (!NILP (data))
3776 Lisp_Object range = Fcar (data);
3777 Lisp_Object val = Fcar (Fcdr (data));
3779 data = Fcdr (Fcdr (data));
3782 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3784 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3785 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3788 for (i = first; i <= last; i++)
3789 Fput_char_table (make_char (i), val, chartab);
3795 Fput_char_table (range, val, chartab);
3804 /************************************************************************/
3805 /* Category Tables, specifically */
3806 /************************************************************************/
3808 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3809 Return t if OBJECT is a category table.
3810 A category table is a type of char table used for keeping track of
3811 categories. Categories are used for classifying characters for use
3812 in regexps -- you can refer to a category rather than having to use
3813 a complicated [] expression (and category lookups are significantly
3816 There are 95 different categories available, one for each printable
3817 character (including space) in the ASCII charset. Each category
3818 is designated by one such character, called a "category designator".
3819 They are specified in a regexp using the syntax "\\cX", where X is
3820 a category designator.
3822 A category table specifies, for each character, the categories that
3823 the character is in. Note that a character can be in more than one
3824 category. More specifically, a category table maps from a character
3825 to either the value nil (meaning the character is in no categories)
3826 or a 95-element bit vector, specifying for each of the 95 categories
3827 whether the character is in that category.
3829 Special Lisp functions are provided that abstract this, so you do not
3830 have to directly manipulate bit vectors.
3834 return (CHAR_TABLEP (object) &&
3835 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3840 check_category_table (Lisp_Object object, Lisp_Object default_)
3844 while (NILP (Fcategory_table_p (object)))
3845 object = wrong_type_argument (Qcategory_table_p, object);
3850 check_category_char (Emchar ch, Lisp_Object table,
3851 unsigned int designator, unsigned int not_p)
3853 REGISTER Lisp_Object temp;
3854 Lisp_Char_Table *ctbl;
3855 #ifdef ERROR_CHECK_TYPECHECK
3856 if (NILP (Fcategory_table_p (table)))
3857 signal_simple_error ("Expected category table", table);
3859 ctbl = XCHAR_TABLE (table);
3860 temp = get_char_table (ch, ctbl);
3865 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3868 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3869 Return t if category of the character at POSITION includes DESIGNATOR.
3870 Optional third arg BUFFER specifies which buffer to use, and defaults
3871 to the current buffer.
3872 Optional fourth arg CATEGORY-TABLE specifies the category table to
3873 use, and defaults to BUFFER's category table.
3875 (position, designator, buffer, category_table))
3880 struct buffer *buf = decode_buffer (buffer, 0);
3882 CHECK_INT (position);
3883 CHECK_CATEGORY_DESIGNATOR (designator);
3884 des = XCHAR (designator);
3885 ctbl = check_category_table (category_table, Vstandard_category_table);
3886 ch = BUF_FETCH_CHAR (buf, XINT (position));
3887 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3890 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3891 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3892 Optional third arg CATEGORY-TABLE specifies the category table to use,
3893 and defaults to the standard category table.
3895 (character, designator, category_table))
3901 CHECK_CATEGORY_DESIGNATOR (designator);
3902 des = XCHAR (designator);
3903 CHECK_CHAR (character);
3904 ch = XCHAR (character);
3905 ctbl = check_category_table (category_table, Vstandard_category_table);
3906 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3909 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3910 Return BUFFER's current category table.
3911 BUFFER defaults to the current buffer.
3915 return decode_buffer (buffer, 0)->category_table;
3918 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3919 Return the standard category table.
3920 This is the one used for new buffers.
3924 return Vstandard_category_table;
3927 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3928 Return a new category table which is a copy of CATEGORY-TABLE.
3929 CATEGORY-TABLE defaults to the standard category table.
3933 if (NILP (Vstandard_category_table))
3934 return Fmake_char_table (Qcategory);
3937 check_category_table (category_table, Vstandard_category_table);
3938 return Fcopy_char_table (category_table);
3941 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3942 Select CATEGORY-TABLE as the new category table for BUFFER.
3943 BUFFER defaults to the current buffer if omitted.
3945 (category_table, buffer))
3947 struct buffer *buf = decode_buffer (buffer, 0);
3948 category_table = check_category_table (category_table, Qnil);
3949 buf->category_table = category_table;
3950 /* Indicate that this buffer now has a specified category table. */
3951 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3952 return category_table;
3955 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3956 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3960 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3963 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3964 Return t if OBJECT is a category table value.
3965 Valid values are nil or a bit vector of size 95.
3969 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3973 #define CATEGORYP(x) \
3974 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3976 #define CATEGORY_SET(c) \
3977 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3979 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3980 The faster version of `!NILP (Faref (category_set, category))'. */
3981 #define CATEGORY_MEMBER(category, category_set) \
3982 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3984 /* Return 1 if there is a word boundary between two word-constituent
3985 characters C1 and C2 if they appear in this order, else return 0.
3986 Use the macro WORD_BOUNDARY_P instead of calling this function
3989 int word_boundary_p (Emchar c1, Emchar c2);
3991 word_boundary_p (Emchar c1, Emchar c2)
3993 Lisp_Object category_set1, category_set2;
3998 if (COMPOSITE_CHAR_P (c1))
3999 c1 = cmpchar_component (c1, 0, 1);
4000 if (COMPOSITE_CHAR_P (c2))
4001 c2 = cmpchar_component (c2, 0, 1);
4004 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4006 tail = Vword_separating_categories;
4011 tail = Vword_combining_categories;
4015 category_set1 = CATEGORY_SET (c1);
4016 if (NILP (category_set1))
4017 return default_result;
4018 category_set2 = CATEGORY_SET (c2);
4019 if (NILP (category_set2))
4020 return default_result;
4022 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4024 Lisp_Object elt = XCONS(tail)->car;
4027 && CATEGORYP (XCONS (elt)->car)
4028 && CATEGORYP (XCONS (elt)->cdr)
4029 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4030 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4031 return !default_result;
4033 return default_result;
4039 syms_of_chartab (void)
4042 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4043 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4044 INIT_LRECORD_IMPLEMENTATION (byte_table);
4046 defsymbol (&Qsystem_char_id, "system-char-id");
4048 defsymbol (&Qto_ucs, "=>ucs");
4049 defsymbol (&Q_ucs, "->ucs");
4050 defsymbol (&Q_ucs_variants, "->ucs-variants");
4051 defsymbol (&Qcomposition, "composition");
4052 defsymbol (&Q_decomposition, "->decomposition");
4053 defsymbol (&Qcompat, "compat");
4054 defsymbol (&Qisolated, "isolated");
4055 defsymbol (&Qinitial, "initial");
4056 defsymbol (&Qmedial, "medial");
4057 defsymbol (&Qfinal, "final");
4058 defsymbol (&Qvertical, "vertical");
4059 defsymbol (&QnoBreak, "noBreak");
4060 defsymbol (&Qfraction, "fraction");
4061 defsymbol (&Qsuper, "super");
4062 defsymbol (&Qsub, "sub");
4063 defsymbol (&Qcircle, "circle");
4064 defsymbol (&Qsquare, "square");
4065 defsymbol (&Qwide, "wide");
4066 defsymbol (&Qnarrow, "narrow");
4067 defsymbol (&Qsmall, "small");
4068 defsymbol (&Qfont, "font");
4070 DEFSUBR (Fchar_attribute_list);
4071 DEFSUBR (Ffind_char_attribute_table);
4072 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4073 DEFSUBR (Fput_char_table_map_function);
4074 #ifdef HAVE_DATABASE
4075 DEFSUBR (Fsave_char_attribute_table);
4076 DEFSUBR (Fmount_char_attribute_table);
4077 DEFSUBR (Freset_char_attribute_table);
4078 DEFSUBR (Fclose_char_attribute_table);
4079 defsymbol (&Qload_char_attribute_table_map_function,
4080 "load-char-attribute-table-map-function");
4081 DEFSUBR (Fload_char_attribute_table_map_function);
4082 DEFSUBR (Fload_char_attribute_table);
4084 DEFSUBR (Fchar_attribute_alist);
4085 DEFSUBR (Fget_char_attribute);
4086 DEFSUBR (Fput_char_attribute);
4087 DEFSUBR (Fremove_char_attribute);
4088 DEFSUBR (Fmap_char_attribute);
4089 DEFSUBR (Fdefine_char);
4090 DEFSUBR (Ffind_char);
4091 DEFSUBR (Fchar_variants);
4093 DEFSUBR (Fget_composite_char);
4096 INIT_LRECORD_IMPLEMENTATION (char_table);
4100 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4103 defsymbol (&Qcategory_table_p, "category-table-p");
4104 defsymbol (&Qcategory_designator_p, "category-designator-p");
4105 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4108 defsymbol (&Qchar_table, "char-table");
4109 defsymbol (&Qchar_tablep, "char-table-p");
4111 DEFSUBR (Fchar_table_p);
4112 DEFSUBR (Fchar_table_type_list);
4113 DEFSUBR (Fvalid_char_table_type_p);
4114 DEFSUBR (Fchar_table_type);
4115 DEFSUBR (Freset_char_table);
4116 DEFSUBR (Fmake_char_table);
4117 DEFSUBR (Fcopy_char_table);
4118 DEFSUBR (Fget_char_table);
4119 DEFSUBR (Fget_range_char_table);
4120 DEFSUBR (Fvalid_char_table_value_p);
4121 DEFSUBR (Fcheck_valid_char_table_value);
4122 DEFSUBR (Fput_char_table);
4123 DEFSUBR (Fmap_char_table);
4126 DEFSUBR (Fcategory_table_p);
4127 DEFSUBR (Fcategory_table);
4128 DEFSUBR (Fstandard_category_table);
4129 DEFSUBR (Fcopy_category_table);
4130 DEFSUBR (Fset_category_table);
4131 DEFSUBR (Fcheck_category_at);
4132 DEFSUBR (Fchar_in_category_p);
4133 DEFSUBR (Fcategory_designator_p);
4134 DEFSUBR (Fcategory_table_value_p);
4140 vars_of_chartab (void)
4143 #ifdef HAVE_DATABASE
4144 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4146 Vchar_db_stingy_mode = Qt;
4147 #endif /* HAVE_DATABASE */
4149 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4150 Vall_syntax_tables = Qnil;
4151 dump_add_weak_object_chain (&Vall_syntax_tables);
4155 structure_type_create_chartab (void)
4157 struct structure_type *st;
4159 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4161 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4162 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4166 complex_vars_of_chartab (void)
4169 staticpro (&Vchar_attribute_hash_table);
4170 Vchar_attribute_hash_table
4171 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4172 #endif /* UTF2000 */
4174 /* Set this now, so first buffer creation can refer to it. */
4175 /* Make it nil before calling copy-category-table
4176 so that copy-category-table will know not to try to copy from garbage */
4177 Vstandard_category_table = Qnil;
4178 Vstandard_category_table = Fcopy_category_table (Qnil);
4179 staticpro (&Vstandard_category_table);
4181 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4182 List of pair (cons) of categories to determine word boundary.
4184 Emacs treats a sequence of word constituent characters as a single
4185 word (i.e. finds no word boundary between them) iff they belongs to
4186 the same charset. But, exceptions are allowed in the following cases.
4188 \(1) The case that characters are in different charsets is controlled
4189 by the variable `word-combining-categories'.
4191 Emacs finds no word boundary between characters of different charsets
4192 if they have categories matching some element of this list.
4194 More precisely, if an element of this list is a cons of category CAT1
4195 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4196 C2 which has CAT2, there's no word boundary between C1 and C2.
4198 For instance, to tell that ASCII characters and Latin-1 characters can
4199 form a single word, the element `(?l . ?l)' should be in this list
4200 because both characters have the category `l' (Latin characters).
4202 \(2) The case that character are in the same charset is controlled by
4203 the variable `word-separating-categories'.
4205 Emacs find a word boundary between characters of the same charset
4206 if they have categories matching some element of this list.
4208 More precisely, if an element of this list is a cons of category CAT1
4209 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4210 C2 which has CAT2, there's a word boundary between C1 and C2.
4212 For instance, to tell that there's a word boundary between Japanese
4213 Hiragana and Japanese Kanji (both are in the same charset), the
4214 element `(?H . ?C) should be in this list.
4217 Vword_combining_categories = Qnil;
4219 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4220 List of pair (cons) of categories to determine word boundary.
4221 See the documentation of the variable `word-combining-categories'.
4224 Vword_separating_categories = Qnil;