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);
3240 value = put_char_ccs_code_point (character, ccs, value);
3241 attribute = XCHARSET_NAME (ccs);
3243 else if (EQ (attribute, Q_decomposition))
3244 put_char_composition (character, value);
3245 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3251 signal_simple_error ("Invalid value for =>ucs", value);
3255 ret = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil);
3258 Fput_char_attribute (make_char (c), Q_ucs_variants,
3259 Fcons (character, Qnil));
3261 else if (NILP (Fmemq (character, ret)))
3263 Fput_char_attribute (make_char (c), Q_ucs_variants,
3264 Fcons (character, ret));
3267 if (EQ (attribute, Q_ucs))
3268 attribute = Qto_ucs;
3272 else if (EQ (attribute, Qideographic_structure))
3273 value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value));
3276 Lisp_Object table = Fgethash (attribute,
3277 Vchar_attribute_hash_table,
3282 table = make_char_id_table (Qunbound);
3283 Fputhash (attribute, table, Vchar_attribute_hash_table);
3284 #ifdef HAVE_CHISE_CLIENT
3285 XCHAR_TABLE_NAME (table) = attribute;
3288 put_char_id_table (XCHAR_TABLE(table), character, value);
3293 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3294 Remove CHARACTER's ATTRIBUTE.
3296 (character, attribute))
3300 CHECK_CHAR (character);
3301 ccs = Ffind_charset (attribute);
3304 return remove_char_ccs (character, ccs);
3308 Lisp_Object table = Fgethash (attribute,
3309 Vchar_attribute_hash_table,
3311 if (!UNBOUNDP (table))
3313 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3320 #ifdef HAVE_CHISE_CLIENT
3322 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3325 Lisp_Object db_dir = Vexec_directory;
3328 db_dir = build_string ("../lib-src");
3330 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3331 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3332 Fmake_directory_internal (db_dir);
3334 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3335 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3336 Fmake_directory_internal (db_dir);
3339 Lisp_Object attribute_name = Fsymbol_name (attribute);
3340 Lisp_Object dest = Qnil, ret;
3342 struct gcpro gcpro1, gcpro2;
3343 int len = XSTRING_CHAR_LENGTH (attribute_name);
3347 for (i = 0; i < len; i++)
3349 Emchar c = string_char (XSTRING (attribute_name), i);
3351 if ( (c == '/') || (c == '%') )
3355 sprintf (str, "%%%02X", c);
3356 dest = concat3 (dest,
3357 Fsubstring (attribute_name,
3358 make_int (base), make_int (i)),
3359 build_string (str));
3363 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3364 dest = concat2 (dest, ret);
3366 return Fexpand_file_name (dest, db_dir);
3369 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3373 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3374 Save values of ATTRIBUTE into database file.
3378 #ifdef HAVE_CHISE_CLIENT
3379 Lisp_Object table = Fgethash (attribute,
3380 Vchar_attribute_hash_table, Qunbound);
3381 Lisp_Char_Table *ct;
3382 Lisp_Object db_file;
3385 if (CHAR_TABLEP (table))
3386 ct = XCHAR_TABLE (table);
3390 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3391 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3394 Lisp_Object (*filter)(Lisp_Object value);
3396 if (EQ (attribute, Qideographic_structure))
3397 filter = &Fchar_refs_simplify_char_specs;
3401 if (UINT8_BYTE_TABLE_P (ct->table))
3402 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db,
3404 else if (UINT16_BYTE_TABLE_P (ct->table))
3405 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db,
3407 else if (BYTE_TABLE_P (ct->table))
3408 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3, filter);
3409 Fclose_database (db);
3419 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3420 Mount database file on char-attribute-table ATTRIBUTE.
3424 #ifdef HAVE_CHISE_CLIENT
3425 Lisp_Object table = Fgethash (attribute,
3426 Vchar_attribute_hash_table, Qunbound);
3428 if (UNBOUNDP (table))
3430 Lisp_Char_Table *ct;
3432 table = make_char_id_table (Qunbound);
3433 Fputhash (attribute, table, Vchar_attribute_hash_table);
3434 XCHAR_TABLE_NAME(table) = attribute;
3435 ct = XCHAR_TABLE (table);
3436 ct->table = Qunloaded;
3437 XCHAR_TABLE_UNLOADED(table) = 1;
3445 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3446 Close database of ATTRIBUTE.
3450 #ifdef HAVE_CHISE_CLIENT
3451 Lisp_Object table = Fgethash (attribute,
3452 Vchar_attribute_hash_table, Qunbound);
3453 Lisp_Char_Table *ct;
3455 if (CHAR_TABLEP (table))
3456 ct = XCHAR_TABLE (table);
3462 if (!NILP (Fdatabase_live_p (ct->db)))
3463 Fclose_database (ct->db);
3470 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3471 Reset values of ATTRIBUTE with database file.
3475 #ifdef HAVE_CHISE_CLIENT
3476 Lisp_Object table = Fgethash (attribute,
3477 Vchar_attribute_hash_table, Qunbound);
3478 Lisp_Char_Table *ct;
3480 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3482 if (!NILP (Ffile_exists_p (db_file)))
3484 if (UNBOUNDP (table))
3486 table = make_char_id_table (Qunbound);
3487 Fputhash (attribute, table, Vchar_attribute_hash_table);
3488 XCHAR_TABLE_NAME(table) = attribute;
3490 ct = XCHAR_TABLE (table);
3491 ct->table = Qunloaded;
3492 if (!NILP (Fdatabase_live_p (ct->db)))
3493 Fclose_database (ct->db);
3495 XCHAR_TABLE_UNLOADED(table) = 1;
3503 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3505 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3507 if (!NILP (attribute))
3509 if (NILP (Fdatabase_live_p (cit->db)))
3512 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3514 cit->db = Fopen_database (db_file, Qnil, Qnil,
3515 build_string ("r"), Qnil);
3517 if (!NILP (cit->db))
3520 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3522 if (!UNBOUNDP (val))
3526 if (!NILP (Vchar_db_stingy_mode))
3528 Fclose_database (cit->db);
3537 Lisp_Char_Table* char_attribute_table_to_load;
3539 Lisp_Object Qload_char_attribute_table_map_function;
3541 DEFUN ("load-char-attribute-table-map-function",
3542 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3543 For internal use. Don't use it.
3547 Lisp_Object c = Fread (key);
3548 Emchar code = XCHAR (c);
3549 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3551 if (EQ (ret, Qunloaded))
3552 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3556 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3557 Load values of ATTRIBUTE into database file.
3561 Lisp_Object table = Fgethash (attribute,
3562 Vchar_attribute_hash_table,
3564 if (CHAR_TABLEP (table))
3566 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3568 if (NILP (Fdatabase_live_p (ct->db)))
3571 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3573 ct->db = Fopen_database (db_file, Qnil, Qnil,
3574 build_string ("r"), Qnil);
3578 struct gcpro gcpro1;
3580 char_attribute_table_to_load = XCHAR_TABLE (table);
3582 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3584 Fclose_database (ct->db);
3586 XCHAR_TABLE_UNLOADED(table) = 0;
3594 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3595 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3596 each key and value in the table.
3598 RANGE specifies a subrange to map over and is in the same format as
3599 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3602 (function, attribute, range))
3605 Lisp_Char_Table *ct;
3606 struct slow_map_char_table_arg slarg;
3607 struct gcpro gcpro1, gcpro2;
3608 struct chartab_range rainj;
3610 if (!NILP (ccs = Ffind_charset (attribute)))
3612 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3614 if (CHAR_TABLEP (encoding_table))
3615 ct = XCHAR_TABLE (encoding_table);
3621 Lisp_Object table = Fgethash (attribute,
3622 Vchar_attribute_hash_table,
3624 if (CHAR_TABLEP (table))
3625 ct = XCHAR_TABLE (table);
3631 decode_char_table_range (range, &rainj);
3632 #ifdef HAVE_CHISE_CLIENT
3633 if (CHAR_TABLE_UNLOADED(ct))
3634 Fload_char_attribute_table (attribute);
3636 slarg.function = function;
3637 slarg.retval = Qnil;
3638 GCPRO2 (slarg.function, slarg.retval);
3639 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3642 return slarg.retval;
3645 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3646 Store character's ATTRIBUTES.
3650 Lisp_Object rest = attributes;
3651 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3652 Lisp_Object character;
3656 while (CONSP (rest))
3658 Lisp_Object cell = Fcar (rest);
3662 signal_simple_error ("Invalid argument", attributes);
3663 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3664 && ((XCHARSET_FINAL (ccs) != 0) ||
3665 (XCHARSET_MAX_CODE (ccs) > 0) ||
3666 (EQ (ccs, Vcharset_chinese_big5))) )
3670 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3672 character = Fdecode_char (ccs, cell, Qnil);
3673 if (!NILP (character))
3674 goto setup_attributes;
3678 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3679 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3683 signal_simple_error ("Invalid argument", attributes);
3685 character = make_char (XINT (code) + 0x100000);
3686 goto setup_attributes;
3690 else if (!INTP (code))
3691 signal_simple_error ("Invalid argument", attributes);
3693 character = make_char (XINT (code));
3697 while (CONSP (rest))
3699 Lisp_Object cell = Fcar (rest);
3702 signal_simple_error ("Invalid argument", attributes);
3704 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3710 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3711 Retrieve the character of the given ATTRIBUTES.
3715 Lisp_Object rest = attributes;
3718 while (CONSP (rest))
3720 Lisp_Object cell = Fcar (rest);
3724 signal_simple_error ("Invalid argument", attributes);
3725 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3729 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3731 return Fdecode_char (ccs, cell, Qnil);
3735 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3736 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3739 signal_simple_error ("Invalid argument", attributes);
3741 return make_char (XINT (code) + 0x100000);
3749 /************************************************************************/
3750 /* Char table read syntax */
3751 /************************************************************************/
3754 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3755 Error_behavior errb)
3757 /* #### should deal with ERRB */
3758 symbol_to_char_table_type (value);
3763 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3764 Error_behavior errb)
3768 /* #### should deal with ERRB */
3769 EXTERNAL_LIST_LOOP (rest, value)
3771 Lisp_Object range = XCAR (rest);
3772 struct chartab_range dummy;
3776 signal_simple_error ("Invalid list format", value);
3779 if (!CONSP (XCDR (range))
3780 || !NILP (XCDR (XCDR (range))))
3781 signal_simple_error ("Invalid range format", range);
3782 decode_char_table_range (XCAR (range), &dummy);
3783 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3786 decode_char_table_range (range, &dummy);
3793 chartab_instantiate (Lisp_Object data)
3795 Lisp_Object chartab;
3796 Lisp_Object type = Qgeneric;
3797 Lisp_Object dataval = Qnil;
3799 while (!NILP (data))
3801 Lisp_Object keyw = Fcar (data);
3807 if (EQ (keyw, Qtype))
3809 else if (EQ (keyw, Qdata))
3813 chartab = Fmake_char_table (type);
3816 while (!NILP (data))
3818 Lisp_Object range = Fcar (data);
3819 Lisp_Object val = Fcar (Fcdr (data));
3821 data = Fcdr (Fcdr (data));
3824 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3826 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3827 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3830 for (i = first; i <= last; i++)
3831 Fput_char_table (make_char (i), val, chartab);
3837 Fput_char_table (range, val, chartab);
3846 /************************************************************************/
3847 /* Category Tables, specifically */
3848 /************************************************************************/
3850 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3851 Return t if OBJECT is a category table.
3852 A category table is a type of char table used for keeping track of
3853 categories. Categories are used for classifying characters for use
3854 in regexps -- you can refer to a category rather than having to use
3855 a complicated [] expression (and category lookups are significantly
3858 There are 95 different categories available, one for each printable
3859 character (including space) in the ASCII charset. Each category
3860 is designated by one such character, called a "category designator".
3861 They are specified in a regexp using the syntax "\\cX", where X is
3862 a category designator.
3864 A category table specifies, for each character, the categories that
3865 the character is in. Note that a character can be in more than one
3866 category. More specifically, a category table maps from a character
3867 to either the value nil (meaning the character is in no categories)
3868 or a 95-element bit vector, specifying for each of the 95 categories
3869 whether the character is in that category.
3871 Special Lisp functions are provided that abstract this, so you do not
3872 have to directly manipulate bit vectors.
3876 return (CHAR_TABLEP (object) &&
3877 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3882 check_category_table (Lisp_Object object, Lisp_Object default_)
3886 while (NILP (Fcategory_table_p (object)))
3887 object = wrong_type_argument (Qcategory_table_p, object);
3892 check_category_char (Emchar ch, Lisp_Object table,
3893 unsigned int designator, unsigned int not_p)
3895 REGISTER Lisp_Object temp;
3896 Lisp_Char_Table *ctbl;
3897 #ifdef ERROR_CHECK_TYPECHECK
3898 if (NILP (Fcategory_table_p (table)))
3899 signal_simple_error ("Expected category table", table);
3901 ctbl = XCHAR_TABLE (table);
3902 temp = get_char_table (ch, ctbl);
3907 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3910 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3911 Return t if category of the character at POSITION includes DESIGNATOR.
3912 Optional third arg BUFFER specifies which buffer to use, and defaults
3913 to the current buffer.
3914 Optional fourth arg CATEGORY-TABLE specifies the category table to
3915 use, and defaults to BUFFER's category table.
3917 (position, designator, buffer, category_table))
3922 struct buffer *buf = decode_buffer (buffer, 0);
3924 CHECK_INT (position);
3925 CHECK_CATEGORY_DESIGNATOR (designator);
3926 des = XCHAR (designator);
3927 ctbl = check_category_table (category_table, Vstandard_category_table);
3928 ch = BUF_FETCH_CHAR (buf, XINT (position));
3929 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3932 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3933 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3934 Optional third arg CATEGORY-TABLE specifies the category table to use,
3935 and defaults to the standard category table.
3937 (character, designator, category_table))
3943 CHECK_CATEGORY_DESIGNATOR (designator);
3944 des = XCHAR (designator);
3945 CHECK_CHAR (character);
3946 ch = XCHAR (character);
3947 ctbl = check_category_table (category_table, Vstandard_category_table);
3948 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3951 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3952 Return BUFFER's current category table.
3953 BUFFER defaults to the current buffer.
3957 return decode_buffer (buffer, 0)->category_table;
3960 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3961 Return the standard category table.
3962 This is the one used for new buffers.
3966 return Vstandard_category_table;
3969 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3970 Return a new category table which is a copy of CATEGORY-TABLE.
3971 CATEGORY-TABLE defaults to the standard category table.
3975 if (NILP (Vstandard_category_table))
3976 return Fmake_char_table (Qcategory);
3979 check_category_table (category_table, Vstandard_category_table);
3980 return Fcopy_char_table (category_table);
3983 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3984 Select CATEGORY-TABLE as the new category table for BUFFER.
3985 BUFFER defaults to the current buffer if omitted.
3987 (category_table, buffer))
3989 struct buffer *buf = decode_buffer (buffer, 0);
3990 category_table = check_category_table (category_table, Qnil);
3991 buf->category_table = category_table;
3992 /* Indicate that this buffer now has a specified category table. */
3993 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3994 return category_table;
3997 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3998 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
4002 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
4005 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
4006 Return t if OBJECT is a category table value.
4007 Valid values are nil or a bit vector of size 95.
4011 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
4015 #define CATEGORYP(x) \
4016 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
4018 #define CATEGORY_SET(c) \
4019 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
4021 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
4022 The faster version of `!NILP (Faref (category_set, category))'. */
4023 #define CATEGORY_MEMBER(category, category_set) \
4024 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
4026 /* Return 1 if there is a word boundary between two word-constituent
4027 characters C1 and C2 if they appear in this order, else return 0.
4028 Use the macro WORD_BOUNDARY_P instead of calling this function
4031 int word_boundary_p (Emchar c1, Emchar c2);
4033 word_boundary_p (Emchar c1, Emchar c2)
4035 Lisp_Object category_set1, category_set2;
4040 if (COMPOSITE_CHAR_P (c1))
4041 c1 = cmpchar_component (c1, 0, 1);
4042 if (COMPOSITE_CHAR_P (c2))
4043 c2 = cmpchar_component (c2, 0, 1);
4046 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4048 tail = Vword_separating_categories;
4053 tail = Vword_combining_categories;
4057 category_set1 = CATEGORY_SET (c1);
4058 if (NILP (category_set1))
4059 return default_result;
4060 category_set2 = CATEGORY_SET (c2);
4061 if (NILP (category_set2))
4062 return default_result;
4064 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4066 Lisp_Object elt = XCONS(tail)->car;
4069 && CATEGORYP (XCONS (elt)->car)
4070 && CATEGORYP (XCONS (elt)->cdr)
4071 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4072 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4073 return !default_result;
4075 return default_result;
4081 syms_of_chartab (void)
4084 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4085 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4086 INIT_LRECORD_IMPLEMENTATION (byte_table);
4088 defsymbol (&Qsystem_char_id, "system-char-id");
4090 defsymbol (&Qto_ucs, "=>ucs");
4091 defsymbol (&Q_ucs, "->ucs");
4092 defsymbol (&Q_ucs_variants, "->ucs-variants");
4093 defsymbol (&Qcomposition, "composition");
4094 defsymbol (&Q_decomposition, "->decomposition");
4095 defsymbol (&Qcompat, "compat");
4096 defsymbol (&Qisolated, "isolated");
4097 defsymbol (&Qinitial, "initial");
4098 defsymbol (&Qmedial, "medial");
4099 defsymbol (&Qfinal, "final");
4100 defsymbol (&Qvertical, "vertical");
4101 defsymbol (&QnoBreak, "noBreak");
4102 defsymbol (&Qfraction, "fraction");
4103 defsymbol (&Qsuper, "super");
4104 defsymbol (&Qsub, "sub");
4105 defsymbol (&Qcircle, "circle");
4106 defsymbol (&Qsquare, "square");
4107 defsymbol (&Qwide, "wide");
4108 defsymbol (&Qnarrow, "narrow");
4109 defsymbol (&Qsmall, "small");
4110 defsymbol (&Qfont, "font");
4112 DEFSUBR (Fchar_attribute_list);
4113 DEFSUBR (Ffind_char_attribute_table);
4114 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4115 DEFSUBR (Fput_char_table_map_function);
4116 #ifdef HAVE_CHISE_CLIENT
4117 DEFSUBR (Fsave_char_attribute_table);
4118 DEFSUBR (Fmount_char_attribute_table);
4119 DEFSUBR (Freset_char_attribute_table);
4120 DEFSUBR (Fclose_char_attribute_table);
4121 defsymbol (&Qload_char_attribute_table_map_function,
4122 "load-char-attribute-table-map-function");
4123 DEFSUBR (Fload_char_attribute_table_map_function);
4124 DEFSUBR (Fload_char_attribute_table);
4126 DEFSUBR (Fchar_attribute_alist);
4127 DEFSUBR (Fget_char_attribute);
4128 DEFSUBR (Fput_char_attribute);
4129 DEFSUBR (Fremove_char_attribute);
4130 DEFSUBR (Fmap_char_attribute);
4131 DEFSUBR (Fdefine_char);
4132 DEFSUBR (Ffind_char);
4133 DEFSUBR (Fchar_variants);
4135 DEFSUBR (Fget_composite_char);
4138 INIT_LRECORD_IMPLEMENTATION (char_table);
4142 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4145 defsymbol (&Qcategory_table_p, "category-table-p");
4146 defsymbol (&Qcategory_designator_p, "category-designator-p");
4147 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4150 defsymbol (&Qchar_table, "char-table");
4151 defsymbol (&Qchar_tablep, "char-table-p");
4153 DEFSUBR (Fchar_table_p);
4154 DEFSUBR (Fchar_table_type_list);
4155 DEFSUBR (Fvalid_char_table_type_p);
4156 DEFSUBR (Fchar_table_type);
4157 DEFSUBR (Freset_char_table);
4158 DEFSUBR (Fmake_char_table);
4159 DEFSUBR (Fcopy_char_table);
4160 DEFSUBR (Fget_char_table);
4161 DEFSUBR (Fget_range_char_table);
4162 DEFSUBR (Fvalid_char_table_value_p);
4163 DEFSUBR (Fcheck_valid_char_table_value);
4164 DEFSUBR (Fput_char_table);
4165 DEFSUBR (Fmap_char_table);
4168 DEFSUBR (Fcategory_table_p);
4169 DEFSUBR (Fcategory_table);
4170 DEFSUBR (Fstandard_category_table);
4171 DEFSUBR (Fcopy_category_table);
4172 DEFSUBR (Fset_category_table);
4173 DEFSUBR (Fcheck_category_at);
4174 DEFSUBR (Fchar_in_category_p);
4175 DEFSUBR (Fcategory_designator_p);
4176 DEFSUBR (Fcategory_table_value_p);
4182 vars_of_chartab (void)
4185 #ifdef HAVE_CHISE_CLIENT
4186 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4188 Vchar_db_stingy_mode = Qt;
4189 #endif /* HAVE_CHISE_CLIENT */
4191 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4192 Vall_syntax_tables = Qnil;
4193 dump_add_weak_object_chain (&Vall_syntax_tables);
4197 structure_type_create_chartab (void)
4199 struct structure_type *st;
4201 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4203 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4204 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4208 complex_vars_of_chartab (void)
4211 staticpro (&Vchar_attribute_hash_table);
4212 Vchar_attribute_hash_table
4213 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4214 #endif /* UTF2000 */
4216 /* Set this now, so first buffer creation can refer to it. */
4217 /* Make it nil before calling copy-category-table
4218 so that copy-category-table will know not to try to copy from garbage */
4219 Vstandard_category_table = Qnil;
4220 Vstandard_category_table = Fcopy_category_table (Qnil);
4221 staticpro (&Vstandard_category_table);
4223 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4224 List of pair (cons) of categories to determine word boundary.
4226 Emacs treats a sequence of word constituent characters as a single
4227 word (i.e. finds no word boundary between them) iff they belongs to
4228 the same charset. But, exceptions are allowed in the following cases.
4230 \(1) The case that characters are in different charsets is controlled
4231 by the variable `word-combining-categories'.
4233 Emacs finds no word boundary between characters of different charsets
4234 if they have categories matching some element of this list.
4236 More precisely, if an element of this list is a cons of category CAT1
4237 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4238 C2 which has CAT2, there's no word boundary between C1 and C2.
4240 For instance, to tell that ASCII characters and Latin-1 characters can
4241 form a single word, the element `(?l . ?l)' should be in this list
4242 because both characters have the category `l' (Latin characters).
4244 \(2) The case that character are in the same charset is controlled by
4245 the variable `word-separating-categories'.
4247 Emacs find a word boundary between characters of the same charset
4248 if they have categories matching some element of this list.
4250 More precisely, if an element of this list is a cons of category CAT1
4251 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4252 C2 which has CAT2, there's a word boundary between C1 and C2.
4254 For instance, to tell that there's a word boundary between Japanese
4255 Hiragana and Japanese Kanji (both are in the same charset), the
4256 element `(?H . ?C) should be in this list.
4259 Vword_combining_categories = Qnil;
4261 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4262 List of pair (cons) of categories to determine word boundary.
4263 See the documentation of the variable `word-combining-categories'.
4266 Vword_separating_categories = Qnil;