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;
1971 else if (EQ (range, Qnil))
1972 outrange->type = CHARTAB_RANGE_DEFAULT;
1974 else if (CHAR_OR_CHAR_INTP (range))
1976 outrange->type = CHARTAB_RANGE_CHAR;
1977 outrange->ch = XCHAR_OR_CHAR_INT (range);
1981 signal_simple_error ("Range must be t or a character", range);
1983 else if (VECTORP (range))
1985 Lisp_Vector *vec = XVECTOR (range);
1986 Lisp_Object *elts = vector_data (vec);
1987 int cell_min, cell_max;
1989 outrange->type = CHARTAB_RANGE_ROW;
1990 outrange->charset = Fget_charset (elts[0]);
1991 CHECK_INT (elts[1]);
1992 outrange->row = XINT (elts[1]);
1993 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1994 signal_simple_error ("Charset in row vector must be multi-byte",
1998 int ret = XCHARSET_CELL_RANGE (outrange->charset);
2000 cell_min = ret >> 8;
2001 cell_max = ret & 0xFF;
2003 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2004 check_int_range (outrange->row, cell_min, cell_max);
2006 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2008 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2009 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2011 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2013 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2014 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2015 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2023 if (!CHARSETP (range) && !SYMBOLP (range))
2025 ("Char table range must be t, charset, char, or vector", range);
2026 outrange->type = CHARTAB_RANGE_CHARSET;
2027 outrange->charset = Fget_charset (range);
2032 #if defined(MULE)&&!defined(UTF2000)
2034 /* called from CHAR_TABLE_VALUE(). */
2036 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2041 Lisp_Object charset;
2043 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2048 BREAKUP_CHAR (c, charset, byte1, byte2);
2050 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2052 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2053 if (CHAR_TABLE_ENTRYP (val))
2055 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2056 val = cte->level2[byte1 - 32];
2057 if (CHAR_TABLE_ENTRYP (val))
2059 cte = XCHAR_TABLE_ENTRY (val);
2060 assert (byte2 >= 32);
2061 val = cte->level2[byte2 - 32];
2062 assert (!CHAR_TABLE_ENTRYP (val));
2072 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2076 Lisp_Object ret = get_char_id_table (ct, ch);
2078 #ifdef HAVE_CHISE_CLIENT
2081 if (EQ (CHAR_TABLE_NAME (ct), Qdowncase))
2082 ret = Fget_char_attribute (make_char (ch), Q_lowercase, Qnil);
2083 else if (EQ (CHAR_TABLE_NAME (ct), Qflippedcase))
2084 ret = Fget_char_attribute (make_char (ch), Q_uppercase, Qnil);
2089 ret = Ffind_char (ret);
2097 Lisp_Object charset;
2101 BREAKUP_CHAR (ch, charset, byte1, byte2);
2103 if (EQ (charset, Vcharset_ascii))
2104 val = ct->ascii[byte1];
2105 else if (EQ (charset, Vcharset_control_1))
2106 val = ct->ascii[byte1 + 128];
2109 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2110 val = ct->level1[lb];
2111 if (CHAR_TABLE_ENTRYP (val))
2113 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2114 val = cte->level2[byte1 - 32];
2115 if (CHAR_TABLE_ENTRYP (val))
2117 cte = XCHAR_TABLE_ENTRY (val);
2118 assert (byte2 >= 32);
2119 val = cte->level2[byte2 - 32];
2120 assert (!CHAR_TABLE_ENTRYP (val));
2127 #else /* not MULE */
2128 return ct->ascii[(unsigned char)ch];
2129 #endif /* not MULE */
2133 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2134 Find value for CHARACTER in CHAR-TABLE.
2136 (character, char_table))
2138 CHECK_CHAR_TABLE (char_table);
2139 CHECK_CHAR_COERCE_INT (character);
2141 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2144 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2145 Find value for a range in CHAR-TABLE.
2146 If there is more than one value, return MULTI (defaults to nil).
2148 (range, char_table, multi))
2150 Lisp_Char_Table *ct;
2151 struct chartab_range rainj;
2153 if (CHAR_OR_CHAR_INTP (range))
2154 return Fget_char_table (range, char_table);
2155 CHECK_CHAR_TABLE (char_table);
2156 ct = XCHAR_TABLE (char_table);
2158 decode_char_table_range (range, &rainj);
2161 case CHARTAB_RANGE_ALL:
2164 if (UINT8_BYTE_TABLE_P (ct->table))
2166 else if (UINT16_BYTE_TABLE_P (ct->table))
2168 else if (BYTE_TABLE_P (ct->table))
2172 #else /* non UTF2000 */
2174 Lisp_Object first = ct->ascii[0];
2176 for (i = 1; i < NUM_ASCII_CHARS; i++)
2177 if (!EQ (first, ct->ascii[i]))
2181 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2184 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2185 || i == LEADING_BYTE_ASCII
2186 || i == LEADING_BYTE_CONTROL_1)
2188 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2194 #endif /* non UTF2000 */
2198 case CHARTAB_RANGE_CHARSET:
2202 if (EQ (rainj.charset, Vcharset_ascii))
2205 Lisp_Object first = ct->ascii[0];
2207 for (i = 1; i < 128; i++)
2208 if (!EQ (first, ct->ascii[i]))
2213 if (EQ (rainj.charset, Vcharset_control_1))
2216 Lisp_Object first = ct->ascii[128];
2218 for (i = 129; i < 160; i++)
2219 if (!EQ (first, ct->ascii[i]))
2225 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2227 if (CHAR_TABLE_ENTRYP (val))
2233 case CHARTAB_RANGE_ROW:
2238 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2240 if (!CHAR_TABLE_ENTRYP (val))
2242 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2243 if (CHAR_TABLE_ENTRYP (val))
2247 #endif /* not UTF2000 */
2248 #endif /* not MULE */
2254 return Qnil; /* not reached */
2258 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2259 Error_behavior errb)
2263 case CHAR_TABLE_TYPE_SYNTAX:
2264 if (!ERRB_EQ (errb, ERROR_ME))
2265 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2266 && CHAR_OR_CHAR_INTP (XCDR (value)));
2269 Lisp_Object cdr = XCDR (value);
2270 CHECK_INT (XCAR (value));
2271 CHECK_CHAR_COERCE_INT (cdr);
2278 case CHAR_TABLE_TYPE_CATEGORY:
2279 if (!ERRB_EQ (errb, ERROR_ME))
2280 return CATEGORY_TABLE_VALUEP (value);
2281 CHECK_CATEGORY_TABLE_VALUE (value);
2285 case CHAR_TABLE_TYPE_GENERIC:
2288 case CHAR_TABLE_TYPE_DISPLAY:
2290 maybe_signal_simple_error ("Display char tables not yet implemented",
2291 value, Qchar_table, errb);
2294 case CHAR_TABLE_TYPE_CHAR:
2295 if (!ERRB_EQ (errb, ERROR_ME))
2296 return CHAR_OR_CHAR_INTP (value);
2297 CHECK_CHAR_COERCE_INT (value);
2304 return 0; /* not reached */
2308 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2312 case CHAR_TABLE_TYPE_SYNTAX:
2315 Lisp_Object car = XCAR (value);
2316 Lisp_Object cdr = XCDR (value);
2317 CHECK_CHAR_COERCE_INT (cdr);
2318 return Fcons (car, cdr);
2321 case CHAR_TABLE_TYPE_CHAR:
2322 CHECK_CHAR_COERCE_INT (value);
2330 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2331 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2333 (value, char_table_type))
2335 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2337 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2340 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2341 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2343 (value, char_table_type))
2345 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2347 check_valid_char_table_value (value, type, ERROR_ME);
2352 Lisp_Char_Table* char_attribute_table_to_put;
2353 Lisp_Object Qput_char_table_map_function;
2354 Lisp_Object value_to_put;
2356 DEFUN ("put-char-table-map-function",
2357 Fput_char_table_map_function, 2, 2, 0, /*
2358 For internal use. Don't use it.
2362 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2367 /* Assign VAL to all characters in RANGE in char table CT. */
2370 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2373 switch (range->type)
2375 case CHARTAB_RANGE_ALL:
2376 /* printf ("put-char-table: range = all\n"); */
2377 fill_char_table (ct, val);
2378 return; /* avoid the duplicate call to update_syntax_table() below,
2379 since fill_char_table() also did that. */
2382 case CHARTAB_RANGE_DEFAULT:
2383 ct->default_value = val;
2388 case CHARTAB_RANGE_CHARSET:
2391 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2393 /* printf ("put-char-table: range = charset: %d\n",
2394 XCHARSET_LEADING_BYTE (range->charset));
2396 if ( CHAR_TABLEP (encoding_table) )
2398 char_attribute_table_to_put = ct;
2400 Fmap_char_attribute (Qput_char_table_map_function,
2401 XCHAR_TABLE_NAME (encoding_table),
2409 for (c = 0; c < 1 << 24; c++)
2411 if ( charset_code_point (range->charset, c) >= 0 )
2412 put_char_id_table_0 (ct, c, val);
2418 if (EQ (range->charset, Vcharset_ascii))
2421 for (i = 0; i < 128; i++)
2424 else if (EQ (range->charset, Vcharset_control_1))
2427 for (i = 128; i < 160; i++)
2432 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2433 ct->level1[lb] = val;
2438 case CHARTAB_RANGE_ROW:
2441 int cell_min, cell_max, i;
2443 i = XCHARSET_CELL_RANGE (range->charset);
2445 cell_max = i & 0xFF;
2446 for (i = cell_min; i <= cell_max; i++)
2448 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2450 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2451 put_char_id_table_0 (ct, ch, val);
2456 Lisp_Char_Table_Entry *cte;
2457 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2458 /* make sure that there is a separate entry for the row. */
2459 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2460 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2461 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2462 cte->level2[range->row - 32] = val;
2464 #endif /* not UTF2000 */
2468 case CHARTAB_RANGE_CHAR:
2470 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2471 put_char_id_table_0 (ct, range->ch, val);
2475 Lisp_Object charset;
2478 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2479 if (EQ (charset, Vcharset_ascii))
2480 ct->ascii[byte1] = val;
2481 else if (EQ (charset, Vcharset_control_1))
2482 ct->ascii[byte1 + 128] = val;
2485 Lisp_Char_Table_Entry *cte;
2486 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2487 /* make sure that there is a separate entry for the row. */
2488 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2489 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2490 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2491 /* now CTE is a char table entry for the charset;
2492 each entry is for a single row (or character of
2493 a one-octet charset). */
2494 if (XCHARSET_DIMENSION (charset) == 1)
2495 cte->level2[byte1 - 32] = val;
2498 /* assigning to one character in a two-octet charset. */
2499 /* make sure that the charset row contains a separate
2500 entry for each character. */
2501 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2502 cte->level2[byte1 - 32] =
2503 make_char_table_entry (cte->level2[byte1 - 32]);
2504 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2505 cte->level2[byte2 - 32] = val;
2509 #else /* not MULE */
2510 ct->ascii[(unsigned char) (range->ch)] = val;
2512 #endif /* not MULE */
2516 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2517 update_syntax_table (ct);
2521 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2522 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2524 RANGE specifies one or more characters to be affected and should be
2525 one of the following:
2527 -- t (all characters are affected)
2528 -- A charset (only allowed when Mule support is present)
2529 -- A vector of two elements: a two-octet charset and a row number
2530 (only allowed when Mule support is present)
2531 -- A single character
2533 VALUE must be a value appropriate for the type of CHAR-TABLE.
2534 See `valid-char-table-type-p'.
2536 (range, value, char_table))
2538 Lisp_Char_Table *ct;
2539 struct chartab_range rainj;
2541 CHECK_CHAR_TABLE (char_table);
2542 ct = XCHAR_TABLE (char_table);
2543 check_valid_char_table_value (value, ct->type, ERROR_ME);
2544 decode_char_table_range (range, &rainj);
2545 value = canonicalize_char_table_value (value, ct->type);
2546 put_char_table (ct, &rainj, value);
2551 /* Map FN over the ASCII chars in CT. */
2554 map_over_charset_ascii (Lisp_Char_Table *ct,
2555 int (*fn) (struct chartab_range *range,
2556 Lisp_Object val, void *arg),
2559 struct chartab_range rainj;
2568 rainj.type = CHARTAB_RANGE_CHAR;
2570 for (i = start, retval = 0; i < stop && retval == 0; i++)
2572 rainj.ch = (Emchar) i;
2573 retval = (fn) (&rainj, ct->ascii[i], arg);
2581 /* Map FN over the Control-1 chars in CT. */
2584 map_over_charset_control_1 (Lisp_Char_Table *ct,
2585 int (*fn) (struct chartab_range *range,
2586 Lisp_Object val, void *arg),
2589 struct chartab_range rainj;
2592 int stop = start + 32;
2594 rainj.type = CHARTAB_RANGE_CHAR;
2596 for (i = start, retval = 0; i < stop && retval == 0; i++)
2598 rainj.ch = (Emchar) (i);
2599 retval = (fn) (&rainj, ct->ascii[i], arg);
2605 /* Map FN over the row ROW of two-byte charset CHARSET.
2606 There must be a separate value for that row in the char table.
2607 CTE specifies the char table entry for CHARSET. */
2610 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2611 Lisp_Object charset, int row,
2612 int (*fn) (struct chartab_range *range,
2613 Lisp_Object val, void *arg),
2616 Lisp_Object val = cte->level2[row - 32];
2618 if (!CHAR_TABLE_ENTRYP (val))
2620 struct chartab_range rainj;
2622 rainj.type = CHARTAB_RANGE_ROW;
2623 rainj.charset = charset;
2625 return (fn) (&rainj, val, arg);
2629 struct chartab_range rainj;
2631 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2632 int start = charset94_p ? 33 : 32;
2633 int stop = charset94_p ? 127 : 128;
2635 cte = XCHAR_TABLE_ENTRY (val);
2637 rainj.type = CHARTAB_RANGE_CHAR;
2639 for (i = start, retval = 0; i < stop && retval == 0; i++)
2641 rainj.ch = MAKE_CHAR (charset, row, i);
2642 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2650 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2651 int (*fn) (struct chartab_range *range,
2652 Lisp_Object val, void *arg),
2655 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2656 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2658 if (!CHARSETP (charset)
2659 || lb == LEADING_BYTE_ASCII
2660 || lb == LEADING_BYTE_CONTROL_1)
2663 if (!CHAR_TABLE_ENTRYP (val))
2665 struct chartab_range rainj;
2667 rainj.type = CHARTAB_RANGE_CHARSET;
2668 rainj.charset = charset;
2669 return (fn) (&rainj, val, arg);
2673 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2674 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2675 int start = charset94_p ? 33 : 32;
2676 int stop = charset94_p ? 127 : 128;
2679 if (XCHARSET_DIMENSION (charset) == 1)
2681 struct chartab_range rainj;
2682 rainj.type = CHARTAB_RANGE_CHAR;
2684 for (i = start, retval = 0; i < stop && retval == 0; i++)
2686 rainj.ch = MAKE_CHAR (charset, i, 0);
2687 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2692 for (i = start, retval = 0; i < stop && retval == 0; i++)
2693 retval = map_over_charset_row (cte, charset, i, fn, arg);
2701 #endif /* not UTF2000 */
2704 struct map_char_table_for_charset_arg
2706 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2707 Lisp_Char_Table *ct;
2712 map_char_table_for_charset_fun (struct chartab_range *range,
2713 Lisp_Object val, void *arg)
2715 struct map_char_table_for_charset_arg *closure =
2716 (struct map_char_table_for_charset_arg *) arg;
2719 switch (range->type)
2721 case CHARTAB_RANGE_ALL:
2724 case CHARTAB_RANGE_DEFAULT:
2727 case CHARTAB_RANGE_CHARSET:
2730 case CHARTAB_RANGE_ROW:
2733 case CHARTAB_RANGE_CHAR:
2734 ret = get_char_table (range->ch, closure->ct);
2735 if (!UNBOUNDP (ret))
2736 return (closure->fn) (range, ret, closure->arg);
2748 /* Map FN (with client data ARG) over range RANGE in char table CT.
2749 Mapping stops the first time FN returns non-zero, and that value
2750 becomes the return value of map_char_table(). */
2753 map_char_table (Lisp_Char_Table *ct,
2754 struct chartab_range *range,
2755 int (*fn) (struct chartab_range *range,
2756 Lisp_Object val, void *arg),
2759 switch (range->type)
2761 case CHARTAB_RANGE_ALL:
2763 if (!UNBOUNDP (ct->default_value))
2765 struct chartab_range rainj;
2768 rainj.type = CHARTAB_RANGE_DEFAULT;
2769 retval = (fn) (&rainj, ct->default_value, arg);
2773 if (UINT8_BYTE_TABLE_P (ct->table))
2774 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2776 else if (UINT16_BYTE_TABLE_P (ct->table))
2777 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2779 else if (BYTE_TABLE_P (ct->table))
2780 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2782 else if (EQ (ct->table, Qunloaded))
2785 struct chartab_range rainj;
2788 Emchar c1 = c + unit;
2791 rainj.type = CHARTAB_RANGE_CHAR;
2793 for (retval = 0; c < c1 && retval == 0; c++)
2795 Lisp_Object ret = get_char_id_table (ct, c);
2797 if (!UNBOUNDP (ret))
2800 retval = (fn) (&rainj, ct->table, arg);
2805 ct->table = Qunbound;
2808 else if (!UNBOUNDP (ct->table))
2809 return (fn) (range, ct->table, arg);
2815 retval = map_over_charset_ascii (ct, fn, arg);
2819 retval = map_over_charset_control_1 (ct, fn, arg);
2824 Charset_ID start = MIN_LEADING_BYTE;
2825 Charset_ID stop = start + NUM_LEADING_BYTES;
2827 for (i = start, retval = 0; i < stop && retval == 0; i++)
2829 retval = map_over_other_charset (ct, i, fn, arg);
2838 case CHARTAB_RANGE_DEFAULT:
2839 if (!UNBOUNDP (ct->default_value))
2840 return (fn) (range, ct->default_value, arg);
2845 case CHARTAB_RANGE_CHARSET:
2848 Lisp_Object encoding_table
2849 = XCHARSET_ENCODING_TABLE (range->charset);
2851 if (!NILP (encoding_table))
2853 struct chartab_range rainj;
2854 struct map_char_table_for_charset_arg mcarg;
2856 #ifdef HAVE_CHISE_CLIENT
2857 if (XCHAR_TABLE_UNLOADED(encoding_table))
2858 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2863 rainj.type = CHARTAB_RANGE_ALL;
2864 return map_char_table (XCHAR_TABLE(encoding_table),
2866 &map_char_table_for_charset_fun,
2872 return map_over_other_charset (ct,
2873 XCHARSET_LEADING_BYTE (range->charset),
2877 case CHARTAB_RANGE_ROW:
2880 int cell_min, cell_max, i;
2882 struct chartab_range rainj;
2884 i = XCHARSET_CELL_RANGE (range->charset);
2886 cell_max = i & 0xFF;
2887 rainj.type = CHARTAB_RANGE_CHAR;
2888 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2890 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2892 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2895 = get_byte_table (get_byte_table
2899 (unsigned char)(ch >> 24)),
2900 (unsigned char) (ch >> 16)),
2901 (unsigned char) (ch >> 8)),
2902 (unsigned char) ch);
2905 val = ct->default_value;
2907 retval = (fn) (&rainj, val, arg);
2914 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2915 - MIN_LEADING_BYTE];
2916 if (!CHAR_TABLE_ENTRYP (val))
2918 struct chartab_range rainj;
2920 rainj.type = CHARTAB_RANGE_ROW;
2921 rainj.charset = range->charset;
2922 rainj.row = range->row;
2923 return (fn) (&rainj, val, arg);
2926 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2927 range->charset, range->row,
2930 #endif /* not UTF2000 */
2933 case CHARTAB_RANGE_CHAR:
2935 Emchar ch = range->ch;
2936 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2938 if (!UNBOUNDP (val))
2940 struct chartab_range rainj;
2942 rainj.type = CHARTAB_RANGE_CHAR;
2944 return (fn) (&rainj, val, arg);
2956 struct slow_map_char_table_arg
2958 Lisp_Object function;
2963 slow_map_char_table_fun (struct chartab_range *range,
2964 Lisp_Object val, void *arg)
2966 Lisp_Object ranjarg = Qnil;
2967 struct slow_map_char_table_arg *closure =
2968 (struct slow_map_char_table_arg *) arg;
2970 switch (range->type)
2972 case CHARTAB_RANGE_ALL:
2977 case CHARTAB_RANGE_DEFAULT:
2983 case CHARTAB_RANGE_CHARSET:
2984 ranjarg = XCHARSET_NAME (range->charset);
2987 case CHARTAB_RANGE_ROW:
2988 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2989 make_int (range->row));
2992 case CHARTAB_RANGE_CHAR:
2993 ranjarg = make_char (range->ch);
2999 closure->retval = call2 (closure->function, ranjarg, val);
3000 return !NILP (closure->retval);
3003 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
3004 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
3005 each key and value in the table.
3007 RANGE specifies a subrange to map over and is in the same format as
3008 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3011 (function, char_table, range))
3013 Lisp_Char_Table *ct;
3014 struct slow_map_char_table_arg slarg;
3015 struct gcpro gcpro1, gcpro2;
3016 struct chartab_range rainj;
3018 CHECK_CHAR_TABLE (char_table);
3019 ct = XCHAR_TABLE (char_table);
3022 decode_char_table_range (range, &rainj);
3023 slarg.function = function;
3024 slarg.retval = Qnil;
3025 GCPRO2 (slarg.function, slarg.retval);
3026 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3029 return slarg.retval;
3033 /************************************************************************/
3034 /* Character Attributes */
3035 /************************************************************************/
3039 Lisp_Object Vchar_attribute_hash_table;
3041 /* We store the char-attributes in hash tables with the names as the
3042 key and the actual char-id-table object as the value. Occasionally
3043 we need to use them in a list format. These routines provide us
3045 struct char_attribute_list_closure
3047 Lisp_Object *char_attribute_list;
3051 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3052 void *char_attribute_list_closure)
3054 /* This function can GC */
3055 struct char_attribute_list_closure *calcl
3056 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3057 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3059 *char_attribute_list = Fcons (key, *char_attribute_list);
3063 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3064 Return the list of all existing character attributes except coded-charsets.
3068 Lisp_Object char_attribute_list = Qnil;
3069 struct gcpro gcpro1;
3070 struct char_attribute_list_closure char_attribute_list_closure;
3072 GCPRO1 (char_attribute_list);
3073 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3074 elisp_maphash (add_char_attribute_to_list_mapper,
3075 Vchar_attribute_hash_table,
3076 &char_attribute_list_closure);
3078 return char_attribute_list;
3081 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3082 Return char-id-table corresponding to ATTRIBUTE.
3086 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3090 /* We store the char-id-tables in hash tables with the attributes as
3091 the key and the actual char-id-table object as the value. Each
3092 char-id-table stores values of an attribute corresponding with
3093 characters. Occasionally we need to get attributes of a character
3094 in a association-list format. These routines provide us with
3096 struct char_attribute_alist_closure
3099 Lisp_Object *char_attribute_alist;
3103 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3104 void *char_attribute_alist_closure)
3106 /* This function can GC */
3107 struct char_attribute_alist_closure *caacl =
3108 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3110 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3111 if (!UNBOUNDP (ret))
3113 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3114 *char_attribute_alist
3115 = Fcons (Fcons (key, ret), *char_attribute_alist);
3120 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3121 Return the alist of attributes of CHARACTER.
3125 struct gcpro gcpro1;
3126 struct char_attribute_alist_closure char_attribute_alist_closure;
3127 Lisp_Object alist = Qnil;
3129 CHECK_CHAR (character);
3132 char_attribute_alist_closure.char_id = XCHAR (character);
3133 char_attribute_alist_closure.char_attribute_alist = &alist;
3134 elisp_maphash (add_char_attribute_alist_mapper,
3135 Vchar_attribute_hash_table,
3136 &char_attribute_alist_closure);
3142 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3143 Return the value of CHARACTER's ATTRIBUTE.
3144 Return DEFAULT-VALUE if the value is not exist.
3146 (character, attribute, default_value))
3150 CHECK_CHAR (character);
3152 if (CHARSETP (attribute))
3153 attribute = XCHARSET_NAME (attribute);
3155 table = Fgethash (attribute, Vchar_attribute_hash_table,
3157 if (!UNBOUNDP (table))
3159 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3161 if (!UNBOUNDP (ret))
3164 return default_value;
3167 void put_char_composition (Lisp_Object character, Lisp_Object value);
3169 put_char_composition (Lisp_Object character, Lisp_Object value)
3172 signal_simple_error ("Invalid value for ->decomposition",
3175 if (CONSP (Fcdr (value)))
3177 if (NILP (Fcdr (Fcdr (value))))
3179 Lisp_Object base = Fcar (value);
3180 Lisp_Object modifier = Fcar (Fcdr (value));
3184 base = make_char (XINT (base));
3185 Fsetcar (value, base);
3187 if (INTP (modifier))
3189 modifier = make_char (XINT (modifier));
3190 Fsetcar (Fcdr (value), modifier);
3195 = Fget_char_attribute (base, Qcomposition, Qnil);
3196 Lisp_Object ret = Fassq (modifier, alist);
3199 Fput_char_attribute (base, Qcomposition,
3200 Fcons (Fcons (modifier, character),
3203 Fsetcdr (ret, character);
3209 Lisp_Object v = Fcar (value);
3213 Emchar c = XINT (v);
3215 = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil);
3219 Fput_char_attribute (make_char (c), Q_ucs_variants,
3220 Fcons (character, Qnil));
3222 else if (NILP (Fmemq (character, ret)))
3224 Fput_char_attribute (make_char (c), Q_ucs_variants,
3225 Fcons (character, ret));
3231 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3232 Store CHARACTER's ATTRIBUTE with VALUE.
3234 (character, attribute, value))
3236 Lisp_Object ccs = Ffind_charset (attribute);
3238 CHECK_CHAR (character);
3242 value = put_char_ccs_code_point (character, ccs, value);
3243 attribute = XCHARSET_NAME (ccs);
3245 else if (EQ (attribute, Q_decomposition))
3246 put_char_composition (character, value);
3247 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3253 signal_simple_error ("Invalid value for =>ucs", value);
3257 ret = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil);
3260 Fput_char_attribute (make_char (c), Q_ucs_variants,
3261 Fcons (character, Qnil));
3263 else if (NILP (Fmemq (character, ret)))
3265 Fput_char_attribute (make_char (c), Q_ucs_variants,
3266 Fcons (character, ret));
3269 if (EQ (attribute, Q_ucs))
3270 attribute = Qto_ucs;
3274 else if (EQ (attribute, Qideographic_structure))
3275 value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value));
3278 Lisp_Object table = Fgethash (attribute,
3279 Vchar_attribute_hash_table,
3284 table = make_char_id_table (Qunbound);
3285 Fputhash (attribute, table, Vchar_attribute_hash_table);
3286 #ifdef HAVE_CHISE_CLIENT
3287 XCHAR_TABLE_NAME (table) = attribute;
3290 put_char_id_table (XCHAR_TABLE(table), character, value);
3295 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3296 Remove CHARACTER's ATTRIBUTE.
3298 (character, attribute))
3302 CHECK_CHAR (character);
3303 ccs = Ffind_charset (attribute);
3306 return remove_char_ccs (character, ccs);
3310 Lisp_Object table = Fgethash (attribute,
3311 Vchar_attribute_hash_table,
3313 if (!UNBOUNDP (table))
3315 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3322 #ifdef HAVE_CHISE_CLIENT
3324 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3327 Lisp_Object db_dir = Vexec_directory;
3330 db_dir = build_string ("../lib-src");
3332 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3333 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3334 Fmake_directory_internal (db_dir);
3336 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3337 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3338 Fmake_directory_internal (db_dir);
3341 Lisp_Object attribute_name = Fsymbol_name (attribute);
3342 Lisp_Object dest = Qnil, ret;
3344 struct gcpro gcpro1, gcpro2;
3345 int len = XSTRING_CHAR_LENGTH (attribute_name);
3349 for (i = 0; i < len; i++)
3351 Emchar c = string_char (XSTRING (attribute_name), i);
3353 if ( (c == '/') || (c == '%') )
3357 sprintf (str, "%%%02X", c);
3358 dest = concat3 (dest,
3359 Fsubstring (attribute_name,
3360 make_int (base), make_int (i)),
3361 build_string (str));
3365 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3366 dest = concat2 (dest, ret);
3368 return Fexpand_file_name (dest, db_dir);
3371 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3375 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3376 Save values of ATTRIBUTE into database file.
3380 #ifdef HAVE_CHISE_CLIENT
3381 Lisp_Object table = Fgethash (attribute,
3382 Vchar_attribute_hash_table, Qunbound);
3383 Lisp_Char_Table *ct;
3384 Lisp_Object db_file;
3387 if (CHAR_TABLEP (table))
3388 ct = XCHAR_TABLE (table);
3392 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3393 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3396 Lisp_Object (*filter)(Lisp_Object value);
3398 if (EQ (attribute, Qideographic_structure))
3399 filter = &Fchar_refs_simplify_char_specs;
3403 if (UINT8_BYTE_TABLE_P (ct->table))
3404 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db,
3406 else if (UINT16_BYTE_TABLE_P (ct->table))
3407 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db,
3409 else if (BYTE_TABLE_P (ct->table))
3410 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3, filter);
3411 Fclose_database (db);
3421 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3422 Mount database file on char-attribute-table ATTRIBUTE.
3426 #ifdef HAVE_CHISE_CLIENT
3427 Lisp_Object table = Fgethash (attribute,
3428 Vchar_attribute_hash_table, Qunbound);
3430 if (UNBOUNDP (table))
3432 Lisp_Char_Table *ct;
3434 table = make_char_id_table (Qunbound);
3435 Fputhash (attribute, table, Vchar_attribute_hash_table);
3436 XCHAR_TABLE_NAME(table) = attribute;
3437 ct = XCHAR_TABLE (table);
3438 ct->table = Qunloaded;
3439 XCHAR_TABLE_UNLOADED(table) = 1;
3447 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3448 Close database of ATTRIBUTE.
3452 #ifdef HAVE_CHISE_CLIENT
3453 Lisp_Object table = Fgethash (attribute,
3454 Vchar_attribute_hash_table, Qunbound);
3455 Lisp_Char_Table *ct;
3457 if (CHAR_TABLEP (table))
3458 ct = XCHAR_TABLE (table);
3464 if (!NILP (Fdatabase_live_p (ct->db)))
3465 Fclose_database (ct->db);
3472 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3473 Reset values of ATTRIBUTE with database file.
3477 #ifdef HAVE_CHISE_CLIENT
3478 Lisp_Object table = Fgethash (attribute,
3479 Vchar_attribute_hash_table, Qunbound);
3480 Lisp_Char_Table *ct;
3482 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3484 if (!NILP (Ffile_exists_p (db_file)))
3486 if (UNBOUNDP (table))
3488 table = make_char_id_table (Qunbound);
3489 Fputhash (attribute, table, Vchar_attribute_hash_table);
3490 XCHAR_TABLE_NAME(table) = attribute;
3492 ct = XCHAR_TABLE (table);
3493 ct->table = Qunloaded;
3494 if (!NILP (Fdatabase_live_p (ct->db)))
3495 Fclose_database (ct->db);
3497 XCHAR_TABLE_UNLOADED(table) = 1;
3505 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3507 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3509 if (!NILP (attribute))
3511 if (NILP (Fdatabase_live_p (cit->db)))
3514 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3516 cit->db = Fopen_database (db_file, Qnil, Qnil,
3517 build_string ("r"), Qnil);
3519 if (!NILP (cit->db))
3522 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3524 if (!UNBOUNDP (val))
3528 if (!NILP (Vchar_db_stingy_mode))
3530 Fclose_database (cit->db);
3539 Lisp_Char_Table* char_attribute_table_to_load;
3541 Lisp_Object Qload_char_attribute_table_map_function;
3543 DEFUN ("load-char-attribute-table-map-function",
3544 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3545 For internal use. Don't use it.
3549 Lisp_Object c = Fread (key);
3550 Emchar code = XCHAR (c);
3551 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3553 if (EQ (ret, Qunloaded))
3554 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3558 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3559 Load values of ATTRIBUTE into database file.
3563 Lisp_Object table = Fgethash (attribute,
3564 Vchar_attribute_hash_table,
3566 if (CHAR_TABLEP (table))
3568 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3570 if (NILP (Fdatabase_live_p (ct->db)))
3573 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3575 ct->db = Fopen_database (db_file, Qnil, Qnil,
3576 build_string ("r"), Qnil);
3580 struct gcpro gcpro1;
3582 char_attribute_table_to_load = XCHAR_TABLE (table);
3584 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3586 Fclose_database (ct->db);
3588 XCHAR_TABLE_UNLOADED(table) = 0;
3596 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3597 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3598 each key and value in the table.
3600 RANGE specifies a subrange to map over and is in the same format as
3601 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3604 (function, attribute, range))
3607 Lisp_Char_Table *ct;
3608 struct slow_map_char_table_arg slarg;
3609 struct gcpro gcpro1, gcpro2;
3610 struct chartab_range rainj;
3612 if (!NILP (ccs = Ffind_charset (attribute)))
3614 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3616 if (CHAR_TABLEP (encoding_table))
3617 ct = XCHAR_TABLE (encoding_table);
3623 Lisp_Object table = Fgethash (attribute,
3624 Vchar_attribute_hash_table,
3626 if (CHAR_TABLEP (table))
3627 ct = XCHAR_TABLE (table);
3633 decode_char_table_range (range, &rainj);
3634 #ifdef HAVE_CHISE_CLIENT
3635 if (CHAR_TABLE_UNLOADED(ct))
3636 Fload_char_attribute_table (attribute);
3638 slarg.function = function;
3639 slarg.retval = Qnil;
3640 GCPRO2 (slarg.function, slarg.retval);
3641 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3644 return slarg.retval;
3647 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3648 Store character's ATTRIBUTES.
3652 Lisp_Object rest = attributes;
3653 Lisp_Object code = Fcdr (Fassq (Qmap_ucs, attributes));
3654 Lisp_Object character;
3657 code = Fcdr (Fassq (Qucs, attributes));
3660 while (CONSP (rest))
3662 Lisp_Object cell = Fcar (rest);
3666 signal_simple_error ("Invalid argument", attributes);
3667 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3668 && ((XCHARSET_FINAL (ccs) != 0) ||
3669 (XCHARSET_MAX_CODE (ccs) > 0) ||
3670 (EQ (ccs, Vcharset_chinese_big5))) )
3674 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3676 character = Fdecode_char (ccs, cell, Qnil);
3677 if (!NILP (character))
3678 goto setup_attributes;
3682 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3683 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3687 signal_simple_error ("Invalid argument", attributes);
3689 character = make_char (XINT (code) + 0x100000);
3690 goto setup_attributes;
3694 else if (!INTP (code))
3695 signal_simple_error ("Invalid argument", attributes);
3697 character = make_char (XINT (code));
3701 while (CONSP (rest))
3703 Lisp_Object cell = Fcar (rest);
3706 signal_simple_error ("Invalid argument", attributes);
3708 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3714 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3715 Retrieve the character of the given ATTRIBUTES.
3719 Lisp_Object rest = attributes;
3722 while (CONSP (rest))
3724 Lisp_Object cell = Fcar (rest);
3728 signal_simple_error ("Invalid argument", attributes);
3729 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3733 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3735 return Fdecode_char (ccs, cell, Qnil);
3739 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3740 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3743 signal_simple_error ("Invalid argument", attributes);
3745 return make_char (XINT (code) + 0x100000);
3753 /************************************************************************/
3754 /* Char table read syntax */
3755 /************************************************************************/
3758 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3759 Error_behavior errb)
3761 /* #### should deal with ERRB */
3762 symbol_to_char_table_type (value);
3767 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3768 Error_behavior errb)
3772 /* #### should deal with ERRB */
3773 EXTERNAL_LIST_LOOP (rest, value)
3775 Lisp_Object range = XCAR (rest);
3776 struct chartab_range dummy;
3780 signal_simple_error ("Invalid list format", value);
3783 if (!CONSP (XCDR (range))
3784 || !NILP (XCDR (XCDR (range))))
3785 signal_simple_error ("Invalid range format", range);
3786 decode_char_table_range (XCAR (range), &dummy);
3787 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3790 decode_char_table_range (range, &dummy);
3797 chartab_instantiate (Lisp_Object data)
3799 Lisp_Object chartab;
3800 Lisp_Object type = Qgeneric;
3801 Lisp_Object dataval = Qnil;
3803 while (!NILP (data))
3805 Lisp_Object keyw = Fcar (data);
3811 if (EQ (keyw, Qtype))
3813 else if (EQ (keyw, Qdata))
3817 chartab = Fmake_char_table (type);
3820 while (!NILP (data))
3822 Lisp_Object range = Fcar (data);
3823 Lisp_Object val = Fcar (Fcdr (data));
3825 data = Fcdr (Fcdr (data));
3828 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3830 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3831 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3834 for (i = first; i <= last; i++)
3835 Fput_char_table (make_char (i), val, chartab);
3841 Fput_char_table (range, val, chartab);
3850 /************************************************************************/
3851 /* Category Tables, specifically */
3852 /************************************************************************/
3854 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3855 Return t if OBJECT is a category table.
3856 A category table is a type of char table used for keeping track of
3857 categories. Categories are used for classifying characters for use
3858 in regexps -- you can refer to a category rather than having to use
3859 a complicated [] expression (and category lookups are significantly
3862 There are 95 different categories available, one for each printable
3863 character (including space) in the ASCII charset. Each category
3864 is designated by one such character, called a "category designator".
3865 They are specified in a regexp using the syntax "\\cX", where X is
3866 a category designator.
3868 A category table specifies, for each character, the categories that
3869 the character is in. Note that a character can be in more than one
3870 category. More specifically, a category table maps from a character
3871 to either the value nil (meaning the character is in no categories)
3872 or a 95-element bit vector, specifying for each of the 95 categories
3873 whether the character is in that category.
3875 Special Lisp functions are provided that abstract this, so you do not
3876 have to directly manipulate bit vectors.
3880 return (CHAR_TABLEP (object) &&
3881 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3886 check_category_table (Lisp_Object object, Lisp_Object default_)
3890 while (NILP (Fcategory_table_p (object)))
3891 object = wrong_type_argument (Qcategory_table_p, object);
3896 check_category_char (Emchar ch, Lisp_Object table,
3897 unsigned int designator, unsigned int not_p)
3899 REGISTER Lisp_Object temp;
3900 Lisp_Char_Table *ctbl;
3901 #ifdef ERROR_CHECK_TYPECHECK
3902 if (NILP (Fcategory_table_p (table)))
3903 signal_simple_error ("Expected category table", table);
3905 ctbl = XCHAR_TABLE (table);
3906 temp = get_char_table (ch, ctbl);
3911 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3914 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3915 Return t if category of the character at POSITION includes DESIGNATOR.
3916 Optional third arg BUFFER specifies which buffer to use, and defaults
3917 to the current buffer.
3918 Optional fourth arg CATEGORY-TABLE specifies the category table to
3919 use, and defaults to BUFFER's category table.
3921 (position, designator, buffer, category_table))
3926 struct buffer *buf = decode_buffer (buffer, 0);
3928 CHECK_INT (position);
3929 CHECK_CATEGORY_DESIGNATOR (designator);
3930 des = XCHAR (designator);
3931 ctbl = check_category_table (category_table, Vstandard_category_table);
3932 ch = BUF_FETCH_CHAR (buf, XINT (position));
3933 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3936 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3937 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3938 Optional third arg CATEGORY-TABLE specifies the category table to use,
3939 and defaults to the standard category table.
3941 (character, designator, category_table))
3947 CHECK_CATEGORY_DESIGNATOR (designator);
3948 des = XCHAR (designator);
3949 CHECK_CHAR (character);
3950 ch = XCHAR (character);
3951 ctbl = check_category_table (category_table, Vstandard_category_table);
3952 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3955 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3956 Return BUFFER's current category table.
3957 BUFFER defaults to the current buffer.
3961 return decode_buffer (buffer, 0)->category_table;
3964 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3965 Return the standard category table.
3966 This is the one used for new buffers.
3970 return Vstandard_category_table;
3973 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3974 Return a new category table which is a copy of CATEGORY-TABLE.
3975 CATEGORY-TABLE defaults to the standard category table.
3979 if (NILP (Vstandard_category_table))
3980 return Fmake_char_table (Qcategory);
3983 check_category_table (category_table, Vstandard_category_table);
3984 return Fcopy_char_table (category_table);
3987 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3988 Select CATEGORY-TABLE as the new category table for BUFFER.
3989 BUFFER defaults to the current buffer if omitted.
3991 (category_table, buffer))
3993 struct buffer *buf = decode_buffer (buffer, 0);
3994 category_table = check_category_table (category_table, Qnil);
3995 buf->category_table = category_table;
3996 /* Indicate that this buffer now has a specified category table. */
3997 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3998 return category_table;
4001 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
4002 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
4006 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
4009 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
4010 Return t if OBJECT is a category table value.
4011 Valid values are nil or a bit vector of size 95.
4015 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
4019 #define CATEGORYP(x) \
4020 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
4022 #define CATEGORY_SET(c) \
4023 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
4025 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
4026 The faster version of `!NILP (Faref (category_set, category))'. */
4027 #define CATEGORY_MEMBER(category, category_set) \
4028 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
4030 /* Return 1 if there is a word boundary between two word-constituent
4031 characters C1 and C2 if they appear in this order, else return 0.
4032 Use the macro WORD_BOUNDARY_P instead of calling this function
4035 int word_boundary_p (Emchar c1, Emchar c2);
4037 word_boundary_p (Emchar c1, Emchar c2)
4039 Lisp_Object category_set1, category_set2;
4044 if (COMPOSITE_CHAR_P (c1))
4045 c1 = cmpchar_component (c1, 0, 1);
4046 if (COMPOSITE_CHAR_P (c2))
4047 c2 = cmpchar_component (c2, 0, 1);
4050 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4052 tail = Vword_separating_categories;
4057 tail = Vword_combining_categories;
4061 category_set1 = CATEGORY_SET (c1);
4062 if (NILP (category_set1))
4063 return default_result;
4064 category_set2 = CATEGORY_SET (c2);
4065 if (NILP (category_set2))
4066 return default_result;
4068 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4070 Lisp_Object elt = XCONS(tail)->car;
4073 && CATEGORYP (XCONS (elt)->car)
4074 && CATEGORYP (XCONS (elt)->cdr)
4075 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4076 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4077 return !default_result;
4079 return default_result;
4085 syms_of_chartab (void)
4088 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4089 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4090 INIT_LRECORD_IMPLEMENTATION (byte_table);
4092 defsymbol (&Qsystem_char_id, "system-char-id");
4094 defsymbol (&Qto_ucs, "=>ucs");
4095 defsymbol (&Q_ucs, "->ucs");
4096 defsymbol (&Q_ucs_variants, "->ucs-variants");
4097 defsymbol (&Qcomposition, "composition");
4098 defsymbol (&Q_decomposition, "->decomposition");
4099 defsymbol (&Qcompat, "compat");
4100 defsymbol (&Qisolated, "isolated");
4101 defsymbol (&Qinitial, "initial");
4102 defsymbol (&Qmedial, "medial");
4103 defsymbol (&Qfinal, "final");
4104 defsymbol (&Qvertical, "vertical");
4105 defsymbol (&QnoBreak, "noBreak");
4106 defsymbol (&Qfraction, "fraction");
4107 defsymbol (&Qsuper, "super");
4108 defsymbol (&Qsub, "sub");
4109 defsymbol (&Qcircle, "circle");
4110 defsymbol (&Qsquare, "square");
4111 defsymbol (&Qwide, "wide");
4112 defsymbol (&Qnarrow, "narrow");
4113 defsymbol (&Qsmall, "small");
4114 defsymbol (&Qfont, "font");
4116 DEFSUBR (Fchar_attribute_list);
4117 DEFSUBR (Ffind_char_attribute_table);
4118 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4119 DEFSUBR (Fput_char_table_map_function);
4120 #ifdef HAVE_CHISE_CLIENT
4121 DEFSUBR (Fsave_char_attribute_table);
4122 DEFSUBR (Fmount_char_attribute_table);
4123 DEFSUBR (Freset_char_attribute_table);
4124 DEFSUBR (Fclose_char_attribute_table);
4125 defsymbol (&Qload_char_attribute_table_map_function,
4126 "load-char-attribute-table-map-function");
4127 DEFSUBR (Fload_char_attribute_table_map_function);
4128 DEFSUBR (Fload_char_attribute_table);
4130 DEFSUBR (Fchar_attribute_alist);
4131 DEFSUBR (Fget_char_attribute);
4132 DEFSUBR (Fput_char_attribute);
4133 DEFSUBR (Fremove_char_attribute);
4134 DEFSUBR (Fmap_char_attribute);
4135 DEFSUBR (Fdefine_char);
4136 DEFSUBR (Ffind_char);
4137 DEFSUBR (Fchar_variants);
4139 DEFSUBR (Fget_composite_char);
4142 INIT_LRECORD_IMPLEMENTATION (char_table);
4146 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4149 defsymbol (&Qcategory_table_p, "category-table-p");
4150 defsymbol (&Qcategory_designator_p, "category-designator-p");
4151 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4154 defsymbol (&Qchar_table, "char-table");
4155 defsymbol (&Qchar_tablep, "char-table-p");
4157 DEFSUBR (Fchar_table_p);
4158 DEFSUBR (Fchar_table_type_list);
4159 DEFSUBR (Fvalid_char_table_type_p);
4160 DEFSUBR (Fchar_table_type);
4161 DEFSUBR (Freset_char_table);
4162 DEFSUBR (Fmake_char_table);
4163 DEFSUBR (Fcopy_char_table);
4164 DEFSUBR (Fget_char_table);
4165 DEFSUBR (Fget_range_char_table);
4166 DEFSUBR (Fvalid_char_table_value_p);
4167 DEFSUBR (Fcheck_valid_char_table_value);
4168 DEFSUBR (Fput_char_table);
4169 DEFSUBR (Fmap_char_table);
4172 DEFSUBR (Fcategory_table_p);
4173 DEFSUBR (Fcategory_table);
4174 DEFSUBR (Fstandard_category_table);
4175 DEFSUBR (Fcopy_category_table);
4176 DEFSUBR (Fset_category_table);
4177 DEFSUBR (Fcheck_category_at);
4178 DEFSUBR (Fchar_in_category_p);
4179 DEFSUBR (Fcategory_designator_p);
4180 DEFSUBR (Fcategory_table_value_p);
4186 vars_of_chartab (void)
4189 #ifdef HAVE_CHISE_CLIENT
4190 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4192 Vchar_db_stingy_mode = Qt;
4193 #endif /* HAVE_CHISE_CLIENT */
4195 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4196 Vall_syntax_tables = Qnil;
4197 dump_add_weak_object_chain (&Vall_syntax_tables);
4201 structure_type_create_chartab (void)
4203 struct structure_type *st;
4205 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4207 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4208 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4212 complex_vars_of_chartab (void)
4215 staticpro (&Vchar_attribute_hash_table);
4216 Vchar_attribute_hash_table
4217 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4218 #endif /* UTF2000 */
4220 /* Set this now, so first buffer creation can refer to it. */
4221 /* Make it nil before calling copy-category-table
4222 so that copy-category-table will know not to try to copy from garbage */
4223 Vstandard_category_table = Qnil;
4224 Vstandard_category_table = Fcopy_category_table (Qnil);
4225 staticpro (&Vstandard_category_table);
4227 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4228 List of pair (cons) of categories to determine word boundary.
4230 Emacs treats a sequence of word constituent characters as a single
4231 word (i.e. finds no word boundary between them) iff they belongs to
4232 the same charset. But, exceptions are allowed in the following cases.
4234 \(1) The case that characters are in different charsets is controlled
4235 by the variable `word-combining-categories'.
4237 Emacs finds no word boundary between characters of different charsets
4238 if they have categories matching some element of this list.
4240 More precisely, if an element of this list is a cons of category CAT1
4241 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4242 C2 which has CAT2, there's no word boundary between C1 and C2.
4244 For instance, to tell that ASCII characters and Latin-1 characters can
4245 form a single word, the element `(?l . ?l)' should be in this list
4246 because both characters have the category `l' (Latin characters).
4248 \(2) The case that character are in the same charset is controlled by
4249 the variable `word-separating-categories'.
4251 Emacs find a word boundary between characters of the same charset
4252 if they have categories matching some element of this list.
4254 More precisely, if an element of this list is a cons of category CAT1
4255 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4256 C2 which has CAT2, there's a word boundary between C1 and C2.
4258 For instance, to tell that there's a word boundary between Japanese
4259 Hiragana and Japanese Kanji (both are in the same charset), the
4260 element `(?H . ?C) should be in this list.
4263 Vword_combining_categories = Qnil;
4265 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4266 List of pair (cons) of categories to determine word boundary.
4267 See the documentation of the variable `word-combining-categories'.
4270 Vword_separating_categories = Qnil;