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, Emchar ofs, int place,
235 int (*fn) (struct chartab_range *range,
236 Lisp_Object val, void *arg),
239 struct chartab_range rainj;
241 int unit = 1 << (8 * place);
245 rainj.type = CHARTAB_RANGE_CHAR;
247 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
249 if (ct->property[i] != BT_UINT8_unbound)
252 for (; c < c1 && retval == 0; c++)
254 if ( NILP (ccs) || charset_code_point (ccs, c) >= 0 )
257 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
267 #define BT_UINT16_MIN 0
268 #define BT_UINT16_MAX (USHRT_MAX - 3)
269 #define BT_UINT16_t (USHRT_MAX - 2)
270 #define BT_UINT16_nil (USHRT_MAX - 1)
271 #define BT_UINT16_unbound USHRT_MAX
273 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
274 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
275 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
276 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
279 INT_UINT16_P (Lisp_Object obj)
283 int num = XINT (obj);
285 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
292 UINT16_VALUE_P (Lisp_Object obj)
294 return EQ (obj, Qunbound)
295 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
298 INLINE_HEADER unsigned short
299 UINT16_ENCODE (Lisp_Object obj)
301 if (EQ (obj, Qunbound))
302 return BT_UINT16_unbound;
303 else if (EQ (obj, Qnil))
304 return BT_UINT16_nil;
305 else if (EQ (obj, Qt))
311 INLINE_HEADER Lisp_Object
312 UINT16_DECODE (unsigned short n)
314 if (n == BT_UINT16_unbound)
316 else if (n == BT_UINT16_nil)
318 else if (n == BT_UINT16_t)
324 INLINE_HEADER unsigned short
325 UINT8_TO_UINT16 (unsigned char n)
327 if (n == BT_UINT8_unbound)
328 return BT_UINT16_unbound;
329 else if (n == BT_UINT8_nil)
330 return BT_UINT16_nil;
331 else if (n == BT_UINT8_t)
338 mark_uint16_byte_table (Lisp_Object obj)
344 print_uint16_byte_table (Lisp_Object obj,
345 Lisp_Object printcharfun, int escapeflag)
347 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
349 struct gcpro gcpro1, gcpro2;
350 GCPRO2 (obj, printcharfun);
352 write_c_string ("\n#<uint16-byte-table", printcharfun);
353 for (i = 0; i < 256; i++)
355 unsigned short n = bte->property[i];
357 write_c_string ("\n ", printcharfun);
358 write_c_string (" ", printcharfun);
359 if (n == BT_UINT16_unbound)
360 write_c_string ("void", printcharfun);
361 else if (n == BT_UINT16_nil)
362 write_c_string ("nil", printcharfun);
363 else if (n == BT_UINT16_t)
364 write_c_string ("t", printcharfun);
369 sprintf (buf, "%hd", n);
370 write_c_string (buf, printcharfun);
374 write_c_string (">", printcharfun);
378 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
380 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
381 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
384 for (i = 0; i < 256; i++)
385 if (te1->property[i] != te2->property[i])
391 uint16_byte_table_hash (Lisp_Object obj, int depth)
393 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
397 for (i = 0; i < 256; i++)
398 hash = HASH2 (hash, te->property[i]);
402 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
403 mark_uint16_byte_table,
404 print_uint16_byte_table,
405 0, uint16_byte_table_equal,
406 uint16_byte_table_hash,
407 0 /* uint16_byte_table_description */,
408 Lisp_Uint16_Byte_Table);
411 make_uint16_byte_table (unsigned short initval)
415 Lisp_Uint16_Byte_Table *cte;
417 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
418 &lrecord_uint16_byte_table);
420 for (i = 0; i < 256; i++)
421 cte->property[i] = initval;
423 XSETUINT16_BYTE_TABLE (obj, cte);
428 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
432 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
433 Lisp_Uint16_Byte_Table* cte;
435 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
436 &lrecord_uint16_byte_table);
437 for (i = 0; i < 256; i++)
439 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
441 XSETUINT16_BYTE_TABLE (obj, cte);
446 uint16_byte_table_same_value_p (Lisp_Object obj)
448 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
449 unsigned short v0 = bte->property[0];
452 for (i = 1; i < 256; i++)
454 if (bte->property[i] != v0)
461 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place,
463 int (*fn) (struct chartab_range *range,
464 Lisp_Object val, void *arg),
467 struct chartab_range rainj;
469 int unit = 1 << (8 * place);
473 rainj.type = CHARTAB_RANGE_CHAR;
475 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
477 if (ct->property[i] != BT_UINT16_unbound)
480 for (; c < c1 && retval == 0; c++)
482 if ( NILP (ccs) || charset_code_point (ccs, c) >= 0 )
485 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]),
498 mark_byte_table (Lisp_Object obj)
500 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
503 for (i = 0; i < 256; i++)
505 mark_object (cte->property[i]);
511 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
513 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
515 struct gcpro gcpro1, gcpro2;
516 GCPRO2 (obj, printcharfun);
518 write_c_string ("\n#<byte-table", printcharfun);
519 for (i = 0; i < 256; i++)
521 Lisp_Object elt = bte->property[i];
523 write_c_string ("\n ", printcharfun);
524 write_c_string (" ", printcharfun);
525 if (EQ (elt, Qunbound))
526 write_c_string ("void", printcharfun);
528 print_internal (elt, printcharfun, escapeflag);
531 write_c_string (">", printcharfun);
535 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
537 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
538 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
541 for (i = 0; i < 256; i++)
542 if (BYTE_TABLE_P (cte1->property[i]))
544 if (BYTE_TABLE_P (cte2->property[i]))
546 if (!byte_table_equal (cte1->property[i],
547 cte2->property[i], depth + 1))
554 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
560 byte_table_hash (Lisp_Object obj, int depth)
562 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
564 return internal_array_hash (cte->property, 256, depth);
567 static const struct lrecord_description byte_table_description[] = {
568 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
572 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
577 byte_table_description,
581 make_byte_table (Lisp_Object initval)
585 Lisp_Byte_Table *cte;
587 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
589 for (i = 0; i < 256; i++)
590 cte->property[i] = initval;
592 XSETBYTE_TABLE (obj, cte);
597 byte_table_same_value_p (Lisp_Object obj)
599 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
600 Lisp_Object v0 = bte->property[0];
603 for (i = 1; i < 256; i++)
605 if (!internal_equal (bte->property[i], v0, 0))
612 map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place,
614 int (*fn) (struct chartab_range *range,
615 Lisp_Object val, void *arg),
620 int unit = 1 << (8 * place);
623 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
626 if (UINT8_BYTE_TABLE_P (v))
629 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v),
630 c, place - 1, ccs, fn, arg);
633 else if (UINT16_BYTE_TABLE_P (v))
636 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v),
637 c, place - 1, ccs, fn, arg);
640 else if (BYTE_TABLE_P (v))
642 retval = map_over_byte_table (XBYTE_TABLE(v),
643 c, place - 1, ccs, fn, arg);
646 else if (!UNBOUNDP (v))
648 struct chartab_range rainj;
649 Emchar c1 = c + unit;
651 rainj.type = CHARTAB_RANGE_CHAR;
653 for (; c < c1 && retval == 0; c++)
655 if ( NILP (ccs) || charset_code_point (ccs, c) >= 0 )
658 retval = (fn) (&rainj, v, arg);
669 Lisp_Object get_byte_table (Lisp_Object table, unsigned char idx);
670 Lisp_Object put_byte_table (Lisp_Object table, unsigned char idx,
674 get_byte_table (Lisp_Object table, unsigned char idx)
676 if (UINT8_BYTE_TABLE_P (table))
677 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
678 else if (UINT16_BYTE_TABLE_P (table))
679 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
680 else if (BYTE_TABLE_P (table))
681 return XBYTE_TABLE(table)->property[idx];
687 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
689 if (UINT8_BYTE_TABLE_P (table))
691 if (UINT8_VALUE_P (value))
693 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
694 if (!UINT8_BYTE_TABLE_P (value) &&
695 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
696 && uint8_byte_table_same_value_p (table))
701 else if (UINT16_VALUE_P (value))
703 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
705 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
710 Lisp_Object new = make_byte_table (Qnil);
713 for (i = 0; i < 256; i++)
715 XBYTE_TABLE(new)->property[i]
716 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
718 XBYTE_TABLE(new)->property[idx] = value;
722 else if (UINT16_BYTE_TABLE_P (table))
724 if (UINT16_VALUE_P (value))
726 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
727 if (!UINT8_BYTE_TABLE_P (value) &&
728 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
729 && uint16_byte_table_same_value_p (table))
736 Lisp_Object new = make_byte_table (Qnil);
739 for (i = 0; i < 256; i++)
741 XBYTE_TABLE(new)->property[i]
742 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
744 XBYTE_TABLE(new)->property[idx] = value;
748 else if (BYTE_TABLE_P (table))
750 XBYTE_TABLE(table)->property[idx] = value;
751 if (!UINT8_BYTE_TABLE_P (value) &&
752 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
753 && byte_table_same_value_p (table))
758 else if (!internal_equal (table, value, 0))
760 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
762 table = make_uint8_byte_table (UINT8_ENCODE (table));
763 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
765 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
767 table = make_uint16_byte_table (UINT16_ENCODE (table));
768 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
772 table = make_byte_table (table);
773 XBYTE_TABLE(table)->property[idx] = value;
780 mark_char_id_table (Lisp_Object obj)
782 Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj);
788 print_char_id_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
790 Lisp_Object table = XCHAR_ID_TABLE (obj)->table;
792 struct gcpro gcpro1, gcpro2;
793 GCPRO2 (obj, printcharfun);
795 write_c_string ("#<char-id-table ", printcharfun);
796 for (i = 0; i < 256; i++)
798 Lisp_Object elt = get_byte_table (table, i);
799 if (i != 0) write_c_string ("\n ", printcharfun);
800 if (EQ (elt, Qunbound))
801 write_c_string ("void", printcharfun);
803 print_internal (elt, printcharfun, escapeflag);
806 write_c_string (">", printcharfun);
810 char_id_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
812 Lisp_Object table1 = XCHAR_ID_TABLE (obj1)->table;
813 Lisp_Object table2 = XCHAR_ID_TABLE (obj2)->table;
816 for (i = 0; i < 256; i++)
818 if (!internal_equal (get_byte_table (table1, i),
819 get_byte_table (table2, i), 0))
826 char_id_table_hash (Lisp_Object obj, int depth)
828 Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj);
830 return char_id_table_hash (cte->table, depth + 1);
833 static const struct lrecord_description char_id_table_description[] = {
834 { XD_LISP_OBJECT, offsetof(Lisp_Char_ID_Table, table) },
838 DEFINE_LRECORD_IMPLEMENTATION ("char-id-table", char_id_table,
841 0, char_id_table_equal,
843 char_id_table_description,
847 make_char_id_table (Lisp_Object initval)
850 Lisp_Char_ID_Table *cte;
852 cte = alloc_lcrecord_type (Lisp_Char_ID_Table, &lrecord_char_id_table);
854 cte->table = make_byte_table (initval);
856 XSETCHAR_ID_TABLE (obj, cte);
862 get_char_id_table (Emchar ch, Lisp_Object table)
864 unsigned int code = ch;
871 (XCHAR_ID_TABLE (table)->table,
872 (unsigned char)(code >> 24)),
873 (unsigned char) (code >> 16)),
874 (unsigned char) (code >> 8)),
875 (unsigned char) code);
879 put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table)
881 unsigned int code = ch;
882 Lisp_Object table1, table2, table3, table4;
884 table1 = XCHAR_ID_TABLE (table)->table;
885 table2 = get_byte_table (table1, (unsigned char)(code >> 24));
886 table3 = get_byte_table (table2, (unsigned char)(code >> 16));
887 table4 = get_byte_table (table3, (unsigned char)(code >> 8));
889 table4 = put_byte_table (table4, (unsigned char)code, value);
890 table3 = put_byte_table (table3, (unsigned char)(code >> 8), table4);
891 table2 = put_byte_table (table2, (unsigned char)(code >> 16), table3);
892 XCHAR_ID_TABLE (table)->table
893 = put_byte_table (table1, (unsigned char)(code >> 24), table2);
896 /* Map FN (with client data ARG) in char table CT.
897 Mapping stops the first time FN returns non-zero, and that value
898 becomes the return value of map_char_id_table(). */
900 map_char_id_table (Lisp_Char_ID_Table *ct,
901 struct chartab_range *range,
902 int (*fn) (struct chartab_range *range,
903 Lisp_Object val, void *arg),
906 map_char_id_table (Lisp_Char_ID_Table *ct,
907 struct chartab_range *range,
908 int (*fn) (struct chartab_range *range,
909 Lisp_Object val, void *arg),
912 Lisp_Object v = ct->table;
916 case CHARTAB_RANGE_ALL:
917 if (UINT8_BYTE_TABLE_P (v))
918 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), 0, 3,
920 else if (UINT16_BYTE_TABLE_P (v))
921 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), 0, 3,
923 else if (BYTE_TABLE_P (v))
924 return map_over_byte_table (XBYTE_TABLE(v), 0, 3, Qnil, fn, arg);
925 else if (!UNBOUNDP (v))
927 struct chartab_range rainj;
930 Emchar c1 = c + unit;
933 rainj.type = CHARTAB_RANGE_CHAR;
935 for (retval = 0; c < c1 && retval == 0; c++)
938 retval = (fn) (&rainj, v, arg);
942 case CHARTAB_RANGE_CHARSET:
943 if (UINT8_BYTE_TABLE_P (v))
944 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), 0, 3,
945 range->charset, fn, arg);
946 else if (UINT16_BYTE_TABLE_P (v))
947 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), 0, 3,
948 range->charset, fn, arg);
949 else if (BYTE_TABLE_P (v))
950 return map_over_byte_table (XBYTE_TABLE(v), 0, 3,
951 range->charset, fn, arg);
952 else if (!UNBOUNDP (v))
954 struct chartab_range rainj;
957 Emchar c1 = c + unit;
960 rainj.type = CHARTAB_RANGE_CHAR;
962 for (retval = 0; c < c1 && retval == 0; c++)
964 if ( charset_code_point (range->charset, c) >= 0 )
967 retval = (fn) (&rainj, v, arg);
972 case CHARTAB_RANGE_ROW:
974 int cell_min, cell_max, i;
976 struct chartab_range rainj;
978 if (XCHARSET_DIMENSION (range->charset) < 2)
979 signal_simple_error ("Charset in row vector must be multi-byte",
983 switch (XCHARSET_CHARS (range->charset))
986 cell_min = 33; cell_max = 126;
989 cell_min = 32; cell_max = 127;
992 cell_min = 0; cell_max = 127;
995 cell_min = 0; cell_max = 255;
1001 if (XCHARSET_DIMENSION (range->charset) == 2)
1002 check_int_range (range->row, cell_min, cell_max);
1003 else if (XCHARSET_DIMENSION (range->charset) == 3)
1005 check_int_range (range->row >> 8 , cell_min, cell_max);
1006 check_int_range (range->row & 0xFF, cell_min, cell_max);
1008 else if (XCHARSET_DIMENSION (range->charset) == 4)
1010 check_int_range ( range->row >> 16 , cell_min, cell_max);
1011 check_int_range ((range->row >> 8) & 0xFF, cell_min, cell_max);
1012 check_int_range ( range->row & 0xFF, cell_min, cell_max);
1017 rainj.type = CHARTAB_RANGE_CHAR;
1018 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
1020 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
1022 = get_byte_table (get_byte_table
1026 (unsigned char)(ch >> 24)),
1027 (unsigned char) (ch >> 16)),
1028 (unsigned char) (ch >> 8)),
1029 (unsigned char) ch);
1031 if (!UNBOUNDP (val))
1034 retval = (fn) (&rainj, val, arg);
1039 case CHARTAB_RANGE_CHAR:
1041 Emchar ch = range->ch;
1043 = get_byte_table (get_byte_table
1047 (unsigned char)(ch >> 24)),
1048 (unsigned char) (ch >> 16)),
1049 (unsigned char) (ch >> 8)),
1050 (unsigned char) ch);
1051 struct chartab_range rainj;
1053 if (!UNBOUNDP (val))
1055 rainj.type = CHARTAB_RANGE_CHAR;
1057 return (fn) (&rainj, val, arg);
1069 Lisp_Object Vcharacter_composition_table;
1070 Lisp_Object Vcharacter_variant_table;
1073 Lisp_Object Q_decomposition;
1074 Lisp_Object Qto_ucs;
1076 Lisp_Object Qcompat;
1077 Lisp_Object Qisolated;
1078 Lisp_Object Qinitial;
1079 Lisp_Object Qmedial;
1081 Lisp_Object Qvertical;
1082 Lisp_Object QnoBreak;
1083 Lisp_Object Qfraction;
1086 Lisp_Object Qcircle;
1087 Lisp_Object Qsquare;
1089 Lisp_Object Qnarrow;
1093 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
1096 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
1102 else if (EQ (v, Qcompat))
1104 else if (EQ (v, Qisolated))
1106 else if (EQ (v, Qinitial))
1108 else if (EQ (v, Qmedial))
1110 else if (EQ (v, Qfinal))
1112 else if (EQ (v, Qvertical))
1114 else if (EQ (v, QnoBreak))
1116 else if (EQ (v, Qfraction))
1118 else if (EQ (v, Qsuper))
1120 else if (EQ (v, Qsub))
1122 else if (EQ (v, Qcircle))
1124 else if (EQ (v, Qsquare))
1126 else if (EQ (v, Qwide))
1128 else if (EQ (v, Qnarrow))
1130 else if (EQ (v, Qsmall))
1132 else if (EQ (v, Qfont))
1135 signal_simple_error (err_msg, err_arg);
1138 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
1139 Return character corresponding with list.
1143 Lisp_Object table = Vcharacter_composition_table;
1144 Lisp_Object rest = list;
1146 while (CONSP (rest))
1148 Lisp_Object v = Fcar (rest);
1150 Emchar c = to_char_id (v, "Invalid value for composition", list);
1152 ret = get_char_id_table (c, table);
1157 if (!CHAR_ID_TABLE_P (ret))
1162 else if (!CONSP (rest))
1164 else if (CHAR_ID_TABLE_P (ret))
1167 signal_simple_error ("Invalid table is found with", list);
1169 signal_simple_error ("Invalid value for composition", list);
1172 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
1173 Return variants of CHARACTER.
1177 CHECK_CHAR (character);
1178 return Fcopy_list (get_char_id_table (XCHAR (character),
1179 Vcharacter_variant_table));
1185 /* A char table maps from ranges of characters to values.
1187 Implementing a general data structure that maps from arbitrary
1188 ranges of numbers to values is tricky to do efficiently. As it
1189 happens, it should suffice (and is usually more convenient, anyway)
1190 when dealing with characters to restrict the sorts of ranges that
1191 can be assigned values, as follows:
1194 2) All characters in a charset.
1195 3) All characters in a particular row of a charset, where a "row"
1196 means all characters with the same first byte.
1197 4) A particular character in a charset.
1199 We use char tables to generalize the 256-element vectors now
1200 littering the Emacs code.
1202 Possible uses (all should be converted at some point):
1208 5) keyboard-translate-table?
1211 abstract type to generalize the Emacs vectors and Mule
1212 vectors-of-vectors goo.
1215 /************************************************************************/
1216 /* Char Table object */
1217 /************************************************************************/
1222 mark_char_table_entry (Lisp_Object obj)
1224 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1227 for (i = 0; i < 96; i++)
1229 mark_object (cte->level2[i]);
1235 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1237 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1238 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1241 for (i = 0; i < 96; i++)
1242 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1248 static unsigned long
1249 char_table_entry_hash (Lisp_Object obj, int depth)
1251 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1253 return internal_array_hash (cte->level2, 96, depth);
1256 static const struct lrecord_description char_table_entry_description[] = {
1257 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1261 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1262 mark_char_table_entry, internal_object_printer,
1263 0, char_table_entry_equal,
1264 char_table_entry_hash,
1265 char_table_entry_description,
1266 Lisp_Char_Table_Entry);
1270 mark_char_table (Lisp_Object obj)
1272 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1275 for (i = 0; i < NUM_ASCII_CHARS; i++)
1276 mark_object (ct->ascii[i]);
1278 for (i = 0; i < NUM_LEADING_BYTES; i++)
1279 mark_object (ct->level1[i]);
1281 return ct->mirror_table;
1284 /* WARNING: All functions of this nature need to be written extremely
1285 carefully to avoid crashes during GC. Cf. prune_specifiers()
1286 and prune_weak_hash_tables(). */
1289 prune_syntax_tables (void)
1291 Lisp_Object rest, prev = Qnil;
1293 for (rest = Vall_syntax_tables;
1295 rest = XCHAR_TABLE (rest)->next_table)
1297 if (! marked_p (rest))
1299 /* This table is garbage. Remove it from the list. */
1301 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1303 XCHAR_TABLE (prev)->next_table =
1304 XCHAR_TABLE (rest)->next_table;
1310 char_table_type_to_symbol (enum char_table_type type)
1315 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1316 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1317 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1318 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1320 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1325 static enum char_table_type
1326 symbol_to_char_table_type (Lisp_Object symbol)
1328 CHECK_SYMBOL (symbol);
1330 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1331 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1332 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1333 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1335 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1338 signal_simple_error ("Unrecognized char table type", symbol);
1339 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1343 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1344 Lisp_Object printcharfun)
1348 write_c_string (" (", printcharfun);
1349 print_internal (make_char (first), printcharfun, 0);
1350 write_c_string (" ", printcharfun);
1351 print_internal (make_char (last), printcharfun, 0);
1352 write_c_string (") ", printcharfun);
1356 write_c_string (" ", printcharfun);
1357 print_internal (make_char (first), printcharfun, 0);
1358 write_c_string (" ", printcharfun);
1360 print_internal (val, printcharfun, 1);
1366 print_chartab_charset_row (Lisp_Object charset,
1368 Lisp_Char_Table_Entry *cte,
1369 Lisp_Object printcharfun)
1372 Lisp_Object cat = Qunbound;
1375 for (i = 32; i < 128; i++)
1377 Lisp_Object pam = cte->level2[i - 32];
1389 print_chartab_range (MAKE_CHAR (charset, first, 0),
1390 MAKE_CHAR (charset, i - 1, 0),
1393 print_chartab_range (MAKE_CHAR (charset, row, first),
1394 MAKE_CHAR (charset, row, i - 1),
1404 print_chartab_range (MAKE_CHAR (charset, first, 0),
1405 MAKE_CHAR (charset, i - 1, 0),
1408 print_chartab_range (MAKE_CHAR (charset, row, first),
1409 MAKE_CHAR (charset, row, i - 1),
1415 print_chartab_two_byte_charset (Lisp_Object charset,
1416 Lisp_Char_Table_Entry *cte,
1417 Lisp_Object printcharfun)
1421 for (i = 32; i < 128; i++)
1423 Lisp_Object jen = cte->level2[i - 32];
1425 if (!CHAR_TABLE_ENTRYP (jen))
1429 write_c_string (" [", printcharfun);
1430 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1431 sprintf (buf, " %d] ", i);
1432 write_c_string (buf, printcharfun);
1433 print_internal (jen, printcharfun, 0);
1436 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1444 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1446 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1449 sprintf (buf, "#s(char-table type %s data (",
1450 string_data (symbol_name (XSYMBOL
1451 (char_table_type_to_symbol (ct->type)))));
1452 write_c_string (buf, printcharfun);
1454 /* Now write out the ASCII/Control-1 stuff. */
1458 Lisp_Object val = Qunbound;
1460 for (i = 0; i < NUM_ASCII_CHARS; i++)
1469 if (!EQ (ct->ascii[i], val))
1471 print_chartab_range (first, i - 1, val, printcharfun);
1478 print_chartab_range (first, i - 1, val, printcharfun);
1485 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1488 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1489 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1491 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1492 || i == LEADING_BYTE_CONTROL_1)
1494 if (!CHAR_TABLE_ENTRYP (ann))
1496 write_c_string (" ", printcharfun);
1497 print_internal (XCHARSET_NAME (charset),
1499 write_c_string (" ", printcharfun);
1500 print_internal (ann, printcharfun, 0);
1504 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1505 if (XCHARSET_DIMENSION (charset) == 1)
1506 print_chartab_charset_row (charset, -1, cte, printcharfun);
1508 print_chartab_two_byte_charset (charset, cte, printcharfun);
1514 write_c_string ("))", printcharfun);
1518 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1520 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1521 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1524 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1527 for (i = 0; i < NUM_ASCII_CHARS; i++)
1528 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1532 for (i = 0; i < NUM_LEADING_BYTES; i++)
1533 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1540 static unsigned long
1541 char_table_hash (Lisp_Object obj, int depth)
1543 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1544 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1547 hashval = HASH2 (hashval,
1548 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1553 static const struct lrecord_description char_table_description[] = {
1554 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1556 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1558 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1559 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1563 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1564 mark_char_table, print_char_table, 0,
1565 char_table_equal, char_table_hash,
1566 char_table_description,
1569 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1570 Return non-nil if OBJECT is a char table.
1572 A char table is a table that maps characters (or ranges of characters)
1573 to values. Char tables are specialized for characters, only allowing
1574 particular sorts of ranges to be assigned values. Although this
1575 loses in generality, it makes for extremely fast (constant-time)
1576 lookups, and thus is feasible for applications that do an extremely
1577 large number of lookups (e.g. scanning a buffer for a character in
1578 a particular syntax, where a lookup in the syntax table must occur
1579 once per character).
1581 When Mule support exists, the types of ranges that can be assigned
1585 -- an entire charset
1586 -- a single row in a two-octet charset
1587 -- a single character
1589 When Mule support is not present, the types of ranges that can be
1593 -- a single character
1595 To create a char table, use `make-char-table'.
1596 To modify a char table, use `put-char-table' or `remove-char-table'.
1597 To retrieve the value for a particular character, use `get-char-table'.
1598 See also `map-char-table', `clear-char-table', `copy-char-table',
1599 `valid-char-table-type-p', `char-table-type-list',
1600 `valid-char-table-value-p', and `check-char-table-value'.
1604 return CHAR_TABLEP (object) ? Qt : Qnil;
1607 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1608 Return a list of the recognized char table types.
1609 See `valid-char-table-type-p'.
1614 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1616 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1620 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1621 Return t if TYPE if a recognized char table type.
1623 Each char table type is used for a different purpose and allows different
1624 sorts of values. The different char table types are
1627 Used for category tables, which specify the regexp categories
1628 that a character is in. The valid values are nil or a
1629 bit vector of 95 elements. Higher-level Lisp functions are
1630 provided for working with category tables. Currently categories
1631 and category tables only exist when Mule support is present.
1633 A generalized char table, for mapping from one character to
1634 another. Used for case tables, syntax matching tables,
1635 `keyboard-translate-table', etc. The valid values are characters.
1637 An even more generalized char table, for mapping from a
1638 character to anything.
1640 Used for display tables, which specify how a particular character
1641 is to appear when displayed. #### Not yet implemented.
1643 Used for syntax tables, which specify the syntax of a particular
1644 character. Higher-level Lisp functions are provided for
1645 working with syntax tables. The valid values are integers.
1650 return (EQ (type, Qchar) ||
1652 EQ (type, Qcategory) ||
1654 EQ (type, Qdisplay) ||
1655 EQ (type, Qgeneric) ||
1656 EQ (type, Qsyntax)) ? Qt : Qnil;
1659 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1660 Return the type of CHAR-TABLE.
1661 See `valid-char-table-type-p'.
1665 CHECK_CHAR_TABLE (char_table);
1666 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1670 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1674 for (i = 0; i < NUM_ASCII_CHARS; i++)
1675 ct->ascii[i] = value;
1677 for (i = 0; i < NUM_LEADING_BYTES; i++)
1678 ct->level1[i] = value;
1681 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1682 update_syntax_table (ct);
1685 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1686 Reset CHAR-TABLE to its default state.
1690 Lisp_Char_Table *ct;
1692 CHECK_CHAR_TABLE (char_table);
1693 ct = XCHAR_TABLE (char_table);
1697 case CHAR_TABLE_TYPE_CHAR:
1698 fill_char_table (ct, make_char (0));
1700 case CHAR_TABLE_TYPE_DISPLAY:
1701 case CHAR_TABLE_TYPE_GENERIC:
1703 case CHAR_TABLE_TYPE_CATEGORY:
1705 fill_char_table (ct, Qnil);
1708 case CHAR_TABLE_TYPE_SYNTAX:
1709 fill_char_table (ct, make_int (Sinherit));
1719 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1720 Return a new, empty char table of type TYPE.
1721 Currently recognized types are 'char, 'category, 'display, 'generic,
1722 and 'syntax. See `valid-char-table-type-p'.
1726 Lisp_Char_Table *ct;
1728 enum char_table_type ty = symbol_to_char_table_type (type);
1730 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1732 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1734 ct->mirror_table = Fmake_char_table (Qgeneric);
1735 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1739 ct->mirror_table = Qnil;
1740 ct->next_table = Qnil;
1741 XSETCHAR_TABLE (obj, ct);
1742 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1744 ct->next_table = Vall_syntax_tables;
1745 Vall_syntax_tables = obj;
1747 Freset_char_table (obj);
1754 make_char_table_entry (Lisp_Object initval)
1758 Lisp_Char_Table_Entry *cte =
1759 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1761 for (i = 0; i < 96; i++)
1762 cte->level2[i] = initval;
1764 XSETCHAR_TABLE_ENTRY (obj, cte);
1769 copy_char_table_entry (Lisp_Object entry)
1771 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1774 Lisp_Char_Table_Entry *ctenew =
1775 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1777 for (i = 0; i < 96; i++)
1779 Lisp_Object new = cte->level2[i];
1780 if (CHAR_TABLE_ENTRYP (new))
1781 ctenew->level2[i] = copy_char_table_entry (new);
1783 ctenew->level2[i] = new;
1786 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1792 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1793 Return a new char table which is a copy of CHAR-TABLE.
1794 It will contain the same values for the same characters and ranges
1795 as CHAR-TABLE. The values will not themselves be copied.
1799 Lisp_Char_Table *ct, *ctnew;
1803 CHECK_CHAR_TABLE (char_table);
1804 ct = XCHAR_TABLE (char_table);
1805 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1806 ctnew->type = ct->type;
1808 for (i = 0; i < NUM_ASCII_CHARS; i++)
1810 Lisp_Object new = ct->ascii[i];
1812 assert (! (CHAR_TABLE_ENTRYP (new)));
1814 ctnew->ascii[i] = new;
1819 for (i = 0; i < NUM_LEADING_BYTES; i++)
1821 Lisp_Object new = ct->level1[i];
1822 if (CHAR_TABLE_ENTRYP (new))
1823 ctnew->level1[i] = copy_char_table_entry (new);
1825 ctnew->level1[i] = new;
1830 if (CHAR_TABLEP (ct->mirror_table))
1831 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1833 ctnew->mirror_table = ct->mirror_table;
1834 ctnew->next_table = Qnil;
1835 XSETCHAR_TABLE (obj, ctnew);
1836 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1838 ctnew->next_table = Vall_syntax_tables;
1839 Vall_syntax_tables = obj;
1845 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1848 outrange->type = CHARTAB_RANGE_ALL;
1849 else if (CHAR_OR_CHAR_INTP (range))
1851 outrange->type = CHARTAB_RANGE_CHAR;
1852 outrange->ch = XCHAR_OR_CHAR_INT (range);
1856 signal_simple_error ("Range must be t or a character", range);
1858 else if (VECTORP (range))
1860 Lisp_Vector *vec = XVECTOR (range);
1861 Lisp_Object *elts = vector_data (vec);
1862 if (vector_length (vec) != 2)
1863 signal_simple_error ("Length of charset row vector must be 2",
1865 outrange->type = CHARTAB_RANGE_ROW;
1866 outrange->charset = Fget_charset (elts[0]);
1867 CHECK_INT (elts[1]);
1868 outrange->row = XINT (elts[1]);
1869 if (XCHARSET_DIMENSION (outrange->charset) >= 2)
1871 switch (XCHARSET_CHARS (outrange->charset))
1874 check_int_range (outrange->row, 33, 126);
1877 check_int_range (outrange->row, 32, 127);
1884 signal_simple_error ("Charset in row vector must be multi-byte",
1889 if (!CHARSETP (range) && !SYMBOLP (range))
1891 ("Char table range must be t, charset, char, or vector", range);
1892 outrange->type = CHARTAB_RANGE_CHARSET;
1893 outrange->charset = Fget_charset (range);
1900 /* called from CHAR_TABLE_VALUE(). */
1902 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
1907 Lisp_Object charset;
1909 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
1914 BREAKUP_CHAR (c, charset, byte1, byte2);
1916 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
1918 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
1919 if (CHAR_TABLE_ENTRYP (val))
1921 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1922 val = cte->level2[byte1 - 32];
1923 if (CHAR_TABLE_ENTRYP (val))
1925 cte = XCHAR_TABLE_ENTRY (val);
1926 assert (byte2 >= 32);
1927 val = cte->level2[byte2 - 32];
1928 assert (!CHAR_TABLE_ENTRYP (val));
1938 get_char_table (Emchar ch, Lisp_Char_Table *ct)
1942 Lisp_Object charset;
1946 BREAKUP_CHAR (ch, charset, byte1, byte2);
1948 if (EQ (charset, Vcharset_ascii))
1949 val = ct->ascii[byte1];
1950 else if (EQ (charset, Vcharset_control_1))
1951 val = ct->ascii[byte1 + 128];
1954 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1955 val = ct->level1[lb];
1956 if (CHAR_TABLE_ENTRYP (val))
1958 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1959 val = cte->level2[byte1 - 32];
1960 if (CHAR_TABLE_ENTRYP (val))
1962 cte = XCHAR_TABLE_ENTRY (val);
1963 assert (byte2 >= 32);
1964 val = cte->level2[byte2 - 32];
1965 assert (!CHAR_TABLE_ENTRYP (val));
1972 #else /* not MULE */
1973 return ct->ascii[(unsigned char)ch];
1974 #endif /* not MULE */
1978 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
1979 Find value for CHARACTER in CHAR-TABLE.
1981 (character, char_table))
1983 CHECK_CHAR_TABLE (char_table);
1984 CHECK_CHAR_COERCE_INT (character);
1986 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
1989 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
1990 Find value for a range in CHAR-TABLE.
1991 If there is more than one value, return MULTI (defaults to nil).
1993 (range, char_table, multi))
1995 Lisp_Char_Table *ct;
1996 struct chartab_range rainj;
1998 if (CHAR_OR_CHAR_INTP (range))
1999 return Fget_char_table (range, char_table);
2000 CHECK_CHAR_TABLE (char_table);
2001 ct = XCHAR_TABLE (char_table);
2003 decode_char_table_range (range, &rainj);
2006 case CHARTAB_RANGE_ALL:
2009 Lisp_Object first = ct->ascii[0];
2011 for (i = 1; i < NUM_ASCII_CHARS; i++)
2012 if (!EQ (first, ct->ascii[i]))
2016 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
2019 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
2020 || i == LEADING_BYTE_ASCII
2021 || i == LEADING_BYTE_CONTROL_1)
2023 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
2032 case CHARTAB_RANGE_CHARSET:
2033 if (EQ (rainj.charset, Vcharset_ascii))
2036 Lisp_Object first = ct->ascii[0];
2038 for (i = 1; i < 128; i++)
2039 if (!EQ (first, ct->ascii[i]))
2044 if (EQ (rainj.charset, Vcharset_control_1))
2047 Lisp_Object first = ct->ascii[128];
2049 for (i = 129; i < 160; i++)
2050 if (!EQ (first, ct->ascii[i]))
2056 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2058 if (CHAR_TABLE_ENTRYP (val))
2063 case CHARTAB_RANGE_ROW:
2065 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
2067 if (!CHAR_TABLE_ENTRYP (val))
2069 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
2070 if (CHAR_TABLE_ENTRYP (val))
2074 #endif /* not MULE */
2080 return Qnil; /* not reached */
2084 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2085 Error_behavior errb)
2089 case CHAR_TABLE_TYPE_SYNTAX:
2090 if (!ERRB_EQ (errb, ERROR_ME))
2091 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2092 && CHAR_OR_CHAR_INTP (XCDR (value)));
2095 Lisp_Object cdr = XCDR (value);
2096 CHECK_INT (XCAR (value));
2097 CHECK_CHAR_COERCE_INT (cdr);
2104 case CHAR_TABLE_TYPE_CATEGORY:
2105 if (!ERRB_EQ (errb, ERROR_ME))
2106 return CATEGORY_TABLE_VALUEP (value);
2107 CHECK_CATEGORY_TABLE_VALUE (value);
2111 case CHAR_TABLE_TYPE_GENERIC:
2114 case CHAR_TABLE_TYPE_DISPLAY:
2116 maybe_signal_simple_error ("Display char tables not yet implemented",
2117 value, Qchar_table, errb);
2120 case CHAR_TABLE_TYPE_CHAR:
2121 if (!ERRB_EQ (errb, ERROR_ME))
2122 return CHAR_OR_CHAR_INTP (value);
2123 CHECK_CHAR_COERCE_INT (value);
2130 return 0; /* not reached */
2134 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2138 case CHAR_TABLE_TYPE_SYNTAX:
2141 Lisp_Object car = XCAR (value);
2142 Lisp_Object cdr = XCDR (value);
2143 CHECK_CHAR_COERCE_INT (cdr);
2144 return Fcons (car, cdr);
2147 case CHAR_TABLE_TYPE_CHAR:
2148 CHECK_CHAR_COERCE_INT (value);
2156 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2157 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2159 (value, char_table_type))
2161 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2163 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2166 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2167 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2169 (value, char_table_type))
2171 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2173 check_valid_char_table_value (value, type, ERROR_ME);
2177 /* Assign VAL to all characters in RANGE in char table CT. */
2180 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2183 switch (range->type)
2185 case CHARTAB_RANGE_ALL:
2186 fill_char_table (ct, val);
2187 return; /* avoid the duplicate call to update_syntax_table() below,
2188 since fill_char_table() also did that. */
2191 case CHARTAB_RANGE_CHARSET:
2192 if (EQ (range->charset, Vcharset_ascii))
2195 for (i = 0; i < 128; i++)
2198 else if (EQ (range->charset, Vcharset_control_1))
2201 for (i = 128; i < 160; i++)
2206 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2207 ct->level1[lb] = val;
2211 case CHARTAB_RANGE_ROW:
2213 Lisp_Char_Table_Entry *cte;
2214 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2215 /* make sure that there is a separate entry for the row. */
2216 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2217 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2218 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2219 cte->level2[range->row - 32] = val;
2224 case CHARTAB_RANGE_CHAR:
2227 Lisp_Object charset;
2230 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2231 if (EQ (charset, Vcharset_ascii))
2232 ct->ascii[byte1] = val;
2233 else if (EQ (charset, Vcharset_control_1))
2234 ct->ascii[byte1 + 128] = val;
2237 Lisp_Char_Table_Entry *cte;
2238 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2239 /* make sure that there is a separate entry for the row. */
2240 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2241 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2242 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2243 /* now CTE is a char table entry for the charset;
2244 each entry is for a single row (or character of
2245 a one-octet charset). */
2246 if (XCHARSET_DIMENSION (charset) == 1)
2247 cte->level2[byte1 - 32] = val;
2250 /* assigning to one character in a two-octet charset. */
2251 /* make sure that the charset row contains a separate
2252 entry for each character. */
2253 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2254 cte->level2[byte1 - 32] =
2255 make_char_table_entry (cte->level2[byte1 - 32]);
2256 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2257 cte->level2[byte2 - 32] = val;
2261 #else /* not MULE */
2262 ct->ascii[(unsigned char) (range->ch)] = val;
2264 #endif /* not MULE */
2267 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2268 update_syntax_table (ct);
2271 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2272 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2274 RANGE specifies one or more characters to be affected and should be
2275 one of the following:
2277 -- t (all characters are affected)
2278 -- A charset (only allowed when Mule support is present)
2279 -- A vector of two elements: a two-octet charset and a row number
2280 (only allowed when Mule support is present)
2281 -- A single character
2283 VALUE must be a value appropriate for the type of CHAR-TABLE.
2284 See `valid-char-table-type-p'.
2286 (range, value, char_table))
2288 Lisp_Char_Table *ct;
2289 struct chartab_range rainj;
2291 CHECK_CHAR_TABLE (char_table);
2292 ct = XCHAR_TABLE (char_table);
2293 check_valid_char_table_value (value, ct->type, ERROR_ME);
2294 decode_char_table_range (range, &rainj);
2295 value = canonicalize_char_table_value (value, ct->type);
2296 put_char_table (ct, &rainj, value);
2300 /* Map FN over the ASCII chars in CT. */
2303 map_over_charset_ascii (Lisp_Char_Table *ct,
2304 int (*fn) (struct chartab_range *range,
2305 Lisp_Object val, void *arg),
2308 struct chartab_range rainj;
2317 rainj.type = CHARTAB_RANGE_CHAR;
2319 for (i = start, retval = 0; i < stop && retval == 0; i++)
2321 rainj.ch = (Emchar) i;
2322 retval = (fn) (&rainj, ct->ascii[i], arg);
2330 /* Map FN over the Control-1 chars in CT. */
2333 map_over_charset_control_1 (Lisp_Char_Table *ct,
2334 int (*fn) (struct chartab_range *range,
2335 Lisp_Object val, void *arg),
2338 struct chartab_range rainj;
2341 int stop = start + 32;
2343 rainj.type = CHARTAB_RANGE_CHAR;
2345 for (i = start, retval = 0; i < stop && retval == 0; i++)
2347 rainj.ch = (Emchar) (i);
2348 retval = (fn) (&rainj, ct->ascii[i], arg);
2354 /* Map FN over the row ROW of two-byte charset CHARSET.
2355 There must be a separate value for that row in the char table.
2356 CTE specifies the char table entry for CHARSET. */
2359 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2360 Lisp_Object charset, int row,
2361 int (*fn) (struct chartab_range *range,
2362 Lisp_Object val, void *arg),
2365 Lisp_Object val = cte->level2[row - 32];
2367 if (!CHAR_TABLE_ENTRYP (val))
2369 struct chartab_range rainj;
2371 rainj.type = CHARTAB_RANGE_ROW;
2372 rainj.charset = charset;
2374 return (fn) (&rainj, val, arg);
2378 struct chartab_range rainj;
2380 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2381 int start = charset94_p ? 33 : 32;
2382 int stop = charset94_p ? 127 : 128;
2384 cte = XCHAR_TABLE_ENTRY (val);
2386 rainj.type = CHARTAB_RANGE_CHAR;
2388 for (i = start, retval = 0; i < stop && retval == 0; i++)
2390 rainj.ch = MAKE_CHAR (charset, row, i);
2391 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2399 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2400 int (*fn) (struct chartab_range *range,
2401 Lisp_Object val, void *arg),
2404 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2405 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2407 if (!CHARSETP (charset)
2408 || lb == LEADING_BYTE_ASCII
2409 || lb == LEADING_BYTE_CONTROL_1)
2412 if (!CHAR_TABLE_ENTRYP (val))
2414 struct chartab_range rainj;
2416 rainj.type = CHARTAB_RANGE_CHARSET;
2417 rainj.charset = charset;
2418 return (fn) (&rainj, val, arg);
2422 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2423 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2424 int start = charset94_p ? 33 : 32;
2425 int stop = charset94_p ? 127 : 128;
2428 if (XCHARSET_DIMENSION (charset) == 1)
2430 struct chartab_range rainj;
2431 rainj.type = CHARTAB_RANGE_CHAR;
2433 for (i = start, retval = 0; i < stop && retval == 0; i++)
2435 rainj.ch = MAKE_CHAR (charset, i, 0);
2436 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2441 for (i = start, retval = 0; i < stop && retval == 0; i++)
2442 retval = map_over_charset_row (cte, charset, i, fn, arg);
2451 /* Map FN (with client data ARG) over range RANGE in char table CT.
2452 Mapping stops the first time FN returns non-zero, and that value
2453 becomes the return value of map_char_table(). */
2456 map_char_table (Lisp_Char_Table *ct,
2457 struct chartab_range *range,
2458 int (*fn) (struct chartab_range *range,
2459 Lisp_Object val, void *arg),
2462 switch (range->type)
2464 case CHARTAB_RANGE_ALL:
2468 retval = map_over_charset_ascii (ct, fn, arg);
2472 retval = map_over_charset_control_1 (ct, fn, arg);
2477 Charset_ID start = MIN_LEADING_BYTE;
2478 Charset_ID stop = start + NUM_LEADING_BYTES;
2480 for (i = start, retval = 0; i < stop && retval == 0; i++)
2482 retval = map_over_other_charset (ct, i, fn, arg);
2490 case CHARTAB_RANGE_CHARSET:
2491 return map_over_other_charset (ct,
2492 XCHARSET_LEADING_BYTE (range->charset),
2495 case CHARTAB_RANGE_ROW:
2497 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2498 - MIN_LEADING_BYTE];
2499 if (!CHAR_TABLE_ENTRYP (val))
2501 struct chartab_range rainj;
2503 rainj.type = CHARTAB_RANGE_ROW;
2504 rainj.charset = range->charset;
2505 rainj.row = range->row;
2506 return (fn) (&rainj, val, arg);
2509 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2510 range->charset, range->row,
2515 case CHARTAB_RANGE_CHAR:
2517 Emchar ch = range->ch;
2518 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2519 struct chartab_range rainj;
2521 rainj.type = CHARTAB_RANGE_CHAR;
2523 return (fn) (&rainj, val, arg);
2533 struct slow_map_char_table_arg
2535 Lisp_Object function;
2540 slow_map_char_table_fun (struct chartab_range *range,
2541 Lisp_Object val, void *arg)
2543 Lisp_Object ranjarg = Qnil;
2544 struct slow_map_char_table_arg *closure =
2545 (struct slow_map_char_table_arg *) arg;
2547 switch (range->type)
2549 case CHARTAB_RANGE_ALL:
2554 case CHARTAB_RANGE_CHARSET:
2555 ranjarg = XCHARSET_NAME (range->charset);
2558 case CHARTAB_RANGE_ROW:
2559 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2560 make_int (range->row));
2563 case CHARTAB_RANGE_CHAR:
2564 ranjarg = make_char (range->ch);
2570 closure->retval = call2 (closure->function, ranjarg, val);
2571 return !NILP (closure->retval);
2574 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2575 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2576 each key and value in the table.
2578 RANGE specifies a subrange to map over and is in the same format as
2579 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2582 (function, char_table, range))
2584 Lisp_Char_Table *ct;
2585 struct slow_map_char_table_arg slarg;
2586 struct gcpro gcpro1, gcpro2;
2587 struct chartab_range rainj;
2589 CHECK_CHAR_TABLE (char_table);
2590 ct = XCHAR_TABLE (char_table);
2593 decode_char_table_range (range, &rainj);
2594 slarg.function = function;
2595 slarg.retval = Qnil;
2596 GCPRO2 (slarg.function, slarg.retval);
2597 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2600 return slarg.retval;
2604 /************************************************************************/
2605 /* Character Attributes */
2606 /************************************************************************/
2610 Lisp_Object Vchar_attribute_hash_table;
2612 /* We store the char-attributes in hash tables with the names as the
2613 key and the actual char-id-table object as the value. Occasionally
2614 we need to use them in a list format. These routines provide us
2616 struct char_attribute_list_closure
2618 Lisp_Object *char_attribute_list;
2622 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
2623 void *char_attribute_list_closure)
2625 /* This function can GC */
2626 struct char_attribute_list_closure *calcl
2627 = (struct char_attribute_list_closure*) char_attribute_list_closure;
2628 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
2630 *char_attribute_list = Fcons (key, *char_attribute_list);
2634 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
2635 Return the list of all existing character attributes except coded-charsets.
2639 Lisp_Object char_attribute_list = Qnil;
2640 struct gcpro gcpro1;
2641 struct char_attribute_list_closure char_attribute_list_closure;
2643 GCPRO1 (char_attribute_list);
2644 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
2645 elisp_maphash (add_char_attribute_to_list_mapper,
2646 Vchar_attribute_hash_table,
2647 &char_attribute_list_closure);
2649 return char_attribute_list;
2652 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
2653 Return char-id-table corresponding to ATTRIBUTE.
2657 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
2661 /* We store the char-id-tables in hash tables with the attributes as
2662 the key and the actual char-id-table object as the value. Each
2663 char-id-table stores values of an attribute corresponding with
2664 characters. Occasionally we need to get attributes of a character
2665 in a association-list format. These routines provide us with
2667 struct char_attribute_alist_closure
2670 Lisp_Object *char_attribute_alist;
2674 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
2675 void *char_attribute_alist_closure)
2677 /* This function can GC */
2678 struct char_attribute_alist_closure *caacl =
2679 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
2680 Lisp_Object ret = get_char_id_table (caacl->char_id, value);
2681 if (!UNBOUNDP (ret))
2683 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
2684 *char_attribute_alist
2685 = Fcons (Fcons (key, ret), *char_attribute_alist);
2690 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
2691 Return the alist of attributes of CHARACTER.
2695 Lisp_Object alist = Qnil;
2698 CHECK_CHAR (character);
2700 struct gcpro gcpro1;
2701 struct char_attribute_alist_closure char_attribute_alist_closure;
2704 char_attribute_alist_closure.char_id = XCHAR (character);
2705 char_attribute_alist_closure.char_attribute_alist = &alist;
2706 elisp_maphash (add_char_attribute_alist_mapper,
2707 Vchar_attribute_hash_table,
2708 &char_attribute_alist_closure);
2712 for (i = 0; i < countof (chlook->charset_by_leading_byte); i++)
2714 Lisp_Object ccs = chlook->charset_by_leading_byte[i];
2718 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
2721 if ( CHAR_ID_TABLE_P (encoding_table)
2722 && INTP (cpos = get_char_id_table (XCHAR (character),
2725 alist = Fcons (Fcons (ccs, cpos), alist);
2732 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
2733 Return the value of CHARACTER's ATTRIBUTE.
2734 Return DEFAULT-VALUE if the value is not exist.
2736 (character, attribute, default_value))
2740 CHECK_CHAR (character);
2741 if (!NILP (ccs = Ffind_charset (attribute)))
2743 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
2745 if (CHAR_ID_TABLE_P (encoding_table))
2746 return get_char_id_table (XCHAR (character), encoding_table);
2750 Lisp_Object table = Fgethash (attribute,
2751 Vchar_attribute_hash_table,
2753 if (!UNBOUNDP (table))
2755 Lisp_Object ret = get_char_id_table (XCHAR (character), table);
2756 if (!UNBOUNDP (ret))
2760 return default_value;
2763 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
2764 Store CHARACTER's ATTRIBUTE with VALUE.
2766 (character, attribute, value))
2770 CHECK_CHAR (character);
2771 ccs = Ffind_charset (attribute);
2774 return put_char_ccs_code_point (character, ccs, value);
2776 else if (EQ (attribute, Q_decomposition))
2781 signal_simple_error ("Invalid value for ->decomposition",
2784 if (CONSP (Fcdr (value)))
2786 Lisp_Object rest = value;
2787 Lisp_Object table = Vcharacter_composition_table;
2791 GET_EXTERNAL_LIST_LENGTH (rest, len);
2792 seq = make_vector (len, Qnil);
2794 while (CONSP (rest))
2796 Lisp_Object v = Fcar (rest);
2799 = to_char_id (v, "Invalid value for ->decomposition", value);
2802 XVECTOR_DATA(seq)[i++] = v;
2804 XVECTOR_DATA(seq)[i++] = make_char (c);
2808 put_char_id_table (c, character, table);
2813 ntable = get_char_id_table (c, table);
2814 if (!CHAR_ID_TABLE_P (ntable))
2816 ntable = make_char_id_table (Qnil);
2817 put_char_id_table (c, ntable, table);
2825 Lisp_Object v = Fcar (value);
2829 Emchar c = XINT (v);
2831 = get_char_id_table (c, Vcharacter_variant_table);
2833 if (NILP (Fmemq (v, ret)))
2835 put_char_id_table (c, Fcons (character, ret),
2836 Vcharacter_variant_table);
2839 seq = make_vector (1, v);
2843 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
2849 signal_simple_error ("Invalid value for ->ucs", value);
2853 ret = get_char_id_table (c, Vcharacter_variant_table);
2854 if (NILP (Fmemq (character, ret)))
2856 put_char_id_table (c, Fcons (character, ret),
2857 Vcharacter_variant_table);
2860 if (EQ (attribute, Q_ucs))
2861 attribute = Qto_ucs;
2865 Lisp_Object table = Fgethash (attribute,
2866 Vchar_attribute_hash_table,
2871 table = make_char_id_table (Qunbound);
2872 Fputhash (attribute, table, Vchar_attribute_hash_table);
2874 put_char_id_table (XCHAR (character), value, table);
2879 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
2880 Remove CHARACTER's ATTRIBUTE.
2882 (character, attribute))
2886 CHECK_CHAR (character);
2887 ccs = Ffind_charset (attribute);
2890 return remove_char_ccs (character, ccs);
2894 Lisp_Object table = Fgethash (attribute,
2895 Vchar_attribute_hash_table,
2897 if (!UNBOUNDP (table))
2899 put_char_id_table (XCHAR (character), Qunbound, table);
2906 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
2907 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
2908 each key and value in the table.
2910 RANGE specifies a subrange to map over and is in the same format as
2911 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2914 (function, attribute, range))
2917 Lisp_Char_ID_Table *ct;
2918 struct slow_map_char_table_arg slarg;
2919 struct gcpro gcpro1, gcpro2;
2920 struct chartab_range rainj;
2922 if (!NILP (ccs = Ffind_charset (attribute)))
2924 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
2926 if (CHAR_ID_TABLE_P (encoding_table))
2927 ct = XCHAR_ID_TABLE (encoding_table);
2933 Lisp_Object table = Fgethash (attribute,
2934 Vchar_attribute_hash_table,
2936 if (CHAR_ID_TABLE_P (table))
2937 ct = XCHAR_ID_TABLE (table);
2943 decode_char_table_range (range, &rainj);
2944 slarg.function = function;
2945 slarg.retval = Qnil;
2946 GCPRO2 (slarg.function, slarg.retval);
2947 map_char_id_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2950 return slarg.retval;
2953 EXFUN (Fmake_char, 3);
2954 EXFUN (Fdecode_char, 2);
2956 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
2957 Store character's ATTRIBUTES.
2961 Lisp_Object rest = attributes;
2962 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
2963 Lisp_Object character;
2967 while (CONSP (rest))
2969 Lisp_Object cell = Fcar (rest);
2973 signal_simple_error ("Invalid argument", attributes);
2974 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
2975 && ((XCHARSET_FINAL (ccs) != 0) ||
2976 (XCHARSET_UCS_MAX (ccs) > 0)) )
2980 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
2982 character = Fdecode_char (ccs, cell);
2983 if (!NILP (character))
2984 goto setup_attributes;
2988 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
2989 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
2993 signal_simple_error ("Invalid argument", attributes);
2995 character = make_char (XINT (code) + 0x100000);
2996 goto setup_attributes;
3000 else if (!INTP (code))
3001 signal_simple_error ("Invalid argument", attributes);
3003 character = make_char (XINT (code));
3007 while (CONSP (rest))
3009 Lisp_Object cell = Fcar (rest);
3012 signal_simple_error ("Invalid argument", attributes);
3014 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3020 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3021 Retrieve the character of the given ATTRIBUTES.
3025 Lisp_Object rest = attributes;
3028 while (CONSP (rest))
3030 Lisp_Object cell = Fcar (rest);
3034 signal_simple_error ("Invalid argument", attributes);
3035 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3039 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3041 return Fdecode_char (ccs, cell);
3045 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3046 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3049 signal_simple_error ("Invalid argument", attributes);
3051 return make_char (XINT (code) + 0x100000);
3059 /************************************************************************/
3060 /* Char table read syntax */
3061 /************************************************************************/
3064 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3065 Error_behavior errb)
3067 /* #### should deal with ERRB */
3068 symbol_to_char_table_type (value);
3073 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3074 Error_behavior errb)
3078 /* #### should deal with ERRB */
3079 EXTERNAL_LIST_LOOP (rest, value)
3081 Lisp_Object range = XCAR (rest);
3082 struct chartab_range dummy;
3086 signal_simple_error ("Invalid list format", value);
3089 if (!CONSP (XCDR (range))
3090 || !NILP (XCDR (XCDR (range))))
3091 signal_simple_error ("Invalid range format", range);
3092 decode_char_table_range (XCAR (range), &dummy);
3093 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3096 decode_char_table_range (range, &dummy);
3103 chartab_instantiate (Lisp_Object data)
3105 Lisp_Object chartab;
3106 Lisp_Object type = Qgeneric;
3107 Lisp_Object dataval = Qnil;
3109 while (!NILP (data))
3111 Lisp_Object keyw = Fcar (data);
3117 if (EQ (keyw, Qtype))
3119 else if (EQ (keyw, Qdata))
3123 chartab = Fmake_char_table (type);
3126 while (!NILP (data))
3128 Lisp_Object range = Fcar (data);
3129 Lisp_Object val = Fcar (Fcdr (data));
3131 data = Fcdr (Fcdr (data));
3134 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3136 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3137 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3140 for (i = first; i <= last; i++)
3141 Fput_char_table (make_char (i), val, chartab);
3147 Fput_char_table (range, val, chartab);
3156 /************************************************************************/
3157 /* Category Tables, specifically */
3158 /************************************************************************/
3160 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3161 Return t if OBJECT is a category table.
3162 A category table is a type of char table used for keeping track of
3163 categories. Categories are used for classifying characters for use
3164 in regexps -- you can refer to a category rather than having to use
3165 a complicated [] expression (and category lookups are significantly
3168 There are 95 different categories available, one for each printable
3169 character (including space) in the ASCII charset. Each category
3170 is designated by one such character, called a "category designator".
3171 They are specified in a regexp using the syntax "\\cX", where X is
3172 a category designator.
3174 A category table specifies, for each character, the categories that
3175 the character is in. Note that a character can be in more than one
3176 category. More specifically, a category table maps from a character
3177 to either the value nil (meaning the character is in no categories)
3178 or a 95-element bit vector, specifying for each of the 95 categories
3179 whether the character is in that category.
3181 Special Lisp functions are provided that abstract this, so you do not
3182 have to directly manipulate bit vectors.
3186 return (CHAR_TABLEP (object) &&
3187 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3192 check_category_table (Lisp_Object object, Lisp_Object default_)
3196 while (NILP (Fcategory_table_p (object)))
3197 object = wrong_type_argument (Qcategory_table_p, object);
3202 check_category_char (Emchar ch, Lisp_Object table,
3203 unsigned int designator, unsigned int not)
3205 REGISTER Lisp_Object temp;
3206 Lisp_Char_Table *ctbl;
3207 #ifdef ERROR_CHECK_TYPECHECK
3208 if (NILP (Fcategory_table_p (table)))
3209 signal_simple_error ("Expected category table", table);
3211 ctbl = XCHAR_TABLE (table);
3212 temp = get_char_table (ch, ctbl);
3217 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not;
3220 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3221 Return t if category of the character at POSITION includes DESIGNATOR.
3222 Optional third arg BUFFER specifies which buffer to use, and defaults
3223 to the current buffer.
3224 Optional fourth arg CATEGORY-TABLE specifies the category table to
3225 use, and defaults to BUFFER's category table.
3227 (position, designator, buffer, category_table))
3232 struct buffer *buf = decode_buffer (buffer, 0);
3234 CHECK_INT (position);
3235 CHECK_CATEGORY_DESIGNATOR (designator);
3236 des = XCHAR (designator);
3237 ctbl = check_category_table (category_table, Vstandard_category_table);
3238 ch = BUF_FETCH_CHAR (buf, XINT (position));
3239 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3242 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3243 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3244 Optional third arg CATEGORY-TABLE specifies the category table to use,
3245 and defaults to the standard category table.
3247 (character, designator, category_table))
3253 CHECK_CATEGORY_DESIGNATOR (designator);
3254 des = XCHAR (designator);
3255 CHECK_CHAR (character);
3256 ch = XCHAR (character);
3257 ctbl = check_category_table (category_table, Vstandard_category_table);
3258 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3261 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3262 Return BUFFER's current category table.
3263 BUFFER defaults to the current buffer.
3267 return decode_buffer (buffer, 0)->category_table;
3270 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3271 Return the standard category table.
3272 This is the one used for new buffers.
3276 return Vstandard_category_table;
3279 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3280 Return a new category table which is a copy of CATEGORY-TABLE.
3281 CATEGORY-TABLE defaults to the standard category table.
3285 if (NILP (Vstandard_category_table))
3286 return Fmake_char_table (Qcategory);
3289 check_category_table (category_table, Vstandard_category_table);
3290 return Fcopy_char_table (category_table);
3293 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3294 Select CATEGORY-TABLE as the new category table for BUFFER.
3295 BUFFER defaults to the current buffer if omitted.
3297 (category_table, buffer))
3299 struct buffer *buf = decode_buffer (buffer, 0);
3300 category_table = check_category_table (category_table, Qnil);
3301 buf->category_table = category_table;
3302 /* Indicate that this buffer now has a specified category table. */
3303 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3304 return category_table;
3307 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3308 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3312 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3315 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3316 Return t if OBJECT is a category table value.
3317 Valid values are nil or a bit vector of size 95.
3321 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3325 #define CATEGORYP(x) \
3326 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3328 #define CATEGORY_SET(c) \
3329 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3331 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3332 The faster version of `!NILP (Faref (category_set, category))'. */
3333 #define CATEGORY_MEMBER(category, category_set) \
3334 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3336 /* Return 1 if there is a word boundary between two word-constituent
3337 characters C1 and C2 if they appear in this order, else return 0.
3338 Use the macro WORD_BOUNDARY_P instead of calling this function
3341 int word_boundary_p (Emchar c1, Emchar c2);
3343 word_boundary_p (Emchar c1, Emchar c2)
3345 Lisp_Object category_set1, category_set2;
3350 if (COMPOSITE_CHAR_P (c1))
3351 c1 = cmpchar_component (c1, 0, 1);
3352 if (COMPOSITE_CHAR_P (c2))
3353 c2 = cmpchar_component (c2, 0, 1);
3356 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3358 tail = Vword_separating_categories;
3363 tail = Vword_combining_categories;
3367 category_set1 = CATEGORY_SET (c1);
3368 if (NILP (category_set1))
3369 return default_result;
3370 category_set2 = CATEGORY_SET (c2);
3371 if (NILP (category_set2))
3372 return default_result;
3374 for (; CONSP (tail); tail = XCONS (tail)->cdr)
3376 Lisp_Object elt = XCONS(tail)->car;
3379 && CATEGORYP (XCONS (elt)->car)
3380 && CATEGORYP (XCONS (elt)->cdr)
3381 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3382 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3383 return !default_result;
3385 return default_result;
3391 syms_of_chartab (void)
3394 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3395 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3396 INIT_LRECORD_IMPLEMENTATION (byte_table);
3397 INIT_LRECORD_IMPLEMENTATION (char_id_table);
3399 defsymbol (&Qto_ucs, "=>ucs");
3400 defsymbol (&Q_ucs, "->ucs");
3401 defsymbol (&Q_decomposition, "->decomposition");
3402 defsymbol (&Qcompat, "compat");
3403 defsymbol (&Qisolated, "isolated");
3404 defsymbol (&Qinitial, "initial");
3405 defsymbol (&Qmedial, "medial");
3406 defsymbol (&Qfinal, "final");
3407 defsymbol (&Qvertical, "vertical");
3408 defsymbol (&QnoBreak, "noBreak");
3409 defsymbol (&Qfraction, "fraction");
3410 defsymbol (&Qsuper, "super");
3411 defsymbol (&Qsub, "sub");
3412 defsymbol (&Qcircle, "circle");
3413 defsymbol (&Qsquare, "square");
3414 defsymbol (&Qwide, "wide");
3415 defsymbol (&Qnarrow, "narrow");
3416 defsymbol (&Qsmall, "small");
3417 defsymbol (&Qfont, "font");
3419 DEFSUBR (Fchar_attribute_list);
3420 DEFSUBR (Ffind_char_attribute_table);
3421 DEFSUBR (Fchar_attribute_alist);
3422 DEFSUBR (Fget_char_attribute);
3423 DEFSUBR (Fput_char_attribute);
3424 DEFSUBR (Fremove_char_attribute);
3425 DEFSUBR (Fmap_char_attribute);
3426 DEFSUBR (Fdefine_char);
3427 DEFSUBR (Ffind_char);
3428 DEFSUBR (Fchar_variants);
3430 DEFSUBR (Fget_composite_char);
3433 INIT_LRECORD_IMPLEMENTATION (char_table);
3436 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3438 defsymbol (&Qcategory_table_p, "category-table-p");
3439 defsymbol (&Qcategory_designator_p, "category-designator-p");
3440 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3443 defsymbol (&Qchar_table, "char-table");
3444 defsymbol (&Qchar_tablep, "char-table-p");
3446 DEFSUBR (Fchar_table_p);
3447 DEFSUBR (Fchar_table_type_list);
3448 DEFSUBR (Fvalid_char_table_type_p);
3449 DEFSUBR (Fchar_table_type);
3450 DEFSUBR (Freset_char_table);
3451 DEFSUBR (Fmake_char_table);
3452 DEFSUBR (Fcopy_char_table);
3453 DEFSUBR (Fget_char_table);
3454 DEFSUBR (Fget_range_char_table);
3455 DEFSUBR (Fvalid_char_table_value_p);
3456 DEFSUBR (Fcheck_valid_char_table_value);
3457 DEFSUBR (Fput_char_table);
3458 DEFSUBR (Fmap_char_table);
3461 DEFSUBR (Fcategory_table_p);
3462 DEFSUBR (Fcategory_table);
3463 DEFSUBR (Fstandard_category_table);
3464 DEFSUBR (Fcopy_category_table);
3465 DEFSUBR (Fset_category_table);
3466 DEFSUBR (Fcheck_category_at);
3467 DEFSUBR (Fchar_in_category_p);
3468 DEFSUBR (Fcategory_designator_p);
3469 DEFSUBR (Fcategory_table_value_p);
3475 vars_of_chartab (void)
3478 Vutf_2000_version = build_string("0.17 (Hōryūji)");
3479 DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3480 Version number of XEmacs UTF-2000.
3483 staticpro (&Vcharacter_composition_table);
3484 Vcharacter_composition_table = make_char_id_table (Qnil);
3486 staticpro (&Vcharacter_variant_table);
3487 Vcharacter_variant_table = make_char_id_table (Qnil);
3489 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
3490 Vall_syntax_tables = Qnil;
3491 dump_add_weak_object_chain (&Vall_syntax_tables);
3495 structure_type_create_chartab (void)
3497 struct structure_type *st;
3499 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3501 define_structure_type_keyword (st, Qtype, chartab_type_validate);
3502 define_structure_type_keyword (st, Qdata, chartab_data_validate);
3506 complex_vars_of_chartab (void)
3509 staticpro (&Vchar_attribute_hash_table);
3510 Vchar_attribute_hash_table
3511 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3512 #endif /* UTF2000 */
3514 /* Set this now, so first buffer creation can refer to it. */
3515 /* Make it nil before calling copy-category-table
3516 so that copy-category-table will know not to try to copy from garbage */
3517 Vstandard_category_table = Qnil;
3518 Vstandard_category_table = Fcopy_category_table (Qnil);
3519 staticpro (&Vstandard_category_table);
3521 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3522 List of pair (cons) of categories to determine word boundary.
3524 Emacs treats a sequence of word constituent characters as a single
3525 word (i.e. finds no word boundary between them) iff they belongs to
3526 the same charset. But, exceptions are allowed in the following cases.
3528 \(1) The case that characters are in different charsets is controlled
3529 by the variable `word-combining-categories'.
3531 Emacs finds no word boundary between characters of different charsets
3532 if they have categories matching some element of this list.
3534 More precisely, if an element of this list is a cons of category CAT1
3535 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3536 C2 which has CAT2, there's no word boundary between C1 and C2.
3538 For instance, to tell that ASCII characters and Latin-1 characters can
3539 form a single word, the element `(?l . ?l)' should be in this list
3540 because both characters have the category `l' (Latin characters).
3542 \(2) The case that character are in the same charset is controlled by
3543 the variable `word-separating-categories'.
3545 Emacs find a word boundary between characters of the same charset
3546 if they have categories matching some element of this list.
3548 More precisely, if an element of this list is a cons of category CAT1
3549 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3550 C2 which has CAT2, there's a word boundary between C1 and C2.
3552 For instance, to tell that there's a word boundary between Japanese
3553 Hiragana and Japanese Kanji (both are in the same charset), the
3554 element `(?H . ?C) should be in this list.
3557 Vword_combining_categories = Qnil;
3559 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3560 List of pair (cons) of categories to determine word boundary.
3561 See the documentation of the variable `word-combining-categories'.
3564 Vword_separating_categories = Qnil;