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.
8 This file is part of XEmacs.
10 XEmacs is free software; you can redistribute it and/or modify it
11 under the terms of the GNU General Public License as published by the
12 Free Software Foundation; either version 2, or (at your option) any
15 XEmacs is distributed in the hope that it will be useful, but WITHOUT
16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with XEmacs; see the file COPYING. If not, write to
22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 Boston, MA 02111-1307, USA. */
25 /* Synched up with: Mule 2.3. Not synched with FSF.
27 This file was written independently of the FSF implementation,
28 and is not compatible. */
32 Ben Wing: wrote, for 19.13 (Mule). Some category table stuff
33 loosely based on the original Mule.
34 Jareth Hein: fixed a couple of bugs in the implementation, and
35 added regex support for categories with check_category_at
48 Lisp_Object Vutf_2000_version;
51 Lisp_Object Qchar_tablep, Qchar_table;
53 Lisp_Object Vall_syntax_tables;
56 Lisp_Object Qcategory_table_p;
57 Lisp_Object Qcategory_designator_p;
58 Lisp_Object Qcategory_table_value_p;
60 Lisp_Object Vstandard_category_table;
62 /* Variables to determine word boundary. */
63 Lisp_Object Vword_combining_categories, Vword_separating_categories;
69 #define BT_UINT8_MIN 0
70 #define BT_UINT8_MAX (UCHAR_MAX - 3)
71 #define BT_UINT8_t (UCHAR_MAX - 2)
72 #define BT_UINT8_nil (UCHAR_MAX - 1)
73 #define BT_UINT8_unbound UCHAR_MAX
75 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
76 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
77 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
78 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
79 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
82 INT_UINT8_P (Lisp_Object obj)
88 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
95 UINT8_VALUE_P (Lisp_Object obj)
97 return EQ (obj, Qunbound)
98 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
101 INLINE_HEADER unsigned char
102 UINT8_ENCODE (Lisp_Object obj)
104 if (EQ (obj, Qunbound))
105 return BT_UINT8_unbound;
106 else if (EQ (obj, Qnil))
108 else if (EQ (obj, Qt))
114 INLINE_HEADER Lisp_Object
115 UINT8_DECODE (unsigned char n)
117 if (n == BT_UINT8_unbound)
119 else if (n == BT_UINT8_nil)
121 else if (n == BT_UINT8_t)
128 mark_uint8_byte_table (Lisp_Object obj)
134 print_uint8_byte_table (Lisp_Object obj,
135 Lisp_Object printcharfun, int escapeflag)
137 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
139 struct gcpro gcpro1, gcpro2;
140 GCPRO2 (obj, printcharfun);
142 write_c_string ("\n#<uint8-byte-table", printcharfun);
143 for (i = 0; i < 256; i++)
145 unsigned char n = bte->property[i];
147 write_c_string ("\n ", printcharfun);
148 write_c_string (" ", printcharfun);
149 if (n == BT_UINT8_unbound)
150 write_c_string ("void", printcharfun);
151 else if (n == BT_UINT8_nil)
152 write_c_string ("nil", printcharfun);
153 else if (n == BT_UINT8_t)
154 write_c_string ("t", printcharfun);
159 sprintf (buf, "%hd", n);
160 write_c_string (buf, printcharfun);
164 write_c_string (">", printcharfun);
168 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
170 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
171 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
174 for (i = 0; i < 256; i++)
175 if (te1->property[i] != te2->property[i])
181 uint8_byte_table_hash (Lisp_Object obj, int depth)
183 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
187 for (i = 0; i < 256; i++)
188 hash = HASH2 (hash, te->property[i]);
192 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
193 mark_uint8_byte_table,
194 print_uint8_byte_table,
195 0, uint8_byte_table_equal,
196 uint8_byte_table_hash,
197 0 /* uint8_byte_table_description */,
198 Lisp_Uint8_Byte_Table);
201 make_uint8_byte_table (unsigned char initval)
205 Lisp_Uint8_Byte_Table *cte;
207 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
208 &lrecord_uint8_byte_table);
210 for (i = 0; i < 256; i++)
211 cte->property[i] = initval;
213 XSETUINT8_BYTE_TABLE (obj, cte);
218 uint8_byte_table_same_value_p (Lisp_Object obj)
220 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
221 unsigned char v0 = bte->property[0];
224 for (i = 1; i < 256; i++)
226 if (bte->property[i] != v0)
233 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct,
234 int (*fn) (struct chartab_range *range,
235 Lisp_Object val, void *arg),
236 void *arg, Emchar ofs, int place)
238 struct chartab_range rainj;
240 int unit = 1 << (8 * place);
244 rainj.type = CHARTAB_RANGE_CHAR;
246 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
248 if (ct->property[i] != BT_UINT8_unbound)
251 for (; c < c1 && retval == 0; c++)
254 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
263 #define BT_UINT16_MIN 0
264 #define BT_UINT16_MAX (USHRT_MAX - 3)
265 #define BT_UINT16_t (USHRT_MAX - 2)
266 #define BT_UINT16_nil (USHRT_MAX - 1)
267 #define BT_UINT16_unbound USHRT_MAX
269 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
270 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
271 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
272 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
275 INT_UINT16_P (Lisp_Object obj)
279 int num = XINT (obj);
281 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
288 UINT16_VALUE_P (Lisp_Object obj)
290 return EQ (obj, Qunbound)
291 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
294 INLINE_HEADER unsigned short
295 UINT16_ENCODE (Lisp_Object obj)
297 if (EQ (obj, Qunbound))
298 return BT_UINT16_unbound;
299 else if (EQ (obj, Qnil))
300 return BT_UINT16_nil;
301 else if (EQ (obj, Qt))
307 INLINE_HEADER Lisp_Object
308 UINT16_DECODE (unsigned short n)
310 if (n == BT_UINT16_unbound)
312 else if (n == BT_UINT16_nil)
314 else if (n == BT_UINT16_t)
320 INLINE_HEADER unsigned short
321 UINT8_TO_UINT16 (unsigned char n)
323 if (n == BT_UINT8_unbound)
324 return BT_UINT16_unbound;
325 else if (n == BT_UINT8_nil)
326 return BT_UINT16_nil;
327 else if (n == BT_UINT8_t)
334 mark_uint16_byte_table (Lisp_Object obj)
340 print_uint16_byte_table (Lisp_Object obj,
341 Lisp_Object printcharfun, int escapeflag)
343 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
345 struct gcpro gcpro1, gcpro2;
346 GCPRO2 (obj, printcharfun);
348 write_c_string ("\n#<uint16-byte-table", printcharfun);
349 for (i = 0; i < 256; i++)
351 unsigned short n = bte->property[i];
353 write_c_string ("\n ", printcharfun);
354 write_c_string (" ", printcharfun);
355 if (n == BT_UINT16_unbound)
356 write_c_string ("void", printcharfun);
357 else if (n == BT_UINT16_nil)
358 write_c_string ("nil", printcharfun);
359 else if (n == BT_UINT16_t)
360 write_c_string ("t", printcharfun);
365 sprintf (buf, "%hd", n);
366 write_c_string (buf, printcharfun);
370 write_c_string (">", printcharfun);
374 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
376 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
377 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
380 for (i = 0; i < 256; i++)
381 if (te1->property[i] != te2->property[i])
387 uint16_byte_table_hash (Lisp_Object obj, int depth)
389 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
393 for (i = 0; i < 256; i++)
394 hash = HASH2 (hash, te->property[i]);
398 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
399 mark_uint16_byte_table,
400 print_uint16_byte_table,
401 0, uint16_byte_table_equal,
402 uint16_byte_table_hash,
403 0 /* uint16_byte_table_description */,
404 Lisp_Uint16_Byte_Table);
407 make_uint16_byte_table (unsigned short initval)
411 Lisp_Uint16_Byte_Table *cte;
413 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
414 &lrecord_uint16_byte_table);
416 for (i = 0; i < 256; i++)
417 cte->property[i] = initval;
419 XSETUINT16_BYTE_TABLE (obj, cte);
424 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
428 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
429 Lisp_Uint16_Byte_Table* cte;
431 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
432 &lrecord_uint16_byte_table);
433 for (i = 0; i < 256; i++)
435 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
437 XSETUINT16_BYTE_TABLE (obj, cte);
442 uint16_byte_table_same_value_p (Lisp_Object obj)
444 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
445 unsigned short v0 = bte->property[0];
448 for (i = 1; i < 256; i++)
450 if (bte->property[i] != v0)
457 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct,
458 int (*fn) (struct chartab_range *range,
459 Lisp_Object val, void *arg),
460 void *arg, Emchar ofs, int place)
462 struct chartab_range rainj;
464 int unit = 1 << (8 * place);
468 rainj.type = CHARTAB_RANGE_CHAR;
470 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
472 if (ct->property[i] != BT_UINT16_unbound)
475 for (; c < c1 && retval == 0; c++)
478 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
489 mark_byte_table (Lisp_Object obj)
491 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
494 for (i = 0; i < 256; i++)
496 mark_object (cte->property[i]);
502 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
504 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
506 struct gcpro gcpro1, gcpro2;
507 GCPRO2 (obj, printcharfun);
509 write_c_string ("\n#<byte-table", printcharfun);
510 for (i = 0; i < 256; i++)
512 Lisp_Object elt = bte->property[i];
514 write_c_string ("\n ", printcharfun);
515 write_c_string (" ", printcharfun);
516 if (EQ (elt, Qunbound))
517 write_c_string ("void", printcharfun);
519 print_internal (elt, printcharfun, escapeflag);
522 write_c_string (">", printcharfun);
526 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
528 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
529 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
532 for (i = 0; i < 256; i++)
533 if (BYTE_TABLE_P (cte1->property[i]))
535 if (BYTE_TABLE_P (cte2->property[i]))
537 if (!byte_table_equal (cte1->property[i],
538 cte2->property[i], depth + 1))
545 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
551 byte_table_hash (Lisp_Object obj, int depth)
553 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
555 return internal_array_hash (cte->property, 256, depth);
558 static const struct lrecord_description byte_table_description[] = {
559 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
563 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
568 byte_table_description,
572 make_byte_table (Lisp_Object initval)
576 Lisp_Byte_Table *cte;
578 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
580 for (i = 0; i < 256; i++)
581 cte->property[i] = initval;
583 XSETBYTE_TABLE (obj, cte);
588 byte_table_same_value_p (Lisp_Object obj)
590 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
591 Lisp_Object v0 = bte->property[0];
594 for (i = 1; i < 256; i++)
596 if (!internal_equal (bte->property[i], v0, 0))
603 map_over_byte_table (Lisp_Byte_Table *ct,
604 int (*fn) (struct chartab_range *range,
605 Lisp_Object val, void *arg),
606 void *arg, Emchar ofs, int place)
610 int unit = 1 << (8 * place);
613 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
616 if (UINT8_BYTE_TABLE_P (v))
619 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v),
620 fn, arg, c, place - 1);
623 else if (UINT16_BYTE_TABLE_P (v))
626 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v),
627 fn, arg, c, place - 1);
630 else if (BYTE_TABLE_P (v))
632 retval = map_over_byte_table (XBYTE_TABLE(v),
633 fn, arg, c, place - 1);
636 else if (!UNBOUNDP (v))
638 struct chartab_range rainj;
639 Emchar c1 = c + unit;
641 rainj.type = CHARTAB_RANGE_CHAR;
643 for (; c < c1 && retval == 0; c++)
646 retval = (fn) (&rainj, v, arg);
656 Lisp_Object get_byte_table (Lisp_Object table, unsigned char idx);
657 Lisp_Object put_byte_table (Lisp_Object table, unsigned char idx,
661 get_byte_table (Lisp_Object table, unsigned char idx)
663 if (UINT8_BYTE_TABLE_P (table))
664 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
665 else if (UINT16_BYTE_TABLE_P (table))
666 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
667 else if (BYTE_TABLE_P (table))
668 return XBYTE_TABLE(table)->property[idx];
674 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
676 if (UINT8_BYTE_TABLE_P (table))
678 if (UINT8_VALUE_P (value))
680 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
681 if (!UINT8_BYTE_TABLE_P (value) &&
682 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
683 && uint8_byte_table_same_value_p (table))
688 else if (UINT16_VALUE_P (value))
690 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
692 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
697 Lisp_Object new = make_byte_table (Qnil);
700 for (i = 0; i < 256; i++)
702 XBYTE_TABLE(new)->property[i]
703 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
705 XBYTE_TABLE(new)->property[idx] = value;
709 else if (UINT16_BYTE_TABLE_P (table))
711 if (UINT16_VALUE_P (value))
713 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
714 if (!UINT8_BYTE_TABLE_P (value) &&
715 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
716 && uint16_byte_table_same_value_p (table))
723 Lisp_Object new = make_byte_table (Qnil);
726 for (i = 0; i < 256; i++)
728 XBYTE_TABLE(new)->property[i]
729 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
731 XBYTE_TABLE(new)->property[idx] = value;
735 else if (BYTE_TABLE_P (table))
737 XBYTE_TABLE(table)->property[idx] = value;
738 if (!UINT8_BYTE_TABLE_P (value) &&
739 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
740 && byte_table_same_value_p (table))
745 else if (!internal_equal (table, value, 0))
747 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
749 table = make_uint8_byte_table (UINT8_ENCODE (table));
750 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
752 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
754 table = make_uint16_byte_table (UINT16_ENCODE (table));
755 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
759 table = make_byte_table (table);
760 XBYTE_TABLE(table)->property[idx] = value;
767 mark_char_id_table (Lisp_Object obj)
769 Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj);
775 print_char_id_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
777 Lisp_Object table = XCHAR_ID_TABLE (obj)->table;
779 struct gcpro gcpro1, gcpro2;
780 GCPRO2 (obj, printcharfun);
782 write_c_string ("#<char-id-table ", printcharfun);
783 for (i = 0; i < 256; i++)
785 Lisp_Object elt = get_byte_table (table, i);
786 if (i != 0) write_c_string ("\n ", printcharfun);
787 if (EQ (elt, Qunbound))
788 write_c_string ("void", printcharfun);
790 print_internal (elt, printcharfun, escapeflag);
793 write_c_string (">", printcharfun);
797 char_id_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
799 Lisp_Object table1 = XCHAR_ID_TABLE (obj1)->table;
800 Lisp_Object table2 = XCHAR_ID_TABLE (obj2)->table;
803 for (i = 0; i < 256; i++)
805 if (!internal_equal (get_byte_table (table1, i),
806 get_byte_table (table2, i), 0))
813 char_id_table_hash (Lisp_Object obj, int depth)
815 Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj);
817 return char_id_table_hash (cte->table, depth + 1);
820 static const struct lrecord_description char_id_table_description[] = {
821 { XD_LISP_OBJECT, offsetof(Lisp_Char_ID_Table, table) },
825 DEFINE_LRECORD_IMPLEMENTATION ("char-id-table", char_id_table,
828 0, char_id_table_equal,
830 char_id_table_description,
834 make_char_id_table (Lisp_Object initval)
837 Lisp_Char_ID_Table *cte;
839 cte = alloc_lcrecord_type (Lisp_Char_ID_Table, &lrecord_char_id_table);
841 cte->table = make_byte_table (initval);
843 XSETCHAR_ID_TABLE (obj, cte);
849 get_char_id_table (Emchar ch, Lisp_Object table)
851 unsigned int code = ch;
858 (XCHAR_ID_TABLE (table)->table,
859 (unsigned char)(code >> 24)),
860 (unsigned char) (code >> 16)),
861 (unsigned char) (code >> 8)),
862 (unsigned char) code);
866 put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table)
868 unsigned int code = ch;
869 Lisp_Object table1, table2, table3, table4;
871 table1 = XCHAR_ID_TABLE (table)->table;
872 table2 = get_byte_table (table1, (unsigned char)(code >> 24));
873 table3 = get_byte_table (table2, (unsigned char)(code >> 16));
874 table4 = get_byte_table (table3, (unsigned char)(code >> 8));
876 table4 = put_byte_table (table4, (unsigned char)code, value);
877 table3 = put_byte_table (table3, (unsigned char)(code >> 8), table4);
878 table2 = put_byte_table (table2, (unsigned char)(code >> 16), table3);
879 XCHAR_ID_TABLE (table)->table
880 = put_byte_table (table1, (unsigned char)(code >> 24), table2);
883 /* Map FN (with client data ARG) in char table CT.
884 Mapping stops the first time FN returns non-zero, and that value
885 becomes the return value of map_char_id_table(). */
887 map_char_id_table (Lisp_Char_ID_Table *ct,
888 int (*fn) (struct chartab_range *range,
889 Lisp_Object val, void *arg),
892 map_char_id_table (Lisp_Char_ID_Table *ct,
893 int (*fn) (struct chartab_range *range,
894 Lisp_Object val, void *arg),
897 Lisp_Object v = ct->table;
899 if (UINT8_BYTE_TABLE_P (v))
900 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), fn, arg, 0, 3);
901 else if (UINT16_BYTE_TABLE_P (v))
902 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), fn, arg, 0, 3);
903 else if (BYTE_TABLE_P (v))
904 return map_over_byte_table (XBYTE_TABLE(v), fn, arg, 0, 3);
905 else if (!UNBOUNDP (v))
907 struct chartab_range rainj;
910 Emchar c1 = c + unit;
913 rainj.type = CHARTAB_RANGE_CHAR;
915 for (retval = 0; c < c1 && retval == 0; c++)
918 retval = (fn) (&rainj, v, arg);
925 Lisp_Object Vcharacter_composition_table;
926 Lisp_Object Vcharacter_variant_table;
929 Lisp_Object Q_decomposition;
933 Lisp_Object Qisolated;
934 Lisp_Object Qinitial;
937 Lisp_Object Qvertical;
938 Lisp_Object QnoBreak;
939 Lisp_Object Qfraction;
949 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
952 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
958 else if (EQ (v, Qcompat))
960 else if (EQ (v, Qisolated))
962 else if (EQ (v, Qinitial))
964 else if (EQ (v, Qmedial))
966 else if (EQ (v, Qfinal))
968 else if (EQ (v, Qvertical))
970 else if (EQ (v, QnoBreak))
972 else if (EQ (v, Qfraction))
974 else if (EQ (v, Qsuper))
976 else if (EQ (v, Qsub))
978 else if (EQ (v, Qcircle))
980 else if (EQ (v, Qsquare))
982 else if (EQ (v, Qwide))
984 else if (EQ (v, Qnarrow))
986 else if (EQ (v, Qsmall))
988 else if (EQ (v, Qfont))
991 signal_simple_error (err_msg, err_arg);
994 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
995 Return character corresponding with list.
999 Lisp_Object table = Vcharacter_composition_table;
1000 Lisp_Object rest = list;
1002 while (CONSP (rest))
1004 Lisp_Object v = Fcar (rest);
1006 Emchar c = to_char_id (v, "Invalid value for composition", list);
1008 ret = get_char_id_table (c, table);
1013 if (!CHAR_ID_TABLE_P (ret))
1018 else if (!CONSP (rest))
1020 else if (CHAR_ID_TABLE_P (ret))
1023 signal_simple_error ("Invalid table is found with", list);
1025 signal_simple_error ("Invalid value for composition", list);
1028 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1029 Return variants of CHARACTER.
1033 CHECK_CHAR (character);
1034 return Fcopy_list (get_char_id_table (XCHAR (character),
1035 Vcharacter_variant_table));
1041 /* A char table maps from ranges of characters to values.
1043 Implementing a general data structure that maps from arbitrary
1044 ranges of numbers to values is tricky to do efficiently. As it
1045 happens, it should suffice (and is usually more convenient, anyway)
1046 when dealing with characters to restrict the sorts of ranges that
1047 can be assigned values, as follows:
1050 2) All characters in a charset.
1051 3) All characters in a particular row of a charset, where a "row"
1052 means all characters with the same first byte.
1053 4) A particular character in a charset.
1055 We use char tables to generalize the 256-element vectors now
1056 littering the Emacs code.
1058 Possible uses (all should be converted at some point):
1064 5) keyboard-translate-table?
1067 abstract type to generalize the Emacs vectors and Mule
1068 vectors-of-vectors goo.
1071 /************************************************************************/
1072 /* Char Table object */
1073 /************************************************************************/
1078 mark_char_table_entry (Lisp_Object obj)
1080 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1083 for (i = 0; i < 96; i++)
1085 mark_object (cte->level2[i]);
1091 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1093 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1094 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1097 for (i = 0; i < 96; i++)
1098 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1104 static unsigned long
1105 char_table_entry_hash (Lisp_Object obj, int depth)
1107 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1109 return internal_array_hash (cte->level2, 96, depth);
1112 static const struct lrecord_description char_table_entry_description[] = {
1113 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1117 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1118 mark_char_table_entry, internal_object_printer,
1119 0, char_table_entry_equal,
1120 char_table_entry_hash,
1121 char_table_entry_description,
1122 Lisp_Char_Table_Entry);
1126 mark_char_table (Lisp_Object obj)
1128 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1131 for (i = 0; i < NUM_ASCII_CHARS; i++)
1132 mark_object (ct->ascii[i]);
1134 for (i = 0; i < NUM_LEADING_BYTES; i++)
1135 mark_object (ct->level1[i]);
1137 return ct->mirror_table;
1140 /* WARNING: All functions of this nature need to be written extremely
1141 carefully to avoid crashes during GC. Cf. prune_specifiers()
1142 and prune_weak_hash_tables(). */
1145 prune_syntax_tables (void)
1147 Lisp_Object rest, prev = Qnil;
1149 for (rest = Vall_syntax_tables;
1151 rest = XCHAR_TABLE (rest)->next_table)
1153 if (! marked_p (rest))
1155 /* This table is garbage. Remove it from the list. */
1157 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1159 XCHAR_TABLE (prev)->next_table =
1160 XCHAR_TABLE (rest)->next_table;
1166 char_table_type_to_symbol (enum char_table_type type)
1171 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1172 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1173 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1174 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1176 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1181 static enum char_table_type
1182 symbol_to_char_table_type (Lisp_Object symbol)
1184 CHECK_SYMBOL (symbol);
1186 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1187 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1188 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1189 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1191 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1194 signal_simple_error ("Unrecognized char table type", symbol);
1195 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1199 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1200 Lisp_Object printcharfun)
1204 write_c_string (" (", printcharfun);
1205 print_internal (make_char (first), printcharfun, 0);
1206 write_c_string (" ", printcharfun);
1207 print_internal (make_char (last), printcharfun, 0);
1208 write_c_string (") ", printcharfun);
1212 write_c_string (" ", printcharfun);
1213 print_internal (make_char (first), printcharfun, 0);
1214 write_c_string (" ", printcharfun);
1216 print_internal (val, printcharfun, 1);
1222 print_chartab_charset_row (Lisp_Object charset,
1224 Lisp_Char_Table_Entry *cte,
1225 Lisp_Object printcharfun)
1228 Lisp_Object cat = Qunbound;
1231 for (i = 32; i < 128; i++)
1233 Lisp_Object pam = cte->level2[i - 32];
1245 print_chartab_range (MAKE_CHAR (charset, first, 0),
1246 MAKE_CHAR (charset, i - 1, 0),
1249 print_chartab_range (MAKE_CHAR (charset, row, first),
1250 MAKE_CHAR (charset, row, i - 1),
1260 print_chartab_range (MAKE_CHAR (charset, first, 0),
1261 MAKE_CHAR (charset, i - 1, 0),
1264 print_chartab_range (MAKE_CHAR (charset, row, first),
1265 MAKE_CHAR (charset, row, i - 1),
1271 print_chartab_two_byte_charset (Lisp_Object charset,
1272 Lisp_Char_Table_Entry *cte,
1273 Lisp_Object printcharfun)
1277 for (i = 32; i < 128; i++)
1279 Lisp_Object jen = cte->level2[i - 32];
1281 if (!CHAR_TABLE_ENTRYP (jen))
1285 write_c_string (" [", printcharfun);
1286 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1287 sprintf (buf, " %d] ", i);
1288 write_c_string (buf, printcharfun);
1289 print_internal (jen, printcharfun, 0);
1292 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1300 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1302 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1305 sprintf (buf, "#s(char-table type %s data (",
1306 string_data (symbol_name (XSYMBOL
1307 (char_table_type_to_symbol (ct->type)))));
1308 write_c_string (buf, printcharfun);
1310 /* Now write out the ASCII/Control-1 stuff. */
1314 Lisp_Object val = Qunbound;
1316 for (i = 0; i < NUM_ASCII_CHARS; i++)
1325 if (!EQ (ct->ascii[i], val))
1327 print_chartab_range (first, i - 1, val, printcharfun);
1334 print_chartab_range (first, i - 1, val, printcharfun);
1341 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1344 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1345 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1347 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1348 || i == LEADING_BYTE_CONTROL_1)
1350 if (!CHAR_TABLE_ENTRYP (ann))
1352 write_c_string (" ", printcharfun);
1353 print_internal (XCHARSET_NAME (charset),
1355 write_c_string (" ", printcharfun);
1356 print_internal (ann, printcharfun, 0);
1360 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1361 if (XCHARSET_DIMENSION (charset) == 1)
1362 print_chartab_charset_row (charset, -1, cte, printcharfun);
1364 print_chartab_two_byte_charset (charset, cte, printcharfun);
1370 write_c_string ("))", printcharfun);
1374 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1376 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1377 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1380 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1383 for (i = 0; i < NUM_ASCII_CHARS; i++)
1384 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1388 for (i = 0; i < NUM_LEADING_BYTES; i++)
1389 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1396 static unsigned long
1397 char_table_hash (Lisp_Object obj, int depth)
1399 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1400 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1403 hashval = HASH2 (hashval,
1404 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1409 static const struct lrecord_description char_table_description[] = {
1410 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1412 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1414 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1415 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1419 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1420 mark_char_table, print_char_table, 0,
1421 char_table_equal, char_table_hash,
1422 char_table_description,
1425 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1426 Return non-nil if OBJECT is a char table.
1428 A char table is a table that maps characters (or ranges of characters)
1429 to values. Char tables are specialized for characters, only allowing
1430 particular sorts of ranges to be assigned values. Although this
1431 loses in generality, it makes for extremely fast (constant-time)
1432 lookups, and thus is feasible for applications that do an extremely
1433 large number of lookups (e.g. scanning a buffer for a character in
1434 a particular syntax, where a lookup in the syntax table must occur
1435 once per character).
1437 When Mule support exists, the types of ranges that can be assigned
1441 -- an entire charset
1442 -- a single row in a two-octet charset
1443 -- a single character
1445 When Mule support is not present, the types of ranges that can be
1449 -- a single character
1451 To create a char table, use `make-char-table'.
1452 To modify a char table, use `put-char-table' or `remove-char-table'.
1453 To retrieve the value for a particular character, use `get-char-table'.
1454 See also `map-char-table', `clear-char-table', `copy-char-table',
1455 `valid-char-table-type-p', `char-table-type-list',
1456 `valid-char-table-value-p', and `check-char-table-value'.
1460 return CHAR_TABLEP (object) ? Qt : Qnil;
1463 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1464 Return a list of the recognized char table types.
1465 See `valid-char-table-type-p'.
1470 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1472 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1476 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1477 Return t if TYPE if a recognized char table type.
1479 Each char table type is used for a different purpose and allows different
1480 sorts of values. The different char table types are
1483 Used for category tables, which specify the regexp categories
1484 that a character is in. The valid values are nil or a
1485 bit vector of 95 elements. Higher-level Lisp functions are
1486 provided for working with category tables. Currently categories
1487 and category tables only exist when Mule support is present.
1489 A generalized char table, for mapping from one character to
1490 another. Used for case tables, syntax matching tables,
1491 `keyboard-translate-table', etc. The valid values are characters.
1493 An even more generalized char table, for mapping from a
1494 character to anything.
1496 Used for display tables, which specify how a particular character
1497 is to appear when displayed. #### Not yet implemented.
1499 Used for syntax tables, which specify the syntax of a particular
1500 character. Higher-level Lisp functions are provided for
1501 working with syntax tables. The valid values are integers.
1506 return (EQ (type, Qchar) ||
1508 EQ (type, Qcategory) ||
1510 EQ (type, Qdisplay) ||
1511 EQ (type, Qgeneric) ||
1512 EQ (type, Qsyntax)) ? Qt : Qnil;
1515 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1516 Return the type of CHAR-TABLE.
1517 See `valid-char-table-type-p'.
1521 CHECK_CHAR_TABLE (char_table);
1522 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1526 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1530 for (i = 0; i < NUM_ASCII_CHARS; i++)
1531 ct->ascii[i] = value;
1533 for (i = 0; i < NUM_LEADING_BYTES; i++)
1534 ct->level1[i] = value;
1537 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1538 update_syntax_table (ct);
1541 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1542 Reset CHAR-TABLE to its default state.
1546 Lisp_Char_Table *ct;
1548 CHECK_CHAR_TABLE (char_table);
1549 ct = XCHAR_TABLE (char_table);
1553 case CHAR_TABLE_TYPE_CHAR:
1554 fill_char_table (ct, make_char (0));
1556 case CHAR_TABLE_TYPE_DISPLAY:
1557 case CHAR_TABLE_TYPE_GENERIC:
1559 case CHAR_TABLE_TYPE_CATEGORY:
1561 fill_char_table (ct, Qnil);
1564 case CHAR_TABLE_TYPE_SYNTAX:
1565 fill_char_table (ct, make_int (Sinherit));
1575 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1576 Return a new, empty char table of type TYPE.
1577 Currently recognized types are 'char, 'category, 'display, 'generic,
1578 and 'syntax. See `valid-char-table-type-p'.
1582 Lisp_Char_Table *ct;
1584 enum char_table_type ty = symbol_to_char_table_type (type);
1586 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1588 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1590 ct->mirror_table = Fmake_char_table (Qgeneric);
1591 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1595 ct->mirror_table = Qnil;
1596 ct->next_table = Qnil;
1597 XSETCHAR_TABLE (obj, ct);
1598 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1600 ct->next_table = Vall_syntax_tables;
1601 Vall_syntax_tables = obj;
1603 Freset_char_table (obj);
1610 make_char_table_entry (Lisp_Object initval)
1614 Lisp_Char_Table_Entry *cte =
1615 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1617 for (i = 0; i < 96; i++)
1618 cte->level2[i] = initval;
1620 XSETCHAR_TABLE_ENTRY (obj, cte);
1625 copy_char_table_entry (Lisp_Object entry)
1627 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1630 Lisp_Char_Table_Entry *ctenew =
1631 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1633 for (i = 0; i < 96; i++)
1635 Lisp_Object new = cte->level2[i];
1636 if (CHAR_TABLE_ENTRYP (new))
1637 ctenew->level2[i] = copy_char_table_entry (new);
1639 ctenew->level2[i] = new;
1642 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1648 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1649 Return a new char table which is a copy of CHAR-TABLE.
1650 It will contain the same values for the same characters and ranges
1651 as CHAR-TABLE. The values will not themselves be copied.
1655 Lisp_Char_Table *ct, *ctnew;
1659 CHECK_CHAR_TABLE (char_table);
1660 ct = XCHAR_TABLE (char_table);
1661 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1662 ctnew->type = ct->type;
1664 for (i = 0; i < NUM_ASCII_CHARS; i++)
1666 Lisp_Object new = ct->ascii[i];
1668 assert (! (CHAR_TABLE_ENTRYP (new)));
1670 ctnew->ascii[i] = new;
1675 for (i = 0; i < NUM_LEADING_BYTES; i++)
1677 Lisp_Object new = ct->level1[i];
1678 if (CHAR_TABLE_ENTRYP (new))
1679 ctnew->level1[i] = copy_char_table_entry (new);
1681 ctnew->level1[i] = new;
1686 if (CHAR_TABLEP (ct->mirror_table))
1687 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1689 ctnew->mirror_table = ct->mirror_table;
1690 ctnew->next_table = Qnil;
1691 XSETCHAR_TABLE (obj, ctnew);
1692 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1694 ctnew->next_table = Vall_syntax_tables;
1695 Vall_syntax_tables = obj;
1701 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1704 outrange->type = CHARTAB_RANGE_ALL;
1705 else if (CHAR_OR_CHAR_INTP (range))
1707 outrange->type = CHARTAB_RANGE_CHAR;
1708 outrange->ch = XCHAR_OR_CHAR_INT (range);
1712 signal_simple_error ("Range must be t or a character", range);
1714 else if (VECTORP (range))
1716 Lisp_Vector *vec = XVECTOR (range);
1717 Lisp_Object *elts = vector_data (vec);
1718 if (vector_length (vec) != 2)
1719 signal_simple_error ("Length of charset row vector must be 2",
1721 outrange->type = CHARTAB_RANGE_ROW;
1722 outrange->charset = Fget_charset (elts[0]);
1723 CHECK_INT (elts[1]);
1724 outrange->row = XINT (elts[1]);
1725 if (XCHARSET_DIMENSION (outrange->charset) >= 2)
1727 switch (XCHARSET_CHARS (outrange->charset))
1730 check_int_range (outrange->row, 33, 126);
1733 check_int_range (outrange->row, 32, 127);
1740 signal_simple_error ("Charset in row vector must be multi-byte",
1745 if (!CHARSETP (range) && !SYMBOLP (range))
1747 ("Char table range must be t, charset, char, or vector", range);
1748 outrange->type = CHARTAB_RANGE_CHARSET;
1749 outrange->charset = Fget_charset (range);
1756 /* called from CHAR_TABLE_VALUE(). */
1758 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
1763 Lisp_Object charset;
1765 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
1770 BREAKUP_CHAR (c, charset, byte1, byte2);
1772 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
1774 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
1775 if (CHAR_TABLE_ENTRYP (val))
1777 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1778 val = cte->level2[byte1 - 32];
1779 if (CHAR_TABLE_ENTRYP (val))
1781 cte = XCHAR_TABLE_ENTRY (val);
1782 assert (byte2 >= 32);
1783 val = cte->level2[byte2 - 32];
1784 assert (!CHAR_TABLE_ENTRYP (val));
1794 get_char_table (Emchar ch, Lisp_Char_Table *ct)
1798 Lisp_Object charset;
1802 BREAKUP_CHAR (ch, charset, byte1, byte2);
1804 if (EQ (charset, Vcharset_ascii))
1805 val = ct->ascii[byte1];
1806 else if (EQ (charset, Vcharset_control_1))
1807 val = ct->ascii[byte1 + 128];
1810 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1811 val = ct->level1[lb];
1812 if (CHAR_TABLE_ENTRYP (val))
1814 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1815 val = cte->level2[byte1 - 32];
1816 if (CHAR_TABLE_ENTRYP (val))
1818 cte = XCHAR_TABLE_ENTRY (val);
1819 assert (byte2 >= 32);
1820 val = cte->level2[byte2 - 32];
1821 assert (!CHAR_TABLE_ENTRYP (val));
1828 #else /* not MULE */
1829 return ct->ascii[(unsigned char)ch];
1830 #endif /* not MULE */
1834 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
1835 Find value for CHARACTER in CHAR-TABLE.
1837 (character, char_table))
1839 CHECK_CHAR_TABLE (char_table);
1840 CHECK_CHAR_COERCE_INT (character);
1842 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
1845 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
1846 Find value for a range in CHAR-TABLE.
1847 If there is more than one value, return MULTI (defaults to nil).
1849 (range, char_table, multi))
1851 Lisp_Char_Table *ct;
1852 struct chartab_range rainj;
1854 if (CHAR_OR_CHAR_INTP (range))
1855 return Fget_char_table (range, char_table);
1856 CHECK_CHAR_TABLE (char_table);
1857 ct = XCHAR_TABLE (char_table);
1859 decode_char_table_range (range, &rainj);
1862 case CHARTAB_RANGE_ALL:
1865 Lisp_Object first = ct->ascii[0];
1867 for (i = 1; i < NUM_ASCII_CHARS; i++)
1868 if (!EQ (first, ct->ascii[i]))
1872 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1875 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
1876 || i == LEADING_BYTE_ASCII
1877 || i == LEADING_BYTE_CONTROL_1)
1879 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
1888 case CHARTAB_RANGE_CHARSET:
1889 if (EQ (rainj.charset, Vcharset_ascii))
1892 Lisp_Object first = ct->ascii[0];
1894 for (i = 1; i < 128; i++)
1895 if (!EQ (first, ct->ascii[i]))
1900 if (EQ (rainj.charset, Vcharset_control_1))
1903 Lisp_Object first = ct->ascii[128];
1905 for (i = 129; i < 160; i++)
1906 if (!EQ (first, ct->ascii[i]))
1912 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
1914 if (CHAR_TABLE_ENTRYP (val))
1919 case CHARTAB_RANGE_ROW:
1921 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
1923 if (!CHAR_TABLE_ENTRYP (val))
1925 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
1926 if (CHAR_TABLE_ENTRYP (val))
1930 #endif /* not MULE */
1936 return Qnil; /* not reached */
1940 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
1941 Error_behavior errb)
1945 case CHAR_TABLE_TYPE_SYNTAX:
1946 if (!ERRB_EQ (errb, ERROR_ME))
1947 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
1948 && CHAR_OR_CHAR_INTP (XCDR (value)));
1951 Lisp_Object cdr = XCDR (value);
1952 CHECK_INT (XCAR (value));
1953 CHECK_CHAR_COERCE_INT (cdr);
1960 case CHAR_TABLE_TYPE_CATEGORY:
1961 if (!ERRB_EQ (errb, ERROR_ME))
1962 return CATEGORY_TABLE_VALUEP (value);
1963 CHECK_CATEGORY_TABLE_VALUE (value);
1967 case CHAR_TABLE_TYPE_GENERIC:
1970 case CHAR_TABLE_TYPE_DISPLAY:
1972 maybe_signal_simple_error ("Display char tables not yet implemented",
1973 value, Qchar_table, errb);
1976 case CHAR_TABLE_TYPE_CHAR:
1977 if (!ERRB_EQ (errb, ERROR_ME))
1978 return CHAR_OR_CHAR_INTP (value);
1979 CHECK_CHAR_COERCE_INT (value);
1986 return 0; /* not reached */
1990 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
1994 case CHAR_TABLE_TYPE_SYNTAX:
1997 Lisp_Object car = XCAR (value);
1998 Lisp_Object cdr = XCDR (value);
1999 CHECK_CHAR_COERCE_INT (cdr);
2000 return Fcons (car, cdr);
2003 case CHAR_TABLE_TYPE_CHAR:
2004 CHECK_CHAR_COERCE_INT (value);
2012 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2013 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2015 (value, char_table_type))
2017 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2019 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2022 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2023 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2025 (value, char_table_type))
2027 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2029 check_valid_char_table_value (value, type, ERROR_ME);
2033 /* Assign VAL to all characters in RANGE in char table CT. */
2036 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2039 switch (range->type)
2041 case CHARTAB_RANGE_ALL:
2042 fill_char_table (ct, val);
2043 return; /* avoid the duplicate call to update_syntax_table() below,
2044 since fill_char_table() also did that. */
2047 case CHARTAB_RANGE_CHARSET:
2048 if (EQ (range->charset, Vcharset_ascii))
2051 for (i = 0; i < 128; i++)
2054 else if (EQ (range->charset, Vcharset_control_1))
2057 for (i = 128; i < 160; i++)
2062 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2063 ct->level1[lb] = val;
2067 case CHARTAB_RANGE_ROW:
2069 Lisp_Char_Table_Entry *cte;
2070 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2071 /* make sure that there is a separate entry for the row. */
2072 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2073 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2074 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2075 cte->level2[range->row - 32] = val;
2080 case CHARTAB_RANGE_CHAR:
2083 Lisp_Object charset;
2086 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2087 if (EQ (charset, Vcharset_ascii))
2088 ct->ascii[byte1] = val;
2089 else if (EQ (charset, Vcharset_control_1))
2090 ct->ascii[byte1 + 128] = val;
2093 Lisp_Char_Table_Entry *cte;
2094 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2095 /* make sure that there is a separate entry for the row. */
2096 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2097 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2098 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2099 /* now CTE is a char table entry for the charset;
2100 each entry is for a single row (or character of
2101 a one-octet charset). */
2102 if (XCHARSET_DIMENSION (charset) == 1)
2103 cte->level2[byte1 - 32] = val;
2106 /* assigning to one character in a two-octet charset. */
2107 /* make sure that the charset row contains a separate
2108 entry for each character. */
2109 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2110 cte->level2[byte1 - 32] =
2111 make_char_table_entry (cte->level2[byte1 - 32]);
2112 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2113 cte->level2[byte2 - 32] = val;
2117 #else /* not MULE */
2118 ct->ascii[(unsigned char) (range->ch)] = val;
2120 #endif /* not MULE */
2123 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2124 update_syntax_table (ct);
2127 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2128 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2130 RANGE specifies one or more characters to be affected and should be
2131 one of the following:
2133 -- t (all characters are affected)
2134 -- A charset (only allowed when Mule support is present)
2135 -- A vector of two elements: a two-octet charset and a row number
2136 (only allowed when Mule support is present)
2137 -- A single character
2139 VALUE must be a value appropriate for the type of CHAR-TABLE.
2140 See `valid-char-table-type-p'.
2142 (range, value, char_table))
2144 Lisp_Char_Table *ct;
2145 struct chartab_range rainj;
2147 CHECK_CHAR_TABLE (char_table);
2148 ct = XCHAR_TABLE (char_table);
2149 check_valid_char_table_value (value, ct->type, ERROR_ME);
2150 decode_char_table_range (range, &rainj);
2151 value = canonicalize_char_table_value (value, ct->type);
2152 put_char_table (ct, &rainj, value);
2156 /* Map FN over the ASCII chars in CT. */
2159 map_over_charset_ascii (Lisp_Char_Table *ct,
2160 int (*fn) (struct chartab_range *range,
2161 Lisp_Object val, void *arg),
2164 struct chartab_range rainj;
2173 rainj.type = CHARTAB_RANGE_CHAR;
2175 for (i = start, retval = 0; i < stop && retval == 0; i++)
2177 rainj.ch = (Emchar) i;
2178 retval = (fn) (&rainj, ct->ascii[i], arg);
2186 /* Map FN over the Control-1 chars in CT. */
2189 map_over_charset_control_1 (Lisp_Char_Table *ct,
2190 int (*fn) (struct chartab_range *range,
2191 Lisp_Object val, void *arg),
2194 struct chartab_range rainj;
2197 int stop = start + 32;
2199 rainj.type = CHARTAB_RANGE_CHAR;
2201 for (i = start, retval = 0; i < stop && retval == 0; i++)
2203 rainj.ch = (Emchar) (i);
2204 retval = (fn) (&rainj, ct->ascii[i], arg);
2210 /* Map FN over the row ROW of two-byte charset CHARSET.
2211 There must be a separate value for that row in the char table.
2212 CTE specifies the char table entry for CHARSET. */
2215 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2216 Lisp_Object charset, int row,
2217 int (*fn) (struct chartab_range *range,
2218 Lisp_Object val, void *arg),
2221 Lisp_Object val = cte->level2[row - 32];
2223 if (!CHAR_TABLE_ENTRYP (val))
2225 struct chartab_range rainj;
2227 rainj.type = CHARTAB_RANGE_ROW;
2228 rainj.charset = charset;
2230 return (fn) (&rainj, val, arg);
2234 struct chartab_range rainj;
2236 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2237 int start = charset94_p ? 33 : 32;
2238 int stop = charset94_p ? 127 : 128;
2240 cte = XCHAR_TABLE_ENTRY (val);
2242 rainj.type = CHARTAB_RANGE_CHAR;
2244 for (i = start, retval = 0; i < stop && retval == 0; i++)
2246 rainj.ch = MAKE_CHAR (charset, row, i);
2247 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2255 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2256 int (*fn) (struct chartab_range *range,
2257 Lisp_Object val, void *arg),
2260 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2261 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2263 if (!CHARSETP (charset)
2264 || lb == LEADING_BYTE_ASCII
2265 || lb == LEADING_BYTE_CONTROL_1)
2268 if (!CHAR_TABLE_ENTRYP (val))
2270 struct chartab_range rainj;
2272 rainj.type = CHARTAB_RANGE_CHARSET;
2273 rainj.charset = charset;
2274 return (fn) (&rainj, val, arg);
2278 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2279 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2280 int start = charset94_p ? 33 : 32;
2281 int stop = charset94_p ? 127 : 128;
2284 if (XCHARSET_DIMENSION (charset) == 1)
2286 struct chartab_range rainj;
2287 rainj.type = CHARTAB_RANGE_CHAR;
2289 for (i = start, retval = 0; i < stop && retval == 0; i++)
2291 rainj.ch = MAKE_CHAR (charset, i, 0);
2292 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2297 for (i = start, retval = 0; i < stop && retval == 0; i++)
2298 retval = map_over_charset_row (cte, charset, i, fn, arg);
2307 /* Map FN (with client data ARG) over range RANGE in char table CT.
2308 Mapping stops the first time FN returns non-zero, and that value
2309 becomes the return value of map_char_table(). */
2312 map_char_table (Lisp_Char_Table *ct,
2313 struct chartab_range *range,
2314 int (*fn) (struct chartab_range *range,
2315 Lisp_Object val, void *arg),
2318 switch (range->type)
2320 case CHARTAB_RANGE_ALL:
2324 retval = map_over_charset_ascii (ct, fn, arg);
2328 retval = map_over_charset_control_1 (ct, fn, arg);
2333 Charset_ID start = MIN_LEADING_BYTE;
2334 Charset_ID stop = start + NUM_LEADING_BYTES;
2336 for (i = start, retval = 0; i < stop && retval == 0; i++)
2338 retval = map_over_other_charset (ct, i, fn, arg);
2346 case CHARTAB_RANGE_CHARSET:
2347 return map_over_other_charset (ct,
2348 XCHARSET_LEADING_BYTE (range->charset),
2351 case CHARTAB_RANGE_ROW:
2353 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2354 - MIN_LEADING_BYTE];
2355 if (!CHAR_TABLE_ENTRYP (val))
2357 struct chartab_range rainj;
2359 rainj.type = CHARTAB_RANGE_ROW;
2360 rainj.charset = range->charset;
2361 rainj.row = range->row;
2362 return (fn) (&rainj, val, arg);
2365 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2366 range->charset, range->row,
2371 case CHARTAB_RANGE_CHAR:
2373 Emchar ch = range->ch;
2374 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2375 struct chartab_range rainj;
2377 rainj.type = CHARTAB_RANGE_CHAR;
2379 return (fn) (&rainj, val, arg);
2389 struct slow_map_char_table_arg
2391 Lisp_Object function;
2396 slow_map_char_table_fun (struct chartab_range *range,
2397 Lisp_Object val, void *arg)
2399 Lisp_Object ranjarg = Qnil;
2400 struct slow_map_char_table_arg *closure =
2401 (struct slow_map_char_table_arg *) arg;
2403 switch (range->type)
2405 case CHARTAB_RANGE_ALL:
2410 case CHARTAB_RANGE_CHARSET:
2411 ranjarg = XCHARSET_NAME (range->charset);
2414 case CHARTAB_RANGE_ROW:
2415 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2416 make_int (range->row));
2419 case CHARTAB_RANGE_CHAR:
2420 ranjarg = make_char (range->ch);
2426 closure->retval = call2 (closure->function, ranjarg, val);
2427 return !NILP (closure->retval);
2430 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2431 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2432 each key and value in the table.
2434 RANGE specifies a subrange to map over and is in the same format as
2435 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2438 (function, char_table, range))
2440 Lisp_Char_Table *ct;
2441 struct slow_map_char_table_arg slarg;
2442 struct gcpro gcpro1, gcpro2;
2443 struct chartab_range rainj;
2445 CHECK_CHAR_TABLE (char_table);
2446 ct = XCHAR_TABLE (char_table);
2449 decode_char_table_range (range, &rainj);
2450 slarg.function = function;
2451 slarg.retval = Qnil;
2452 GCPRO2 (slarg.function, slarg.retval);
2453 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2456 return slarg.retval;
2460 /************************************************************************/
2461 /* Character Attributes */
2462 /************************************************************************/
2466 Lisp_Object Vchar_attribute_hash_table;
2468 /* We store the char-attributes in hash tables with the names as the
2469 key and the actual char-id-table object as the value. Occasionally
2470 we need to use them in a list format. These routines provide us
2472 struct char_attribute_list_closure
2474 Lisp_Object *char_attribute_list;
2478 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
2479 void *char_attribute_list_closure)
2481 /* This function can GC */
2482 struct char_attribute_list_closure *calcl
2483 = (struct char_attribute_list_closure*) char_attribute_list_closure;
2484 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
2486 *char_attribute_list = Fcons (key, *char_attribute_list);
2490 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
2491 Return the list of all existing character attributes except coded-charsets.
2495 Lisp_Object char_attribute_list = Qnil;
2496 struct gcpro gcpro1;
2497 struct char_attribute_list_closure char_attribute_list_closure;
2499 GCPRO1 (char_attribute_list);
2500 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
2501 elisp_maphash (add_char_attribute_to_list_mapper,
2502 Vchar_attribute_hash_table,
2503 &char_attribute_list_closure);
2505 return char_attribute_list;
2508 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
2509 Return char-id-table corresponding to ATTRIBUTE.
2513 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
2517 /* We store the char-id-tables in hash tables with the attributes as
2518 the key and the actual char-id-table object as the value. Each
2519 char-id-table stores values of an attribute corresponding with
2520 characters. Occasionally we need to get attributes of a character
2521 in a association-list format. These routines provide us with
2523 struct char_attribute_alist_closure
2526 Lisp_Object *char_attribute_alist;
2530 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
2531 void *char_attribute_alist_closure)
2533 /* This function can GC */
2534 struct char_attribute_alist_closure *caacl =
2535 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
2536 Lisp_Object ret = get_char_id_table (caacl->char_id, value);
2537 if (!UNBOUNDP (ret))
2539 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
2540 *char_attribute_alist
2541 = Fcons (Fcons (key, ret), *char_attribute_alist);
2546 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
2547 Return the alist of attributes of CHARACTER.
2551 Lisp_Object alist = Qnil;
2554 CHECK_CHAR (character);
2556 struct gcpro gcpro1;
2557 struct char_attribute_alist_closure char_attribute_alist_closure;
2560 char_attribute_alist_closure.char_id = XCHAR (character);
2561 char_attribute_alist_closure.char_attribute_alist = &alist;
2562 elisp_maphash (add_char_attribute_alist_mapper,
2563 Vchar_attribute_hash_table,
2564 &char_attribute_alist_closure);
2568 for (i = 0; i < countof (chlook->charset_by_leading_byte); i++)
2570 Lisp_Object ccs = chlook->charset_by_leading_byte[i];
2574 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
2577 if ( CHAR_ID_TABLE_P (encoding_table)
2578 && INTP (cpos = get_char_id_table (XCHAR (character),
2581 alist = Fcons (Fcons (ccs, cpos), alist);
2588 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
2589 Return the value of CHARACTER's ATTRIBUTE.
2590 Return DEFAULT-VALUE if the value is not exist.
2592 (character, attribute, default_value))
2596 CHECK_CHAR (character);
2597 if (!NILP (ccs = Ffind_charset (attribute)))
2599 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
2601 if (CHAR_ID_TABLE_P (encoding_table))
2602 return get_char_id_table (XCHAR (character), encoding_table);
2606 Lisp_Object table = Fgethash (attribute,
2607 Vchar_attribute_hash_table,
2609 if (!UNBOUNDP (table))
2611 Lisp_Object ret = get_char_id_table (XCHAR (character), table);
2612 if (!UNBOUNDP (ret))
2616 return default_value;
2619 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
2620 Store CHARACTER's ATTRIBUTE with VALUE.
2622 (character, attribute, value))
2626 CHECK_CHAR (character);
2627 ccs = Ffind_charset (attribute);
2630 return put_char_ccs_code_point (character, ccs, value);
2632 else if (EQ (attribute, Q_decomposition))
2637 signal_simple_error ("Invalid value for ->decomposition",
2640 if (CONSP (Fcdr (value)))
2642 Lisp_Object rest = value;
2643 Lisp_Object table = Vcharacter_composition_table;
2647 GET_EXTERNAL_LIST_LENGTH (rest, len);
2648 seq = make_vector (len, Qnil);
2650 while (CONSP (rest))
2652 Lisp_Object v = Fcar (rest);
2655 = to_char_id (v, "Invalid value for ->decomposition", value);
2658 XVECTOR_DATA(seq)[i++] = v;
2660 XVECTOR_DATA(seq)[i++] = make_char (c);
2664 put_char_id_table (c, character, table);
2669 ntable = get_char_id_table (c, table);
2670 if (!CHAR_ID_TABLE_P (ntable))
2672 ntable = make_char_id_table (Qnil);
2673 put_char_id_table (c, ntable, table);
2681 Lisp_Object v = Fcar (value);
2685 Emchar c = XINT (v);
2687 = get_char_id_table (c, Vcharacter_variant_table);
2689 if (NILP (Fmemq (v, ret)))
2691 put_char_id_table (c, Fcons (character, ret),
2692 Vcharacter_variant_table);
2695 seq = make_vector (1, v);
2699 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
2705 signal_simple_error ("Invalid value for ->ucs", value);
2709 ret = get_char_id_table (c, Vcharacter_variant_table);
2710 if (NILP (Fmemq (character, ret)))
2712 put_char_id_table (c, Fcons (character, ret),
2713 Vcharacter_variant_table);
2716 if (EQ (attribute, Q_ucs))
2717 attribute = Qto_ucs;
2721 Lisp_Object table = Fgethash (attribute,
2722 Vchar_attribute_hash_table,
2727 table = make_char_id_table (Qunbound);
2728 Fputhash (attribute, table, Vchar_attribute_hash_table);
2730 put_char_id_table (XCHAR (character), value, table);
2735 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
2736 Remove CHARACTER's ATTRIBUTE.
2738 (character, attribute))
2742 CHECK_CHAR (character);
2743 ccs = Ffind_charset (attribute);
2746 return remove_char_ccs (character, ccs);
2750 Lisp_Object table = Fgethash (attribute,
2751 Vchar_attribute_hash_table,
2753 if (!UNBOUNDP (table))
2755 put_char_id_table (XCHAR (character), Qunbound, table);
2762 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 2, 0, /*
2763 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
2764 each key and value in the table.
2766 (function, attribute))
2769 Lisp_Char_ID_Table *ct;
2770 struct slow_map_char_table_arg slarg;
2771 struct gcpro gcpro1, gcpro2;
2773 if (!NILP (ccs = Ffind_charset (attribute)))
2775 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
2777 if (CHAR_ID_TABLE_P (encoding_table))
2778 ct = XCHAR_ID_TABLE (encoding_table);
2784 Lisp_Object table = Fgethash (attribute,
2785 Vchar_attribute_hash_table,
2787 if (CHAR_ID_TABLE_P (table))
2788 ct = XCHAR_ID_TABLE (table);
2792 slarg.function = function;
2793 slarg.retval = Qnil;
2794 GCPRO2 (slarg.function, slarg.retval);
2795 map_char_id_table (ct, slow_map_char_table_fun, &slarg);
2798 return slarg.retval;
2801 EXFUN (Fmake_char, 3);
2802 EXFUN (Fdecode_char, 2);
2804 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
2805 Store character's ATTRIBUTES.
2809 Lisp_Object rest = attributes;
2810 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
2811 Lisp_Object character;
2815 while (CONSP (rest))
2817 Lisp_Object cell = Fcar (rest);
2821 signal_simple_error ("Invalid argument", attributes);
2822 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
2823 && ((XCHARSET_FINAL (ccs) != 0) ||
2824 (XCHARSET_UCS_MAX (ccs) > 0)) )
2828 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
2830 character = Fdecode_char (ccs, cell);
2831 if (!NILP (character))
2832 goto setup_attributes;
2836 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
2837 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
2841 signal_simple_error ("Invalid argument", attributes);
2843 character = make_char (XINT (code) + 0x100000);
2844 goto setup_attributes;
2848 else if (!INTP (code))
2849 signal_simple_error ("Invalid argument", attributes);
2851 character = make_char (XINT (code));
2855 while (CONSP (rest))
2857 Lisp_Object cell = Fcar (rest);
2860 signal_simple_error ("Invalid argument", attributes);
2862 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
2868 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
2869 Retrieve the character of the given ATTRIBUTES.
2873 Lisp_Object rest = attributes;
2876 while (CONSP (rest))
2878 Lisp_Object cell = Fcar (rest);
2882 signal_simple_error ("Invalid argument", attributes);
2883 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
2887 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
2889 return Fdecode_char (ccs, cell);
2893 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
2894 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
2897 signal_simple_error ("Invalid argument", attributes);
2899 return make_char (XINT (code) + 0x100000);
2907 /************************************************************************/
2908 /* Char table read syntax */
2909 /************************************************************************/
2912 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
2913 Error_behavior errb)
2915 /* #### should deal with ERRB */
2916 symbol_to_char_table_type (value);
2921 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
2922 Error_behavior errb)
2926 /* #### should deal with ERRB */
2927 EXTERNAL_LIST_LOOP (rest, value)
2929 Lisp_Object range = XCAR (rest);
2930 struct chartab_range dummy;
2934 signal_simple_error ("Invalid list format", value);
2937 if (!CONSP (XCDR (range))
2938 || !NILP (XCDR (XCDR (range))))
2939 signal_simple_error ("Invalid range format", range);
2940 decode_char_table_range (XCAR (range), &dummy);
2941 decode_char_table_range (XCAR (XCDR (range)), &dummy);
2944 decode_char_table_range (range, &dummy);
2951 chartab_instantiate (Lisp_Object data)
2953 Lisp_Object chartab;
2954 Lisp_Object type = Qgeneric;
2955 Lisp_Object dataval = Qnil;
2957 while (!NILP (data))
2959 Lisp_Object keyw = Fcar (data);
2965 if (EQ (keyw, Qtype))
2967 else if (EQ (keyw, Qdata))
2971 chartab = Fmake_char_table (type);
2974 while (!NILP (data))
2976 Lisp_Object range = Fcar (data);
2977 Lisp_Object val = Fcar (Fcdr (data));
2979 data = Fcdr (Fcdr (data));
2982 if (CHAR_OR_CHAR_INTP (XCAR (range)))
2984 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
2985 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
2988 for (i = first; i <= last; i++)
2989 Fput_char_table (make_char (i), val, chartab);
2995 Fput_char_table (range, val, chartab);
3004 /************************************************************************/
3005 /* Category Tables, specifically */
3006 /************************************************************************/
3008 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3009 Return t if OBJECT is a category table.
3010 A category table is a type of char table used for keeping track of
3011 categories. Categories are used for classifying characters for use
3012 in regexps -- you can refer to a category rather than having to use
3013 a complicated [] expression (and category lookups are significantly
3016 There are 95 different categories available, one for each printable
3017 character (including space) in the ASCII charset. Each category
3018 is designated by one such character, called a "category designator".
3019 They are specified in a regexp using the syntax "\\cX", where X is
3020 a category designator.
3022 A category table specifies, for each character, the categories that
3023 the character is in. Note that a character can be in more than one
3024 category. More specifically, a category table maps from a character
3025 to either the value nil (meaning the character is in no categories)
3026 or a 95-element bit vector, specifying for each of the 95 categories
3027 whether the character is in that category.
3029 Special Lisp functions are provided that abstract this, so you do not
3030 have to directly manipulate bit vectors.
3034 return (CHAR_TABLEP (object) &&
3035 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3040 check_category_table (Lisp_Object object, Lisp_Object default_)
3044 while (NILP (Fcategory_table_p (object)))
3045 object = wrong_type_argument (Qcategory_table_p, object);
3050 check_category_char (Emchar ch, Lisp_Object table,
3051 unsigned int designator, unsigned int not)
3053 REGISTER Lisp_Object temp;
3054 Lisp_Char_Table *ctbl;
3055 #ifdef ERROR_CHECK_TYPECHECK
3056 if (NILP (Fcategory_table_p (table)))
3057 signal_simple_error ("Expected category table", table);
3059 ctbl = XCHAR_TABLE (table);
3060 temp = get_char_table (ch, ctbl);
3065 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
3068 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3069 Return t if category of the character at POSITION includes DESIGNATOR.
3070 Optional third arg BUFFER specifies which buffer to use, and defaults
3071 to the current buffer.
3072 Optional fourth arg CATEGORY-TABLE specifies the category table to
3073 use, and defaults to BUFFER's category table.
3075 (position, designator, buffer, category_table))
3080 struct buffer *buf = decode_buffer (buffer, 0);
3082 CHECK_INT (position);
3083 CHECK_CATEGORY_DESIGNATOR (designator);
3084 des = XCHAR (designator);
3085 ctbl = check_category_table (category_table, Vstandard_category_table);
3086 ch = BUF_FETCH_CHAR (buf, XINT (position));
3087 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3090 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3091 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3092 Optional third arg CATEGORY-TABLE specifies the category table to use,
3093 and defaults to the standard category table.
3095 (character, designator, category_table))
3101 CHECK_CATEGORY_DESIGNATOR (designator);
3102 des = XCHAR (designator);
3103 CHECK_CHAR (character);
3104 ch = XCHAR (character);
3105 ctbl = check_category_table (category_table, Vstandard_category_table);
3106 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3109 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3110 Return BUFFER's current category table.
3111 BUFFER defaults to the current buffer.
3115 return decode_buffer (buffer, 0)->category_table;
3118 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3119 Return the standard category table.
3120 This is the one used for new buffers.
3124 return Vstandard_category_table;
3127 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3128 Return a new category table which is a copy of CATEGORY-TABLE.
3129 CATEGORY-TABLE defaults to the standard category table.
3133 if (NILP (Vstandard_category_table))
3134 return Fmake_char_table (Qcategory);
3137 check_category_table (category_table, Vstandard_category_table);
3138 return Fcopy_char_table (category_table);
3141 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3142 Select CATEGORY-TABLE as the new category table for BUFFER.
3143 BUFFER defaults to the current buffer if omitted.
3145 (category_table, buffer))
3147 struct buffer *buf = decode_buffer (buffer, 0);
3148 category_table = check_category_table (category_table, Qnil);
3149 buf->category_table = category_table;
3150 /* Indicate that this buffer now has a specified category table. */
3151 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3152 return category_table;
3155 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3156 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3160 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3163 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3164 Return t if OBJECT is a category table value.
3165 Valid values are nil or a bit vector of size 95.
3169 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3173 #define CATEGORYP(x) \
3174 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3176 #define CATEGORY_SET(c) \
3177 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3179 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3180 The faster version of `!NILP (Faref (category_set, category))'. */
3181 #define CATEGORY_MEMBER(category, category_set) \
3182 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3184 /* Return 1 if there is a word boundary between two word-constituent
3185 characters C1 and C2 if they appear in this order, else return 0.
3186 Use the macro WORD_BOUNDARY_P instead of calling this function
3189 int word_boundary_p (Emchar c1, Emchar c2);
3191 word_boundary_p (Emchar c1, Emchar c2)
3193 Lisp_Object category_set1, category_set2;
3198 if (COMPOSITE_CHAR_P (c1))
3199 c1 = cmpchar_component (c1, 0, 1);
3200 if (COMPOSITE_CHAR_P (c2))
3201 c2 = cmpchar_component (c2, 0, 1);
3204 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3206 tail = Vword_separating_categories;
3211 tail = Vword_combining_categories;
3215 category_set1 = CATEGORY_SET (c1);
3216 if (NILP (category_set1))
3217 return default_result;
3218 category_set2 = CATEGORY_SET (c2);
3219 if (NILP (category_set2))
3220 return default_result;
3222 for (; CONSP (tail); tail = XCONS (tail)->cdr)
3224 Lisp_Object elt = XCONS(tail)->car;
3227 && CATEGORYP (XCONS (elt)->car)
3228 && CATEGORYP (XCONS (elt)->cdr)
3229 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3230 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3231 return !default_result;
3233 return default_result;
3239 syms_of_chartab (void)
3242 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3243 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3244 INIT_LRECORD_IMPLEMENTATION (byte_table);
3245 INIT_LRECORD_IMPLEMENTATION (char_id_table);
3247 defsymbol (&Qto_ucs, "=>ucs");
3248 defsymbol (&Q_ucs, "->ucs");
3249 defsymbol (&Q_decomposition, "->decomposition");
3250 defsymbol (&Qcompat, "compat");
3251 defsymbol (&Qisolated, "isolated");
3252 defsymbol (&Qinitial, "initial");
3253 defsymbol (&Qmedial, "medial");
3254 defsymbol (&Qfinal, "final");
3255 defsymbol (&Qvertical, "vertical");
3256 defsymbol (&QnoBreak, "noBreak");
3257 defsymbol (&Qfraction, "fraction");
3258 defsymbol (&Qsuper, "super");
3259 defsymbol (&Qsub, "sub");
3260 defsymbol (&Qcircle, "circle");
3261 defsymbol (&Qsquare, "square");
3262 defsymbol (&Qwide, "wide");
3263 defsymbol (&Qnarrow, "narrow");
3264 defsymbol (&Qsmall, "small");
3265 defsymbol (&Qfont, "font");
3267 DEFSUBR (Fchar_attribute_list);
3268 DEFSUBR (Ffind_char_attribute_table);
3269 DEFSUBR (Fchar_attribute_alist);
3270 DEFSUBR (Fget_char_attribute);
3271 DEFSUBR (Fput_char_attribute);
3272 DEFSUBR (Fremove_char_attribute);
3273 DEFSUBR (Fmap_char_attribute);
3274 DEFSUBR (Fdefine_char);
3275 DEFSUBR (Ffind_char);
3276 DEFSUBR (Fchar_variants);
3278 DEFSUBR (Fget_composite_char);
3281 INIT_LRECORD_IMPLEMENTATION (char_table);
3284 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3286 defsymbol (&Qcategory_table_p, "category-table-p");
3287 defsymbol (&Qcategory_designator_p, "category-designator-p");
3288 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3291 defsymbol (&Qchar_table, "char-table");
3292 defsymbol (&Qchar_tablep, "char-table-p");
3294 DEFSUBR (Fchar_table_p);
3295 DEFSUBR (Fchar_table_type_list);
3296 DEFSUBR (Fvalid_char_table_type_p);
3297 DEFSUBR (Fchar_table_type);
3298 DEFSUBR (Freset_char_table);
3299 DEFSUBR (Fmake_char_table);
3300 DEFSUBR (Fcopy_char_table);
3301 DEFSUBR (Fget_char_table);
3302 DEFSUBR (Fget_range_char_table);
3303 DEFSUBR (Fvalid_char_table_value_p);
3304 DEFSUBR (Fcheck_valid_char_table_value);
3305 DEFSUBR (Fput_char_table);
3306 DEFSUBR (Fmap_char_table);
3309 DEFSUBR (Fcategory_table_p);
3310 DEFSUBR (Fcategory_table);
3311 DEFSUBR (Fstandard_category_table);
3312 DEFSUBR (Fcopy_category_table);
3313 DEFSUBR (Fset_category_table);
3314 DEFSUBR (Fcheck_category_at);
3315 DEFSUBR (Fchar_in_category_p);
3316 DEFSUBR (Fcategory_designator_p);
3317 DEFSUBR (Fcategory_table_value_p);
3323 vars_of_chartab (void)
3326 Vutf_2000_version = build_string("0.17 (Hōryūji)");
3327 DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3328 Version number of XEmacs UTF-2000.
3331 staticpro (&Vcharacter_composition_table);
3332 Vcharacter_composition_table = make_char_id_table (Qnil);
3334 staticpro (&Vcharacter_variant_table);
3335 Vcharacter_variant_table = make_char_id_table (Qnil);
3337 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
3338 Vall_syntax_tables = Qnil;
3339 dump_add_weak_object_chain (&Vall_syntax_tables);
3343 structure_type_create_chartab (void)
3345 struct structure_type *st;
3347 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3349 define_structure_type_keyword (st, Qtype, chartab_type_validate);
3350 define_structure_type_keyword (st, Qdata, chartab_data_validate);
3354 complex_vars_of_chartab (void)
3357 staticpro (&Vchar_attribute_hash_table);
3358 Vchar_attribute_hash_table
3359 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3360 #endif /* UTF2000 */
3362 /* Set this now, so first buffer creation can refer to it. */
3363 /* Make it nil before calling copy-category-table
3364 so that copy-category-table will know not to try to copy from garbage */
3365 Vstandard_category_table = Qnil;
3366 Vstandard_category_table = Fcopy_category_table (Qnil);
3367 staticpro (&Vstandard_category_table);
3369 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3370 List of pair (cons) of categories to determine word boundary.
3372 Emacs treats a sequence of word constituent characters as a single
3373 word (i.e. finds no word boundary between them) iff they belongs to
3374 the same charset. But, exceptions are allowed in the following cases.
3376 \(1) The case that characters are in different charsets is controlled
3377 by the variable `word-combining-categories'.
3379 Emacs finds no word boundary between characters of different charsets
3380 if they have categories matching some element of this list.
3382 More precisely, if an element of this list is a cons of category CAT1
3383 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3384 C2 which has CAT2, there's no word boundary between C1 and C2.
3386 For instance, to tell that ASCII characters and Latin-1 characters can
3387 form a single word, the element `(?l . ?l)' should be in this list
3388 because both characters have the category `l' (Latin characters).
3390 \(2) The case that character are in the same charset is controlled by
3391 the variable `word-separating-categories'.
3393 Emacs find a word boundary between characters of the same charset
3394 if they have categories matching some element of this list.
3396 More precisely, if an element of this list is a cons of category CAT1
3397 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3398 C2 which has CAT2, there's a word boundary between C1 and C2.
3400 For instance, to tell that there's a word boundary between Japanese
3401 Hiragana and Japanese Kanji (both are in the same charset), the
3402 element `(?H . ?C) should be in this list.
3405 Vword_combining_categories = Qnil;
3407 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3408 List of pair (cons) of categories to determine word boundary.
3409 See the documentation of the variable `word-combining-categories'.
3412 Vword_separating_categories = Qnil;