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);
1276 for (i = 0; i < NUM_ASCII_CHARS; i++)
1277 mark_object (ct->ascii[i]);
1279 for (i = 0; i < NUM_LEADING_BYTES; i++)
1280 mark_object (ct->level1[i]);
1284 return ct->default_value;
1286 return ct->mirror_table;
1290 /* WARNING: All functions of this nature need to be written extremely
1291 carefully to avoid crashes during GC. Cf. prune_specifiers()
1292 and prune_weak_hash_tables(). */
1295 prune_syntax_tables (void)
1297 Lisp_Object rest, prev = Qnil;
1299 for (rest = Vall_syntax_tables;
1301 rest = XCHAR_TABLE (rest)->next_table)
1303 if (! marked_p (rest))
1305 /* This table is garbage. Remove it from the list. */
1307 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1309 XCHAR_TABLE (prev)->next_table =
1310 XCHAR_TABLE (rest)->next_table;
1316 char_table_type_to_symbol (enum char_table_type type)
1321 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1322 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1323 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1324 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1326 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1331 static enum char_table_type
1332 symbol_to_char_table_type (Lisp_Object symbol)
1334 CHECK_SYMBOL (symbol);
1336 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1337 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1338 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1339 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1341 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1344 signal_simple_error ("Unrecognized char table type", symbol);
1345 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1349 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1350 Lisp_Object printcharfun)
1354 write_c_string (" (", printcharfun);
1355 print_internal (make_char (first), printcharfun, 0);
1356 write_c_string (" ", printcharfun);
1357 print_internal (make_char (last), printcharfun, 0);
1358 write_c_string (") ", printcharfun);
1362 write_c_string (" ", printcharfun);
1363 print_internal (make_char (first), printcharfun, 0);
1364 write_c_string (" ", printcharfun);
1366 print_internal (val, printcharfun, 1);
1369 #if defined(MULE)&&!defined(UTF2000)
1372 print_chartab_charset_row (Lisp_Object charset,
1374 Lisp_Char_Table_Entry *cte,
1375 Lisp_Object printcharfun)
1378 Lisp_Object cat = Qunbound;
1381 for (i = 32; i < 128; i++)
1383 Lisp_Object pam = cte->level2[i - 32];
1395 print_chartab_range (MAKE_CHAR (charset, first, 0),
1396 MAKE_CHAR (charset, i - 1, 0),
1399 print_chartab_range (MAKE_CHAR (charset, row, first),
1400 MAKE_CHAR (charset, row, i - 1),
1410 print_chartab_range (MAKE_CHAR (charset, first, 0),
1411 MAKE_CHAR (charset, i - 1, 0),
1414 print_chartab_range (MAKE_CHAR (charset, row, first),
1415 MAKE_CHAR (charset, row, i - 1),
1421 print_chartab_two_byte_charset (Lisp_Object charset,
1422 Lisp_Char_Table_Entry *cte,
1423 Lisp_Object printcharfun)
1427 for (i = 32; i < 128; i++)
1429 Lisp_Object jen = cte->level2[i - 32];
1431 if (!CHAR_TABLE_ENTRYP (jen))
1435 write_c_string (" [", printcharfun);
1436 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1437 sprintf (buf, " %d] ", i);
1438 write_c_string (buf, printcharfun);
1439 print_internal (jen, printcharfun, 0);
1442 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1450 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1452 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1455 struct gcpro gcpro1, gcpro2;
1456 GCPRO2 (obj, printcharfun);
1458 write_c_string ("#s(char-table ", printcharfun);
1459 write_c_string (" ", printcharfun);
1460 write_c_string (string_data
1462 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1464 write_c_string ("\n ", printcharfun);
1465 print_internal (ct->default_value, printcharfun, escapeflag);
1466 for (i = 0; i < 256; i++)
1468 Lisp_Object elt = get_byte_table (ct->table, i);
1469 if (i != 0) write_c_string ("\n ", printcharfun);
1470 if (EQ (elt, Qunbound))
1471 write_c_string ("void", printcharfun);
1473 print_internal (elt, printcharfun, escapeflag);
1476 #else /* non UTF2000 */
1479 sprintf (buf, "#s(char-table type %s data (",
1480 string_data (symbol_name (XSYMBOL
1481 (char_table_type_to_symbol (ct->type)))));
1482 write_c_string (buf, printcharfun);
1484 /* Now write out the ASCII/Control-1 stuff. */
1488 Lisp_Object val = Qunbound;
1490 for (i = 0; i < NUM_ASCII_CHARS; i++)
1499 if (!EQ (ct->ascii[i], val))
1501 print_chartab_range (first, i - 1, val, printcharfun);
1508 print_chartab_range (first, i - 1, val, printcharfun);
1515 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1518 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1519 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1521 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1522 || i == LEADING_BYTE_CONTROL_1)
1524 if (!CHAR_TABLE_ENTRYP (ann))
1526 write_c_string (" ", printcharfun);
1527 print_internal (XCHARSET_NAME (charset),
1529 write_c_string (" ", printcharfun);
1530 print_internal (ann, printcharfun, 0);
1534 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1535 if (XCHARSET_DIMENSION (charset) == 1)
1536 print_chartab_charset_row (charset, -1, cte, printcharfun);
1538 print_chartab_two_byte_charset (charset, cte, printcharfun);
1543 #endif /* non UTF2000 */
1545 write_c_string ("))", printcharfun);
1549 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1551 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1552 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1555 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1559 for (i = 0; i < 256; i++)
1561 if (!internal_equal (get_byte_table (ct1->table, i),
1562 get_byte_table (ct2->table, i), 0))
1566 for (i = 0; i < NUM_ASCII_CHARS; i++)
1567 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1571 for (i = 0; i < NUM_LEADING_BYTES; i++)
1572 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1575 #endif /* non UTF2000 */
1580 static unsigned long
1581 char_table_hash (Lisp_Object obj, int depth)
1583 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1585 return byte_table_hash (ct->table, depth + 1);
1587 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1590 hashval = HASH2 (hashval,
1591 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1597 static const struct lrecord_description char_table_description[] = {
1599 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1600 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1601 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) },
1603 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1605 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1609 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1611 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1615 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1616 mark_char_table, print_char_table, 0,
1617 char_table_equal, char_table_hash,
1618 char_table_description,
1621 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1622 Return non-nil if OBJECT is a char table.
1624 A char table is a table that maps characters (or ranges of characters)
1625 to values. Char tables are specialized for characters, only allowing
1626 particular sorts of ranges to be assigned values. Although this
1627 loses in generality, it makes for extremely fast (constant-time)
1628 lookups, and thus is feasible for applications that do an extremely
1629 large number of lookups (e.g. scanning a buffer for a character in
1630 a particular syntax, where a lookup in the syntax table must occur
1631 once per character).
1633 When Mule support exists, the types of ranges that can be assigned
1637 -- an entire charset
1638 -- a single row in a two-octet charset
1639 -- a single character
1641 When Mule support is not present, the types of ranges that can be
1645 -- a single character
1647 To create a char table, use `make-char-table'.
1648 To modify a char table, use `put-char-table' or `remove-char-table'.
1649 To retrieve the value for a particular character, use `get-char-table'.
1650 See also `map-char-table', `clear-char-table', `copy-char-table',
1651 `valid-char-table-type-p', `char-table-type-list',
1652 `valid-char-table-value-p', and `check-char-table-value'.
1656 return CHAR_TABLEP (object) ? Qt : Qnil;
1659 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1660 Return a list of the recognized char table types.
1661 See `valid-char-table-type-p'.
1666 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1668 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1672 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1673 Return t if TYPE if a recognized char table type.
1675 Each char table type is used for a different purpose and allows different
1676 sorts of values. The different char table types are
1679 Used for category tables, which specify the regexp categories
1680 that a character is in. The valid values are nil or a
1681 bit vector of 95 elements. Higher-level Lisp functions are
1682 provided for working with category tables. Currently categories
1683 and category tables only exist when Mule support is present.
1685 A generalized char table, for mapping from one character to
1686 another. Used for case tables, syntax matching tables,
1687 `keyboard-translate-table', etc. The valid values are characters.
1689 An even more generalized char table, for mapping from a
1690 character to anything.
1692 Used for display tables, which specify how a particular character
1693 is to appear when displayed. #### Not yet implemented.
1695 Used for syntax tables, which specify the syntax of a particular
1696 character. Higher-level Lisp functions are provided for
1697 working with syntax tables. The valid values are integers.
1702 return (EQ (type, Qchar) ||
1704 EQ (type, Qcategory) ||
1706 EQ (type, Qdisplay) ||
1707 EQ (type, Qgeneric) ||
1708 EQ (type, Qsyntax)) ? Qt : Qnil;
1711 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1712 Return the type of CHAR-TABLE.
1713 See `valid-char-table-type-p'.
1717 CHECK_CHAR_TABLE (char_table);
1718 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1722 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1725 ct->table = Qunbound;
1726 ct->default_value = value;
1731 for (i = 0; i < NUM_ASCII_CHARS; i++)
1732 ct->ascii[i] = value;
1734 for (i = 0; i < NUM_LEADING_BYTES; i++)
1735 ct->level1[i] = value;
1740 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1741 update_syntax_table (ct);
1745 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1746 Reset CHAR-TABLE to its default state.
1750 Lisp_Char_Table *ct;
1752 CHECK_CHAR_TABLE (char_table);
1753 ct = XCHAR_TABLE (char_table);
1757 case CHAR_TABLE_TYPE_CHAR:
1758 fill_char_table (ct, make_char (0));
1760 case CHAR_TABLE_TYPE_DISPLAY:
1761 case CHAR_TABLE_TYPE_GENERIC:
1763 case CHAR_TABLE_TYPE_CATEGORY:
1765 fill_char_table (ct, Qnil);
1768 case CHAR_TABLE_TYPE_SYNTAX:
1769 fill_char_table (ct, make_int (Sinherit));
1779 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1780 Return a new, empty char table of type TYPE.
1781 Currently recognized types are 'char, 'category, 'display, 'generic,
1782 and 'syntax. See `valid-char-table-type-p'.
1786 Lisp_Char_Table *ct;
1788 enum char_table_type ty = symbol_to_char_table_type (type);
1790 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1793 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1795 ct->mirror_table = Fmake_char_table (Qgeneric);
1796 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1800 ct->mirror_table = Qnil;
1804 ct->next_table = Qnil;
1805 XSETCHAR_TABLE (obj, ct);
1806 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1808 ct->next_table = Vall_syntax_tables;
1809 Vall_syntax_tables = obj;
1811 Freset_char_table (obj);
1815 #if defined(MULE)&&!defined(UTF2000)
1818 make_char_table_entry (Lisp_Object initval)
1822 Lisp_Char_Table_Entry *cte =
1823 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1825 for (i = 0; i < 96; i++)
1826 cte->level2[i] = initval;
1828 XSETCHAR_TABLE_ENTRY (obj, cte);
1833 copy_char_table_entry (Lisp_Object entry)
1835 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1838 Lisp_Char_Table_Entry *ctenew =
1839 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1841 for (i = 0; i < 96; i++)
1843 Lisp_Object new = cte->level2[i];
1844 if (CHAR_TABLE_ENTRYP (new))
1845 ctenew->level2[i] = copy_char_table_entry (new);
1847 ctenew->level2[i] = new;
1850 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1856 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1857 Return a new char table which is a copy of CHAR-TABLE.
1858 It will contain the same values for the same characters and ranges
1859 as CHAR-TABLE. The values will not themselves be copied.
1863 Lisp_Char_Table *ct, *ctnew;
1869 CHECK_CHAR_TABLE (char_table);
1870 ct = XCHAR_TABLE (char_table);
1871 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1872 ctnew->type = ct->type;
1874 ctnew->default_value = ct->default_value;
1875 /* [tomo:2002-01-21] Perhaps this code seems wrong */
1876 ctnew->name = ct->name;
1878 if (UINT8_BYTE_TABLE_P (ct->table))
1880 ctnew->table = copy_uint8_byte_table (ct->table);
1882 else if (UINT16_BYTE_TABLE_P (ct->table))
1884 ctnew->table = copy_uint16_byte_table (ct->table);
1886 else if (BYTE_TABLE_P (ct->table))
1888 ctnew->table = copy_byte_table (ct->table);
1890 else if (!UNBOUNDP (ct->table))
1891 ctnew->table = ct->table;
1892 #else /* non UTF2000 */
1894 for (i = 0; i < NUM_ASCII_CHARS; i++)
1896 Lisp_Object new = ct->ascii[i];
1898 assert (! (CHAR_TABLE_ENTRYP (new)));
1900 ctnew->ascii[i] = new;
1905 for (i = 0; i < NUM_LEADING_BYTES; i++)
1907 Lisp_Object new = ct->level1[i];
1908 if (CHAR_TABLE_ENTRYP (new))
1909 ctnew->level1[i] = copy_char_table_entry (new);
1911 ctnew->level1[i] = new;
1915 #endif /* non UTF2000 */
1918 if (CHAR_TABLEP (ct->mirror_table))
1919 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1921 ctnew->mirror_table = ct->mirror_table;
1923 ctnew->next_table = Qnil;
1924 XSETCHAR_TABLE (obj, ctnew);
1925 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1927 ctnew->next_table = Vall_syntax_tables;
1928 Vall_syntax_tables = obj;
1933 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1935 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1937 switch (XCHARSET_CHARS (ccs))
1940 return (33 << 8) | 126;
1942 return (32 << 8) | 127;
1945 return (0 << 8) | 127;
1947 return (0 << 8) | 255;
1959 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1962 outrange->type = CHARTAB_RANGE_ALL;
1963 else if (EQ (range, Qnil))
1964 outrange->type = CHARTAB_RANGE_DEFAULT;
1965 else if (CHAR_OR_CHAR_INTP (range))
1967 outrange->type = CHARTAB_RANGE_CHAR;
1968 outrange->ch = XCHAR_OR_CHAR_INT (range);
1972 signal_simple_error ("Range must be t or a character", range);
1974 else if (VECTORP (range))
1976 Lisp_Vector *vec = XVECTOR (range);
1977 Lisp_Object *elts = vector_data (vec);
1978 int cell_min, cell_max;
1980 outrange->type = CHARTAB_RANGE_ROW;
1981 outrange->charset = Fget_charset (elts[0]);
1982 CHECK_INT (elts[1]);
1983 outrange->row = XINT (elts[1]);
1984 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1985 signal_simple_error ("Charset in row vector must be multi-byte",
1989 int ret = XCHARSET_CELL_RANGE (outrange->charset);
1991 cell_min = ret >> 8;
1992 cell_max = ret & 0xFF;
1994 if (XCHARSET_DIMENSION (outrange->charset) == 2)
1995 check_int_range (outrange->row, cell_min, cell_max);
1997 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
1999 check_int_range (outrange->row >> 8 , cell_min, cell_max);
2000 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
2002 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
2004 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
2005 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
2006 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
2014 if (!CHARSETP (range) && !SYMBOLP (range))
2016 ("Char table range must be t, charset, char, or vector", range);
2017 outrange->type = CHARTAB_RANGE_CHARSET;
2018 outrange->charset = Fget_charset (range);
2023 #if defined(MULE)&&!defined(UTF2000)
2025 /* called from CHAR_TABLE_VALUE(). */
2027 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
2032 Lisp_Object charset;
2034 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
2039 BREAKUP_CHAR (c, charset, byte1, byte2);
2041 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
2043 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
2044 if (CHAR_TABLE_ENTRYP (val))
2046 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2047 val = cte->level2[byte1 - 32];
2048 if (CHAR_TABLE_ENTRYP (val))
2050 cte = XCHAR_TABLE_ENTRY (val);
2051 assert (byte2 >= 32);
2052 val = cte->level2[byte2 - 32];
2053 assert (!CHAR_TABLE_ENTRYP (val));
2063 get_char_table (Emchar ch, Lisp_Char_Table *ct)
2066 return get_char_id_table (ct, ch);
2069 Lisp_Object charset;
2073 BREAKUP_CHAR (ch, charset, byte1, byte2);
2075 if (EQ (charset, Vcharset_ascii))
2076 val = ct->ascii[byte1];
2077 else if (EQ (charset, Vcharset_control_1))
2078 val = ct->ascii[byte1 + 128];
2081 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2082 val = ct->level1[lb];
2083 if (CHAR_TABLE_ENTRYP (val))
2085 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2086 val = cte->level2[byte1 - 32];
2087 if (CHAR_TABLE_ENTRYP (val))
2089 cte = XCHAR_TABLE_ENTRY (val);
2090 assert (byte2 >= 32);
2091 val = cte->level2[byte2 - 32];
2092 assert (!CHAR_TABLE_ENTRYP (val));
2099 #else /* not MULE */
2100 return ct->ascii[(unsigned char)ch];
2101 #endif /* not MULE */
2105 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
2106 Find value for CHARACTER in CHAR-TABLE.
2108 (character, char_table))
2110 CHECK_CHAR_TABLE (char_table);
2111 CHECK_CHAR_COERCE_INT (character);
2113 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
2116 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
2117 Find value for a range in CHAR-TABLE.
2118 If there is more than one value, return MULTI (defaults to nil).
2120 (range, char_table, multi))
2122 Lisp_Char_Table *ct;
2123 struct chartab_range rainj;
2125 if (CHAR_OR_CHAR_INTP (range))
2126 return Fget_char_table (range, char_table);
2127 CHECK_CHAR_TABLE (char_table);
2128 ct = XCHAR_TABLE (char_table);
2130 decode_char_table_range (range, &rainj);
2133 case CHARTAB_RANGE_ALL:
2136 if (UINT8_BYTE_TABLE_P (ct->table))
2138 else if (UINT16_BYTE_TABLE_P (ct->table))
2140 else if (BYTE_TABLE_P (ct->table))
2144 #else /* non UTF2000 */
2146 Lisp_Object first = ct->ascii[0];
2148 for (i = 1; i < NUM_ASCII_CHARS; i++)
2149 if (!EQ (first, ct->ascii[i]))
2153 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2156 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2157 || i == LEADING_BYTE_ASCII
2158 || i == LEADING_BYTE_CONTROL_1)
2160 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2166 #endif /* non UTF2000 */
2170 case CHARTAB_RANGE_CHARSET:
2174 if (EQ (rainj.charset, Vcharset_ascii))
2177 Lisp_Object first = ct->ascii[0];
2179 for (i = 1; i < 128; i++)
2180 if (!EQ (first, ct->ascii[i]))
2185 if (EQ (rainj.charset, Vcharset_control_1))
2188 Lisp_Object first = ct->ascii[128];
2190 for (i = 129; i < 160; i++)
2191 if (!EQ (first, ct->ascii[i]))
2197 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2199 if (CHAR_TABLE_ENTRYP (val))
2205 case CHARTAB_RANGE_ROW:
2210 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2212 if (!CHAR_TABLE_ENTRYP (val))
2214 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2215 if (CHAR_TABLE_ENTRYP (val))
2219 #endif /* not UTF2000 */
2220 #endif /* not MULE */
2226 return Qnil; /* not reached */
2230 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2231 Error_behavior errb)
2235 case CHAR_TABLE_TYPE_SYNTAX:
2236 if (!ERRB_EQ (errb, ERROR_ME))
2237 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2238 && CHAR_OR_CHAR_INTP (XCDR (value)));
2241 Lisp_Object cdr = XCDR (value);
2242 CHECK_INT (XCAR (value));
2243 CHECK_CHAR_COERCE_INT (cdr);
2250 case CHAR_TABLE_TYPE_CATEGORY:
2251 if (!ERRB_EQ (errb, ERROR_ME))
2252 return CATEGORY_TABLE_VALUEP (value);
2253 CHECK_CATEGORY_TABLE_VALUE (value);
2257 case CHAR_TABLE_TYPE_GENERIC:
2260 case CHAR_TABLE_TYPE_DISPLAY:
2262 maybe_signal_simple_error ("Display char tables not yet implemented",
2263 value, Qchar_table, errb);
2266 case CHAR_TABLE_TYPE_CHAR:
2267 if (!ERRB_EQ (errb, ERROR_ME))
2268 return CHAR_OR_CHAR_INTP (value);
2269 CHECK_CHAR_COERCE_INT (value);
2276 return 0; /* not reached */
2280 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2284 case CHAR_TABLE_TYPE_SYNTAX:
2287 Lisp_Object car = XCAR (value);
2288 Lisp_Object cdr = XCDR (value);
2289 CHECK_CHAR_COERCE_INT (cdr);
2290 return Fcons (car, cdr);
2293 case CHAR_TABLE_TYPE_CHAR:
2294 CHECK_CHAR_COERCE_INT (value);
2302 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2303 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2305 (value, char_table_type))
2307 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2309 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2312 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2313 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2315 (value, char_table_type))
2317 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2319 check_valid_char_table_value (value, type, ERROR_ME);
2324 Lisp_Char_Table* char_attribute_table_to_put;
2325 Lisp_Object Qput_char_table_map_function;
2326 Lisp_Object value_to_put;
2328 DEFUN ("put-char-table-map-function",
2329 Fput_char_table_map_function, 2, 2, 0, /*
2330 For internal use. Don't use it.
2334 put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put);
2339 /* Assign VAL to all characters in RANGE in char table CT. */
2342 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2345 switch (range->type)
2347 case CHARTAB_RANGE_ALL:
2348 /* printf ("put-char-table: range = all\n"); */
2349 fill_char_table (ct, val);
2350 return; /* avoid the duplicate call to update_syntax_table() below,
2351 since fill_char_table() also did that. */
2354 case CHARTAB_RANGE_DEFAULT:
2355 ct->default_value = val;
2360 case CHARTAB_RANGE_CHARSET:
2364 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2366 /* printf ("put-char-table: range = charset: %d\n",
2367 XCHARSET_LEADING_BYTE (range->charset));
2369 if ( CHAR_TABLEP (encoding_table) )
2372 char_attribute_table_to_put = ct;
2374 Fmap_char_attribute (Qput_char_table_map_function,
2375 XCHAR_TABLE_NAME (encoding_table),
2378 for (c = 0; c < 1 << 24; c++)
2380 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2382 put_char_id_table_0 (ct, c, val);
2388 for (c = 0; c < 1 << 24; c++)
2390 if ( charset_code_point (range->charset, c) >= 0 )
2391 put_char_id_table_0 (ct, c, val);
2396 if (EQ (range->charset, Vcharset_ascii))
2399 for (i = 0; i < 128; i++)
2402 else if (EQ (range->charset, Vcharset_control_1))
2405 for (i = 128; i < 160; i++)
2410 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2411 ct->level1[lb] = val;
2416 case CHARTAB_RANGE_ROW:
2419 int cell_min, cell_max, i;
2421 i = XCHARSET_CELL_RANGE (range->charset);
2423 cell_max = i & 0xFF;
2424 for (i = cell_min; i <= cell_max; i++)
2426 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2428 if ( charset_code_point (range->charset, ch) >= 0 )
2429 put_char_id_table_0 (ct, ch, val);
2434 Lisp_Char_Table_Entry *cte;
2435 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2436 /* make sure that there is a separate entry for the row. */
2437 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2438 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2439 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2440 cte->level2[range->row - 32] = val;
2442 #endif /* not UTF2000 */
2446 case CHARTAB_RANGE_CHAR:
2448 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2449 put_char_id_table_0 (ct, range->ch, val);
2453 Lisp_Object charset;
2456 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2457 if (EQ (charset, Vcharset_ascii))
2458 ct->ascii[byte1] = val;
2459 else if (EQ (charset, Vcharset_control_1))
2460 ct->ascii[byte1 + 128] = val;
2463 Lisp_Char_Table_Entry *cte;
2464 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2465 /* make sure that there is a separate entry for the row. */
2466 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2467 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2468 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2469 /* now CTE is a char table entry for the charset;
2470 each entry is for a single row (or character of
2471 a one-octet charset). */
2472 if (XCHARSET_DIMENSION (charset) == 1)
2473 cte->level2[byte1 - 32] = val;
2476 /* assigning to one character in a two-octet charset. */
2477 /* make sure that the charset row contains a separate
2478 entry for each character. */
2479 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2480 cte->level2[byte1 - 32] =
2481 make_char_table_entry (cte->level2[byte1 - 32]);
2482 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2483 cte->level2[byte2 - 32] = val;
2487 #else /* not MULE */
2488 ct->ascii[(unsigned char) (range->ch)] = val;
2490 #endif /* not MULE */
2494 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2495 update_syntax_table (ct);
2499 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2500 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2502 RANGE specifies one or more characters to be affected and should be
2503 one of the following:
2505 -- t (all characters are affected)
2506 -- A charset (only allowed when Mule support is present)
2507 -- A vector of two elements: a two-octet charset and a row number
2508 (only allowed when Mule support is present)
2509 -- A single character
2511 VALUE must be a value appropriate for the type of CHAR-TABLE.
2512 See `valid-char-table-type-p'.
2514 (range, value, char_table))
2516 Lisp_Char_Table *ct;
2517 struct chartab_range rainj;
2519 CHECK_CHAR_TABLE (char_table);
2520 ct = XCHAR_TABLE (char_table);
2521 check_valid_char_table_value (value, ct->type, ERROR_ME);
2522 decode_char_table_range (range, &rainj);
2523 value = canonicalize_char_table_value (value, ct->type);
2524 put_char_table (ct, &rainj, value);
2529 /* Map FN over the ASCII chars in CT. */
2532 map_over_charset_ascii (Lisp_Char_Table *ct,
2533 int (*fn) (struct chartab_range *range,
2534 Lisp_Object val, void *arg),
2537 struct chartab_range rainj;
2546 rainj.type = CHARTAB_RANGE_CHAR;
2548 for (i = start, retval = 0; i < stop && retval == 0; i++)
2550 rainj.ch = (Emchar) i;
2551 retval = (fn) (&rainj, ct->ascii[i], arg);
2559 /* Map FN over the Control-1 chars in CT. */
2562 map_over_charset_control_1 (Lisp_Char_Table *ct,
2563 int (*fn) (struct chartab_range *range,
2564 Lisp_Object val, void *arg),
2567 struct chartab_range rainj;
2570 int stop = start + 32;
2572 rainj.type = CHARTAB_RANGE_CHAR;
2574 for (i = start, retval = 0; i < stop && retval == 0; i++)
2576 rainj.ch = (Emchar) (i);
2577 retval = (fn) (&rainj, ct->ascii[i], arg);
2583 /* Map FN over the row ROW of two-byte charset CHARSET.
2584 There must be a separate value for that row in the char table.
2585 CTE specifies the char table entry for CHARSET. */
2588 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2589 Lisp_Object charset, int row,
2590 int (*fn) (struct chartab_range *range,
2591 Lisp_Object val, void *arg),
2594 Lisp_Object val = cte->level2[row - 32];
2596 if (!CHAR_TABLE_ENTRYP (val))
2598 struct chartab_range rainj;
2600 rainj.type = CHARTAB_RANGE_ROW;
2601 rainj.charset = charset;
2603 return (fn) (&rainj, val, arg);
2607 struct chartab_range rainj;
2609 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2610 int start = charset94_p ? 33 : 32;
2611 int stop = charset94_p ? 127 : 128;
2613 cte = XCHAR_TABLE_ENTRY (val);
2615 rainj.type = CHARTAB_RANGE_CHAR;
2617 for (i = start, retval = 0; i < stop && retval == 0; i++)
2619 rainj.ch = MAKE_CHAR (charset, row, i);
2620 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2628 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2629 int (*fn) (struct chartab_range *range,
2630 Lisp_Object val, void *arg),
2633 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2634 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2636 if (!CHARSETP (charset)
2637 || lb == LEADING_BYTE_ASCII
2638 || lb == LEADING_BYTE_CONTROL_1)
2641 if (!CHAR_TABLE_ENTRYP (val))
2643 struct chartab_range rainj;
2645 rainj.type = CHARTAB_RANGE_CHARSET;
2646 rainj.charset = charset;
2647 return (fn) (&rainj, val, arg);
2651 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2652 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2653 int start = charset94_p ? 33 : 32;
2654 int stop = charset94_p ? 127 : 128;
2657 if (XCHARSET_DIMENSION (charset) == 1)
2659 struct chartab_range rainj;
2660 rainj.type = CHARTAB_RANGE_CHAR;
2662 for (i = start, retval = 0; i < stop && retval == 0; i++)
2664 rainj.ch = MAKE_CHAR (charset, i, 0);
2665 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2670 for (i = start, retval = 0; i < stop && retval == 0; i++)
2671 retval = map_over_charset_row (cte, charset, i, fn, arg);
2679 #endif /* not UTF2000 */
2682 struct map_char_table_for_charset_arg
2684 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2685 Lisp_Char_Table *ct;
2690 map_char_table_for_charset_fun (struct chartab_range *range,
2691 Lisp_Object val, void *arg)
2693 struct map_char_table_for_charset_arg *closure =
2694 (struct map_char_table_for_charset_arg *) arg;
2697 switch (range->type)
2699 case CHARTAB_RANGE_ALL:
2702 case CHARTAB_RANGE_DEFAULT:
2705 case CHARTAB_RANGE_CHARSET:
2708 case CHARTAB_RANGE_ROW:
2711 case CHARTAB_RANGE_CHAR:
2712 ret = get_char_table (range->ch, closure->ct);
2713 if (!UNBOUNDP (ret))
2714 return (closure->fn) (range, ret, closure->arg);
2724 #if defined(HAVE_DATABASE)
2725 EXFUN (Fload_char_attribute_table, 1);
2730 /* Map FN (with client data ARG) over range RANGE in char table CT.
2731 Mapping stops the first time FN returns non-zero, and that value
2732 becomes the return value of map_char_table(). */
2735 map_char_table (Lisp_Char_Table *ct,
2736 struct chartab_range *range,
2737 int (*fn) (struct chartab_range *range,
2738 Lisp_Object val, void *arg),
2741 switch (range->type)
2743 case CHARTAB_RANGE_ALL:
2745 if (!UNBOUNDP (ct->default_value))
2747 struct chartab_range rainj;
2750 rainj.type = CHARTAB_RANGE_DEFAULT;
2751 retval = (fn) (&rainj, ct->default_value, arg);
2755 if (UINT8_BYTE_TABLE_P (ct->table))
2756 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct,
2758 else if (UINT16_BYTE_TABLE_P (ct->table))
2759 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct,
2761 else if (BYTE_TABLE_P (ct->table))
2762 return map_over_byte_table (XBYTE_TABLE(ct->table), ct,
2764 else if (EQ (ct->table, Qunloaded))
2767 struct chartab_range rainj;
2770 Emchar c1 = c + unit;
2773 rainj.type = CHARTAB_RANGE_CHAR;
2775 for (retval = 0; c < c1 && retval == 0; c++)
2777 Lisp_Object ret = get_char_id_table (ct, c);
2779 if (!UNBOUNDP (ret))
2782 retval = (fn) (&rainj, ct->table, arg);
2787 ct->table = Qunbound;
2790 else if (!UNBOUNDP (ct->table))
2791 return (fn) (range, ct->table, arg);
2797 retval = map_over_charset_ascii (ct, fn, arg);
2801 retval = map_over_charset_control_1 (ct, fn, arg);
2806 Charset_ID start = MIN_LEADING_BYTE;
2807 Charset_ID stop = start + NUM_LEADING_BYTES;
2809 for (i = start, retval = 0; i < stop && retval == 0; i++)
2811 retval = map_over_other_charset (ct, i, fn, arg);
2820 case CHARTAB_RANGE_DEFAULT:
2821 if (!UNBOUNDP (ct->default_value))
2822 return (fn) (range, ct->default_value, arg);
2827 case CHARTAB_RANGE_CHARSET:
2830 Lisp_Object encoding_table
2831 = XCHARSET_ENCODING_TABLE (range->charset);
2833 if (!NILP (encoding_table))
2835 struct chartab_range rainj;
2836 struct map_char_table_for_charset_arg mcarg;
2838 #ifdef HAVE_DATABASE
2839 if (XCHAR_TABLE_UNLOADED(encoding_table))
2840 Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table));
2845 rainj.type = CHARTAB_RANGE_ALL;
2846 return map_char_table (XCHAR_TABLE(encoding_table),
2848 &map_char_table_for_charset_fun,
2854 return map_over_other_charset (ct,
2855 XCHARSET_LEADING_BYTE (range->charset),
2859 case CHARTAB_RANGE_ROW:
2862 int cell_min, cell_max, i;
2864 struct chartab_range rainj;
2866 i = XCHARSET_CELL_RANGE (range->charset);
2868 cell_max = i & 0xFF;
2869 rainj.type = CHARTAB_RANGE_CHAR;
2870 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2872 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2874 if ( charset_code_point (range->charset, ch) >= 0 )
2877 = get_byte_table (get_byte_table
2881 (unsigned char)(ch >> 24)),
2882 (unsigned char) (ch >> 16)),
2883 (unsigned char) (ch >> 8)),
2884 (unsigned char) ch);
2887 val = ct->default_value;
2889 retval = (fn) (&rainj, val, arg);
2896 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2897 - MIN_LEADING_BYTE];
2898 if (!CHAR_TABLE_ENTRYP (val))
2900 struct chartab_range rainj;
2902 rainj.type = CHARTAB_RANGE_ROW;
2903 rainj.charset = range->charset;
2904 rainj.row = range->row;
2905 return (fn) (&rainj, val, arg);
2908 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2909 range->charset, range->row,
2912 #endif /* not UTF2000 */
2915 case CHARTAB_RANGE_CHAR:
2917 Emchar ch = range->ch;
2918 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2920 if (!UNBOUNDP (val))
2922 struct chartab_range rainj;
2924 rainj.type = CHARTAB_RANGE_CHAR;
2926 return (fn) (&rainj, val, arg);
2938 struct slow_map_char_table_arg
2940 Lisp_Object function;
2945 slow_map_char_table_fun (struct chartab_range *range,
2946 Lisp_Object val, void *arg)
2948 Lisp_Object ranjarg = Qnil;
2949 struct slow_map_char_table_arg *closure =
2950 (struct slow_map_char_table_arg *) arg;
2952 switch (range->type)
2954 case CHARTAB_RANGE_ALL:
2959 case CHARTAB_RANGE_DEFAULT:
2965 case CHARTAB_RANGE_CHARSET:
2966 ranjarg = XCHARSET_NAME (range->charset);
2969 case CHARTAB_RANGE_ROW:
2970 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2971 make_int (range->row));
2974 case CHARTAB_RANGE_CHAR:
2975 ranjarg = make_char (range->ch);
2981 closure->retval = call2 (closure->function, ranjarg, val);
2982 return !NILP (closure->retval);
2985 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2986 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2987 each key and value in the table.
2989 RANGE specifies a subrange to map over and is in the same format as
2990 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2993 (function, char_table, range))
2995 Lisp_Char_Table *ct;
2996 struct slow_map_char_table_arg slarg;
2997 struct gcpro gcpro1, gcpro2;
2998 struct chartab_range rainj;
3000 CHECK_CHAR_TABLE (char_table);
3001 ct = XCHAR_TABLE (char_table);
3004 decode_char_table_range (range, &rainj);
3005 slarg.function = function;
3006 slarg.retval = Qnil;
3007 GCPRO2 (slarg.function, slarg.retval);
3008 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3011 return slarg.retval;
3015 /************************************************************************/
3016 /* Character Attributes */
3017 /************************************************************************/
3021 Lisp_Object Vchar_attribute_hash_table;
3023 /* We store the char-attributes in hash tables with the names as the
3024 key and the actual char-id-table object as the value. Occasionally
3025 we need to use them in a list format. These routines provide us
3027 struct char_attribute_list_closure
3029 Lisp_Object *char_attribute_list;
3033 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
3034 void *char_attribute_list_closure)
3036 /* This function can GC */
3037 struct char_attribute_list_closure *calcl
3038 = (struct char_attribute_list_closure*) char_attribute_list_closure;
3039 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
3041 *char_attribute_list = Fcons (key, *char_attribute_list);
3045 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
3046 Return the list of all existing character attributes except coded-charsets.
3050 Lisp_Object char_attribute_list = Qnil;
3051 struct gcpro gcpro1;
3052 struct char_attribute_list_closure char_attribute_list_closure;
3054 GCPRO1 (char_attribute_list);
3055 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
3056 elisp_maphash (add_char_attribute_to_list_mapper,
3057 Vchar_attribute_hash_table,
3058 &char_attribute_list_closure);
3060 return char_attribute_list;
3063 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
3064 Return char-id-table corresponding to ATTRIBUTE.
3068 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
3072 /* We store the char-id-tables in hash tables with the attributes as
3073 the key and the actual char-id-table object as the value. Each
3074 char-id-table stores values of an attribute corresponding with
3075 characters. Occasionally we need to get attributes of a character
3076 in a association-list format. These routines provide us with
3078 struct char_attribute_alist_closure
3081 Lisp_Object *char_attribute_alist;
3085 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
3086 void *char_attribute_alist_closure)
3088 /* This function can GC */
3089 struct char_attribute_alist_closure *caacl =
3090 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
3092 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
3093 if (!UNBOUNDP (ret))
3095 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
3096 *char_attribute_alist
3097 = Fcons (Fcons (key, ret), *char_attribute_alist);
3102 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
3103 Return the alist of attributes of CHARACTER.
3107 struct gcpro gcpro1;
3108 struct char_attribute_alist_closure char_attribute_alist_closure;
3109 Lisp_Object alist = Qnil;
3111 CHECK_CHAR (character);
3114 char_attribute_alist_closure.char_id = XCHAR (character);
3115 char_attribute_alist_closure.char_attribute_alist = &alist;
3116 elisp_maphash (add_char_attribute_alist_mapper,
3117 Vchar_attribute_hash_table,
3118 &char_attribute_alist_closure);
3124 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
3125 Return the value of CHARACTER's ATTRIBUTE.
3126 Return DEFAULT-VALUE if the value is not exist.
3128 (character, attribute, default_value))
3132 CHECK_CHAR (character);
3134 if (CHARSETP (attribute))
3135 attribute = XCHARSET_NAME (attribute);
3137 table = Fgethash (attribute, Vchar_attribute_hash_table,
3139 if (!UNBOUNDP (table))
3141 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
3143 if (!UNBOUNDP (ret))
3146 return default_value;
3149 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
3150 Store CHARACTER's ATTRIBUTE with VALUE.
3152 (character, attribute, value))
3154 Lisp_Object ccs = Ffind_charset (attribute);
3158 CHECK_CHAR (character);
3159 value = put_char_ccs_code_point (character, ccs, value);
3161 else if (EQ (attribute, Q_decomposition))
3165 CHECK_CHAR (character);
3167 signal_simple_error ("Invalid value for ->decomposition",
3170 if (CONSP (Fcdr (value)))
3172 Lisp_Object rest = value;
3173 Lisp_Object table = Vcharacter_composition_table;
3177 GET_EXTERNAL_LIST_LENGTH (rest, len);
3178 seq = make_vector (len, Qnil);
3180 while (CONSP (rest))
3182 Lisp_Object v = Fcar (rest);
3185 = to_char_id (v, "Invalid value for ->decomposition", value);
3188 XVECTOR_DATA(seq)[i++] = v;
3190 XVECTOR_DATA(seq)[i++] = make_char (c);
3194 put_char_id_table (XCHAR_TABLE(table),
3195 make_char (c), character);
3200 ntable = get_char_id_table (XCHAR_TABLE(table), c);
3201 if (!CHAR_TABLEP (ntable))
3203 ntable = make_char_id_table (Qnil);
3204 put_char_id_table (XCHAR_TABLE(table),
3205 make_char (c), ntable);
3213 Lisp_Object v = Fcar (value);
3217 Emchar c = XINT (v);
3219 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3224 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3225 make_char (c), Fcons (character, Qnil));
3227 else if (NILP (Fmemq (v, ret)))
3229 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3230 make_char (c), Fcons (character, ret));
3233 seq = make_vector (1, v);
3237 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
3242 CHECK_CHAR (character);
3244 signal_simple_error ("Invalid value for ->ucs", value);
3248 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
3251 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3252 make_char (c), Fcons (character, Qnil));
3254 else if (NILP (Fmemq (character, ret)))
3256 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
3257 make_char (c), Fcons (character, ret));
3260 if (EQ (attribute, Q_ucs))
3261 attribute = Qto_ucs;
3265 Lisp_Object table = Fgethash (attribute,
3266 Vchar_attribute_hash_table,
3271 table = make_char_id_table (Qunbound);
3272 Fputhash (attribute, table, Vchar_attribute_hash_table);
3273 #ifdef HAVE_DATABASE
3274 XCHAR_TABLE_NAME (table) = attribute;
3277 put_char_id_table (XCHAR_TABLE(table), character, value);
3282 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3283 Remove CHARACTER's ATTRIBUTE.
3285 (character, attribute))
3289 CHECK_CHAR (character);
3290 ccs = Ffind_charset (attribute);
3293 return remove_char_ccs (character, ccs);
3297 Lisp_Object table = Fgethash (attribute,
3298 Vchar_attribute_hash_table,
3300 if (!UNBOUNDP (table))
3302 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3310 char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute,
3313 Lisp_Object db_dir = Vexec_directory;
3316 db_dir = build_string ("../lib-src");
3318 db_dir = Fexpand_file_name (build_string ("char-db"), db_dir);
3319 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3320 Fmake_directory_internal (db_dir);
3322 db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir);
3323 if (writing_mode && NILP (Ffile_exists_p (db_dir)))
3324 Fmake_directory_internal (db_dir);
3327 Lisp_Object attribute_name = Fsymbol_name (attribute);
3328 Lisp_Object dest = Qnil, ret;
3330 struct gcpro gcpro1, gcpro2;
3331 int len = XSTRING_CHAR_LENGTH (attribute_name);
3335 for (i = 0; i < len; i++)
3337 Emchar c = string_char (XSTRING (attribute_name), i);
3339 if ( (c == '/') || (c == '%') )
3343 sprintf (str, "%%%02X", c);
3344 dest = concat3 (dest,
3345 Fsubstring (attribute_name,
3346 make_int (base), make_int (i)),
3347 build_string (str));
3351 ret = Fsubstring (attribute_name, make_int (base), make_int (len));
3352 dest = concat2 (dest, ret);
3354 return Fexpand_file_name (dest, db_dir);
3357 return Fexpand_file_name (Fsymbol_name (attribute), db_dir);
3361 DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /*
3362 Save values of ATTRIBUTE into database file.
3366 #ifdef HAVE_DATABASE
3367 Lisp_Object table = Fgethash (attribute,
3368 Vchar_attribute_hash_table, Qunbound);
3369 Lisp_Char_Table *ct;
3371 Lisp_Object db_file;
3373 if (CHAR_TABLEP (table))
3374 ct = XCHAR_TABLE (table);
3378 db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1);
3379 db = Fopen_database (db_file, Qnil, Qnil, Qnil, Qnil);
3382 if (UINT8_BYTE_TABLE_P (ct->table))
3383 save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db, 0, 3);
3384 else if (UINT16_BYTE_TABLE_P (ct->table))
3385 save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db, 0, 3);
3386 else if (BYTE_TABLE_P (ct->table))
3387 save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3);
3388 Fclose_database (db);
3398 DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /*
3399 Reset values of ATTRIBUTE with database file.
3403 #ifdef HAVE_DATABASE
3404 Lisp_Object table = Fgethash (attribute,
3405 Vchar_attribute_hash_table, Qunbound);
3406 Lisp_Char_Table *ct;
3408 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3410 if (!NILP (Ffile_exists_p (db_file)))
3412 if (UNBOUNDP (table))
3414 table = make_char_id_table (Qunbound);
3415 Fputhash (attribute, table, Vchar_attribute_hash_table);
3416 XCHAR_TABLE_NAME(table) = attribute;
3418 ct = XCHAR_TABLE (table);
3419 ct->table = Qunloaded;
3420 XCHAR_TABLE_UNLOADED(table) = 1;
3427 #ifdef HAVE_DATABASE
3429 load_char_attribute_maybe (Emchar ch, Lisp_Object attribute)
3433 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3435 db = Fopen_database (db_file, Qnil, Qnil, Qnil, Qnil);
3439 = Fget_database (Fprin1_to_string (make_char (ch), Qnil),
3441 if (!UNBOUNDP (val))
3445 Fclose_database (db);
3452 Lisp_Char_Table* char_attribute_table_to_load;
3454 Lisp_Object Qload_char_attribute_table_map_function;
3456 DEFUN ("load-char-attribute-table-map-function",
3457 Fload_char_attribute_table_map_function, 2, 2, 0, /*
3458 For internal use. Don't use it.
3462 Lisp_Object c = Fread (key);
3463 Emchar code = XCHAR (c);
3464 Lisp_Object ret = get_char_id_table (char_attribute_table_to_load, code);
3466 if (EQ (ret, Qunloaded))
3467 put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value));
3472 DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /*
3473 Load values of ATTRIBUTE into database file.
3477 #ifdef HAVE_DATABASE
3480 = char_attribute_system_db_file (Qsystem_char_id, attribute, 0);
3482 db = Fopen_database (db_file, Qnil, Qnil, Qnil, Qnil);
3485 Lisp_Object table = Fgethash (attribute,
3486 Vchar_attribute_hash_table,
3488 struct gcpro gcpro1, gcpro2;
3490 if (CHAR_TABLEP (table))
3491 char_attribute_table_to_load = XCHAR_TABLE (table);
3494 Fclose_database (db);
3498 Fmap_database (Qload_char_attribute_table_map_function, db);
3500 Fclose_database (db);
3501 XCHAR_TABLE_UNLOADED(table) = 0;
3509 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3510 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3511 each key and value in the table.
3513 RANGE specifies a subrange to map over and is in the same format as
3514 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3517 (function, attribute, range))
3520 Lisp_Char_Table *ct;
3521 struct slow_map_char_table_arg slarg;
3522 struct gcpro gcpro1, gcpro2;
3523 struct chartab_range rainj;
3525 if (!NILP (ccs = Ffind_charset (attribute)))
3527 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3529 if (CHAR_TABLEP (encoding_table))
3530 ct = XCHAR_TABLE (encoding_table);
3536 Lisp_Object table = Fgethash (attribute,
3537 Vchar_attribute_hash_table,
3539 if (CHAR_TABLEP (table))
3540 ct = XCHAR_TABLE (table);
3546 decode_char_table_range (range, &rainj);
3547 #ifdef HAVE_DATABASE
3548 if (CHAR_TABLE_UNLOADED(ct))
3549 Fload_char_attribute_table (attribute);
3551 slarg.function = function;
3552 slarg.retval = Qnil;
3553 GCPRO2 (slarg.function, slarg.retval);
3554 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3557 return slarg.retval;
3560 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3561 Store character's ATTRIBUTES.
3565 Lisp_Object rest = attributes;
3566 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3567 Lisp_Object character;
3571 while (CONSP (rest))
3573 Lisp_Object cell = Fcar (rest);
3577 signal_simple_error ("Invalid argument", attributes);
3578 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3579 && ((XCHARSET_FINAL (ccs) != 0) ||
3580 (XCHARSET_MAX_CODE (ccs) > 0) ||
3581 (EQ (ccs, Vcharset_chinese_big5))) )
3585 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3587 character = Fdecode_char (ccs, cell, Qnil);
3588 if (!NILP (character))
3589 goto setup_attributes;
3593 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3594 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3598 signal_simple_error ("Invalid argument", attributes);
3600 character = make_char (XINT (code) + 0x100000);
3601 goto setup_attributes;
3605 else if (!INTP (code))
3606 signal_simple_error ("Invalid argument", attributes);
3608 character = make_char (XINT (code));
3612 while (CONSP (rest))
3614 Lisp_Object cell = Fcar (rest);
3617 signal_simple_error ("Invalid argument", attributes);
3619 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3625 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3626 Retrieve the character of the given ATTRIBUTES.
3630 Lisp_Object rest = attributes;
3633 while (CONSP (rest))
3635 Lisp_Object cell = Fcar (rest);
3639 signal_simple_error ("Invalid argument", attributes);
3640 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3644 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3646 return Fdecode_char (ccs, cell, Qnil);
3650 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3651 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3654 signal_simple_error ("Invalid argument", attributes);
3656 return make_char (XINT (code) + 0x100000);
3664 /************************************************************************/
3665 /* Char table read syntax */
3666 /************************************************************************/
3669 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3670 Error_behavior errb)
3672 /* #### should deal with ERRB */
3673 symbol_to_char_table_type (value);
3678 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3679 Error_behavior errb)
3683 /* #### should deal with ERRB */
3684 EXTERNAL_LIST_LOOP (rest, value)
3686 Lisp_Object range = XCAR (rest);
3687 struct chartab_range dummy;
3691 signal_simple_error ("Invalid list format", value);
3694 if (!CONSP (XCDR (range))
3695 || !NILP (XCDR (XCDR (range))))
3696 signal_simple_error ("Invalid range format", range);
3697 decode_char_table_range (XCAR (range), &dummy);
3698 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3701 decode_char_table_range (range, &dummy);
3708 chartab_instantiate (Lisp_Object data)
3710 Lisp_Object chartab;
3711 Lisp_Object type = Qgeneric;
3712 Lisp_Object dataval = Qnil;
3714 while (!NILP (data))
3716 Lisp_Object keyw = Fcar (data);
3722 if (EQ (keyw, Qtype))
3724 else if (EQ (keyw, Qdata))
3728 chartab = Fmake_char_table (type);
3731 while (!NILP (data))
3733 Lisp_Object range = Fcar (data);
3734 Lisp_Object val = Fcar (Fcdr (data));
3736 data = Fcdr (Fcdr (data));
3739 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3741 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3742 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3745 for (i = first; i <= last; i++)
3746 Fput_char_table (make_char (i), val, chartab);
3752 Fput_char_table (range, val, chartab);
3761 /************************************************************************/
3762 /* Category Tables, specifically */
3763 /************************************************************************/
3765 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3766 Return t if OBJECT is a category table.
3767 A category table is a type of char table used for keeping track of
3768 categories. Categories are used for classifying characters for use
3769 in regexps -- you can refer to a category rather than having to use
3770 a complicated [] expression (and category lookups are significantly
3773 There are 95 different categories available, one for each printable
3774 character (including space) in the ASCII charset. Each category
3775 is designated by one such character, called a "category designator".
3776 They are specified in a regexp using the syntax "\\cX", where X is
3777 a category designator.
3779 A category table specifies, for each character, the categories that
3780 the character is in. Note that a character can be in more than one
3781 category. More specifically, a category table maps from a character
3782 to either the value nil (meaning the character is in no categories)
3783 or a 95-element bit vector, specifying for each of the 95 categories
3784 whether the character is in that category.
3786 Special Lisp functions are provided that abstract this, so you do not
3787 have to directly manipulate bit vectors.
3791 return (CHAR_TABLEP (object) &&
3792 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3797 check_category_table (Lisp_Object object, Lisp_Object default_)
3801 while (NILP (Fcategory_table_p (object)))
3802 object = wrong_type_argument (Qcategory_table_p, object);
3807 check_category_char (Emchar ch, Lisp_Object table,
3808 unsigned int designator, unsigned int not_p)
3810 REGISTER Lisp_Object temp;
3811 Lisp_Char_Table *ctbl;
3812 #ifdef ERROR_CHECK_TYPECHECK
3813 if (NILP (Fcategory_table_p (table)))
3814 signal_simple_error ("Expected category table", table);
3816 ctbl = XCHAR_TABLE (table);
3817 temp = get_char_table (ch, ctbl);
3822 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3825 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3826 Return t if category of the character at POSITION includes DESIGNATOR.
3827 Optional third arg BUFFER specifies which buffer to use, and defaults
3828 to the current buffer.
3829 Optional fourth arg CATEGORY-TABLE specifies the category table to
3830 use, and defaults to BUFFER's category table.
3832 (position, designator, buffer, category_table))
3837 struct buffer *buf = decode_buffer (buffer, 0);
3839 CHECK_INT (position);
3840 CHECK_CATEGORY_DESIGNATOR (designator);
3841 des = XCHAR (designator);
3842 ctbl = check_category_table (category_table, Vstandard_category_table);
3843 ch = BUF_FETCH_CHAR (buf, XINT (position));
3844 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3847 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3848 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3849 Optional third arg CATEGORY-TABLE specifies the category table to use,
3850 and defaults to the standard category table.
3852 (character, designator, category_table))
3858 CHECK_CATEGORY_DESIGNATOR (designator);
3859 des = XCHAR (designator);
3860 CHECK_CHAR (character);
3861 ch = XCHAR (character);
3862 ctbl = check_category_table (category_table, Vstandard_category_table);
3863 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3866 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3867 Return BUFFER's current category table.
3868 BUFFER defaults to the current buffer.
3872 return decode_buffer (buffer, 0)->category_table;
3875 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3876 Return the standard category table.
3877 This is the one used for new buffers.
3881 return Vstandard_category_table;
3884 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3885 Return a new category table which is a copy of CATEGORY-TABLE.
3886 CATEGORY-TABLE defaults to the standard category table.
3890 if (NILP (Vstandard_category_table))
3891 return Fmake_char_table (Qcategory);
3894 check_category_table (category_table, Vstandard_category_table);
3895 return Fcopy_char_table (category_table);
3898 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3899 Select CATEGORY-TABLE as the new category table for BUFFER.
3900 BUFFER defaults to the current buffer if omitted.
3902 (category_table, buffer))
3904 struct buffer *buf = decode_buffer (buffer, 0);
3905 category_table = check_category_table (category_table, Qnil);
3906 buf->category_table = category_table;
3907 /* Indicate that this buffer now has a specified category table. */
3908 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3909 return category_table;
3912 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3913 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3917 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3920 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3921 Return t if OBJECT is a category table value.
3922 Valid values are nil or a bit vector of size 95.
3926 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3930 #define CATEGORYP(x) \
3931 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3933 #define CATEGORY_SET(c) \
3934 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3936 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3937 The faster version of `!NILP (Faref (category_set, category))'. */
3938 #define CATEGORY_MEMBER(category, category_set) \
3939 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3941 /* Return 1 if there is a word boundary between two word-constituent
3942 characters C1 and C2 if they appear in this order, else return 0.
3943 Use the macro WORD_BOUNDARY_P instead of calling this function
3946 int word_boundary_p (Emchar c1, Emchar c2);
3948 word_boundary_p (Emchar c1, Emchar c2)
3950 Lisp_Object category_set1, category_set2;
3955 if (COMPOSITE_CHAR_P (c1))
3956 c1 = cmpchar_component (c1, 0, 1);
3957 if (COMPOSITE_CHAR_P (c2))
3958 c2 = cmpchar_component (c2, 0, 1);
3961 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3963 tail = Vword_separating_categories;
3968 tail = Vword_combining_categories;
3972 category_set1 = CATEGORY_SET (c1);
3973 if (NILP (category_set1))
3974 return default_result;
3975 category_set2 = CATEGORY_SET (c2);
3976 if (NILP (category_set2))
3977 return default_result;
3979 for (; CONSP (tail); tail = XCONS (tail)->cdr)
3981 Lisp_Object elt = XCONS(tail)->car;
3984 && CATEGORYP (XCONS (elt)->car)
3985 && CATEGORYP (XCONS (elt)->cdr)
3986 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3987 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3988 return !default_result;
3990 return default_result;
3996 syms_of_chartab (void)
3999 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
4000 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
4001 INIT_LRECORD_IMPLEMENTATION (byte_table);
4003 defsymbol (&Qsystem_char_id, "system-char-id");
4005 defsymbol (&Qto_ucs, "=>ucs");
4006 defsymbol (&Q_ucs, "->ucs");
4007 defsymbol (&Q_ucs_variants, "->ucs-variants");
4008 defsymbol (&Q_decomposition, "->decomposition");
4009 defsymbol (&Qcompat, "compat");
4010 defsymbol (&Qisolated, "isolated");
4011 defsymbol (&Qinitial, "initial");
4012 defsymbol (&Qmedial, "medial");
4013 defsymbol (&Qfinal, "final");
4014 defsymbol (&Qvertical, "vertical");
4015 defsymbol (&QnoBreak, "noBreak");
4016 defsymbol (&Qfraction, "fraction");
4017 defsymbol (&Qsuper, "super");
4018 defsymbol (&Qsub, "sub");
4019 defsymbol (&Qcircle, "circle");
4020 defsymbol (&Qsquare, "square");
4021 defsymbol (&Qwide, "wide");
4022 defsymbol (&Qnarrow, "narrow");
4023 defsymbol (&Qsmall, "small");
4024 defsymbol (&Qfont, "font");
4026 DEFSUBR (Fchar_attribute_list);
4027 DEFSUBR (Ffind_char_attribute_table);
4028 defsymbol (&Qput_char_table_map_function, "put-char-table-map-function");
4029 DEFSUBR (Fput_char_table_map_function);
4030 DEFSUBR (Fsave_char_attribute_table);
4031 DEFSUBR (Freset_char_attribute_table);
4032 #ifdef HAVE_DATABASE
4033 defsymbol (&Qload_char_attribute_table_map_function,
4034 "load-char-attribute-table-map-function");
4035 DEFSUBR (Fload_char_attribute_table_map_function);
4037 DEFSUBR (Fload_char_attribute_table);
4038 DEFSUBR (Fchar_attribute_alist);
4039 DEFSUBR (Fget_char_attribute);
4040 DEFSUBR (Fput_char_attribute);
4041 DEFSUBR (Fremove_char_attribute);
4042 DEFSUBR (Fmap_char_attribute);
4043 DEFSUBR (Fdefine_char);
4044 DEFSUBR (Ffind_char);
4045 DEFSUBR (Fchar_variants);
4047 DEFSUBR (Fget_composite_char);
4050 INIT_LRECORD_IMPLEMENTATION (char_table);
4054 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
4057 defsymbol (&Qcategory_table_p, "category-table-p");
4058 defsymbol (&Qcategory_designator_p, "category-designator-p");
4059 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
4062 defsymbol (&Qchar_table, "char-table");
4063 defsymbol (&Qchar_tablep, "char-table-p");
4065 DEFSUBR (Fchar_table_p);
4066 DEFSUBR (Fchar_table_type_list);
4067 DEFSUBR (Fvalid_char_table_type_p);
4068 DEFSUBR (Fchar_table_type);
4069 DEFSUBR (Freset_char_table);
4070 DEFSUBR (Fmake_char_table);
4071 DEFSUBR (Fcopy_char_table);
4072 DEFSUBR (Fget_char_table);
4073 DEFSUBR (Fget_range_char_table);
4074 DEFSUBR (Fvalid_char_table_value_p);
4075 DEFSUBR (Fcheck_valid_char_table_value);
4076 DEFSUBR (Fput_char_table);
4077 DEFSUBR (Fmap_char_table);
4080 DEFSUBR (Fcategory_table_p);
4081 DEFSUBR (Fcategory_table);
4082 DEFSUBR (Fstandard_category_table);
4083 DEFSUBR (Fcopy_category_table);
4084 DEFSUBR (Fset_category_table);
4085 DEFSUBR (Fcheck_category_at);
4086 DEFSUBR (Fchar_in_category_p);
4087 DEFSUBR (Fcategory_designator_p);
4088 DEFSUBR (Fcategory_table_value_p);
4094 vars_of_chartab (void)
4097 staticpro (&Vcharacter_composition_table);
4098 Vcharacter_composition_table = make_char_id_table (Qnil);
4100 staticpro (&Vcharacter_variant_table);
4101 Vcharacter_variant_table = make_char_id_table (Qunbound);
4103 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
4104 Vall_syntax_tables = Qnil;
4105 dump_add_weak_object_chain (&Vall_syntax_tables);
4109 structure_type_create_chartab (void)
4111 struct structure_type *st;
4113 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
4115 define_structure_type_keyword (st, Qtype, chartab_type_validate);
4116 define_structure_type_keyword (st, Qdata, chartab_data_validate);
4120 complex_vars_of_chartab (void)
4123 staticpro (&Vchar_attribute_hash_table);
4124 Vchar_attribute_hash_table
4125 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
4126 #ifdef HAVE_DATABASE
4127 Fputhash (Q_ucs_variants, Vcharacter_variant_table,
4128 Vchar_attribute_hash_table);
4129 XCHAR_TABLE_NAME (Vcharacter_variant_table) = Q_ucs_variants;
4130 #endif /* HAVE_DATABASE */
4131 #endif /* UTF2000 */
4133 /* Set this now, so first buffer creation can refer to it. */
4134 /* Make it nil before calling copy-category-table
4135 so that copy-category-table will know not to try to copy from garbage */
4136 Vstandard_category_table = Qnil;
4137 Vstandard_category_table = Fcopy_category_table (Qnil);
4138 staticpro (&Vstandard_category_table);
4140 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
4141 List of pair (cons) of categories to determine word boundary.
4143 Emacs treats a sequence of word constituent characters as a single
4144 word (i.e. finds no word boundary between them) iff they belongs to
4145 the same charset. But, exceptions are allowed in the following cases.
4147 \(1) The case that characters are in different charsets is controlled
4148 by the variable `word-combining-categories'.
4150 Emacs finds no word boundary between characters of different charsets
4151 if they have categories matching some element of this list.
4153 More precisely, if an element of this list is a cons of category CAT1
4154 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4155 C2 which has CAT2, there's no word boundary between C1 and C2.
4157 For instance, to tell that ASCII characters and Latin-1 characters can
4158 form a single word, the element `(?l . ?l)' should be in this list
4159 because both characters have the category `l' (Latin characters).
4161 \(2) The case that character are in the same charset is controlled by
4162 the variable `word-separating-categories'.
4164 Emacs find a word boundary between characters of the same charset
4165 if they have categories matching some element of this list.
4167 More precisely, if an element of this list is a cons of category CAT1
4168 and CAT2, and a multibyte character C1 which has CAT1 is followed by
4169 C2 which has CAT2, there's a word boundary between C1 and C2.
4171 For instance, to tell that there's a word boundary between Japanese
4172 Hiragana and Japanese Kanji (both are in the same charset), the
4173 element `(?H . ?C) should be in this list.
4176 Vword_combining_categories = Qnil;
4178 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
4179 List of pair (cons) of categories to determine word boundary.
4180 See the documentation of the variable `word-combining-categories'.
4183 Vword_separating_categories = Qnil;