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;
1076 Lisp_Object Q_ucs_unified;
1077 Lisp_Object Qcompat;
1078 Lisp_Object Qisolated;
1079 Lisp_Object Qinitial;
1080 Lisp_Object Qmedial;
1082 Lisp_Object Qvertical;
1083 Lisp_Object QnoBreak;
1084 Lisp_Object Qfraction;
1087 Lisp_Object Qcircle;
1088 Lisp_Object Qsquare;
1090 Lisp_Object Qnarrow;
1094 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1097 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1103 else if (EQ (v, Qcompat))
1105 else if (EQ (v, Qisolated))
1107 else if (EQ (v, Qinitial))
1109 else if (EQ (v, Qmedial))
1111 else if (EQ (v, Qfinal))
1113 else if (EQ (v, Qvertical))
1115 else if (EQ (v, QnoBreak))
1117 else if (EQ (v, Qfraction))
1119 else if (EQ (v, Qsuper))
1121 else if (EQ (v, Qsub))
1123 else if (EQ (v, Qcircle))
1125 else if (EQ (v, Qsquare))
1127 else if (EQ (v, Qwide))
1129 else if (EQ (v, Qnarrow))
1131 else if (EQ (v, Qsmall))
1133 else if (EQ (v, Qfont))
1136 signal_simple_error (err_msg, err_arg);
1139 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1140 Return character corresponding with list.
1144 Lisp_Object base, modifier;
1148 signal_simple_error ("Invalid value for composition", list);
1151 while (!NILP (rest))
1156 signal_simple_error ("Invalid value for composition", list);
1157 modifier = Fcar (rest);
1159 base = Fcdr (Fassq (modifier,
1160 Fget_char_attribute (base, Qcomposition, Qnil)));
1165 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1166 Return variants of CHARACTER.
1172 CHECK_CHAR (character);
1173 ret = Fget_char_attribute (character, Q_ucs_unified, Qnil);
1175 return Fcopy_list (ret);
1183 /* A char table maps from ranges of characters to values.
1185 Implementing a general data structure that maps from arbitrary
1186 ranges of numbers to values is tricky to do efficiently. As it
1187 happens, it should suffice (and is usually more convenient, anyway)
1188 when dealing with characters to restrict the sorts of ranges that
1189 can be assigned values, as follows:
1192 2) All characters in a charset.
1193 3) All characters in a particular row of a charset, where a "row"
1194 means all characters with the same first byte.
1195 4) A particular character in a charset.
1197 We use char tables to generalize the 256-element vectors now
1198 littering the Emacs code.
1200 Possible uses (all should be converted at some point):
1206 5) keyboard-translate-table?
1209 abstract type to generalize the Emacs vectors and Mule
1210 vectors-of-vectors goo.
1213 /************************************************************************/
1214 /* Char Table object */
1215 /************************************************************************/
1217 #if defined(MULE)&&!defined(UTF2000)
1220 mark_char_table_entry (Lisp_Object obj)
1222 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1225 for (i = 0; i < 96; i++)
1227 mark_object (cte->level2[i]);
1233 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1235 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1236 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1239 for (i = 0; i < 96; i++)
1240 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1246 static unsigned long
1247 char_table_entry_hash (Lisp_Object obj, int depth)
1249 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1251 return internal_array_hash (cte->level2, 96, depth);
1254 static const struct lrecord_description char_table_entry_description[] = {
1255 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1259 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1260 mark_char_table_entry, internal_object_printer,
1261 0, char_table_entry_equal,
1262 char_table_entry_hash,
1263 char_table_entry_description,
1264 Lisp_Char_Table_Entry);
1268 mark_char_table (Lisp_Object obj)
1270 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1273 mark_object (ct->table);
1274 mark_object (ct->name);
1275 mark_object (ct->db);
1279 for (i = 0; i < NUM_ASCII_CHARS; i++)
1280 mark_object (ct->ascii[i]);
1282 for (i = 0; i < NUM_LEADING_BYTES; i++)
1283 mark_object (ct->level1[i]);
1287 return ct->default_value;
1289 return ct->mirror_table;
1293 /* WARNING: All functions of this nature need to be written extremely
1294 carefully to avoid crashes during GC. Cf. prune_specifiers()
1295 and prune_weak_hash_tables(). */
1298 prune_syntax_tables (void)
1300 Lisp_Object rest, prev = Qnil;
1302 for (rest = Vall_syntax_tables;
1304 rest = XCHAR_TABLE (rest)->next_table)
1306 if (! marked_p (rest))
1308 /* This table is garbage. Remove it from the list. */
1310 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1312 XCHAR_TABLE (prev)->next_table =
1313 XCHAR_TABLE (rest)->next_table;
1319 char_table_type_to_symbol (enum char_table_type type)
1324 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1325 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1326 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1327 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1329 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1334 static enum char_table_type
1335 symbol_to_char_table_type (Lisp_Object symbol)
1337 CHECK_SYMBOL (symbol);
1339 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1340 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1341 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1342 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1344 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1347 signal_simple_error ("Unrecognized char table type", symbol);
1348 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1352 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1353 Lisp_Object printcharfun)
1357 write_c_string (" (", printcharfun);
1358 print_internal (make_char (first), printcharfun, 0);
1359 write_c_string (" ", printcharfun);
1360 print_internal (make_char (last), printcharfun, 0);
1361 write_c_string (") ", printcharfun);
1365 write_c_string (" ", printcharfun);
1366 print_internal (make_char (first), printcharfun, 0);
1367 write_c_string (" ", printcharfun);
1369 print_internal (val, printcharfun, 1);
1372 #if defined(MULE)&&!defined(UTF2000)
1375 print_chartab_charset_row (Lisp_Object charset,
1377 Lisp_Char_Table_Entry *cte,
1378 Lisp_Object printcharfun)
1381 Lisp_Object cat = Qunbound;
1384 for (i = 32; i < 128; i++)
1386 Lisp_Object pam = cte->level2[i - 32];
1398 print_chartab_range (MAKE_CHAR (charset, first, 0),
1399 MAKE_CHAR (charset, i - 1, 0),
1402 print_chartab_range (MAKE_CHAR (charset, row, first),
1403 MAKE_CHAR (charset, row, i - 1),
1413 print_chartab_range (MAKE_CHAR (charset, first, 0),
1414 MAKE_CHAR (charset, i - 1, 0),
1417 print_chartab_range (MAKE_CHAR (charset, row, first),
1418 MAKE_CHAR (charset, row, i - 1),
1424 print_chartab_two_byte_charset (Lisp_Object charset,
1425 Lisp_Char_Table_Entry *cte,
1426 Lisp_Object printcharfun)
1430 for (i = 32; i < 128; i++)
1432 Lisp_Object jen = cte->level2[i - 32];
1434 if (!CHAR_TABLE_ENTRYP (jen))
1438 write_c_string (" [", printcharfun);
1439 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1440 sprintf (buf, " %d] ", i);
1441 write_c_string (buf, printcharfun);
1442 print_internal (jen, printcharfun, 0);
1445 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1453 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1455 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1458 struct gcpro gcpro1, gcpro2;
1459 GCPRO2 (obj, printcharfun);
1461 write_c_string ("#s(char-table ", printcharfun);
1462 write_c_string (" ", printcharfun);
1463 write_c_string (string_data
1465 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1467 write_c_string ("\n ", printcharfun);
1468 print_internal (ct->default_value, printcharfun, escapeflag);
1469 for (i = 0; i < 256; i++)
1471 Lisp_Object elt = get_byte_table (ct->table, i);
1472 if (i != 0) write_c_string ("\n ", printcharfun);
1473 if (EQ (elt, Qunbound))
1474 write_c_string ("void", printcharfun);
1476 print_internal (elt, printcharfun, escapeflag);
1479 #else /* non UTF2000 */
1482 sprintf (buf, "#s(char-table type %s data (",
1483 string_data (symbol_name (XSYMBOL
1484 (char_table_type_to_symbol (ct->type)))));
1485 write_c_string (buf, printcharfun);
1487 /* Now write out the ASCII/Control-1 stuff. */
1491 Lisp_Object val = Qunbound;
1493 for (i = 0; i < NUM_ASCII_CHARS; i++)
1502 if (!EQ (ct->ascii[i], val))
1504 print_chartab_range (first, i - 1, val, printcharfun);
1511 print_chartab_range (first, i - 1, val, printcharfun);
1518 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1521 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1522 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1524 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1525 || i == LEADING_BYTE_CONTROL_1)
1527 if (!CHAR_TABLE_ENTRYP (ann))
1529 write_c_string (" ", printcharfun);
1530 print_internal (XCHARSET_NAME (charset),
1532 write_c_string (" ", printcharfun);
1533 print_internal (ann, printcharfun, 0);
1537 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1538 if (XCHARSET_DIMENSION (charset) == 1)
1539 print_chartab_charset_row (charset, -1, cte, printcharfun);
1541 print_chartab_two_byte_charset (charset, cte, printcharfun);
1546 #endif /* non UTF2000 */
1548 write_c_string ("))", printcharfun);
1552 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1554 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1555 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1558 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1562 for (i = 0; i < 256; i++)
1564 if (!internal_equal (get_byte_table (ct1->table, i),
1565 get_byte_table (ct2->table, i), 0))
1569 for (i = 0; i < NUM_ASCII_CHARS; i++)
1570 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1574 for (i = 0; i < NUM_LEADING_BYTES; i++)
1575 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1578 #endif /* non UTF2000 */
1583 static unsigned long
1584 char_table_hash (Lisp_Object obj, int depth)
1586 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1588 return byte_table_hash (ct->table, depth + 1);
1590 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1593 hashval = HASH2 (hashval,
1594 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1600 static const struct lrecord_description char_table_description[] = {
1602 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1603 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1604 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1605 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1607 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1609 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1613 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1615 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1619 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1620 mark_char_table, print_char_table, 0,
1621 char_table_equal, char_table_hash,
1622 char_table_description,
1625 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1626 Return non-nil if OBJECT is a char table.
1628 A char table is a table that maps characters (or ranges of characters)
1629 to values. Char tables are specialized for characters, only allowing
1630 particular sorts of ranges to be assigned values. Although this
1631 loses in generality, it makes for extremely fast (constant-time)
1632 lookups, and thus is feasible for applications that do an extremely
1633 large number of lookups (e.g. scanning a buffer for a character in
1634 a particular syntax, where a lookup in the syntax table must occur
1635 once per character).
1637 When Mule support exists, the types of ranges that can be assigned
1641 -- an entire charset
1642 -- a single row in a two-octet charset
1643 -- a single character
1645 When Mule support is not present, the types of ranges that can be
1649 -- a single character
1651 To create a char table, use `make-char-table'.
1652 To modify a char table, use `put-char-table' or `remove-char-table'.
1653 To retrieve the value for a particular character, use `get-char-table'.
1654 See also `map-char-table', `clear-char-table', `copy-char-table',
1655 `valid-char-table-type-p', `char-table-type-list',
1656 `valid-char-table-value-p', and `check-char-table-value'.
1660 return CHAR_TABLEP (object) ? Qt : Qnil;
1663 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1664 Return a list of the recognized char table types.
1665 See `valid-char-table-type-p'.
1670 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1672 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1676 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1677 Return t if TYPE if a recognized char table type.
1679 Each char table type is used for a different purpose and allows different
1680 sorts of values. The different char table types are
1683 Used for category tables, which specify the regexp categories
1684 that a character is in. The valid values are nil or a
1685 bit vector of 95 elements. Higher-level Lisp functions are
1686 provided for working with category tables. Currently categories
1687 and category tables only exist when Mule support is present.
1689 A generalized char table, for mapping from one character to
1690 another. Used for case tables, syntax matching tables,
1691 `keyboard-translate-table', etc. The valid values are characters.
1693 An even more generalized char table, for mapping from a
1694 character to anything.
1696 Used for display tables, which specify how a particular character
1697 is to appear when displayed. #### Not yet implemented.
1699 Used for syntax tables, which specify the syntax of a particular
1700 character. Higher-level Lisp functions are provided for
1701 working with syntax tables. The valid values are integers.
1706 return (EQ (type, Qchar) ||
1708 EQ (type, Qcategory) ||
1710 EQ (type, Qdisplay) ||
1711 EQ (type, Qgeneric) ||
1712 EQ (type, Qsyntax)) ? Qt : Qnil;
1715 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1716 Return the type of CHAR-TABLE.
1717 See `valid-char-table-type-p'.
1721 CHECK_CHAR_TABLE (char_table);
1722 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1726 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1729 ct->table = Qunbound;
1730 ct->default_value = value;
1735 for (i = 0; i < NUM_ASCII_CHARS; i++)
1736 ct->ascii[i] = value;
1738 for (i = 0; i < NUM_LEADING_BYTES; i++)
1739 ct->level1[i] = value;
1744 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1745 update_syntax_table (ct);
1749 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1750 Reset CHAR-TABLE to its default state.
1754 Lisp_Char_Table *ct;
1756 CHECK_CHAR_TABLE (char_table);
1757 ct = XCHAR_TABLE (char_table);
1761 case CHAR_TABLE_TYPE_CHAR:
1762 fill_char_table (ct, make_char (0));
1764 case CHAR_TABLE_TYPE_DISPLAY:
1765 case CHAR_TABLE_TYPE_GENERIC:
1767 case CHAR_TABLE_TYPE_CATEGORY:
1769 fill_char_table (ct, Qnil);
1772 case CHAR_TABLE_TYPE_SYNTAX:
1773 fill_char_table (ct, make_int (Sinherit));
1783 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1784 Return a new, empty char table of type TYPE.
1785 Currently recognized types are 'char, 'category, 'display, 'generic,
1786 and 'syntax. See `valid-char-table-type-p'.
1790 Lisp_Char_Table *ct;
1792 enum char_table_type ty = symbol_to_char_table_type (type);
1794 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1797 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1799 ct->mirror_table = Fmake_char_table (Qgeneric);
1800 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1804 ct->mirror_table = Qnil;
1809 ct->next_table = Qnil;
1810 XSETCHAR_TABLE (obj, ct);
1811 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1813 ct->next_table = Vall_syntax_tables;
1814 Vall_syntax_tables = obj;
1816 Freset_char_table (obj);
1820 #if defined(MULE)&&!defined(UTF2000)
1823 make_char_table_entry (Lisp_Object initval)
1827 Lisp_Char_Table_Entry *cte =
1828 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1830 for (i = 0; i < 96; i++)
1831 cte->level2[i] = initval;
1833 XSETCHAR_TABLE_ENTRY (obj, cte);
1838 copy_char_table_entry (Lisp_Object entry)
1840 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1843 Lisp_Char_Table_Entry *ctenew =
1844 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1846 for (i = 0; i < 96; i++)
1848 Lisp_Object new = cte->level2[i];
1849 if (CHAR_TABLE_ENTRYP (new))
1850 ctenew->level2[i] = copy_char_table_entry (new);
1852 ctenew->level2[i] = new;
1855 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1861 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1862 Return a new char table which is a copy of CHAR-TABLE.
1863 It will contain the same values for the same characters and ranges
1864 as CHAR-TABLE. The values will not themselves be copied.
1868 Lisp_Char_Table *ct, *ctnew;
1874 CHECK_CHAR_TABLE (char_table);
1875 ct = XCHAR_TABLE (char_table);
1876 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1877 ctnew->type = ct->type;
1879 ctnew->default_value = ct->default_value;
1880 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1881 ctnew->name = ct->name;
1884 if (UINT8_BYTE_TABLE_P (ct->table))
1886 ctnew->table = copy_uint8_byte_table (ct->table);
1888 else if (UINT16_BYTE_TABLE_P (ct->table))
1890 ctnew->table = copy_uint16_byte_table (ct->table);
1892 else if (BYTE_TABLE_P (ct->table))
1894 ctnew->table = copy_byte_table (ct->table);
1896 else if (!UNBOUNDP (ct->table))
1897 ctnew->table = ct->table;
1898 #else /* non UTF2000 */
1900 for (i = 0; i < NUM_ASCII_CHARS; i++)
1902 Lisp_Object new = ct->ascii[i];
1904 assert (! (CHAR_TABLE_ENTRYP (new)));
1906 ctnew->ascii[i] = new;
1911 for (i = 0; i < NUM_LEADING_BYTES; i++)
1913 Lisp_Object new = ct->level1[i];
1914 if (CHAR_TABLE_ENTRYP (new))
1915 ctnew->level1[i] = copy_char_table_entry (new);
1917 ctnew->level1[i] = new;
1921 #endif /* non UTF2000 */
1924 if (CHAR_TABLEP (ct->mirror_table))
1925 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1927 ctnew->mirror_table = ct->mirror_table;
1929 ctnew->next_table = Qnil;
1930 XSETCHAR_TABLE (obj, ctnew);
1931 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1933 ctnew->next_table = Vall_syntax_tables;
1934 Vall_syntax_tables = obj;
1939 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1941 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1943 switch (XCHARSET_CHARS (ccs))
1946 return (33 << 8) | 126;
1948 return (32 << 8) | 127;
1951 return (0 << 8) | 127;
1953 return (0 << 8) | 255;
1965 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1968 outrange->type = CHARTAB_RANGE_ALL;
1970 else if (EQ (range, Qnil))
1971 outrange->type = CHARTAB_RANGE_DEFAULT;
1973 else if (CHAR_OR_CHAR_INTP (range))
1975 outrange->type = CHARTAB_RANGE_CHAR;
1976 outrange->ch = XCHAR_OR_CHAR_INT (range);
1980 signal_simple_error ("Range must be t or a character", range);
1982 else if (VECTORP (range))
1984 Lisp_Vector *vec = XVECTOR (range);
1985 Lisp_Object *elts = vector_data (vec);
1986 int cell_min, cell_max;
1988 outrange->type = CHARTAB_RANGE_ROW;
1989 outrange->charset = Fget_charset (elts[0]);
1990 CHECK_INT (elts[1]);
1991 outrange->row = XINT (elts[1]);
1992 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1993 signal_simple_error ("Charset in row vector must be multi-byte",
1997 int ret = XCHARSET_CELL_RANGE (outrange->charset);
1999 cell_min = ret >> 8;
2000 cell_max = ret & 0xFF;
2002 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2003 check_int_range (outrange->row, cell_min, cell_max);
2005 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2007 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2008 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2010 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2012 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2013 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2014 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2022 if (!CHARSETP (range) && !SYMBOLP (range))
2024 ("Char table range must be t, charset, char, or vector", range);
2025 outrange->type = CHARTAB_RANGE_CHARSET;
2026 outrange->charset = Fget_charset (range);
2031 #if defined(MULE)&&!defined(UTF2000)
2033 /* called from CHAR_TABLE_VALUE(). */
2035 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2040 Lisp_Object charset;
2042 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2047 BREAKUP_CHAR (c, charset, byte1, byte2);
2049 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2051 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2052 if (CHAR_TABLE_ENTRYP (val))
2054 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2055 val = cte->level2[byte1 - 32];
2056 if (CHAR_TABLE_ENTRYP (val))
2058 cte = XCHAR_TABLE_ENTRY (val);
2059 assert (byte2 >= 32);
2060 val = cte->level2[byte2 - 32];
2061 assert (!CHAR_TABLE_ENTRYP (val));
2071 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2075 Lisp_Object ret = get_char_id_table (ct, ch);
2077 #ifdef HAVE_CHISE_CLIENT
2080 if (EQ (CHAR_TABLE_NAME (ct), Qdowncase))
2081 ret = Fget_char_attribute (make_char (ch), Q_lowercase, Qnil);
2082 else if (EQ (CHAR_TABLE_NAME (ct), Qflippedcase))
2083 ret = Fget_char_attribute (make_char (ch), Q_uppercase, Qnil);
2088 ret = Ffind_char (ret);
2096 Lisp_Object charset;
2100 BREAKUP_CHAR (ch, charset, byte1, byte2);
2102 if (EQ (charset, Vcharset_ascii))
2103 val = ct->ascii[byte1];
2104 else if (EQ (charset, Vcharset_control_1))
2105 val = ct->ascii[byte1 + 128];
2108 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2109 val = ct->level1[lb];
2110 if (CHAR_TABLE_ENTRYP (val))
2112 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2113 val = cte->level2[byte1 - 32];
2114 if (CHAR_TABLE_ENTRYP (val))
2116 cte = XCHAR_TABLE_ENTRY (val);
2117 assert (byte2 >= 32);
2118 val = cte->level2[byte2 - 32];
2119 assert (!CHAR_TABLE_ENTRYP (val));
2126 #else /* not MULE */
2127 return ct->ascii[(unsigned char)ch];
2128 #endif /* not MULE */
2132 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2133 Find value for CHARACTER in CHAR-TABLE.
2135 (character, char_table))
2137 CHECK_CHAR_TABLE (char_table);
2138 CHECK_CHAR_COERCE_INT (character);
2140 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2143 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2144 Find value for a range in CHAR-TABLE.
2145 If there is more than one value, return MULTI (defaults to nil).
2147 (range, char_table, multi))
2149 Lisp_Char_Table *ct;
2150 struct chartab_range rainj;
2152 if (CHAR_OR_CHAR_INTP (range))
2153 return Fget_char_table (range, char_table);
2154 CHECK_CHAR_TABLE (char_table);
2155 ct = XCHAR_TABLE (char_table);
2157 decode_char_table_range (range, &rainj);
2160 case CHARTAB_RANGE_ALL:
2163 if (UINT8_BYTE_TABLE_P (ct->table))
2165 else if (UINT16_BYTE_TABLE_P (ct->table))
2167 else if (BYTE_TABLE_P (ct->table))
2171 #else /* non UTF2000 */
2173 Lisp_Object first = ct->ascii[0];
2175 for (i = 1; i < NUM_ASCII_CHARS; i++)
2176 if (!EQ (first, ct->ascii[i]))
2180 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2183 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2184 || i == LEADING_BYTE_ASCII
2185 || i == LEADING_BYTE_CONTROL_1)
2187 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2193 #endif /* non UTF2000 */
2197 case CHARTAB_RANGE_CHARSET:
2201 if (EQ (rainj.charset, Vcharset_ascii))
2204 Lisp_Object first = ct->ascii[0];
2206 for (i = 1; i < 128; i++)
2207 if (!EQ (first, ct->ascii[i]))
2212 if (EQ (rainj.charset, Vcharset_control_1))
2215 Lisp_Object first = ct->ascii[128];
2217 for (i = 129; i < 160; i++)
2218 if (!EQ (first, ct->ascii[i]))
2224 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2226 if (CHAR_TABLE_ENTRYP (val))
2232 case CHARTAB_RANGE_ROW:
2237 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2239 if (!CHAR_TABLE_ENTRYP (val))
2241 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2242 if (CHAR_TABLE_ENTRYP (val))
2246 #endif /* not UTF2000 */
2247 #endif /* not MULE */
2253 return Qnil; /* not reached */
2257 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2258 Error_behavior errb)
2262 case CHAR_TABLE_TYPE_SYNTAX:
2263 if (!ERRB_EQ (errb, ERROR_ME))
2264 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2265 && CHAR_OR_CHAR_INTP (XCDR (value)));
2268 Lisp_Object cdr = XCDR (value);
2269 CHECK_INT (XCAR (value));
2270 CHECK_CHAR_COERCE_INT (cdr);
2277 case CHAR_TABLE_TYPE_CATEGORY:
2278 if (!ERRB_EQ (errb, ERROR_ME))
2279 return CATEGORY_TABLE_VALUEP (value);
2280 CHECK_CATEGORY_TABLE_VALUE (value);
2284 case CHAR_TABLE_TYPE_GENERIC:
2287 case CHAR_TABLE_TYPE_DISPLAY:
2289 maybe_signal_simple_error ("Display char tables not yet implemented",
2290 value, Qchar_table, errb);
2293 case CHAR_TABLE_TYPE_CHAR:
2294 if (!ERRB_EQ (errb, ERROR_ME))
2295 return CHAR_OR_CHAR_INTP (value);
2296 CHECK_CHAR_COERCE_INT (value);
2303 return 0; /* not reached */
2307 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2311 case CHAR_TABLE_TYPE_SYNTAX:
2314 Lisp_Object car = XCAR (value);
2315 Lisp_Object cdr = XCDR (value);
2316 CHECK_CHAR_COERCE_INT (cdr);
2317 return Fcons (car, cdr);
2320 case CHAR_TABLE_TYPE_CHAR:
2321 CHECK_CHAR_COERCE_INT (value);
2329 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2330 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2332 (value, char_table_type))
2334 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2336 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2339 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2340 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2342 (value, char_table_type))
2344 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2346 check_valid_char_table_value (value, type, ERROR_ME);
2351 Lisp_Char_Table* char_attribute_table_to_put;
2352 Lisp_Object Qput_char_table_map_function;
2353 Lisp_Object value_to_put;
2355 DEFUN ("put-char-table-map-function",
2356 Fput_char_table_map_function, 2, 2, 0, /*
2357 For internal use. Don't use it.
2361 put_char_id_table_0 (char_attribute_table_to_put,
2362 XCHAR (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 Lisp_Object mother = XCHARSET_MOTHER (range->charset);
2400 char_attribute_table_to_put = ct;
2402 Fmap_char_attribute (Qput_char_table_map_function,
2403 XCHAR_TABLE_NAME (encoding_table),
2405 if ( CHARSETP (mother) )
2407 struct chartab_range r;
2409 r.type = CHARTAB_RANGE_CHARSET;
2411 put_char_table (ct, &r, val);
2419 for (c = 0; c < 1 << 24; c++)
2421 if ( charset_code_point (range->charset, c) >= 0 )
2422 put_char_id_table_0 (ct, c, val);
2428 if (EQ (range->charset, Vcharset_ascii))
2431 for (i = 0; i < 128; i++)
2434 else if (EQ (range->charset, Vcharset_control_1))
2437 for (i = 128; i < 160; i++)
2442 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2443 ct->level1[lb] = val;
2448 case CHARTAB_RANGE_ROW:
2451 int cell_min, cell_max, i;
2453 i = XCHARSET_CELL_RANGE (range->charset);
2455 cell_max = i & 0xFF;
2456 for (i = cell_min; i <= cell_max; i++)
2458 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2460 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2461 put_char_id_table_0 (ct, ch, val);
2466 Lisp_Char_Table_Entry *cte;
2467 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2468 /* make sure that there is a separate entry for the row. */
2469 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2470 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2471 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2472 cte->level2[range->row - 32] = val;
2474 #endif /* not UTF2000 */
2478 case CHARTAB_RANGE_CHAR:
2480 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2481 put_char_id_table_0 (ct, range->ch, val);
2485 Lisp_Object charset;
2488 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2489 if (EQ (charset, Vcharset_ascii))
2490 ct->ascii[byte1] = val;
2491 else if (EQ (charset, Vcharset_control_1))
2492 ct->ascii[byte1 + 128] = val;
2495 Lisp_Char_Table_Entry *cte;
2496 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2497 /* make sure that there is a separate entry for the row. */
2498 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2499 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2500 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2501 /* now CTE is a char table entry for the charset;
2502 each entry is for a single row (or character of
2503 a one-octet charset). */
2504 if (XCHARSET_DIMENSION (charset) == 1)
2505 cte->level2[byte1 - 32] = val;
2508 /* assigning to one character in a two-octet charset. */
2509 /* make sure that the charset row contains a separate
2510 entry for each character. */
2511 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2512 cte->level2[byte1 - 32] =
2513 make_char_table_entry (cte->level2[byte1 - 32]);
2514 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2515 cte->level2[byte2 - 32] = val;
2519 #else /* not MULE */
2520 ct->ascii[(unsigned char) (range->ch)] = val;
2522 #endif /* not MULE */
2526 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2527 update_syntax_table (ct);
2531 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2532 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2534 RANGE specifies one or more characters to be affected and should be
2535 one of the following:
2537 -- t (all characters are affected)
2538 -- A charset (only allowed when Mule support is present)
2539 -- A vector of two elements: a two-octet charset and a row number
2540 (only allowed when Mule support is present)
2541 -- A single character
2543 VALUE must be a value appropriate for the type of CHAR-TABLE.
2544 See `valid-char-table-type-p'.
2546 (range, value, char_table))
2548 Lisp_Char_Table *ct;
2549 struct chartab_range rainj;
2551 CHECK_CHAR_TABLE (char_table);
2552 ct = XCHAR_TABLE (char_table);
2553 check_valid_char_table_value (value, ct->type, ERROR_ME);
2554 decode_char_table_range (range, &rainj);
2555 value = canonicalize_char_table_value (value, ct->type);
2556 put_char_table (ct, &rainj, value);
2561 /* Map FN over the ASCII chars in CT. */
2564 map_over_charset_ascii (Lisp_Char_Table *ct,
2565 int (*fn) (struct chartab_range *range,
2566 Lisp_Object val, void *arg),
2569 struct chartab_range rainj;
2578 rainj.type = CHARTAB_RANGE_CHAR;
2580 for (i = start, retval = 0; i < stop && retval == 0; i++)
2582 rainj.ch = (Emchar) i;
2583 retval = (fn) (&rainj, ct->ascii[i], arg);
2591 /* Map FN over the Control-1 chars in CT. */
2594 map_over_charset_control_1 (Lisp_Char_Table *ct,
2595 int (*fn) (struct chartab_range *range,
2596 Lisp_Object val, void *arg),
2599 struct chartab_range rainj;
2602 int stop = start + 32;
2604 rainj.type = CHARTAB_RANGE_CHAR;
2606 for (i = start, retval = 0; i < stop && retval == 0; i++)
2608 rainj.ch = (Emchar) (i);
2609 retval = (fn) (&rainj, ct->ascii[i], arg);
2615 /* Map FN over the row ROW of two-byte charset CHARSET.
2616 There must be a separate value for that row in the char table.
2617 CTE specifies the char table entry for CHARSET. */
2620 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2621 Lisp_Object charset, int row,
2622 int (*fn) (struct chartab_range *range,
2623 Lisp_Object val, void *arg),
2626 Lisp_Object val = cte->level2[row - 32];
2628 if (!CHAR_TABLE_ENTRYP (val))
2630 struct chartab_range rainj;
2632 rainj.type = CHARTAB_RANGE_ROW;
2633 rainj.charset = charset;
2635 return (fn) (&rainj, val, arg);
2639 struct chartab_range rainj;
2641 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2642 int start = charset94_p ? 33 : 32;
2643 int stop = charset94_p ? 127 : 128;
2645 cte = XCHAR_TABLE_ENTRY (val);
2647 rainj.type = CHARTAB_RANGE_CHAR;
2649 for (i = start, retval = 0; i < stop && retval == 0; i++)
2651 rainj.ch = MAKE_CHAR (charset, row, i);
2652 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2660 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2661 int (*fn) (struct chartab_range *range,
2662 Lisp_Object val, void *arg),
2665 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2666 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2668 if (!CHARSETP (charset)
2669 || lb == LEADING_BYTE_ASCII
2670 || lb == LEADING_BYTE_CONTROL_1)
2673 if (!CHAR_TABLE_ENTRYP (val))
2675 struct chartab_range rainj;
2677 rainj.type = CHARTAB_RANGE_CHARSET;
2678 rainj.charset = charset;
2679 return (fn) (&rainj, val, arg);
2683 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2684 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2685 int start = charset94_p ? 33 : 32;
2686 int stop = charset94_p ? 127 : 128;
2689 if (XCHARSET_DIMENSION (charset) == 1)
2691 struct chartab_range rainj;
2692 rainj.type = CHARTAB_RANGE_CHAR;
2694 for (i = start, retval = 0; i < stop && retval == 0; i++)
2696 rainj.ch = MAKE_CHAR (charset, i, 0);
2697 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2702 for (i = start, retval = 0; i < stop && retval == 0; i++)
2703 retval = map_over_charset_row (cte, charset, i, fn, arg);
2711 #endif /* not UTF2000 */
2714 struct map_char_table_for_charset_arg
2716 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2717 Lisp_Char_Table *ct;
2722 map_char_table_for_charset_fun (struct chartab_range *range,
2723 Lisp_Object val, void *arg)
2725 struct map_char_table_for_charset_arg *closure =
2726 (struct map_char_table_for_charset_arg *) arg;
2729 switch (range->type)
2731 case CHARTAB_RANGE_ALL:
2734 case CHARTAB_RANGE_DEFAULT:
2737 case CHARTAB_RANGE_CHARSET:
2740 case CHARTAB_RANGE_ROW:
2743 case CHARTAB_RANGE_CHAR:
2744 ret = get_char_table (range->ch, closure->ct);
2745 if (!UNBOUNDP (ret))
2746 return (closure->fn) (range, ret, closure->arg);
2758 /* Map FN (with client data ARG) over range RANGE in char table CT.
2759 Mapping stops the first time FN returns non-zero, and that value
2760 becomes the return value of map_char_table(). */
2763 map_char_table (Lisp_Char_Table *ct,
2764 struct chartab_range *range,
2765 int (*fn) (struct chartab_range *range,
2766 Lisp_Object val, void *arg),
2769 switch (range->type)
2771 case CHARTAB_RANGE_ALL:
2773 if (!UNBOUNDP (ct->default_value))
2775 struct chartab_range rainj;
2778 rainj.type = CHARTAB_RANGE_DEFAULT;
2779 retval = (fn) (&rainj, ct->default_value, arg);
2783 if (UINT8_BYTE_TABLE_P (ct->table))
2784 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2786 else if (UINT16_BYTE_TABLE_P (ct->table))
2787 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2789 else if (BYTE_TABLE_P (ct->table))
2790 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2792 else if (EQ (ct->table, Qunloaded))
2795 struct chartab_range rainj;
2798 Emchar c1 = c + unit;
2801 rainj.type = CHARTAB_RANGE_CHAR;
2803 for (retval = 0; c < c1 && retval == 0; c++)
2805 Lisp_Object ret = get_char_id_table (ct, c);
2807 if (!UNBOUNDP (ret))
2810 retval = (fn) (&rainj, ct->table, arg);
2815 ct->table = Qunbound;
2818 else if (!UNBOUNDP (ct->table))
2819 return (fn) (range, ct->table, arg);
2825 retval = map_over_charset_ascii (ct, fn, arg);
2829 retval = map_over_charset_control_1 (ct, fn, arg);
2834 Charset_ID start = MIN_LEADING_BYTE;
2835 Charset_ID stop = start + NUM_LEADING_BYTES;
2837 for (i = start, retval = 0; i < stop && retval == 0; i++)
2839 retval = map_over_other_charset (ct, i, fn, arg);
2848 case CHARTAB_RANGE_DEFAULT:
2849 if (!UNBOUNDP (ct->default_value))
2850 return (fn) (range, ct->default_value, arg);
2855 case CHARTAB_RANGE_CHARSET:
2858 Lisp_Object encoding_table
2859 = XCHARSET_ENCODING_TABLE (range->charset);
2861 if (!NILP (encoding_table))
2863 struct chartab_range rainj;
2864 struct map_char_table_for_charset_arg mcarg;
2866 #ifdef HAVE_CHISE_CLIENT
2867 if (XCHAR_TABLE_UNLOADED(encoding_table))
2868 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2873 rainj.type = CHARTAB_RANGE_ALL;
2874 return map_char_table (XCHAR_TABLE(encoding_table),
2876 &map_char_table_for_charset_fun,
2882 return map_over_other_charset (ct,
2883 XCHARSET_LEADING_BYTE (range->charset),
2887 case CHARTAB_RANGE_ROW:
2890 int cell_min, cell_max, i;
2892 struct chartab_range rainj;
2894 i = XCHARSET_CELL_RANGE (range->charset);
2896 cell_max = i & 0xFF;
2897 rainj.type = CHARTAB_RANGE_CHAR;
2898 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2900 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2902 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2905 = get_byte_table (get_byte_table
2909 (unsigned char)(ch >> 24)),
2910 (unsigned char) (ch >> 16)),
2911 (unsigned char) (ch >> 8)),
2912 (unsigned char) ch);
2915 val = ct->default_value;
2917 retval = (fn) (&rainj, val, arg);
2924 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2925 - MIN_LEADING_BYTE];
2926 if (!CHAR_TABLE_ENTRYP (val))
2928 struct chartab_range rainj;
2930 rainj.type = CHARTAB_RANGE_ROW;
2931 rainj.charset = range->charset;
2932 rainj.row = range->row;
2933 return (fn) (&rainj, val, arg);
2936 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2937 range->charset, range->row,
2940 #endif /* not UTF2000 */
2943 case CHARTAB_RANGE_CHAR:
2945 Emchar ch = range->ch;
2946 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2948 if (!UNBOUNDP (val))
2950 struct chartab_range rainj;
2952 rainj.type = CHARTAB_RANGE_CHAR;
2954 return (fn) (&rainj, val, arg);
2966 struct slow_map_char_table_arg
2968 Lisp_Object function;
2973 slow_map_char_table_fun (struct chartab_range *range,
2974 Lisp_Object val, void *arg)
2976 Lisp_Object ranjarg = Qnil;
2977 struct slow_map_char_table_arg *closure =
2978 (struct slow_map_char_table_arg *) arg;
2980 switch (range->type)
2982 case CHARTAB_RANGE_ALL:
2987 case CHARTAB_RANGE_DEFAULT:
2993 case CHARTAB_RANGE_CHARSET:
2994 ranjarg = XCHARSET_NAME (range->charset);
2997 case CHARTAB_RANGE_ROW:
2998 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2999 make_int (range->row));
3002 case CHARTAB_RANGE_CHAR:
3003 ranjarg = make_char (range->ch);
3009 closure->retval = call2 (closure->function, ranjarg, val);
3010 return !NILP (closure->retval);
3013 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
3014 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
3015 each key and value in the table.
3017 RANGE specifies a subrange to map over and is in the same format as
3018 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3021 (function, char_table, range))
3023 Lisp_Char_Table *ct;
3024 struct slow_map_char_table_arg slarg;
3025 struct gcpro gcpro1, gcpro2;
3026 struct chartab_range rainj;
3028 CHECK_CHAR_TABLE (char_table);
3029 ct = XCHAR_TABLE (char_table);
3032 decode_char_table_range (range, &rainj);
3033 slarg.function = function;
3034 slarg.retval = Qnil;
3035 GCPRO2 (slarg.function, slarg.retval);
3036 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3039 return slarg.retval;
3043 /************************************************************************/
3044 /* Character Attributes */
3045 /************************************************************************/
3049 Lisp_Object Vchar_attribute_hash_table;
3051 /* We store the char-attributes in hash tables with the names as the
3052 key and the actual char-id-table object as the value. Occasionally
3053 we need to use them in a list format. These routines provide us
3055 struct char_attribute_list_closure
3057 Lisp_Object *char_attribute_list;
3061 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3062 void *char_attribute_list_closure)
3064 /* This function can GC */
3065 struct char_attribute_list_closure *calcl
3066 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3067 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3069 *char_attribute_list = Fcons (key, *char_attribute_list);
3073 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3074 Return the list of all existing character attributes except coded-charsets.
3078 Lisp_Object char_attribute_list = Qnil;
3079 struct gcpro gcpro1;
3080 struct char_attribute_list_closure char_attribute_list_closure;
3082 GCPRO1 (char_attribute_list);
3083 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3084 elisp_maphash (add_char_attribute_to_list_mapper,
3085 Vchar_attribute_hash_table,
3086 &char_attribute_list_closure);
3088 return char_attribute_list;
3091 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3092 Return char-id-table corresponding to ATTRIBUTE.
3096 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3100 /* We store the char-id-tables in hash tables with the attributes as
3101 the key and the actual char-id-table object as the value. Each
3102 char-id-table stores values of an attribute corresponding with
3103 characters. Occasionally we need to get attributes of a character
3104 in a association-list format. These routines provide us with
3106 struct char_attribute_alist_closure
3109 Lisp_Object *char_attribute_alist;
3113 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3114 void *char_attribute_alist_closure)
3116 /* This function can GC */
3117 struct char_attribute_alist_closure *caacl =
3118 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3120 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3121 if (!UNBOUNDP (ret))
3123 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3124 *char_attribute_alist
3125 = Fcons (Fcons (key, ret), *char_attribute_alist);
3130 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3131 Return the alist of attributes of CHARACTER.
3135 struct gcpro gcpro1;
3136 struct char_attribute_alist_closure char_attribute_alist_closure;
3137 Lisp_Object alist = Qnil;
3139 CHECK_CHAR (character);
3142 char_attribute_alist_closure.char_id = XCHAR (character);
3143 char_attribute_alist_closure.char_attribute_alist = &alist;
3144 elisp_maphash (add_char_attribute_alist_mapper,
3145 Vchar_attribute_hash_table,
3146 &char_attribute_alist_closure);
3152 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3153 Return the value of CHARACTER's ATTRIBUTE.
3154 Return DEFAULT-VALUE if the value is not exist.
3156 (character, attribute, default_value))
3160 CHECK_CHAR (character);
3162 if (CHARSETP (attribute))
3163 attribute = XCHARSET_NAME (attribute);
3165 table = Fgethash (attribute, Vchar_attribute_hash_table,
3167 if (!UNBOUNDP (table))
3169 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3171 if (!UNBOUNDP (ret))
3174 return default_value;
3177 void put_char_composition (Lisp_Object character, Lisp_Object value);
3179 put_char_composition (Lisp_Object character, Lisp_Object value)
3182 signal_simple_error ("Invalid value for ->decomposition",
3185 if (CONSP (Fcdr (value)))
3187 if (NILP (Fcdr (Fcdr (value))))
3189 Lisp_Object base = Fcar (value);
3190 Lisp_Object modifier = Fcar (Fcdr (value));
3194 base = make_char (XINT (base));
3195 Fsetcar (value, base);
3197 if (INTP (modifier))
3199 modifier = make_char (XINT (modifier));
3200 Fsetcar (Fcdr (value), modifier);
3205 = Fget_char_attribute (base, Qcomposition, Qnil);
3206 Lisp_Object ret = Fassq (modifier, alist);
3209 Fput_char_attribute (base, Qcomposition,
3210 Fcons (Fcons (modifier, character),
3213 Fsetcdr (ret, character);
3219 Lisp_Object v = Fcar (value);
3223 Emchar c = XINT (v);
3225 = Fget_char_attribute (make_char (c), Q_ucs_unified, Qnil);
3229 Fput_char_attribute (make_char (c), Q_ucs_unified,
3230 Fcons (character, Qnil));
3232 else if (NILP (Fmemq (character, ret)))
3234 Fput_char_attribute (make_char (c), Q_ucs_unified,
3235 Fcons (character, ret));
3241 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3242 Store CHARACTER's ATTRIBUTE with VALUE.
3244 (character, attribute, value))
3246 Lisp_Object ccs = Ffind_charset (attribute);
3248 CHECK_CHAR (character);
3252 value = put_char_ccs_code_point (character, ccs, value);
3253 attribute = XCHARSET_NAME (ccs);
3255 else if (EQ (attribute, Q_decomposition))
3256 put_char_composition (character, value);
3257 else if (EQ (attribute, Qto_ucs))
3263 signal_simple_error ("Invalid value for =>ucs", value);
3267 ret = Fget_char_attribute (make_char (c), Q_ucs_unified, Qnil);
3270 Fput_char_attribute (make_char (c), Q_ucs_unified,
3271 Fcons (character, Qnil));
3273 else if (NILP (Fmemq (character, ret)))
3275 Fput_char_attribute (make_char (c), Q_ucs_unified,
3276 Fcons (character, ret));
3280 else if (EQ (attribute, Qideographic_structure))
3281 value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value));
3284 Lisp_Object table = Fgethash (attribute,
3285 Vchar_attribute_hash_table,
3290 table = make_char_id_table (Qunbound);
3291 Fputhash (attribute, table, Vchar_attribute_hash_table);
3292 #ifdef HAVE_CHISE_CLIENT
3293 XCHAR_TABLE_NAME (table) = attribute;
3296 put_char_id_table (XCHAR_TABLE(table), character, value);
3301 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3302 Remove CHARACTER's ATTRIBUTE.
3304 (character, attribute))
3308 CHECK_CHAR (character);
3309 ccs = Ffind_charset (attribute);
3312 return remove_char_ccs (character, ccs);
3316 Lisp_Object table = Fgethash (attribute,
3317 Vchar_attribute_hash_table,
3319 if (!UNBOUNDP (table))
3321 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3328 #ifdef HAVE_CHISE_CLIENT
3330 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3333 Lisp_Object db_dir = Vexec_directory;
3336 db_dir = build_string ("../lib-src");
3338 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3339 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3340 Fmake_directory_internal (db_dir);
3342 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3343 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3344 Fmake_directory_internal (db_dir);
3347 Lisp_Object attribute_name = Fsymbol_name (attribute);
3348 Lisp_Object dest = Qnil, ret;
3350 struct gcpro gcpro1, gcpro2;
3351 int len = XSTRING_CHAR_LENGTH (attribute_name);
3355 for (i = 0; i < len; i++)
3357 Emchar c = string_char (XSTRING (attribute_name), i);
3359 if ( (c == '/') || (c == '%') )
3363 sprintf (str, "%%%02X", c);
3364 dest = concat3 (dest,
3365 Fsubstring (attribute_name,
3366 make_int (base), make_int (i)),
3367 build_string (str));
3371 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3372 dest = concat2 (dest, ret);
3374 return Fexpand_file_name (dest, db_dir);
3377 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3381 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3382 Save values of ATTRIBUTE into database file.
3386 #ifdef HAVE_CHISE_CLIENT
3387 Lisp_Object table = Fgethash (attribute,
3388 Vchar_attribute_hash_table, Qunbound);
3389 Lisp_Char_Table *ct;
3390 Lisp_Object db_file;
3393 if (CHAR_TABLEP (table))
3394 ct = XCHAR_TABLE (table);
3398 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3399 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3402 Lisp_Object (*filter)(Lisp_Object value);
3404 if (EQ (attribute, Qideographic_structure))
3405 filter = &Fchar_refs_simplify_char_specs;
3409 if (UINT8_BYTE_TABLE_P (ct->table))
3410 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db,
3412 else if (UINT16_BYTE_TABLE_P (ct->table))
3413 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db,
3415 else if (BYTE_TABLE_P (ct->table))
3416 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3, filter);
3417 Fclose_database (db);
3427 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
3428 Mount database file on char-attribute-table ATTRIBUTE.
3432 #ifdef HAVE_CHISE_CLIENT
3433 Lisp_Object table = Fgethash (attribute,
3434 Vchar_attribute_hash_table, Qunbound);
3436 if (UNBOUNDP (table))
3438 Lisp_Char_Table *ct;
3440 table = make_char_id_table (Qunbound);
3441 Fputhash (attribute, table, Vchar_attribute_hash_table);
3442 XCHAR_TABLE_NAME(table) = attribute;
3443 ct = XCHAR_TABLE (table);
3444 ct->table = Qunloaded;
3445 XCHAR_TABLE_UNLOADED(table) = 1;
3453 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3454 Close database of ATTRIBUTE.
3458 #ifdef HAVE_CHISE_CLIENT
3459 Lisp_Object table = Fgethash (attribute,
3460 Vchar_attribute_hash_table, Qunbound);
3461 Lisp_Char_Table *ct;
3463 if (CHAR_TABLEP (table))
3464 ct = XCHAR_TABLE (table);
3470 if (!NILP (Fdatabase_live_p (ct->db)))
3471 Fclose_database (ct->db);
3478 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3479 Reset values of ATTRIBUTE with database file.
3483 #ifdef HAVE_CHISE_CLIENT
3484 Lisp_Object table = Fgethash (attribute,
3485 Vchar_attribute_hash_table, Qunbound);
3486 Lisp_Char_Table *ct;
3488 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3490 if (!NILP (Ffile_exists_p (db_file)))
3492 if (UNBOUNDP (table))
3494 table = make_char_id_table (Qunbound);
3495 Fputhash (attribute, table, Vchar_attribute_hash_table);
3496 XCHAR_TABLE_NAME(table) = attribute;
3498 ct = XCHAR_TABLE (table);
3499 ct->table = Qunloaded;
3500 if (!NILP (Fdatabase_live_p (ct->db)))
3501 Fclose_database (ct->db);
3503 XCHAR_TABLE_UNLOADED(table) = 1;
3511 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3513 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3515 if (!NILP (attribute))
3517 if (NILP (Fdatabase_live_p (cit->db)))
3520 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3522 cit->db = Fopen_database (db_file, Qnil, Qnil,
3523 build_string ("r"), Qnil);
3525 if (!NILP (cit->db))
3528 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3530 if (!UNBOUNDP (val))
3534 if (!NILP (Vchar_db_stingy_mode))
3536 Fclose_database (cit->db);
3545 Lisp_Char_Table* char_attribute_table_to_load;
3547 Lisp_Object Qload_char_attribute_table_map_function;
3549 DEFUN ("load-char-attribute-table-map-function",
3550 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3551 For internal use. Don't use it.
3555 Lisp_Object c = Fread (key);
3556 Emchar code = XCHAR (c);
3557 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
3559 if (EQ (ret, Qunloaded))
3560 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3564 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3565 Load values of ATTRIBUTE into database file.
3569 Lisp_Object table = Fgethash (attribute,
3570 Vchar_attribute_hash_table,
3572 if (CHAR_TABLEP (table))
3574 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3576 if (NILP (Fdatabase_live_p (ct->db)))
3579 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3581 ct->db = Fopen_database (db_file, Qnil, Qnil,
3582 build_string ("r"), Qnil);
3586 struct gcpro gcpro1;
3588 char_attribute_table_to_load = XCHAR_TABLE (table);
3590 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3592 Fclose_database (ct->db);
3594 XCHAR_TABLE_UNLOADED(table) = 0;
3602 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3603 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3604 each key and value in the table.
3606 RANGE specifies a subrange to map over and is in the same format as
3607 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3610 (function, attribute, range))
3613 Lisp_Char_Table *ct;
3614 struct slow_map_char_table_arg slarg;
3615 struct gcpro gcpro1, gcpro2;
3616 struct chartab_range rainj;
3618 if (!NILP (ccs = Ffind_charset (attribute)))
3620 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3622 if (CHAR_TABLEP (encoding_table))
3623 ct = XCHAR_TABLE (encoding_table);
3629 Lisp_Object table = Fgethash (attribute,
3630 Vchar_attribute_hash_table,
3632 if (CHAR_TABLEP (table))
3633 ct = XCHAR_TABLE (table);
3639 decode_char_table_range (range, &rainj);
3640 #ifdef HAVE_CHISE_CLIENT
3641 if (CHAR_TABLE_UNLOADED(ct))
3642 Fload_char_attribute_table (attribute);
3644 slarg.function = function;
3645 slarg.retval = Qnil;
3646 GCPRO2 (slarg.function, slarg.retval);
3647 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3650 return slarg.retval;
3653 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3654 Store character's ATTRIBUTES.
3658 Lisp_Object rest = attributes;
3659 Lisp_Object code = Fcdr (Fassq (Qmap_ucs, attributes));
3660 Lisp_Object character;
3663 code = Fcdr (Fassq (Qucs, attributes));
3666 while (CONSP (rest))
3668 Lisp_Object cell = Fcar (rest);
3672 signal_simple_error ("Invalid argument", attributes);
3673 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3674 && ((XCHARSET_FINAL (ccs) != 0) ||
3675 (XCHARSET_MAX_CODE (ccs) > 0) ||
3676 (EQ (ccs, Vcharset_chinese_big5))) )
3680 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3682 character = Fdecode_char (ccs, cell, Qnil);
3683 if (!NILP (character))
3684 goto setup_attributes;
3688 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) )
3691 signal_simple_error ("Invalid argument", attributes);
3693 character = make_char (XINT (code) + 0x100000);
3694 goto setup_attributes;
3698 else if (!INTP (code))
3699 signal_simple_error ("Invalid argument", attributes);
3701 character = make_char (XINT (code));
3705 while (CONSP (rest))
3707 Lisp_Object cell = Fcar (rest);
3710 signal_simple_error ("Invalid argument", attributes);
3712 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3718 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3719 Retrieve the character of the given ATTRIBUTES.
3723 Lisp_Object rest = attributes;
3726 while (CONSP (rest))
3728 Lisp_Object cell = Fcar (rest);
3732 signal_simple_error ("Invalid argument", attributes);
3733 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3737 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3739 return Fdecode_char (ccs, cell, Qnil);
3743 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) )
3746 signal_simple_error ("Invalid argument", attributes);
3748 return make_char (XINT (code) + 0x100000);
3756 /************************************************************************/
3757 /* Char table read syntax */
3758 /************************************************************************/
3761 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3762 Error_behavior errb)
3764 /* #### should deal with ERRB */
3765 symbol_to_char_table_type (value);
3770 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3771 Error_behavior errb)
3775 /* #### should deal with ERRB */
3776 EXTERNAL_LIST_LOOP (rest, value)
3778 Lisp_Object range = XCAR (rest);
3779 struct chartab_range dummy;
3783 signal_simple_error ("Invalid list format", value);
3786 if (!CONSP (XCDR (range))
3787 || !NILP (XCDR (XCDR (range))))
3788 signal_simple_error ("Invalid range format", range);
3789 decode_char_table_range (XCAR (range), &dummy);
3790 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3793 decode_char_table_range (range, &dummy);
3800 chartab_instantiate (Lisp_Object data)
3802 Lisp_Object chartab;
3803 Lisp_Object type = Qgeneric;
3804 Lisp_Object dataval = Qnil;
3806 while (!NILP (data))
3808 Lisp_Object keyw = Fcar (data);
3814 if (EQ (keyw, Qtype))
3816 else if (EQ (keyw, Qdata))
3820 chartab = Fmake_char_table (type);
3823 while (!NILP (data))
3825 Lisp_Object range = Fcar (data);
3826 Lisp_Object val = Fcar (Fcdr (data));
3828 data = Fcdr (Fcdr (data));
3831 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3833 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3834 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3837 for (i = first; i <= last; i++)
3838 Fput_char_table (make_char (i), val, chartab);
3844 Fput_char_table (range, val, chartab);
3853 /************************************************************************/
3854 /* Category Tables, specifically */
3855 /************************************************************************/
3857 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3858 Return t if OBJECT is a category table.
3859 A category table is a type of char table used for keeping track of
3860 categories. Categories are used for classifying characters for use
3861 in regexps -- you can refer to a category rather than having to use
3862 a complicated [] expression (and category lookups are significantly
3865 There are 95 different categories available, one for each printable
3866 character (including space) in the ASCII charset. Each category
3867 is designated by one such character, called a "category designator".
3868 They are specified in a regexp using the syntax "\\cX", where X is
3869 a category designator.
3871 A category table specifies, for each character, the categories that
3872 the character is in. Note that a character can be in more than one
3873 category. More specifically, a category table maps from a character
3874 to either the value nil (meaning the character is in no categories)
3875 or a 95-element bit vector, specifying for each of the 95 categories
3876 whether the character is in that category.
3878 Special Lisp functions are provided that abstract this, so you do not
3879 have to directly manipulate bit vectors.
3883 return (CHAR_TABLEP (object) &&
3884 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3889 check_category_table (Lisp_Object object, Lisp_Object default_)
3893 while (NILP (Fcategory_table_p (object)))
3894 object = wrong_type_argument (Qcategory_table_p, object);
3899 check_category_char (Emchar ch, Lisp_Object table,
3900 unsigned int designator, unsigned int not_p)
3902 REGISTER Lisp_Object temp;
3903 Lisp_Char_Table *ctbl;
3904 #ifdef ERROR_CHECK_TYPECHECK
3905 if (NILP (Fcategory_table_p (table)))
3906 signal_simple_error ("Expected category table", table);
3908 ctbl = XCHAR_TABLE (table);
3909 temp = get_char_table (ch, ctbl);
3914 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3917 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3918 Return t if category of the character at POSITION includes DESIGNATOR.
3919 Optional third arg BUFFER specifies which buffer to use, and defaults
3920 to the current buffer.
3921 Optional fourth arg CATEGORY-TABLE specifies the category table to
3922 use, and defaults to BUFFER's category table.
3924 (position, designator, buffer, category_table))
3929 struct buffer *buf = decode_buffer (buffer, 0);
3931 CHECK_INT (position);
3932 CHECK_CATEGORY_DESIGNATOR (designator);
3933 des = XCHAR (designator);
3934 ctbl = check_category_table (category_table, Vstandard_category_table);
3935 ch = BUF_FETCH_CHAR (buf, XINT (position));
3936 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3939 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3940 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3941 Optional third arg CATEGORY-TABLE specifies the category table to use,
3942 and defaults to the standard category table.
3944 (character, designator, category_table))
3950 CHECK_CATEGORY_DESIGNATOR (designator);
3951 des = XCHAR (designator);
3952 CHECK_CHAR (character);
3953 ch = XCHAR (character);
3954 ctbl = check_category_table (category_table, Vstandard_category_table);
3955 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3958 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3959 Return BUFFER's current category table.
3960 BUFFER defaults to the current buffer.
3964 return decode_buffer (buffer, 0)->category_table;
3967 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3968 Return the standard category table.
3969 This is the one used for new buffers.
3973 return Vstandard_category_table;
3976 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3977 Return a new category table which is a copy of CATEGORY-TABLE.
3978 CATEGORY-TABLE defaults to the standard category table.
3982 if (NILP (Vstandard_category_table))
3983 return Fmake_char_table (Qcategory);
3986 check_category_table (category_table, Vstandard_category_table);
3987 return Fcopy_char_table (category_table);
3990 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3991 Select CATEGORY-TABLE as the new category table for BUFFER.
3992 BUFFER defaults to the current buffer if omitted.
3994 (category_table, buffer))
3996 struct buffer *buf = decode_buffer (buffer, 0);
3997 category_table = check_category_table (category_table, Qnil);
3998 buf->category_table = category_table;
3999 /* Indicate that this buffer now has a specified category table. */
4000 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
4001 return category_table;
4004 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
4005 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
4009 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
4012 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
4013 Return t if OBJECT is a category table value.
4014 Valid values are nil or a bit vector of size 95.
4018 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
4022 #define CATEGORYP(x) \
4023 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
4025 #define CATEGORY_SET(c) \
4026 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
4028 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
4029 The faster version of `!NILP (Faref (category_set, category))'. */
4030 #define CATEGORY_MEMBER(category, category_set) \
4031 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
4033 /* Return 1 if there is a word boundary between two word-constituent
4034 characters C1 and C2 if they appear in this order, else return 0.
4035 Use the macro WORD_BOUNDARY_P instead of calling this function
4038 int word_boundary_p (Emchar c1, Emchar c2);
4040 word_boundary_p (Emchar c1, Emchar c2)
4042 Lisp_Object category_set1, category_set2;
4047 if (COMPOSITE_CHAR_P (c1))
4048 c1 = cmpchar_component (c1, 0, 1);
4049 if (COMPOSITE_CHAR_P (c2))
4050 c2 = cmpchar_component (c2, 0, 1);
4054 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4057 tail = Vword_separating_categories;
4063 tail = Vword_combining_categories;
4068 category_set1 = CATEGORY_SET (c1);
4069 if (NILP (category_set1))
4070 return default_result;
4071 category_set2 = CATEGORY_SET (c2);
4072 if (NILP (category_set2))
4073 return default_result;
4075 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4077 Lisp_Object elt = XCONS(tail)->car;
4080 && CATEGORYP (XCONS (elt)->car)
4081 && CATEGORYP (XCONS (elt)->cdr)
4082 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4083 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4084 return !default_result;
4086 return default_result;
4092 syms_of_chartab (void)
4095 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4096 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4097 INIT_LRECORD_IMPLEMENTATION (byte_table);
4099 defsymbol (&Qsystem_char_id, "system-char-id");
4101 defsymbol (&Qto_ucs, "=>ucs");
4102 defsymbol (&Q_ucs_unified, "->ucs-unified");
4103 defsymbol (&Qcomposition, "composition");
4104 defsymbol (&Q_decomposition, "->decomposition");
4105 defsymbol (&Qcompat, "compat");
4106 defsymbol (&Qisolated, "isolated");
4107 defsymbol (&Qinitial, "initial");
4108 defsymbol (&Qmedial, "medial");
4109 defsymbol (&Qfinal, "final");
4110 defsymbol (&Qvertical, "vertical");
4111 defsymbol (&QnoBreak, "noBreak");
4112 defsymbol (&Qfraction, "fraction");
4113 defsymbol (&Qsuper, "super");
4114 defsymbol (&Qsub, "sub");
4115 defsymbol (&Qcircle, "circle");
4116 defsymbol (&Qsquare, "square");
4117 defsymbol (&Qwide, "wide");
4118 defsymbol (&Qnarrow, "narrow");
4119 defsymbol (&Qsmall, "small");
4120 defsymbol (&Qfont, "font");
4122 DEFSUBR (Fchar_attribute_list);
4123 DEFSUBR (Ffind_char_attribute_table);
4124 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4125 DEFSUBR (Fput_char_table_map_function);
4126 #ifdef HAVE_CHISE_CLIENT
4127 DEFSUBR (Fsave_char_attribute_table);
4128 DEFSUBR (Fmount_char_attribute_table);
4129 DEFSUBR (Freset_char_attribute_table);
4130 DEFSUBR (Fclose_char_attribute_table);
4131 defsymbol (&Qload_char_attribute_table_map_function,
4132 "load-char-attribute-table-map-function");
4133 DEFSUBR (Fload_char_attribute_table_map_function);
4134 DEFSUBR (Fload_char_attribute_table);
4136 DEFSUBR (Fchar_attribute_alist);
4137 DEFSUBR (Fget_char_attribute);
4138 DEFSUBR (Fput_char_attribute);
4139 DEFSUBR (Fremove_char_attribute);
4140 DEFSUBR (Fmap_char_attribute);
4141 DEFSUBR (Fdefine_char);
4142 DEFSUBR (Ffind_char);
4143 DEFSUBR (Fchar_variants);
4145 DEFSUBR (Fget_composite_char);
4148 INIT_LRECORD_IMPLEMENTATION (char_table);
4152 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4155 defsymbol (&Qcategory_table_p, "category-table-p");
4156 defsymbol (&Qcategory_designator_p, "category-designator-p");
4157 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4160 defsymbol (&Qchar_table, "char-table");
4161 defsymbol (&Qchar_tablep, "char-table-p");
4163 DEFSUBR (Fchar_table_p);
4164 DEFSUBR (Fchar_table_type_list);
4165 DEFSUBR (Fvalid_char_table_type_p);
4166 DEFSUBR (Fchar_table_type);
4167 DEFSUBR (Freset_char_table);
4168 DEFSUBR (Fmake_char_table);
4169 DEFSUBR (Fcopy_char_table);
4170 DEFSUBR (Fget_char_table);
4171 DEFSUBR (Fget_range_char_table);
4172 DEFSUBR (Fvalid_char_table_value_p);
4173 DEFSUBR (Fcheck_valid_char_table_value);
4174 DEFSUBR (Fput_char_table);
4175 DEFSUBR (Fmap_char_table);
4178 DEFSUBR (Fcategory_table_p);
4179 DEFSUBR (Fcategory_table);
4180 DEFSUBR (Fstandard_category_table);
4181 DEFSUBR (Fcopy_category_table);
4182 DEFSUBR (Fset_category_table);
4183 DEFSUBR (Fcheck_category_at);
4184 DEFSUBR (Fchar_in_category_p);
4185 DEFSUBR (Fcategory_designator_p);
4186 DEFSUBR (Fcategory_table_value_p);
4192 vars_of_chartab (void)
4195 #ifdef HAVE_CHISE_CLIENT
4196 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4198 Vchar_db_stingy_mode = Qt;
4199 #endif /* HAVE_CHISE_CLIENT */
4201 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4202 Vall_syntax_tables = Qnil;
4203 dump_add_weak_object_chain (&Vall_syntax_tables);
4207 structure_type_create_chartab (void)
4209 struct structure_type *st;
4211 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4213 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4214 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4218 complex_vars_of_chartab (void)
4221 staticpro (&Vchar_attribute_hash_table);
4222 Vchar_attribute_hash_table
4223 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4224 #endif /* UTF2000 */
4226 /* Set this now, so first buffer creation can refer to it. */
4227 /* Make it nil before calling copy-category-table
4228 so that copy-category-table will know not to try to copy from garbage */
4229 Vstandard_category_table = Qnil;
4230 Vstandard_category_table = Fcopy_category_table (Qnil);
4231 staticpro (&Vstandard_category_table);
4233 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4234 List of pair (cons) of categories to determine word boundary.
4236 Emacs treats a sequence of word constituent characters as a single
4237 word (i.e. finds no word boundary between them) iff they belongs to
4238 the same charset. But, exceptions are allowed in the following cases.
4240 \(1) The case that characters are in different charsets is controlled
4241 by the variable `word-combining-categories'.
4243 Emacs finds no word boundary between characters of different charsets
4244 if they have categories matching some element of this list.
4246 More precisely, if an element of this list is a cons of category CAT1
4247 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4248 C2 which has CAT2, there's no word boundary between C1 and C2.
4250 For instance, to tell that ASCII characters and Latin-1 characters can
4251 form a single word, the element `(?l . ?l)' should be in this list
4252 because both characters have the category `l' (Latin characters).
4254 \(2) The case that character are in the same charset is controlled by
4255 the variable `word-separating-categories'.
4257 Emacs find a word boundary between characters of the same charset
4258 if they have categories matching some element of this list.
4260 More precisely, if an element of this list is a cons of category CAT1
4261 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4262 C2 which has CAT2, there's a word boundary between C1 and C2.
4264 For instance, to tell that there's a word boundary between Japanese
4265 Hiragana and Japanese Kanji (both are in the same charset), the
4266 element `(?H . ?C) should be in this list.
4269 Vword_combining_categories = Qnil;
4271 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4272 List of pair (cons) of categories to determine word boundary.
4273 See the documentation of the variable `word-combining-categories'.
4276 Vword_separating_categories = Qnil;