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;
68 EXFUN (Fchar_refs_simplify_char_specs, 1);
69 extern Lisp_Object Qideographic_structure;
71 EXFUN (Fmap_char_attribute, 3);
73 #if defined(HAVE_CHISE_CLIENT)
74 EXFUN (Fload_char_attribute_table, 1);
76 Lisp_Object Vchar_db_stingy_mode;
79 #define BT_UINT8_MIN 0
80 #define BT_UINT8_MAX (UCHAR_MAX - 4)
81 #define BT_UINT8_t (UCHAR_MAX - 3)
82 #define BT_UINT8_nil (UCHAR_MAX - 2)
83 #define BT_UINT8_unbound (UCHAR_MAX - 1)
84 #define BT_UINT8_unloaded UCHAR_MAX
86 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
87 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
88 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
89 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
90 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
93 INT_UINT8_P (Lisp_Object obj)
99 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
106 UINT8_VALUE_P (Lisp_Object obj)
108 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
109 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
112 INLINE_HEADER unsigned char
113 UINT8_ENCODE (Lisp_Object obj)
115 if (EQ (obj, Qunloaded))
116 return BT_UINT8_unloaded;
117 else if (EQ (obj, Qunbound))
118 return BT_UINT8_unbound;
119 else if (EQ (obj, Qnil))
121 else if (EQ (obj, Qt))
127 INLINE_HEADER Lisp_Object
128 UINT8_DECODE (unsigned char n)
130 if (n == BT_UINT8_unloaded)
132 else if (n == BT_UINT8_unbound)
134 else if (n == BT_UINT8_nil)
136 else if (n == BT_UINT8_t)
143 mark_uint8_byte_table (Lisp_Object obj)
149 print_uint8_byte_table (Lisp_Object obj,
150 Lisp_Object printcharfun, int escapeflag)
152 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
154 struct gcpro gcpro1, gcpro2;
155 GCPRO2 (obj, printcharfun);
157 write_c_string ("\n#<uint8-byte-table", printcharfun);
158 for (i = 0; i < 256; i++)
160 unsigned char n = bte->property[i];
162 write_c_string ("\n ", printcharfun);
163 write_c_string (" ", printcharfun);
164 if (n == BT_UINT8_unbound)
165 write_c_string ("void", printcharfun);
166 else if (n == BT_UINT8_nil)
167 write_c_string ("nil", printcharfun);
168 else if (n == BT_UINT8_t)
169 write_c_string ("t", printcharfun);
174 sprintf (buf, "%hd", n);
175 write_c_string (buf, printcharfun);
179 write_c_string (">", printcharfun);
183 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
185 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
186 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
189 for (i = 0; i < 256; i++)
190 if (te1->property[i] != te2->property[i])
196 uint8_byte_table_hash (Lisp_Object obj, int depth)
198 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
202 for (i = 0; i < 256; i++)
203 hash = HASH2 (hash, te->property[i]);
207 static const struct lrecord_description uint8_byte_table_description[] = {
211 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
212 mark_uint8_byte_table,
213 print_uint8_byte_table,
214 0, uint8_byte_table_equal,
215 uint8_byte_table_hash,
216 uint8_byte_table_description,
217 Lisp_Uint8_Byte_Table);
220 make_uint8_byte_table (unsigned char initval)
224 Lisp_Uint8_Byte_Table *cte;
226 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
227 &lrecord_uint8_byte_table);
229 for (i = 0; i < 256; i++)
230 cte->property[i] = initval;
232 XSETUINT8_BYTE_TABLE (obj, cte);
237 copy_uint8_byte_table (Lisp_Object entry)
239 Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
242 Lisp_Uint8_Byte_Table *ctenew
243 = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
244 &lrecord_uint8_byte_table);
246 for (i = 0; i < 256; i++)
248 ctenew->property[i] = cte->property[i];
251 XSETUINT8_BYTE_TABLE (obj, ctenew);
256 uint8_byte_table_same_value_p (Lisp_Object obj)
258 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
259 unsigned char v0 = bte->property[0];
262 for (i = 1; i < 256; i++)
264 if (bte->property[i] != v0)
271 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
272 Emchar ofs, int place,
273 int (*fn) (struct chartab_range *range,
274 Lisp_Object val, void *arg),
277 struct chartab_range rainj;
279 int unit = 1 << (8 * place);
283 rainj.type = CHARTAB_RANGE_CHAR;
285 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
287 if (ct->property[i] == BT_UINT8_unloaded)
291 for (; c < c1 && retval == 0; c++)
293 Lisp_Object ret = get_char_id_table (root, c);
298 retval = (fn) (&rainj, ret, arg);
302 ct->property[i] = BT_UINT8_unbound;
306 else if (ct->property[i] != BT_UINT8_unbound)
309 for (; c < c1 && retval == 0; c++)
312 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
321 #ifdef HAVE_CHISE_CLIENT
323 save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
325 Emchar ofs, int place,
326 Lisp_Object (*filter)(Lisp_Object value))
328 struct chartab_range rainj;
330 int unit = 1 << (8 * place);
334 rainj.type = CHARTAB_RANGE_CHAR;
336 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
338 if (ct->property[i] == BT_UINT8_unloaded)
342 else if (ct->property[i] != BT_UINT8_unbound)
345 for (; c < c1 && retval == 0; c++)
347 Fput_database (Fprin1_to_string (make_char (c), Qnil),
348 Fprin1_to_string (UINT8_DECODE (ct->property[i]),
359 #define BT_UINT16_MIN 0
360 #define BT_UINT16_MAX (USHRT_MAX - 4)
361 #define BT_UINT16_t (USHRT_MAX - 3)
362 #define BT_UINT16_nil (USHRT_MAX - 2)
363 #define BT_UINT16_unbound (USHRT_MAX - 1)
364 #define BT_UINT16_unloaded USHRT_MAX
366 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
367 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
368 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
369 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
372 INT_UINT16_P (Lisp_Object obj)
376 int num = XINT (obj);
378 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
385 UINT16_VALUE_P (Lisp_Object obj)
387 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
388 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
391 INLINE_HEADER unsigned short
392 UINT16_ENCODE (Lisp_Object obj)
394 if (EQ (obj, Qunloaded))
395 return BT_UINT16_unloaded;
396 else if (EQ (obj, Qunbound))
397 return BT_UINT16_unbound;
398 else if (EQ (obj, Qnil))
399 return BT_UINT16_nil;
400 else if (EQ (obj, Qt))
406 INLINE_HEADER Lisp_Object
407 UINT16_DECODE (unsigned short n)
409 if (n == BT_UINT16_unloaded)
411 else if (n == BT_UINT16_unbound)
413 else if (n == BT_UINT16_nil)
415 else if (n == BT_UINT16_t)
421 INLINE_HEADER unsigned short
422 UINT8_TO_UINT16 (unsigned char n)
424 if (n == BT_UINT8_unloaded)
425 return BT_UINT16_unloaded;
426 else if (n == BT_UINT8_unbound)
427 return BT_UINT16_unbound;
428 else if (n == BT_UINT8_nil)
429 return BT_UINT16_nil;
430 else if (n == BT_UINT8_t)
437 mark_uint16_byte_table (Lisp_Object obj)
443 print_uint16_byte_table (Lisp_Object obj,
444 Lisp_Object printcharfun, int escapeflag)
446 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
448 struct gcpro gcpro1, gcpro2;
449 GCPRO2 (obj, printcharfun);
451 write_c_string ("\n#<uint16-byte-table", printcharfun);
452 for (i = 0; i < 256; i++)
454 unsigned short n = bte->property[i];
456 write_c_string ("\n ", printcharfun);
457 write_c_string (" ", printcharfun);
458 if (n == BT_UINT16_unbound)
459 write_c_string ("void", printcharfun);
460 else if (n == BT_UINT16_nil)
461 write_c_string ("nil", printcharfun);
462 else if (n == BT_UINT16_t)
463 write_c_string ("t", printcharfun);
468 sprintf (buf, "%hd", n);
469 write_c_string (buf, printcharfun);
473 write_c_string (">", printcharfun);
477 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
479 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
480 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
483 for (i = 0; i < 256; i++)
484 if (te1->property[i] != te2->property[i])
490 uint16_byte_table_hash (Lisp_Object obj, int depth)
492 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
496 for (i = 0; i < 256; i++)
497 hash = HASH2 (hash, te->property[i]);
501 static const struct lrecord_description uint16_byte_table_description[] = {
505 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
506 mark_uint16_byte_table,
507 print_uint16_byte_table,
508 0, uint16_byte_table_equal,
509 uint16_byte_table_hash,
510 uint16_byte_table_description,
511 Lisp_Uint16_Byte_Table);
514 make_uint16_byte_table (unsigned short initval)
518 Lisp_Uint16_Byte_Table *cte;
520 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
521 &lrecord_uint16_byte_table);
523 for (i = 0; i < 256; i++)
524 cte->property[i] = initval;
526 XSETUINT16_BYTE_TABLE (obj, cte);
531 copy_uint16_byte_table (Lisp_Object entry)
533 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
536 Lisp_Uint16_Byte_Table *ctenew
537 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
538 &lrecord_uint16_byte_table);
540 for (i = 0; i < 256; i++)
542 ctenew->property[i] = cte->property[i];
545 XSETUINT16_BYTE_TABLE (obj, ctenew);
550 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
554 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
555 Lisp_Uint16_Byte_Table* cte;
557 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
558 &lrecord_uint16_byte_table);
559 for (i = 0; i < 256; i++)
561 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
563 XSETUINT16_BYTE_TABLE (obj, cte);
568 uint16_byte_table_same_value_p (Lisp_Object obj)
570 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
571 unsigned short v0 = bte->property[0];
574 for (i = 1; i < 256; i++)
576 if (bte->property[i] != v0)
583 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
584 Emchar ofs, int place,
585 int (*fn) (struct chartab_range *range,
586 Lisp_Object val, void *arg),
589 struct chartab_range rainj;
591 int unit = 1 << (8 * place);
595 rainj.type = CHARTAB_RANGE_CHAR;
597 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
599 if (ct->property[i] == BT_UINT16_unloaded)
603 for (; c < c1 && retval == 0; c++)
605 Lisp_Object ret = get_char_id_table (root, c);
610 retval = (fn) (&rainj, ret, arg);
614 ct->property[i] = BT_UINT16_unbound;
618 else if (ct->property[i] != BT_UINT16_unbound)
621 for (; c < c1 && retval == 0; c++)
624 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
633 #ifdef HAVE_CHISE_CLIENT
635 save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
637 Emchar ofs, int place,
638 Lisp_Object (*filter)(Lisp_Object value))
640 struct chartab_range rainj;
642 int unit = 1 << (8 * place);
646 rainj.type = CHARTAB_RANGE_CHAR;
648 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
650 if (ct->property[i] == BT_UINT16_unloaded)
654 else if (ct->property[i] != BT_UINT16_unbound)
657 for (; c < c1 && retval == 0; c++)
659 Fput_database (Fprin1_to_string (make_char (c), Qnil),
660 Fprin1_to_string (UINT16_DECODE (ct->property[i]),
673 mark_byte_table (Lisp_Object obj)
675 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
678 for (i = 0; i < 256; i++)
680 mark_object (cte->property[i]);
686 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
688 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
690 struct gcpro gcpro1, gcpro2;
691 GCPRO2 (obj, printcharfun);
693 write_c_string ("\n#<byte-table", printcharfun);
694 for (i = 0; i < 256; i++)
696 Lisp_Object elt = bte->property[i];
698 write_c_string ("\n ", printcharfun);
699 write_c_string (" ", printcharfun);
700 if (EQ (elt, Qunbound))
701 write_c_string ("void", printcharfun);
703 print_internal (elt, printcharfun, escapeflag);
706 write_c_string (">", printcharfun);
710 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
712 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
713 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
716 for (i = 0; i < 256; i++)
717 if (BYTE_TABLE_P (cte1->property[i]))
719 if (BYTE_TABLE_P (cte2->property[i]))
721 if (!byte_table_equal (cte1->property[i],
722 cte2->property[i], depth + 1))
729 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
735 byte_table_hash (Lisp_Object obj, int depth)
737 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
739 return internal_array_hash (cte->property, 256, depth);
742 static const struct lrecord_description byte_table_description[] = {
743 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
747 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
752 byte_table_description,
756 make_byte_table (Lisp_Object initval)
760 Lisp_Byte_Table *cte;
762 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
764 for (i = 0; i < 256; i++)
765 cte->property[i] = initval;
767 XSETBYTE_TABLE (obj, cte);
772 copy_byte_table (Lisp_Object entry)
774 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
777 Lisp_Byte_Table *ctnew
778 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
780 for (i = 0; i < 256; i++)
782 if (UINT8_BYTE_TABLE_P (cte->property[i]))
784 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
786 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
788 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
790 else if (BYTE_TABLE_P (cte->property[i]))
792 ctnew->property[i] = copy_byte_table (cte->property[i]);
795 ctnew->property[i] = cte->property[i];
798 XSETBYTE_TABLE (obj, ctnew);
803 byte_table_same_value_p (Lisp_Object obj)
805 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
806 Lisp_Object v0 = bte->property[0];
809 for (i = 1; i < 256; i++)
811 if (!internal_equal (bte->property[i], v0, 0))
818 map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
819 Emchar ofs, int place,
820 int (*fn) (struct chartab_range *range,
821 Lisp_Object val, void *arg),
826 int unit = 1 << (8 * place);
829 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
832 if (UINT8_BYTE_TABLE_P (v))
835 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
836 c, place - 1, fn, arg);
839 else if (UINT16_BYTE_TABLE_P (v))
842 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
843 c, place - 1, fn, arg);
846 else if (BYTE_TABLE_P (v))
848 retval = map_over_byte_table (XBYTE_TABLE(v), root,
849 c, place - 1, fn, arg);
852 else if (EQ (v, Qunloaded))
855 struct chartab_range rainj;
856 Emchar c1 = c + unit;
858 rainj.type = CHARTAB_RANGE_CHAR;
860 for (; c < c1 && retval == 0; c++)
862 Lisp_Object ret = get_char_id_table (root, c);
867 retval = (fn) (&rainj, ret, arg);
871 ct->property[i] = Qunbound;
875 else if (!UNBOUNDP (v))
877 struct chartab_range rainj;
878 Emchar c1 = c + unit;
880 rainj.type = CHARTAB_RANGE_CHAR;
882 for (; c < c1 && retval == 0; c++)
885 retval = (fn) (&rainj, v, arg);
894 #ifdef HAVE_CHISE_CLIENT
896 save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
898 Emchar ofs, int place,
899 Lisp_Object (*filter)(Lisp_Object value))
903 int unit = 1 << (8 * place);
906 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
909 if (UINT8_BYTE_TABLE_P (v))
911 save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db,
912 c, place - 1, filter);
915 else if (UINT16_BYTE_TABLE_P (v))
917 save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db,
918 c, place - 1, filter);
921 else if (BYTE_TABLE_P (v))
923 save_byte_table (XBYTE_TABLE(v), root, db,
924 c, place - 1, filter);
927 else if (EQ (v, Qunloaded))
931 else if (!UNBOUNDP (v))
933 struct chartab_range rainj;
934 Emchar c1 = c + unit;
939 rainj.type = CHARTAB_RANGE_CHAR;
941 for (; c < c1 && retval == 0; c++)
943 Fput_database (Fprin1_to_string (make_char (c), Qnil),
944 Fprin1_to_string (v, Qnil),
955 get_byte_table (Lisp_Object table, unsigned char idx)
957 if (UINT8_BYTE_TABLE_P (table))
958 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
959 else if (UINT16_BYTE_TABLE_P (table))
960 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
961 else if (BYTE_TABLE_P (table))
962 return XBYTE_TABLE(table)->property[idx];
968 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
970 if (UINT8_BYTE_TABLE_P (table))
972 if (UINT8_VALUE_P (value))
974 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
975 if (!UINT8_BYTE_TABLE_P (value) &&
976 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
977 && uint8_byte_table_same_value_p (table))
982 else if (UINT16_VALUE_P (value))
984 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
986 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
991 Lisp_Object new = make_byte_table (Qnil);
994 for (i = 0; i < 256; i++)
996 XBYTE_TABLE(new)->property[i]
997 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
999 XBYTE_TABLE(new)->property[idx] = value;
1003 else if (UINT16_BYTE_TABLE_P (table))
1005 if (UINT16_VALUE_P (value))
1007 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1008 if (!UINT8_BYTE_TABLE_P (value) &&
1009 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1010 && uint16_byte_table_same_value_p (table))
1017 Lisp_Object new = make_byte_table (Qnil);
1020 for (i = 0; i < 256; i++)
1022 XBYTE_TABLE(new)->property[i]
1023 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
1025 XBYTE_TABLE(new)->property[idx] = value;
1029 else if (BYTE_TABLE_P (table))
1031 XBYTE_TABLE(table)->property[idx] = value;
1032 if (!UINT8_BYTE_TABLE_P (value) &&
1033 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1034 && byte_table_same_value_p (table))
1039 else if (!internal_equal (table, value, 0))
1041 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
1043 table = make_uint8_byte_table (UINT8_ENCODE (table));
1044 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
1046 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
1048 table = make_uint16_byte_table (UINT16_ENCODE (table));
1049 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1053 table = make_byte_table (table);
1054 XBYTE_TABLE(table)->property[idx] = value;
1062 make_char_id_table (Lisp_Object initval)
1065 obj = Fmake_char_table (Qgeneric);
1066 fill_char_table (XCHAR_TABLE (obj), initval);
1071 Lisp_Object Qsystem_char_id;
1073 Lisp_Object Qcomposition;
1074 Lisp_Object Q_decomposition;
1075 Lisp_Object Qto_ucs;
1077 Lisp_Object Q_ucs_variants;
1078 Lisp_Object Qcompat;
1079 Lisp_Object Qisolated;
1080 Lisp_Object Qinitial;
1081 Lisp_Object Qmedial;
1083 Lisp_Object Qvertical;
1084 Lisp_Object QnoBreak;
1085 Lisp_Object Qfraction;
1088 Lisp_Object Qcircle;
1089 Lisp_Object Qsquare;
1091 Lisp_Object Qnarrow;
1095 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1098 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1104 else if (EQ (v, Qcompat))
1106 else if (EQ (v, Qisolated))
1108 else if (EQ (v, Qinitial))
1110 else if (EQ (v, Qmedial))
1112 else if (EQ (v, Qfinal))
1114 else if (EQ (v, Qvertical))
1116 else if (EQ (v, QnoBreak))
1118 else if (EQ (v, Qfraction))
1120 else if (EQ (v, Qsuper))
1122 else if (EQ (v, Qsub))
1124 else if (EQ (v, Qcircle))
1126 else if (EQ (v, Qsquare))
1128 else if (EQ (v, Qwide))
1130 else if (EQ (v, Qnarrow))
1132 else if (EQ (v, Qsmall))
1134 else if (EQ (v, Qfont))
1137 signal_simple_error (err_msg, err_arg);
1140 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1141 Return character corresponding with list.
1145 Lisp_Object base, modifier;
1149 signal_simple_error ("Invalid value for composition", list);
1152 while (!NILP (rest))
1157 signal_simple_error ("Invalid value for composition", list);
1158 modifier = Fcar (rest);
1160 base = Fcdr (Fassq (modifier,
1161 Fget_char_attribute (base, Qcomposition, Qnil)));
1166 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1167 Return variants of CHARACTER.
1173 CHECK_CHAR (character);
1174 ret = Fget_char_attribute (character, Q_ucs_variants, Qnil);
1176 return Fcopy_list (ret);
1184 /* A char table maps from ranges of characters to values.
1186 Implementing a general data structure that maps from arbitrary
1187 ranges of numbers to values is tricky to do efficiently. As it
1188 happens, it should suffice (and is usually more convenient, anyway)
1189 when dealing with characters to restrict the sorts of ranges that
1190 can be assigned values, as follows:
1193 2) All characters in a charset.
1194 3) All characters in a particular row of a charset, where a "row"
1195 means all characters with the same first byte.
1196 4) A particular character in a charset.
1198 We use char tables to generalize the 256-element vectors now
1199 littering the Emacs code.
1201 Possible uses (all should be converted at some point):
1207 5) keyboard-translate-table?
1210 abstract type to generalize the Emacs vectors and Mule
1211 vectors-of-vectors goo.
1214 /************************************************************************/
1215 /* Char Table object */
1216 /************************************************************************/
1218 #if defined(MULE)&&!defined(UTF2000)
1221 mark_char_table_entry (Lisp_Object obj)
1223 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1226 for (i = 0; i < 96; i++)
1228 mark_object (cte->level2[i]);
1234 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1236 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1237 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1240 for (i = 0; i < 96; i++)
1241 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1247 static unsigned long
1248 char_table_entry_hash (Lisp_Object obj, int depth)
1250 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1252 return internal_array_hash (cte->level2, 96, depth);
1255 static const struct lrecord_description char_table_entry_description[] = {
1256 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1260 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1261 mark_char_table_entry, internal_object_printer,
1262 0, char_table_entry_equal,
1263 char_table_entry_hash,
1264 char_table_entry_description,
1265 Lisp_Char_Table_Entry);
1269 mark_char_table (Lisp_Object obj)
1271 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1274 mark_object (ct->table);
1275 mark_object (ct->name);
1276 mark_object (ct->db);
1280 for (i = 0; i < NUM_ASCII_CHARS; i++)
1281 mark_object (ct->ascii[i]);
1283 for (i = 0; i < NUM_LEADING_BYTES; i++)
1284 mark_object (ct->level1[i]);
1288 return ct->default_value;
1290 return ct->mirror_table;
1294 /* WARNING: All functions of this nature need to be written extremely
1295 carefully to avoid crashes during GC. Cf. prune_specifiers()
1296 and prune_weak_hash_tables(). */
1299 prune_syntax_tables (void)
1301 Lisp_Object rest, prev = Qnil;
1303 for (rest = Vall_syntax_tables;
1305 rest = XCHAR_TABLE (rest)->next_table)
1307 if (! marked_p (rest))
1309 /* This table is garbage. Remove it from the list. */
1311 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1313 XCHAR_TABLE (prev)->next_table =
1314 XCHAR_TABLE (rest)->next_table;
1320 char_table_type_to_symbol (enum char_table_type type)
1325 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1326 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1327 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1328 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1330 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1335 static enum char_table_type
1336 symbol_to_char_table_type (Lisp_Object symbol)
1338 CHECK_SYMBOL (symbol);
1340 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1341 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1342 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1343 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1345 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1348 signal_simple_error ("Unrecognized char table type", symbol);
1349 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1353 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1354 Lisp_Object printcharfun)
1358 write_c_string (" (", printcharfun);
1359 print_internal (make_char (first), printcharfun, 0);
1360 write_c_string (" ", printcharfun);
1361 print_internal (make_char (last), printcharfun, 0);
1362 write_c_string (") ", printcharfun);
1366 write_c_string (" ", printcharfun);
1367 print_internal (make_char (first), printcharfun, 0);
1368 write_c_string (" ", printcharfun);
1370 print_internal (val, printcharfun, 1);
1373 #if defined(MULE)&&!defined(UTF2000)
1376 print_chartab_charset_row (Lisp_Object charset,
1378 Lisp_Char_Table_Entry *cte,
1379 Lisp_Object printcharfun)
1382 Lisp_Object cat = Qunbound;
1385 for (i = 32; i < 128; i++)
1387 Lisp_Object pam = cte->level2[i - 32];
1399 print_chartab_range (MAKE_CHAR (charset, first, 0),
1400 MAKE_CHAR (charset, i - 1, 0),
1403 print_chartab_range (MAKE_CHAR (charset, row, first),
1404 MAKE_CHAR (charset, row, i - 1),
1414 print_chartab_range (MAKE_CHAR (charset, first, 0),
1415 MAKE_CHAR (charset, i - 1, 0),
1418 print_chartab_range (MAKE_CHAR (charset, row, first),
1419 MAKE_CHAR (charset, row, i - 1),
1425 print_chartab_two_byte_charset (Lisp_Object charset,
1426 Lisp_Char_Table_Entry *cte,
1427 Lisp_Object printcharfun)
1431 for (i = 32; i < 128; i++)
1433 Lisp_Object jen = cte->level2[i - 32];
1435 if (!CHAR_TABLE_ENTRYP (jen))
1439 write_c_string (" [", printcharfun);
1440 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1441 sprintf (buf, " %d] ", i);
1442 write_c_string (buf, printcharfun);
1443 print_internal (jen, printcharfun, 0);
1446 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1454 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1456 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1459 struct gcpro gcpro1, gcpro2;
1460 GCPRO2 (obj, printcharfun);
1462 write_c_string ("#s(char-table ", printcharfun);
1463 write_c_string (" ", printcharfun);
1464 write_c_string (string_data
1466 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1468 write_c_string ("\n ", printcharfun);
1469 print_internal (ct->default_value, printcharfun, escapeflag);
1470 for (i = 0; i < 256; i++)
1472 Lisp_Object elt = get_byte_table (ct->table, i);
1473 if (i != 0) write_c_string ("\n ", printcharfun);
1474 if (EQ (elt, Qunbound))
1475 write_c_string ("void", printcharfun);
1477 print_internal (elt, printcharfun, escapeflag);
1480 #else /* non UTF2000 */
1483 sprintf (buf, "#s(char-table type %s data (",
1484 string_data (symbol_name (XSYMBOL
1485 (char_table_type_to_symbol (ct->type)))));
1486 write_c_string (buf, printcharfun);
1488 /* Now write out the ASCII/Control-1 stuff. */
1492 Lisp_Object val = Qunbound;
1494 for (i = 0; i < NUM_ASCII_CHARS; i++)
1503 if (!EQ (ct->ascii[i], val))
1505 print_chartab_range (first, i - 1, val, printcharfun);
1512 print_chartab_range (first, i - 1, val, printcharfun);
1519 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1522 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1523 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1525 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1526 || i == LEADING_BYTE_CONTROL_1)
1528 if (!CHAR_TABLE_ENTRYP (ann))
1530 write_c_string (" ", printcharfun);
1531 print_internal (XCHARSET_NAME (charset),
1533 write_c_string (" ", printcharfun);
1534 print_internal (ann, printcharfun, 0);
1538 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1539 if (XCHARSET_DIMENSION (charset) == 1)
1540 print_chartab_charset_row (charset, -1, cte, printcharfun);
1542 print_chartab_two_byte_charset (charset, cte, printcharfun);
1547 #endif /* non UTF2000 */
1549 write_c_string ("))", printcharfun);
1553 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1555 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1556 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1559 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1563 for (i = 0; i < 256; i++)
1565 if (!internal_equal (get_byte_table (ct1->table, i),
1566 get_byte_table (ct2->table, i), 0))
1570 for (i = 0; i < NUM_ASCII_CHARS; i++)
1571 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1575 for (i = 0; i < NUM_LEADING_BYTES; i++)
1576 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1579 #endif /* non UTF2000 */
1584 static unsigned long
1585 char_table_hash (Lisp_Object obj, int depth)
1587 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1589 return byte_table_hash (ct->table, depth + 1);
1591 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1594 hashval = HASH2 (hashval,
1595 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1601 static const struct lrecord_description char_table_description[] = {
1603 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1604 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1605 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1606 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1608 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1610 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1614 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1616 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1620 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1621 mark_char_table, print_char_table, 0,
1622 char_table_equal, char_table_hash,
1623 char_table_description,
1626 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1627 Return non-nil if OBJECT is a char table.
1629 A char table is a table that maps characters (or ranges of characters)
1630 to values. Char tables are specialized for characters, only allowing
1631 particular sorts of ranges to be assigned values. Although this
1632 loses in generality, it makes for extremely fast (constant-time)
1633 lookups, and thus is feasible for applications that do an extremely
1634 large number of lookups (e.g. scanning a buffer for a character in
1635 a particular syntax, where a lookup in the syntax table must occur
1636 once per character).
1638 When Mule support exists, the types of ranges that can be assigned
1642 -- an entire charset
1643 -- a single row in a two-octet charset
1644 -- a single character
1646 When Mule support is not present, the types of ranges that can be
1650 -- a single character
1652 To create a char table, use `make-char-table'.
1653 To modify a char table, use `put-char-table' or `remove-char-table'.
1654 To retrieve the value for a particular character, use `get-char-table'.
1655 See also `map-char-table', `clear-char-table', `copy-char-table',
1656 `valid-char-table-type-p', `char-table-type-list',
1657 `valid-char-table-value-p', and `check-char-table-value'.
1661 return CHAR_TABLEP (object) ? Qt : Qnil;
1664 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1665 Return a list of the recognized char table types.
1666 See `valid-char-table-type-p'.
1671 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1673 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1677 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1678 Return t if TYPE if a recognized char table type.
1680 Each char table type is used for a different purpose and allows different
1681 sorts of values. The different char table types are
1684 Used for category tables, which specify the regexp categories
1685 that a character is in. The valid values are nil or a
1686 bit vector of 95 elements. Higher-level Lisp functions are
1687 provided for working with category tables. Currently categories
1688 and category tables only exist when Mule support is present.
1690 A generalized char table, for mapping from one character to
1691 another. Used for case tables, syntax matching tables,
1692 `keyboard-translate-table', etc. The valid values are characters.
1694 An even more generalized char table, for mapping from a
1695 character to anything.
1697 Used for display tables, which specify how a particular character
1698 is to appear when displayed. #### Not yet implemented.
1700 Used for syntax tables, which specify the syntax of a particular
1701 character. Higher-level Lisp functions are provided for
1702 working with syntax tables. The valid values are integers.
1707 return (EQ (type, Qchar) ||
1709 EQ (type, Qcategory) ||
1711 EQ (type, Qdisplay) ||
1712 EQ (type, Qgeneric) ||
1713 EQ (type, Qsyntax)) ? Qt : Qnil;
1716 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1717 Return the type of CHAR-TABLE.
1718 See `valid-char-table-type-p'.
1722 CHECK_CHAR_TABLE (char_table);
1723 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1727 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1730 ct->table = Qunbound;
1731 ct->default_value = value;
1736 for (i = 0; i < NUM_ASCII_CHARS; i++)
1737 ct->ascii[i] = value;
1739 for (i = 0; i < NUM_LEADING_BYTES; i++)
1740 ct->level1[i] = value;
1745 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1746 update_syntax_table (ct);
1750 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1751 Reset CHAR-TABLE to its default state.
1755 Lisp_Char_Table *ct;
1757 CHECK_CHAR_TABLE (char_table);
1758 ct = XCHAR_TABLE (char_table);
1762 case CHAR_TABLE_TYPE_CHAR:
1763 fill_char_table (ct, make_char (0));
1765 case CHAR_TABLE_TYPE_DISPLAY:
1766 case CHAR_TABLE_TYPE_GENERIC:
1768 case CHAR_TABLE_TYPE_CATEGORY:
1770 fill_char_table (ct, Qnil);
1773 case CHAR_TABLE_TYPE_SYNTAX:
1774 fill_char_table (ct, make_int (Sinherit));
1784 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1785 Return a new, empty char table of type TYPE.
1786 Currently recognized types are 'char, 'category, 'display, 'generic,
1787 and 'syntax. See `valid-char-table-type-p'.
1791 Lisp_Char_Table *ct;
1793 enum char_table_type ty = symbol_to_char_table_type (type);
1795 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1798 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1800 ct->mirror_table = Fmake_char_table (Qgeneric);
1801 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1805 ct->mirror_table = Qnil;
1810 ct->next_table = Qnil;
1811 XSETCHAR_TABLE (obj, ct);
1812 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1814 ct->next_table = Vall_syntax_tables;
1815 Vall_syntax_tables = obj;
1817 Freset_char_table (obj);
1821 #if defined(MULE)&&!defined(UTF2000)
1824 make_char_table_entry (Lisp_Object initval)
1828 Lisp_Char_Table_Entry *cte =
1829 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1831 for (i = 0; i < 96; i++)
1832 cte->level2[i] = initval;
1834 XSETCHAR_TABLE_ENTRY (obj, cte);
1839 copy_char_table_entry (Lisp_Object entry)
1841 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1844 Lisp_Char_Table_Entry *ctenew =
1845 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1847 for (i = 0; i < 96; i++)
1849 Lisp_Object new = cte->level2[i];
1850 if (CHAR_TABLE_ENTRYP (new))
1851 ctenew->level2[i] = copy_char_table_entry (new);
1853 ctenew->level2[i] = new;
1856 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1862 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1863 Return a new char table which is a copy of CHAR-TABLE.
1864 It will contain the same values for the same characters and ranges
1865 as CHAR-TABLE. The values will not themselves be copied.
1869 Lisp_Char_Table *ct, *ctnew;
1875 CHECK_CHAR_TABLE (char_table);
1876 ct = XCHAR_TABLE (char_table);
1877 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1878 ctnew->type = ct->type;
1880 ctnew->default_value = ct->default_value;
1881 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1882 ctnew->name = ct->name;
1885 if (UINT8_BYTE_TABLE_P (ct->table))
1887 ctnew->table = copy_uint8_byte_table (ct->table);
1889 else if (UINT16_BYTE_TABLE_P (ct->table))
1891 ctnew->table = copy_uint16_byte_table (ct->table);
1893 else if (BYTE_TABLE_P (ct->table))
1895 ctnew->table = copy_byte_table (ct->table);
1897 else if (!UNBOUNDP (ct->table))
1898 ctnew->table = ct->table;
1899 #else /* non UTF2000 */
1901 for (i = 0; i < NUM_ASCII_CHARS; i++)
1903 Lisp_Object new = ct->ascii[i];
1905 assert (! (CHAR_TABLE_ENTRYP (new)));
1907 ctnew->ascii[i] = new;
1912 for (i = 0; i < NUM_LEADING_BYTES; i++)
1914 Lisp_Object new = ct->level1[i];
1915 if (CHAR_TABLE_ENTRYP (new))
1916 ctnew->level1[i] = copy_char_table_entry (new);
1918 ctnew->level1[i] = new;
1922 #endif /* non UTF2000 */
1925 if (CHAR_TABLEP (ct->mirror_table))
1926 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1928 ctnew->mirror_table = ct->mirror_table;
1930 ctnew->next_table = Qnil;
1931 XSETCHAR_TABLE (obj, ctnew);
1932 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1934 ctnew->next_table = Vall_syntax_tables;
1935 Vall_syntax_tables = obj;
1940 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1942 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1944 switch (XCHARSET_CHARS (ccs))
1947 return (33 << 8) | 126;
1949 return (32 << 8) | 127;
1952 return (0 << 8) | 127;
1954 return (0 << 8) | 255;
1966 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1969 outrange->type = CHARTAB_RANGE_ALL;
1970 else if (EQ (range, Qnil))
1971 outrange->type = CHARTAB_RANGE_DEFAULT;
1972 else if (CHAR_OR_CHAR_INTP (range))
1974 outrange->type = CHARTAB_RANGE_CHAR;
1975 outrange->ch = XCHAR_OR_CHAR_INT (range);
1979 signal_simple_error ("Range must be t or a character", range);
1981 else if (VECTORP (range))
1983 Lisp_Vector *vec = XVECTOR (range);
1984 Lisp_Object *elts = vector_data (vec);
1985 int cell_min, cell_max;
1987 outrange->type = CHARTAB_RANGE_ROW;
1988 outrange->charset = Fget_charset (elts[0]);
1989 CHECK_INT (elts[1]);
1990 outrange->row = XINT (elts[1]);
1991 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1992 signal_simple_error ("Charset in row vector must be multi-byte",
1996 int ret = XCHARSET_CELL_RANGE (outrange->charset);
1998 cell_min = ret >> 8;
1999 cell_max = ret & 0xFF;
2001 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2002 check_int_range (outrange->row, cell_min, cell_max);
2004 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2006 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2007 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2009 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2011 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2012 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2013 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2021 if (!CHARSETP (range) && !SYMBOLP (range))
2023 ("Char table range must be t, charset, char, or vector", range);
2024 outrange->type = CHARTAB_RANGE_CHARSET;
2025 outrange->charset = Fget_charset (range);
2030 #if defined(MULE)&&!defined(UTF2000)
2032 /* called from CHAR_TABLE_VALUE(). */
2034 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2039 Lisp_Object charset;
2041 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2046 BREAKUP_CHAR (c, charset, byte1, byte2);
2048 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2050 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2051 if (CHAR_TABLE_ENTRYP (val))
2053 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2054 val = cte->level2[byte1 - 32];
2055 if (CHAR_TABLE_ENTRYP (val))
2057 cte = XCHAR_TABLE_ENTRY (val);
2058 assert (byte2 >= 32);
2059 val = cte->level2[byte2 - 32];
2060 assert (!CHAR_TABLE_ENTRYP (val));
2070 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2074 Lisp_Object ret = get_char_id_table (ct, ch);
2076 #ifdef HAVE_CHISE_CLIENT
2079 if (EQ (CHAR_TABLE_NAME (ct), Qdowncase))
2080 ret = Fget_char_attribute (make_char (ch), Q_lowercase, Qnil);
2081 else if (EQ (CHAR_TABLE_NAME (ct), Qflippedcase))
2082 ret = Fget_char_attribute (make_char (ch), Q_uppercase, Qnil);
2087 ret = Ffind_char (ret);
2095 Lisp_Object charset;
2099 BREAKUP_CHAR (ch, charset, byte1, byte2);
2101 if (EQ (charset, Vcharset_ascii))
2102 val = ct->ascii[byte1];
2103 else if (EQ (charset, Vcharset_control_1))
2104 val = ct->ascii[byte1 + 128];
2107 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2108 val = ct->level1[lb];
2109 if (CHAR_TABLE_ENTRYP (val))
2111 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2112 val = cte->level2[byte1 - 32];
2113 if (CHAR_TABLE_ENTRYP (val))
2115 cte = XCHAR_TABLE_ENTRY (val);
2116 assert (byte2 >= 32);
2117 val = cte->level2[byte2 - 32];
2118 assert (!CHAR_TABLE_ENTRYP (val));
2125 #else /* not MULE */
2126 return ct->ascii[(unsigned char)ch];
2127 #endif /* not MULE */
2131 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2132 Find value for CHARACTER in CHAR-TABLE.
2134 (character, char_table))
2136 CHECK_CHAR_TABLE (char_table);
2137 CHECK_CHAR_COERCE_INT (character);
2139 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2142 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2143 Find value for a range in CHAR-TABLE.
2144 If there is more than one value, return MULTI (defaults to nil).
2146 (range, char_table, multi))
2148 Lisp_Char_Table *ct;
2149 struct chartab_range rainj;
2151 if (CHAR_OR_CHAR_INTP (range))
2152 return Fget_char_table (range, char_table);
2153 CHECK_CHAR_TABLE (char_table);
2154 ct = XCHAR_TABLE (char_table);
2156 decode_char_table_range (range, &rainj);
2159 case CHARTAB_RANGE_ALL:
2162 if (UINT8_BYTE_TABLE_P (ct->table))
2164 else if (UINT16_BYTE_TABLE_P (ct->table))
2166 else if (BYTE_TABLE_P (ct->table))
2170 #else /* non UTF2000 */
2172 Lisp_Object first = ct->ascii[0];
2174 for (i = 1; i < NUM_ASCII_CHARS; i++)
2175 if (!EQ (first, ct->ascii[i]))
2179 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2182 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2183 || i == LEADING_BYTE_ASCII
2184 || i == LEADING_BYTE_CONTROL_1)
2186 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2192 #endif /* non UTF2000 */
2196 case CHARTAB_RANGE_CHARSET:
2200 if (EQ (rainj.charset, Vcharset_ascii))
2203 Lisp_Object first = ct->ascii[0];
2205 for (i = 1; i < 128; i++)
2206 if (!EQ (first, ct->ascii[i]))
2211 if (EQ (rainj.charset, Vcharset_control_1))
2214 Lisp_Object first = ct->ascii[128];
2216 for (i = 129; i < 160; i++)
2217 if (!EQ (first, ct->ascii[i]))
2223 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2225 if (CHAR_TABLE_ENTRYP (val))
2231 case CHARTAB_RANGE_ROW:
2236 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2238 if (!CHAR_TABLE_ENTRYP (val))
2240 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2241 if (CHAR_TABLE_ENTRYP (val))
2245 #endif /* not UTF2000 */
2246 #endif /* not MULE */
2252 return Qnil; /* not reached */
2256 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2257 Error_behavior errb)
2261 case CHAR_TABLE_TYPE_SYNTAX:
2262 if (!ERRB_EQ (errb, ERROR_ME))
2263 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2264 && CHAR_OR_CHAR_INTP (XCDR (value)));
2267 Lisp_Object cdr = XCDR (value);
2268 CHECK_INT (XCAR (value));
2269 CHECK_CHAR_COERCE_INT (cdr);
2276 case CHAR_TABLE_TYPE_CATEGORY:
2277 if (!ERRB_EQ (errb, ERROR_ME))
2278 return CATEGORY_TABLE_VALUEP (value);
2279 CHECK_CATEGORY_TABLE_VALUE (value);
2283 case CHAR_TABLE_TYPE_GENERIC:
2286 case CHAR_TABLE_TYPE_DISPLAY:
2288 maybe_signal_simple_error ("Display char tables not yet implemented",
2289 value, Qchar_table, errb);
2292 case CHAR_TABLE_TYPE_CHAR:
2293 if (!ERRB_EQ (errb, ERROR_ME))
2294 return CHAR_OR_CHAR_INTP (value);
2295 CHECK_CHAR_COERCE_INT (value);
2302 return 0; /* not reached */
2306 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2310 case CHAR_TABLE_TYPE_SYNTAX:
2313 Lisp_Object car = XCAR (value);
2314 Lisp_Object cdr = XCDR (value);
2315 CHECK_CHAR_COERCE_INT (cdr);
2316 return Fcons (car, cdr);
2319 case CHAR_TABLE_TYPE_CHAR:
2320 CHECK_CHAR_COERCE_INT (value);
2328 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2329 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2331 (value, char_table_type))
2333 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2335 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2338 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2339 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2341 (value, char_table_type))
2343 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2345 check_valid_char_table_value (value, type, ERROR_ME);
2350 Lisp_Char_Table* char_attribute_table_to_put;
2351 Lisp_Object Qput_char_table_map_function;
2352 Lisp_Object value_to_put;
2354 DEFUN ("put-char-table-map-function",
2355 Fput_char_table_map_function, 2, 2, 0, /*
2356 For internal use. Don't use it.
2360 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2365 /* Assign VAL to all characters in RANGE in char table CT. */
2368 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2371 switch (range->type)
2373 case CHARTAB_RANGE_ALL:
2374 /* printf ("put-char-table: range = all\n"); */
2375 fill_char_table (ct, val);
2376 return; /* avoid the duplicate call to update_syntax_table() below,
2377 since fill_char_table() also did that. */
2380 case CHARTAB_RANGE_DEFAULT:
2381 ct->default_value = val;
2386 case CHARTAB_RANGE_CHARSET:
2389 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2391 /* printf ("put-char-table: range = charset: %d\n",
2392 XCHARSET_LEADING_BYTE (range->charset));
2394 if ( CHAR_TABLEP (encoding_table) )
2396 char_attribute_table_to_put = ct;
2398 Fmap_char_attribute (Qput_char_table_map_function,
2399 XCHAR_TABLE_NAME (encoding_table),
2407 for (c = 0; c < 1 << 24; c++)
2409 if ( charset_code_point (range->charset, c) >= 0 )
2410 put_char_id_table_0 (ct, c, val);
2416 if (EQ (range->charset, Vcharset_ascii))
2419 for (i = 0; i < 128; i++)
2422 else if (EQ (range->charset, Vcharset_control_1))
2425 for (i = 128; i < 160; i++)
2430 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2431 ct->level1[lb] = val;
2436 case CHARTAB_RANGE_ROW:
2439 int cell_min, cell_max, i;
2441 i = XCHARSET_CELL_RANGE (range->charset);
2443 cell_max = i & 0xFF;
2444 for (i = cell_min; i <= cell_max; i++)
2446 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2448 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2449 put_char_id_table_0 (ct, ch, val);
2454 Lisp_Char_Table_Entry *cte;
2455 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2456 /* make sure that there is a separate entry for the row. */
2457 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2458 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2459 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2460 cte->level2[range->row - 32] = val;
2462 #endif /* not UTF2000 */
2466 case CHARTAB_RANGE_CHAR:
2468 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2469 put_char_id_table_0 (ct, range->ch, val);
2473 Lisp_Object charset;
2476 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2477 if (EQ (charset, Vcharset_ascii))
2478 ct->ascii[byte1] = val;
2479 else if (EQ (charset, Vcharset_control_1))
2480 ct->ascii[byte1 + 128] = val;
2483 Lisp_Char_Table_Entry *cte;
2484 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2485 /* make sure that there is a separate entry for the row. */
2486 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2487 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2488 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2489 /* now CTE is a char table entry for the charset;
2490 each entry is for a single row (or character of
2491 a one-octet charset). */
2492 if (XCHARSET_DIMENSION (charset) == 1)
2493 cte->level2[byte1 - 32] = val;
2496 /* assigning to one character in a two-octet charset. */
2497 /* make sure that the charset row contains a separate
2498 entry for each character. */
2499 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2500 cte->level2[byte1 - 32] =
2501 make_char_table_entry (cte->level2[byte1 - 32]);
2502 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2503 cte->level2[byte2 - 32] = val;
2507 #else /* not MULE */
2508 ct->ascii[(unsigned char) (range->ch)] = val;
2510 #endif /* not MULE */
2514 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2515 update_syntax_table (ct);
2519 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2520 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2522 RANGE specifies one or more characters to be affected and should be
2523 one of the following:
2525 -- t (all characters are affected)
2526 -- A charset (only allowed when Mule support is present)
2527 -- A vector of two elements: a two-octet charset and a row number
2528 (only allowed when Mule support is present)
2529 -- A single character
2531 VALUE must be a value appropriate for the type of CHAR-TABLE.
2532 See `valid-char-table-type-p'.
2534 (range, value, char_table))
2536 Lisp_Char_Table *ct;
2537 struct chartab_range rainj;
2539 CHECK_CHAR_TABLE (char_table);
2540 ct = XCHAR_TABLE (char_table);
2541 check_valid_char_table_value (value, ct->type, ERROR_ME);
2542 decode_char_table_range (range, &rainj);
2543 value = canonicalize_char_table_value (value, ct->type);
2544 put_char_table (ct, &rainj, value);
2549 /* Map FN over the ASCII chars in CT. */
2552 map_over_charset_ascii (Lisp_Char_Table *ct,
2553 int (*fn) (struct chartab_range *range,
2554 Lisp_Object val, void *arg),
2557 struct chartab_range rainj;
2566 rainj.type = CHARTAB_RANGE_CHAR;
2568 for (i = start, retval = 0; i < stop && retval == 0; i++)
2570 rainj.ch = (Emchar) i;
2571 retval = (fn) (&rainj, ct->ascii[i], arg);
2579 /* Map FN over the Control-1 chars in CT. */
2582 map_over_charset_control_1 (Lisp_Char_Table *ct,
2583 int (*fn) (struct chartab_range *range,
2584 Lisp_Object val, void *arg),
2587 struct chartab_range rainj;
2590 int stop = start + 32;
2592 rainj.type = CHARTAB_RANGE_CHAR;
2594 for (i = start, retval = 0; i < stop && retval == 0; i++)
2596 rainj.ch = (Emchar) (i);
2597 retval = (fn) (&rainj, ct->ascii[i], arg);
2603 /* Map FN over the row ROW of two-byte charset CHARSET.
2604 There must be a separate value for that row in the char table.
2605 CTE specifies the char table entry for CHARSET. */
2608 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2609 Lisp_Object charset, int row,
2610 int (*fn) (struct chartab_range *range,
2611 Lisp_Object val, void *arg),
2614 Lisp_Object val = cte->level2[row - 32];
2616 if (!CHAR_TABLE_ENTRYP (val))
2618 struct chartab_range rainj;
2620 rainj.type = CHARTAB_RANGE_ROW;
2621 rainj.charset = charset;
2623 return (fn) (&rainj, val, arg);
2627 struct chartab_range rainj;
2629 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2630 int start = charset94_p ? 33 : 32;
2631 int stop = charset94_p ? 127 : 128;
2633 cte = XCHAR_TABLE_ENTRY (val);
2635 rainj.type = CHARTAB_RANGE_CHAR;
2637 for (i = start, retval = 0; i < stop && retval == 0; i++)
2639 rainj.ch = MAKE_CHAR (charset, row, i);
2640 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2648 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2649 int (*fn) (struct chartab_range *range,
2650 Lisp_Object val, void *arg),
2653 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2654 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2656 if (!CHARSETP (charset)
2657 || lb == LEADING_BYTE_ASCII
2658 || lb == LEADING_BYTE_CONTROL_1)
2661 if (!CHAR_TABLE_ENTRYP (val))
2663 struct chartab_range rainj;
2665 rainj.type = CHARTAB_RANGE_CHARSET;
2666 rainj.charset = charset;
2667 return (fn) (&rainj, val, arg);
2671 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2672 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2673 int start = charset94_p ? 33 : 32;
2674 int stop = charset94_p ? 127 : 128;
2677 if (XCHARSET_DIMENSION (charset) == 1)
2679 struct chartab_range rainj;
2680 rainj.type = CHARTAB_RANGE_CHAR;
2682 for (i = start, retval = 0; i < stop && retval == 0; i++)
2684 rainj.ch = MAKE_CHAR (charset, i, 0);
2685 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2690 for (i = start, retval = 0; i < stop && retval == 0; i++)
2691 retval = map_over_charset_row (cte, charset, i, fn, arg);
2699 #endif /* not UTF2000 */
2702 struct map_char_table_for_charset_arg
2704 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2705 Lisp_Char_Table *ct;
2710 map_char_table_for_charset_fun (struct chartab_range *range,
2711 Lisp_Object val, void *arg)
2713 struct map_char_table_for_charset_arg *closure =
2714 (struct map_char_table_for_charset_arg *) arg;
2717 switch (range->type)
2719 case CHARTAB_RANGE_ALL:
2722 case CHARTAB_RANGE_DEFAULT:
2725 case CHARTAB_RANGE_CHARSET:
2728 case CHARTAB_RANGE_ROW:
2731 case CHARTAB_RANGE_CHAR:
2732 ret = get_char_table (range->ch, closure->ct);
2733 if (!UNBOUNDP (ret))
2734 return (closure->fn) (range, ret, closure->arg);
2746 /* Map FN (with client data ARG) over range RANGE in char table CT.
2747 Mapping stops the first time FN returns non-zero, and that value
2748 becomes the return value of map_char_table(). */
2751 map_char_table (Lisp_Char_Table *ct,
2752 struct chartab_range *range,
2753 int (*fn) (struct chartab_range *range,
2754 Lisp_Object val, void *arg),
2757 switch (range->type)
2759 case CHARTAB_RANGE_ALL:
2761 if (!UNBOUNDP (ct->default_value))
2763 struct chartab_range rainj;
2766 rainj.type = CHARTAB_RANGE_DEFAULT;
2767 retval = (fn) (&rainj, ct->default_value, arg);
2771 if (UINT8_BYTE_TABLE_P (ct->table))
2772 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2774 else if (UINT16_BYTE_TABLE_P (ct->table))
2775 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2777 else if (BYTE_TABLE_P (ct->table))
2778 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2780 else if (EQ (ct->table, Qunloaded))
2783 struct chartab_range rainj;
2786 Emchar c1 = c + unit;
2789 rainj.type = CHARTAB_RANGE_CHAR;
2791 for (retval = 0; c < c1 && retval == 0; c++)
2793 Lisp_Object ret = get_char_id_table (ct, c);
2795 if (!UNBOUNDP (ret))
2798 retval = (fn) (&rainj, ct->table, arg);
2803 ct->table = Qunbound;
2806 else if (!UNBOUNDP (ct->table))
2807 return (fn) (range, ct->table, arg);
2813 retval = map_over_charset_ascii (ct, fn, arg);
2817 retval = map_over_charset_control_1 (ct, fn, arg);
2822 Charset_ID start = MIN_LEADING_BYTE;
2823 Charset_ID stop = start + NUM_LEADING_BYTES;
2825 for (i = start, retval = 0; i < stop && retval == 0; i++)
2827 retval = map_over_other_charset (ct, i, fn, arg);
2836 case CHARTAB_RANGE_DEFAULT:
2837 if (!UNBOUNDP (ct->default_value))
2838 return (fn) (range, ct->default_value, arg);
2843 case CHARTAB_RANGE_CHARSET:
2846 Lisp_Object encoding_table
2847 = XCHARSET_ENCODING_TABLE (range->charset);
2849 if (!NILP (encoding_table))
2851 struct chartab_range rainj;
2852 struct map_char_table_for_charset_arg mcarg;
2854 #ifdef HAVE_CHISE_CLIENT
2855 if (XCHAR_TABLE_UNLOADED(encoding_table))
2856 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2861 rainj.type = CHARTAB_RANGE_ALL;
2862 return map_char_table (XCHAR_TABLE(encoding_table),
2864 &map_char_table_for_charset_fun,
2870 return map_over_other_charset (ct,
2871 XCHARSET_LEADING_BYTE (range->charset),
2875 case CHARTAB_RANGE_ROW:
2878 int cell_min, cell_max, i;
2880 struct chartab_range rainj;
2882 i = XCHARSET_CELL_RANGE (range->charset);
2884 cell_max = i & 0xFF;
2885 rainj.type = CHARTAB_RANGE_CHAR;
2886 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2888 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2890 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2893 = get_byte_table (get_byte_table
2897 (unsigned char)(ch >> 24)),
2898 (unsigned char) (ch >> 16)),
2899 (unsigned char) (ch >> 8)),
2900 (unsigned char) ch);
2903 val = ct->default_value;
2905 retval = (fn) (&rainj, val, arg);
2912 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2913 - MIN_LEADING_BYTE];
2914 if (!CHAR_TABLE_ENTRYP (val))
2916 struct chartab_range rainj;
2918 rainj.type = CHARTAB_RANGE_ROW;
2919 rainj.charset = range->charset;
2920 rainj.row = range->row;
2921 return (fn) (&rainj, val, arg);
2924 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2925 range->charset, range->row,
2928 #endif /* not UTF2000 */
2931 case CHARTAB_RANGE_CHAR:
2933 Emchar ch = range->ch;
2934 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2936 if (!UNBOUNDP (val))
2938 struct chartab_range rainj;
2940 rainj.type = CHARTAB_RANGE_CHAR;
2942 return (fn) (&rainj, val, arg);
2954 struct slow_map_char_table_arg
2956 Lisp_Object function;
2961 slow_map_char_table_fun (struct chartab_range *range,
2962 Lisp_Object val, void *arg)
2964 Lisp_Object ranjarg = Qnil;
2965 struct slow_map_char_table_arg *closure =
2966 (struct slow_map_char_table_arg *) arg;
2968 switch (range->type)
2970 case CHARTAB_RANGE_ALL:
2975 case CHARTAB_RANGE_DEFAULT:
2981 case CHARTAB_RANGE_CHARSET:
2982 ranjarg = XCHARSET_NAME (range->charset);
2985 case CHARTAB_RANGE_ROW:
2986 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2987 make_int (range->row));
2990 case CHARTAB_RANGE_CHAR:
2991 ranjarg = make_char (range->ch);
2997 closure->retval = call2 (closure->function, ranjarg, val);
2998 return !NILP (closure->retval);
3001 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
3002 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
3003 each key and value in the table.
3005 RANGE specifies a subrange to map over and is in the same format as
3006 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3009 (function, char_table, range))
3011 Lisp_Char_Table *ct;
3012 struct slow_map_char_table_arg slarg;
3013 struct gcpro gcpro1, gcpro2;
3014 struct chartab_range rainj;
3016 CHECK_CHAR_TABLE (char_table);
3017 ct = XCHAR_TABLE (char_table);
3020 decode_char_table_range (range, &rainj);
3021 slarg.function = function;
3022 slarg.retval = Qnil;
3023 GCPRO2 (slarg.function, slarg.retval);
3024 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3027 return slarg.retval;
3031 /************************************************************************/
3032 /* Character Attributes */
3033 /************************************************************************/
3037 Lisp_Object Vchar_attribute_hash_table;
3039 /* We store the char-attributes in hash tables with the names as the
3040 key and the actual char-id-table object as the value. Occasionally
3041 we need to use them in a list format. These routines provide us
3043 struct char_attribute_list_closure
3045 Lisp_Object *char_attribute_list;
3049 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3050 void *char_attribute_list_closure)
3052 /* This function can GC */
3053 struct char_attribute_list_closure *calcl
3054 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3055 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3057 *char_attribute_list = Fcons (key, *char_attribute_list);
3061 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3062 Return the list of all existing character attributes except coded-charsets.
3066 Lisp_Object char_attribute_list = Qnil;
3067 struct gcpro gcpro1;
3068 struct char_attribute_list_closure char_attribute_list_closure;
3070 GCPRO1 (char_attribute_list);
3071 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3072 elisp_maphash (add_char_attribute_to_list_mapper,
3073 Vchar_attribute_hash_table,
3074 &char_attribute_list_closure);
3076 return char_attribute_list;
3079 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3080 Return char-id-table corresponding to ATTRIBUTE.
3084 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3088 /* We store the char-id-tables in hash tables with the attributes as
3089 the key and the actual char-id-table object as the value. Each
3090 char-id-table stores values of an attribute corresponding with
3091 characters. Occasionally we need to get attributes of a character
3092 in a association-list format. These routines provide us with
3094 struct char_attribute_alist_closure
3097 Lisp_Object *char_attribute_alist;
3101 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3102 void *char_attribute_alist_closure)
3104 /* This function can GC */
3105 struct char_attribute_alist_closure *caacl =
3106 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3108 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3109 if (!UNBOUNDP (ret))
3111 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3112 *char_attribute_alist
3113 = Fcons (Fcons (key, ret), *char_attribute_alist);
3118 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3119 Return the alist of attributes of CHARACTER.
3123 struct gcpro gcpro1;
3124 struct char_attribute_alist_closure char_attribute_alist_closure;
3125 Lisp_Object alist = Qnil;
3127 CHECK_CHAR (character);
3130 char_attribute_alist_closure.char_id = XCHAR (character);
3131 char_attribute_alist_closure.char_attribute_alist = &alist;
3132 elisp_maphash (add_char_attribute_alist_mapper,
3133 Vchar_attribute_hash_table,
3134 &char_attribute_alist_closure);
3140 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3141 Return the value of CHARACTER's ATTRIBUTE.
3142 Return DEFAULT-VALUE if the value is not exist.
3144 (character, attribute, default_value))
3148 CHECK_CHAR (character);
3150 if (CHARSETP (attribute))
3151 attribute = XCHARSET_NAME (attribute);
3153 table = Fgethash (attribute, Vchar_attribute_hash_table,
3155 if (!UNBOUNDP (table))
3157 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3159 if (!UNBOUNDP (ret))
3162 return default_value;
3165 void put_char_composition (Lisp_Object character, Lisp_Object value);
3167 put_char_composition (Lisp_Object character, Lisp_Object value)
3170 signal_simple_error ("Invalid value for ->decomposition",
3173 if (CONSP (Fcdr (value)))
3175 if (NILP (Fcdr (Fcdr (value))))
3177 Lisp_Object base = Fcar (value);
3178 Lisp_Object modifier = Fcar (Fcdr (value));
3182 base = make_char (XINT (base));
3183 Fsetcar (value, base);
3185 if (INTP (modifier))
3187 modifier = make_char (XINT (modifier));
3188 Fsetcar (Fcdr (value), modifier);
3193 = Fget_char_attribute (base, Qcomposition, Qnil);
3194 Lisp_Object ret = Fassq (modifier, alist);
3197 Fput_char_attribute (base, Qcomposition,
3198 Fcons (Fcons (modifier, character),
3201 Fsetcdr (ret, character);
3207 Lisp_Object v = Fcar (value);
3211 Emchar c = XINT (v);
3213 = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil);
3217 Fput_char_attribute (make_char (c), Q_ucs_variants,
3218 Fcons (character, Qnil));
3220 else if (NILP (Fmemq (character, ret)))
3222 Fput_char_attribute (make_char (c), Q_ucs_variants,
3223 Fcons (character, ret));
3229 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3230 Store CHARACTER's ATTRIBUTE with VALUE.
3232 (character, attribute, value))
3234 Lisp_Object ccs = Ffind_charset (attribute);
3236 CHECK_CHAR (character);
3239 value = put_char_ccs_code_point (character, ccs, value);
3240 else if (EQ (attribute, Q_decomposition))
3241 put_char_composition (character, value);
3242 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3248 signal_simple_error ("Invalid value for =>ucs", value);
3252 ret = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil);
3255 Fput_char_attribute (make_char (c), Q_ucs_variants,
3256 Fcons (character, Qnil));
3258 else if (NILP (Fmemq (character, ret)))
3260 Fput_char_attribute (make_char (c), Q_ucs_variants,
3261 Fcons (character, ret));
3264 if (EQ (attribute, Q_ucs))
3265 attribute = Qto_ucs;
3269 else if (EQ (attribute, Qideographic_structure))
3270 value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value));
3273 Lisp_Object table = Fgethash (attribute,
3274 Vchar_attribute_hash_table,
3279 table = make_char_id_table (Qunbound);
3280 Fputhash (attribute, table, Vchar_attribute_hash_table);
3281 #ifdef HAVE_CHISE_CLIENT
3282 XCHAR_TABLE_NAME (table) = attribute;
3285 put_char_id_table (XCHAR_TABLE(table), character, value);
3290 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3291 Remove CHARACTER's ATTRIBUTE.
3293 (character, attribute))
3297 CHECK_CHAR (character);
3298 ccs = Ffind_charset (attribute);
3301 return remove_char_ccs (character, ccs);
3305 Lisp_Object table = Fgethash (attribute,
3306 Vchar_attribute_hash_table,
3308 if (!UNBOUNDP (table))
3310 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3317 #ifdef HAVE_CHISE_CLIENT
3319 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3322 Lisp_Object db_dir = Vexec_directory;
3325 db_dir = build_string ("../lib-src");
3327 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3328 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3329 Fmake_directory_internal (db_dir);
3331 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3332 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3333 Fmake_directory_internal (db_dir);
3336 Lisp_Object attribute_name = Fsymbol_name (attribute);
3337 Lisp_Object dest = Qnil, ret;
3339 struct gcpro gcpro1, gcpro2;
3340 int len = XSTRING_CHAR_LENGTH (attribute_name);
3344 for (i = 0; i < len; i++)
3346 Emchar c = string_char (XSTRING (attribute_name), i);
3348 if ( (c == '/') || (c == '%') )
3352 sprintf (str, "%%%02X", c);
3353 dest = concat3 (dest,
3354 Fsubstring (attribute_name,
3355 make_int (base), make_int (i)),
3356 build_string (str));
3360 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3361 dest = concat2 (dest, ret);
3363 return Fexpand_file_name (dest, db_dir);
3366 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3370 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3371 Save values of ATTRIBUTE into database file.
3375 #ifdef HAVE_CHISE_CLIENT
3376 Lisp_Object table = Fgethash (attribute,
3377 Vchar_attribute_hash_table, Qunbound);
3378 Lisp_Char_Table *ct;
3379 Lisp_Object db_file;
3382 if (CHAR_TABLEP (table))
3383 ct = XCHAR_TABLE (table);
3387 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3388 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3391 Lisp_Object (*filter)(Lisp_Object value);
3393 if (EQ (attribute, Qideographic_structure))
3394 filter = &Fchar_refs_simplify_char_specs;
3398 if (UINT8_BYTE_TABLE_P (ct->table))
3399 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db,
3401 else if (UINT16_BYTE_TABLE_P (ct->table))
3402 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db,
3404 else if (BYTE_TABLE_P (ct->table))
3405 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3, filter);
3406 Fclose_database (db);
3416 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3417 Mount database file on char-attribute-table ATTRIBUTE.
3421 #ifdef HAVE_CHISE_CLIENT
3422 Lisp_Object table = Fgethash (attribute,
3423 Vchar_attribute_hash_table, Qunbound);
3425 if (UNBOUNDP (table))
3427 Lisp_Char_Table *ct;
3429 table = make_char_id_table (Qunbound);
3430 Fputhash (attribute, table, Vchar_attribute_hash_table);
3431 XCHAR_TABLE_NAME(table) = attribute;
3432 ct = XCHAR_TABLE (table);
3433 ct->table = Qunloaded;
3434 XCHAR_TABLE_UNLOADED(table) = 1;
3442 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3443 Close database of ATTRIBUTE.
3447 #ifdef HAVE_CHISE_CLIENT
3448 Lisp_Object table = Fgethash (attribute,
3449 Vchar_attribute_hash_table, Qunbound);
3450 Lisp_Char_Table *ct;
3452 if (CHAR_TABLEP (table))
3453 ct = XCHAR_TABLE (table);
3459 if (!NILP (Fdatabase_live_p (ct->db)))
3460 Fclose_database (ct->db);
3467 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3468 Reset values of ATTRIBUTE with database file.
3472 #ifdef HAVE_CHISE_CLIENT
3473 Lisp_Object table = Fgethash (attribute,
3474 Vchar_attribute_hash_table, Qunbound);
3475 Lisp_Char_Table *ct;
3477 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3479 if (!NILP (Ffile_exists_p (db_file)))
3481 if (UNBOUNDP (table))
3483 table = make_char_id_table (Qunbound);
3484 Fputhash (attribute, table, Vchar_attribute_hash_table);
3485 XCHAR_TABLE_NAME(table) = attribute;
3487 ct = XCHAR_TABLE (table);
3488 ct->table = Qunloaded;
3489 if (!NILP (Fdatabase_live_p (ct->db)))
3490 Fclose_database (ct->db);
3492 XCHAR_TABLE_UNLOADED(table) = 1;
3500 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3502 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3504 if (!NILP (attribute))
3506 if (NILP (Fdatabase_live_p (cit->db)))
3509 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3511 cit->db = Fopen_database (db_file, Qnil, Qnil,
3512 build_string ("r"), Qnil);
3514 if (!NILP (cit->db))
3517 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3519 if (!UNBOUNDP (val))
3523 if (!NILP (Vchar_db_stingy_mode))
3525 Fclose_database (cit->db);
3534 Lisp_Char_Table* char_attribute_table_to_load;
3536 Lisp_Object Qload_char_attribute_table_map_function;
3538 DEFUN ("load-char-attribute-table-map-function",
3539 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3540 For internal use. Don't use it.
3544 Lisp_Object c = Fread (key);
3545 Emchar code = XCHAR (c);
3546 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3548 if (EQ (ret, Qunloaded))
3549 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3553 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3554 Load values of ATTRIBUTE into database file.
3558 Lisp_Object table = Fgethash (attribute,
3559 Vchar_attribute_hash_table,
3561 if (CHAR_TABLEP (table))
3563 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3565 if (NILP (Fdatabase_live_p (ct->db)))
3568 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3570 ct->db = Fopen_database (db_file, Qnil, Qnil,
3571 build_string ("r"), Qnil);
3575 struct gcpro gcpro1;
3577 char_attribute_table_to_load = XCHAR_TABLE (table);
3579 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3581 Fclose_database (ct->db);
3583 XCHAR_TABLE_UNLOADED(table) = 0;
3591 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3592 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3593 each key and value in the table.
3595 RANGE specifies a subrange to map over and is in the same format as
3596 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3599 (function, attribute, range))
3602 Lisp_Char_Table *ct;
3603 struct slow_map_char_table_arg slarg;
3604 struct gcpro gcpro1, gcpro2;
3605 struct chartab_range rainj;
3607 if (!NILP (ccs = Ffind_charset (attribute)))
3609 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3611 if (CHAR_TABLEP (encoding_table))
3612 ct = XCHAR_TABLE (encoding_table);
3618 Lisp_Object table = Fgethash (attribute,
3619 Vchar_attribute_hash_table,
3621 if (CHAR_TABLEP (table))
3622 ct = XCHAR_TABLE (table);
3628 decode_char_table_range (range, &rainj);
3629 #ifdef HAVE_CHISE_CLIENT
3630 if (CHAR_TABLE_UNLOADED(ct))
3631 Fload_char_attribute_table (attribute);
3633 slarg.function = function;
3634 slarg.retval = Qnil;
3635 GCPRO2 (slarg.function, slarg.retval);
3636 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3639 return slarg.retval;
3642 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3643 Store character's ATTRIBUTES.
3647 Lisp_Object rest = attributes;
3648 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3649 Lisp_Object character;
3653 while (CONSP (rest))
3655 Lisp_Object cell = Fcar (rest);
3659 signal_simple_error ("Invalid argument", attributes);
3660 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3661 && ((XCHARSET_FINAL (ccs) != 0) ||
3662 (XCHARSET_MAX_CODE (ccs) > 0) ||
3663 (EQ (ccs, Vcharset_chinese_big5))) )
3667 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3669 character = Fdecode_char (ccs, cell, Qnil);
3670 if (!NILP (character))
3671 goto setup_attributes;
3675 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3676 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3680 signal_simple_error ("Invalid argument", attributes);
3682 character = make_char (XINT (code) + 0x100000);
3683 goto setup_attributes;
3687 else if (!INTP (code))
3688 signal_simple_error ("Invalid argument", attributes);
3690 character = make_char (XINT (code));
3694 while (CONSP (rest))
3696 Lisp_Object cell = Fcar (rest);
3699 signal_simple_error ("Invalid argument", attributes);
3701 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3707 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3708 Retrieve the character of the given ATTRIBUTES.
3712 Lisp_Object rest = attributes;
3715 while (CONSP (rest))
3717 Lisp_Object cell = Fcar (rest);
3721 signal_simple_error ("Invalid argument", attributes);
3722 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3726 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3728 return Fdecode_char (ccs, cell, Qnil);
3732 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3733 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3736 signal_simple_error ("Invalid argument", attributes);
3738 return make_char (XINT (code) + 0x100000);
3746 /************************************************************************/
3747 /* Char table read syntax */
3748 /************************************************************************/
3751 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3752 Error_behavior errb)
3754 /* #### should deal with ERRB */
3755 symbol_to_char_table_type (value);
3760 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3761 Error_behavior errb)
3765 /* #### should deal with ERRB */
3766 EXTERNAL_LIST_LOOP (rest, value)
3768 Lisp_Object range = XCAR (rest);
3769 struct chartab_range dummy;
3773 signal_simple_error ("Invalid list format", value);
3776 if (!CONSP (XCDR (range))
3777 || !NILP (XCDR (XCDR (range))))
3778 signal_simple_error ("Invalid range format", range);
3779 decode_char_table_range (XCAR (range), &dummy);
3780 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3783 decode_char_table_range (range, &dummy);
3790 chartab_instantiate (Lisp_Object data)
3792 Lisp_Object chartab;
3793 Lisp_Object type = Qgeneric;
3794 Lisp_Object dataval = Qnil;
3796 while (!NILP (data))
3798 Lisp_Object keyw = Fcar (data);
3804 if (EQ (keyw, Qtype))
3806 else if (EQ (keyw, Qdata))
3810 chartab = Fmake_char_table (type);
3813 while (!NILP (data))
3815 Lisp_Object range = Fcar (data);
3816 Lisp_Object val = Fcar (Fcdr (data));
3818 data = Fcdr (Fcdr (data));
3821 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3823 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3824 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3827 for (i = first; i <= last; i++)
3828 Fput_char_table (make_char (i), val, chartab);
3834 Fput_char_table (range, val, chartab);
3843 /************************************************************************/
3844 /* Category Tables, specifically */
3845 /************************************************************************/
3847 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3848 Return t if OBJECT is a category table.
3849 A category table is a type of char table used for keeping track of
3850 categories. Categories are used for classifying characters for use
3851 in regexps -- you can refer to a category rather than having to use
3852 a complicated [] expression (and category lookups are significantly
3855 There are 95 different categories available, one for each printable
3856 character (including space) in the ASCII charset. Each category
3857 is designated by one such character, called a "category designator".
3858 They are specified in a regexp using the syntax "\\cX", where X is
3859 a category designator.
3861 A category table specifies, for each character, the categories that
3862 the character is in. Note that a character can be in more than one
3863 category. More specifically, a category table maps from a character
3864 to either the value nil (meaning the character is in no categories)
3865 or a 95-element bit vector, specifying for each of the 95 categories
3866 whether the character is in that category.
3868 Special Lisp functions are provided that abstract this, so you do not
3869 have to directly manipulate bit vectors.
3873 return (CHAR_TABLEP (object) &&
3874 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3879 check_category_table (Lisp_Object object, Lisp_Object default_)
3883 while (NILP (Fcategory_table_p (object)))
3884 object = wrong_type_argument (Qcategory_table_p, object);
3889 check_category_char (Emchar ch, Lisp_Object table,
3890 unsigned int designator, unsigned int not_p)
3892 REGISTER Lisp_Object temp;
3893 Lisp_Char_Table *ctbl;
3894 #ifdef ERROR_CHECK_TYPECHECK
3895 if (NILP (Fcategory_table_p (table)))
3896 signal_simple_error ("Expected category table", table);
3898 ctbl = XCHAR_TABLE (table);
3899 temp = get_char_table (ch, ctbl);
3904 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3907 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3908 Return t if category of the character at POSITION includes DESIGNATOR.
3909 Optional third arg BUFFER specifies which buffer to use, and defaults
3910 to the current buffer.
3911 Optional fourth arg CATEGORY-TABLE specifies the category table to
3912 use, and defaults to BUFFER's category table.
3914 (position, designator, buffer, category_table))
3919 struct buffer *buf = decode_buffer (buffer, 0);
3921 CHECK_INT (position);
3922 CHECK_CATEGORY_DESIGNATOR (designator);
3923 des = XCHAR (designator);
3924 ctbl = check_category_table (category_table, Vstandard_category_table);
3925 ch = BUF_FETCH_CHAR (buf, XINT (position));
3926 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3929 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3930 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3931 Optional third arg CATEGORY-TABLE specifies the category table to use,
3932 and defaults to the standard category table.
3934 (character, designator, category_table))
3940 CHECK_CATEGORY_DESIGNATOR (designator);
3941 des = XCHAR (designator);
3942 CHECK_CHAR (character);
3943 ch = XCHAR (character);
3944 ctbl = check_category_table (category_table, Vstandard_category_table);
3945 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3948 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3949 Return BUFFER's current category table.
3950 BUFFER defaults to the current buffer.
3954 return decode_buffer (buffer, 0)->category_table;
3957 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3958 Return the standard category table.
3959 This is the one used for new buffers.
3963 return Vstandard_category_table;
3966 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3967 Return a new category table which is a copy of CATEGORY-TABLE.
3968 CATEGORY-TABLE defaults to the standard category table.
3972 if (NILP (Vstandard_category_table))
3973 return Fmake_char_table (Qcategory);
3976 check_category_table (category_table, Vstandard_category_table);
3977 return Fcopy_char_table (category_table);
3980 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3981 Select CATEGORY-TABLE as the new category table for BUFFER.
3982 BUFFER defaults to the current buffer if omitted.
3984 (category_table, buffer))
3986 struct buffer *buf = decode_buffer (buffer, 0);
3987 category_table = check_category_table (category_table, Qnil);
3988 buf->category_table = category_table;
3989 /* Indicate that this buffer now has a specified category table. */
3990 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3991 return category_table;
3994 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3995 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3999 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
4002 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
4003 Return t if OBJECT is a category table value.
4004 Valid values are nil or a bit vector of size 95.
4008 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
4012 #define CATEGORYP(x) \
4013 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
4015 #define CATEGORY_SET(c) \
4016 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
4018 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
4019 The faster version of `!NILP (Faref (category_set, category))'. */
4020 #define CATEGORY_MEMBER(category, category_set) \
4021 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
4023 /* Return 1 if there is a word boundary between two word-constituent
4024 characters C1 and C2 if they appear in this order, else return 0.
4025 Use the macro WORD_BOUNDARY_P instead of calling this function
4028 int word_boundary_p (Emchar c1, Emchar c2);
4030 word_boundary_p (Emchar c1, Emchar c2)
4032 Lisp_Object category_set1, category_set2;
4037 if (COMPOSITE_CHAR_P (c1))
4038 c1 = cmpchar_component (c1, 0, 1);
4039 if (COMPOSITE_CHAR_P (c2))
4040 c2 = cmpchar_component (c2, 0, 1);
4043 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4045 tail = Vword_separating_categories;
4050 tail = Vword_combining_categories;
4054 category_set1 = CATEGORY_SET (c1);
4055 if (NILP (category_set1))
4056 return default_result;
4057 category_set2 = CATEGORY_SET (c2);
4058 if (NILP (category_set2))
4059 return default_result;
4061 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4063 Lisp_Object elt = XCONS(tail)->car;
4066 && CATEGORYP (XCONS (elt)->car)
4067 && CATEGORYP (XCONS (elt)->cdr)
4068 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4069 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4070 return !default_result;
4072 return default_result;
4078 syms_of_chartab (void)
4081 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4082 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4083 INIT_LRECORD_IMPLEMENTATION (byte_table);
4085 defsymbol (&Qsystem_char_id, "system-char-id");
4087 defsymbol (&Qto_ucs, "=>ucs");
4088 defsymbol (&Q_ucs, "->ucs");
4089 defsymbol (&Q_ucs_variants, "->ucs-variants");
4090 defsymbol (&Qcomposition, "composition");
4091 defsymbol (&Q_decomposition, "->decomposition");
4092 defsymbol (&Qcompat, "compat");
4093 defsymbol (&Qisolated, "isolated");
4094 defsymbol (&Qinitial, "initial");
4095 defsymbol (&Qmedial, "medial");
4096 defsymbol (&Qfinal, "final");
4097 defsymbol (&Qvertical, "vertical");
4098 defsymbol (&QnoBreak, "noBreak");
4099 defsymbol (&Qfraction, "fraction");
4100 defsymbol (&Qsuper, "super");
4101 defsymbol (&Qsub, "sub");
4102 defsymbol (&Qcircle, "circle");
4103 defsymbol (&Qsquare, "square");
4104 defsymbol (&Qwide, "wide");
4105 defsymbol (&Qnarrow, "narrow");
4106 defsymbol (&Qsmall, "small");
4107 defsymbol (&Qfont, "font");
4109 DEFSUBR (Fchar_attribute_list);
4110 DEFSUBR (Ffind_char_attribute_table);
4111 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4112 DEFSUBR (Fput_char_table_map_function);
4113 #ifdef HAVE_CHISE_CLIENT
4114 DEFSUBR (Fsave_char_attribute_table);
4115 DEFSUBR (Fmount_char_attribute_table);
4116 DEFSUBR (Freset_char_attribute_table);
4117 DEFSUBR (Fclose_char_attribute_table);
4118 defsymbol (&Qload_char_attribute_table_map_function,
4119 "load-char-attribute-table-map-function");
4120 DEFSUBR (Fload_char_attribute_table_map_function);
4121 DEFSUBR (Fload_char_attribute_table);
4123 DEFSUBR (Fchar_attribute_alist);
4124 DEFSUBR (Fget_char_attribute);
4125 DEFSUBR (Fput_char_attribute);
4126 DEFSUBR (Fremove_char_attribute);
4127 DEFSUBR (Fmap_char_attribute);
4128 DEFSUBR (Fdefine_char);
4129 DEFSUBR (Ffind_char);
4130 DEFSUBR (Fchar_variants);
4132 DEFSUBR (Fget_composite_char);
4135 INIT_LRECORD_IMPLEMENTATION (char_table);
4139 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4142 defsymbol (&Qcategory_table_p, "category-table-p");
4143 defsymbol (&Qcategory_designator_p, "category-designator-p");
4144 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4147 defsymbol (&Qchar_table, "char-table");
4148 defsymbol (&Qchar_tablep, "char-table-p");
4150 DEFSUBR (Fchar_table_p);
4151 DEFSUBR (Fchar_table_type_list);
4152 DEFSUBR (Fvalid_char_table_type_p);
4153 DEFSUBR (Fchar_table_type);
4154 DEFSUBR (Freset_char_table);
4155 DEFSUBR (Fmake_char_table);
4156 DEFSUBR (Fcopy_char_table);
4157 DEFSUBR (Fget_char_table);
4158 DEFSUBR (Fget_range_char_table);
4159 DEFSUBR (Fvalid_char_table_value_p);
4160 DEFSUBR (Fcheck_valid_char_table_value);
4161 DEFSUBR (Fput_char_table);
4162 DEFSUBR (Fmap_char_table);
4165 DEFSUBR (Fcategory_table_p);
4166 DEFSUBR (Fcategory_table);
4167 DEFSUBR (Fstandard_category_table);
4168 DEFSUBR (Fcopy_category_table);
4169 DEFSUBR (Fset_category_table);
4170 DEFSUBR (Fcheck_category_at);
4171 DEFSUBR (Fchar_in_category_p);
4172 DEFSUBR (Fcategory_designator_p);
4173 DEFSUBR (Fcategory_table_value_p);
4179 vars_of_chartab (void)
4182 #ifdef HAVE_CHISE_CLIENT
4183 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4185 Vchar_db_stingy_mode = Qt;
4186 #endif /* HAVE_CHISE_CLIENT */
4188 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4189 Vall_syntax_tables = Qnil;
4190 dump_add_weak_object_chain (&Vall_syntax_tables);
4194 structure_type_create_chartab (void)
4196 struct structure_type *st;
4198 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4200 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4201 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4205 complex_vars_of_chartab (void)
4208 staticpro (&Vchar_attribute_hash_table);
4209 Vchar_attribute_hash_table
4210 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4211 #endif /* UTF2000 */
4213 /* Set this now, so first buffer creation can refer to it. */
4214 /* Make it nil before calling copy-category-table
4215 so that copy-category-table will know not to try to copy from garbage */
4216 Vstandard_category_table = Qnil;
4217 Vstandard_category_table = Fcopy_category_table (Qnil);
4218 staticpro (&Vstandard_category_table);
4220 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4221 List of pair (cons) of categories to determine word boundary.
4223 Emacs treats a sequence of word constituent characters as a single
4224 word (i.e. finds no word boundary between them) iff they belongs to
4225 the same charset. But, exceptions are allowed in the following cases.
4227 \(1) The case that characters are in different charsets is controlled
4228 by the variable `word-combining-categories'.
4230 Emacs finds no word boundary between characters of different charsets
4231 if they have categories matching some element of this list.
4233 More precisely, if an element of this list is a cons of category CAT1
4234 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4235 C2 which has CAT2, there's no word boundary between C1 and C2.
4237 For instance, to tell that ASCII characters and Latin-1 characters can
4238 form a single word, the element `(?l . ?l)' should be in this list
4239 because both characters have the category `l' (Latin characters).
4241 \(2) The case that character are in the same charset is controlled by
4242 the variable `word-separating-categories'.
4244 Emacs find a word boundary between characters of the same charset
4245 if they have categories matching some element of this list.
4247 More precisely, if an element of this list is a cons of category CAT1
4248 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4249 C2 which has CAT2, there's a word boundary between C1 and C2.
4251 For instance, to tell that there's a word boundary between Japanese
4252 Hiragana and Japanese Kanji (both are in the same charset), the
4253 element `(?H . ?C) should be in this list.
4256 Vword_combining_categories = Qnil;
4258 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4259 List of pair (cons) of categories to determine word boundary.
4260 See the documentation of the variable `word-combining-categories'.
4263 Vword_separating_categories = Qnil;