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,2003 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;
67 CHISE_DS *default_chise_data_source = NULL;
72 EXFUN (Fchar_refs_simplify_char_specs, 1);
73 extern Lisp_Object Qideographic_structure;
75 EXFUN (Fmap_char_attribute, 3);
77 #if defined(HAVE_CHISE_CLIENT)
78 EXFUN (Fload_char_attribute_table, 1);
80 Lisp_Object Vchar_db_stingy_mode;
83 #define BT_UINT8_MIN 0
84 #define BT_UINT8_MAX (UCHAR_MAX - 4)
85 #define BT_UINT8_t (UCHAR_MAX - 3)
86 #define BT_UINT8_nil (UCHAR_MAX - 2)
87 #define BT_UINT8_unbound (UCHAR_MAX - 1)
88 #define BT_UINT8_unloaded UCHAR_MAX
90 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
91 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
92 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
93 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
94 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
97 INT_UINT8_P (Lisp_Object obj)
101 int num = XINT (obj);
103 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
110 UINT8_VALUE_P (Lisp_Object obj)
112 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
113 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
116 INLINE_HEADER unsigned char
117 UINT8_ENCODE (Lisp_Object obj)
119 if (EQ (obj, Qunloaded))
120 return BT_UINT8_unloaded;
121 else if (EQ (obj, Qunbound))
122 return BT_UINT8_unbound;
123 else if (EQ (obj, Qnil))
125 else if (EQ (obj, Qt))
131 INLINE_HEADER Lisp_Object
132 UINT8_DECODE (unsigned char n)
134 if (n == BT_UINT8_unloaded)
136 else if (n == BT_UINT8_unbound)
138 else if (n == BT_UINT8_nil)
140 else if (n == BT_UINT8_t)
147 mark_uint8_byte_table (Lisp_Object obj)
153 print_uint8_byte_table (Lisp_Object obj,
154 Lisp_Object printcharfun, int escapeflag)
156 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
158 struct gcpro gcpro1, gcpro2;
159 GCPRO2 (obj, printcharfun);
161 write_c_string ("\n#<uint8-byte-table", printcharfun);
162 for (i = 0; i < 256; i++)
164 unsigned char n = bte->property[i];
166 write_c_string ("\n ", printcharfun);
167 write_c_string (" ", printcharfun);
168 if (n == BT_UINT8_unbound)
169 write_c_string ("void", printcharfun);
170 else if (n == BT_UINT8_nil)
171 write_c_string ("nil", printcharfun);
172 else if (n == BT_UINT8_t)
173 write_c_string ("t", printcharfun);
178 sprintf (buf, "%hd", n);
179 write_c_string (buf, printcharfun);
183 write_c_string (">", printcharfun);
187 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
189 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
190 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
193 for (i = 0; i < 256; i++)
194 if (te1->property[i] != te2->property[i])
200 uint8_byte_table_hash (Lisp_Object obj, int depth)
202 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
206 for (i = 0; i < 256; i++)
207 hash = HASH2 (hash, te->property[i]);
211 static const struct lrecord_description uint8_byte_table_description[] = {
215 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
216 mark_uint8_byte_table,
217 print_uint8_byte_table,
218 0, uint8_byte_table_equal,
219 uint8_byte_table_hash,
220 uint8_byte_table_description,
221 Lisp_Uint8_Byte_Table);
224 make_uint8_byte_table (unsigned char initval)
228 Lisp_Uint8_Byte_Table *cte;
230 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
231 &lrecord_uint8_byte_table);
233 for (i = 0; i < 256; i++)
234 cte->property[i] = initval;
236 XSETUINT8_BYTE_TABLE (obj, cte);
241 copy_uint8_byte_table (Lisp_Object entry)
243 Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
246 Lisp_Uint8_Byte_Table *ctenew
247 = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
248 &lrecord_uint8_byte_table);
250 for (i = 0; i < 256; i++)
252 ctenew->property[i] = cte->property[i];
255 XSETUINT8_BYTE_TABLE (obj, ctenew);
260 uint8_byte_table_same_value_p (Lisp_Object obj)
262 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
263 unsigned char v0 = bte->property[0];
266 for (i = 1; i < 256; i++)
268 if (bte->property[i] != v0)
275 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
276 Emchar ofs, int place,
277 int (*fn) (struct chartab_range *range,
278 Lisp_Object val, void *arg),
281 struct chartab_range rainj;
283 int unit = 1 << (8 * place);
287 rainj.type = CHARTAB_RANGE_CHAR;
289 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
291 if (ct->property[i] == BT_UINT8_unloaded)
295 for (; c < c1 && retval == 0; c++)
297 Lisp_Object ret = get_char_id_table (root, c);
302 retval = (fn) (&rainj, ret, arg);
306 ct->property[i] = BT_UINT8_unbound;
310 else if (ct->property[i] != BT_UINT8_unbound)
313 for (; c < c1 && retval == 0; c++)
316 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
325 #ifdef HAVE_CHISE_CLIENT
327 save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
329 Emchar ofs, int place,
330 Lisp_Object (*filter)(Lisp_Object value))
332 struct chartab_range rainj;
334 int unit = 1 << (8 * place);
338 rainj.type = CHARTAB_RANGE_CHAR;
340 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
342 if (ct->property[i] == BT_UINT8_unloaded)
346 else if (ct->property[i] != BT_UINT8_unbound)
349 for (; c < c1 && retval == 0; c++)
351 Fput_database (Fprin1_to_string (make_char (c), Qnil),
352 Fprin1_to_string (UINT8_DECODE (ct->property[i]),
363 #define BT_UINT16_MIN 0
364 #define BT_UINT16_MAX (USHRT_MAX - 4)
365 #define BT_UINT16_t (USHRT_MAX - 3)
366 #define BT_UINT16_nil (USHRT_MAX - 2)
367 #define BT_UINT16_unbound (USHRT_MAX - 1)
368 #define BT_UINT16_unloaded USHRT_MAX
370 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
371 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
372 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
373 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
376 INT_UINT16_P (Lisp_Object obj)
380 int num = XINT (obj);
382 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
389 UINT16_VALUE_P (Lisp_Object obj)
391 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
392 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
395 INLINE_HEADER unsigned short
396 UINT16_ENCODE (Lisp_Object obj)
398 if (EQ (obj, Qunloaded))
399 return BT_UINT16_unloaded;
400 else if (EQ (obj, Qunbound))
401 return BT_UINT16_unbound;
402 else if (EQ (obj, Qnil))
403 return BT_UINT16_nil;
404 else if (EQ (obj, Qt))
410 INLINE_HEADER Lisp_Object
411 UINT16_DECODE (unsigned short n)
413 if (n == BT_UINT16_unloaded)
415 else if (n == BT_UINT16_unbound)
417 else if (n == BT_UINT16_nil)
419 else if (n == BT_UINT16_t)
425 INLINE_HEADER unsigned short
426 UINT8_TO_UINT16 (unsigned char n)
428 if (n == BT_UINT8_unloaded)
429 return BT_UINT16_unloaded;
430 else if (n == BT_UINT8_unbound)
431 return BT_UINT16_unbound;
432 else if (n == BT_UINT8_nil)
433 return BT_UINT16_nil;
434 else if (n == BT_UINT8_t)
441 mark_uint16_byte_table (Lisp_Object obj)
447 print_uint16_byte_table (Lisp_Object obj,
448 Lisp_Object printcharfun, int escapeflag)
450 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
452 struct gcpro gcpro1, gcpro2;
453 GCPRO2 (obj, printcharfun);
455 write_c_string ("\n#<uint16-byte-table", printcharfun);
456 for (i = 0; i < 256; i++)
458 unsigned short n = bte->property[i];
460 write_c_string ("\n ", printcharfun);
461 write_c_string (" ", printcharfun);
462 if (n == BT_UINT16_unbound)
463 write_c_string ("void", printcharfun);
464 else if (n == BT_UINT16_nil)
465 write_c_string ("nil", printcharfun);
466 else if (n == BT_UINT16_t)
467 write_c_string ("t", printcharfun);
472 sprintf (buf, "%hd", n);
473 write_c_string (buf, printcharfun);
477 write_c_string (">", printcharfun);
481 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
483 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
484 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
487 for (i = 0; i < 256; i++)
488 if (te1->property[i] != te2->property[i])
494 uint16_byte_table_hash (Lisp_Object obj, int depth)
496 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
500 for (i = 0; i < 256; i++)
501 hash = HASH2 (hash, te->property[i]);
505 static const struct lrecord_description uint16_byte_table_description[] = {
509 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
510 mark_uint16_byte_table,
511 print_uint16_byte_table,
512 0, uint16_byte_table_equal,
513 uint16_byte_table_hash,
514 uint16_byte_table_description,
515 Lisp_Uint16_Byte_Table);
518 make_uint16_byte_table (unsigned short initval)
522 Lisp_Uint16_Byte_Table *cte;
524 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
525 &lrecord_uint16_byte_table);
527 for (i = 0; i < 256; i++)
528 cte->property[i] = initval;
530 XSETUINT16_BYTE_TABLE (obj, cte);
535 copy_uint16_byte_table (Lisp_Object entry)
537 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
540 Lisp_Uint16_Byte_Table *ctenew
541 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
542 &lrecord_uint16_byte_table);
544 for (i = 0; i < 256; i++)
546 ctenew->property[i] = cte->property[i];
549 XSETUINT16_BYTE_TABLE (obj, ctenew);
554 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
558 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
559 Lisp_Uint16_Byte_Table* cte;
561 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
562 &lrecord_uint16_byte_table);
563 for (i = 0; i < 256; i++)
565 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
567 XSETUINT16_BYTE_TABLE (obj, cte);
572 uint16_byte_table_same_value_p (Lisp_Object obj)
574 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
575 unsigned short v0 = bte->property[0];
578 for (i = 1; i < 256; i++)
580 if (bte->property[i] != v0)
587 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
588 Emchar ofs, int place,
589 int (*fn) (struct chartab_range *range,
590 Lisp_Object val, void *arg),
593 struct chartab_range rainj;
595 int unit = 1 << (8 * place);
599 rainj.type = CHARTAB_RANGE_CHAR;
601 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
603 if (ct->property[i] == BT_UINT16_unloaded)
607 for (; c < c1 && retval == 0; c++)
609 Lisp_Object ret = get_char_id_table (root, c);
614 retval = (fn) (&rainj, ret, arg);
618 ct->property[i] = BT_UINT16_unbound;
622 else if (ct->property[i] != BT_UINT16_unbound)
625 for (; c < c1 && retval == 0; c++)
628 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
637 #ifdef HAVE_CHISE_CLIENT
639 save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
641 Emchar ofs, int place,
642 Lisp_Object (*filter)(Lisp_Object value))
644 struct chartab_range rainj;
646 int unit = 1 << (8 * place);
650 rainj.type = CHARTAB_RANGE_CHAR;
652 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
654 if (ct->property[i] == BT_UINT16_unloaded)
658 else if (ct->property[i] != BT_UINT16_unbound)
661 for (; c < c1 && retval == 0; c++)
663 Fput_database (Fprin1_to_string (make_char (c), Qnil),
664 Fprin1_to_string (UINT16_DECODE (ct->property[i]),
677 mark_byte_table (Lisp_Object obj)
679 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
682 for (i = 0; i < 256; i++)
684 mark_object (cte->property[i]);
690 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
692 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
694 struct gcpro gcpro1, gcpro2;
695 GCPRO2 (obj, printcharfun);
697 write_c_string ("\n#<byte-table", printcharfun);
698 for (i = 0; i < 256; i++)
700 Lisp_Object elt = bte->property[i];
702 write_c_string ("\n ", printcharfun);
703 write_c_string (" ", printcharfun);
704 if (EQ (elt, Qunbound))
705 write_c_string ("void", printcharfun);
707 print_internal (elt, printcharfun, escapeflag);
710 write_c_string (">", printcharfun);
714 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
716 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
717 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
720 for (i = 0; i < 256; i++)
721 if (BYTE_TABLE_P (cte1->property[i]))
723 if (BYTE_TABLE_P (cte2->property[i]))
725 if (!byte_table_equal (cte1->property[i],
726 cte2->property[i], depth + 1))
733 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
739 byte_table_hash (Lisp_Object obj, int depth)
741 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
743 return internal_array_hash (cte->property, 256, depth);
746 static const struct lrecord_description byte_table_description[] = {
747 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
751 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
756 byte_table_description,
760 make_byte_table (Lisp_Object initval)
764 Lisp_Byte_Table *cte;
766 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
768 for (i = 0; i < 256; i++)
769 cte->property[i] = initval;
771 XSETBYTE_TABLE (obj, cte);
776 copy_byte_table (Lisp_Object entry)
778 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
781 Lisp_Byte_Table *ctnew
782 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
784 for (i = 0; i < 256; i++)
786 if (UINT8_BYTE_TABLE_P (cte->property[i]))
788 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
790 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
792 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
794 else if (BYTE_TABLE_P (cte->property[i]))
796 ctnew->property[i] = copy_byte_table (cte->property[i]);
799 ctnew->property[i] = cte->property[i];
802 XSETBYTE_TABLE (obj, ctnew);
807 byte_table_same_value_p (Lisp_Object obj)
809 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
810 Lisp_Object v0 = bte->property[0];
813 for (i = 1; i < 256; i++)
815 if (!internal_equal (bte->property[i], v0, 0))
822 map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
823 Emchar ofs, int place,
824 int (*fn) (struct chartab_range *range,
825 Lisp_Object val, void *arg),
830 int unit = 1 << (8 * place);
833 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
836 if (UINT8_BYTE_TABLE_P (v))
839 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
840 c, place - 1, fn, arg);
843 else if (UINT16_BYTE_TABLE_P (v))
846 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
847 c, place - 1, fn, arg);
850 else if (BYTE_TABLE_P (v))
852 retval = map_over_byte_table (XBYTE_TABLE(v), root,
853 c, place - 1, fn, arg);
856 else if (EQ (v, Qunloaded))
859 struct chartab_range rainj;
860 Emchar c1 = c + unit;
862 rainj.type = CHARTAB_RANGE_CHAR;
864 for (; c < c1 && retval == 0; c++)
866 Lisp_Object ret = get_char_id_table (root, c);
871 retval = (fn) (&rainj, ret, arg);
875 ct->property[i] = Qunbound;
879 else if (!UNBOUNDP (v))
881 struct chartab_range rainj;
882 Emchar c1 = c + unit;
884 rainj.type = CHARTAB_RANGE_CHAR;
886 for (; c < c1 && retval == 0; c++)
889 retval = (fn) (&rainj, v, arg);
898 #ifdef HAVE_CHISE_CLIENT
900 save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
902 Emchar ofs, int place,
903 Lisp_Object (*filter)(Lisp_Object value))
907 int unit = 1 << (8 * place);
910 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
913 if (UINT8_BYTE_TABLE_P (v))
915 save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db,
916 c, place - 1, filter);
919 else if (UINT16_BYTE_TABLE_P (v))
921 save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db,
922 c, place - 1, filter);
925 else if (BYTE_TABLE_P (v))
927 save_byte_table (XBYTE_TABLE(v), root, db,
928 c, place - 1, filter);
931 else if (EQ (v, Qunloaded))
935 else if (!UNBOUNDP (v))
937 struct chartab_range rainj;
938 Emchar c1 = c + unit;
943 rainj.type = CHARTAB_RANGE_CHAR;
945 for (; c < c1 && retval == 0; c++)
947 Fput_database (Fprin1_to_string (make_char (c), Qnil),
948 Fprin1_to_string (v, Qnil),
959 get_byte_table (Lisp_Object table, unsigned char idx)
961 if (UINT8_BYTE_TABLE_P (table))
962 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
963 else if (UINT16_BYTE_TABLE_P (table))
964 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
965 else if (BYTE_TABLE_P (table))
966 return XBYTE_TABLE(table)->property[idx];
972 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
974 if (UINT8_BYTE_TABLE_P (table))
976 if (UINT8_VALUE_P (value))
978 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
979 if (!UINT8_BYTE_TABLE_P (value) &&
980 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
981 && uint8_byte_table_same_value_p (table))
986 else if (UINT16_VALUE_P (value))
988 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
990 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
995 Lisp_Object new = make_byte_table (Qnil);
998 for (i = 0; i < 256; i++)
1000 XBYTE_TABLE(new)->property[i]
1001 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
1003 XBYTE_TABLE(new)->property[idx] = value;
1007 else if (UINT16_BYTE_TABLE_P (table))
1009 if (UINT16_VALUE_P (value))
1011 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1012 if (!UINT8_BYTE_TABLE_P (value) &&
1013 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1014 && uint16_byte_table_same_value_p (table))
1021 Lisp_Object new = make_byte_table (Qnil);
1024 for (i = 0; i < 256; i++)
1026 XBYTE_TABLE(new)->property[i]
1027 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
1029 XBYTE_TABLE(new)->property[idx] = value;
1033 else if (BYTE_TABLE_P (table))
1035 XBYTE_TABLE(table)->property[idx] = value;
1036 if (!UINT8_BYTE_TABLE_P (value) &&
1037 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1038 && byte_table_same_value_p (table))
1043 else if (!internal_equal (table, value, 0))
1045 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
1047 table = make_uint8_byte_table (UINT8_ENCODE (table));
1048 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
1050 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
1052 table = make_uint16_byte_table (UINT16_ENCODE (table));
1053 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1057 table = make_byte_table (table);
1058 XBYTE_TABLE(table)->property[idx] = value;
1066 make_char_id_table (Lisp_Object initval)
1069 obj = Fmake_char_table (Qgeneric);
1070 fill_char_table (XCHAR_TABLE (obj), initval);
1075 Lisp_Object Qsystem_char_id;
1077 Lisp_Object Qcomposition;
1078 Lisp_Object Q_decomposition;
1079 Lisp_Object Qto_ucs;
1080 Lisp_Object Q_ucs_unified;
1081 Lisp_Object Qcompat;
1082 Lisp_Object Qisolated;
1083 Lisp_Object Qinitial;
1084 Lisp_Object Qmedial;
1086 Lisp_Object Qvertical;
1087 Lisp_Object QnoBreak;
1088 Lisp_Object Qfraction;
1091 Lisp_Object Qcircle;
1092 Lisp_Object Qsquare;
1094 Lisp_Object Qnarrow;
1098 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1101 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1107 else if (EQ (v, Qcompat))
1109 else if (EQ (v, Qisolated))
1111 else if (EQ (v, Qinitial))
1113 else if (EQ (v, Qmedial))
1115 else if (EQ (v, Qfinal))
1117 else if (EQ (v, Qvertical))
1119 else if (EQ (v, QnoBreak))
1121 else if (EQ (v, Qfraction))
1123 else if (EQ (v, Qsuper))
1125 else if (EQ (v, Qsub))
1127 else if (EQ (v, Qcircle))
1129 else if (EQ (v, Qsquare))
1131 else if (EQ (v, Qwide))
1133 else if (EQ (v, Qnarrow))
1135 else if (EQ (v, Qsmall))
1137 else if (EQ (v, Qfont))
1140 signal_simple_error (err_msg, err_arg);
1143 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1144 Return character corresponding with list.
1148 Lisp_Object base, modifier;
1152 signal_simple_error ("Invalid value for composition", list);
1155 while (!NILP (rest))
1160 signal_simple_error ("Invalid value for composition", list);
1161 modifier = Fcar (rest);
1163 base = Fcdr (Fassq (modifier,
1164 Fget_char_attribute (base, Qcomposition, Qnil)));
1169 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1170 Return variants of CHARACTER.
1176 CHECK_CHAR (character);
1177 ret = Fget_char_attribute (character, Q_ucs_unified, Qnil);
1179 return Fcopy_list (ret);
1187 /* A char table maps from ranges of characters to values.
1189 Implementing a general data structure that maps from arbitrary
1190 ranges of numbers to values is tricky to do efficiently. As it
1191 happens, it should suffice (and is usually more convenient, anyway)
1192 when dealing with characters to restrict the sorts of ranges that
1193 can be assigned values, as follows:
1196 2) All characters in a charset.
1197 3) All characters in a particular row of a charset, where a "row"
1198 means all characters with the same first byte.
1199 4) A particular character in a charset.
1201 We use char tables to generalize the 256-element vectors now
1202 littering the Emacs code.
1204 Possible uses (all should be converted at some point):
1210 5) keyboard-translate-table?
1213 abstract type to generalize the Emacs vectors and Mule
1214 vectors-of-vectors goo.
1217 /************************************************************************/
1218 /* Char Table object */
1219 /************************************************************************/
1221 #if defined(MULE)&&!defined(UTF2000)
1224 mark_char_table_entry (Lisp_Object obj)
1226 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1229 for (i = 0; i < 96; i++)
1231 mark_object (cte->level2[i]);
1237 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1239 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1240 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1243 for (i = 0; i < 96; i++)
1244 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1250 static unsigned long
1251 char_table_entry_hash (Lisp_Object obj, int depth)
1253 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1255 return internal_array_hash (cte->level2, 96, depth);
1258 static const struct lrecord_description char_table_entry_description[] = {
1259 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1263 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1264 mark_char_table_entry, internal_object_printer,
1265 0, char_table_entry_equal,
1266 char_table_entry_hash,
1267 char_table_entry_description,
1268 Lisp_Char_Table_Entry);
1272 mark_char_table (Lisp_Object obj)
1274 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1277 mark_object (ct->table);
1278 mark_object (ct->name);
1280 mark_object (ct->db);
1285 for (i = 0; i < NUM_ASCII_CHARS; i++)
1286 mark_object (ct->ascii[i]);
1288 for (i = 0; i < NUM_LEADING_BYTES; i++)
1289 mark_object (ct->level1[i]);
1293 return ct->default_value;
1295 return ct->mirror_table;
1299 /* WARNING: All functions of this nature need to be written extremely
1300 carefully to avoid crashes during GC. Cf. prune_specifiers()
1301 and prune_weak_hash_tables(). */
1304 prune_syntax_tables (void)
1306 Lisp_Object rest, prev = Qnil;
1308 for (rest = Vall_syntax_tables;
1310 rest = XCHAR_TABLE (rest)->next_table)
1312 if (! marked_p (rest))
1314 /* This table is garbage. Remove it from the list. */
1316 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1318 XCHAR_TABLE (prev)->next_table =
1319 XCHAR_TABLE (rest)->next_table;
1325 char_table_type_to_symbol (enum char_table_type type)
1330 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1331 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1332 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1333 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1335 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1340 static enum char_table_type
1341 symbol_to_char_table_type (Lisp_Object symbol)
1343 CHECK_SYMBOL (symbol);
1345 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1346 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1347 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1348 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1350 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1353 signal_simple_error ("Unrecognized char table type", symbol);
1354 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1358 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1359 Lisp_Object printcharfun)
1363 write_c_string (" (", printcharfun);
1364 print_internal (make_char (first), printcharfun, 0);
1365 write_c_string (" ", printcharfun);
1366 print_internal (make_char (last), printcharfun, 0);
1367 write_c_string (") ", printcharfun);
1371 write_c_string (" ", printcharfun);
1372 print_internal (make_char (first), printcharfun, 0);
1373 write_c_string (" ", printcharfun);
1375 print_internal (val, printcharfun, 1);
1378 #if defined(MULE)&&!defined(UTF2000)
1381 print_chartab_charset_row (Lisp_Object charset,
1383 Lisp_Char_Table_Entry *cte,
1384 Lisp_Object printcharfun)
1387 Lisp_Object cat = Qunbound;
1390 for (i = 32; i < 128; i++)
1392 Lisp_Object pam = cte->level2[i - 32];
1404 print_chartab_range (MAKE_CHAR (charset, first, 0),
1405 MAKE_CHAR (charset, i - 1, 0),
1408 print_chartab_range (MAKE_CHAR (charset, row, first),
1409 MAKE_CHAR (charset, row, i - 1),
1419 print_chartab_range (MAKE_CHAR (charset, first, 0),
1420 MAKE_CHAR (charset, i - 1, 0),
1423 print_chartab_range (MAKE_CHAR (charset, row, first),
1424 MAKE_CHAR (charset, row, i - 1),
1430 print_chartab_two_byte_charset (Lisp_Object charset,
1431 Lisp_Char_Table_Entry *cte,
1432 Lisp_Object printcharfun)
1436 for (i = 32; i < 128; i++)
1438 Lisp_Object jen = cte->level2[i - 32];
1440 if (!CHAR_TABLE_ENTRYP (jen))
1444 write_c_string (" [", printcharfun);
1445 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1446 sprintf (buf, " %d] ", i);
1447 write_c_string (buf, printcharfun);
1448 print_internal (jen, printcharfun, 0);
1451 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1459 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1461 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1464 struct gcpro gcpro1, gcpro2;
1465 GCPRO2 (obj, printcharfun);
1467 write_c_string ("#s(char-table ", printcharfun);
1468 write_c_string (" ", printcharfun);
1469 write_c_string (string_data
1471 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1473 write_c_string ("\n ", printcharfun);
1474 print_internal (ct->default_value, printcharfun, escapeflag);
1475 for (i = 0; i < 256; i++)
1477 Lisp_Object elt = get_byte_table (ct->table, i);
1478 if (i != 0) write_c_string ("\n ", printcharfun);
1479 if (EQ (elt, Qunbound))
1480 write_c_string ("void", printcharfun);
1482 print_internal (elt, printcharfun, escapeflag);
1485 #else /* non UTF2000 */
1488 sprintf (buf, "#s(char-table type %s data (",
1489 string_data (symbol_name (XSYMBOL
1490 (char_table_type_to_symbol (ct->type)))));
1491 write_c_string (buf, printcharfun);
1493 /* Now write out the ASCII/Control-1 stuff. */
1497 Lisp_Object val = Qunbound;
1499 for (i = 0; i < NUM_ASCII_CHARS; i++)
1508 if (!EQ (ct->ascii[i], val))
1510 print_chartab_range (first, i - 1, val, printcharfun);
1517 print_chartab_range (first, i - 1, val, printcharfun);
1524 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1527 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1528 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1530 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1531 || i == LEADING_BYTE_CONTROL_1)
1533 if (!CHAR_TABLE_ENTRYP (ann))
1535 write_c_string (" ", printcharfun);
1536 print_internal (XCHARSET_NAME (charset),
1538 write_c_string (" ", printcharfun);
1539 print_internal (ann, printcharfun, 0);
1543 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1544 if (XCHARSET_DIMENSION (charset) == 1)
1545 print_chartab_charset_row (charset, -1, cte, printcharfun);
1547 print_chartab_two_byte_charset (charset, cte, printcharfun);
1552 #endif /* non UTF2000 */
1554 write_c_string ("))", printcharfun);
1558 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1560 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1561 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1564 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1568 for (i = 0; i < 256; i++)
1570 if (!internal_equal (get_byte_table (ct1->table, i),
1571 get_byte_table (ct2->table, i), 0))
1575 for (i = 0; i < NUM_ASCII_CHARS; i++)
1576 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1580 for (i = 0; i < NUM_LEADING_BYTES; i++)
1581 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1584 #endif /* non UTF2000 */
1589 static unsigned long
1590 char_table_hash (Lisp_Object obj, int depth)
1592 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1594 return byte_table_hash (ct->table, depth + 1);
1596 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1599 hashval = HASH2 (hashval,
1600 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1606 static const struct lrecord_description char_table_description[] = {
1608 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1609 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1610 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1612 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1615 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1617 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1621 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1623 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1627 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1628 mark_char_table, print_char_table, 0,
1629 char_table_equal, char_table_hash,
1630 char_table_description,
1633 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1634 Return non-nil if OBJECT is a char table.
1636 A char table is a table that maps characters (or ranges of characters)
1637 to values. Char tables are specialized for characters, only allowing
1638 particular sorts of ranges to be assigned values. Although this
1639 loses in generality, it makes for extremely fast (constant-time)
1640 lookups, and thus is feasible for applications that do an extremely
1641 large number of lookups (e.g. scanning a buffer for a character in
1642 a particular syntax, where a lookup in the syntax table must occur
1643 once per character).
1645 When Mule support exists, the types of ranges that can be assigned
1649 -- an entire charset
1650 -- a single row in a two-octet charset
1651 -- a single character
1653 When Mule support is not present, the types of ranges that can be
1657 -- a single character
1659 To create a char table, use `make-char-table'.
1660 To modify a char table, use `put-char-table' or `remove-char-table'.
1661 To retrieve the value for a particular character, use `get-char-table'.
1662 See also `map-char-table', `clear-char-table', `copy-char-table',
1663 `valid-char-table-type-p', `char-table-type-list',
1664 `valid-char-table-value-p', and `check-char-table-value'.
1668 return CHAR_TABLEP (object) ? Qt : Qnil;
1671 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1672 Return a list of the recognized char table types.
1673 See `valid-char-table-type-p'.
1678 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1680 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1684 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1685 Return t if TYPE if a recognized char table type.
1687 Each char table type is used for a different purpose and allows different
1688 sorts of values. The different char table types are
1691 Used for category tables, which specify the regexp categories
1692 that a character is in. The valid values are nil or a
1693 bit vector of 95 elements. Higher-level Lisp functions are
1694 provided for working with category tables. Currently categories
1695 and category tables only exist when Mule support is present.
1697 A generalized char table, for mapping from one character to
1698 another. Used for case tables, syntax matching tables,
1699 `keyboard-translate-table', etc. The valid values are characters.
1701 An even more generalized char table, for mapping from a
1702 character to anything.
1704 Used for display tables, which specify how a particular character
1705 is to appear when displayed. #### Not yet implemented.
1707 Used for syntax tables, which specify the syntax of a particular
1708 character. Higher-level Lisp functions are provided for
1709 working with syntax tables. The valid values are integers.
1714 return (EQ (type, Qchar) ||
1716 EQ (type, Qcategory) ||
1718 EQ (type, Qdisplay) ||
1719 EQ (type, Qgeneric) ||
1720 EQ (type, Qsyntax)) ? Qt : Qnil;
1723 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1724 Return the type of CHAR-TABLE.
1725 See `valid-char-table-type-p'.
1729 CHECK_CHAR_TABLE (char_table);
1730 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1734 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1737 ct->table = Qunbound;
1738 ct->default_value = value;
1743 for (i = 0; i < NUM_ASCII_CHARS; i++)
1744 ct->ascii[i] = value;
1746 for (i = 0; i < NUM_LEADING_BYTES; i++)
1747 ct->level1[i] = value;
1752 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1753 update_syntax_table (ct);
1757 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1758 Reset CHAR-TABLE to its default state.
1762 Lisp_Char_Table *ct;
1764 CHECK_CHAR_TABLE (char_table);
1765 ct = XCHAR_TABLE (char_table);
1769 case CHAR_TABLE_TYPE_CHAR:
1770 fill_char_table (ct, make_char (0));
1772 case CHAR_TABLE_TYPE_DISPLAY:
1773 case CHAR_TABLE_TYPE_GENERIC:
1775 case CHAR_TABLE_TYPE_CATEGORY:
1777 fill_char_table (ct, Qnil);
1780 case CHAR_TABLE_TYPE_SYNTAX:
1781 fill_char_table (ct, make_int (Sinherit));
1791 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1792 Return a new, empty char table of type TYPE.
1793 Currently recognized types are 'char, 'category, 'display, 'generic,
1794 and 'syntax. See `valid-char-table-type-p'.
1798 Lisp_Char_Table *ct;
1800 enum char_table_type ty = symbol_to_char_table_type (type);
1802 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1805 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1807 ct->mirror_table = Fmake_char_table (Qgeneric);
1808 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1812 ct->mirror_table = Qnil;
1816 ct->feature_table = NULL;
1821 ct->next_table = Qnil;
1822 XSETCHAR_TABLE (obj, ct);
1823 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1825 ct->next_table = Vall_syntax_tables;
1826 Vall_syntax_tables = obj;
1828 Freset_char_table (obj);
1832 #if defined(MULE)&&!defined(UTF2000)
1835 make_char_table_entry (Lisp_Object initval)
1839 Lisp_Char_Table_Entry *cte =
1840 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1842 for (i = 0; i < 96; i++)
1843 cte->level2[i] = initval;
1845 XSETCHAR_TABLE_ENTRY (obj, cte);
1850 copy_char_table_entry (Lisp_Object entry)
1852 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1855 Lisp_Char_Table_Entry *ctenew =
1856 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1858 for (i = 0; i < 96; i++)
1860 Lisp_Object new = cte->level2[i];
1861 if (CHAR_TABLE_ENTRYP (new))
1862 ctenew->level2[i] = copy_char_table_entry (new);
1864 ctenew->level2[i] = new;
1867 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1873 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1874 Return a new char table which is a copy of CHAR-TABLE.
1875 It will contain the same values for the same characters and ranges
1876 as CHAR-TABLE. The values will not themselves be copied.
1880 Lisp_Char_Table *ct, *ctnew;
1886 CHECK_CHAR_TABLE (char_table);
1887 ct = XCHAR_TABLE (char_table);
1888 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1889 ctnew->type = ct->type;
1891 ctnew->default_value = ct->default_value;
1892 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1893 ctnew->name = ct->name;
1895 ctnew->feature_table = ct->feature_table;
1900 if (UINT8_BYTE_TABLE_P (ct->table))
1902 ctnew->table = copy_uint8_byte_table (ct->table);
1904 else if (UINT16_BYTE_TABLE_P (ct->table))
1906 ctnew->table = copy_uint16_byte_table (ct->table);
1908 else if (BYTE_TABLE_P (ct->table))
1910 ctnew->table = copy_byte_table (ct->table);
1912 else if (!UNBOUNDP (ct->table))
1913 ctnew->table = ct->table;
1914 #else /* non UTF2000 */
1916 for (i = 0; i < NUM_ASCII_CHARS; i++)
1918 Lisp_Object new = ct->ascii[i];
1920 assert (! (CHAR_TABLE_ENTRYP (new)));
1922 ctnew->ascii[i] = new;
1927 for (i = 0; i < NUM_LEADING_BYTES; i++)
1929 Lisp_Object new = ct->level1[i];
1930 if (CHAR_TABLE_ENTRYP (new))
1931 ctnew->level1[i] = copy_char_table_entry (new);
1933 ctnew->level1[i] = new;
1937 #endif /* non UTF2000 */
1940 if (CHAR_TABLEP (ct->mirror_table))
1941 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1943 ctnew->mirror_table = ct->mirror_table;
1945 ctnew->next_table = Qnil;
1946 XSETCHAR_TABLE (obj, ctnew);
1947 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1949 ctnew->next_table = Vall_syntax_tables;
1950 Vall_syntax_tables = obj;
1955 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1957 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1959 switch (XCHARSET_CHARS (ccs))
1962 return (33 << 8) | 126;
1964 return (32 << 8) | 127;
1967 return (0 << 8) | 127;
1969 return (0 << 8) | 255;
1981 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1984 outrange->type = CHARTAB_RANGE_ALL;
1986 else if (EQ (range, Qnil))
1987 outrange->type = CHARTAB_RANGE_DEFAULT;
1989 else if (CHAR_OR_CHAR_INTP (range))
1991 outrange->type = CHARTAB_RANGE_CHAR;
1992 outrange->ch = XCHAR_OR_CHAR_INT (range);
1996 signal_simple_error ("Range must be t or a character", range);
1998 else if (VECTORP (range))
2000 Lisp_Vector *vec = XVECTOR (range);
2001 Lisp_Object *elts = vector_data (vec);
2002 int cell_min, cell_max;
2004 outrange->type = CHARTAB_RANGE_ROW;
2005 outrange->charset = Fget_charset (elts[0]);
2006 CHECK_INT (elts[1]);
2007 outrange->row = XINT (elts[1]);
2008 if (XCHARSET_DIMENSION (outrange->charset) < 2)
2009 signal_simple_error ("Charset in row vector must be multi-byte",
2013 int ret = XCHARSET_CELL_RANGE (outrange->charset);
2015 cell_min = ret >> 8;
2016 cell_max = ret & 0xFF;
2018 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2019 check_int_range (outrange->row, cell_min, cell_max);
2021 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2023 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2024 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2026 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2028 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2029 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2030 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2038 if (!CHARSETP (range) && !SYMBOLP (range))
2040 ("Char table range must be t, charset, char, or vector", range);
2041 outrange->type = CHARTAB_RANGE_CHARSET;
2042 outrange->charset = Fget_charset (range);
2047 #if defined(MULE)&&!defined(UTF2000)
2049 /* called from CHAR_TABLE_VALUE(). */
2051 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2056 Lisp_Object charset;
2058 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2063 BREAKUP_CHAR (c, charset, byte1, byte2);
2065 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2067 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2068 if (CHAR_TABLE_ENTRYP (val))
2070 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2071 val = cte->level2[byte1 - 32];
2072 if (CHAR_TABLE_ENTRYP (val))
2074 cte = XCHAR_TABLE_ENTRY (val);
2075 assert (byte2 >= 32);
2076 val = cte->level2[byte2 - 32];
2077 assert (!CHAR_TABLE_ENTRYP (val));
2087 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2091 Lisp_Object ret = get_char_id_table (ct, ch);
2093 #ifdef HAVE_CHISE_CLIENT
2096 if (EQ (CHAR_TABLE_NAME (ct), Qdowncase))
2097 ret = Fget_char_attribute (make_char (ch), Q_lowercase, Qnil);
2098 else if (EQ (CHAR_TABLE_NAME (ct), Qflippedcase))
2099 ret = Fget_char_attribute (make_char (ch), Q_uppercase, Qnil);
2104 ret = Ffind_char (ret);
2112 Lisp_Object charset;
2116 BREAKUP_CHAR (ch, charset, byte1, byte2);
2118 if (EQ (charset, Vcharset_ascii))
2119 val = ct->ascii[byte1];
2120 else if (EQ (charset, Vcharset_control_1))
2121 val = ct->ascii[byte1 + 128];
2124 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2125 val = ct->level1[lb];
2126 if (CHAR_TABLE_ENTRYP (val))
2128 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2129 val = cte->level2[byte1 - 32];
2130 if (CHAR_TABLE_ENTRYP (val))
2132 cte = XCHAR_TABLE_ENTRY (val);
2133 assert (byte2 >= 32);
2134 val = cte->level2[byte2 - 32];
2135 assert (!CHAR_TABLE_ENTRYP (val));
2142 #else /* not MULE */
2143 return ct->ascii[(unsigned char)ch];
2144 #endif /* not MULE */
2148 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2149 Find value for CHARACTER in CHAR-TABLE.
2151 (character, char_table))
2153 CHECK_CHAR_TABLE (char_table);
2154 CHECK_CHAR_COERCE_INT (character);
2156 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2159 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2160 Find value for a range in CHAR-TABLE.
2161 If there is more than one value, return MULTI (defaults to nil).
2163 (range, char_table, multi))
2165 Lisp_Char_Table *ct;
2166 struct chartab_range rainj;
2168 if (CHAR_OR_CHAR_INTP (range))
2169 return Fget_char_table (range, char_table);
2170 CHECK_CHAR_TABLE (char_table);
2171 ct = XCHAR_TABLE (char_table);
2173 decode_char_table_range (range, &rainj);
2176 case CHARTAB_RANGE_ALL:
2179 if (UINT8_BYTE_TABLE_P (ct->table))
2181 else if (UINT16_BYTE_TABLE_P (ct->table))
2183 else if (BYTE_TABLE_P (ct->table))
2187 #else /* non UTF2000 */
2189 Lisp_Object first = ct->ascii[0];
2191 for (i = 1; i < NUM_ASCII_CHARS; i++)
2192 if (!EQ (first, ct->ascii[i]))
2196 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2199 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2200 || i == LEADING_BYTE_ASCII
2201 || i == LEADING_BYTE_CONTROL_1)
2203 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2209 #endif /* non UTF2000 */
2213 case CHARTAB_RANGE_CHARSET:
2217 if (EQ (rainj.charset, Vcharset_ascii))
2220 Lisp_Object first = ct->ascii[0];
2222 for (i = 1; i < 128; i++)
2223 if (!EQ (first, ct->ascii[i]))
2228 if (EQ (rainj.charset, Vcharset_control_1))
2231 Lisp_Object first = ct->ascii[128];
2233 for (i = 129; i < 160; i++)
2234 if (!EQ (first, ct->ascii[i]))
2240 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2242 if (CHAR_TABLE_ENTRYP (val))
2248 case CHARTAB_RANGE_ROW:
2253 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2255 if (!CHAR_TABLE_ENTRYP (val))
2257 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2258 if (CHAR_TABLE_ENTRYP (val))
2262 #endif /* not UTF2000 */
2263 #endif /* not MULE */
2269 return Qnil; /* not reached */
2273 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2274 Error_behavior errb)
2278 case CHAR_TABLE_TYPE_SYNTAX:
2279 if (!ERRB_EQ (errb, ERROR_ME))
2280 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2281 && CHAR_OR_CHAR_INTP (XCDR (value)));
2284 Lisp_Object cdr = XCDR (value);
2285 CHECK_INT (XCAR (value));
2286 CHECK_CHAR_COERCE_INT (cdr);
2293 case CHAR_TABLE_TYPE_CATEGORY:
2294 if (!ERRB_EQ (errb, ERROR_ME))
2295 return CATEGORY_TABLE_VALUEP (value);
2296 CHECK_CATEGORY_TABLE_VALUE (value);
2300 case CHAR_TABLE_TYPE_GENERIC:
2303 case CHAR_TABLE_TYPE_DISPLAY:
2305 maybe_signal_simple_error ("Display char tables not yet implemented",
2306 value, Qchar_table, errb);
2309 case CHAR_TABLE_TYPE_CHAR:
2310 if (!ERRB_EQ (errb, ERROR_ME))
2311 return CHAR_OR_CHAR_INTP (value);
2312 CHECK_CHAR_COERCE_INT (value);
2319 return 0; /* not reached */
2323 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2327 case CHAR_TABLE_TYPE_SYNTAX:
2330 Lisp_Object car = XCAR (value);
2331 Lisp_Object cdr = XCDR (value);
2332 CHECK_CHAR_COERCE_INT (cdr);
2333 return Fcons (car, cdr);
2336 case CHAR_TABLE_TYPE_CHAR:
2337 CHECK_CHAR_COERCE_INT (value);
2345 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2346 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2348 (value, char_table_type))
2350 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2352 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2355 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2356 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2358 (value, char_table_type))
2360 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2362 check_valid_char_table_value (value, type, ERROR_ME);
2367 Lisp_Char_Table* char_attribute_table_to_put;
2368 Lisp_Object Qput_char_table_map_function;
2369 Lisp_Object value_to_put;
2371 DEFUN ("put-char-table-map-function",
2372 Fput_char_table_map_function, 2, 2, 0, /*
2373 For internal use. Don't use it.
2377 put_char_id_table_0 (char_attribute_table_to_put,
2378 XCHAR (c), value_to_put);
2383 /* Assign VAL to all characters in RANGE in char table CT. */
2386 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2389 switch (range->type)
2391 case CHARTAB_RANGE_ALL:
2392 /* printf ("put-char-table: range = all\n"); */
2393 fill_char_table (ct, val);
2394 return; /* avoid the duplicate call to update_syntax_table() below,
2395 since fill_char_table() also did that. */
2398 case CHARTAB_RANGE_DEFAULT:
2399 ct->default_value = val;
2404 case CHARTAB_RANGE_CHARSET:
2407 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2409 /* printf ("put-char-table: range = charset: %d\n",
2410 XCHARSET_LEADING_BYTE (range->charset));
2412 if ( CHAR_TABLEP (encoding_table) )
2414 Lisp_Object mother = XCHARSET_MOTHER (range->charset);
2416 char_attribute_table_to_put = ct;
2418 Fmap_char_attribute (Qput_char_table_map_function,
2419 XCHAR_TABLE_NAME (encoding_table),
2421 if ( CHARSETP (mother) )
2423 struct chartab_range r;
2425 r.type = CHARTAB_RANGE_CHARSET;
2427 put_char_table (ct, &r, val);
2435 for (c = 0; c < 1 << 24; c++)
2437 if ( charset_code_point (range->charset, c) >= 0 )
2438 put_char_id_table_0 (ct, c, val);
2444 if (EQ (range->charset, Vcharset_ascii))
2447 for (i = 0; i < 128; i++)
2450 else if (EQ (range->charset, Vcharset_control_1))
2453 for (i = 128; i < 160; i++)
2458 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2459 ct->level1[lb] = val;
2464 case CHARTAB_RANGE_ROW:
2467 int cell_min, cell_max, i;
2469 i = XCHARSET_CELL_RANGE (range->charset);
2471 cell_max = i & 0xFF;
2472 for (i = cell_min; i <= cell_max; i++)
2474 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2476 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2477 put_char_id_table_0 (ct, ch, val);
2482 Lisp_Char_Table_Entry *cte;
2483 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2484 /* make sure that there is a separate entry for the row. */
2485 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2486 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2487 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2488 cte->level2[range->row - 32] = val;
2490 #endif /* not UTF2000 */
2494 case CHARTAB_RANGE_CHAR:
2496 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2497 put_char_id_table_0 (ct, range->ch, val);
2501 Lisp_Object charset;
2504 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2505 if (EQ (charset, Vcharset_ascii))
2506 ct->ascii[byte1] = val;
2507 else if (EQ (charset, Vcharset_control_1))
2508 ct->ascii[byte1 + 128] = val;
2511 Lisp_Char_Table_Entry *cte;
2512 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2513 /* make sure that there is a separate entry for the row. */
2514 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2515 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2516 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2517 /* now CTE is a char table entry for the charset;
2518 each entry is for a single row (or character of
2519 a one-octet charset). */
2520 if (XCHARSET_DIMENSION (charset) == 1)
2521 cte->level2[byte1 - 32] = val;
2524 /* assigning to one character in a two-octet charset. */
2525 /* make sure that the charset row contains a separate
2526 entry for each character. */
2527 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2528 cte->level2[byte1 - 32] =
2529 make_char_table_entry (cte->level2[byte1 - 32]);
2530 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2531 cte->level2[byte2 - 32] = val;
2535 #else /* not MULE */
2536 ct->ascii[(unsigned char) (range->ch)] = val;
2538 #endif /* not MULE */
2542 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2543 update_syntax_table (ct);
2547 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2548 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2550 RANGE specifies one or more characters to be affected and should be
2551 one of the following:
2553 -- t (all characters are affected)
2554 -- A charset (only allowed when Mule support is present)
2555 -- A vector of two elements: a two-octet charset and a row number
2556 (only allowed when Mule support is present)
2557 -- A single character
2559 VALUE must be a value appropriate for the type of CHAR-TABLE.
2560 See `valid-char-table-type-p'.
2562 (range, value, char_table))
2564 Lisp_Char_Table *ct;
2565 struct chartab_range rainj;
2567 CHECK_CHAR_TABLE (char_table);
2568 ct = XCHAR_TABLE (char_table);
2569 check_valid_char_table_value (value, ct->type, ERROR_ME);
2570 decode_char_table_range (range, &rainj);
2571 value = canonicalize_char_table_value (value, ct->type);
2572 put_char_table (ct, &rainj, value);
2577 /* Map FN over the ASCII chars in CT. */
2580 map_over_charset_ascii (Lisp_Char_Table *ct,
2581 int (*fn) (struct chartab_range *range,
2582 Lisp_Object val, void *arg),
2585 struct chartab_range rainj;
2594 rainj.type = CHARTAB_RANGE_CHAR;
2596 for (i = start, retval = 0; i < stop && retval == 0; i++)
2598 rainj.ch = (Emchar) i;
2599 retval = (fn) (&rainj, ct->ascii[i], arg);
2607 /* Map FN over the Control-1 chars in CT. */
2610 map_over_charset_control_1 (Lisp_Char_Table *ct,
2611 int (*fn) (struct chartab_range *range,
2612 Lisp_Object val, void *arg),
2615 struct chartab_range rainj;
2618 int stop = start + 32;
2620 rainj.type = CHARTAB_RANGE_CHAR;
2622 for (i = start, retval = 0; i < stop && retval == 0; i++)
2624 rainj.ch = (Emchar) (i);
2625 retval = (fn) (&rainj, ct->ascii[i], arg);
2631 /* Map FN over the row ROW of two-byte charset CHARSET.
2632 There must be a separate value for that row in the char table.
2633 CTE specifies the char table entry for CHARSET. */
2636 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2637 Lisp_Object charset, int row,
2638 int (*fn) (struct chartab_range *range,
2639 Lisp_Object val, void *arg),
2642 Lisp_Object val = cte->level2[row - 32];
2644 if (!CHAR_TABLE_ENTRYP (val))
2646 struct chartab_range rainj;
2648 rainj.type = CHARTAB_RANGE_ROW;
2649 rainj.charset = charset;
2651 return (fn) (&rainj, val, arg);
2655 struct chartab_range rainj;
2657 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2658 int start = charset94_p ? 33 : 32;
2659 int stop = charset94_p ? 127 : 128;
2661 cte = XCHAR_TABLE_ENTRY (val);
2663 rainj.type = CHARTAB_RANGE_CHAR;
2665 for (i = start, retval = 0; i < stop && retval == 0; i++)
2667 rainj.ch = MAKE_CHAR (charset, row, i);
2668 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2676 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2677 int (*fn) (struct chartab_range *range,
2678 Lisp_Object val, void *arg),
2681 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2682 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2684 if (!CHARSETP (charset)
2685 || lb == LEADING_BYTE_ASCII
2686 || lb == LEADING_BYTE_CONTROL_1)
2689 if (!CHAR_TABLE_ENTRYP (val))
2691 struct chartab_range rainj;
2693 rainj.type = CHARTAB_RANGE_CHARSET;
2694 rainj.charset = charset;
2695 return (fn) (&rainj, val, arg);
2699 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2700 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2701 int start = charset94_p ? 33 : 32;
2702 int stop = charset94_p ? 127 : 128;
2705 if (XCHARSET_DIMENSION (charset) == 1)
2707 struct chartab_range rainj;
2708 rainj.type = CHARTAB_RANGE_CHAR;
2710 for (i = start, retval = 0; i < stop && retval == 0; i++)
2712 rainj.ch = MAKE_CHAR (charset, i, 0);
2713 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2718 for (i = start, retval = 0; i < stop && retval == 0; i++)
2719 retval = map_over_charset_row (cte, charset, i, fn, arg);
2727 #endif /* not UTF2000 */
2730 struct map_char_table_for_charset_arg
2732 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2733 Lisp_Char_Table *ct;
2738 map_char_table_for_charset_fun (struct chartab_range *range,
2739 Lisp_Object val, void *arg)
2741 struct map_char_table_for_charset_arg *closure =
2742 (struct map_char_table_for_charset_arg *) arg;
2745 switch (range->type)
2747 case CHARTAB_RANGE_ALL:
2750 case CHARTAB_RANGE_DEFAULT:
2753 case CHARTAB_RANGE_CHARSET:
2756 case CHARTAB_RANGE_ROW:
2759 case CHARTAB_RANGE_CHAR:
2760 ret = get_char_table (range->ch, closure->ct);
2761 if (!UNBOUNDP (ret))
2762 return (closure->fn) (range, ret, closure->arg);
2774 /* Map FN (with client data ARG) over range RANGE in char table CT.
2775 Mapping stops the first time FN returns non-zero, and that value
2776 becomes the return value of map_char_table(). */
2779 map_char_table (Lisp_Char_Table *ct,
2780 struct chartab_range *range,
2781 int (*fn) (struct chartab_range *range,
2782 Lisp_Object val, void *arg),
2785 switch (range->type)
2787 case CHARTAB_RANGE_ALL:
2789 if (!UNBOUNDP (ct->default_value))
2791 struct chartab_range rainj;
2794 rainj.type = CHARTAB_RANGE_DEFAULT;
2795 retval = (fn) (&rainj, ct->default_value, arg);
2799 if (UINT8_BYTE_TABLE_P (ct->table))
2800 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2802 else if (UINT16_BYTE_TABLE_P (ct->table))
2803 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2805 else if (BYTE_TABLE_P (ct->table))
2806 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2808 else if (EQ (ct->table, Qunloaded))
2811 struct chartab_range rainj;
2814 Emchar c1 = c + unit;
2817 rainj.type = CHARTAB_RANGE_CHAR;
2819 for (retval = 0; c < c1 && retval == 0; c++)
2821 Lisp_Object ret = get_char_id_table (ct, c);
2823 if (!UNBOUNDP (ret))
2826 retval = (fn) (&rainj, ct->table, arg);
2831 ct->table = Qunbound;
2834 else if (!UNBOUNDP (ct->table))
2835 return (fn) (range, ct->table, arg);
2841 retval = map_over_charset_ascii (ct, fn, arg);
2845 retval = map_over_charset_control_1 (ct, fn, arg);
2850 Charset_ID start = MIN_LEADING_BYTE;
2851 Charset_ID stop = start + NUM_LEADING_BYTES;
2853 for (i = start, retval = 0; i < stop && retval == 0; i++)
2855 retval = map_over_other_charset (ct, i, fn, arg);
2864 case CHARTAB_RANGE_DEFAULT:
2865 if (!UNBOUNDP (ct->default_value))
2866 return (fn) (range, ct->default_value, arg);
2871 case CHARTAB_RANGE_CHARSET:
2874 Lisp_Object encoding_table
2875 = XCHARSET_ENCODING_TABLE (range->charset);
2877 if (!NILP (encoding_table))
2879 struct chartab_range rainj;
2880 struct map_char_table_for_charset_arg mcarg;
2882 #ifdef HAVE_CHISE_CLIENT
2883 if (XCHAR_TABLE_UNLOADED(encoding_table))
2884 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2889 rainj.type = CHARTAB_RANGE_ALL;
2890 return map_char_table (XCHAR_TABLE(encoding_table),
2892 &map_char_table_for_charset_fun,
2898 return map_over_other_charset (ct,
2899 XCHARSET_LEADING_BYTE (range->charset),
2903 case CHARTAB_RANGE_ROW:
2906 int cell_min, cell_max, i;
2908 struct chartab_range rainj;
2910 i = XCHARSET_CELL_RANGE (range->charset);
2912 cell_max = i & 0xFF;
2913 rainj.type = CHARTAB_RANGE_CHAR;
2914 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2916 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2918 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2921 = get_byte_table (get_byte_table
2925 (unsigned char)(ch >> 24)),
2926 (unsigned char) (ch >> 16)),
2927 (unsigned char) (ch >> 8)),
2928 (unsigned char) ch);
2931 val = ct->default_value;
2933 retval = (fn) (&rainj, val, arg);
2940 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2941 - MIN_LEADING_BYTE];
2942 if (!CHAR_TABLE_ENTRYP (val))
2944 struct chartab_range rainj;
2946 rainj.type = CHARTAB_RANGE_ROW;
2947 rainj.charset = range->charset;
2948 rainj.row = range->row;
2949 return (fn) (&rainj, val, arg);
2952 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2953 range->charset, range->row,
2956 #endif /* not UTF2000 */
2959 case CHARTAB_RANGE_CHAR:
2961 Emchar ch = range->ch;
2962 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2964 if (!UNBOUNDP (val))
2966 struct chartab_range rainj;
2968 rainj.type = CHARTAB_RANGE_CHAR;
2970 return (fn) (&rainj, val, arg);
2982 struct slow_map_char_table_arg
2984 Lisp_Object function;
2989 slow_map_char_table_fun (struct chartab_range *range,
2990 Lisp_Object val, void *arg)
2992 Lisp_Object ranjarg = Qnil;
2993 struct slow_map_char_table_arg *closure =
2994 (struct slow_map_char_table_arg *) arg;
2996 switch (range->type)
2998 case CHARTAB_RANGE_ALL:
3003 case CHARTAB_RANGE_DEFAULT:
3009 case CHARTAB_RANGE_CHARSET:
3010 ranjarg = XCHARSET_NAME (range->charset);
3013 case CHARTAB_RANGE_ROW:
3014 ranjarg = vector2 (XCHARSET_NAME (range->charset),
3015 make_int (range->row));
3018 case CHARTAB_RANGE_CHAR:
3019 ranjarg = make_char (range->ch);
3025 closure->retval = call2 (closure->function, ranjarg, val);
3026 return !NILP (closure->retval);
3029 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
3030 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
3031 each key and value in the table.
3033 RANGE specifies a subrange to map over and is in the same format as
3034 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3037 (function, char_table, range))
3039 Lisp_Char_Table *ct;
3040 struct slow_map_char_table_arg slarg;
3041 struct gcpro gcpro1, gcpro2;
3042 struct chartab_range rainj;
3044 CHECK_CHAR_TABLE (char_table);
3045 ct = XCHAR_TABLE (char_table);
3048 decode_char_table_range (range, &rainj);
3049 slarg.function = function;
3050 slarg.retval = Qnil;
3051 GCPRO2 (slarg.function, slarg.retval);
3052 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3055 return slarg.retval;
3059 /************************************************************************/
3060 /* Character Attributes */
3061 /************************************************************************/
3065 Lisp_Object Vchar_attribute_hash_table;
3067 /* We store the char-attributes in hash tables with the names as the
3068 key and the actual char-id-table object as the value. Occasionally
3069 we need to use them in a list format. These routines provide us
3071 struct char_attribute_list_closure
3073 Lisp_Object *char_attribute_list;
3077 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3078 void *char_attribute_list_closure)
3080 /* This function can GC */
3081 struct char_attribute_list_closure *calcl
3082 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3083 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3085 *char_attribute_list = Fcons (key, *char_attribute_list);
3089 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3090 Return the list of all existing character attributes except coded-charsets.
3094 Lisp_Object char_attribute_list = Qnil;
3095 struct gcpro gcpro1;
3096 struct char_attribute_list_closure char_attribute_list_closure;
3098 GCPRO1 (char_attribute_list);
3099 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3100 elisp_maphash (add_char_attribute_to_list_mapper,
3101 Vchar_attribute_hash_table,
3102 &char_attribute_list_closure);
3104 return char_attribute_list;
3107 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3108 Return char-id-table corresponding to ATTRIBUTE.
3112 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3116 /* We store the char-id-tables in hash tables with the attributes as
3117 the key and the actual char-id-table object as the value. Each
3118 char-id-table stores values of an attribute corresponding with
3119 characters. Occasionally we need to get attributes of a character
3120 in a association-list format. These routines provide us with
3122 struct char_attribute_alist_closure
3125 Lisp_Object *char_attribute_alist;
3129 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3130 void *char_attribute_alist_closure)
3132 /* This function can GC */
3133 struct char_attribute_alist_closure *caacl =
3134 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3136 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3137 if (!UNBOUNDP (ret))
3139 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3140 *char_attribute_alist
3141 = Fcons (Fcons (key, ret), *char_attribute_alist);
3146 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3147 Return the alist of attributes of CHARACTER.
3151 struct gcpro gcpro1;
3152 struct char_attribute_alist_closure char_attribute_alist_closure;
3153 Lisp_Object alist = Qnil;
3155 CHECK_CHAR (character);
3158 char_attribute_alist_closure.char_id = XCHAR (character);
3159 char_attribute_alist_closure.char_attribute_alist = &alist;
3160 elisp_maphash (add_char_attribute_alist_mapper,
3161 Vchar_attribute_hash_table,
3162 &char_attribute_alist_closure);
3168 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3169 Return the value of CHARACTER's ATTRIBUTE.
3170 Return DEFAULT-VALUE if the value is not exist.
3172 (character, attribute, default_value))
3176 CHECK_CHAR (character);
3178 if (CHARSETP (attribute))
3179 attribute = XCHARSET_NAME (attribute);
3181 table = Fgethash (attribute, Vchar_attribute_hash_table,
3183 if (!UNBOUNDP (table))
3185 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3187 if (!UNBOUNDP (ret))
3190 return default_value;
3193 void put_char_composition (Lisp_Object character, Lisp_Object value);
3195 put_char_composition (Lisp_Object character, Lisp_Object value)
3198 signal_simple_error ("Invalid value for ->decomposition",
3201 if (CONSP (Fcdr (value)))
3203 if (NILP (Fcdr (Fcdr (value))))
3205 Lisp_Object base = Fcar (value);
3206 Lisp_Object modifier = Fcar (Fcdr (value));
3210 base = make_char (XINT (base));
3211 Fsetcar (value, base);
3213 if (INTP (modifier))
3215 modifier = make_char (XINT (modifier));
3216 Fsetcar (Fcdr (value), modifier);
3221 = Fget_char_attribute (base, Qcomposition, Qnil);
3222 Lisp_Object ret = Fassq (modifier, alist);
3225 Fput_char_attribute (base, Qcomposition,
3226 Fcons (Fcons (modifier, character),
3229 Fsetcdr (ret, character);
3235 Lisp_Object v = Fcar (value);
3239 Emchar c = XINT (v);
3241 = Fget_char_attribute (make_char (c), Q_ucs_unified, Qnil);
3245 Fput_char_attribute (make_char (c), Q_ucs_unified,
3246 Fcons (character, Qnil));
3248 else if (NILP (Fmemq (character, ret)))
3250 Fput_char_attribute (make_char (c), Q_ucs_unified,
3251 Fcons (character, ret));
3257 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3258 Store CHARACTER's ATTRIBUTE with VALUE.
3260 (character, attribute, value))
3262 Lisp_Object ccs = Ffind_charset (attribute);
3264 CHECK_CHAR (character);
3268 value = put_char_ccs_code_point (character, ccs, value);
3269 attribute = XCHARSET_NAME (ccs);
3271 else if (EQ (attribute, Q_decomposition))
3272 put_char_composition (character, value);
3273 else if (EQ (attribute, Qto_ucs))
3279 signal_simple_error ("Invalid value for =>ucs", value);
3283 ret = Fget_char_attribute (make_char (c), Q_ucs_unified, Qnil);
3286 Fput_char_attribute (make_char (c), Q_ucs_unified,
3287 Fcons (character, Qnil));
3289 else if (NILP (Fmemq (character, ret)))
3291 Fput_char_attribute (make_char (c), Q_ucs_unified,
3292 Fcons (character, ret));
3296 else if (EQ (attribute, Qideographic_structure))
3297 value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value));
3300 Lisp_Object table = Fgethash (attribute,
3301 Vchar_attribute_hash_table,
3306 table = make_char_id_table (Qunbound);
3307 Fputhash (attribute, table, Vchar_attribute_hash_table);
3308 #ifdef HAVE_CHISE_CLIENT
3309 XCHAR_TABLE_NAME (table) = attribute;
3312 put_char_id_table (XCHAR_TABLE(table), character, value);
3317 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3318 Remove CHARACTER's ATTRIBUTE.
3320 (character, attribute))
3324 CHECK_CHAR (character);
3325 ccs = Ffind_charset (attribute);
3328 return remove_char_ccs (character, ccs);
3332 Lisp_Object table = Fgethash (attribute,
3333 Vchar_attribute_hash_table,
3335 if (!UNBOUNDP (table))
3337 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3344 #ifdef HAVE_CHISE_CLIENT
3346 int char_table_open_db_maybe (Lisp_Char_Table* cit);
3347 void char_table_close_db_maybe (Lisp_Char_Table* cit);
3348 Lisp_Object char_table_get_db (Lisp_Char_Table* cit, Emchar ch);
3351 open_chise_data_source_maybe ()
3353 if (default_chise_data_source == NULL)
3355 Lisp_Object db_dir = Vexec_directory;
3358 db_dir = build_string ("../lib-src");
3359 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3361 default_chise_data_source
3362 = chise_open_data_source (CHISE_DS_Berkeley_DB,
3363 XSTRING_DATA (db_dir));
3364 if (default_chise_data_source == NULL)
3370 DEFUN ("close-char-data-source", Fclose_char_data_source, 0, 0, 0, /*
3371 Close data-source of CHISE.
3376 int status = chise_ds_close (default_chise_data_source);
3378 default_chise_data_source = NULL;
3386 char_table_open_db_maybe (Lisp_Char_Table* cit)
3388 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3390 if (!NILP (attribute))
3395 DBTYPE real_subtype;
3397 if (cit->feature_table == NULL)
3399 if ( open_chise_data_source_maybe () )
3402 modemask = 0755; /* rwxr-xr-x */
3403 real_subtype = DB_HASH;
3404 accessmask = DB_RDONLY;
3407 = chise_ds_open_feature_table (default_chise_data_source,
3408 XSTRING_DATA (Fsymbol_name
3411 accessmask, modemask);
3412 if (cit->feature_table == NULL)
3416 if (NILP (Fdatabase_live_p (cit->db)))
3419 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3421 cit->db = Fopen_database (db_file, Qnil, Qnil,
3422 build_string ("r"), Qnil);
3434 char_table_close_db_maybe (Lisp_Char_Table* cit)
3437 if (cit->feature_table != NULL)
3439 chise_ft_close (cit->feature_table);
3440 cit->feature_table = NULL;
3443 if (!NILP (cit->db))
3445 if (!NILP (Fdatabase_live_p (cit->db)))
3446 Fclose_database (cit->db);
3453 char_table_get_db (Lisp_Char_Table* cit, Emchar ch)
3459 = chise_char_load_feature_value (ch, cit->feature_table, &value);
3463 val = Fread (make_string (chise_value_data (&value),
3464 chise_value_size (&value) ));
3469 val = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3471 if (!UNBOUNDP (val))
3480 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3483 Lisp_Object db_dir = Vexec_directory;
3486 db_dir = build_string ("../lib-src");
3488 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3489 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3490 Fmake_directory_internal (db_dir);
3492 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3493 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3494 Fmake_directory_internal (db_dir);
3497 Lisp_Object attribute_name = Fsymbol_name (attribute);
3498 Lisp_Object dest = Qnil, ret;
3500 struct gcpro gcpro1, gcpro2;
3501 int len = XSTRING_CHAR_LENGTH (attribute_name);
3505 for (i = 0; i < len; i++)
3507 Emchar c = string_char (XSTRING (attribute_name), i);
3509 if ( (c == '/') || (c == '%') )
3513 sprintf (str, "%%%02X", c);
3514 dest = concat3 (dest,
3515 Fsubstring (attribute_name,
3516 make_int (base), make_int (i)),
3517 build_string (str));
3521 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3522 dest = concat2 (dest, ret);
3524 return Fexpand_file_name (dest, db_dir);
3527 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3531 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3532 Save values of ATTRIBUTE into database file.
3536 #ifdef HAVE_CHISE_CLIENT
3537 Lisp_Object table = Fgethash (attribute,
3538 Vchar_attribute_hash_table, Qunbound);
3539 Lisp_Char_Table *ct;
3540 Lisp_Object db_file;
3543 if (CHAR_TABLEP (table))
3544 ct = XCHAR_TABLE (table);
3548 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3549 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3552 Lisp_Object (*filter)(Lisp_Object value);
3554 if (EQ (attribute, Qideographic_structure))
3555 filter = &Fchar_refs_simplify_char_specs;
3559 if (UINT8_BYTE_TABLE_P (ct->table))
3560 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db,
3562 else if (UINT16_BYTE_TABLE_P (ct->table))
3563 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db,
3565 else if (BYTE_TABLE_P (ct->table))
3566 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3, filter);
3567 Fclose_database (db);
3577 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3578 Mount database file on char-attribute-table ATTRIBUTE.
3582 #ifdef HAVE_CHISE_CLIENT
3583 Lisp_Object table = Fgethash (attribute,
3584 Vchar_attribute_hash_table, Qunbound);
3586 if (UNBOUNDP (table))
3588 Lisp_Char_Table *ct;
3590 table = make_char_id_table (Qunbound);
3591 Fputhash (attribute, table, Vchar_attribute_hash_table);
3592 XCHAR_TABLE_NAME(table) = attribute;
3593 ct = XCHAR_TABLE (table);
3594 ct->table = Qunloaded;
3595 XCHAR_TABLE_UNLOADED(table) = 1;
3597 ct->feature_table = NULL;
3607 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3608 Close database of ATTRIBUTE.
3612 #ifdef HAVE_CHISE_CLIENT
3613 Lisp_Object table = Fgethash (attribute,
3614 Vchar_attribute_hash_table, Qunbound);
3615 Lisp_Char_Table *ct;
3617 if (CHAR_TABLEP (table))
3618 ct = XCHAR_TABLE (table);
3621 char_table_close_db_maybe (ct);
3626 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3627 Reset values of ATTRIBUTE with database file.
3631 #ifdef HAVE_CHISE_CLIENT
3632 Lisp_Object table = Fgethash (attribute,
3633 Vchar_attribute_hash_table, Qunbound);
3634 Lisp_Char_Table *ct;
3636 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3638 if (!NILP (Ffile_exists_p (db_file)))
3640 if (UNBOUNDP (table))
3642 table = make_char_id_table (Qunbound);
3643 Fputhash (attribute, table, Vchar_attribute_hash_table);
3644 XCHAR_TABLE_NAME(table) = attribute;
3646 ct = XCHAR_TABLE (table);
3647 ct->table = Qunloaded;
3648 char_table_close_db_maybe (ct);
3649 XCHAR_TABLE_UNLOADED(table) = 1;
3657 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3659 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3661 if (!NILP (attribute))
3665 if (char_table_open_db_maybe (cit))
3668 val = char_table_get_db (cit, ch);
3670 if (!NILP (Vchar_db_stingy_mode))
3671 char_table_close_db_maybe (cit);
3678 Lisp_Char_Table* char_attribute_table_to_load;
3682 load_char_attribute_table_map_func (CHISE_Char_ID cid,
3683 CHISE_Feature feature,
3684 CHISE_Value *value);
3686 load_char_attribute_table_map_func (CHISE_Char_ID cid,
3687 CHISE_Feature feature,
3691 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3693 if (EQ (ret, Qunloaded))
3694 put_char_id_table_0 (char_attribute_table_to_load, code,
3695 Fread (make_string ((Bufbyte *) value->data,
3700 Lisp_Object Qload_char_attribute_table_map_function;
3702 DEFUN ("load-char-attribute-table-map-function",
3703 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3704 For internal use. Don't use it.
3708 Lisp_Object c = Fread (key);
3709 Emchar code = XCHAR (c);
3710 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3712 if (EQ (ret, Qunloaded))
3713 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3718 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3719 Load values of ATTRIBUTE into database file.
3723 Lisp_Object table = Fgethash (attribute,
3724 Vchar_attribute_hash_table,
3726 if (CHAR_TABLEP (table))
3728 Lisp_Char_Table *cit = XCHAR_TABLE (table);
3730 if (char_table_open_db_maybe (cit))
3733 char_attribute_table_to_load = XCHAR_TABLE (table);
3735 struct gcpro gcpro1;
3739 chise_char_feature_value_iterate
3740 (cit->feature_table,
3741 &load_char_attribute_table_map_func);
3743 Fmap_database (Qload_char_attribute_table_map_function, cit->db);
3747 char_table_close_db_maybe (cit);
3748 XCHAR_TABLE_UNLOADED(table) = 0;
3755 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3756 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3757 each key and value in the table.
3759 RANGE specifies a subrange to map over and is in the same format as
3760 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3763 (function, attribute, range))
3766 Lisp_Char_Table *ct;
3767 struct slow_map_char_table_arg slarg;
3768 struct gcpro gcpro1, gcpro2;
3769 struct chartab_range rainj;
3771 if (!NILP (ccs = Ffind_charset (attribute)))
3773 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3775 if (CHAR_TABLEP (encoding_table))
3776 ct = XCHAR_TABLE (encoding_table);
3782 Lisp_Object table = Fgethash (attribute,
3783 Vchar_attribute_hash_table,
3785 if (CHAR_TABLEP (table))
3786 ct = XCHAR_TABLE (table);
3792 decode_char_table_range (range, &rainj);
3793 #ifdef HAVE_CHISE_CLIENT
3794 if (CHAR_TABLE_UNLOADED(ct))
3795 Fload_char_attribute_table (attribute);
3797 slarg.function = function;
3798 slarg.retval = Qnil;
3799 GCPRO2 (slarg.function, slarg.retval);
3800 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3803 return slarg.retval;
3806 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3807 Store character's ATTRIBUTES.
3811 Lisp_Object rest = attributes;
3812 Lisp_Object code = Fcdr (Fassq (Qmap_ucs, attributes));
3813 Lisp_Object character;
3816 code = Fcdr (Fassq (Qucs, attributes));
3819 while (CONSP (rest))
3821 Lisp_Object cell = Fcar (rest);
3825 signal_simple_error ("Invalid argument", attributes);
3826 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3827 && ((XCHARSET_FINAL (ccs) != 0) ||
3828 (XCHARSET_MAX_CODE (ccs) > 0) ||
3829 (EQ (ccs, Vcharset_chinese_big5))) )
3833 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3835 character = Fdecode_char (ccs, cell, Qnil);
3836 if (!NILP (character))
3837 goto setup_attributes;
3841 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) )
3844 signal_simple_error ("Invalid argument", attributes);
3846 character = make_char (XINT (code) + 0x100000);
3847 goto setup_attributes;
3851 else if (!INTP (code))
3852 signal_simple_error ("Invalid argument", attributes);
3854 character = make_char (XINT (code));
3858 while (CONSP (rest))
3860 Lisp_Object cell = Fcar (rest);
3863 signal_simple_error ("Invalid argument", attributes);
3865 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3871 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3872 Retrieve the character of the given ATTRIBUTES.
3876 Lisp_Object rest = attributes;
3879 while (CONSP (rest))
3881 Lisp_Object cell = Fcar (rest);
3885 signal_simple_error ("Invalid argument", attributes);
3886 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3890 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3892 return Fdecode_char (ccs, cell, Qnil);
3896 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) )
3899 signal_simple_error ("Invalid argument", attributes);
3901 return make_char (XINT (code) + 0x100000);
3909 /************************************************************************/
3910 /* Char table read syntax */
3911 /************************************************************************/
3914 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3915 Error_behavior errb)
3917 /* #### should deal with ERRB */
3918 symbol_to_char_table_type (value);
3923 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3924 Error_behavior errb)
3928 /* #### should deal with ERRB */
3929 EXTERNAL_LIST_LOOP (rest, value)
3931 Lisp_Object range = XCAR (rest);
3932 struct chartab_range dummy;
3936 signal_simple_error ("Invalid list format", value);
3939 if (!CONSP (XCDR (range))
3940 || !NILP (XCDR (XCDR (range))))
3941 signal_simple_error ("Invalid range format", range);
3942 decode_char_table_range (XCAR (range), &dummy);
3943 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3946 decode_char_table_range (range, &dummy);
3953 chartab_instantiate (Lisp_Object data)
3955 Lisp_Object chartab;
3956 Lisp_Object type = Qgeneric;
3957 Lisp_Object dataval = Qnil;
3959 while (!NILP (data))
3961 Lisp_Object keyw = Fcar (data);
3967 if (EQ (keyw, Qtype))
3969 else if (EQ (keyw, Qdata))
3973 chartab = Fmake_char_table (type);
3976 while (!NILP (data))
3978 Lisp_Object range = Fcar (data);
3979 Lisp_Object val = Fcar (Fcdr (data));
3981 data = Fcdr (Fcdr (data));
3984 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3986 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3987 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3990 for (i = first; i <= last; i++)
3991 Fput_char_table (make_char (i), val, chartab);
3997 Fput_char_table (range, val, chartab);
4006 /************************************************************************/
4007 /* Category Tables, specifically */
4008 /************************************************************************/
4010 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
4011 Return t if OBJECT is a category table.
4012 A category table is a type of char table used for keeping track of
4013 categories. Categories are used for classifying characters for use
4014 in regexps -- you can refer to a category rather than having to use
4015 a complicated [] expression (and category lookups are significantly
4018 There are 95 different categories available, one for each printable
4019 character (including space) in the ASCII charset. Each category
4020 is designated by one such character, called a "category designator".
4021 They are specified in a regexp using the syntax "\\cX", where X is
4022 a category designator.
4024 A category table specifies, for each character, the categories that
4025 the character is in. Note that a character can be in more than one
4026 category. More specifically, a category table maps from a character
4027 to either the value nil (meaning the character is in no categories)
4028 or a 95-element bit vector, specifying for each of the 95 categories
4029 whether the character is in that category.
4031 Special Lisp functions are provided that abstract this, so you do not
4032 have to directly manipulate bit vectors.
4036 return (CHAR_TABLEP (object) &&
4037 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
4042 check_category_table (Lisp_Object object, Lisp_Object default_)
4046 while (NILP (Fcategory_table_p (object)))
4047 object = wrong_type_argument (Qcategory_table_p, object);
4052 check_category_char (Emchar ch, Lisp_Object table,
4053 unsigned int designator, unsigned int not_p)
4055 REGISTER Lisp_Object temp;
4056 Lisp_Char_Table *ctbl;
4057 #ifdef ERROR_CHECK_TYPECHECK
4058 if (NILP (Fcategory_table_p (table)))
4059 signal_simple_error ("Expected category table", table);
4061 ctbl = XCHAR_TABLE (table);
4062 temp = get_char_table (ch, ctbl);
4067 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
4070 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
4071 Return t if category of the character at POSITION includes DESIGNATOR.
4072 Optional third arg BUFFER specifies which buffer to use, and defaults
4073 to the current buffer.
4074 Optional fourth arg CATEGORY-TABLE specifies the category table to
4075 use, and defaults to BUFFER's category table.
4077 (position, designator, buffer, category_table))
4082 struct buffer *buf = decode_buffer (buffer, 0);
4084 CHECK_INT (position);
4085 CHECK_CATEGORY_DESIGNATOR (designator);
4086 des = XCHAR (designator);
4087 ctbl = check_category_table (category_table, Vstandard_category_table);
4088 ch = BUF_FETCH_CHAR (buf, XINT (position));
4089 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
4092 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
4093 Return t if category of CHARACTER includes DESIGNATOR, else nil.
4094 Optional third arg CATEGORY-TABLE specifies the category table to use,
4095 and defaults to the standard category table.
4097 (character, designator, category_table))
4103 CHECK_CATEGORY_DESIGNATOR (designator);
4104 des = XCHAR (designator);
4105 CHECK_CHAR (character);
4106 ch = XCHAR (character);
4107 ctbl = check_category_table (category_table, Vstandard_category_table);
4108 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
4111 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
4112 Return BUFFER's current category table.
4113 BUFFER defaults to the current buffer.
4117 return decode_buffer (buffer, 0)->category_table;
4120 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
4121 Return the standard category table.
4122 This is the one used for new buffers.
4126 return Vstandard_category_table;
4129 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
4130 Return a new category table which is a copy of CATEGORY-TABLE.
4131 CATEGORY-TABLE defaults to the standard category table.
4135 if (NILP (Vstandard_category_table))
4136 return Fmake_char_table (Qcategory);
4139 check_category_table (category_table, Vstandard_category_table);
4140 return Fcopy_char_table (category_table);
4143 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
4144 Select CATEGORY-TABLE as the new category table for BUFFER.
4145 BUFFER defaults to the current buffer if omitted.
4147 (category_table, buffer))
4149 struct buffer *buf = decode_buffer (buffer, 0);
4150 category_table = check_category_table (category_table, Qnil);
4151 buf->category_table = category_table;
4152 /* Indicate that this buffer now has a specified category table. */
4153 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
4154 return category_table;
4157 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
4158 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
4162 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
4165 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
4166 Return t if OBJECT is a category table value.
4167 Valid values are nil or a bit vector of size 95.
4171 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
4175 #define CATEGORYP(x) \
4176 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
4178 #define CATEGORY_SET(c) \
4179 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
4181 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
4182 The faster version of `!NILP (Faref (category_set, category))'. */
4183 #define CATEGORY_MEMBER(category, category_set) \
4184 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
4186 /* Return 1 if there is a word boundary between two word-constituent
4187 characters C1 and C2 if they appear in this order, else return 0.
4188 Use the macro WORD_BOUNDARY_P instead of calling this function
4191 int word_boundary_p (Emchar c1, Emchar c2);
4193 word_boundary_p (Emchar c1, Emchar c2)
4195 Lisp_Object category_set1, category_set2;
4200 if (COMPOSITE_CHAR_P (c1))
4201 c1 = cmpchar_component (c1, 0, 1);
4202 if (COMPOSITE_CHAR_P (c2))
4203 c2 = cmpchar_component (c2, 0, 1);
4207 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4210 tail = Vword_separating_categories;
4216 tail = Vword_combining_categories;
4221 category_set1 = CATEGORY_SET (c1);
4222 if (NILP (category_set1))
4223 return default_result;
4224 category_set2 = CATEGORY_SET (c2);
4225 if (NILP (category_set2))
4226 return default_result;
4228 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4230 Lisp_Object elt = XCONS(tail)->car;
4233 && CATEGORYP (XCONS (elt)->car)
4234 && CATEGORYP (XCONS (elt)->cdr)
4235 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4236 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4237 return !default_result;
4239 return default_result;
4245 syms_of_chartab (void)
4248 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4249 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4250 INIT_LRECORD_IMPLEMENTATION (byte_table);
4252 defsymbol (&Qsystem_char_id, "system-char-id");
4254 defsymbol (&Qto_ucs, "=>ucs");
4255 defsymbol (&Q_ucs_unified, "->ucs-unified");
4256 defsymbol (&Qcomposition, "composition");
4257 defsymbol (&Q_decomposition, "->decomposition");
4258 defsymbol (&Qcompat, "compat");
4259 defsymbol (&Qisolated, "isolated");
4260 defsymbol (&Qinitial, "initial");
4261 defsymbol (&Qmedial, "medial");
4262 defsymbol (&Qfinal, "final");
4263 defsymbol (&Qvertical, "vertical");
4264 defsymbol (&QnoBreak, "noBreak");
4265 defsymbol (&Qfraction, "fraction");
4266 defsymbol (&Qsuper, "super");
4267 defsymbol (&Qsub, "sub");
4268 defsymbol (&Qcircle, "circle");
4269 defsymbol (&Qsquare, "square");
4270 defsymbol (&Qwide, "wide");
4271 defsymbol (&Qnarrow, "narrow");
4272 defsymbol (&Qsmall, "small");
4273 defsymbol (&Qfont, "font");
4275 DEFSUBR (Fchar_attribute_list);
4276 DEFSUBR (Ffind_char_attribute_table);
4277 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4278 DEFSUBR (Fput_char_table_map_function);
4279 #ifdef HAVE_CHISE_CLIENT
4280 DEFSUBR (Fsave_char_attribute_table);
4281 DEFSUBR (Fmount_char_attribute_table);
4282 DEFSUBR (Freset_char_attribute_table);
4283 DEFSUBR (Fclose_char_attribute_table);
4284 DEFSUBR (Fclose_char_data_source);
4286 defsymbol (&Qload_char_attribute_table_map_function,
4287 "load-char-attribute-table-map-function");
4288 DEFSUBR (Fload_char_attribute_table_map_function);
4290 DEFSUBR (Fload_char_attribute_table);
4292 DEFSUBR (Fchar_attribute_alist);
4293 DEFSUBR (Fget_char_attribute);
4294 DEFSUBR (Fput_char_attribute);
4295 DEFSUBR (Fremove_char_attribute);
4296 DEFSUBR (Fmap_char_attribute);
4297 DEFSUBR (Fdefine_char);
4298 DEFSUBR (Ffind_char);
4299 DEFSUBR (Fchar_variants);
4301 DEFSUBR (Fget_composite_char);
4304 INIT_LRECORD_IMPLEMENTATION (char_table);
4308 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4311 defsymbol (&Qcategory_table_p, "category-table-p");
4312 defsymbol (&Qcategory_designator_p, "category-designator-p");
4313 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4316 defsymbol (&Qchar_table, "char-table");
4317 defsymbol (&Qchar_tablep, "char-table-p");
4319 DEFSUBR (Fchar_table_p);
4320 DEFSUBR (Fchar_table_type_list);
4321 DEFSUBR (Fvalid_char_table_type_p);
4322 DEFSUBR (Fchar_table_type);
4323 DEFSUBR (Freset_char_table);
4324 DEFSUBR (Fmake_char_table);
4325 DEFSUBR (Fcopy_char_table);
4326 DEFSUBR (Fget_char_table);
4327 DEFSUBR (Fget_range_char_table);
4328 DEFSUBR (Fvalid_char_table_value_p);
4329 DEFSUBR (Fcheck_valid_char_table_value);
4330 DEFSUBR (Fput_char_table);
4331 DEFSUBR (Fmap_char_table);
4334 DEFSUBR (Fcategory_table_p);
4335 DEFSUBR (Fcategory_table);
4336 DEFSUBR (Fstandard_category_table);
4337 DEFSUBR (Fcopy_category_table);
4338 DEFSUBR (Fset_category_table);
4339 DEFSUBR (Fcheck_category_at);
4340 DEFSUBR (Fchar_in_category_p);
4341 DEFSUBR (Fcategory_designator_p);
4342 DEFSUBR (Fcategory_table_value_p);
4348 vars_of_chartab (void)
4351 #ifdef HAVE_CHISE_CLIENT
4352 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4354 Vchar_db_stingy_mode = Qt;
4355 #endif /* HAVE_CHISE_CLIENT */
4357 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4358 Vall_syntax_tables = Qnil;
4359 dump_add_weak_object_chain (&Vall_syntax_tables);
4363 structure_type_create_chartab (void)
4365 struct structure_type *st;
4367 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4369 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4370 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4374 complex_vars_of_chartab (void)
4377 staticpro (&Vchar_attribute_hash_table);
4378 Vchar_attribute_hash_table
4379 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4380 #endif /* UTF2000 */
4382 /* Set this now, so first buffer creation can refer to it. */
4383 /* Make it nil before calling copy-category-table
4384 so that copy-category-table will know not to try to copy from garbage */
4385 Vstandard_category_table = Qnil;
4386 Vstandard_category_table = Fcopy_category_table (Qnil);
4387 staticpro (&Vstandard_category_table);
4389 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4390 List of pair (cons) of categories to determine word boundary.
4392 Emacs treats a sequence of word constituent characters as a single
4393 word (i.e. finds no word boundary between them) iff they belongs to
4394 the same charset. But, exceptions are allowed in the following cases.
4396 \(1) The case that characters are in different charsets is controlled
4397 by the variable `word-combining-categories'.
4399 Emacs finds no word boundary between characters of different charsets
4400 if they have categories matching some element of this list.
4402 More precisely, if an element of this list is a cons of category CAT1
4403 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4404 C2 which has CAT2, there's no word boundary between C1 and C2.
4406 For instance, to tell that ASCII characters and Latin-1 characters can
4407 form a single word, the element `(?l . ?l)' should be in this list
4408 because both characters have the category `l' (Latin characters).
4410 \(2) The case that character are in the same charset is controlled by
4411 the variable `word-separating-categories'.
4413 Emacs find a word boundary between characters of the same charset
4414 if they have categories matching some element of this list.
4416 More precisely, if an element of this list is a cons of category CAT1
4417 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4418 C2 which has CAT2, there's a word boundary between C1 and C2.
4420 For instance, to tell that there's a word boundary between Japanese
4421 Hiragana and Japanese Kanji (both are in the same charset), the
4422 element `(?H . ?C) should be in this list.
4425 Vword_combining_categories = Qnil;
4427 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4428 List of pair (cons) of categories to determine word boundary.
4429 See the documentation of the variable `word-combining-categories'.
4432 Vword_separating_categories = Qnil;