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, 2004, 2005, 2006, 2008,
8 2010, 2011, 2012 MORIOKA Tomohiko
10 This file is part of XEmacs.
12 XEmacs is free software; you can redistribute it and/or modify it
13 under the terms of the GNU General Public License as published by the
14 Free Software Foundation; either version 2, or (at your option) any
17 XEmacs is distributed in the hope that it will be useful, but WITHOUT
18 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
19 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
22 You should have received a copy of the GNU General Public License
23 along with XEmacs; see the file COPYING. If not, write to
24 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 Boston, MA 02111-1307, USA. */
27 /* Synched up with: Mule 2.3. Not synched with FSF.
29 This file was written independently of the FSF implementation,
30 and is not compatible. */
34 Ben Wing: wrote, for 19.13 (Mule). Some category table stuff
35 loosely based on the original Mule.
36 Jareth Hein: fixed a couple of bugs in the implementation, and
37 added regex support for categories with check_category_at
38 MORIOKA Tomohiko: Rewritten for XEmacs CHISE
51 Lisp_Object Qchar_tablep, Qchar_table;
53 Lisp_Object Vall_syntax_tables;
56 Lisp_Object Qcategory_table_p;
57 Lisp_Object Qcategory_designator_p;
58 Lisp_Object Qcategory_table_value_p;
60 Lisp_Object Vstandard_category_table;
62 /* Variables to determine word boundary. */
63 Lisp_Object Vword_combining_categories, Vword_separating_categories;
68 Lisp_Object Vchise_db_directory;
69 Lisp_Object Vchise_system_db_directory;
71 CHISE_DS *default_chise_data_source = NULL;
76 EXFUN (Fchar_refs_simplify_char_specs, 1);
77 extern Lisp_Object Qideographic_structure;
79 Lisp_Object Vnext_defined_char_id;
81 EXFUN (Fmap_char_attribute, 3);
84 EXFUN (Fmount_char_attribute_table, 1);
88 EXFUN (Fload_char_attribute_table, 1);
90 Lisp_Object Vchar_db_stingy_mode;
93 #define BT_UINT8_MIN 0
94 #define BT_UINT8_MAX (UCHAR_MAX - 4)
95 #define BT_UINT8_t (UCHAR_MAX - 3)
96 #define BT_UINT8_nil (UCHAR_MAX - 2)
97 #define BT_UINT8_unbound (UCHAR_MAX - 1)
98 #define BT_UINT8_unloaded UCHAR_MAX
100 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
101 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
102 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
103 /* INLINE_HEADER */ Lisp_Object UINT8_DECODE (unsigned char n);
104 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
107 INT_UINT8_P (Lisp_Object obj)
111 int num = XINT (obj);
113 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
120 UINT8_VALUE_P (Lisp_Object obj)
122 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
123 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
126 INLINE_HEADER unsigned char
127 UINT8_ENCODE (Lisp_Object obj)
129 if (EQ (obj, Qunloaded))
130 return BT_UINT8_unloaded;
131 else if (EQ (obj, Qunbound))
132 return BT_UINT8_unbound;
133 else if (EQ (obj, Qnil))
135 else if (EQ (obj, Qt))
141 /* INLINE_HEADER */ Lisp_Object
142 UINT8_DECODE (unsigned char n)
144 if (n == BT_UINT8_unloaded)
146 else if (n == BT_UINT8_unbound)
148 else if (n == BT_UINT8_nil)
150 else if (n == BT_UINT8_t)
157 mark_uint8_byte_table (Lisp_Object obj)
163 print_uint8_byte_table (Lisp_Object obj,
164 Lisp_Object printcharfun, int escapeflag)
166 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
168 struct gcpro gcpro1, gcpro2;
169 GCPRO2 (obj, printcharfun);
171 write_c_string ("\n#<uint8-byte-table", printcharfun);
172 for (i = 0; i < 256; i++)
174 unsigned char n = bte->property[i];
176 write_c_string ("\n ", printcharfun);
177 write_c_string (" ", printcharfun);
178 if (n == BT_UINT8_unbound)
179 write_c_string ("void", printcharfun);
180 else if (n == BT_UINT8_nil)
181 write_c_string ("nil", printcharfun);
182 else if (n == BT_UINT8_t)
183 write_c_string ("t", printcharfun);
188 sprintf (buf, "%hd", n);
189 write_c_string (buf, printcharfun);
193 write_c_string (">", printcharfun);
197 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
199 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
200 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
203 for (i = 0; i < 256; i++)
204 if (te1->property[i] != te2->property[i])
210 uint8_byte_table_hash (Lisp_Object obj, int depth)
212 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
216 for (i = 0; i < 256; i++)
217 hash = HASH2 (hash, te->property[i]);
221 static const struct lrecord_description uint8_byte_table_description[] = {
225 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
226 mark_uint8_byte_table,
227 print_uint8_byte_table,
228 0, uint8_byte_table_equal,
229 uint8_byte_table_hash,
230 uint8_byte_table_description,
231 Lisp_Uint8_Byte_Table);
234 make_uint8_byte_table (unsigned char initval)
238 Lisp_Uint8_Byte_Table *cte;
240 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
241 &lrecord_uint8_byte_table);
243 for (i = 0; i < 256; i++)
244 cte->property[i] = initval;
246 XSETUINT8_BYTE_TABLE (obj, cte);
251 copy_uint8_byte_table (Lisp_Object entry)
253 Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
256 Lisp_Uint8_Byte_Table *ctenew
257 = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
258 &lrecord_uint8_byte_table);
260 for (i = 0; i < 256; i++)
262 ctenew->property[i] = cte->property[i];
265 XSETUINT8_BYTE_TABLE (obj, ctenew);
270 uint8_byte_table_same_value_p (Lisp_Object obj)
272 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
273 unsigned char v0 = bte->property[0];
276 for (i = 1; i < 256; i++)
278 if (bte->property[i] != v0)
285 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
286 Emchar ofs, int place,
287 int (*fn) (struct chartab_range *range,
288 Lisp_Object val, void *arg),
291 struct chartab_range rainj;
293 int unit = 1 << (8 * place);
297 rainj.type = CHARTAB_RANGE_CHAR;
299 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
301 if (ct->property[i] == BT_UINT8_unloaded)
305 for (; c < c1 && retval == 0; c++)
307 Lisp_Object ret = get_char_id_table (root, c);
312 retval = (fn) (&rainj, ret, arg);
316 ct->property[i] = BT_UINT8_unbound;
320 else if (ct->property[i] != BT_UINT8_unbound)
323 for (; c < c1 && retval == 0; c++)
326 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
337 save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
339 CHISE_Feature feature,
343 Emchar ofs, int place,
344 Lisp_Object (*filter)(Lisp_Object value))
346 struct chartab_range rainj;
348 int unit = 1 << (8 * place);
352 rainj.type = CHARTAB_RANGE_CHAR;
354 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
356 if (ct->property[i] == BT_UINT8_unloaded)
360 else if (ct->property[i] != BT_UINT8_unbound)
363 for (; c < c1 && retval == 0; c++)
366 chise_char_set_feature_value
369 (Fprin1_to_string (UINT8_DECODE (ct->property[i]),
372 Fput_database (Fprin1_to_string (make_char (c), Qnil),
373 Fprin1_to_string (UINT8_DECODE (ct->property[i]),
385 #define BT_UINT16_MIN 0
386 #define BT_UINT16_MAX (USHRT_MAX - 4)
387 #define BT_UINT16_t (USHRT_MAX - 3)
388 #define BT_UINT16_nil (USHRT_MAX - 2)
389 #define BT_UINT16_unbound (USHRT_MAX - 1)
390 #define BT_UINT16_unloaded USHRT_MAX
392 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
393 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
394 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
395 /* INLINE_HEADER */ Lisp_Object UINT16_DECODE (unsigned short us);
398 INT_UINT16_P (Lisp_Object obj)
402 int num = XINT (obj);
404 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
411 UINT16_VALUE_P (Lisp_Object obj)
413 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
414 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
417 INLINE_HEADER unsigned short
418 UINT16_ENCODE (Lisp_Object obj)
420 if (EQ (obj, Qunloaded))
421 return BT_UINT16_unloaded;
422 else if (EQ (obj, Qunbound))
423 return BT_UINT16_unbound;
424 else if (EQ (obj, Qnil))
425 return BT_UINT16_nil;
426 else if (EQ (obj, Qt))
432 /* INLINE_HEADER */ Lisp_Object
433 UINT16_DECODE (unsigned short n)
435 if (n == BT_UINT16_unloaded)
437 else if (n == BT_UINT16_unbound)
439 else if (n == BT_UINT16_nil)
441 else if (n == BT_UINT16_t)
447 INLINE_HEADER unsigned short
448 UINT8_TO_UINT16 (unsigned char n)
450 if (n == BT_UINT8_unloaded)
451 return BT_UINT16_unloaded;
452 else if (n == BT_UINT8_unbound)
453 return BT_UINT16_unbound;
454 else if (n == BT_UINT8_nil)
455 return BT_UINT16_nil;
456 else if (n == BT_UINT8_t)
463 mark_uint16_byte_table (Lisp_Object obj)
469 print_uint16_byte_table (Lisp_Object obj,
470 Lisp_Object printcharfun, int escapeflag)
472 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
474 struct gcpro gcpro1, gcpro2;
475 GCPRO2 (obj, printcharfun);
477 write_c_string ("\n#<uint16-byte-table", printcharfun);
478 for (i = 0; i < 256; i++)
480 unsigned short n = bte->property[i];
482 write_c_string ("\n ", printcharfun);
483 write_c_string (" ", printcharfun);
484 if (n == BT_UINT16_unbound)
485 write_c_string ("void", printcharfun);
486 else if (n == BT_UINT16_nil)
487 write_c_string ("nil", printcharfun);
488 else if (n == BT_UINT16_t)
489 write_c_string ("t", printcharfun);
494 sprintf (buf, "%hd", n);
495 write_c_string (buf, printcharfun);
499 write_c_string (">", printcharfun);
503 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
505 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
506 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
509 for (i = 0; i < 256; i++)
510 if (te1->property[i] != te2->property[i])
516 uint16_byte_table_hash (Lisp_Object obj, int depth)
518 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
522 for (i = 0; i < 256; i++)
523 hash = HASH2 (hash, te->property[i]);
527 static const struct lrecord_description uint16_byte_table_description[] = {
531 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
532 mark_uint16_byte_table,
533 print_uint16_byte_table,
534 0, uint16_byte_table_equal,
535 uint16_byte_table_hash,
536 uint16_byte_table_description,
537 Lisp_Uint16_Byte_Table);
540 make_uint16_byte_table (unsigned short initval)
544 Lisp_Uint16_Byte_Table *cte;
546 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
547 &lrecord_uint16_byte_table);
549 for (i = 0; i < 256; i++)
550 cte->property[i] = initval;
552 XSETUINT16_BYTE_TABLE (obj, cte);
557 copy_uint16_byte_table (Lisp_Object entry)
559 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
562 Lisp_Uint16_Byte_Table *ctenew
563 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
564 &lrecord_uint16_byte_table);
566 for (i = 0; i < 256; i++)
568 ctenew->property[i] = cte->property[i];
571 XSETUINT16_BYTE_TABLE (obj, ctenew);
576 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
580 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
581 Lisp_Uint16_Byte_Table* cte;
583 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
584 &lrecord_uint16_byte_table);
585 for (i = 0; i < 256; i++)
587 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
589 XSETUINT16_BYTE_TABLE (obj, cte);
594 uint16_byte_table_same_value_p (Lisp_Object obj)
596 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
597 unsigned short v0 = bte->property[0];
600 for (i = 1; i < 256; i++)
602 if (bte->property[i] != v0)
609 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
610 Emchar ofs, int place,
611 int (*fn) (struct chartab_range *range,
612 Lisp_Object val, void *arg),
615 struct chartab_range rainj;
617 int unit = 1 << (8 * place);
621 rainj.type = CHARTAB_RANGE_CHAR;
623 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
625 if (ct->property[i] == BT_UINT16_unloaded)
629 for (; c < c1 && retval == 0; c++)
631 Lisp_Object ret = get_char_id_table (root, c);
636 retval = (fn) (&rainj, ret, arg);
640 ct->property[i] = BT_UINT16_unbound;
644 else if (ct->property[i] != BT_UINT16_unbound)
647 for (; c < c1 && retval == 0; c++)
650 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
661 save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
663 CHISE_Feature feature,
667 Emchar ofs, int place,
668 Lisp_Object (*filter)(Lisp_Object value))
670 struct chartab_range rainj;
672 int unit = 1 << (8 * place);
676 rainj.type = CHARTAB_RANGE_CHAR;
678 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
680 if (ct->property[i] == BT_UINT16_unloaded)
684 else if (ct->property[i] != BT_UINT16_unbound)
687 for (; c < c1 && retval == 0; c++)
690 chise_char_set_feature_value
693 (Fprin1_to_string (UINT16_DECODE (ct->property[i]),
696 Fput_database (Fprin1_to_string (make_char (c), Qnil),
697 Fprin1_to_string (UINT16_DECODE (ct->property[i]),
711 mark_byte_table (Lisp_Object obj)
713 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
716 for (i = 0; i < 256; i++)
718 mark_object (cte->property[i]);
724 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
726 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
728 struct gcpro gcpro1, gcpro2;
729 GCPRO2 (obj, printcharfun);
731 write_c_string ("\n#<byte-table", printcharfun);
732 for (i = 0; i < 256; i++)
734 Lisp_Object elt = bte->property[i];
736 write_c_string ("\n ", printcharfun);
737 write_c_string (" ", printcharfun);
738 if (EQ (elt, Qunbound))
739 write_c_string ("void", printcharfun);
741 print_internal (elt, printcharfun, escapeflag);
744 write_c_string (">", printcharfun);
748 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
750 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
751 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
754 for (i = 0; i < 256; i++)
755 if (BYTE_TABLE_P (cte1->property[i]))
757 if (BYTE_TABLE_P (cte2->property[i]))
759 if (!byte_table_equal (cte1->property[i],
760 cte2->property[i], depth + 1))
767 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
773 byte_table_hash (Lisp_Object obj, int depth)
775 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
777 return internal_array_hash (cte->property, 256, depth);
780 static const struct lrecord_description byte_table_description[] = {
781 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
785 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
790 byte_table_description,
794 make_byte_table (Lisp_Object initval)
798 Lisp_Byte_Table *cte;
800 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
802 for (i = 0; i < 256; i++)
803 cte->property[i] = initval;
805 XSETBYTE_TABLE (obj, cte);
810 copy_byte_table (Lisp_Object entry)
812 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
815 Lisp_Byte_Table *ctnew
816 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
818 for (i = 0; i < 256; i++)
820 if (UINT8_BYTE_TABLE_P (cte->property[i]))
822 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
824 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
826 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
828 else if (BYTE_TABLE_P (cte->property[i]))
830 ctnew->property[i] = copy_byte_table (cte->property[i]);
833 ctnew->property[i] = cte->property[i];
836 XSETBYTE_TABLE (obj, ctnew);
841 byte_table_same_value_p (Lisp_Object obj)
843 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
844 Lisp_Object v0 = bte->property[0];
847 for (i = 1; i < 256; i++)
849 if (!internal_equal (bte->property[i], v0, 0))
856 map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
857 Emchar ofs, int place,
858 int (*fn) (struct chartab_range *range,
859 Lisp_Object val, void *arg),
864 int unit = 1 << (8 * place);
867 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
870 if (UINT8_BYTE_TABLE_P (v))
873 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
874 c, place - 1, fn, arg);
877 else if (UINT16_BYTE_TABLE_P (v))
880 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
881 c, place - 1, fn, arg);
884 else if (BYTE_TABLE_P (v))
886 retval = map_over_byte_table (XBYTE_TABLE(v), root,
887 c, place - 1, fn, arg);
890 else if (EQ (v, Qunloaded))
893 struct chartab_range rainj;
894 Emchar c1 = c + unit;
896 rainj.type = CHARTAB_RANGE_CHAR;
898 for (; c < c1 && retval == 0; c++)
900 Lisp_Object ret = get_char_id_table (root, c);
905 retval = (fn) (&rainj, ret, arg);
909 ct->property[i] = Qunbound;
913 else if (!UNBOUNDP (v))
915 struct chartab_range rainj;
916 Emchar c1 = c + unit;
918 rainj.type = CHARTAB_RANGE_CHAR;
920 for (; c < c1 && retval == 0; c++)
923 retval = (fn) (&rainj, v, arg);
934 save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
936 CHISE_Feature feature,
940 Emchar ofs, int place,
941 Lisp_Object (*filter)(Lisp_Object value))
945 int unit = 1 << (8 * place);
948 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
951 if (UINT8_BYTE_TABLE_P (v))
953 save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
959 c, place - 1, filter);
962 else if (UINT16_BYTE_TABLE_P (v))
964 save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
970 c, place - 1, filter);
973 else if (BYTE_TABLE_P (v))
975 save_byte_table (XBYTE_TABLE(v), root,
981 c, place - 1, filter);
984 else if (EQ (v, Qunloaded))
988 else if (!UNBOUNDP (v))
990 struct chartab_range rainj;
991 Emchar c1 = c + unit;
996 rainj.type = CHARTAB_RANGE_CHAR;
998 for (; c < c1 && retval == 0; c++)
1000 #ifdef HAVE_LIBCHISE
1001 chise_char_set_feature_value
1002 (c, feature, XSTRING_DATA (Fprin1_to_string (v, Qnil)));
1004 Fput_database (Fprin1_to_string (make_char (c), Qnil),
1005 Fprin1_to_string (v, Qnil),
1017 get_byte_table (Lisp_Object table, unsigned char idx)
1019 if (UINT8_BYTE_TABLE_P (table))
1020 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
1021 else if (UINT16_BYTE_TABLE_P (table))
1022 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
1023 else if (BYTE_TABLE_P (table))
1024 return XBYTE_TABLE(table)->property[idx];
1030 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
1032 if (UINT8_BYTE_TABLE_P (table))
1034 if (UINT8_VALUE_P (value))
1036 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
1037 if (!UINT8_BYTE_TABLE_P (value) &&
1038 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1039 && uint8_byte_table_same_value_p (table))
1044 else if (UINT16_VALUE_P (value))
1046 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
1048 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
1053 Lisp_Object new = make_byte_table (Qnil);
1056 for (i = 0; i < 256; i++)
1058 XBYTE_TABLE(new)->property[i]
1059 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
1061 XBYTE_TABLE(new)->property[idx] = value;
1065 else if (UINT16_BYTE_TABLE_P (table))
1067 if (UINT16_VALUE_P (value))
1069 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1070 if (!UINT8_BYTE_TABLE_P (value) &&
1071 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1072 && uint16_byte_table_same_value_p (table))
1079 Lisp_Object new = make_byte_table (Qnil);
1082 for (i = 0; i < 256; i++)
1084 XBYTE_TABLE(new)->property[i]
1085 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
1087 XBYTE_TABLE(new)->property[idx] = value;
1091 else if (BYTE_TABLE_P (table))
1093 XBYTE_TABLE(table)->property[idx] = value;
1094 if (!UINT8_BYTE_TABLE_P (value) &&
1095 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1096 && byte_table_same_value_p (table))
1101 else if (!internal_equal (table, value, 0))
1103 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
1105 table = make_uint8_byte_table (UINT8_ENCODE (table));
1106 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
1108 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
1110 table = make_uint16_byte_table (UINT16_ENCODE (table));
1111 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1115 table = make_byte_table (table);
1116 XBYTE_TABLE(table)->property[idx] = value;
1124 make_char_id_table (Lisp_Object initval)
1127 obj = Fmake_char_table (Qgeneric);
1128 fill_char_table (XCHAR_TABLE (obj), initval);
1133 Lisp_Object Qcomposition;
1134 Lisp_Object Qrep_decomposition;
1135 Lisp_Object Qto_decomposition_at_superscript;
1136 Lisp_Object Qto_decomposition_at_circled;
1137 Lisp_Object Q_canonical;
1138 Lisp_Object Q_halfwidth_of;
1139 Lisp_Object Q_superscript_of;
1140 Lisp_Object Q_subscript_of;
1141 Lisp_Object Q_circled_of;
1142 Lisp_Object Q_decomposition;
1143 Lisp_Object Q_identical;
1144 Lisp_Object Q_identical_from;
1145 Lisp_Object Q_denotational;
1146 Lisp_Object Q_denotational_from;
1147 Lisp_Object Q_subsumptive;
1148 Lisp_Object Q_subsumptive_from;
1149 Lisp_Object Q_component;
1150 Lisp_Object Q_component_of;
1151 Lisp_Object Qto_ucs;
1152 Lisp_Object Q_ucs_unified;
1153 Lisp_Object Qcompat;
1154 Lisp_Object Qisolated;
1155 Lisp_Object Qinitial;
1156 Lisp_Object Qmedial;
1158 Lisp_Object Qvertical;
1159 Lisp_Object QnoBreak;
1160 Lisp_Object Qfraction;
1163 Lisp_Object Qcircle;
1164 Lisp_Object Qsquare;
1166 Lisp_Object Qnarrow;
1170 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1173 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1179 else if (EQ (v, Qcompat))
1181 else if (EQ (v, Qisolated))
1183 else if (EQ (v, Qinitial))
1185 else if (EQ (v, Qmedial))
1187 else if (EQ (v, Qfinal))
1189 else if (EQ (v, Qvertical))
1191 else if (EQ (v, QnoBreak))
1193 else if (EQ (v, Qfraction))
1195 else if (EQ (v, Qsuper))
1197 else if (EQ (v, Qsub))
1199 else if (EQ (v, Qcircle))
1201 else if (EQ (v, Qsquare))
1203 else if (EQ (v, Qwide))
1205 else if (EQ (v, Qnarrow))
1207 else if (EQ (v, Qsmall))
1209 else if (EQ (v, Qfont))
1212 signal_simple_error (err_msg, err_arg);
1215 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1216 Return character corresponding with list.
1220 Lisp_Object base, modifier;
1224 signal_simple_error ("Invalid value for composition", list);
1227 while (!NILP (rest))
1232 signal_simple_error ("Invalid value for composition", list);
1233 modifier = Fcar (rest);
1235 base = Fcdr (Fassq (modifier,
1236 Fchar_feature (base, Qcomposition, Qnil,
1242 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1243 Return variants of CHARACTER.
1247 CHECK_CHAR (character);
1250 (Fcopy_list (Fget_char_attribute (character, Q_subsumptive, Qnil)),
1252 (Fcopy_list (Fget_char_attribute (character, Q_denotational, Qnil)),
1254 (Fcopy_list (Fget_char_attribute (character, Q_identical, Qnil)),
1255 Fcopy_list (Fchar_feature (character, Q_ucs_unified, Qnil,
1262 /* A char table maps from ranges of characters to values.
1264 Implementing a general data structure that maps from arbitrary
1265 ranges of numbers to values is tricky to do efficiently. As it
1266 happens, it should suffice (and is usually more convenient, anyway)
1267 when dealing with characters to restrict the sorts of ranges that
1268 can be assigned values, as follows:
1271 2) All characters in a charset.
1272 3) All characters in a particular row of a charset, where a "row"
1273 means all characters with the same first byte.
1274 4) A particular character in a charset.
1276 We use char tables to generalize the 256-element vectors now
1277 littering the Emacs code.
1279 Possible uses (all should be converted at some point):
1285 5) keyboard-translate-table?
1288 abstract type to generalize the Emacs vectors and Mule
1289 vectors-of-vectors goo.
1292 /************************************************************************/
1293 /* Char Table object */
1294 /************************************************************************/
1296 #if defined(MULE)&&!defined(UTF2000)
1299 mark_char_table_entry (Lisp_Object obj)
1301 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1304 for (i = 0; i < 96; i++)
1306 mark_object (cte->level2[i]);
1312 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1314 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1315 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1318 for (i = 0; i < 96; i++)
1319 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1325 static unsigned long
1326 char_table_entry_hash (Lisp_Object obj, int depth)
1328 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1330 return internal_array_hash (cte->level2, 96, depth);
1333 static const struct lrecord_description char_table_entry_description[] = {
1334 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1338 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1339 mark_char_table_entry, internal_object_printer,
1340 0, char_table_entry_equal,
1341 char_table_entry_hash,
1342 char_table_entry_description,
1343 Lisp_Char_Table_Entry);
1347 mark_char_table (Lisp_Object obj)
1349 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1352 mark_object (ct->table);
1353 mark_object (ct->name);
1354 #ifndef HAVE_LIBCHISE
1355 mark_object (ct->db);
1360 for (i = 0; i < NUM_ASCII_CHARS; i++)
1361 mark_object (ct->ascii[i]);
1363 for (i = 0; i < NUM_LEADING_BYTES; i++)
1364 mark_object (ct->level1[i]);
1368 return ct->default_value;
1370 return ct->mirror_table;
1374 /* WARNING: All functions of this nature need to be written extremely
1375 carefully to avoid crashes during GC. Cf. prune_specifiers()
1376 and prune_weak_hash_tables(). */
1379 prune_syntax_tables (void)
1381 Lisp_Object rest, prev = Qnil;
1383 for (rest = Vall_syntax_tables;
1385 rest = XCHAR_TABLE (rest)->next_table)
1387 if (! marked_p (rest))
1389 /* This table is garbage. Remove it from the list. */
1391 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1393 XCHAR_TABLE (prev)->next_table =
1394 XCHAR_TABLE (rest)->next_table;
1400 char_table_type_to_symbol (enum char_table_type type)
1405 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1406 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1407 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1408 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1410 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1415 static enum char_table_type
1416 symbol_to_char_table_type (Lisp_Object symbol)
1418 CHECK_SYMBOL (symbol);
1420 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1421 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1422 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1423 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1425 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1428 signal_simple_error ("Unrecognized char table type", symbol);
1429 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1434 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1435 Lisp_Object printcharfun)
1439 write_c_string (" (", printcharfun);
1440 print_internal (make_char (first), printcharfun, 0);
1441 write_c_string (" ", printcharfun);
1442 print_internal (make_char (last), printcharfun, 0);
1443 write_c_string (") ", printcharfun);
1447 write_c_string (" ", printcharfun);
1448 print_internal (make_char (first), printcharfun, 0);
1449 write_c_string (" ", printcharfun);
1451 print_internal (val, printcharfun, 1);
1455 #if defined(MULE)&&!defined(UTF2000)
1458 print_chartab_charset_row (Lisp_Object charset,
1460 Lisp_Char_Table_Entry *cte,
1461 Lisp_Object printcharfun)
1464 Lisp_Object cat = Qunbound;
1467 for (i = 32; i < 128; i++)
1469 Lisp_Object pam = cte->level2[i - 32];
1481 print_chartab_range (MAKE_CHAR (charset, first, 0),
1482 MAKE_CHAR (charset, i - 1, 0),
1485 print_chartab_range (MAKE_CHAR (charset, row, first),
1486 MAKE_CHAR (charset, row, i - 1),
1496 print_chartab_range (MAKE_CHAR (charset, first, 0),
1497 MAKE_CHAR (charset, i - 1, 0),
1500 print_chartab_range (MAKE_CHAR (charset, row, first),
1501 MAKE_CHAR (charset, row, i - 1),
1507 print_chartab_two_byte_charset (Lisp_Object charset,
1508 Lisp_Char_Table_Entry *cte,
1509 Lisp_Object printcharfun)
1513 for (i = 32; i < 128; i++)
1515 Lisp_Object jen = cte->level2[i - 32];
1517 if (!CHAR_TABLE_ENTRYP (jen))
1521 write_c_string (" [", printcharfun);
1522 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1523 sprintf (buf, " %d] ", i);
1524 write_c_string (buf, printcharfun);
1525 print_internal (jen, printcharfun, 0);
1528 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1536 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1538 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1541 struct gcpro gcpro1, gcpro2;
1542 GCPRO2 (obj, printcharfun);
1544 write_c_string ("#s(char-table ", printcharfun);
1545 write_c_string (" ", printcharfun);
1546 write_c_string (string_data
1548 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1550 write_c_string ("\n ", printcharfun);
1551 print_internal (ct->default_value, printcharfun, escapeflag);
1552 for (i = 0; i < 256; i++)
1554 Lisp_Object elt = get_byte_table (ct->table, i);
1555 if (i != 0) write_c_string ("\n ", printcharfun);
1556 if (EQ (elt, Qunbound))
1557 write_c_string ("void", printcharfun);
1559 print_internal (elt, printcharfun, escapeflag);
1562 #else /* non UTF2000 */
1565 sprintf (buf, "#s(char-table type %s data (",
1566 string_data (symbol_name (XSYMBOL
1567 (char_table_type_to_symbol (ct->type)))));
1568 write_c_string (buf, printcharfun);
1570 /* Now write out the ASCII/Control-1 stuff. */
1574 Lisp_Object val = Qunbound;
1576 for (i = 0; i < NUM_ASCII_CHARS; i++)
1585 if (!EQ (ct->ascii[i], val))
1587 print_chartab_range (first, i - 1, val, printcharfun);
1594 print_chartab_range (first, i - 1, val, printcharfun);
1601 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1604 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1605 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1607 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1608 || i == LEADING_BYTE_CONTROL_1)
1610 if (!CHAR_TABLE_ENTRYP (ann))
1612 write_c_string (" ", printcharfun);
1613 print_internal (XCHARSET_NAME (charset),
1615 write_c_string (" ", printcharfun);
1616 print_internal (ann, printcharfun, 0);
1620 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1621 if (XCHARSET_DIMENSION (charset) == 1)
1622 print_chartab_charset_row (charset, -1, cte, printcharfun);
1624 print_chartab_two_byte_charset (charset, cte, printcharfun);
1629 #endif /* non UTF2000 */
1631 write_c_string ("))", printcharfun);
1635 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1637 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1638 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1641 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1645 for (i = 0; i < 256; i++)
1647 if (!internal_equal (get_byte_table (ct1->table, i),
1648 get_byte_table (ct2->table, i), 0))
1652 for (i = 0; i < NUM_ASCII_CHARS; i++)
1653 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1657 for (i = 0; i < NUM_LEADING_BYTES; i++)
1658 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1661 #endif /* non UTF2000 */
1666 static unsigned long
1667 char_table_hash (Lisp_Object obj, int depth)
1669 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1671 return byte_table_hash (ct->table, depth + 1);
1673 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1676 hashval = HASH2 (hashval,
1677 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1683 static const struct lrecord_description char_table_description[] = {
1685 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1686 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1687 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1688 #ifndef HAVE_LIBCHISE
1689 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1692 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1694 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1698 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1700 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1704 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1705 mark_char_table, print_char_table, 0,
1706 char_table_equal, char_table_hash,
1707 char_table_description,
1710 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1711 Return non-nil if OBJECT is a char table.
1713 A char table is a table that maps characters (or ranges of characters)
1714 to values. Char tables are specialized for characters, only allowing
1715 particular sorts of ranges to be assigned values. Although this
1716 loses in generality, it makes for extremely fast (constant-time)
1717 lookups, and thus is feasible for applications that do an extremely
1718 large number of lookups (e.g. scanning a buffer for a character in
1719 a particular syntax, where a lookup in the syntax table must occur
1720 once per character).
1722 When Mule support exists, the types of ranges that can be assigned
1725 -- all characters (represented by t)
1726 -- an entire charset
1727 -- a single row in a two-octet charset (represented by a vector of two
1728 elements: a two-octet charset and a row number; the row must be an
1729 integer, not a character)
1730 -- a single character
1732 When Mule support is not present, the types of ranges that can be
1735 -- all characters (represented by t)
1736 -- a single character
1738 To create a char table, use `make-char-table'.
1739 To modify a char table, use `put-char-table' or `remove-char-table'.
1740 To retrieve the value for a particular character, use `get-char-table'.
1741 See also `map-char-table', `clear-char-table', `copy-char-table',
1742 `valid-char-table-type-p', `char-table-type-list',
1743 `valid-char-table-value-p', and `check-char-table-value'.
1747 return CHAR_TABLEP (object) ? Qt : Qnil;
1750 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1751 Return a list of the recognized char table types.
1752 See `valid-char-table-type-p'.
1757 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1759 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1763 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1764 Return t if TYPE if a recognized char table type.
1766 Each char table type is used for a different purpose and allows different
1767 sorts of values. The different char table types are
1770 Used for category tables, which specify the regexp categories
1771 that a character is in. The valid values are nil or a
1772 bit vector of 95 elements. Higher-level Lisp functions are
1773 provided for working with category tables. Currently categories
1774 and category tables only exist when Mule support is present.
1776 A generalized char table, for mapping from one character to
1777 another. Used for case tables, syntax matching tables,
1778 `keyboard-translate-table', etc. The valid values are characters.
1780 An even more generalized char table, for mapping from a
1781 character to anything.
1783 Used for display tables, which specify how a particular character
1784 is to appear when displayed. #### Not yet implemented.
1786 Used for syntax tables, which specify the syntax of a particular
1787 character. Higher-level Lisp functions are provided for
1788 working with syntax tables. The valid values are integers.
1793 return (EQ (type, Qchar) ||
1795 EQ (type, Qcategory) ||
1797 EQ (type, Qdisplay) ||
1798 EQ (type, Qgeneric) ||
1799 EQ (type, Qsyntax)) ? Qt : Qnil;
1802 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1803 Return the type of CHAR-TABLE.
1804 See `valid-char-table-type-p'.
1808 CHECK_CHAR_TABLE (char_table);
1809 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1813 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1816 ct->table = Qunbound;
1817 ct->default_value = value;
1822 for (i = 0; i < NUM_ASCII_CHARS; i++)
1823 ct->ascii[i] = value;
1825 for (i = 0; i < NUM_LEADING_BYTES; i++)
1826 ct->level1[i] = value;
1831 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1832 update_syntax_table (ct);
1836 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1837 Reset CHAR-TABLE to its default state.
1841 Lisp_Char_Table *ct;
1843 CHECK_CHAR_TABLE (char_table);
1844 ct = XCHAR_TABLE (char_table);
1848 case CHAR_TABLE_TYPE_CHAR:
1849 fill_char_table (ct, make_char (0));
1851 case CHAR_TABLE_TYPE_DISPLAY:
1852 case CHAR_TABLE_TYPE_GENERIC:
1854 case CHAR_TABLE_TYPE_CATEGORY:
1856 fill_char_table (ct, Qnil);
1859 case CHAR_TABLE_TYPE_SYNTAX:
1860 fill_char_table (ct, make_int (Sinherit));
1870 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1871 Return a new, empty char table of type TYPE.
1872 Currently recognized types are 'char, 'category, 'display, 'generic,
1873 and 'syntax. See `valid-char-table-type-p'.
1877 Lisp_Char_Table *ct;
1879 enum char_table_type ty = symbol_to_char_table_type (type);
1881 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1884 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1886 ct->mirror_table = Fmake_char_table (Qgeneric);
1887 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1891 ct->mirror_table = Qnil;
1894 #ifndef HAVE_LIBCHISE
1898 ct->next_table = Qnil;
1899 XSETCHAR_TABLE (obj, ct);
1900 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1902 ct->next_table = Vall_syntax_tables;
1903 Vall_syntax_tables = obj;
1905 Freset_char_table (obj);
1909 #if defined(MULE)&&!defined(UTF2000)
1912 make_char_table_entry (Lisp_Object initval)
1916 Lisp_Char_Table_Entry *cte =
1917 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1919 for (i = 0; i < 96; i++)
1920 cte->level2[i] = initval;
1922 XSETCHAR_TABLE_ENTRY (obj, cte);
1927 copy_char_table_entry (Lisp_Object entry)
1929 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1932 Lisp_Char_Table_Entry *ctenew =
1933 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1935 for (i = 0; i < 96; i++)
1937 Lisp_Object new = cte->level2[i];
1938 if (CHAR_TABLE_ENTRYP (new))
1939 ctenew->level2[i] = copy_char_table_entry (new);
1941 ctenew->level2[i] = new;
1944 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1950 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1951 Return a new char table which is a copy of CHAR-TABLE.
1952 It will contain the same values for the same characters and ranges
1953 as CHAR-TABLE. The values will not themselves be copied.
1957 Lisp_Char_Table *ct, *ctnew;
1963 CHECK_CHAR_TABLE (char_table);
1964 ct = XCHAR_TABLE (char_table);
1965 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1966 ctnew->type = ct->type;
1968 ctnew->default_value = ct->default_value;
1969 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1970 ctnew->name = ct->name;
1971 #ifndef HAVE_LIBCHISE
1975 if (UINT8_BYTE_TABLE_P (ct->table))
1977 ctnew->table = copy_uint8_byte_table (ct->table);
1979 else if (UINT16_BYTE_TABLE_P (ct->table))
1981 ctnew->table = copy_uint16_byte_table (ct->table);
1983 else if (BYTE_TABLE_P (ct->table))
1985 ctnew->table = copy_byte_table (ct->table);
1987 else if (!UNBOUNDP (ct->table))
1988 ctnew->table = ct->table;
1989 #else /* non UTF2000 */
1991 for (i = 0; i < NUM_ASCII_CHARS; i++)
1993 Lisp_Object new = ct->ascii[i];
1995 assert (! (CHAR_TABLE_ENTRYP (new)));
1997 ctnew->ascii[i] = new;
2002 for (i = 0; i < NUM_LEADING_BYTES; i++)
2004 Lisp_Object new = ct->level1[i];
2005 if (CHAR_TABLE_ENTRYP (new))
2006 ctnew->level1[i] = copy_char_table_entry (new);
2008 ctnew->level1[i] = new;
2012 #endif /* non UTF2000 */
2015 if (CHAR_TABLEP (ct->mirror_table))
2016 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
2018 ctnew->mirror_table = ct->mirror_table;
2020 ctnew->next_table = Qnil;
2021 XSETCHAR_TABLE (obj, ctnew);
2022 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
2024 ctnew->next_table = Vall_syntax_tables;
2025 Vall_syntax_tables = obj;
2030 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
2032 XCHARSET_CELL_RANGE (Lisp_Object ccs)
2034 switch (XCHARSET_CHARS (ccs))
2037 return (33 << 8) | 126;
2039 return (32 << 8) | 127;
2042 return (0 << 8) | 127;
2044 return (0 << 8) | 255;
2056 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
2059 outrange->type = CHARTAB_RANGE_ALL;
2061 else if (EQ (range, Qnil))
2062 outrange->type = CHARTAB_RANGE_DEFAULT;
2064 else if (CHAR_OR_CHAR_INTP (range))
2066 outrange->type = CHARTAB_RANGE_CHAR;
2067 outrange->ch = XCHAR_OR_CHAR_INT (range);
2071 signal_simple_error ("Range must be t or a character", range);
2073 else if (VECTORP (range))
2075 Lisp_Vector *vec = XVECTOR (range);
2076 Lisp_Object *elts = vector_data (vec);
2077 int cell_min, cell_max;
2079 outrange->type = CHARTAB_RANGE_ROW;
2080 outrange->charset = Fget_charset (elts[0]);
2081 CHECK_INT (elts[1]);
2082 outrange->row = XINT (elts[1]);
2083 if (XCHARSET_DIMENSION (outrange->charset) < 2)
2084 signal_simple_error ("Charset in row vector must be multi-byte",
2088 int ret = XCHARSET_CELL_RANGE (outrange->charset);
2090 cell_min = ret >> 8;
2091 cell_max = ret & 0xFF;
2093 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2094 check_int_range (outrange->row, cell_min, cell_max);
2096 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2098 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2099 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2101 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2103 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2104 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2105 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2113 if (!CHARSETP (range) && !SYMBOLP (range))
2115 ("Char table range must be t, charset, char, or vector", range);
2116 outrange->type = CHARTAB_RANGE_CHARSET;
2117 outrange->charset = Fget_charset (range);
2122 #if defined(MULE)&&!defined(UTF2000)
2124 /* called from CHAR_TABLE_VALUE(). */
2126 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2131 Lisp_Object charset;
2133 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2138 BREAKUP_CHAR (c, charset, byte1, byte2);
2140 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2142 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2143 if (CHAR_TABLE_ENTRYP (val))
2145 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2146 val = cte->level2[byte1 - 32];
2147 if (CHAR_TABLE_ENTRYP (val))
2149 cte = XCHAR_TABLE_ENTRY (val);
2150 assert (byte2 >= 32);
2151 val = cte->level2[byte2 - 32];
2152 assert (!CHAR_TABLE_ENTRYP (val));
2162 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2166 Lisp_Object ret = get_char_id_table (ct, ch);
2171 if (EQ (CHAR_TABLE_NAME (ct), Qdowncase))
2172 ret = Fchar_feature (make_char (ch), Q_lowercase, Qnil,
2174 else if (EQ (CHAR_TABLE_NAME (ct), Qflippedcase))
2175 ret = Fchar_feature (make_char (ch), Q_uppercase, Qnil,
2181 ret = Ffind_char (ret);
2189 Lisp_Object charset;
2193 BREAKUP_CHAR (ch, charset, byte1, byte2);
2195 if (EQ (charset, Vcharset_ascii))
2196 val = ct->ascii[byte1];
2197 else if (EQ (charset, Vcharset_control_1))
2198 val = ct->ascii[byte1 + 128];
2201 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2202 val = ct->level1[lb];
2203 if (CHAR_TABLE_ENTRYP (val))
2205 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2206 val = cte->level2[byte1 - 32];
2207 if (CHAR_TABLE_ENTRYP (val))
2209 cte = XCHAR_TABLE_ENTRY (val);
2210 assert (byte2 >= 32);
2211 val = cte->level2[byte2 - 32];
2212 assert (!CHAR_TABLE_ENTRYP (val));
2219 #else /* not MULE */
2220 return ct->ascii[(unsigned char)ch];
2221 #endif /* not MULE */
2225 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2226 Find value for CHARACTER in CHAR-TABLE.
2228 (character, char_table))
2230 CHECK_CHAR_TABLE (char_table);
2231 CHECK_CHAR_COERCE_INT (character);
2233 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2236 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2237 Find value for RANGE in CHAR-TABLE.
2238 If there is more than one value, return MULTI (defaults to nil).
2240 Valid values for RANGE are single characters, charsets, a row in a
2241 two-octet charset, and all characters. See `put-char-table'.
2243 (range, char_table, multi))
2245 Lisp_Char_Table *ct;
2246 struct chartab_range rainj;
2248 if (CHAR_OR_CHAR_INTP (range))
2249 return Fget_char_table (range, char_table);
2250 CHECK_CHAR_TABLE (char_table);
2251 ct = XCHAR_TABLE (char_table);
2253 decode_char_table_range (range, &rainj);
2256 case CHARTAB_RANGE_ALL:
2259 if (UINT8_BYTE_TABLE_P (ct->table))
2261 else if (UINT16_BYTE_TABLE_P (ct->table))
2263 else if (BYTE_TABLE_P (ct->table))
2267 #else /* non UTF2000 */
2269 Lisp_Object first = ct->ascii[0];
2271 for (i = 1; i < NUM_ASCII_CHARS; i++)
2272 if (!EQ (first, ct->ascii[i]))
2276 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2279 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2280 || i == LEADING_BYTE_ASCII
2281 || i == LEADING_BYTE_CONTROL_1)
2283 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2289 #endif /* non UTF2000 */
2293 case CHARTAB_RANGE_CHARSET:
2297 if (EQ (rainj.charset, Vcharset_ascii))
2300 Lisp_Object first = ct->ascii[0];
2302 for (i = 1; i < 128; i++)
2303 if (!EQ (first, ct->ascii[i]))
2308 if (EQ (rainj.charset, Vcharset_control_1))
2311 Lisp_Object first = ct->ascii[128];
2313 for (i = 129; i < 160; i++)
2314 if (!EQ (first, ct->ascii[i]))
2320 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2322 if (CHAR_TABLE_ENTRYP (val))
2328 case CHARTAB_RANGE_ROW:
2333 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2335 if (!CHAR_TABLE_ENTRYP (val))
2337 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2338 if (CHAR_TABLE_ENTRYP (val))
2342 #endif /* not UTF2000 */
2343 #endif /* not MULE */
2346 case CHARTAB_RANGE_DEFAULT:
2347 return ct->default_value;
2348 #endif /* not UTF2000 */
2354 return Qnil; /* not reached */
2358 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2359 Error_behavior errb)
2363 case CHAR_TABLE_TYPE_SYNTAX:
2364 if (!ERRB_EQ (errb, ERROR_ME))
2365 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2366 && CHAR_OR_CHAR_INTP (XCDR (value)));
2369 Lisp_Object cdr = XCDR (value);
2370 CHECK_INT (XCAR (value));
2371 CHECK_CHAR_COERCE_INT (cdr);
2378 case CHAR_TABLE_TYPE_CATEGORY:
2379 if (!ERRB_EQ (errb, ERROR_ME))
2380 return CATEGORY_TABLE_VALUEP (value);
2381 CHECK_CATEGORY_TABLE_VALUE (value);
2385 case CHAR_TABLE_TYPE_GENERIC:
2388 case CHAR_TABLE_TYPE_DISPLAY:
2390 maybe_signal_simple_error ("Display char tables not yet implemented",
2391 value, Qchar_table, errb);
2394 case CHAR_TABLE_TYPE_CHAR:
2395 if (!ERRB_EQ (errb, ERROR_ME))
2396 return CHAR_OR_CHAR_INTP (value);
2397 CHECK_CHAR_COERCE_INT (value);
2404 return 0; /* not reached */
2408 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2412 case CHAR_TABLE_TYPE_SYNTAX:
2415 Lisp_Object car = XCAR (value);
2416 Lisp_Object cdr = XCDR (value);
2417 CHECK_CHAR_COERCE_INT (cdr);
2418 return Fcons (car, cdr);
2421 case CHAR_TABLE_TYPE_CHAR:
2422 CHECK_CHAR_COERCE_INT (value);
2430 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2431 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2433 (value, char_table_type))
2435 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2437 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2440 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2441 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2443 (value, char_table_type))
2445 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2447 check_valid_char_table_value (value, type, ERROR_ME);
2452 Lisp_Char_Table* char_attribute_table_to_put;
2453 Lisp_Object Qput_char_table_map_function;
2454 Lisp_Object value_to_put;
2456 DEFUN ("put-char-table-map-function",
2457 Fput_char_table_map_function, 2, 2, 0, /*
2458 For internal use. Don't use it.
2462 put_char_id_table_0 (char_attribute_table_to_put,
2463 XCHAR (c), value_to_put);
2468 /* Assign VAL to all characters in RANGE in char table CT. */
2471 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2474 switch (range->type)
2476 case CHARTAB_RANGE_ALL:
2477 fill_char_table (ct, val);
2478 return; /* avoid the duplicate call to update_syntax_table() below,
2479 since fill_char_table() also did that. */
2482 case CHARTAB_RANGE_DEFAULT:
2483 ct->default_value = val;
2488 case CHARTAB_RANGE_CHARSET:
2491 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2493 if ( CHAR_TABLEP (encoding_table) )
2495 Lisp_Object mother = XCHARSET_MOTHER (range->charset);
2497 char_attribute_table_to_put = ct;
2499 Fmap_char_attribute (Qput_char_table_map_function,
2500 XCHAR_TABLE_NAME (encoding_table),
2502 if ( CHARSETP (mother) )
2504 struct chartab_range r;
2506 r.type = CHARTAB_RANGE_CHARSET;
2508 put_char_table (ct, &r, val);
2516 for (c = 0; c < 1 << 24; c++)
2518 if ( charset_code_point (range->charset, c) >= 0 )
2519 put_char_id_table_0 (ct, c, val);
2525 if (EQ (range->charset, Vcharset_ascii))
2528 for (i = 0; i < 128; i++)
2531 else if (EQ (range->charset, Vcharset_control_1))
2534 for (i = 128; i < 160; i++)
2539 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2540 ct->level1[lb] = val;
2545 case CHARTAB_RANGE_ROW:
2548 int cell_min, cell_max, i;
2550 i = XCHARSET_CELL_RANGE (range->charset);
2552 cell_max = i & 0xFF;
2553 for (i = cell_min; i <= cell_max; i++)
2556 = DECODE_CHAR (range->charset, (range->row << 8) | i, 0);
2558 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2559 put_char_id_table_0 (ct, ch, val);
2564 Lisp_Char_Table_Entry *cte;
2565 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2566 /* make sure that there is a separate entry for the row. */
2567 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2568 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2569 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2570 cte->level2[range->row - 32] = val;
2572 #endif /* not UTF2000 */
2576 case CHARTAB_RANGE_CHAR:
2578 put_char_id_table_0 (ct, range->ch, val);
2582 Lisp_Object charset;
2585 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2586 if (EQ (charset, Vcharset_ascii))
2587 ct->ascii[byte1] = val;
2588 else if (EQ (charset, Vcharset_control_1))
2589 ct->ascii[byte1 + 128] = val;
2592 Lisp_Char_Table_Entry *cte;
2593 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2594 /* make sure that there is a separate entry for the row. */
2595 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2596 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2597 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2598 /* now CTE is a char table entry for the charset;
2599 each entry is for a single row (or character of
2600 a one-octet charset). */
2601 if (XCHARSET_DIMENSION (charset) == 1)
2602 cte->level2[byte1 - 32] = val;
2605 /* assigning to one character in a two-octet charset. */
2606 /* make sure that the charset row contains a separate
2607 entry for each character. */
2608 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2609 cte->level2[byte1 - 32] =
2610 make_char_table_entry (cte->level2[byte1 - 32]);
2611 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2612 cte->level2[byte2 - 32] = val;
2616 #else /* not MULE */
2617 ct->ascii[(unsigned char) (range->ch)] = val;
2619 #endif /* not MULE */
2623 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2624 update_syntax_table (ct);
2628 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2629 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2631 RANGE specifies one or more characters to be affected and should be
2632 one of the following:
2634 -- t (all characters are affected)
2635 -- A charset (only allowed when Mule support is present)
2636 -- A vector of two elements: a two-octet charset and a row number; the row
2637 must be an integer, not a character (only allowed when Mule support is
2639 -- A single character
2641 VALUE must be a value appropriate for the type of CHAR-TABLE.
2642 See `valid-char-table-type-p'.
2644 (range, value, char_table))
2646 Lisp_Char_Table *ct;
2647 struct chartab_range rainj;
2649 CHECK_CHAR_TABLE (char_table);
2650 ct = XCHAR_TABLE (char_table);
2651 check_valid_char_table_value (value, ct->type, ERROR_ME);
2652 decode_char_table_range (range, &rainj);
2653 value = canonicalize_char_table_value (value, ct->type);
2654 put_char_table (ct, &rainj, value);
2659 /* Map FN over the ASCII chars in CT. */
2662 map_over_charset_ascii (Lisp_Char_Table *ct,
2663 int (*fn) (struct chartab_range *range,
2664 Lisp_Object val, void *arg),
2667 struct chartab_range rainj;
2676 rainj.type = CHARTAB_RANGE_CHAR;
2678 for (i = start, retval = 0; i < stop && retval == 0; i++)
2680 rainj.ch = (Emchar) i;
2681 retval = (fn) (&rainj, ct->ascii[i], arg);
2689 /* Map FN over the Control-1 chars in CT. */
2692 map_over_charset_control_1 (Lisp_Char_Table *ct,
2693 int (*fn) (struct chartab_range *range,
2694 Lisp_Object val, void *arg),
2697 struct chartab_range rainj;
2700 int stop = start + 32;
2702 rainj.type = CHARTAB_RANGE_CHAR;
2704 for (i = start, retval = 0; i < stop && retval == 0; i++)
2706 rainj.ch = (Emchar) (i);
2707 retval = (fn) (&rainj, ct->ascii[i], arg);
2713 /* Map FN over the row ROW of two-byte charset CHARSET.
2714 There must be a separate value for that row in the char table.
2715 CTE specifies the char table entry for CHARSET. */
2718 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2719 Lisp_Object charset, int row,
2720 int (*fn) (struct chartab_range *range,
2721 Lisp_Object val, void *arg),
2724 Lisp_Object val = cte->level2[row - 32];
2726 if (!CHAR_TABLE_ENTRYP (val))
2728 struct chartab_range rainj;
2730 rainj.type = CHARTAB_RANGE_ROW;
2731 rainj.charset = charset;
2733 return (fn) (&rainj, val, arg);
2737 struct chartab_range rainj;
2739 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2740 int start = charset94_p ? 33 : 32;
2741 int stop = charset94_p ? 127 : 128;
2743 cte = XCHAR_TABLE_ENTRY (val);
2745 rainj.type = CHARTAB_RANGE_CHAR;
2747 for (i = start, retval = 0; i < stop && retval == 0; i++)
2749 rainj.ch = MAKE_CHAR (charset, row, i);
2750 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2758 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2759 int (*fn) (struct chartab_range *range,
2760 Lisp_Object val, void *arg),
2763 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2764 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2766 if (!CHARSETP (charset)
2767 || lb == LEADING_BYTE_ASCII
2768 || lb == LEADING_BYTE_CONTROL_1)
2771 if (!CHAR_TABLE_ENTRYP (val))
2773 struct chartab_range rainj;
2775 rainj.type = CHARTAB_RANGE_CHARSET;
2776 rainj.charset = charset;
2777 return (fn) (&rainj, val, arg);
2781 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2782 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2783 int start = charset94_p ? 33 : 32;
2784 int stop = charset94_p ? 127 : 128;
2787 if (XCHARSET_DIMENSION (charset) == 1)
2789 struct chartab_range rainj;
2790 rainj.type = CHARTAB_RANGE_CHAR;
2792 for (i = start, retval = 0; i < stop && retval == 0; i++)
2794 rainj.ch = MAKE_CHAR (charset, i, 0);
2795 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2800 for (i = start, retval = 0; i < stop && retval == 0; i++)
2801 retval = map_over_charset_row (cte, charset, i, fn, arg);
2809 #endif /* not UTF2000 */
2812 struct map_char_table_for_charset_arg
2814 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2815 Lisp_Char_Table *ct;
2820 map_char_table_for_charset_fun (struct chartab_range *range,
2821 Lisp_Object val, void *arg)
2823 struct map_char_table_for_charset_arg *closure =
2824 (struct map_char_table_for_charset_arg *) arg;
2827 switch (range->type)
2829 case CHARTAB_RANGE_ALL:
2832 case CHARTAB_RANGE_DEFAULT:
2835 case CHARTAB_RANGE_CHARSET:
2838 case CHARTAB_RANGE_ROW:
2841 case CHARTAB_RANGE_CHAR:
2842 ret = get_char_table (range->ch, closure->ct);
2843 if (!UNBOUNDP (ret))
2844 return (closure->fn) (range, ret, closure->arg);
2856 /* Map FN (with client data ARG) over range RANGE in char table CT.
2857 Mapping stops the first time FN returns non-zero, and that value
2858 becomes the return value of map_char_table(). */
2861 map_char_table (Lisp_Char_Table *ct,
2862 struct chartab_range *range,
2863 int (*fn) (struct chartab_range *range,
2864 Lisp_Object val, void *arg),
2867 switch (range->type)
2869 case CHARTAB_RANGE_ALL:
2871 if (!UNBOUNDP (ct->default_value))
2873 struct chartab_range rainj;
2876 rainj.type = CHARTAB_RANGE_DEFAULT;
2877 retval = (fn) (&rainj, ct->default_value, arg);
2881 if (UINT8_BYTE_TABLE_P (ct->table))
2882 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2884 else if (UINT16_BYTE_TABLE_P (ct->table))
2885 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2887 else if (BYTE_TABLE_P (ct->table))
2888 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2890 else if (EQ (ct->table, Qunloaded))
2893 struct chartab_range rainj;
2896 Emchar c1 = c + unit;
2899 rainj.type = CHARTAB_RANGE_CHAR;
2901 for (retval = 0; c < c1 && retval == 0; c++)
2903 Lisp_Object ret = get_char_id_table (ct, c);
2905 if (!UNBOUNDP (ret))
2908 retval = (fn) (&rainj, ct->table, arg);
2913 ct->table = Qunbound;
2916 else if (!UNBOUNDP (ct->table))
2917 return (fn) (range, ct->table, arg);
2923 retval = map_over_charset_ascii (ct, fn, arg);
2927 retval = map_over_charset_control_1 (ct, fn, arg);
2932 Charset_ID start = MIN_LEADING_BYTE;
2933 Charset_ID stop = start + NUM_LEADING_BYTES;
2935 for (i = start, retval = 0; i < stop && retval == 0; i++)
2937 retval = map_over_other_charset (ct, i, fn, arg);
2946 case CHARTAB_RANGE_DEFAULT:
2947 if (!UNBOUNDP (ct->default_value))
2948 return (fn) (range, ct->default_value, arg);
2953 case CHARTAB_RANGE_CHARSET:
2956 Lisp_Object encoding_table
2957 = XCHARSET_ENCODING_TABLE (range->charset);
2959 if (!NILP (encoding_table))
2961 struct chartab_range rainj;
2962 struct map_char_table_for_charset_arg mcarg;
2965 if (XCHAR_TABLE_UNLOADED(encoding_table))
2966 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2971 rainj.type = CHARTAB_RANGE_ALL;
2972 return map_char_table (XCHAR_TABLE(encoding_table),
2974 &map_char_table_for_charset_fun,
2980 return map_over_other_charset (ct,
2981 XCHARSET_LEADING_BYTE (range->charset),
2985 case CHARTAB_RANGE_ROW:
2988 int cell_min, cell_max, i;
2990 struct chartab_range rainj;
2992 i = XCHARSET_CELL_RANGE (range->charset);
2994 cell_max = i & 0xFF;
2995 rainj.type = CHARTAB_RANGE_CHAR;
2996 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2999 = DECODE_CHAR (range->charset, (range->row << 8) | i, 0);
3001 if ( charset_code_point (range->charset, ch, 0) >= 0 )
3004 = get_byte_table (get_byte_table
3008 (unsigned char)(ch >> 24)),
3009 (unsigned char) (ch >> 16)),
3010 (unsigned char) (ch >> 8)),
3011 (unsigned char) ch);
3014 val = ct->default_value;
3016 retval = (fn) (&rainj, val, arg);
3023 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
3024 - MIN_LEADING_BYTE];
3025 if (!CHAR_TABLE_ENTRYP (val))
3027 struct chartab_range rainj;
3029 rainj.type = CHARTAB_RANGE_ROW;
3030 rainj.charset = range->charset;
3031 rainj.row = range->row;
3032 return (fn) (&rainj, val, arg);
3035 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
3036 range->charset, range->row,
3039 #endif /* not UTF2000 */
3042 case CHARTAB_RANGE_CHAR:
3044 Emchar ch = range->ch;
3045 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
3047 if (!UNBOUNDP (val))
3049 struct chartab_range rainj;
3051 rainj.type = CHARTAB_RANGE_CHAR;
3053 return (fn) (&rainj, val, arg);
3065 struct slow_map_char_table_arg
3067 Lisp_Object function;
3072 slow_map_char_table_fun (struct chartab_range *range,
3073 Lisp_Object val, void *arg)
3075 Lisp_Object ranjarg = Qnil;
3076 struct slow_map_char_table_arg *closure =
3077 (struct slow_map_char_table_arg *) arg;
3079 switch (range->type)
3081 case CHARTAB_RANGE_ALL:
3086 case CHARTAB_RANGE_DEFAULT:
3092 case CHARTAB_RANGE_CHARSET:
3093 ranjarg = XCHARSET_NAME (range->charset);
3096 case CHARTAB_RANGE_ROW:
3097 ranjarg = vector2 (XCHARSET_NAME (range->charset),
3098 make_int (range->row));
3101 case CHARTAB_RANGE_CHAR:
3102 ranjarg = make_char (range->ch);
3108 closure->retval = call2 (closure->function, ranjarg, val);
3109 return !NILP (closure->retval);
3112 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
3113 Map FUNCTION over CHAR-TABLE until it returns non-nil; return that value.
3114 FUNCTION is called with two arguments, each key and entry in the table.
3116 RANGE specifies a subrange to map over and is in the same format as
3117 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3120 (function, char_table, range))
3122 Lisp_Char_Table *ct;
3123 struct slow_map_char_table_arg slarg;
3124 struct gcpro gcpro1, gcpro2;
3125 struct chartab_range rainj;
3127 CHECK_CHAR_TABLE (char_table);
3128 ct = XCHAR_TABLE (char_table);
3131 decode_char_table_range (range, &rainj);
3132 slarg.function = function;
3133 slarg.retval = Qnil;
3134 GCPRO2 (slarg.function, slarg.retval);
3135 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3138 return slarg.retval;
3142 /************************************************************************/
3143 /* Character Attributes */
3144 /************************************************************************/
3148 Lisp_Object Vchar_attribute_hash_table;
3150 /* We store the char-attributes in hash tables with the names as the
3151 key and the actual char-id-table object as the value. Occasionally
3152 we need to use them in a list format. These routines provide us
3154 struct char_attribute_list_closure
3156 Lisp_Object *char_attribute_list;
3160 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3161 void *char_attribute_list_closure)
3163 /* This function can GC */
3164 struct char_attribute_list_closure *calcl
3165 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3166 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3168 *char_attribute_list = Fcons (key, *char_attribute_list);
3172 #ifdef HAVE_LIBCHISE
3174 char_attribute_list_reset_map_func (CHISE_DS *ds, unsigned char *name)
3176 Fmount_char_attribute_table (intern (name));
3180 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 1, 0, /*
3181 Return the list of all existing character attributes except coded-charsets.
3185 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3186 Return the list of all existing character attributes except coded-charsets.
3191 Lisp_Object char_attribute_list = Qnil;
3192 struct gcpro gcpro1;
3193 struct char_attribute_list_closure char_attribute_list_closure;
3195 #ifdef HAVE_LIBCHISE
3198 open_chise_data_source_maybe ();
3199 chise_ds_foreach_char_feature_name
3200 (default_chise_data_source, &char_attribute_list_reset_map_func);
3203 GCPRO1 (char_attribute_list);
3204 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3205 elisp_maphash (add_char_attribute_to_list_mapper,
3206 Vchar_attribute_hash_table,
3207 &char_attribute_list_closure);
3209 return char_attribute_list;
3212 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3213 Return char-id-table corresponding to ATTRIBUTE.
3217 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3221 /* We store the char-id-tables in hash tables with the attributes as
3222 the key and the actual char-id-table object as the value. Each
3223 char-id-table stores values of an attribute corresponding with
3224 characters. Occasionally we need to get attributes of a character
3225 in a association-list format. These routines provide us with
3227 struct char_attribute_alist_closure
3230 Lisp_Object *char_attribute_alist;
3234 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3235 void *char_attribute_alist_closure)
3237 /* This function can GC */
3238 struct char_attribute_alist_closure *caacl =
3239 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3241 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3242 if (!UNBOUNDP (ret))
3244 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3245 *char_attribute_alist
3246 = Fcons (Fcons (key, ret), *char_attribute_alist);
3251 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3252 Return the alist of attributes of CHARACTER.
3256 struct gcpro gcpro1;
3257 struct char_attribute_alist_closure char_attribute_alist_closure;
3258 Lisp_Object alist = Qnil;
3260 CHECK_CHAR (character);
3263 char_attribute_alist_closure.char_id = XCHAR (character);
3264 char_attribute_alist_closure.char_attribute_alist = &alist;
3265 elisp_maphash (add_char_attribute_alist_mapper,
3266 Vchar_attribute_hash_table,
3267 &char_attribute_alist_closure);
3273 DEFUN ("char-feature-base-name=", Fchar_feature_base_name_eq, 2, 2, 0, /*
3274 Return the alist of attributes of CHARACTER.
3276 (base_name, feature_name))
3278 Lisp_String *bn, *fn;
3279 Bytecount len_bn, len_fn, i;
3280 Bufbyte *ptr_bn, *ptr_fn;
3282 CHECK_SYMBOL (base_name);
3283 CHECK_SYMBOL (feature_name);
3285 bn = XSYMBOL (base_name)->name;
3286 fn = XSYMBOL (feature_name)->name;
3287 len_bn = string_length (bn);
3288 len_fn = string_length (fn);
3290 if ( len_bn > len_fn )
3293 ptr_bn = string_data (bn);
3294 ptr_fn = string_data (fn);
3295 for ( i = len_fn - 1; i >= 0; i-- )
3297 if ( ptr_fn[i] == '*' )
3299 if ( ptr_fn[i] == '@' )
3304 if ( (len_bn == i) && (memcmp (ptr_bn, ptr_fn, len_bn) == 0) )
3310 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3311 Return the value of CHARACTER's ATTRIBUTE.
3312 Return DEFAULT-VALUE if the value is not exist.
3314 (character, attribute, default_value))
3318 CHECK_CHAR (character);
3320 if (CHARSETP (attribute))
3321 attribute = XCHARSET_NAME (attribute);
3323 table = Fgethash (attribute, Vchar_attribute_hash_table,
3325 if (!UNBOUNDP (table))
3327 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3329 if (!UNBOUNDP (ret))
3332 return default_value;
3336 find_char_feature_in_family (Lisp_Object character,
3337 Lisp_Object con_feature,
3338 Lisp_Object feature,
3339 Lisp_Object feature_rel_max)
3341 Lisp_Object ancestors
3342 = Fget_char_attribute (character, con_feature, Qnil);
3344 while (!NILP (ancestors))
3346 Lisp_Object ancestor = XCAR (ancestors);
3349 if (EQ (ancestor, character))
3352 ret = Fchar_feature (ancestor, feature, Qunbound,
3353 Qnil, make_int (0));
3354 if (!UNBOUNDP (ret))
3357 ancestors = XCDR (ancestors);
3359 ret = Fget_char_attribute (ancestor, Q_subsumptive_from, Qnil);
3361 ancestors = nconc2 (Fcopy_sequence (ancestors), ret);
3363 ret = Fget_char_attribute (ancestor, Q_denotational_from, Qnil);
3365 ancestors = nconc2 (Fcopy_sequence (ancestors), ret);
3370 DEFUN ("char-feature", Fchar_feature, 2, 5, 0, /*
3371 Return the value of CHARACTER's FEATURE.
3372 Return DEFAULT-VALUE if the value is not exist.
3374 (character, attribute, default_value,
3375 feature_rel_max, char_rel_max))
3378 = Fget_char_attribute (character, attribute, Qunbound);
3380 if (!UNBOUNDP (ret))
3383 if (NILP (feature_rel_max)
3384 || (INTP (feature_rel_max) &&
3385 XINT (feature_rel_max) > 0))
3387 Lisp_String* name = symbol_name (XSYMBOL (attribute));
3388 Bufbyte *name_str = string_data (name);
3390 if (name_str[0] == '=' && name_str[1] == '>')
3392 Bytecount length = string_length (name) - 1;
3393 Lisp_Object map_to = make_uninit_string (length);
3395 memcpy (XSTRING_DATA (map_to) + 1, name_str + 2, length - 1);
3396 XSTRING_DATA(map_to)[0] = '=';
3397 ret = Fchar_feature (character, Fintern (map_to, Qnil),
3399 NILP (feature_rel_max)
3401 : make_int (XINT (feature_rel_max) - 1),
3403 if (!UNBOUNDP (ret))
3408 if ( !(EQ (attribute, Q_identical)) &&
3409 !(EQ (attribute, Q_subsumptive_from)) &&
3410 !(EQ (attribute, Q_denotational_from)) &&
3411 ( (NILP (char_rel_max)
3412 || (INTP (char_rel_max) &&
3413 XINT (char_rel_max) > 0)) ) )
3415 Lisp_String* name = symbol_name (XSYMBOL (attribute));
3416 Bufbyte *name_str = string_data (name);
3418 if ( (name_str[0] != '=') || (name_str[1] == '>') )
3420 ret = find_char_feature_in_family (character, Q_identical,
3421 attribute, feature_rel_max);
3422 if (!UNBOUNDP (ret))
3425 ret = find_char_feature_in_family (character, Q_subsumptive_from,
3426 attribute, feature_rel_max);
3427 if (!UNBOUNDP (ret))
3430 ret = find_char_feature_in_family (character, Q_denotational_from,
3431 attribute, feature_rel_max);
3432 if (!UNBOUNDP (ret))
3436 return default_value;
3440 put_char_composition (Lisp_Object character, Lisp_Object value);
3442 put_char_composition (Lisp_Object character, Lisp_Object value)
3445 signal_simple_error ("Invalid value for =decomposition",
3448 if (CONSP (XCDR (value)))
3450 if (NILP (Fcdr (XCDR (value))))
3452 Lisp_Object base = XCAR (value);
3453 Lisp_Object modifier = XCAR (XCDR (value));
3457 base = make_char (XINT (base));
3458 Fsetcar (value, base);
3460 if (INTP (modifier))
3462 modifier = make_char (XINT (modifier));
3463 Fsetcar (XCDR (value), modifier);
3468 = Fchar_feature (base, Qcomposition, Qnil,
3470 Lisp_Object ret = Fassq (modifier, alist);
3473 Fput_char_attribute (base, Qcomposition,
3474 Fcons (Fcons (modifier, character),
3477 Fsetcdr (ret, character);
3479 else if (EQ (base, Qnarrow))
3480 return Q_halfwidth_of;
3481 else if (EQ (base, Qsuper))
3482 return Q_superscript_of;
3483 else if (EQ (base, Qsub))
3484 return Q_subscript_of;
3485 else if (EQ (base, Qcircle))
3486 return Q_circled_of;
3487 else if ( EQ (base, Qisolated)||
3488 EQ (base, Qinitial) ||
3489 EQ (base, Qmedial) ||
3492 Fintern (concat2 (build_string ("<-formed@"),
3493 Fsymbol_name (base)),
3495 else if (SYMBOLP (base))
3497 Fintern (concat2 (build_string ("<-"),
3498 Fsymbol_name (base)),
3501 else if (EQ (XCAR (value), Qsuper))
3502 return Qto_decomposition_at_superscript;
3503 else if (EQ (XCAR (value), Qcircle))
3504 return Qto_decomposition_at_circled;
3507 Fintern (concat2 (build_string ("=>decomposition@"),
3508 Fsymbol_name (XCAR (value))),
3515 Lisp_Object v = Fcar (value);
3519 Emchar c = DECODE_CHAR (Vcharset_ucs, XINT (v), 0);
3521 = Fchar_feature (make_char (c), Q_ucs_unified, Qnil,
3526 Fput_char_attribute (make_char (c), Q_ucs_unified,
3527 Fcons (character, Qnil));
3529 else if (NILP (Fmemq (character, ret)))
3531 Fput_char_attribute (make_char (c), Q_ucs_unified,
3532 Fcons (character, ret));
3537 return Qrep_decomposition;
3541 put_char_attribute (Lisp_Object character, Lisp_Object attribute,
3544 Lisp_Object table = Fgethash (attribute,
3545 Vchar_attribute_hash_table,
3550 table = make_char_id_table (Qunbound);
3551 Fputhash (attribute, table, Vchar_attribute_hash_table);
3553 XCHAR_TABLE_NAME (table) = attribute;
3556 put_char_id_table (XCHAR_TABLE(table), character, value);
3560 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3561 Store CHARACTER's ATTRIBUTE with VALUE.
3563 (character, attribute, value))
3565 Lisp_Object ccs = Ffind_charset (attribute);
3567 CHECK_CHAR (character);
3571 if ( !NILP (value) )
3572 value = put_char_ccs_code_point (character, ccs, value);
3573 attribute = XCHARSET_NAME (ccs);
3577 EQ (attribute, Qrep_decomposition) ||
3579 !NILP (Fchar_feature_base_name_eq (Qrep_decomposition,
3582 EQ (attribute, Q_decomposition) /* || */
3584 !NILP (Fstring_match (build_string ("^=decomposition@[^*]+$"),
3585 Fsymbol_name (attribute),
3592 value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value));
3593 ret = put_char_composition (character, value);
3594 if ( !EQ (ret, Qrep_decomposition) &&
3595 SYMBOLP (XCAR (value)) )
3598 value = XCDR (value);
3601 else if (EQ (attribute, Qto_ucs))
3607 signal_simple_error ("Invalid value for =>ucs", value);
3609 c = DECODE_CHAR (Vcharset_ucs, XINT (value), 0);
3611 ret = Fchar_feature (make_char (c), Q_ucs_unified, Qnil,
3614 put_char_attribute (make_char (c), Q_ucs_unified,
3616 else if (NILP (Fmemq (character, ret)))
3617 Fput_char_attribute (make_char (c), Q_ucs_unified,
3618 Fcons (character, ret));
3620 if ( EQ (attribute, Q_subsumptive) ||
3621 EQ (attribute, Q_subsumptive_from) ||
3622 EQ (attribute, Q_denotational) ||
3623 EQ (attribute, Q_denotational_from) ||
3624 EQ (attribute, Q_identical) ||
3625 EQ (attribute, Q_identical_from) ||
3626 EQ (attribute, Q_canonical) ||
3627 EQ (attribute, Q_halfwidth_of) ||
3628 EQ (attribute, Q_superscript_of) ||
3629 EQ (attribute, Q_subscript_of) ||
3630 EQ (attribute, Q_circled_of) ||
3631 EQ (attribute, Q_component) ||
3632 EQ (attribute, Q_component_of) ||
3633 ( !EQ (attribute, Q_ucs_unified)
3634 && !NILP (Fstring_match
3635 (build_string ("^\\(<-\\|->\\)[^*]*$"),
3636 Fsymbol_name (attribute),
3641 Lisp_Object rest = value;
3643 Lisp_Object rev_feature = Qnil;
3644 struct gcpro gcpro1;
3645 GCPRO1 (rev_feature);
3647 if (EQ (attribute, Q_identical))
3648 rev_feature = Q_identical_from;
3649 else if (EQ (attribute, Q_identical_from))
3650 rev_feature = Q_identical;
3651 else if (EQ (attribute, Q_subsumptive))
3652 rev_feature = Q_subsumptive_from;
3653 else if (EQ (attribute, Q_subsumptive_from))
3654 rev_feature = Q_subsumptive;
3655 else if (EQ (attribute, Q_denotational))
3656 rev_feature = Q_denotational_from;
3657 else if (EQ (attribute, Q_denotational_from))
3658 rev_feature = Q_denotational;
3659 else if (EQ (attribute, Q_component))
3660 rev_feature = Q_component_of;
3661 else if (EQ (attribute, Q_component_of))
3662 rev_feature = Q_component;
3665 Lisp_String* name = symbol_name (XSYMBOL (attribute));
3666 Bufbyte *name_str = string_data (name);
3668 if ( (name_str[0] == '<' && name_str[1] == '-') ||
3669 (name_str[0] == '-' && name_str[1] == '>') )
3671 Bytecount length = string_length (name);
3672 Bufbyte *rev_name_str = alloca (length + 1);
3674 memcpy (rev_name_str + 2, name_str + 2, length - 2);
3675 if (name_str[0] == '<')
3677 rev_name_str[0] = '-';
3678 rev_name_str[1] = '>';
3682 rev_name_str[0] = '<';
3683 rev_name_str[1] = '-';
3685 rev_name_str[length] = 0;
3686 rev_feature = intern (rev_name_str);
3690 while (CONSP (rest))
3695 ret = Fdefine_char (ret);
3696 else if (INTP (ret))
3698 int code_point = XINT (ret);
3699 Emchar cid = DECODE_CHAR (Vcharset_ucs, code_point, 0);
3702 ret = make_char (cid);
3704 ret = make_char (code_point);
3707 if ( !NILP (ret) && !EQ (ret, character) )
3711 ffv = Fget_char_attribute (ret, rev_feature, Qnil);
3713 put_char_attribute (ret, rev_feature, list1 (character));
3714 else if (NILP (Fmemq (character, ffv)))
3717 nconc2 (Fcopy_sequence (ffv), list1 (character)));
3718 Fsetcar (rest, ret);
3725 else if ( EQ (attribute, Qideographic_structure) ||
3726 !NILP (Fstring_match
3727 (build_string ("^=>decomposition\\(\\|@[^*]+\\)$"),
3728 Fsymbol_name (attribute),
3730 value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value));
3732 return put_char_attribute (character, attribute, value);
3735 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3736 Remove CHARACTER's ATTRIBUTE.
3738 (character, attribute))
3742 CHECK_CHAR (character);
3743 ccs = Ffind_charset (attribute);
3746 return remove_char_ccs (character, ccs);
3750 Lisp_Object table = Fgethash (attribute,
3751 Vchar_attribute_hash_table,
3753 if (!UNBOUNDP (table))
3755 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3764 int char_table_open_db_maybe (Lisp_Char_Table* cit);
3765 void char_table_close_db_maybe (Lisp_Char_Table* cit);
3766 Lisp_Object char_table_get_db (Lisp_Char_Table* cit, Emchar ch);
3768 #ifdef HAVE_LIBCHISE
3770 open_chise_data_source_maybe ()
3772 if (default_chise_data_source == NULL)
3774 Lisp_Object db_dir = Vdata_directory;
3775 int modemask = 0755; /* rwxr-xr-x */
3778 db_dir = build_string ("../etc");
3779 db_dir = Fexpand_file_name (build_string ("chise-db"), db_dir);
3781 default_chise_data_source
3782 = CHISE_DS_open (CHISE_DS_Berkeley_DB, XSTRING_DATA (db_dir),
3783 0 /* DB_HASH */, modemask);
3784 if (default_chise_data_source == NULL)
3787 chise_ds_set_make_string_function (default_chise_data_source,
3793 #endif /* HAVE_LIBCHISE */
3795 DEFUN ("close-char-data-source", Fclose_char_data_source, 0, 0, 0, /*
3796 Close data-source of CHISE.
3800 #ifdef HAVE_LIBCHISE
3801 int status = CHISE_DS_close (default_chise_data_source);
3803 default_chise_data_source = NULL;
3806 #endif /* HAVE_LIBCHISE */
3811 char_table_open_db_maybe (Lisp_Char_Table* cit)
3813 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3815 if (!NILP (attribute))
3817 #ifdef HAVE_LIBCHISE
3818 if ( open_chise_data_source_maybe () )
3820 #else /* HAVE_LIBCHISE */
3821 if (NILP (Fdatabase_live_p (cit->db)))
3824 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3826 cit->db = Fopen_database (db_file, Qnil, Qnil,
3827 build_string ("r"), Qnil);
3831 #endif /* not HAVE_LIBCHISE */
3839 char_table_close_db_maybe (Lisp_Char_Table* cit)
3841 #ifndef HAVE_LIBCHISE
3842 if (!NILP (cit->db))
3844 if (!NILP (Fdatabase_live_p (cit->db)))
3845 Fclose_database (cit->db);
3848 #endif /* not HAVE_LIBCHISE */
3852 char_table_get_db (Lisp_Char_Table* cit, Emchar ch)
3855 #ifdef HAVE_LIBCHISE
3858 = chise_ds_load_char_feature_value (default_chise_data_source, ch,
3859 XSTRING_DATA(Fsymbol_name
3866 val = Fread (make_string (chise_value_data (&value),
3867 chise_value_size (&value) ));
3869 val = read_from_c_string (chise_value_data (&value),
3870 chise_value_size (&value) );
3875 #else /* HAVE_LIBCHISE */
3876 val = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3878 if (!UNBOUNDP (val))
3882 #endif /* not HAVE_LIBCHISE */
3886 #ifndef HAVE_LIBCHISE
3888 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3891 Lisp_Object db_dir = Vdata_directory;
3894 db_dir = build_string ("../etc");
3896 db_dir = Fexpand_file_name (build_string ("chise-db"), db_dir);
3897 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3898 Fmake_directory_internal (db_dir);
3900 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3901 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3902 Fmake_directory_internal (db_dir);
3905 Lisp_Object attribute_name = Fsymbol_name (attribute);
3906 Lisp_Object dest = Qnil, ret;
3908 struct gcpro gcpro1, gcpro2;
3909 int len = XSTRING_CHAR_LENGTH (attribute_name);
3913 for (i = 0; i < len; i++)
3915 Emchar c = string_char (XSTRING (attribute_name), i);
3917 if ( (c == '/') || (c == '%') )
3921 sprintf (str, "%%%02X", c);
3922 dest = concat3 (dest,
3923 Fsubstring (attribute_name,
3924 make_int (base), make_int (i)),
3925 build_string (str));
3929 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3930 dest = concat2 (dest, ret);
3932 return Fexpand_file_name (dest, db_dir);
3935 #endif /* not HAVE_LIBCHISE */
3937 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3938 Save values of ATTRIBUTE into database file.
3942 Lisp_Object table = Fgethash (attribute,
3943 Vchar_attribute_hash_table, Qunbound);
3944 Lisp_Char_Table *ct;
3945 #ifdef HAVE_LIBCHISE
3946 CHISE_Feature feature;
3947 #else /* HAVE_LIBCHISE */
3948 Lisp_Object db_file;
3950 #endif /* not HAVE_LIBCHISE */
3952 if (CHAR_TABLEP (table))
3953 ct = XCHAR_TABLE (table);
3957 #ifdef HAVE_LIBCHISE
3958 if ( open_chise_data_source_maybe () )
3961 = chise_ds_get_feature (default_chise_data_source,
3962 XSTRING_DATA (Fsymbol_name (attribute)));
3963 #else /* HAVE_LIBCHISE */
3964 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3965 db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil);
3966 #endif /* not HAVE_LIBCHISE */
3968 #ifdef HAVE_LIBCHISE
3970 #else /* HAVE_LIBCHISE */
3972 #endif /* not HAVE_LIBCHISE */
3975 Lisp_Object (*filter)(Lisp_Object value);
3977 if ( !NILP (Ffind_charset (attribute)) )
3979 else if ( EQ (attribute, Qideographic_structure) ||
3980 EQ (attribute, Q_identical) ||
3981 EQ (attribute, Q_identical_from) ||
3982 EQ (attribute, Q_canonical) ||
3983 EQ (attribute, Q_halfwidth_of) ||
3984 EQ (attribute, Q_superscript_of) ||
3985 EQ (attribute, Q_subscript_of) ||
3986 EQ (attribute, Q_circled_of) ||
3987 !NILP (Fstring_match
3988 (build_string ("^\\(<-\\|->\\)\\(simplified"
3989 "\\|same\\|vulgar\\|wrong"
3990 "\\|original\\|ancient"
3991 "\\|Oracle-Bones\\)[^*]*$"),
3992 Fsymbol_name (attribute),
3994 filter = &Fchar_refs_simplify_char_specs;
3998 if (UINT8_BYTE_TABLE_P (ct->table))
3999 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
4000 #ifdef HAVE_LIBCHISE
4002 #else /* HAVE_LIBCHISE */
4004 #endif /* not HAVE_LIBCHISE */
4006 else if (UINT16_BYTE_TABLE_P (ct->table))
4007 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
4008 #ifdef HAVE_LIBCHISE
4010 #else /* HAVE_LIBCHISE */
4012 #endif /* not HAVE_LIBCHISE */
4014 else if (BYTE_TABLE_P (ct->table))
4015 save_byte_table (XBYTE_TABLE(ct->table), ct,
4016 #ifdef HAVE_LIBCHISE
4018 #else /* HAVE_LIBCHISE */
4020 #endif /* not HAVE_LIBCHISE */
4022 #ifdef HAVE_LIBCHISE
4023 chise_feature_sync (feature);
4024 #else /* HAVE_LIBCHISE */
4025 Fclose_database (db);
4026 #endif /* not HAVE_LIBCHISE */
4033 DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /*
4034 Mount database file on char-attribute-table ATTRIBUTE.
4038 Lisp_Object table = Fgethash (attribute,
4039 Vchar_attribute_hash_table, Qunbound);
4041 if (UNBOUNDP (table))
4043 Lisp_Char_Table *ct;
4045 table = make_char_id_table (Qunbound);
4046 Fputhash (attribute, table, Vchar_attribute_hash_table);
4047 XCHAR_TABLE_NAME(table) = attribute;
4048 ct = XCHAR_TABLE (table);
4049 ct->table = Qunloaded;
4050 XCHAR_TABLE_UNLOADED(table) = 1;
4051 #ifndef HAVE_LIBCHISE
4053 #endif /* not HAVE_LIBCHISE */
4059 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
4060 Close database of ATTRIBUTE.
4064 Lisp_Object table = Fgethash (attribute,
4065 Vchar_attribute_hash_table, Qunbound);
4066 Lisp_Char_Table *ct;
4068 if (CHAR_TABLEP (table))
4069 ct = XCHAR_TABLE (table);
4072 char_table_close_db_maybe (ct);
4076 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
4077 Reset values of ATTRIBUTE with database file.
4081 #ifdef HAVE_LIBCHISE
4082 CHISE_Feature feature
4083 = chise_ds_get_feature (default_chise_data_source,
4084 XSTRING_DATA (Fsymbol_name
4087 if (feature == NULL)
4090 if (chise_feature_setup_db (feature, 0) == 0)
4092 Lisp_Object table = Fgethash (attribute,
4093 Vchar_attribute_hash_table, Qunbound);
4094 Lisp_Char_Table *ct;
4096 chise_feature_sync (feature);
4097 if (UNBOUNDP (table))
4099 table = make_char_id_table (Qunbound);
4100 Fputhash (attribute, table, Vchar_attribute_hash_table);
4101 XCHAR_TABLE_NAME(table) = attribute;
4103 ct = XCHAR_TABLE (table);
4104 ct->table = Qunloaded;
4105 char_table_close_db_maybe (ct);
4106 XCHAR_TABLE_UNLOADED(table) = 1;
4110 Lisp_Object table = Fgethash (attribute,
4111 Vchar_attribute_hash_table, Qunbound);
4112 Lisp_Char_Table *ct;
4114 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
4116 if (!NILP (Ffile_exists_p (db_file)))
4118 if (UNBOUNDP (table))
4120 table = make_char_id_table (Qunbound);
4121 Fputhash (attribute, table, Vchar_attribute_hash_table);
4122 XCHAR_TABLE_NAME(table) = attribute;
4124 ct = XCHAR_TABLE (table);
4125 ct->table = Qunloaded;
4126 char_table_close_db_maybe (ct);
4127 XCHAR_TABLE_UNLOADED(table) = 1;
4135 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
4137 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
4139 if (!NILP (attribute))
4143 if (char_table_open_db_maybe (cit))
4146 val = char_table_get_db (cit, ch);
4148 if (!NILP (Vchar_db_stingy_mode))
4149 char_table_close_db_maybe (cit);
4156 Lisp_Char_Table* char_attribute_table_to_load;
4158 #ifdef HAVE_LIBCHISE
4160 load_char_attribute_table_map_func (CHISE_Char_ID cid,
4161 CHISE_Feature feature,
4162 CHISE_Value *value);
4164 load_char_attribute_table_map_func (CHISE_Char_ID cid,
4165 CHISE_Feature feature,
4169 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
4171 if (EQ (ret, Qunloaded))
4172 put_char_id_table_0 (char_attribute_table_to_load, code,
4173 Fread (make_string ((Bufbyte *) value->data,
4177 #else /* HAVE_LIBCHISE */
4178 Lisp_Object Qload_char_attribute_table_map_function;
4180 DEFUN ("load-char-attribute-table-map-function",
4181 Fload_char_attribute_table_map_function, 2, 2, 0, /*
4182 For internal use. Don't use it.
4186 Lisp_Object c = Fread (key);
4187 Emchar code = XCHAR (c);
4188 Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code);
4190 if (EQ (ret, Qunloaded))
4191 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
4194 #endif /* not HAVE_LIBCHISE */
4196 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
4197 Load values of ATTRIBUTE into database file.
4201 Lisp_Object table = Fgethash (attribute,
4202 Vchar_attribute_hash_table,
4204 if (CHAR_TABLEP (table))
4206 Lisp_Char_Table *cit = XCHAR_TABLE (table);
4208 if (char_table_open_db_maybe (cit))
4211 char_attribute_table_to_load = XCHAR_TABLE (table);
4213 struct gcpro gcpro1;
4216 #ifdef HAVE_LIBCHISE
4217 chise_feature_foreach_char_with_value
4218 (chise_ds_get_feature (default_chise_data_source,
4219 XSTRING_DATA (Fsymbol_name (cit->name))),
4220 &load_char_attribute_table_map_func);
4221 #else /* HAVE_LIBCHISE */
4222 Fmap_database (Qload_char_attribute_table_map_function, cit->db);
4223 #endif /* not HAVE_LIBCHISE */
4226 char_table_close_db_maybe (cit);
4227 XCHAR_TABLE_UNLOADED(table) = 0;
4232 #endif /* HAVE_CHISE */
4234 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
4235 Map FUNCTION over ATTRIBUTE until it returns non-nil; return that value.
4236 FUNCTION is called with two arguments, each key and entry in the table.
4238 RANGE specifies a subrange to map over. If omitted or t, it defaults to
4241 Both RANGE and the keys passed to FUNCTION are in the same format as the
4242 RANGE argument to `put-char-table'. N.B. This function does NOT map over
4243 all characters in RANGE, but over the subranges that have been assigned to.
4244 Thus this function is most suitable for searching a char-table, or for
4245 populating one char-table based on the contents of another. The current
4246 implementation does not coalesce ranges all of whose values are the same.
4248 (function, attribute, range))
4251 Lisp_Char_Table *ct;
4252 struct slow_map_char_table_arg slarg;
4253 struct gcpro gcpro1, gcpro2;
4254 struct chartab_range rainj;
4256 if (!NILP (ccs = Ffind_charset (attribute)))
4258 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
4260 if (CHAR_TABLEP (encoding_table))
4261 ct = XCHAR_TABLE (encoding_table);
4267 Lisp_Object table = Fgethash (attribute,
4268 Vchar_attribute_hash_table,
4270 if (CHAR_TABLEP (table))
4271 ct = XCHAR_TABLE (table);
4277 decode_char_table_range (range, &rainj);
4279 if (CHAR_TABLE_UNLOADED(ct))
4280 Fload_char_attribute_table (attribute);
4282 slarg.function = function;
4283 slarg.retval = Qnil;
4284 GCPRO2 (slarg.function, slarg.retval);
4285 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
4288 return slarg.retval;
4292 allocate_character ()
4294 int cid = XINT (Vnext_defined_char_id);
4296 if (cid <= 0xE00000)
4298 Vnext_defined_char_id = make_int (cid + 1);
4299 return make_char (cid);
4305 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
4306 Store character's ATTRIBUTES.
4311 Lisp_Object code = Fcdr (Fassq (Qrep_ucs, attributes));
4312 Lisp_Object character;
4315 code = Fcdr (Fassq (Qucs, attributes));
4320 while (CONSP (rest))
4322 Lisp_Object cell = Fcar (rest);
4325 if ( !LISTP (cell) )
4326 signal_simple_error ("Invalid argument", attributes);
4328 ccs = Ffind_charset (Fcar (cell));
4334 character = Fdecode_char (ccs, cell, Qt, Qt);
4335 if (!NILP (character))
4336 goto setup_attributes;
4338 if ( (XCHARSET_FINAL (ccs) != 0) ||
4339 (XCHARSET_MAX_CODE (ccs) > 0) ||
4340 (EQ (ccs, Vcharset_chinese_big5)) )
4344 = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
4346 character = Fdecode_char (ccs, cell, Qnil, Qt);
4347 if (!NILP (character))
4348 goto setup_attributes;
4355 int cid = XINT (Vnext_defined_char_id);
4357 if (cid <= 0xE00000)
4359 character = make_char (cid);
4360 Vnext_defined_char_id = make_int (cid + 1);
4361 goto setup_attributes;
4365 if ( NILP (character = allocate_character ()) )
4369 else if (!INTP (code))
4370 signal_simple_error ("Invalid argument", attributes);
4372 character = make_char (XINT (code));
4376 while (CONSP (rest))
4378 Lisp_Object cell = Fcar (rest);
4381 signal_simple_error ("Invalid argument", attributes);
4383 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
4389 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
4390 Retrieve the character of the given ATTRIBUTES.
4394 Lisp_Object rest = attributes;
4397 while (CONSP (rest))
4399 Lisp_Object cell = Fcar (rest);
4403 signal_simple_error ("Invalid argument", attributes);
4404 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
4408 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
4410 return Fdecode_char (ccs, cell, Qnil, Qnil);
4414 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) )
4417 signal_simple_error ("Invalid argument", attributes);
4419 return make_char (XINT (code) + 0x100000);
4427 /************************************************************************/
4428 /* Character Feature Property */
4429 /************************************************************************/
4431 #ifdef HAVE_LIBCHISE
4432 DEFUN ("char-feature-property", Fchar_feature_property, 2, 3, 0, /*
4433 Return the value of FEATURE's PROPERTY.
4434 Return DEFAULT-VALUE if the value is not exist.
4436 (feature, property, default_value))
4438 unsigned char* feature_name;
4439 unsigned char* property_name;
4443 feature_name = XSTRING_DATA (Fsymbol_name (feature));
4444 property_name = XSTRING_DATA (Fsymbol_name (property));
4446 = chise_feature_load_property_value (chise_ds_get_feature
4447 (default_chise_data_source,
4449 chise_ds_get_property
4450 (default_chise_data_source,
4454 return read_from_c_string (chise_value_data (&value),
4455 chise_value_size (&value) );
4457 return default_value;
4460 DEFUN ("put-char-feature-property", Fput_char_feature_property, 3, 3, 0, /*
4461 Store FEATURE's PROPERTY with VALUE.
4463 (feature, property, value))
4465 unsigned char* feature_name;
4466 unsigned char* property_name;
4467 CHISE_Property prop;
4469 feature_name = XSTRING_DATA (Fsymbol_name (feature));
4470 property_name = XSTRING_DATA (Fsymbol_name (property));
4471 prop = chise_ds_get_property (default_chise_data_source,
4473 chise_feature_set_property_value
4474 (chise_ds_get_feature (default_chise_data_source, feature_name),
4475 prop, XSTRING_DATA (Fprin1_to_string
4477 chise_property_sync (prop);
4483 /************************************************************************/
4484 /* Char table read syntax */
4485 /************************************************************************/
4488 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
4489 Error_behavior errb)
4491 /* #### should deal with ERRB */
4492 symbol_to_char_table_type (value);
4497 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
4498 Error_behavior errb)
4502 /* #### should deal with ERRB */
4503 EXTERNAL_LIST_LOOP (rest, value)
4505 Lisp_Object range = XCAR (rest);
4506 struct chartab_range dummy;
4510 signal_simple_error ("Invalid list format", value);
4513 if (!CONSP (XCDR (range))
4514 || !NILP (XCDR (XCDR (range))))
4515 signal_simple_error ("Invalid range format", range);
4516 decode_char_table_range (XCAR (range), &dummy);
4517 decode_char_table_range (XCAR (XCDR (range)), &dummy);
4520 decode_char_table_range (range, &dummy);
4527 chartab_instantiate (Lisp_Object data)
4529 Lisp_Object chartab;
4530 Lisp_Object type = Qgeneric;
4531 Lisp_Object dataval = Qnil;
4533 while (!NILP (data))
4535 Lisp_Object keyw = Fcar (data);
4541 if (EQ (keyw, Qtype))
4543 else if (EQ (keyw, Qdata))
4547 chartab = Fmake_char_table (type);
4550 while (!NILP (data))
4552 Lisp_Object range = Fcar (data);
4553 Lisp_Object val = Fcar (Fcdr (data));
4555 data = Fcdr (Fcdr (data));
4558 if (CHAR_OR_CHAR_INTP (XCAR (range)))
4560 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
4561 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
4564 for (i = first; i <= last; i++)
4565 Fput_char_table (make_char (i), val, chartab);
4571 Fput_char_table (range, val, chartab);
4580 /************************************************************************/
4581 /* Category Tables, specifically */
4582 /************************************************************************/
4584 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
4585 Return t if OBJECT is a category table.
4586 A category table is a type of char table used for keeping track of
4587 categories. Categories are used for classifying characters for use
4588 in regexps -- you can refer to a category rather than having to use
4589 a complicated [] expression (and category lookups are significantly
4592 There are 95 different categories available, one for each printable
4593 character (including space) in the ASCII charset. Each category
4594 is designated by one such character, called a "category designator".
4595 They are specified in a regexp using the syntax "\\cX", where X is
4596 a category designator.
4598 A category table specifies, for each character, the categories that
4599 the character is in. Note that a character can be in more than one
4600 category. More specifically, a category table maps from a character
4601 to either the value nil (meaning the character is in no categories)
4602 or a 95-element bit vector, specifying for each of the 95 categories
4603 whether the character is in that category.
4605 Special Lisp functions are provided that abstract this, so you do not
4606 have to directly manipulate bit vectors.
4610 return (CHAR_TABLEP (object) &&
4611 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
4616 check_category_table (Lisp_Object object, Lisp_Object default_)
4620 while (NILP (Fcategory_table_p (object)))
4621 object = wrong_type_argument (Qcategory_table_p, object);
4626 check_category_char (Emchar ch, Lisp_Object table,
4627 unsigned int designator, unsigned int not_p)
4629 REGISTER Lisp_Object temp;
4630 Lisp_Char_Table *ctbl;
4631 #ifdef ERROR_CHECK_TYPECHECK
4632 if (NILP (Fcategory_table_p (table)))
4633 signal_simple_error ("Expected category table", table);
4635 ctbl = XCHAR_TABLE (table);
4636 temp = get_char_table (ch, ctbl);
4641 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
4644 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
4645 Return t if category of the character at POSITION includes DESIGNATOR.
4646 Optional third arg BUFFER specifies which buffer to use, and defaults
4647 to the current buffer.
4648 Optional fourth arg CATEGORY-TABLE specifies the category table to
4649 use, and defaults to BUFFER's category table.
4651 (position, designator, buffer, category_table))
4656 struct buffer *buf = decode_buffer (buffer, 0);
4658 CHECK_INT (position);
4659 CHECK_CATEGORY_DESIGNATOR (designator);
4660 des = XCHAR (designator);
4661 ctbl = check_category_table (category_table, Vstandard_category_table);
4662 ch = BUF_FETCH_CHAR (buf, XINT (position));
4663 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
4666 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
4667 Return t if category of CHARACTER includes DESIGNATOR, else nil.
4668 Optional third arg CATEGORY-TABLE specifies the category table to use,
4669 and defaults to the standard category table.
4671 (character, designator, category_table))
4677 CHECK_CATEGORY_DESIGNATOR (designator);
4678 des = XCHAR (designator);
4679 CHECK_CHAR (character);
4680 ch = XCHAR (character);
4681 ctbl = check_category_table (category_table, Vstandard_category_table);
4682 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
4685 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
4686 Return BUFFER's current category table.
4687 BUFFER defaults to the current buffer.
4691 return decode_buffer (buffer, 0)->category_table;
4694 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
4695 Return the standard category table.
4696 This is the one used for new buffers.
4700 return Vstandard_category_table;
4703 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
4704 Return a new category table which is a copy of CATEGORY-TABLE.
4705 CATEGORY-TABLE defaults to the standard category table.
4709 if (NILP (Vstandard_category_table))
4710 return Fmake_char_table (Qcategory);
4713 check_category_table (category_table, Vstandard_category_table);
4714 return Fcopy_char_table (category_table);
4717 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
4718 Select CATEGORY-TABLE as the new category table for BUFFER.
4719 BUFFER defaults to the current buffer if omitted.
4721 (category_table, buffer))
4723 struct buffer *buf = decode_buffer (buffer, 0);
4724 category_table = check_category_table (category_table, Qnil);
4725 buf->category_table = category_table;
4726 /* Indicate that this buffer now has a specified category table. */
4727 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
4728 return category_table;
4731 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
4732 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
4736 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
4739 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
4740 Return t if OBJECT is a category table value.
4741 Valid values are nil or a bit vector of size 95.
4745 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
4749 #define CATEGORYP(x) \
4750 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
4752 #define CATEGORY_SET(c) \
4753 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
4755 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
4756 The faster version of `!NILP (Faref (category_set, category))'. */
4757 #define CATEGORY_MEMBER(category, category_set) \
4758 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
4760 /* Return 1 if there is a word boundary between two word-constituent
4761 characters C1 and C2 if they appear in this order, else return 0.
4762 Use the macro WORD_BOUNDARY_P instead of calling this function
4765 int word_boundary_p (Emchar c1, Emchar c2);
4767 word_boundary_p (Emchar c1, Emchar c2)
4769 Lisp_Object category_set1, category_set2;
4774 if (COMPOSITE_CHAR_P (c1))
4775 c1 = cmpchar_component (c1, 0, 1);
4776 if (COMPOSITE_CHAR_P (c2))
4777 c2 = cmpchar_component (c2, 0, 1);
4781 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4784 tail = Vword_separating_categories;
4790 tail = Vword_combining_categories;
4795 category_set1 = CATEGORY_SET (c1);
4796 if (NILP (category_set1))
4797 return default_result;
4798 category_set2 = CATEGORY_SET (c2);
4799 if (NILP (category_set2))
4800 return default_result;
4802 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4804 Lisp_Object elt = XCONS(tail)->car;
4807 && CATEGORYP (XCONS (elt)->car)
4808 && CATEGORYP (XCONS (elt)->cdr)
4809 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4810 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4811 return !default_result;
4813 return default_result;
4819 syms_of_chartab (void)
4821 #if defined(UTF2000) || defined(HAVE_CONCORD)
4822 defsymbol (&Q_subsumptive, "->subsumptive");
4823 defsymbol (&Q_subsumptive_from, "<-subsumptive");
4824 defsymbol (&Q_denotational, "->denotational");
4825 defsymbol (&Q_denotational_from, "<-denotational");
4828 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4829 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4830 INIT_LRECORD_IMPLEMENTATION (byte_table);
4832 defsymbol (&Qto_ucs, "=>ucs");
4833 defsymbol (&Q_ucs_unified, "->ucs-unified");
4834 defsymbol (&Q_identical, "->identical");
4835 defsymbol (&Q_identical_from, "<-identical");
4836 defsymbol (&Q_component, "->ideographic-component-forms");
4837 defsymbol (&Q_component_of, "<-ideographic-component-forms");
4838 defsymbol (&Qcomposition, "composition");
4839 defsymbol (&Qrep_decomposition, "=decomposition");
4840 defsymbol (&Qto_decomposition_at_superscript,
4841 "=>decomposition@superscript");
4842 defsymbol (&Qto_decomposition_at_circled, "=>decomposition@circled");
4843 defsymbol (&Q_canonical, "->canonical");
4844 defsymbol (&Q_halfwidth_of, "<-halfwidth");
4845 defsymbol (&Q_superscript_of, "<-superscript");
4846 defsymbol (&Q_subscript_of, "<-subscript");
4847 defsymbol (&Q_circled_of, "<-circled");
4848 defsymbol (&Q_decomposition, "->decomposition");
4849 defsymbol (&Qcompat, "compat");
4850 defsymbol (&Qisolated, "isolated");
4851 defsymbol (&Qinitial, "initial");
4852 defsymbol (&Qmedial, "medial");
4853 defsymbol (&Qfinal, "final");
4854 defsymbol (&Qvertical, "vertical");
4855 defsymbol (&QnoBreak, "noBreak");
4856 defsymbol (&Qfraction, "fraction");
4857 defsymbol (&Qsuper, "super");
4858 defsymbol (&Qsub, "sub");
4859 defsymbol (&Qcircle, "circle");
4860 defsymbol (&Qsquare, "square");
4861 defsymbol (&Qwide, "wide");
4862 defsymbol (&Qnarrow, "narrow");
4863 defsymbol (&Qsmall, "small");
4864 defsymbol (&Qfont, "font");
4866 DEFSUBR (Fchar_attribute_list);
4867 DEFSUBR (Ffind_char_attribute_table);
4868 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4869 DEFSUBR (Fput_char_table_map_function);
4871 DEFSUBR (Fsave_char_attribute_table);
4872 DEFSUBR (Fmount_char_attribute_table);
4873 DEFSUBR (Freset_char_attribute_table);
4874 DEFSUBR (Fclose_char_attribute_table);
4875 DEFSUBR (Fclose_char_data_source);
4876 #ifndef HAVE_LIBCHISE
4877 defsymbol (&Qload_char_attribute_table_map_function,
4878 "load-char-attribute-table-map-function");
4879 DEFSUBR (Fload_char_attribute_table_map_function);
4881 DEFSUBR (Fload_char_attribute_table);
4883 DEFSUBR (Fchar_feature_base_name_eq);
4884 DEFSUBR (Fchar_feature);
4885 DEFSUBR (Fchar_attribute_alist);
4886 DEFSUBR (Fget_char_attribute);
4887 DEFSUBR (Fput_char_attribute);
4888 DEFSUBR (Fremove_char_attribute);
4889 DEFSUBR (Fmap_char_attribute);
4890 DEFSUBR (Fdefine_char);
4891 DEFSUBR (Ffind_char);
4892 DEFSUBR (Fchar_variants);
4894 DEFSUBR (Fget_composite_char);
4895 #ifdef HAVE_LIBCHISE
4896 DEFSUBR (Fchar_feature_property);
4897 DEFSUBR (Fput_char_feature_property);
4898 #endif /* HAVE_LIBCHISE */
4901 INIT_LRECORD_IMPLEMENTATION (char_table);
4905 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4908 defsymbol (&Qcategory_table_p, "category-table-p");
4909 defsymbol (&Qcategory_designator_p, "category-designator-p");
4910 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4913 defsymbol (&Qchar_table, "char-table");
4914 defsymbol (&Qchar_tablep, "char-table-p");
4916 DEFSUBR (Fchar_table_p);
4917 DEFSUBR (Fchar_table_type_list);
4918 DEFSUBR (Fvalid_char_table_type_p);
4919 DEFSUBR (Fchar_table_type);
4920 DEFSUBR (Freset_char_table);
4921 DEFSUBR (Fmake_char_table);
4922 DEFSUBR (Fcopy_char_table);
4923 DEFSUBR (Fget_char_table);
4924 DEFSUBR (Fget_range_char_table);
4925 DEFSUBR (Fvalid_char_table_value_p);
4926 DEFSUBR (Fcheck_valid_char_table_value);
4927 DEFSUBR (Fput_char_table);
4928 DEFSUBR (Fmap_char_table);
4931 DEFSUBR (Fcategory_table_p);
4932 DEFSUBR (Fcategory_table);
4933 DEFSUBR (Fstandard_category_table);
4934 DEFSUBR (Fcopy_category_table);
4935 DEFSUBR (Fset_category_table);
4936 DEFSUBR (Fcheck_category_at);
4937 DEFSUBR (Fchar_in_category_p);
4938 DEFSUBR (Fcategory_designator_p);
4939 DEFSUBR (Fcategory_table_value_p);
4945 vars_of_chartab (void)
4948 DEFVAR_LISP ("next-defined-char-id", &Vnext_defined_char_id /*
4950 Vnext_defined_char_id = make_int (0x0F0000);
4954 DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /*
4956 Vchar_db_stingy_mode = Qt;
4958 #ifdef HAVE_LIBCHISE
4959 Vchise_db_directory = build_string(chise_db_dir);
4960 DEFVAR_LISP ("chise-db-directory", &Vchise_db_directory /*
4961 Directory of CHISE character databases.
4964 Vchise_system_db_directory = build_string(chise_system_db_dir);
4965 DEFVAR_LISP ("chise-system-db-directory", &Vchise_system_db_directory /*
4966 Directory of system character database of CHISE.
4970 #endif /* HAVE_CHISE */
4971 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4972 Vall_syntax_tables = Qnil;
4973 dump_add_weak_object_chain (&Vall_syntax_tables);
4977 structure_type_create_chartab (void)
4979 struct structure_type *st;
4981 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4983 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4984 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4988 complex_vars_of_chartab (void)
4991 staticpro (&Vchar_attribute_hash_table);
4992 Vchar_attribute_hash_table
4993 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4994 #endif /* UTF2000 */
4996 /* Set this now, so first buffer creation can refer to it. */
4997 /* Make it nil before calling copy-category-table
4998 so that copy-category-table will know not to try to copy from garbage */
4999 Vstandard_category_table = Qnil;
5000 Vstandard_category_table = Fcopy_category_table (Qnil);
5001 staticpro (&Vstandard_category_table);
5003 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
5004 List of pair (cons) of categories to determine word boundary.
5006 Emacs treats a sequence of word constituent characters as a single
5007 word (i.e. finds no word boundary between them) iff they belongs to
5008 the same charset. But, exceptions are allowed in the following cases.
5010 \(1) The case that characters are in different charsets is controlled
5011 by the variable `word-combining-categories'.
5013 Emacs finds no word boundary between characters of different charsets
5014 if they have categories matching some element of this list.
5016 More precisely, if an element of this list is a cons of category CAT1
5017 and CAT2, and a multibyte character C1 which has CAT1 is followed by
5018 C2 which has CAT2, there's no word boundary between C1 and C2.
5020 For instance, to tell that ASCII characters and Latin-1 characters can
5021 form a single word, the element `(?l . ?l)' should be in this list
5022 because both characters have the category `l' (Latin characters).
5024 \(2) The case that character are in the same charset is controlled by
5025 the variable `word-separating-categories'.
5027 Emacs find a word boundary between characters of the same charset
5028 if they have categories matching some element of this list.
5030 More precisely, if an element of this list is a cons of category CAT1
5031 and CAT2, and a multibyte character C1 which has CAT1 is followed by
5032 C2 which has CAT2, there's a word boundary between C1 and C2.
5034 For instance, to tell that there's a word boundary between Japanese
5035 Hiragana and Japanese Kanji (both are in the same charset), the
5036 element `(?H . ?C) should be in this list.
5039 Vword_combining_categories = Qnil;
5041 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
5042 List of pair (cons) of categories to determine word boundary.
5043 See the documentation of the variable `word-combining-categories'.
5046 Vword_separating_categories = Qnil;