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 MORIOKA Tomohiko
9 This file is part of XEmacs.
11 XEmacs is free software; you can redistribute it and/or modify it
12 under the terms of the GNU General Public License as published by the
13 Free Software Foundation; either version 2, or (at your option) any
16 XEmacs is distributed in the hope that it will be useful, but WITHOUT
17 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
18 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
21 You should have received a copy of the GNU General Public License
22 along with XEmacs; see the file COPYING. If not, write to
23 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 Boston, MA 02111-1307, USA. */
26 /* Synched up with: Mule 2.3. Not synched with FSF.
28 This file was written independently of the FSF implementation,
29 and is not compatible. */
33 Ben Wing: wrote, for 19.13 (Mule). Some category table stuff
34 loosely based on the original Mule.
35 Jareth Hein: fixed a couple of bugs in the implementation, and
36 added regex support for categories with check_category_at
49 Lisp_Object Qchar_tablep, Qchar_table;
51 Lisp_Object Vall_syntax_tables;
54 Lisp_Object Qcategory_table_p;
55 Lisp_Object Qcategory_designator_p;
56 Lisp_Object Qcategory_table_value_p;
58 Lisp_Object Vstandard_category_table;
60 /* Variables to determine word boundary. */
61 Lisp_Object Vword_combining_categories, Vword_separating_categories;
67 #define BT_UINT8_MIN 0
68 #define BT_UINT8_MAX (UCHAR_MAX - 4)
69 #define BT_UINT8_t (UCHAR_MAX - 3)
70 #define BT_UINT8_nil (UCHAR_MAX - 2)
71 #define BT_UINT8_unbound (UCHAR_MAX - 1)
72 #define BT_UINT8_unloaded UCHAR_MAX
74 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
75 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
76 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
77 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
78 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
81 INT_UINT8_P (Lisp_Object obj)
87 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
94 UINT8_VALUE_P (Lisp_Object obj)
96 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
97 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
100 INLINE_HEADER unsigned char
101 UINT8_ENCODE (Lisp_Object obj)
103 if (EQ (obj, Qunloaded))
104 return BT_UINT8_unloaded;
105 else if (EQ (obj, Qunbound))
106 return BT_UINT8_unbound;
107 else if (EQ (obj, Qnil))
109 else if (EQ (obj, Qt))
115 INLINE_HEADER Lisp_Object
116 UINT8_DECODE (unsigned char n)
118 if (n == BT_UINT8_unloaded)
120 else if (n == BT_UINT8_unbound)
122 else if (n == BT_UINT8_nil)
124 else if (n == BT_UINT8_t)
131 mark_uint8_byte_table (Lisp_Object obj)
137 print_uint8_byte_table (Lisp_Object obj,
138 Lisp_Object printcharfun, int escapeflag)
140 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
142 struct gcpro gcpro1, gcpro2;
143 GCPRO2 (obj, printcharfun);
145 write_c_string ("\n#<uint8-byte-table", printcharfun);
146 for (i = 0; i < 256; i++)
148 unsigned char n = bte->property[i];
150 write_c_string ("\n ", printcharfun);
151 write_c_string (" ", printcharfun);
152 if (n == BT_UINT8_unbound)
153 write_c_string ("void", printcharfun);
154 else if (n == BT_UINT8_nil)
155 write_c_string ("nil", printcharfun);
156 else if (n == BT_UINT8_t)
157 write_c_string ("t", printcharfun);
162 sprintf (buf, "%hd", n);
163 write_c_string (buf, printcharfun);
167 write_c_string (">", printcharfun);
171 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
173 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
174 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
177 for (i = 0; i < 256; i++)
178 if (te1->property[i] != te2->property[i])
184 uint8_byte_table_hash (Lisp_Object obj, int depth)
186 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
190 for (i = 0; i < 256; i++)
191 hash = HASH2 (hash, te->property[i]);
195 static const struct lrecord_description uint8_byte_table_description[] = {
199 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
200 mark_uint8_byte_table,
201 print_uint8_byte_table,
202 0, uint8_byte_table_equal,
203 uint8_byte_table_hash,
204 uint8_byte_table_description,
205 Lisp_Uint8_Byte_Table);
208 make_uint8_byte_table (unsigned char initval)
212 Lisp_Uint8_Byte_Table *cte;
214 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
215 &lrecord_uint8_byte_table);
217 for (i = 0; i < 256; i++)
218 cte->property[i] = initval;
220 XSETUINT8_BYTE_TABLE (obj, cte);
225 copy_uint8_byte_table (Lisp_Object entry)
227 Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
230 Lisp_Uint8_Byte_Table *ctenew
231 = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
232 &lrecord_uint8_byte_table);
234 for (i = 0; i < 256; i++)
236 ctenew->property[i] = cte->property[i];
239 XSETUINT8_BYTE_TABLE (obj, ctenew);
244 uint8_byte_table_same_value_p (Lisp_Object obj)
246 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
247 unsigned char v0 = bte->property[0];
250 for (i = 1; i < 256; i++)
252 if (bte->property[i] != v0)
259 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
260 Emchar ofs, int place,
261 int (*fn) (struct chartab_range *range,
262 Lisp_Object val, void *arg),
265 struct chartab_range rainj;
267 int unit = 1 << (8 * place);
271 rainj.type = CHARTAB_RANGE_CHAR;
273 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
275 if (ct->property[i] == BT_UINT8_unloaded)
279 for (; c < c1 && retval == 0; c++)
281 Lisp_Object ret = get_char_id_table (root, c);
286 retval = (fn) (&rainj, ret, arg);
290 ct->property[i] = BT_UINT8_unbound;
294 else if (ct->property[i] != BT_UINT8_unbound)
297 for (; c < c1 && retval == 0; c++)
300 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
311 save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root,
313 Emchar ofs, int place)
315 struct chartab_range rainj;
317 int unit = 1 << (8 * place);
321 rainj.type = CHARTAB_RANGE_CHAR;
323 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
325 if (ct->property[i] == BT_UINT8_unloaded)
329 else if (ct->property[i] != BT_UINT8_unbound)
332 for (; c < c1 && retval == 0; c++)
334 Fput_database (Fprin1_to_string (make_char (c), Qnil),
335 Fprin1_to_string (UINT8_DECODE (ct->property[i]),
338 put_char_id_table (root, make_char (c), Qunloaded);
347 #define BT_UINT16_MIN 0
348 #define BT_UINT16_MAX (USHRT_MAX - 4)
349 #define BT_UINT16_t (USHRT_MAX - 3)
350 #define BT_UINT16_nil (USHRT_MAX - 2)
351 #define BT_UINT16_unbound (USHRT_MAX - 1)
352 #define BT_UINT16_unloaded USHRT_MAX
354 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
355 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
356 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
357 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
360 INT_UINT16_P (Lisp_Object obj)
364 int num = XINT (obj);
366 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
373 UINT16_VALUE_P (Lisp_Object obj)
375 return EQ (obj, Qunloaded) || EQ (obj, Qunbound)
376 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
379 INLINE_HEADER unsigned short
380 UINT16_ENCODE (Lisp_Object obj)
382 if (EQ (obj, Qunloaded))
383 return BT_UINT16_unloaded;
384 else if (EQ (obj, Qunbound))
385 return BT_UINT16_unbound;
386 else if (EQ (obj, Qnil))
387 return BT_UINT16_nil;
388 else if (EQ (obj, Qt))
394 INLINE_HEADER Lisp_Object
395 UINT16_DECODE (unsigned short n)
397 if (n == BT_UINT16_unloaded)
399 else if (n == BT_UINT16_unbound)
401 else if (n == BT_UINT16_nil)
403 else if (n == BT_UINT16_t)
409 INLINE_HEADER unsigned short
410 UINT8_TO_UINT16 (unsigned char n)
412 if (n == BT_UINT8_unloaded)
413 return BT_UINT16_unloaded;
414 else if (n == BT_UINT8_unbound)
415 return BT_UINT16_unbound;
416 else if (n == BT_UINT8_nil)
417 return BT_UINT16_nil;
418 else if (n == BT_UINT8_t)
425 mark_uint16_byte_table (Lisp_Object obj)
431 print_uint16_byte_table (Lisp_Object obj,
432 Lisp_Object printcharfun, int escapeflag)
434 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
436 struct gcpro gcpro1, gcpro2;
437 GCPRO2 (obj, printcharfun);
439 write_c_string ("\n#<uint16-byte-table", printcharfun);
440 for (i = 0; i < 256; i++)
442 unsigned short n = bte->property[i];
444 write_c_string ("\n ", printcharfun);
445 write_c_string (" ", printcharfun);
446 if (n == BT_UINT16_unbound)
447 write_c_string ("void", printcharfun);
448 else if (n == BT_UINT16_nil)
449 write_c_string ("nil", printcharfun);
450 else if (n == BT_UINT16_t)
451 write_c_string ("t", printcharfun);
456 sprintf (buf, "%hd", n);
457 write_c_string (buf, printcharfun);
461 write_c_string (">", printcharfun);
465 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
467 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
468 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
471 for (i = 0; i < 256; i++)
472 if (te1->property[i] != te2->property[i])
478 uint16_byte_table_hash (Lisp_Object obj, int depth)
480 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
484 for (i = 0; i < 256; i++)
485 hash = HASH2 (hash, te->property[i]);
489 static const struct lrecord_description uint16_byte_table_description[] = {
493 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
494 mark_uint16_byte_table,
495 print_uint16_byte_table,
496 0, uint16_byte_table_equal,
497 uint16_byte_table_hash,
498 uint16_byte_table_description,
499 Lisp_Uint16_Byte_Table);
502 make_uint16_byte_table (unsigned short initval)
506 Lisp_Uint16_Byte_Table *cte;
508 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
509 &lrecord_uint16_byte_table);
511 for (i = 0; i < 256; i++)
512 cte->property[i] = initval;
514 XSETUINT16_BYTE_TABLE (obj, cte);
519 copy_uint16_byte_table (Lisp_Object entry)
521 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
524 Lisp_Uint16_Byte_Table *ctenew
525 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
526 &lrecord_uint16_byte_table);
528 for (i = 0; i < 256; i++)
530 ctenew->property[i] = cte->property[i];
533 XSETUINT16_BYTE_TABLE (obj, ctenew);
538 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
542 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
543 Lisp_Uint16_Byte_Table* cte;
545 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
546 &lrecord_uint16_byte_table);
547 for (i = 0; i < 256; i++)
549 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
551 XSETUINT16_BYTE_TABLE (obj, cte);
556 uint16_byte_table_same_value_p (Lisp_Object obj)
558 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
559 unsigned short v0 = bte->property[0];
562 for (i = 1; i < 256; i++)
564 if (bte->property[i] != v0)
571 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
572 Emchar ofs, int place,
573 int (*fn) (struct chartab_range *range,
574 Lisp_Object val, void *arg),
577 struct chartab_range rainj;
579 int unit = 1 << (8 * place);
583 rainj.type = CHARTAB_RANGE_CHAR;
585 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
587 if (ct->property[i] == BT_UINT16_unloaded)
591 for (; c < c1 && retval == 0; c++)
593 Lisp_Object ret = get_char_id_table (root, c);
598 retval = (fn) (&rainj, ret, arg);
602 ct->property[i] = BT_UINT16_unbound;
606 else if (ct->property[i] != BT_UINT16_unbound)
609 for (; c < c1 && retval == 0; c++)
612 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
623 save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root,
625 Emchar ofs, int place)
627 struct chartab_range rainj;
629 int unit = 1 << (8 * place);
633 rainj.type = CHARTAB_RANGE_CHAR;
635 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
637 if (ct->property[i] == BT_UINT16_unloaded)
641 else if (ct->property[i] != BT_UINT16_unbound)
644 for (; c < c1 && retval == 0; c++)
646 Fput_database (Fprin1_to_string (make_char (c), Qnil),
647 Fprin1_to_string (UINT16_DECODE (ct->property[i]),
650 put_char_id_table (root, make_char (c), Qunloaded);
661 mark_byte_table (Lisp_Object obj)
663 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
666 for (i = 0; i < 256; i++)
668 mark_object (cte->property[i]);
674 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
676 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
678 struct gcpro gcpro1, gcpro2;
679 GCPRO2 (obj, printcharfun);
681 write_c_string ("\n#<byte-table", printcharfun);
682 for (i = 0; i < 256; i++)
684 Lisp_Object elt = bte->property[i];
686 write_c_string ("\n ", printcharfun);
687 write_c_string (" ", printcharfun);
688 if (EQ (elt, Qunbound))
689 write_c_string ("void", printcharfun);
691 print_internal (elt, printcharfun, escapeflag);
694 write_c_string (">", printcharfun);
698 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
700 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
701 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
704 for (i = 0; i < 256; i++)
705 if (BYTE_TABLE_P (cte1->property[i]))
707 if (BYTE_TABLE_P (cte2->property[i]))
709 if (!byte_table_equal (cte1->property[i],
710 cte2->property[i], depth + 1))
717 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
723 byte_table_hash (Lisp_Object obj, int depth)
725 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
727 return internal_array_hash (cte->property, 256, depth);
730 static const struct lrecord_description byte_table_description[] = {
731 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
735 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
740 byte_table_description,
744 make_byte_table (Lisp_Object initval)
748 Lisp_Byte_Table *cte;
750 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
752 for (i = 0; i < 256; i++)
753 cte->property[i] = initval;
755 XSETBYTE_TABLE (obj, cte);
760 copy_byte_table (Lisp_Object entry)
762 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
765 Lisp_Byte_Table *ctnew
766 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
768 for (i = 0; i < 256; i++)
770 if (UINT8_BYTE_TABLE_P (cte->property[i]))
772 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
774 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
776 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
778 else if (BYTE_TABLE_P (cte->property[i]))
780 ctnew->property[i] = copy_byte_table (cte->property[i]);
783 ctnew->property[i] = cte->property[i];
786 XSETBYTE_TABLE (obj, ctnew);
791 byte_table_same_value_p (Lisp_Object obj)
793 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
794 Lisp_Object v0 = bte->property[0];
797 for (i = 1; i < 256; i++)
799 if (!internal_equal (bte->property[i], v0, 0))
806 map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
807 Emchar ofs, int place,
808 int (*fn) (struct chartab_range *range,
809 Lisp_Object val, void *arg),
814 int unit = 1 << (8 * place);
817 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
820 if (UINT8_BYTE_TABLE_P (v))
823 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root,
824 c, place - 1, fn, arg);
827 else if (UINT16_BYTE_TABLE_P (v))
830 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root,
831 c, place - 1, fn, arg);
834 else if (BYTE_TABLE_P (v))
836 retval = map_over_byte_table (XBYTE_TABLE(v), root,
837 c, place - 1, fn, arg);
840 else if (EQ (v, Qunloaded))
843 struct chartab_range rainj;
844 Emchar c1 = c + unit;
846 rainj.type = CHARTAB_RANGE_CHAR;
848 for (; c < c1 && retval == 0; c++)
850 Lisp_Object ret = get_char_id_table (root, c);
855 retval = (fn) (&rainj, ret, arg);
859 ct->property[i] = Qunbound;
863 else if (!UNBOUNDP (v))
865 struct chartab_range rainj;
866 Emchar c1 = c + unit;
868 rainj.type = CHARTAB_RANGE_CHAR;
870 for (; c < c1 && retval == 0; c++)
873 retval = (fn) (&rainj, v, arg);
884 save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root,
886 Emchar ofs, int place)
890 int unit = 1 << (8 * place);
893 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
896 if (UINT8_BYTE_TABLE_P (v))
898 save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db,
902 else if (UINT16_BYTE_TABLE_P (v))
904 save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db,
908 else if (BYTE_TABLE_P (v))
910 save_byte_table (XBYTE_TABLE(v), root, db,
914 else if (EQ (v, Qunloaded))
918 else if (!UNBOUNDP (v))
920 struct chartab_range rainj;
921 Emchar c1 = c + unit;
923 rainj.type = CHARTAB_RANGE_CHAR;
925 for (; c < c1 && retval == 0; c++)
927 Fput_database (Fprin1_to_string (make_char (c), Qnil),
928 Fprin1_to_string (v, Qnil),
930 put_char_id_table (root, make_char (c), Qunloaded);
940 get_byte_table (Lisp_Object table, unsigned char idx)
942 if (UINT8_BYTE_TABLE_P (table))
943 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
944 else if (UINT16_BYTE_TABLE_P (table))
945 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
946 else if (BYTE_TABLE_P (table))
947 return XBYTE_TABLE(table)->property[idx];
953 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
955 if (UINT8_BYTE_TABLE_P (table))
957 if (UINT8_VALUE_P (value))
959 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
960 if (!UINT8_BYTE_TABLE_P (value) &&
961 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
962 && uint8_byte_table_same_value_p (table))
967 else if (UINT16_VALUE_P (value))
969 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
971 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
976 Lisp_Object new = make_byte_table (Qnil);
979 for (i = 0; i < 256; i++)
981 XBYTE_TABLE(new)->property[i]
982 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
984 XBYTE_TABLE(new)->property[idx] = value;
988 else if (UINT16_BYTE_TABLE_P (table))
990 if (UINT16_VALUE_P (value))
992 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
993 if (!UINT8_BYTE_TABLE_P (value) &&
994 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
995 && uint16_byte_table_same_value_p (table))
1002 Lisp_Object new = make_byte_table (Qnil);
1005 for (i = 0; i < 256; i++)
1007 XBYTE_TABLE(new)->property[i]
1008 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
1010 XBYTE_TABLE(new)->property[idx] = value;
1014 else if (BYTE_TABLE_P (table))
1016 XBYTE_TABLE(table)->property[idx] = value;
1017 if (!UINT8_BYTE_TABLE_P (value) &&
1018 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
1019 && byte_table_same_value_p (table))
1024 else if (!internal_equal (table, value, 0))
1026 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
1028 table = make_uint8_byte_table (UINT8_ENCODE (table));
1029 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
1031 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
1033 table = make_uint16_byte_table (UINT16_ENCODE (table));
1034 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
1038 table = make_byte_table (table);
1039 XBYTE_TABLE(table)->property[idx] = value;
1047 make_char_id_table (Lisp_Object initval)
1050 obj = Fmake_char_table (Qgeneric);
1051 fill_char_table (XCHAR_TABLE (obj), initval);
1056 Lisp_Object Vcharacter_composition_table;
1057 Lisp_Object Vcharacter_variant_table;
1060 Lisp_Object Qsystem_char_id;
1062 Lisp_Object Q_decomposition;
1063 Lisp_Object Qto_ucs;
1065 Lisp_Object Q_ucs_variants;
1066 Lisp_Object Qcompat;
1067 Lisp_Object Qisolated;
1068 Lisp_Object Qinitial;
1069 Lisp_Object Qmedial;
1071 Lisp_Object Qvertical;
1072 Lisp_Object QnoBreak;
1073 Lisp_Object Qfraction;
1076 Lisp_Object Qcircle;
1077 Lisp_Object Qsquare;
1079 Lisp_Object Qnarrow;
1083 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1086 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1092 else if (EQ (v, Qcompat))
1094 else if (EQ (v, Qisolated))
1096 else if (EQ (v, Qinitial))
1098 else if (EQ (v, Qmedial))
1100 else if (EQ (v, Qfinal))
1102 else if (EQ (v, Qvertical))
1104 else if (EQ (v, QnoBreak))
1106 else if (EQ (v, Qfraction))
1108 else if (EQ (v, Qsuper))
1110 else if (EQ (v, Qsub))
1112 else if (EQ (v, Qcircle))
1114 else if (EQ (v, Qsquare))
1116 else if (EQ (v, Qwide))
1118 else if (EQ (v, Qnarrow))
1120 else if (EQ (v, Qsmall))
1122 else if (EQ (v, Qfont))
1125 signal_simple_error (err_msg, err_arg);
1128 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1129 Return character corresponding with list.
1133 Lisp_Object table = Vcharacter_composition_table;
1134 Lisp_Object rest = list;
1136 while (CONSP (rest))
1138 Lisp_Object v = Fcar (rest);
1140 Emchar c = to_char_id (v, "Invalid value for composition", list);
1142 ret = get_char_id_table (XCHAR_TABLE(table), c);
1147 if (!CHAR_TABLEP (ret))
1152 else if (!CONSP (rest))
1154 else if (CHAR_TABLEP (ret))
1157 signal_simple_error ("Invalid table is found with", list);
1159 signal_simple_error ("Invalid value for composition", list);
1162 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1163 Return variants of CHARACTER.
1169 CHECK_CHAR (character);
1170 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
1173 return Fcopy_list (ret);
1181 /* A char table maps from ranges of characters to values.
1183 Implementing a general data structure that maps from arbitrary
1184 ranges of numbers to values is tricky to do efficiently. As it
1185 happens, it should suffice (and is usually more convenient, anyway)
1186 when dealing with characters to restrict the sorts of ranges that
1187 can be assigned values, as follows:
1190 2) All characters in a charset.
1191 3) All characters in a particular row of a charset, where a "row"
1192 means all characters with the same first byte.
1193 4) A particular character in a charset.
1195 We use char tables to generalize the 256-element vectors now
1196 littering the Emacs code.
1198 Possible uses (all should be converted at some point):
1204 5) keyboard-translate-table?
1207 abstract type to generalize the Emacs vectors and Mule
1208 vectors-of-vectors goo.
1211 /************************************************************************/
1212 /* Char Table object */
1213 /************************************************************************/
1215 #if defined(MULE)&&!defined(UTF2000)
1218 mark_char_table_entry (Lisp_Object obj)
1220 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1223 for (i = 0; i < 96; i++)
1225 mark_object (cte->level2[i]);
1231 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1233 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1234 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1237 for (i = 0; i < 96; i++)
1238 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1244 static unsigned long
1245 char_table_entry_hash (Lisp_Object obj, int depth)
1247 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1249 return internal_array_hash (cte->level2, 96, depth);
1252 static const struct lrecord_description char_table_entry_description[] = {
1253 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1257 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1258 mark_char_table_entry, internal_object_printer,
1259 0, char_table_entry_equal,
1260 char_table_entry_hash,
1261 char_table_entry_description,
1262 Lisp_Char_Table_Entry);
1266 mark_char_table (Lisp_Object obj)
1268 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1271 mark_object (ct->table);
1272 mark_object (ct->name);
1273 mark_object (ct->db_file);
1274 mark_object (ct->db);
1278 for (i = 0; i < NUM_ASCII_CHARS; i++)
1279 mark_object (ct->ascii[i]);
1281 for (i = 0; i < NUM_LEADING_BYTES; i++)
1282 mark_object (ct->level1[i]);
1286 return ct->default_value;
1288 return ct->mirror_table;
1292 /* WARNING: All functions of this nature need to be written extremely
1293 carefully to avoid crashes during GC. Cf. prune_specifiers()
1294 and prune_weak_hash_tables(). */
1297 prune_syntax_tables (void)
1299 Lisp_Object rest, prev = Qnil;
1301 for (rest = Vall_syntax_tables;
1303 rest = XCHAR_TABLE (rest)->next_table)
1305 if (! marked_p (rest))
1307 /* This table is garbage. Remove it from the list. */
1309 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1311 XCHAR_TABLE (prev)->next_table =
1312 XCHAR_TABLE (rest)->next_table;
1318 char_table_type_to_symbol (enum char_table_type type)
1323 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1324 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1325 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1326 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1328 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1333 static enum char_table_type
1334 symbol_to_char_table_type (Lisp_Object symbol)
1336 CHECK_SYMBOL (symbol);
1338 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1339 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1340 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1341 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1343 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1346 signal_simple_error ("Unrecognized char table type", symbol);
1347 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1351 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1352 Lisp_Object printcharfun)
1356 write_c_string (" (", printcharfun);
1357 print_internal (make_char (first), printcharfun, 0);
1358 write_c_string (" ", printcharfun);
1359 print_internal (make_char (last), printcharfun, 0);
1360 write_c_string (") ", printcharfun);
1364 write_c_string (" ", printcharfun);
1365 print_internal (make_char (first), printcharfun, 0);
1366 write_c_string (" ", printcharfun);
1368 print_internal (val, printcharfun, 1);
1371 #if defined(MULE)&&!defined(UTF2000)
1374 print_chartab_charset_row (Lisp_Object charset,
1376 Lisp_Char_Table_Entry *cte,
1377 Lisp_Object printcharfun)
1380 Lisp_Object cat = Qunbound;
1383 for (i = 32; i < 128; i++)
1385 Lisp_Object pam = cte->level2[i - 32];
1397 print_chartab_range (MAKE_CHAR (charset, first, 0),
1398 MAKE_CHAR (charset, i - 1, 0),
1401 print_chartab_range (MAKE_CHAR (charset, row, first),
1402 MAKE_CHAR (charset, row, i - 1),
1412 print_chartab_range (MAKE_CHAR (charset, first, 0),
1413 MAKE_CHAR (charset, i - 1, 0),
1416 print_chartab_range (MAKE_CHAR (charset, row, first),
1417 MAKE_CHAR (charset, row, i - 1),
1423 print_chartab_two_byte_charset (Lisp_Object charset,
1424 Lisp_Char_Table_Entry *cte,
1425 Lisp_Object printcharfun)
1429 for (i = 32; i < 128; i++)
1431 Lisp_Object jen = cte->level2[i - 32];
1433 if (!CHAR_TABLE_ENTRYP (jen))
1437 write_c_string (" [", printcharfun);
1438 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1439 sprintf (buf, " %d] ", i);
1440 write_c_string (buf, printcharfun);
1441 print_internal (jen, printcharfun, 0);
1444 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1452 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1454 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1457 struct gcpro gcpro1, gcpro2;
1458 GCPRO2 (obj, printcharfun);
1460 write_c_string ("#s(char-table ", printcharfun);
1461 write_c_string (" ", printcharfun);
1462 write_c_string (string_data
1464 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1466 write_c_string ("\n ", printcharfun);
1467 print_internal (ct->default_value, printcharfun, escapeflag);
1468 for (i = 0; i < 256; i++)
1470 Lisp_Object elt = get_byte_table (ct->table, i);
1471 if (i != 0) write_c_string ("\n ", printcharfun);
1472 if (EQ (elt, Qunbound))
1473 write_c_string ("void", printcharfun);
1475 print_internal (elt, printcharfun, escapeflag);
1478 #else /* non UTF2000 */
1481 sprintf (buf, "#s(char-table type %s data (",
1482 string_data (symbol_name (XSYMBOL
1483 (char_table_type_to_symbol (ct->type)))));
1484 write_c_string (buf, printcharfun);
1486 /* Now write out the ASCII/Control-1 stuff. */
1490 Lisp_Object val = Qunbound;
1492 for (i = 0; i < NUM_ASCII_CHARS; i++)
1501 if (!EQ (ct->ascii[i], val))
1503 print_chartab_range (first, i - 1, val, printcharfun);
1510 print_chartab_range (first, i - 1, val, printcharfun);
1517 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1520 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1521 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1523 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1524 || i == LEADING_BYTE_CONTROL_1)
1526 if (!CHAR_TABLE_ENTRYP (ann))
1528 write_c_string (" ", printcharfun);
1529 print_internal (XCHARSET_NAME (charset),
1531 write_c_string (" ", printcharfun);
1532 print_internal (ann, printcharfun, 0);
1536 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1537 if (XCHARSET_DIMENSION (charset) == 1)
1538 print_chartab_charset_row (charset, -1, cte, printcharfun);
1540 print_chartab_two_byte_charset (charset, cte, printcharfun);
1545 #endif /* non UTF2000 */
1547 write_c_string ("))", printcharfun);
1551 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1553 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1554 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1557 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1561 for (i = 0; i < 256; i++)
1563 if (!internal_equal (get_byte_table (ct1->table, i),
1564 get_byte_table (ct2->table, i), 0))
1568 for (i = 0; i < NUM_ASCII_CHARS; i++)
1569 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1573 for (i = 0; i < NUM_LEADING_BYTES; i++)
1574 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1577 #endif /* non UTF2000 */
1582 static unsigned long
1583 char_table_hash (Lisp_Object obj, int depth)
1585 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1587 return byte_table_hash (ct->table, depth + 1);
1589 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1592 hashval = HASH2 (hashval,
1593 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1599 static const struct lrecord_description char_table_description[] = {
1601 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1602 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1603 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1604 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db_file) },
1605 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) },
1607 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1609 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1613 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1615 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1619 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1620 mark_char_table, print_char_table, 0,
1621 char_table_equal, char_table_hash,
1622 char_table_description,
1625 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1626 Return non-nil if OBJECT is a char table.
1628 A char table is a table that maps characters (or ranges of characters)
1629 to values. Char tables are specialized for characters, only allowing
1630 particular sorts of ranges to be assigned values. Although this
1631 loses in generality, it makes for extremely fast (constant-time)
1632 lookups, and thus is feasible for applications that do an extremely
1633 large number of lookups (e.g. scanning a buffer for a character in
1634 a particular syntax, where a lookup in the syntax table must occur
1635 once per character).
1637 When Mule support exists, the types of ranges that can be assigned
1641 -- an entire charset
1642 -- a single row in a two-octet charset
1643 -- a single character
1645 When Mule support is not present, the types of ranges that can be
1649 -- a single character
1651 To create a char table, use `make-char-table'.
1652 To modify a char table, use `put-char-table' or `remove-char-table'.
1653 To retrieve the value for a particular character, use `get-char-table'.
1654 See also `map-char-table', `clear-char-table', `copy-char-table',
1655 `valid-char-table-type-p', `char-table-type-list',
1656 `valid-char-table-value-p', and `check-char-table-value'.
1660 return CHAR_TABLEP (object) ? Qt : Qnil;
1663 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1664 Return a list of the recognized char table types.
1665 See `valid-char-table-type-p'.
1670 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1672 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1676 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1677 Return t if TYPE if a recognized char table type.
1679 Each char table type is used for a different purpose and allows different
1680 sorts of values. The different char table types are
1683 Used for category tables, which specify the regexp categories
1684 that a character is in. The valid values are nil or a
1685 bit vector of 95 elements. Higher-level Lisp functions are
1686 provided for working with category tables. Currently categories
1687 and category tables only exist when Mule support is present.
1689 A generalized char table, for mapping from one character to
1690 another. Used for case tables, syntax matching tables,
1691 `keyboard-translate-table', etc. The valid values are characters.
1693 An even more generalized char table, for mapping from a
1694 character to anything.
1696 Used for display tables, which specify how a particular character
1697 is to appear when displayed. #### Not yet implemented.
1699 Used for syntax tables, which specify the syntax of a particular
1700 character. Higher-level Lisp functions are provided for
1701 working with syntax tables. The valid values are integers.
1706 return (EQ (type, Qchar) ||
1708 EQ (type, Qcategory) ||
1710 EQ (type, Qdisplay) ||
1711 EQ (type, Qgeneric) ||
1712 EQ (type, Qsyntax)) ? Qt : Qnil;
1715 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1716 Return the type of CHAR-TABLE.
1717 See `valid-char-table-type-p'.
1721 CHECK_CHAR_TABLE (char_table);
1722 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1726 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1729 ct->table = Qunbound;
1730 ct->default_value = value;
1735 for (i = 0; i < NUM_ASCII_CHARS; i++)
1736 ct->ascii[i] = value;
1738 for (i = 0; i < NUM_LEADING_BYTES; i++)
1739 ct->level1[i] = value;
1744 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1745 update_syntax_table (ct);
1749 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1750 Reset CHAR-TABLE to its default state.
1754 Lisp_Char_Table *ct;
1756 CHECK_CHAR_TABLE (char_table);
1757 ct = XCHAR_TABLE (char_table);
1761 case CHAR_TABLE_TYPE_CHAR:
1762 fill_char_table (ct, make_char (0));
1764 case CHAR_TABLE_TYPE_DISPLAY:
1765 case CHAR_TABLE_TYPE_GENERIC:
1767 case CHAR_TABLE_TYPE_CATEGORY:
1769 fill_char_table (ct, Qnil);
1772 case CHAR_TABLE_TYPE_SYNTAX:
1773 fill_char_table (ct, make_int (Sinherit));
1783 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1784 Return a new, empty char table of type TYPE.
1785 Currently recognized types are 'char, 'category, 'display, 'generic,
1786 and 'syntax. See `valid-char-table-type-p'.
1790 Lisp_Char_Table *ct;
1792 enum char_table_type ty = symbol_to_char_table_type (type);
1794 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1797 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1799 ct->mirror_table = Fmake_char_table (Qgeneric);
1800 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1804 ct->mirror_table = Qnil;
1810 ct->next_table = Qnil;
1811 XSETCHAR_TABLE (obj, ct);
1812 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1814 ct->next_table = Vall_syntax_tables;
1815 Vall_syntax_tables = obj;
1817 Freset_char_table (obj);
1821 #if defined(MULE)&&!defined(UTF2000)
1824 make_char_table_entry (Lisp_Object initval)
1828 Lisp_Char_Table_Entry *cte =
1829 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1831 for (i = 0; i < 96; i++)
1832 cte->level2[i] = initval;
1834 XSETCHAR_TABLE_ENTRY (obj, cte);
1839 copy_char_table_entry (Lisp_Object entry)
1841 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1844 Lisp_Char_Table_Entry *ctenew =
1845 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1847 for (i = 0; i < 96; i++)
1849 Lisp_Object new = cte->level2[i];
1850 if (CHAR_TABLE_ENTRYP (new))
1851 ctenew->level2[i] = copy_char_table_entry (new);
1853 ctenew->level2[i] = new;
1856 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1862 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1863 Return a new char table which is a copy of CHAR-TABLE.
1864 It will contain the same values for the same characters and ranges
1865 as CHAR-TABLE. The values will not themselves be copied.
1869 Lisp_Char_Table *ct, *ctnew;
1875 CHECK_CHAR_TABLE (char_table);
1876 ct = XCHAR_TABLE (char_table);
1877 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1878 ctnew->type = ct->type;
1880 ctnew->default_value = ct->default_value;
1881 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1882 ctnew->name = ct->name;
1883 ctnew->db_file = ct->db_file;
1886 if (UINT8_BYTE_TABLE_P (ct->table))
1888 ctnew->table = copy_uint8_byte_table (ct->table);
1890 else if (UINT16_BYTE_TABLE_P (ct->table))
1892 ctnew->table = copy_uint16_byte_table (ct->table);
1894 else if (BYTE_TABLE_P (ct->table))
1896 ctnew->table = copy_byte_table (ct->table);
1898 else if (!UNBOUNDP (ct->table))
1899 ctnew->table = ct->table;
1900 #else /* non UTF2000 */
1902 for (i = 0; i < NUM_ASCII_CHARS; i++)
1904 Lisp_Object new = ct->ascii[i];
1906 assert (! (CHAR_TABLE_ENTRYP (new)));
1908 ctnew->ascii[i] = new;
1913 for (i = 0; i < NUM_LEADING_BYTES; i++)
1915 Lisp_Object new = ct->level1[i];
1916 if (CHAR_TABLE_ENTRYP (new))
1917 ctnew->level1[i] = copy_char_table_entry (new);
1919 ctnew->level1[i] = new;
1923 #endif /* non UTF2000 */
1926 if (CHAR_TABLEP (ct->mirror_table))
1927 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1929 ctnew->mirror_table = ct->mirror_table;
1931 ctnew->next_table = Qnil;
1932 XSETCHAR_TABLE (obj, ctnew);
1933 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1935 ctnew->next_table = Vall_syntax_tables;
1936 Vall_syntax_tables = obj;
1941 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1943 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1945 switch (XCHARSET_CHARS (ccs))
1948 return (33 << 8) | 126;
1950 return (32 << 8) | 127;
1953 return (0 << 8) | 127;
1955 return (0 << 8) | 255;
1967 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1970 outrange->type = CHARTAB_RANGE_ALL;
1971 else if (EQ (range, Qnil))
1972 outrange->type = CHARTAB_RANGE_DEFAULT;
1973 else if (CHAR_OR_CHAR_INTP (range))
1975 outrange->type = CHARTAB_RANGE_CHAR;
1976 outrange->ch = XCHAR_OR_CHAR_INT (range);
1980 signal_simple_error ("Range must be t or a character", range);
1982 else if (VECTORP (range))
1984 Lisp_Vector *vec = XVECTOR (range);
1985 Lisp_Object *elts = vector_data (vec);
1986 int cell_min, cell_max;
1988 outrange->type = CHARTAB_RANGE_ROW;
1989 outrange->charset = Fget_charset (elts[0]);
1990 CHECK_INT (elts[1]);
1991 outrange->row = XINT (elts[1]);
1992 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1993 signal_simple_error ("Charset in row vector must be multi-byte",
1997 int ret = XCHARSET_CELL_RANGE (outrange->charset);
1999 cell_min = ret >> 8;
2000 cell_max = ret & 0xFF;
2002 if (XCHARSET_DIMENSION (outrange->charset) == 2)
2003 check_int_range (outrange->row, cell_min, cell_max);
2005 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
2007 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2008 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2010 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2012 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2013 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2014 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2022 if (!CHARSETP (range) && !SYMBOLP (range))
2024 ("Char table range must be t, charset, char, or vector", range);
2025 outrange->type = CHARTAB_RANGE_CHARSET;
2026 outrange->charset = Fget_charset (range);
2031 #if defined(MULE)&&!defined(UTF2000)
2033 /* called from CHAR_TABLE_VALUE(). */
2035 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2040 Lisp_Object charset;
2042 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2047 BREAKUP_CHAR (c, charset, byte1, byte2);
2049 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2051 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2052 if (CHAR_TABLE_ENTRYP (val))
2054 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2055 val = cte->level2[byte1 - 32];
2056 if (CHAR_TABLE_ENTRYP (val))
2058 cte = XCHAR_TABLE_ENTRY (val);
2059 assert (byte2 >= 32);
2060 val = cte->level2[byte2 - 32];
2061 assert (!CHAR_TABLE_ENTRYP (val));
2071 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2074 return get_char_id_table (ct, ch);
2077 Lisp_Object charset;
2081 BREAKUP_CHAR (ch, charset, byte1, byte2);
2083 if (EQ (charset, Vcharset_ascii))
2084 val = ct->ascii[byte1];
2085 else if (EQ (charset, Vcharset_control_1))
2086 val = ct->ascii[byte1 + 128];
2089 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2090 val = ct->level1[lb];
2091 if (CHAR_TABLE_ENTRYP (val))
2093 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2094 val = cte->level2[byte1 - 32];
2095 if (CHAR_TABLE_ENTRYP (val))
2097 cte = XCHAR_TABLE_ENTRY (val);
2098 assert (byte2 >= 32);
2099 val = cte->level2[byte2 - 32];
2100 assert (!CHAR_TABLE_ENTRYP (val));
2107 #else /* not MULE */
2108 return ct->ascii[(unsigned char)ch];
2109 #endif /* not MULE */
2113 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2114 Find value for CHARACTER in CHAR-TABLE.
2116 (character, char_table))
2118 CHECK_CHAR_TABLE (char_table);
2119 CHECK_CHAR_COERCE_INT (character);
2121 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2124 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2125 Find value for a range in CHAR-TABLE.
2126 If there is more than one value, return MULTI (defaults to nil).
2128 (range, char_table, multi))
2130 Lisp_Char_Table *ct;
2131 struct chartab_range rainj;
2133 if (CHAR_OR_CHAR_INTP (range))
2134 return Fget_char_table (range, char_table);
2135 CHECK_CHAR_TABLE (char_table);
2136 ct = XCHAR_TABLE (char_table);
2138 decode_char_table_range (range, &rainj);
2141 case CHARTAB_RANGE_ALL:
2144 if (UINT8_BYTE_TABLE_P (ct->table))
2146 else if (UINT16_BYTE_TABLE_P (ct->table))
2148 else if (BYTE_TABLE_P (ct->table))
2152 #else /* non UTF2000 */
2154 Lisp_Object first = ct->ascii[0];
2156 for (i = 1; i < NUM_ASCII_CHARS; i++)
2157 if (!EQ (first, ct->ascii[i]))
2161 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2164 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2165 || i == LEADING_BYTE_ASCII
2166 || i == LEADING_BYTE_CONTROL_1)
2168 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2174 #endif /* non UTF2000 */
2178 case CHARTAB_RANGE_CHARSET:
2182 if (EQ (rainj.charset, Vcharset_ascii))
2185 Lisp_Object first = ct->ascii[0];
2187 for (i = 1; i < 128; i++)
2188 if (!EQ (first, ct->ascii[i]))
2193 if (EQ (rainj.charset, Vcharset_control_1))
2196 Lisp_Object first = ct->ascii[128];
2198 for (i = 129; i < 160; i++)
2199 if (!EQ (first, ct->ascii[i]))
2205 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2207 if (CHAR_TABLE_ENTRYP (val))
2213 case CHARTAB_RANGE_ROW:
2218 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2220 if (!CHAR_TABLE_ENTRYP (val))
2222 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2223 if (CHAR_TABLE_ENTRYP (val))
2227 #endif /* not UTF2000 */
2228 #endif /* not MULE */
2234 return Qnil; /* not reached */
2238 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2239 Error_behavior errb)
2243 case CHAR_TABLE_TYPE_SYNTAX:
2244 if (!ERRB_EQ (errb, ERROR_ME))
2245 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2246 && CHAR_OR_CHAR_INTP (XCDR (value)));
2249 Lisp_Object cdr = XCDR (value);
2250 CHECK_INT (XCAR (value));
2251 CHECK_CHAR_COERCE_INT (cdr);
2258 case CHAR_TABLE_TYPE_CATEGORY:
2259 if (!ERRB_EQ (errb, ERROR_ME))
2260 return CATEGORY_TABLE_VALUEP (value);
2261 CHECK_CATEGORY_TABLE_VALUE (value);
2265 case CHAR_TABLE_TYPE_GENERIC:
2268 case CHAR_TABLE_TYPE_DISPLAY:
2270 maybe_signal_simple_error ("Display char tables not yet implemented",
2271 value, Qchar_table, errb);
2274 case CHAR_TABLE_TYPE_CHAR:
2275 if (!ERRB_EQ (errb, ERROR_ME))
2276 return CHAR_OR_CHAR_INTP (value);
2277 CHECK_CHAR_COERCE_INT (value);
2284 return 0; /* not reached */
2288 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2292 case CHAR_TABLE_TYPE_SYNTAX:
2295 Lisp_Object car = XCAR (value);
2296 Lisp_Object cdr = XCDR (value);
2297 CHECK_CHAR_COERCE_INT (cdr);
2298 return Fcons (car, cdr);
2301 case CHAR_TABLE_TYPE_CHAR:
2302 CHECK_CHAR_COERCE_INT (value);
2310 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2311 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2313 (value, char_table_type))
2315 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2317 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2320 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2321 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2323 (value, char_table_type))
2325 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2327 check_valid_char_table_value (value, type, ERROR_ME);
2332 Lisp_Char_Table* char_attribute_table_to_put;
2333 Lisp_Object Qput_char_table_map_function;
2334 Lisp_Object value_to_put;
2336 DEFUN ("put-char-table-map-function",
2337 Fput_char_table_map_function, 2, 2, 0, /*
2338 For internal use. Don't use it.
2342 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2347 /* Assign VAL to all characters in RANGE in char table CT. */
2350 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2353 switch (range->type)
2355 case CHARTAB_RANGE_ALL:
2356 /* printf ("put-char-table: range = all\n"); */
2357 fill_char_table (ct, val);
2358 return; /* avoid the duplicate call to update_syntax_table() below,
2359 since fill_char_table() also did that. */
2362 case CHARTAB_RANGE_DEFAULT:
2363 ct->default_value = val;
2368 case CHARTAB_RANGE_CHARSET:
2372 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2374 /* printf ("put-char-table: range = charset: %d\n",
2375 XCHARSET_LEADING_BYTE (range->charset));
2377 if ( CHAR_TABLEP (encoding_table) )
2380 char_attribute_table_to_put = ct;
2382 Fmap_char_attribute (Qput_char_table_map_function,
2383 XCHAR_TABLE_NAME (encoding_table),
2386 for (c = 0; c < 1 << 24; c++)
2388 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2390 put_char_id_table_0 (ct, c, val);
2396 for (c = 0; c < 1 << 24; c++)
2398 if ( charset_code_point (range->charset, c) >= 0 )
2399 put_char_id_table_0 (ct, c, val);
2404 if (EQ (range->charset, Vcharset_ascii))
2407 for (i = 0; i < 128; i++)
2410 else if (EQ (range->charset, Vcharset_control_1))
2413 for (i = 128; i < 160; i++)
2418 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2419 ct->level1[lb] = val;
2424 case CHARTAB_RANGE_ROW:
2427 int cell_min, cell_max, i;
2429 i = XCHARSET_CELL_RANGE (range->charset);
2431 cell_max = i & 0xFF;
2432 for (i = cell_min; i <= cell_max; i++)
2434 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2436 if ( charset_code_point (range->charset, ch) >= 0 )
2437 put_char_id_table_0 (ct, ch, val);
2442 Lisp_Char_Table_Entry *cte;
2443 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2444 /* make sure that there is a separate entry for the row. */
2445 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2446 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2447 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2448 cte->level2[range->row - 32] = val;
2450 #endif /* not UTF2000 */
2454 case CHARTAB_RANGE_CHAR:
2456 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2457 put_char_id_table_0 (ct, range->ch, val);
2461 Lisp_Object charset;
2464 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2465 if (EQ (charset, Vcharset_ascii))
2466 ct->ascii[byte1] = val;
2467 else if (EQ (charset, Vcharset_control_1))
2468 ct->ascii[byte1 + 128] = val;
2471 Lisp_Char_Table_Entry *cte;
2472 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2473 /* make sure that there is a separate entry for the row. */
2474 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2475 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2476 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2477 /* now CTE is a char table entry for the charset;
2478 each entry is for a single row (or character of
2479 a one-octet charset). */
2480 if (XCHARSET_DIMENSION (charset) == 1)
2481 cte->level2[byte1 - 32] = val;
2484 /* assigning to one character in a two-octet charset. */
2485 /* make sure that the charset row contains a separate
2486 entry for each character. */
2487 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2488 cte->level2[byte1 - 32] =
2489 make_char_table_entry (cte->level2[byte1 - 32]);
2490 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2491 cte->level2[byte2 - 32] = val;
2495 #else /* not MULE */
2496 ct->ascii[(unsigned char) (range->ch)] = val;
2498 #endif /* not MULE */
2502 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2503 update_syntax_table (ct);
2507 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2508 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2510 RANGE specifies one or more characters to be affected and should be
2511 one of the following:
2513 -- t (all characters are affected)
2514 -- A charset (only allowed when Mule support is present)
2515 -- A vector of two elements: a two-octet charset and a row number
2516 (only allowed when Mule support is present)
2517 -- A single character
2519 VALUE must be a value appropriate for the type of CHAR-TABLE.
2520 See `valid-char-table-type-p'.
2522 (range, value, char_table))
2524 Lisp_Char_Table *ct;
2525 struct chartab_range rainj;
2527 CHECK_CHAR_TABLE (char_table);
2528 ct = XCHAR_TABLE (char_table);
2529 check_valid_char_table_value (value, ct->type, ERROR_ME);
2530 decode_char_table_range (range, &rainj);
2531 value = canonicalize_char_table_value (value, ct->type);
2532 put_char_table (ct, &rainj, value);
2537 /* Map FN over the ASCII chars in CT. */
2540 map_over_charset_ascii (Lisp_Char_Table *ct,
2541 int (*fn) (struct chartab_range *range,
2542 Lisp_Object val, void *arg),
2545 struct chartab_range rainj;
2554 rainj.type = CHARTAB_RANGE_CHAR;
2556 for (i = start, retval = 0; i < stop && retval == 0; i++)
2558 rainj.ch = (Emchar) i;
2559 retval = (fn) (&rainj, ct->ascii[i], arg);
2567 /* Map FN over the Control-1 chars in CT. */
2570 map_over_charset_control_1 (Lisp_Char_Table *ct,
2571 int (*fn) (struct chartab_range *range,
2572 Lisp_Object val, void *arg),
2575 struct chartab_range rainj;
2578 int stop = start + 32;
2580 rainj.type = CHARTAB_RANGE_CHAR;
2582 for (i = start, retval = 0; i < stop && retval == 0; i++)
2584 rainj.ch = (Emchar) (i);
2585 retval = (fn) (&rainj, ct->ascii[i], arg);
2591 /* Map FN over the row ROW of two-byte charset CHARSET.
2592 There must be a separate value for that row in the char table.
2593 CTE specifies the char table entry for CHARSET. */
2596 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2597 Lisp_Object charset, int row,
2598 int (*fn) (struct chartab_range *range,
2599 Lisp_Object val, void *arg),
2602 Lisp_Object val = cte->level2[row - 32];
2604 if (!CHAR_TABLE_ENTRYP (val))
2606 struct chartab_range rainj;
2608 rainj.type = CHARTAB_RANGE_ROW;
2609 rainj.charset = charset;
2611 return (fn) (&rainj, val, arg);
2615 struct chartab_range rainj;
2617 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2618 int start = charset94_p ? 33 : 32;
2619 int stop = charset94_p ? 127 : 128;
2621 cte = XCHAR_TABLE_ENTRY (val);
2623 rainj.type = CHARTAB_RANGE_CHAR;
2625 for (i = start, retval = 0; i < stop && retval == 0; i++)
2627 rainj.ch = MAKE_CHAR (charset, row, i);
2628 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2636 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2637 int (*fn) (struct chartab_range *range,
2638 Lisp_Object val, void *arg),
2641 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2642 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2644 if (!CHARSETP (charset)
2645 || lb == LEADING_BYTE_ASCII
2646 || lb == LEADING_BYTE_CONTROL_1)
2649 if (!CHAR_TABLE_ENTRYP (val))
2651 struct chartab_range rainj;
2653 rainj.type = CHARTAB_RANGE_CHARSET;
2654 rainj.charset = charset;
2655 return (fn) (&rainj, val, arg);
2659 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2660 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2661 int start = charset94_p ? 33 : 32;
2662 int stop = charset94_p ? 127 : 128;
2665 if (XCHARSET_DIMENSION (charset) == 1)
2667 struct chartab_range rainj;
2668 rainj.type = CHARTAB_RANGE_CHAR;
2670 for (i = start, retval = 0; i < stop && retval == 0; i++)
2672 rainj.ch = MAKE_CHAR (charset, i, 0);
2673 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2678 for (i = start, retval = 0; i < stop && retval == 0; i++)
2679 retval = map_over_charset_row (cte, charset, i, fn, arg);
2687 #endif /* not UTF2000 */
2690 struct map_char_table_for_charset_arg
2692 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2693 Lisp_Char_Table *ct;
2698 map_char_table_for_charset_fun (struct chartab_range *range,
2699 Lisp_Object val, void *arg)
2701 struct map_char_table_for_charset_arg *closure =
2702 (struct map_char_table_for_charset_arg *) arg;
2705 switch (range->type)
2707 case CHARTAB_RANGE_ALL:
2710 case CHARTAB_RANGE_DEFAULT:
2713 case CHARTAB_RANGE_CHARSET:
2716 case CHARTAB_RANGE_ROW:
2719 case CHARTAB_RANGE_CHAR:
2720 ret = get_char_table (range->ch, closure->ct);
2721 if (!UNBOUNDP (ret))
2722 return (closure->fn) (range, ret, closure->arg);
2732 #if defined(HAVE_DATABASE)
2733 EXFUN (Fload_char_attribute_table, 1);
2738 /* Map FN (with client data ARG) over range RANGE in char table CT.
2739 Mapping stops the first time FN returns non-zero, and that value
2740 becomes the return value of map_char_table(). */
2743 map_char_table (Lisp_Char_Table *ct,
2744 struct chartab_range *range,
2745 int (*fn) (struct chartab_range *range,
2746 Lisp_Object val, void *arg),
2749 switch (range->type)
2751 case CHARTAB_RANGE_ALL:
2753 if (!UNBOUNDP (ct->default_value))
2755 struct chartab_range rainj;
2758 rainj.type = CHARTAB_RANGE_DEFAULT;
2759 retval = (fn) (&rainj, ct->default_value, arg);
2763 if (UINT8_BYTE_TABLE_P (ct->table))
2764 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2766 else if (UINT16_BYTE_TABLE_P (ct->table))
2767 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2769 else if (BYTE_TABLE_P (ct->table))
2770 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2772 else if (EQ (ct->table, Qunloaded))
2775 struct chartab_range rainj;
2778 Emchar c1 = c + unit;
2781 rainj.type = CHARTAB_RANGE_CHAR;
2783 for (retval = 0; c < c1 && retval == 0; c++)
2785 Lisp_Object ret = get_char_id_table (ct, c);
2787 if (!UNBOUNDP (ret))
2790 retval = (fn) (&rainj, ct->table, arg);
2795 ct->table = Qunbound;
2798 else if (!UNBOUNDP (ct->table))
2799 return (fn) (range, ct->table, arg);
2805 retval = map_over_charset_ascii (ct, fn, arg);
2809 retval = map_over_charset_control_1 (ct, fn, arg);
2814 Charset_ID start = MIN_LEADING_BYTE;
2815 Charset_ID stop = start + NUM_LEADING_BYTES;
2817 for (i = start, retval = 0; i < stop && retval == 0; i++)
2819 retval = map_over_other_charset (ct, i, fn, arg);
2828 case CHARTAB_RANGE_DEFAULT:
2829 if (!UNBOUNDP (ct->default_value))
2830 return (fn) (range, ct->default_value, arg);
2835 case CHARTAB_RANGE_CHARSET:
2838 Lisp_Object encoding_table
2839 = XCHARSET_ENCODING_TABLE (range->charset);
2841 if (!NILP (encoding_table))
2843 struct chartab_range rainj;
2844 struct map_char_table_for_charset_arg mcarg;
2846 #ifdef HAVE_DATABASE
2847 if (XCHAR_TABLE_UNLOADED(encoding_table))
2848 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2853 rainj.type = CHARTAB_RANGE_ALL;
2854 return map_char_table (XCHAR_TABLE(encoding_table),
2856 &map_char_table_for_charset_fun,
2862 return map_over_other_charset (ct,
2863 XCHARSET_LEADING_BYTE (range->charset),
2867 case CHARTAB_RANGE_ROW:
2870 int cell_min, cell_max, i;
2872 struct chartab_range rainj;
2874 i = XCHARSET_CELL_RANGE (range->charset);
2876 cell_max = i & 0xFF;
2877 rainj.type = CHARTAB_RANGE_CHAR;
2878 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2880 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2882 if ( charset_code_point (range->charset, ch) >= 0 )
2885 = get_byte_table (get_byte_table
2889 (unsigned char)(ch >> 24)),
2890 (unsigned char) (ch >> 16)),
2891 (unsigned char) (ch >> 8)),
2892 (unsigned char) ch);
2895 val = ct->default_value;
2897 retval = (fn) (&rainj, val, arg);
2904 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2905 - MIN_LEADING_BYTE];
2906 if (!CHAR_TABLE_ENTRYP (val))
2908 struct chartab_range rainj;
2910 rainj.type = CHARTAB_RANGE_ROW;
2911 rainj.charset = range->charset;
2912 rainj.row = range->row;
2913 return (fn) (&rainj, val, arg);
2916 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2917 range->charset, range->row,
2920 #endif /* not UTF2000 */
2923 case CHARTAB_RANGE_CHAR:
2925 Emchar ch = range->ch;
2926 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2928 if (!UNBOUNDP (val))
2930 struct chartab_range rainj;
2932 rainj.type = CHARTAB_RANGE_CHAR;
2934 return (fn) (&rainj, val, arg);
2946 struct slow_map_char_table_arg
2948 Lisp_Object function;
2953 slow_map_char_table_fun (struct chartab_range *range,
2954 Lisp_Object val, void *arg)
2956 Lisp_Object ranjarg = Qnil;
2957 struct slow_map_char_table_arg *closure =
2958 (struct slow_map_char_table_arg *) arg;
2960 switch (range->type)
2962 case CHARTAB_RANGE_ALL:
2967 case CHARTAB_RANGE_DEFAULT:
2973 case CHARTAB_RANGE_CHARSET:
2974 ranjarg = XCHARSET_NAME (range->charset);
2977 case CHARTAB_RANGE_ROW:
2978 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2979 make_int (range->row));
2982 case CHARTAB_RANGE_CHAR:
2983 ranjarg = make_char (range->ch);
2989 closure->retval = call2 (closure->function, ranjarg, val);
2990 return !NILP (closure->retval);
2993 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2994 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2995 each key and value in the table.
2997 RANGE specifies a subrange to map over and is in the same format as
2998 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3001 (function, char_table, range))
3003 Lisp_Char_Table *ct;
3004 struct slow_map_char_table_arg slarg;
3005 struct gcpro gcpro1, gcpro2;
3006 struct chartab_range rainj;
3008 CHECK_CHAR_TABLE (char_table);
3009 ct = XCHAR_TABLE (char_table);
3012 decode_char_table_range (range, &rainj);
3013 slarg.function = function;
3014 slarg.retval = Qnil;
3015 GCPRO2 (slarg.function, slarg.retval);
3016 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3019 return slarg.retval;
3023 /************************************************************************/
3024 /* Character Attributes */
3025 /************************************************************************/
3029 Lisp_Object Vchar_attribute_hash_table;
3031 /* We store the char-attributes in hash tables with the names as the
3032 key and the actual char-id-table object as the value. Occasionally
3033 we need to use them in a list format. These routines provide us
3035 struct char_attribute_list_closure
3037 Lisp_Object *char_attribute_list;
3041 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3042 void *char_attribute_list_closure)
3044 /* This function can GC */
3045 struct char_attribute_list_closure *calcl
3046 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3047 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3049 *char_attribute_list = Fcons (key, *char_attribute_list);
3053 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3054 Return the list of all existing character attributes except coded-charsets.
3058 Lisp_Object char_attribute_list = Qnil;
3059 struct gcpro gcpro1;
3060 struct char_attribute_list_closure char_attribute_list_closure;
3062 GCPRO1 (char_attribute_list);
3063 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3064 elisp_maphash (add_char_attribute_to_list_mapper,
3065 Vchar_attribute_hash_table,
3066 &char_attribute_list_closure);
3068 return char_attribute_list;
3071 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3072 Return char-id-table corresponding to ATTRIBUTE.
3076 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3080 /* We store the char-id-tables in hash tables with the attributes as
3081 the key and the actual char-id-table object as the value. Each
3082 char-id-table stores values of an attribute corresponding with
3083 characters. Occasionally we need to get attributes of a character
3084 in a association-list format. These routines provide us with
3086 struct char_attribute_alist_closure
3089 Lisp_Object *char_attribute_alist;
3093 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3094 void *char_attribute_alist_closure)
3096 /* This function can GC */
3097 struct char_attribute_alist_closure *caacl =
3098 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3100 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3101 if (!UNBOUNDP (ret))
3103 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3104 *char_attribute_alist
3105 = Fcons (Fcons (key, ret), *char_attribute_alist);
3110 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3111 Return the alist of attributes of CHARACTER.
3115 struct gcpro gcpro1;
3116 struct char_attribute_alist_closure char_attribute_alist_closure;
3117 Lisp_Object alist = Qnil;
3119 CHECK_CHAR (character);
3122 char_attribute_alist_closure.char_id = XCHAR (character);
3123 char_attribute_alist_closure.char_attribute_alist = &alist;
3124 elisp_maphash (add_char_attribute_alist_mapper,
3125 Vchar_attribute_hash_table,
3126 &char_attribute_alist_closure);
3132 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3133 Return the value of CHARACTER's ATTRIBUTE.
3134 Return DEFAULT-VALUE if the value is not exist.
3136 (character, attribute, default_value))
3140 CHECK_CHAR (character);
3142 if (CHARSETP (attribute))
3143 attribute = XCHARSET_NAME (attribute);
3145 table = Fgethash (attribute, Vchar_attribute_hash_table,
3147 if (!UNBOUNDP (table))
3149 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3151 if (!UNBOUNDP (ret))
3154 return default_value;
3157 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3158 Store CHARACTER's ATTRIBUTE with VALUE.
3160 (character, attribute, value))
3162 Lisp_Object ccs = Ffind_charset (attribute);
3166 CHECK_CHAR (character);
3167 value = put_char_ccs_code_point (character, ccs, value);
3169 else if (EQ (attribute, Q_decomposition))
3173 CHECK_CHAR (character);
3175 signal_simple_error ("Invalid value for ->decomposition",
3178 if (CONSP (Fcdr (value)))
3180 Lisp_Object rest = value;
3181 Lisp_Object table = Vcharacter_composition_table;
3185 GET_EXTERNAL_LIST_LENGTH (rest, len);
3186 seq = make_vector (len, Qnil);
3188 while (CONSP (rest))
3190 Lisp_Object v = Fcar (rest);
3193 = to_char_id (v, "Invalid value for ->decomposition", value);
3196 XVECTOR_DATA(seq)[i++] = v;
3198 XVECTOR_DATA(seq)[i++] = make_char (c);
3202 put_char_id_table (XCHAR_TABLE(table),
3203 make_char (c), character);
3208 ntable = get_char_id_table (XCHAR_TABLE(table), c);
3209 if (!CHAR_TABLEP (ntable))
3211 ntable = make_char_id_table (Qnil);
3212 put_char_id_table (XCHAR_TABLE(table),
3213 make_char (c), ntable);
3221 Lisp_Object v = Fcar (value);
3225 Emchar c = XINT (v);
3227 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3232 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3233 make_char (c), Fcons (character, Qnil));
3235 else if (NILP (Fmemq (v, ret)))
3237 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3238 make_char (c), Fcons (character, ret));
3241 seq = make_vector (1, v);
3245 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3250 CHECK_CHAR (character);
3252 signal_simple_error ("Invalid value for ->ucs", value);
3256 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
3259 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3260 make_char (c), Fcons (character, Qnil));
3262 else if (NILP (Fmemq (character, ret)))
3264 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3265 make_char (c), Fcons (character, ret));
3268 if (EQ (attribute, Q_ucs))
3269 attribute = Qto_ucs;
3273 Lisp_Object table = Fgethash (attribute,
3274 Vchar_attribute_hash_table,
3279 table = make_char_id_table (Qunbound);
3280 Fputhash (attribute, table, Vchar_attribute_hash_table);
3281 #ifdef HAVE_DATABASE
3282 XCHAR_TABLE_NAME (table) = attribute;
3285 put_char_id_table (XCHAR_TABLE(table), character, value);
3290 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3291 Remove CHARACTER's ATTRIBUTE.
3293 (character, attribute))
3297 CHECK_CHAR (character);
3298 ccs = Ffind_charset (attribute);
3301 return remove_char_ccs (character, ccs);
3305 Lisp_Object table = Fgethash (attribute,
3306 Vchar_attribute_hash_table,
3308 if (!UNBOUNDP (table))
3310 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3318 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3321 Lisp_Object db_dir = Vexec_directory;
3324 db_dir = build_string ("../lib-src");
3326 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3327 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3328 Fmake_directory_internal (db_dir);
3330 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3331 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3332 Fmake_directory_internal (db_dir);
3335 Lisp_Object attribute_name = Fsymbol_name (attribute);
3336 Lisp_Object dest = Qnil, ret;
3338 struct gcpro gcpro1, gcpro2;
3339 int len = XSTRING_CHAR_LENGTH (attribute_name);
3343 for (i = 0; i < len; i++)
3345 Emchar c = string_char (XSTRING (attribute_name), i);
3347 if ( (c == '/') || (c == '%') )
3351 sprintf (str, "%%%02X", c);
3352 dest = concat3 (dest,
3353 Fsubstring (attribute_name,
3354 make_int (base), make_int (i)),
3355 build_string (str));
3359 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3360 dest = concat2 (dest, ret);
3362 return Fexpand_file_name (dest, db_dir);
3365 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3369 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3370 Save values of ATTRIBUTE into database file.
3374 #ifdef HAVE_DATABASE
3375 Lisp_Object table = Fgethash (attribute,
3376 Vchar_attribute_hash_table, Qunbound);
3377 Lisp_Char_Table *ct;
3379 if (CHAR_TABLEP (table))
3380 ct = XCHAR_TABLE (table);
3384 if (NILP (ct->db_file))
3386 = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3387 if (NILP (Fdatabase_live_p (ct->db)))
3388 ct->db = Fopen_database (ct->db_file, Qnil, Qnil, Qnil, Qnil);
3391 if (UINT8_BYTE_TABLE_P (ct->table))
3392 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, ct->db, 0, 3);
3393 else if (UINT16_BYTE_TABLE_P (ct->table))
3394 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, ct->db, 0, 3);
3395 else if (BYTE_TABLE_P (ct->table))
3396 save_byte_table (XBYTE_TABLE(ct->table), ct, ct->db, 0, 3);
3397 Fclose_database (ct->db);
3408 DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /*
3409 Close database of ATTRIBUTE.
3413 #ifdef HAVE_DATABASE
3414 Lisp_Object table = Fgethash (attribute,
3415 Vchar_attribute_hash_table, Qunbound);
3416 Lisp_Char_Table *ct;
3418 if (CHAR_TABLEP (table))
3419 ct = XCHAR_TABLE (table);
3425 if (!NILP (Fdatabase_live_p (ct->db)))
3426 Fclose_database (ct->db);
3434 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3435 Reset values of ATTRIBUTE with database file.
3439 #ifdef HAVE_DATABASE
3440 Lisp_Object table = Fgethash (attribute,
3441 Vchar_attribute_hash_table, Qunbound);
3442 Lisp_Char_Table *ct;
3444 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3446 if (!NILP (Ffile_exists_p (db_file)))
3448 if (UNBOUNDP (table))
3450 table = make_char_id_table (Qunbound);
3451 Fputhash (attribute, table, Vchar_attribute_hash_table);
3452 XCHAR_TABLE_NAME(table) = attribute;
3454 ct = XCHAR_TABLE (table);
3455 ct->table = Qunloaded;
3456 ct->db_file = db_file;
3457 if (!NILP (Fdatabase_live_p (ct->db)))
3458 Fclose_database (ct->db);
3460 XCHAR_TABLE_UNLOADED(table) = 1;
3467 #ifdef HAVE_DATABASE
3469 load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch)
3471 Lisp_Object attribute = CHAR_TABLE_NAME (cit);
3473 if (!NILP (attribute))
3475 if (NILP (cit->db_file))
3477 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3478 if (NILP (Fdatabase_live_p (cit->db)))
3479 cit->db = Fopen_database (cit->db_file, Qnil, Qnil, Qnil, Qnil);
3480 if (!NILP (cit->db))
3483 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3485 if (!UNBOUNDP (val))
3495 Lisp_Char_Table* char_attribute_table_to_load;
3497 Lisp_Object Qload_char_attribute_table_map_function;
3499 DEFUN ("load-char-attribute-table-map-function",
3500 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3501 For internal use. Don't use it.
3505 Lisp_Object c = Fread (key);
3506 Emchar code = XCHAR (c);
3507 Lisp_Object ret = get_char_id_table (char_attribute_table_to_load, code);
3509 if (EQ (ret, Qunloaded))
3510 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3515 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3516 Load values of ATTRIBUTE into database file.
3520 #ifdef HAVE_DATABASE
3521 Lisp_Object table = Fgethash (attribute,
3522 Vchar_attribute_hash_table,
3524 if (CHAR_TABLEP (table))
3526 Lisp_Char_Table *ct = XCHAR_TABLE (table);
3528 if (NILP (ct->db_file))
3530 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3531 if (NILP (Fdatabase_live_p (ct->db)))
3532 ct->db = Fopen_database (ct->db_file, Qnil, Qnil, Qnil, Qnil);
3535 struct gcpro gcpro1;
3537 char_attribute_table_to_load = XCHAR_TABLE (table);
3539 Fmap_database (Qload_char_attribute_table_map_function, ct->db);
3541 Fclose_database (ct->db);
3543 XCHAR_TABLE_UNLOADED(table) = 0;
3551 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3552 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3553 each key and value in the table.
3555 RANGE specifies a subrange to map over and is in the same format as
3556 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3559 (function, attribute, range))
3562 Lisp_Char_Table *ct;
3563 struct slow_map_char_table_arg slarg;
3564 struct gcpro gcpro1, gcpro2;
3565 struct chartab_range rainj;
3567 if (!NILP (ccs = Ffind_charset (attribute)))
3569 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3571 if (CHAR_TABLEP (encoding_table))
3572 ct = XCHAR_TABLE (encoding_table);
3578 Lisp_Object table = Fgethash (attribute,
3579 Vchar_attribute_hash_table,
3581 if (CHAR_TABLEP (table))
3582 ct = XCHAR_TABLE (table);
3588 decode_char_table_range (range, &rainj);
3589 #ifdef HAVE_DATABASE
3590 if (CHAR_TABLE_UNLOADED(ct))
3591 Fload_char_attribute_table (attribute);
3593 slarg.function = function;
3594 slarg.retval = Qnil;
3595 GCPRO2 (slarg.function, slarg.retval);
3596 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3599 return slarg.retval;
3602 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3603 Store character's ATTRIBUTES.
3607 Lisp_Object rest = attributes;
3608 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3609 Lisp_Object character;
3613 while (CONSP (rest))
3615 Lisp_Object cell = Fcar (rest);
3619 signal_simple_error ("Invalid argument", attributes);
3620 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3621 && ((XCHARSET_FINAL (ccs) != 0) ||
3622 (XCHARSET_MAX_CODE (ccs) > 0) ||
3623 (EQ (ccs, Vcharset_chinese_big5))) )
3627 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3629 character = Fdecode_char (ccs, cell, Qnil);
3630 if (!NILP (character))
3631 goto setup_attributes;
3635 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3636 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3640 signal_simple_error ("Invalid argument", attributes);
3642 character = make_char (XINT (code) + 0x100000);
3643 goto setup_attributes;
3647 else if (!INTP (code))
3648 signal_simple_error ("Invalid argument", attributes);
3650 character = make_char (XINT (code));
3654 while (CONSP (rest))
3656 Lisp_Object cell = Fcar (rest);
3659 signal_simple_error ("Invalid argument", attributes);
3661 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3667 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3668 Retrieve the character of the given ATTRIBUTES.
3672 Lisp_Object rest = attributes;
3675 while (CONSP (rest))
3677 Lisp_Object cell = Fcar (rest);
3681 signal_simple_error ("Invalid argument", attributes);
3682 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3686 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3688 return Fdecode_char (ccs, cell, Qnil);
3692 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3693 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3696 signal_simple_error ("Invalid argument", attributes);
3698 return make_char (XINT (code) + 0x100000);
3706 /************************************************************************/
3707 /* Char table read syntax */
3708 /************************************************************************/
3711 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3712 Error_behavior errb)
3714 /* #### should deal with ERRB */
3715 symbol_to_char_table_type (value);
3720 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3721 Error_behavior errb)
3725 /* #### should deal with ERRB */
3726 EXTERNAL_LIST_LOOP (rest, value)
3728 Lisp_Object range = XCAR (rest);
3729 struct chartab_range dummy;
3733 signal_simple_error ("Invalid list format", value);
3736 if (!CONSP (XCDR (range))
3737 || !NILP (XCDR (XCDR (range))))
3738 signal_simple_error ("Invalid range format", range);
3739 decode_char_table_range (XCAR (range), &dummy);
3740 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3743 decode_char_table_range (range, &dummy);
3750 chartab_instantiate (Lisp_Object data)
3752 Lisp_Object chartab;
3753 Lisp_Object type = Qgeneric;
3754 Lisp_Object dataval = Qnil;
3756 while (!NILP (data))
3758 Lisp_Object keyw = Fcar (data);
3764 if (EQ (keyw, Qtype))
3766 else if (EQ (keyw, Qdata))
3770 chartab = Fmake_char_table (type);
3773 while (!NILP (data))
3775 Lisp_Object range = Fcar (data);
3776 Lisp_Object val = Fcar (Fcdr (data));
3778 data = Fcdr (Fcdr (data));
3781 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3783 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3784 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3787 for (i = first; i <= last; i++)
3788 Fput_char_table (make_char (i), val, chartab);
3794 Fput_char_table (range, val, chartab);
3803 /************************************************************************/
3804 /* Category Tables, specifically */
3805 /************************************************************************/
3807 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3808 Return t if OBJECT is a category table.
3809 A category table is a type of char table used for keeping track of
3810 categories. Categories are used for classifying characters for use
3811 in regexps -- you can refer to a category rather than having to use
3812 a complicated [] expression (and category lookups are significantly
3815 There are 95 different categories available, one for each printable
3816 character (including space) in the ASCII charset. Each category
3817 is designated by one such character, called a "category designator".
3818 They are specified in a regexp using the syntax "\\cX", where X is
3819 a category designator.
3821 A category table specifies, for each character, the categories that
3822 the character is in. Note that a character can be in more than one
3823 category. More specifically, a category table maps from a character
3824 to either the value nil (meaning the character is in no categories)
3825 or a 95-element bit vector, specifying for each of the 95 categories
3826 whether the character is in that category.
3828 Special Lisp functions are provided that abstract this, so you do not
3829 have to directly manipulate bit vectors.
3833 return (CHAR_TABLEP (object) &&
3834 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3839 check_category_table (Lisp_Object object, Lisp_Object default_)
3843 while (NILP (Fcategory_table_p (object)))
3844 object = wrong_type_argument (Qcategory_table_p, object);
3849 check_category_char (Emchar ch, Lisp_Object table,
3850 unsigned int designator, unsigned int not_p)
3852 REGISTER Lisp_Object temp;
3853 Lisp_Char_Table *ctbl;
3854 #ifdef ERROR_CHECK_TYPECHECK
3855 if (NILP (Fcategory_table_p (table)))
3856 signal_simple_error ("Expected category table", table);
3858 ctbl = XCHAR_TABLE (table);
3859 temp = get_char_table (ch, ctbl);
3864 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3867 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3868 Return t if category of the character at POSITION includes DESIGNATOR.
3869 Optional third arg BUFFER specifies which buffer to use, and defaults
3870 to the current buffer.
3871 Optional fourth arg CATEGORY-TABLE specifies the category table to
3872 use, and defaults to BUFFER's category table.
3874 (position, designator, buffer, category_table))
3879 struct buffer *buf = decode_buffer (buffer, 0);
3881 CHECK_INT (position);
3882 CHECK_CATEGORY_DESIGNATOR (designator);
3883 des = XCHAR (designator);
3884 ctbl = check_category_table (category_table, Vstandard_category_table);
3885 ch = BUF_FETCH_CHAR (buf, XINT (position));
3886 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3889 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3890 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3891 Optional third arg CATEGORY-TABLE specifies the category table to use,
3892 and defaults to the standard category table.
3894 (character, designator, category_table))
3900 CHECK_CATEGORY_DESIGNATOR (designator);
3901 des = XCHAR (designator);
3902 CHECK_CHAR (character);
3903 ch = XCHAR (character);
3904 ctbl = check_category_table (category_table, Vstandard_category_table);
3905 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3908 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3909 Return BUFFER's current category table.
3910 BUFFER defaults to the current buffer.
3914 return decode_buffer (buffer, 0)->category_table;
3917 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3918 Return the standard category table.
3919 This is the one used for new buffers.
3923 return Vstandard_category_table;
3926 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3927 Return a new category table which is a copy of CATEGORY-TABLE.
3928 CATEGORY-TABLE defaults to the standard category table.
3932 if (NILP (Vstandard_category_table))
3933 return Fmake_char_table (Qcategory);
3936 check_category_table (category_table, Vstandard_category_table);
3937 return Fcopy_char_table (category_table);
3940 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3941 Select CATEGORY-TABLE as the new category table for BUFFER.
3942 BUFFER defaults to the current buffer if omitted.
3944 (category_table, buffer))
3946 struct buffer *buf = decode_buffer (buffer, 0);
3947 category_table = check_category_table (category_table, Qnil);
3948 buf->category_table = category_table;
3949 /* Indicate that this buffer now has a specified category table. */
3950 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3951 return category_table;
3954 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3955 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3959 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3962 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3963 Return t if OBJECT is a category table value.
3964 Valid values are nil or a bit vector of size 95.
3968 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3972 #define CATEGORYP(x) \
3973 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3975 #define CATEGORY_SET(c) \
3976 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3978 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3979 The faster version of `!NILP (Faref (category_set, category))'. */
3980 #define CATEGORY_MEMBER(category, category_set) \
3981 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3983 /* Return 1 if there is a word boundary between two word-constituent
3984 characters C1 and C2 if they appear in this order, else return 0.
3985 Use the macro WORD_BOUNDARY_P instead of calling this function
3988 int word_boundary_p (Emchar c1, Emchar c2);
3990 word_boundary_p (Emchar c1, Emchar c2)
3992 Lisp_Object category_set1, category_set2;
3997 if (COMPOSITE_CHAR_P (c1))
3998 c1 = cmpchar_component (c1, 0, 1);
3999 if (COMPOSITE_CHAR_P (c2))
4000 c2 = cmpchar_component (c2, 0, 1);
4003 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
4005 tail = Vword_separating_categories;
4010 tail = Vword_combining_categories;
4014 category_set1 = CATEGORY_SET (c1);
4015 if (NILP (category_set1))
4016 return default_result;
4017 category_set2 = CATEGORY_SET (c2);
4018 if (NILP (category_set2))
4019 return default_result;
4021 for (; CONSP (tail); tail = XCONS (tail)->cdr)
4023 Lisp_Object elt = XCONS(tail)->car;
4026 && CATEGORYP (XCONS (elt)->car)
4027 && CATEGORYP (XCONS (elt)->cdr)
4028 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
4029 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
4030 return !default_result;
4032 return default_result;
4038 syms_of_chartab (void)
4041 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4042 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4043 INIT_LRECORD_IMPLEMENTATION (byte_table);
4045 defsymbol (&Qsystem_char_id, "system-char-id");
4047 defsymbol (&Qto_ucs, "=>ucs");
4048 defsymbol (&Q_ucs, "->ucs");
4049 defsymbol (&Q_ucs_variants, "->ucs-variants");
4050 defsymbol (&Q_decomposition, "->decomposition");
4051 defsymbol (&Qcompat, "compat");
4052 defsymbol (&Qisolated, "isolated");
4053 defsymbol (&Qinitial, "initial");
4054 defsymbol (&Qmedial, "medial");
4055 defsymbol (&Qfinal, "final");
4056 defsymbol (&Qvertical, "vertical");
4057 defsymbol (&QnoBreak, "noBreak");
4058 defsymbol (&Qfraction, "fraction");
4059 defsymbol (&Qsuper, "super");
4060 defsymbol (&Qsub, "sub");
4061 defsymbol (&Qcircle, "circle");
4062 defsymbol (&Qsquare, "square");
4063 defsymbol (&Qwide, "wide");
4064 defsymbol (&Qnarrow, "narrow");
4065 defsymbol (&Qsmall, "small");
4066 defsymbol (&Qfont, "font");
4068 DEFSUBR (Fchar_attribute_list);
4069 DEFSUBR (Ffind_char_attribute_table);
4070 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4071 DEFSUBR (Fput_char_table_map_function);
4072 DEFSUBR (Fsave_char_attribute_table);
4073 DEFSUBR (Freset_char_attribute_table);
4074 DEFSUBR (Fclose_char_attribute_table);
4075 #ifdef HAVE_DATABASE
4076 defsymbol (&Qload_char_attribute_table_map_function,
4077 "load-char-attribute-table-map-function");
4078 DEFSUBR (Fload_char_attribute_table_map_function);
4080 DEFSUBR (Fload_char_attribute_table);
4081 DEFSUBR (Fchar_attribute_alist);
4082 DEFSUBR (Fget_char_attribute);
4083 DEFSUBR (Fput_char_attribute);
4084 DEFSUBR (Fremove_char_attribute);
4085 DEFSUBR (Fmap_char_attribute);
4086 DEFSUBR (Fdefine_char);
4087 DEFSUBR (Ffind_char);
4088 DEFSUBR (Fchar_variants);
4090 DEFSUBR (Fget_composite_char);
4093 INIT_LRECORD_IMPLEMENTATION (char_table);
4097 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4100 defsymbol (&Qcategory_table_p, "category-table-p");
4101 defsymbol (&Qcategory_designator_p, "category-designator-p");
4102 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4105 defsymbol (&Qchar_table, "char-table");
4106 defsymbol (&Qchar_tablep, "char-table-p");
4108 DEFSUBR (Fchar_table_p);
4109 DEFSUBR (Fchar_table_type_list);
4110 DEFSUBR (Fvalid_char_table_type_p);
4111 DEFSUBR (Fchar_table_type);
4112 DEFSUBR (Freset_char_table);
4113 DEFSUBR (Fmake_char_table);
4114 DEFSUBR (Fcopy_char_table);
4115 DEFSUBR (Fget_char_table);
4116 DEFSUBR (Fget_range_char_table);
4117 DEFSUBR (Fvalid_char_table_value_p);
4118 DEFSUBR (Fcheck_valid_char_table_value);
4119 DEFSUBR (Fput_char_table);
4120 DEFSUBR (Fmap_char_table);
4123 DEFSUBR (Fcategory_table_p);
4124 DEFSUBR (Fcategory_table);
4125 DEFSUBR (Fstandard_category_table);
4126 DEFSUBR (Fcopy_category_table);
4127 DEFSUBR (Fset_category_table);
4128 DEFSUBR (Fcheck_category_at);
4129 DEFSUBR (Fchar_in_category_p);
4130 DEFSUBR (Fcategory_designator_p);
4131 DEFSUBR (Fcategory_table_value_p);
4137 vars_of_chartab (void)
4140 staticpro (&Vcharacter_composition_table);
4141 Vcharacter_composition_table = make_char_id_table (Qnil);
4143 staticpro (&Vcharacter_variant_table);
4144 Vcharacter_variant_table = make_char_id_table (Qunbound);
4146 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4147 Vall_syntax_tables = Qnil;
4148 dump_add_weak_object_chain (&Vall_syntax_tables);
4152 structure_type_create_chartab (void)
4154 struct structure_type *st;
4156 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4158 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4159 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4163 complex_vars_of_chartab (void)
4166 staticpro (&Vchar_attribute_hash_table);
4167 Vchar_attribute_hash_table
4168 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4169 #ifdef HAVE_DATABASE
4170 Fputhash (Q_ucs_variants, Vcharacter_variant_table,
4171 Vchar_attribute_hash_table);
4172 XCHAR_TABLE_NAME (Vcharacter_variant_table) = Q_ucs_variants;
4173 #endif /* HAVE_DATABASE */
4174 #endif /* UTF2000 */
4176 /* Set this now, so first buffer creation can refer to it. */
4177 /* Make it nil before calling copy-category-table
4178 so that copy-category-table will know not to try to copy from garbage */
4179 Vstandard_category_table = Qnil;
4180 Vstandard_category_table = Fcopy_category_table (Qnil);
4181 staticpro (&Vstandard_category_table);
4183 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4184 List of pair (cons) of categories to determine word boundary.
4186 Emacs treats a sequence of word constituent characters as a single
4187 word (i.e. finds no word boundary between them) iff they belongs to
4188 the same charset. But, exceptions are allowed in the following cases.
4190 \(1) The case that characters are in different charsets is controlled
4191 by the variable `word-combining-categories'.
4193 Emacs finds no word boundary between characters of different charsets
4194 if they have categories matching some element of this list.
4196 More precisely, if an element of this list is a cons of category CAT1
4197 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4198 C2 which has CAT2, there's no word boundary between C1 and C2.
4200 For instance, to tell that ASCII characters and Latin-1 characters can
4201 form a single word, the element `(?l . ?l)' should be in this list
4202 because both characters have the category `l' (Latin characters).
4204 \(2) The case that character are in the same charset is controlled by
4205 the variable `word-separating-categories'.
4207 Emacs find a word boundary between characters of the same charset
4208 if they have categories matching some element of this list.
4210 More precisely, if an element of this list is a cons of category CAT1
4211 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4212 C2 which has CAT2, there's a word boundary between C1 and C2.
4214 For instance, to tell that there's a word boundary between Japanese
4215 Hiragana and Japanese Kanji (both are in the same charset), the
4216 element `(?H . ?C) should be in this list.
4219 Vword_combining_categories = Qnil;
4221 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4222 List of pair (cons) of categories to determine word boundary.
4223 See the documentation of the variable `word-combining-categories'.
4226 Vword_separating_categories = Qnil;