1 /* XEmacs routines to deal with char tables.
2 Copyright (C) 1992, 1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
5 Copyright (C) 1995, 1997, 1999 Electrotechnical Laboratory, JAPAN.
6 Licensed to the Free Software Foundation.
7 Copyright (C) 1999,2000,2001 MORIOKA Tomohiko
9 This file is part of XEmacs.
11 XEmacs is free software; you can redistribute it and/or modify it
12 under the terms of the GNU General Public License as published by the
13 Free Software Foundation; either version 2, or (at your option) any
16 XEmacs is distributed in the hope that it will be useful, but WITHOUT
17 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
18 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
21 You should have received a copy of the GNU General Public License
22 along with XEmacs; see the file COPYING. If not, write to
23 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 Boston, MA 02111-1307, USA. */
26 /* Synched up with: Mule 2.3. Not synched with FSF.
28 This file was written independently of the FSF implementation,
29 and is not compatible. */
33 Ben Wing: wrote, for 19.13 (Mule). Some category table stuff
34 loosely based on the original Mule.
35 Jareth Hein: fixed a couple of bugs in the implementation, and
36 added regex support for categories with check_category_at
49 Lisp_Object Vutf_2000_version;
52 Lisp_Object Qchar_tablep, Qchar_table;
54 Lisp_Object Vall_syntax_tables;
57 Lisp_Object Qcategory_table_p;
58 Lisp_Object Qcategory_designator_p;
59 Lisp_Object Qcategory_table_value_p;
61 Lisp_Object Vstandard_category_table;
63 /* Variables to determine word boundary. */
64 Lisp_Object Vword_combining_categories, Vword_separating_categories;
70 #define BT_UINT8_MIN 0
71 #define BT_UINT8_MAX (UCHAR_MAX - 3)
72 #define BT_UINT8_t (UCHAR_MAX - 2)
73 #define BT_UINT8_nil (UCHAR_MAX - 1)
74 #define BT_UINT8_unbound UCHAR_MAX
76 INLINE_HEADER int INT_UINT8_P (Lisp_Object obj);
77 INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj);
78 INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj);
79 INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n);
80 INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n);
83 INT_UINT8_P (Lisp_Object obj)
89 return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX);
96 UINT8_VALUE_P (Lisp_Object obj)
98 return EQ (obj, Qunbound)
99 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj);
102 INLINE_HEADER unsigned char
103 UINT8_ENCODE (Lisp_Object obj)
105 if (EQ (obj, Qunbound))
106 return BT_UINT8_unbound;
107 else if (EQ (obj, Qnil))
109 else if (EQ (obj, Qt))
115 INLINE_HEADER Lisp_Object
116 UINT8_DECODE (unsigned char n)
118 if (n == BT_UINT8_unbound)
120 else if (n == BT_UINT8_nil)
122 else if (n == BT_UINT8_t)
129 mark_uint8_byte_table (Lisp_Object obj)
135 print_uint8_byte_table (Lisp_Object obj,
136 Lisp_Object printcharfun, int escapeflag)
138 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
140 struct gcpro gcpro1, gcpro2;
141 GCPRO2 (obj, printcharfun);
143 write_c_string ("\n#<uint8-byte-table", printcharfun);
144 for (i = 0; i < 256; i++)
146 unsigned char n = bte->property[i];
148 write_c_string ("\n ", printcharfun);
149 write_c_string (" ", printcharfun);
150 if (n == BT_UINT8_unbound)
151 write_c_string ("void", printcharfun);
152 else if (n == BT_UINT8_nil)
153 write_c_string ("nil", printcharfun);
154 else if (n == BT_UINT8_t)
155 write_c_string ("t", printcharfun);
160 sprintf (buf, "%hd", n);
161 write_c_string (buf, printcharfun);
165 write_c_string (">", printcharfun);
169 uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
171 Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1);
172 Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2);
175 for (i = 0; i < 256; i++)
176 if (te1->property[i] != te2->property[i])
182 uint8_byte_table_hash (Lisp_Object obj, int depth)
184 Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj);
188 for (i = 0; i < 256; i++)
189 hash = HASH2 (hash, te->property[i]);
193 static const struct lrecord_description uint8_byte_table_description[] = {
197 DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table,
198 mark_uint8_byte_table,
199 print_uint8_byte_table,
200 0, uint8_byte_table_equal,
201 uint8_byte_table_hash,
202 uint8_byte_table_description,
203 Lisp_Uint8_Byte_Table);
206 make_uint8_byte_table (unsigned char initval)
210 Lisp_Uint8_Byte_Table *cte;
212 cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
213 &lrecord_uint8_byte_table);
215 for (i = 0; i < 256; i++)
216 cte->property[i] = initval;
218 XSETUINT8_BYTE_TABLE (obj, cte);
223 copy_uint8_byte_table (Lisp_Object entry)
225 Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry);
228 Lisp_Uint8_Byte_Table *ctenew
229 = alloc_lcrecord_type (Lisp_Uint8_Byte_Table,
230 &lrecord_uint8_byte_table);
232 for (i = 0; i < 256; i++)
234 ctenew->property[i] = cte->property[i];
237 XSETUINT8_BYTE_TABLE (obj, ctenew);
242 uint8_byte_table_same_value_p (Lisp_Object obj)
244 Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj);
245 unsigned char v0 = bte->property[0];
248 for (i = 1; i < 256; i++)
250 if (bte->property[i] != v0)
257 map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place,
258 int (*fn) (struct chartab_range *range,
259 Lisp_Object val, void *arg),
262 struct chartab_range rainj;
264 int unit = 1 << (8 * place);
268 rainj.type = CHARTAB_RANGE_CHAR;
270 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
272 if (ct->property[i] != BT_UINT8_unbound)
275 for (; c < c1 && retval == 0; c++)
278 retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg);
287 #define BT_UINT16_MIN 0
288 #define BT_UINT16_MAX (USHRT_MAX - 3)
289 #define BT_UINT16_t (USHRT_MAX - 2)
290 #define BT_UINT16_nil (USHRT_MAX - 1)
291 #define BT_UINT16_unbound USHRT_MAX
293 INLINE_HEADER int INT_UINT16_P (Lisp_Object obj);
294 INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj);
295 INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj);
296 INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us);
299 INT_UINT16_P (Lisp_Object obj)
303 int num = XINT (obj);
305 return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX);
312 UINT16_VALUE_P (Lisp_Object obj)
314 return EQ (obj, Qunbound)
315 || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj);
318 INLINE_HEADER unsigned short
319 UINT16_ENCODE (Lisp_Object obj)
321 if (EQ (obj, Qunbound))
322 return BT_UINT16_unbound;
323 else if (EQ (obj, Qnil))
324 return BT_UINT16_nil;
325 else if (EQ (obj, Qt))
331 INLINE_HEADER Lisp_Object
332 UINT16_DECODE (unsigned short n)
334 if (n == BT_UINT16_unbound)
336 else if (n == BT_UINT16_nil)
338 else if (n == BT_UINT16_t)
344 INLINE_HEADER unsigned short
345 UINT8_TO_UINT16 (unsigned char n)
347 if (n == BT_UINT8_unbound)
348 return BT_UINT16_unbound;
349 else if (n == BT_UINT8_nil)
350 return BT_UINT16_nil;
351 else if (n == BT_UINT8_t)
358 mark_uint16_byte_table (Lisp_Object obj)
364 print_uint16_byte_table (Lisp_Object obj,
365 Lisp_Object printcharfun, int escapeflag)
367 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
369 struct gcpro gcpro1, gcpro2;
370 GCPRO2 (obj, printcharfun);
372 write_c_string ("\n#<uint16-byte-table", printcharfun);
373 for (i = 0; i < 256; i++)
375 unsigned short n = bte->property[i];
377 write_c_string ("\n ", printcharfun);
378 write_c_string (" ", printcharfun);
379 if (n == BT_UINT16_unbound)
380 write_c_string ("void", printcharfun);
381 else if (n == BT_UINT16_nil)
382 write_c_string ("nil", printcharfun);
383 else if (n == BT_UINT16_t)
384 write_c_string ("t", printcharfun);
389 sprintf (buf, "%hd", n);
390 write_c_string (buf, printcharfun);
394 write_c_string (">", printcharfun);
398 uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
400 Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1);
401 Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2);
404 for (i = 0; i < 256; i++)
405 if (te1->property[i] != te2->property[i])
411 uint16_byte_table_hash (Lisp_Object obj, int depth)
413 Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj);
417 for (i = 0; i < 256; i++)
418 hash = HASH2 (hash, te->property[i]);
422 static const struct lrecord_description uint16_byte_table_description[] = {
426 DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table,
427 mark_uint16_byte_table,
428 print_uint16_byte_table,
429 0, uint16_byte_table_equal,
430 uint16_byte_table_hash,
431 uint16_byte_table_description,
432 Lisp_Uint16_Byte_Table);
435 make_uint16_byte_table (unsigned short initval)
439 Lisp_Uint16_Byte_Table *cte;
441 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
442 &lrecord_uint16_byte_table);
444 for (i = 0; i < 256; i++)
445 cte->property[i] = initval;
447 XSETUINT16_BYTE_TABLE (obj, cte);
452 copy_uint16_byte_table (Lisp_Object entry)
454 Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry);
457 Lisp_Uint16_Byte_Table *ctenew
458 = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
459 &lrecord_uint16_byte_table);
461 for (i = 0; i < 256; i++)
463 ctenew->property[i] = cte->property[i];
466 XSETUINT16_BYTE_TABLE (obj, ctenew);
471 expand_uint8_byte_table_to_uint16 (Lisp_Object table)
475 Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table);
476 Lisp_Uint16_Byte_Table* cte;
478 cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table,
479 &lrecord_uint16_byte_table);
480 for (i = 0; i < 256; i++)
482 cte->property[i] = UINT8_TO_UINT16 (bte->property[i]);
484 XSETUINT16_BYTE_TABLE (obj, cte);
489 uint16_byte_table_same_value_p (Lisp_Object obj)
491 Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj);
492 unsigned short v0 = bte->property[0];
495 for (i = 1; i < 256; i++)
497 if (bte->property[i] != v0)
504 map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place,
505 int (*fn) (struct chartab_range *range,
506 Lisp_Object val, void *arg),
509 struct chartab_range rainj;
511 int unit = 1 << (8 * place);
515 rainj.type = CHARTAB_RANGE_CHAR;
517 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
519 if (ct->property[i] != BT_UINT16_unbound)
522 for (; c < c1 && retval == 0; c++)
525 retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg);
536 mark_byte_table (Lisp_Object obj)
538 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
541 for (i = 0; i < 256; i++)
543 mark_object (cte->property[i]);
549 print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
551 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
553 struct gcpro gcpro1, gcpro2;
554 GCPRO2 (obj, printcharfun);
556 write_c_string ("\n#<byte-table", printcharfun);
557 for (i = 0; i < 256; i++)
559 Lisp_Object elt = bte->property[i];
561 write_c_string ("\n ", printcharfun);
562 write_c_string (" ", printcharfun);
563 if (EQ (elt, Qunbound))
564 write_c_string ("void", printcharfun);
566 print_internal (elt, printcharfun, escapeflag);
569 write_c_string (">", printcharfun);
573 byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
575 Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1);
576 Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2);
579 for (i = 0; i < 256; i++)
580 if (BYTE_TABLE_P (cte1->property[i]))
582 if (BYTE_TABLE_P (cte2->property[i]))
584 if (!byte_table_equal (cte1->property[i],
585 cte2->property[i], depth + 1))
592 if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
598 byte_table_hash (Lisp_Object obj, int depth)
600 Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
602 return internal_array_hash (cte->property, 256, depth);
605 static const struct lrecord_description byte_table_description[] = {
606 { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
610 DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
615 byte_table_description,
619 make_byte_table (Lisp_Object initval)
623 Lisp_Byte_Table *cte;
625 cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
627 for (i = 0; i < 256; i++)
628 cte->property[i] = initval;
630 XSETBYTE_TABLE (obj, cte);
635 copy_byte_table (Lisp_Object entry)
637 Lisp_Byte_Table *cte = XBYTE_TABLE (entry);
640 Lisp_Byte_Table *ctnew
641 = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
643 for (i = 0; i < 256; i++)
645 if (UINT8_BYTE_TABLE_P (cte->property[i]))
647 ctnew->property[i] = copy_uint8_byte_table (cte->property[i]);
649 else if (UINT16_BYTE_TABLE_P (cte->property[i]))
651 ctnew->property[i] = copy_uint16_byte_table (cte->property[i]);
653 else if (BYTE_TABLE_P (cte->property[i]))
655 ctnew->property[i] = copy_byte_table (cte->property[i]);
658 ctnew->property[i] = cte->property[i];
661 XSETBYTE_TABLE (obj, ctnew);
666 byte_table_same_value_p (Lisp_Object obj)
668 Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
669 Lisp_Object v0 = bte->property[0];
672 for (i = 1; i < 256; i++)
674 if (!internal_equal (bte->property[i], v0, 0))
681 map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place,
682 int (*fn) (struct chartab_range *range,
683 Lisp_Object val, void *arg),
688 int unit = 1 << (8 * place);
691 for (i = 0, retval = 0; i < 256 && retval == 0; i++)
694 if (UINT8_BYTE_TABLE_P (v))
697 = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v),
698 c, place - 1, fn, arg);
701 else if (UINT16_BYTE_TABLE_P (v))
704 = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v),
705 c, place - 1, fn, arg);
708 else if (BYTE_TABLE_P (v))
710 retval = map_over_byte_table (XBYTE_TABLE(v),
711 c, place - 1, fn, arg);
714 else if (!UNBOUNDP (v))
716 struct chartab_range rainj;
717 Emchar c1 = c + unit;
719 rainj.type = CHARTAB_RANGE_CHAR;
721 for (; c < c1 && retval == 0; c++)
724 retval = (fn) (&rainj, v, arg);
735 get_byte_table (Lisp_Object table, unsigned char idx)
737 if (UINT8_BYTE_TABLE_P (table))
738 return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
739 else if (UINT16_BYTE_TABLE_P (table))
740 return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
741 else if (BYTE_TABLE_P (table))
742 return XBYTE_TABLE(table)->property[idx];
748 put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
750 if (UINT8_BYTE_TABLE_P (table))
752 if (UINT8_VALUE_P (value))
754 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
755 if (!UINT8_BYTE_TABLE_P (value) &&
756 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
757 && uint8_byte_table_same_value_p (table))
762 else if (UINT16_VALUE_P (value))
764 Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
766 XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
771 Lisp_Object new = make_byte_table (Qnil);
774 for (i = 0; i < 256; i++)
776 XBYTE_TABLE(new)->property[i]
777 = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
779 XBYTE_TABLE(new)->property[idx] = value;
783 else if (UINT16_BYTE_TABLE_P (table))
785 if (UINT16_VALUE_P (value))
787 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
788 if (!UINT8_BYTE_TABLE_P (value) &&
789 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
790 && uint16_byte_table_same_value_p (table))
797 Lisp_Object new = make_byte_table (Qnil);
800 for (i = 0; i < 256; i++)
802 XBYTE_TABLE(new)->property[i]
803 = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
805 XBYTE_TABLE(new)->property[idx] = value;
809 else if (BYTE_TABLE_P (table))
811 XBYTE_TABLE(table)->property[idx] = value;
812 if (!UINT8_BYTE_TABLE_P (value) &&
813 !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
814 && byte_table_same_value_p (table))
819 else if (!internal_equal (table, value, 0))
821 if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
823 table = make_uint8_byte_table (UINT8_ENCODE (table));
824 XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
826 else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
828 table = make_uint16_byte_table (UINT16_ENCODE (table));
829 XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
833 table = make_byte_table (table);
834 XBYTE_TABLE(table)->property[idx] = value;
842 make_char_id_table (Lisp_Object initval)
845 obj = Fmake_char_table (Qgeneric);
846 fill_char_table (XCHAR_TABLE (obj), initval);
851 Lisp_Object Vcharacter_composition_table;
852 Lisp_Object Vcharacter_variant_table;
855 Lisp_Object Q_decomposition;
859 Lisp_Object Qisolated;
860 Lisp_Object Qinitial;
863 Lisp_Object Qvertical;
864 Lisp_Object QnoBreak;
865 Lisp_Object Qfraction;
875 Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
878 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
884 else if (EQ (v, Qcompat))
886 else if (EQ (v, Qisolated))
888 else if (EQ (v, Qinitial))
890 else if (EQ (v, Qmedial))
892 else if (EQ (v, Qfinal))
894 else if (EQ (v, Qvertical))
896 else if (EQ (v, QnoBreak))
898 else if (EQ (v, Qfraction))
900 else if (EQ (v, Qsuper))
902 else if (EQ (v, Qsub))
904 else if (EQ (v, Qcircle))
906 else if (EQ (v, Qsquare))
908 else if (EQ (v, Qwide))
910 else if (EQ (v, Qnarrow))
912 else if (EQ (v, Qsmall))
914 else if (EQ (v, Qfont))
917 signal_simple_error (err_msg, err_arg);
920 DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
921 Return character corresponding with list.
925 Lisp_Object table = Vcharacter_composition_table;
926 Lisp_Object rest = list;
930 Lisp_Object v = Fcar (rest);
932 Emchar c = to_char_id (v, "Invalid value for composition", list);
934 ret = get_char_id_table (XCHAR_TABLE(table), c);
939 if (!CHAR_TABLEP (ret))
944 else if (!CONSP (rest))
946 else if (CHAR_TABLEP (ret))
949 signal_simple_error ("Invalid table is found with", list);
951 signal_simple_error ("Invalid value for composition", list);
954 DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
955 Return variants of CHARACTER.
959 CHECK_CHAR (character);
960 return Fcopy_list (get_char_id_table
961 (XCHAR_TABLE(Vcharacter_variant_table),
968 /* A char table maps from ranges of characters to values.
970 Implementing a general data structure that maps from arbitrary
971 ranges of numbers to values is tricky to do efficiently. As it
972 happens, it should suffice (and is usually more convenient, anyway)
973 when dealing with characters to restrict the sorts of ranges that
974 can be assigned values, as follows:
977 2) All characters in a charset.
978 3) All characters in a particular row of a charset, where a "row"
979 means all characters with the same first byte.
980 4) A particular character in a charset.
982 We use char tables to generalize the 256-element vectors now
983 littering the Emacs code.
985 Possible uses (all should be converted at some point):
991 5) keyboard-translate-table?
994 abstract type to generalize the Emacs vectors and Mule
995 vectors-of-vectors goo.
998 /************************************************************************/
999 /* Char Table object */
1000 /************************************************************************/
1002 #if defined(MULE)&&!defined(UTF2000)
1005 mark_char_table_entry (Lisp_Object obj)
1007 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1010 for (i = 0; i < 96; i++)
1012 mark_object (cte->level2[i]);
1018 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1020 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
1021 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
1024 for (i = 0; i < 96; i++)
1025 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
1031 static unsigned long
1032 char_table_entry_hash (Lisp_Object obj, int depth)
1034 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
1036 return internal_array_hash (cte->level2, 96, depth);
1039 static const struct lrecord_description char_table_entry_description[] = {
1040 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
1044 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
1045 mark_char_table_entry, internal_object_printer,
1046 0, char_table_entry_equal,
1047 char_table_entry_hash,
1048 char_table_entry_description,
1049 Lisp_Char_Table_Entry);
1053 mark_char_table (Lisp_Object obj)
1055 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1058 mark_object (ct->table);
1062 for (i = 0; i < NUM_ASCII_CHARS; i++)
1063 mark_object (ct->ascii[i]);
1065 for (i = 0; i < NUM_LEADING_BYTES; i++)
1066 mark_object (ct->level1[i]);
1070 return ct->default_value;
1072 return ct->mirror_table;
1076 /* WARNING: All functions of this nature need to be written extremely
1077 carefully to avoid crashes during GC. Cf. prune_specifiers()
1078 and prune_weak_hash_tables(). */
1081 prune_syntax_tables (void)
1083 Lisp_Object rest, prev = Qnil;
1085 for (rest = Vall_syntax_tables;
1087 rest = XCHAR_TABLE (rest)->next_table)
1089 if (! marked_p (rest))
1091 /* This table is garbage. Remove it from the list. */
1093 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
1095 XCHAR_TABLE (prev)->next_table =
1096 XCHAR_TABLE (rest)->next_table;
1102 char_table_type_to_symbol (enum char_table_type type)
1107 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
1108 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
1109 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
1110 case CHAR_TABLE_TYPE_CHAR: return Qchar;
1112 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
1117 static enum char_table_type
1118 symbol_to_char_table_type (Lisp_Object symbol)
1120 CHECK_SYMBOL (symbol);
1122 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
1123 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
1124 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
1125 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
1127 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
1130 signal_simple_error ("Unrecognized char table type", symbol);
1131 return CHAR_TABLE_TYPE_GENERIC; /* not reached */
1135 print_chartab_range (Emchar first, Emchar last, Lisp_Object val,
1136 Lisp_Object printcharfun)
1140 write_c_string (" (", printcharfun);
1141 print_internal (make_char (first), printcharfun, 0);
1142 write_c_string (" ", printcharfun);
1143 print_internal (make_char (last), printcharfun, 0);
1144 write_c_string (") ", printcharfun);
1148 write_c_string (" ", printcharfun);
1149 print_internal (make_char (first), printcharfun, 0);
1150 write_c_string (" ", printcharfun);
1152 print_internal (val, printcharfun, 1);
1155 #if defined(MULE)&&!defined(UTF2000)
1158 print_chartab_charset_row (Lisp_Object charset,
1160 Lisp_Char_Table_Entry *cte,
1161 Lisp_Object printcharfun)
1164 Lisp_Object cat = Qunbound;
1167 for (i = 32; i < 128; i++)
1169 Lisp_Object pam = cte->level2[i - 32];
1181 print_chartab_range (MAKE_CHAR (charset, first, 0),
1182 MAKE_CHAR (charset, i - 1, 0),
1185 print_chartab_range (MAKE_CHAR (charset, row, first),
1186 MAKE_CHAR (charset, row, i - 1),
1196 print_chartab_range (MAKE_CHAR (charset, first, 0),
1197 MAKE_CHAR (charset, i - 1, 0),
1200 print_chartab_range (MAKE_CHAR (charset, row, first),
1201 MAKE_CHAR (charset, row, i - 1),
1207 print_chartab_two_byte_charset (Lisp_Object charset,
1208 Lisp_Char_Table_Entry *cte,
1209 Lisp_Object printcharfun)
1213 for (i = 32; i < 128; i++)
1215 Lisp_Object jen = cte->level2[i - 32];
1217 if (!CHAR_TABLE_ENTRYP (jen))
1221 write_c_string (" [", printcharfun);
1222 print_internal (XCHARSET_NAME (charset), printcharfun, 0);
1223 sprintf (buf, " %d] ", i);
1224 write_c_string (buf, printcharfun);
1225 print_internal (jen, printcharfun, 0);
1228 print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen),
1236 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1238 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1241 struct gcpro gcpro1, gcpro2;
1242 GCPRO2 (obj, printcharfun);
1244 write_c_string ("#s(char-table ", printcharfun);
1245 write_c_string (" ", printcharfun);
1246 write_c_string (string_data
1248 (XSYMBOL (char_table_type_to_symbol (ct->type)))),
1250 write_c_string ("\n ", printcharfun);
1251 print_internal (ct->default_value, printcharfun, escapeflag);
1252 for (i = 0; i < 256; i++)
1254 Lisp_Object elt = get_byte_table (ct->table, i);
1255 if (i != 0) write_c_string ("\n ", printcharfun);
1256 if (EQ (elt, Qunbound))
1257 write_c_string ("void", printcharfun);
1259 print_internal (elt, printcharfun, escapeflag);
1262 #else /* non UTF2000 */
1265 sprintf (buf, "#s(char-table type %s data (",
1266 string_data (symbol_name (XSYMBOL
1267 (char_table_type_to_symbol (ct->type)))));
1268 write_c_string (buf, printcharfun);
1270 /* Now write out the ASCII/Control-1 stuff. */
1274 Lisp_Object val = Qunbound;
1276 for (i = 0; i < NUM_ASCII_CHARS; i++)
1285 if (!EQ (ct->ascii[i], val))
1287 print_chartab_range (first, i - 1, val, printcharfun);
1294 print_chartab_range (first, i - 1, val, printcharfun);
1301 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1304 Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE];
1305 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i);
1307 if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII
1308 || i == LEADING_BYTE_CONTROL_1)
1310 if (!CHAR_TABLE_ENTRYP (ann))
1312 write_c_string (" ", printcharfun);
1313 print_internal (XCHARSET_NAME (charset),
1315 write_c_string (" ", printcharfun);
1316 print_internal (ann, printcharfun, 0);
1320 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann);
1321 if (XCHARSET_DIMENSION (charset) == 1)
1322 print_chartab_charset_row (charset, -1, cte, printcharfun);
1324 print_chartab_two_byte_charset (charset, cte, printcharfun);
1329 #endif /* non UTF2000 */
1331 write_c_string ("))", printcharfun);
1335 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1337 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
1338 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
1341 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
1345 for (i = 0; i < 256; i++)
1347 if (!internal_equal (get_byte_table (ct1->table, i),
1348 get_byte_table (ct2->table, i), 0))
1352 for (i = 0; i < NUM_ASCII_CHARS; i++)
1353 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
1357 for (i = 0; i < NUM_LEADING_BYTES; i++)
1358 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
1361 #endif /* non UTF2000 */
1366 static unsigned long
1367 char_table_hash (Lisp_Object obj, int depth)
1369 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
1371 return byte_table_hash (ct->table, depth + 1);
1373 unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
1376 hashval = HASH2 (hashval,
1377 internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth));
1383 static const struct lrecord_description char_table_description[] = {
1385 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) },
1386 { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) },
1388 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
1390 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
1394 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
1396 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
1400 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
1401 mark_char_table, print_char_table, 0,
1402 char_table_equal, char_table_hash,
1403 char_table_description,
1406 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
1407 Return non-nil if OBJECT is a char table.
1409 A char table is a table that maps characters (or ranges of characters)
1410 to values. Char tables are specialized for characters, only allowing
1411 particular sorts of ranges to be assigned values. Although this
1412 loses in generality, it makes for extremely fast (constant-time)
1413 lookups, and thus is feasible for applications that do an extremely
1414 large number of lookups (e.g. scanning a buffer for a character in
1415 a particular syntax, where a lookup in the syntax table must occur
1416 once per character).
1418 When Mule support exists, the types of ranges that can be assigned
1422 -- an entire charset
1423 -- a single row in a two-octet charset
1424 -- a single character
1426 When Mule support is not present, the types of ranges that can be
1430 -- a single character
1432 To create a char table, use `make-char-table'.
1433 To modify a char table, use `put-char-table' or `remove-char-table'.
1434 To retrieve the value for a particular character, use `get-char-table'.
1435 See also `map-char-table', `clear-char-table', `copy-char-table',
1436 `valid-char-table-type-p', `char-table-type-list',
1437 `valid-char-table-value-p', and `check-char-table-value'.
1441 return CHAR_TABLEP (object) ? Qt : Qnil;
1444 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
1445 Return a list of the recognized char table types.
1446 See `valid-char-table-type-p'.
1451 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
1453 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
1457 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
1458 Return t if TYPE if a recognized char table type.
1460 Each char table type is used for a different purpose and allows different
1461 sorts of values. The different char table types are
1464 Used for category tables, which specify the regexp categories
1465 that a character is in. The valid values are nil or a
1466 bit vector of 95 elements. Higher-level Lisp functions are
1467 provided for working with category tables. Currently categories
1468 and category tables only exist when Mule support is present.
1470 A generalized char table, for mapping from one character to
1471 another. Used for case tables, syntax matching tables,
1472 `keyboard-translate-table', etc. The valid values are characters.
1474 An even more generalized char table, for mapping from a
1475 character to anything.
1477 Used for display tables, which specify how a particular character
1478 is to appear when displayed. #### Not yet implemented.
1480 Used for syntax tables, which specify the syntax of a particular
1481 character. Higher-level Lisp functions are provided for
1482 working with syntax tables. The valid values are integers.
1487 return (EQ (type, Qchar) ||
1489 EQ (type, Qcategory) ||
1491 EQ (type, Qdisplay) ||
1492 EQ (type, Qgeneric) ||
1493 EQ (type, Qsyntax)) ? Qt : Qnil;
1496 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
1497 Return the type of CHAR-TABLE.
1498 See `valid-char-table-type-p'.
1502 CHECK_CHAR_TABLE (char_table);
1503 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
1507 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
1510 ct->table = Qunbound;
1511 ct->default_value = value;
1515 for (i = 0; i < NUM_ASCII_CHARS; i++)
1516 ct->ascii[i] = value;
1518 for (i = 0; i < NUM_LEADING_BYTES; i++)
1519 ct->level1[i] = value;
1524 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
1525 update_syntax_table (ct);
1529 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
1530 Reset CHAR-TABLE to its default state.
1534 Lisp_Char_Table *ct;
1536 CHECK_CHAR_TABLE (char_table);
1537 ct = XCHAR_TABLE (char_table);
1541 case CHAR_TABLE_TYPE_CHAR:
1542 fill_char_table (ct, make_char (0));
1544 case CHAR_TABLE_TYPE_DISPLAY:
1545 case CHAR_TABLE_TYPE_GENERIC:
1547 case CHAR_TABLE_TYPE_CATEGORY:
1549 fill_char_table (ct, Qnil);
1552 case CHAR_TABLE_TYPE_SYNTAX:
1553 fill_char_table (ct, make_int (Sinherit));
1563 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
1564 Return a new, empty char table of type TYPE.
1565 Currently recognized types are 'char, 'category, 'display, 'generic,
1566 and 'syntax. See `valid-char-table-type-p'.
1570 Lisp_Char_Table *ct;
1572 enum char_table_type ty = symbol_to_char_table_type (type);
1574 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1577 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1579 ct->mirror_table = Fmake_char_table (Qgeneric);
1580 fill_char_table (XCHAR_TABLE (ct->mirror_table),
1584 ct->mirror_table = Qnil;
1586 ct->next_table = Qnil;
1587 XSETCHAR_TABLE (obj, ct);
1588 if (ty == CHAR_TABLE_TYPE_SYNTAX)
1590 ct->next_table = Vall_syntax_tables;
1591 Vall_syntax_tables = obj;
1593 Freset_char_table (obj);
1597 #if defined(MULE)&&!defined(UTF2000)
1600 make_char_table_entry (Lisp_Object initval)
1604 Lisp_Char_Table_Entry *cte =
1605 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1607 for (i = 0; i < 96; i++)
1608 cte->level2[i] = initval;
1610 XSETCHAR_TABLE_ENTRY (obj, cte);
1615 copy_char_table_entry (Lisp_Object entry)
1617 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
1620 Lisp_Char_Table_Entry *ctenew =
1621 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
1623 for (i = 0; i < 96; i++)
1625 Lisp_Object new = cte->level2[i];
1626 if (CHAR_TABLE_ENTRYP (new))
1627 ctenew->level2[i] = copy_char_table_entry (new);
1629 ctenew->level2[i] = new;
1632 XSETCHAR_TABLE_ENTRY (obj, ctenew);
1638 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
1639 Return a new char table which is a copy of CHAR-TABLE.
1640 It will contain the same values for the same characters and ranges
1641 as CHAR-TABLE. The values will not themselves be copied.
1645 Lisp_Char_Table *ct, *ctnew;
1651 CHECK_CHAR_TABLE (char_table);
1652 ct = XCHAR_TABLE (char_table);
1653 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
1654 ctnew->type = ct->type;
1656 ctnew->default_value = ct->default_value;
1658 if (UINT8_BYTE_TABLE_P (ct->table))
1660 ctnew->table = copy_uint8_byte_table (ct->table);
1662 else if (UINT16_BYTE_TABLE_P (ct->table))
1664 ctnew->table = copy_uint16_byte_table (ct->table);
1666 else if (BYTE_TABLE_P (ct->table))
1668 ctnew->table = copy_byte_table (ct->table);
1670 else if (!UNBOUNDP (ct->table))
1671 ctnew->table = ct->table;
1672 #else /* non UTF2000 */
1674 for (i = 0; i < NUM_ASCII_CHARS; i++)
1676 Lisp_Object new = ct->ascii[i];
1678 assert (! (CHAR_TABLE_ENTRYP (new)));
1680 ctnew->ascii[i] = new;
1685 for (i = 0; i < NUM_LEADING_BYTES; i++)
1687 Lisp_Object new = ct->level1[i];
1688 if (CHAR_TABLE_ENTRYP (new))
1689 ctnew->level1[i] = copy_char_table_entry (new);
1691 ctnew->level1[i] = new;
1695 #endif /* non UTF2000 */
1698 if (CHAR_TABLEP (ct->mirror_table))
1699 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
1701 ctnew->mirror_table = ct->mirror_table;
1703 ctnew->next_table = Qnil;
1704 XSETCHAR_TABLE (obj, ctnew);
1705 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
1707 ctnew->next_table = Vall_syntax_tables;
1708 Vall_syntax_tables = obj;
1713 INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
1715 XCHARSET_CELL_RANGE (Lisp_Object ccs)
1717 switch (XCHARSET_CHARS (ccs))
1720 return (33 << 8) | 126;
1722 return (32 << 8) | 127;
1725 return (0 << 8) | 127;
1727 return (0 << 8) | 255;
1739 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
1742 outrange->type = CHARTAB_RANGE_ALL;
1743 else if (EQ (range, Qnil))
1744 outrange->type = CHARTAB_RANGE_DEFAULT;
1745 else if (CHAR_OR_CHAR_INTP (range))
1747 outrange->type = CHARTAB_RANGE_CHAR;
1748 outrange->ch = XCHAR_OR_CHAR_INT (range);
1752 signal_simple_error ("Range must be t or a character", range);
1754 else if (VECTORP (range))
1756 Lisp_Vector *vec = XVECTOR (range);
1757 Lisp_Object *elts = vector_data (vec);
1758 int cell_min, cell_max;
1760 outrange->type = CHARTAB_RANGE_ROW;
1761 outrange->charset = Fget_charset (elts[0]);
1762 CHECK_INT (elts[1]);
1763 outrange->row = XINT (elts[1]);
1764 if (XCHARSET_DIMENSION (outrange->charset) < 2)
1765 signal_simple_error ("Charset in row vector must be multi-byte",
1769 int ret = XCHARSET_CELL_RANGE (outrange->charset);
1771 cell_min = ret >> 8;
1772 cell_max = ret & 0xFF;
1774 if (XCHARSET_DIMENSION (outrange->charset) == 2)
1775 check_int_range (outrange->row, cell_min, cell_max);
1777 else if (XCHARSET_DIMENSION (outrange->charset) == 3)
1779 check_int_range (outrange->row >> 8 , cell_min, cell_max);
1780 check_int_range (outrange->row & 0xFF, cell_min, cell_max);
1782 else if (XCHARSET_DIMENSION (outrange->charset) == 4)
1784 check_int_range ( outrange->row >> 16 , cell_min, cell_max);
1785 check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
1786 check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
1794 if (!CHARSETP (range) && !SYMBOLP (range))
1796 ("Char table range must be t, charset, char, or vector", range);
1797 outrange->type = CHARTAB_RANGE_CHARSET;
1798 outrange->charset = Fget_charset (range);
1803 #if defined(MULE)&&!defined(UTF2000)
1805 /* called from CHAR_TABLE_VALUE(). */
1807 get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
1812 Lisp_Object charset;
1814 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
1819 BREAKUP_CHAR (c, charset, byte1, byte2);
1821 BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
1823 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
1824 if (CHAR_TABLE_ENTRYP (val))
1826 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1827 val = cte->level2[byte1 - 32];
1828 if (CHAR_TABLE_ENTRYP (val))
1830 cte = XCHAR_TABLE_ENTRY (val);
1831 assert (byte2 >= 32);
1832 val = cte->level2[byte2 - 32];
1833 assert (!CHAR_TABLE_ENTRYP (val));
1843 get_char_table (Emchar ch, Lisp_Char_Table *ct)
1846 return get_char_id_table (ct, ch);
1849 Lisp_Object charset;
1853 BREAKUP_CHAR (ch, charset, byte1, byte2);
1855 if (EQ (charset, Vcharset_ascii))
1856 val = ct->ascii[byte1];
1857 else if (EQ (charset, Vcharset_control_1))
1858 val = ct->ascii[byte1 + 128];
1861 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
1862 val = ct->level1[lb];
1863 if (CHAR_TABLE_ENTRYP (val))
1865 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
1866 val = cte->level2[byte1 - 32];
1867 if (CHAR_TABLE_ENTRYP (val))
1869 cte = XCHAR_TABLE_ENTRY (val);
1870 assert (byte2 >= 32);
1871 val = cte->level2[byte2 - 32];
1872 assert (!CHAR_TABLE_ENTRYP (val));
1879 #else /* not MULE */
1880 return ct->ascii[(unsigned char)ch];
1881 #endif /* not MULE */
1885 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
1886 Find value for CHARACTER in CHAR-TABLE.
1888 (character, char_table))
1890 CHECK_CHAR_TABLE (char_table);
1891 CHECK_CHAR_COERCE_INT (character);
1893 return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
1896 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
1897 Find value for a range in CHAR-TABLE.
1898 If there is more than one value, return MULTI (defaults to nil).
1900 (range, char_table, multi))
1902 Lisp_Char_Table *ct;
1903 struct chartab_range rainj;
1905 if (CHAR_OR_CHAR_INTP (range))
1906 return Fget_char_table (range, char_table);
1907 CHECK_CHAR_TABLE (char_table);
1908 ct = XCHAR_TABLE (char_table);
1910 decode_char_table_range (range, &rainj);
1913 case CHARTAB_RANGE_ALL:
1916 if (UINT8_BYTE_TABLE_P (ct->table))
1918 else if (UINT16_BYTE_TABLE_P (ct->table))
1920 else if (BYTE_TABLE_P (ct->table))
1924 #else /* non UTF2000 */
1926 Lisp_Object first = ct->ascii[0];
1928 for (i = 1; i < NUM_ASCII_CHARS; i++)
1929 if (!EQ (first, ct->ascii[i]))
1933 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
1936 if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
1937 || i == LEADING_BYTE_ASCII
1938 || i == LEADING_BYTE_CONTROL_1)
1940 if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
1946 #endif /* non UTF2000 */
1950 case CHARTAB_RANGE_CHARSET:
1954 if (EQ (rainj.charset, Vcharset_ascii))
1957 Lisp_Object first = ct->ascii[0];
1959 for (i = 1; i < 128; i++)
1960 if (!EQ (first, ct->ascii[i]))
1965 if (EQ (rainj.charset, Vcharset_control_1))
1968 Lisp_Object first = ct->ascii[128];
1970 for (i = 129; i < 160; i++)
1971 if (!EQ (first, ct->ascii[i]))
1977 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
1979 if (CHAR_TABLE_ENTRYP (val))
1985 case CHARTAB_RANGE_ROW:
1990 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
1992 if (!CHAR_TABLE_ENTRYP (val))
1994 val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
1995 if (CHAR_TABLE_ENTRYP (val))
1999 #endif /* not UTF2000 */
2000 #endif /* not MULE */
2006 return Qnil; /* not reached */
2010 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
2011 Error_behavior errb)
2015 case CHAR_TABLE_TYPE_SYNTAX:
2016 if (!ERRB_EQ (errb, ERROR_ME))
2017 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
2018 && CHAR_OR_CHAR_INTP (XCDR (value)));
2021 Lisp_Object cdr = XCDR (value);
2022 CHECK_INT (XCAR (value));
2023 CHECK_CHAR_COERCE_INT (cdr);
2030 case CHAR_TABLE_TYPE_CATEGORY:
2031 if (!ERRB_EQ (errb, ERROR_ME))
2032 return CATEGORY_TABLE_VALUEP (value);
2033 CHECK_CATEGORY_TABLE_VALUE (value);
2037 case CHAR_TABLE_TYPE_GENERIC:
2040 case CHAR_TABLE_TYPE_DISPLAY:
2042 maybe_signal_simple_error ("Display char tables not yet implemented",
2043 value, Qchar_table, errb);
2046 case CHAR_TABLE_TYPE_CHAR:
2047 if (!ERRB_EQ (errb, ERROR_ME))
2048 return CHAR_OR_CHAR_INTP (value);
2049 CHECK_CHAR_COERCE_INT (value);
2056 return 0; /* not reached */
2060 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
2064 case CHAR_TABLE_TYPE_SYNTAX:
2067 Lisp_Object car = XCAR (value);
2068 Lisp_Object cdr = XCDR (value);
2069 CHECK_CHAR_COERCE_INT (cdr);
2070 return Fcons (car, cdr);
2073 case CHAR_TABLE_TYPE_CHAR:
2074 CHECK_CHAR_COERCE_INT (value);
2082 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
2083 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
2085 (value, char_table_type))
2087 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2089 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
2092 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
2093 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
2095 (value, char_table_type))
2097 enum char_table_type type = symbol_to_char_table_type (char_table_type);
2099 check_valid_char_table_value (value, type, ERROR_ME);
2103 /* Assign VAL to all characters in RANGE in char table CT. */
2106 put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
2109 switch (range->type)
2111 case CHARTAB_RANGE_ALL:
2112 /* printf ("put-char-table: range = all\n"); */
2113 fill_char_table (ct, val);
2114 return; /* avoid the duplicate call to update_syntax_table() below,
2115 since fill_char_table() also did that. */
2118 case CHARTAB_RANGE_DEFAULT:
2119 ct->default_value = val;
2124 case CHARTAB_RANGE_CHARSET:
2128 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
2130 /* printf ("put-char-table: range = charset: %d\n",
2131 XCHARSET_LEADING_BYTE (range->charset));
2133 if ( CHAR_TABLEP (encoding_table) )
2135 for (c = 0; c < 1 << 24; c++)
2137 if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
2139 put_char_id_table_0 (ct, c, val);
2144 for (c = 0; c < 1 << 24; c++)
2146 if ( charset_code_point (range->charset, c, 0) >= 0 )
2147 put_char_id_table_0 (ct, c, val);
2152 if (EQ (range->charset, Vcharset_ascii))
2155 for (i = 0; i < 128; i++)
2158 else if (EQ (range->charset, Vcharset_control_1))
2161 for (i = 128; i < 160; i++)
2166 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2167 ct->level1[lb] = val;
2172 case CHARTAB_RANGE_ROW:
2175 int cell_min, cell_max, i;
2177 i = XCHARSET_CELL_RANGE (range->charset);
2179 cell_max = i & 0xFF;
2180 for (i = cell_min; i <= cell_max; i++)
2182 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2184 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2185 put_char_id_table_0 (ct, ch, val);
2190 Lisp_Char_Table_Entry *cte;
2191 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
2192 /* make sure that there is a separate entry for the row. */
2193 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2194 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2195 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2196 cte->level2[range->row - 32] = val;
2198 #endif /* not UTF2000 */
2202 case CHARTAB_RANGE_CHAR:
2204 /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
2205 put_char_id_table_0 (ct, range->ch, val);
2209 Lisp_Object charset;
2212 BREAKUP_CHAR (range->ch, charset, byte1, byte2);
2213 if (EQ (charset, Vcharset_ascii))
2214 ct->ascii[byte1] = val;
2215 else if (EQ (charset, Vcharset_control_1))
2216 ct->ascii[byte1 + 128] = val;
2219 Lisp_Char_Table_Entry *cte;
2220 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
2221 /* make sure that there is a separate entry for the row. */
2222 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
2223 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
2224 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
2225 /* now CTE is a char table entry for the charset;
2226 each entry is for a single row (or character of
2227 a one-octet charset). */
2228 if (XCHARSET_DIMENSION (charset) == 1)
2229 cte->level2[byte1 - 32] = val;
2232 /* assigning to one character in a two-octet charset. */
2233 /* make sure that the charset row contains a separate
2234 entry for each character. */
2235 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
2236 cte->level2[byte1 - 32] =
2237 make_char_table_entry (cte->level2[byte1 - 32]);
2238 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
2239 cte->level2[byte2 - 32] = val;
2243 #else /* not MULE */
2244 ct->ascii[(unsigned char) (range->ch)] = val;
2246 #endif /* not MULE */
2250 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
2251 update_syntax_table (ct);
2255 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
2256 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
2258 RANGE specifies one or more characters to be affected and should be
2259 one of the following:
2261 -- t (all characters are affected)
2262 -- A charset (only allowed when Mule support is present)
2263 -- A vector of two elements: a two-octet charset and a row number
2264 (only allowed when Mule support is present)
2265 -- A single character
2267 VALUE must be a value appropriate for the type of CHAR-TABLE.
2268 See `valid-char-table-type-p'.
2270 (range, value, char_table))
2272 Lisp_Char_Table *ct;
2273 struct chartab_range rainj;
2275 CHECK_CHAR_TABLE (char_table);
2276 ct = XCHAR_TABLE (char_table);
2277 check_valid_char_table_value (value, ct->type, ERROR_ME);
2278 decode_char_table_range (range, &rainj);
2279 value = canonicalize_char_table_value (value, ct->type);
2280 put_char_table (ct, &rainj, value);
2285 /* Map FN over the ASCII chars in CT. */
2288 map_over_charset_ascii (Lisp_Char_Table *ct,
2289 int (*fn) (struct chartab_range *range,
2290 Lisp_Object val, void *arg),
2293 struct chartab_range rainj;
2302 rainj.type = CHARTAB_RANGE_CHAR;
2304 for (i = start, retval = 0; i < stop && retval == 0; i++)
2306 rainj.ch = (Emchar) i;
2307 retval = (fn) (&rainj, ct->ascii[i], arg);
2315 /* Map FN over the Control-1 chars in CT. */
2318 map_over_charset_control_1 (Lisp_Char_Table *ct,
2319 int (*fn) (struct chartab_range *range,
2320 Lisp_Object val, void *arg),
2323 struct chartab_range rainj;
2326 int stop = start + 32;
2328 rainj.type = CHARTAB_RANGE_CHAR;
2330 for (i = start, retval = 0; i < stop && retval == 0; i++)
2332 rainj.ch = (Emchar) (i);
2333 retval = (fn) (&rainj, ct->ascii[i], arg);
2339 /* Map FN over the row ROW of two-byte charset CHARSET.
2340 There must be a separate value for that row in the char table.
2341 CTE specifies the char table entry for CHARSET. */
2344 map_over_charset_row (Lisp_Char_Table_Entry *cte,
2345 Lisp_Object charset, int row,
2346 int (*fn) (struct chartab_range *range,
2347 Lisp_Object val, void *arg),
2350 Lisp_Object val = cte->level2[row - 32];
2352 if (!CHAR_TABLE_ENTRYP (val))
2354 struct chartab_range rainj;
2356 rainj.type = CHARTAB_RANGE_ROW;
2357 rainj.charset = charset;
2359 return (fn) (&rainj, val, arg);
2363 struct chartab_range rainj;
2365 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2366 int start = charset94_p ? 33 : 32;
2367 int stop = charset94_p ? 127 : 128;
2369 cte = XCHAR_TABLE_ENTRY (val);
2371 rainj.type = CHARTAB_RANGE_CHAR;
2373 for (i = start, retval = 0; i < stop && retval == 0; i++)
2375 rainj.ch = MAKE_CHAR (charset, row, i);
2376 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2384 map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb,
2385 int (*fn) (struct chartab_range *range,
2386 Lisp_Object val, void *arg),
2389 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
2390 Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb);
2392 if (!CHARSETP (charset)
2393 || lb == LEADING_BYTE_ASCII
2394 || lb == LEADING_BYTE_CONTROL_1)
2397 if (!CHAR_TABLE_ENTRYP (val))
2399 struct chartab_range rainj;
2401 rainj.type = CHARTAB_RANGE_CHARSET;
2402 rainj.charset = charset;
2403 return (fn) (&rainj, val, arg);
2407 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
2408 int charset94_p = (XCHARSET_CHARS (charset) == 94);
2409 int start = charset94_p ? 33 : 32;
2410 int stop = charset94_p ? 127 : 128;
2413 if (XCHARSET_DIMENSION (charset) == 1)
2415 struct chartab_range rainj;
2416 rainj.type = CHARTAB_RANGE_CHAR;
2418 for (i = start, retval = 0; i < stop && retval == 0; i++)
2420 rainj.ch = MAKE_CHAR (charset, i, 0);
2421 retval = (fn) (&rainj, cte->level2[i - 32], arg);
2426 for (i = start, retval = 0; i < stop && retval == 0; i++)
2427 retval = map_over_charset_row (cte, charset, i, fn, arg);
2435 #endif /* not UTF2000 */
2438 struct map_char_table_for_charset_arg
2440 int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg);
2441 Lisp_Char_Table *ct;
2446 map_char_table_for_charset_fun (struct chartab_range *range,
2447 Lisp_Object val, void *arg)
2449 struct map_char_table_for_charset_arg *closure =
2450 (struct map_char_table_for_charset_arg *) arg;
2453 switch (range->type)
2455 case CHARTAB_RANGE_ALL:
2458 case CHARTAB_RANGE_DEFAULT:
2461 case CHARTAB_RANGE_CHARSET:
2464 case CHARTAB_RANGE_ROW:
2467 case CHARTAB_RANGE_CHAR:
2468 ret = get_char_table (range->ch, closure->ct);
2469 if (!UNBOUNDP (ret))
2470 return (closure->fn) (range, ret, closure->arg);
2481 /* Map FN (with client data ARG) over range RANGE in char table CT.
2482 Mapping stops the first time FN returns non-zero, and that value
2483 becomes the return value of map_char_table(). */
2486 map_char_table (Lisp_Char_Table *ct,
2487 struct chartab_range *range,
2488 int (*fn) (struct chartab_range *range,
2489 Lisp_Object val, void *arg),
2492 switch (range->type)
2494 case CHARTAB_RANGE_ALL:
2496 if (!UNBOUNDP (ct->default_value))
2498 struct chartab_range rainj;
2501 rainj.type = CHARTAB_RANGE_DEFAULT;
2502 retval = (fn) (&rainj, ct->default_value, arg);
2506 if (UINT8_BYTE_TABLE_P (ct->table))
2507 return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table),
2509 else if (UINT16_BYTE_TABLE_P (ct->table))
2510 return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table),
2512 else if (BYTE_TABLE_P (ct->table))
2513 return map_over_byte_table (XBYTE_TABLE(ct->table),
2515 else if (!UNBOUNDP (ct->table))
2518 struct chartab_range rainj;
2521 Emchar c1 = c + unit;
2524 rainj.type = CHARTAB_RANGE_CHAR;
2526 for (retval = 0; c < c1 && retval == 0; c++)
2529 retval = (fn) (&rainj, ct->table, arg);
2534 return (fn) (range, ct->table, arg);
2541 retval = map_over_charset_ascii (ct, fn, arg);
2545 retval = map_over_charset_control_1 (ct, fn, arg);
2550 Charset_ID start = MIN_LEADING_BYTE;
2551 Charset_ID stop = start + NUM_LEADING_BYTES;
2553 for (i = start, retval = 0; i < stop && retval == 0; i++)
2555 retval = map_over_other_charset (ct, i, fn, arg);
2564 case CHARTAB_RANGE_DEFAULT:
2565 if (!UNBOUNDP (ct->default_value))
2566 return (fn) (range, ct->default_value, arg);
2571 case CHARTAB_RANGE_CHARSET:
2574 Lisp_Object encoding_table
2575 = XCHARSET_ENCODING_TABLE (range->charset);
2577 if (!NILP (encoding_table))
2579 struct chartab_range rainj;
2580 struct map_char_table_for_charset_arg mcarg;
2585 rainj.type = CHARTAB_RANGE_ALL;
2586 return map_char_table (XCHAR_TABLE(encoding_table),
2588 &map_char_table_for_charset_fun,
2594 return map_over_other_charset (ct,
2595 XCHARSET_LEADING_BYTE (range->charset),
2599 case CHARTAB_RANGE_ROW:
2602 int cell_min, cell_max, i;
2604 struct chartab_range rainj;
2606 i = XCHARSET_CELL_RANGE (range->charset);
2608 cell_max = i & 0xFF;
2609 rainj.type = CHARTAB_RANGE_CHAR;
2610 for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++)
2612 Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
2614 if ( charset_code_point (range->charset, ch, 0) >= 0 )
2617 = get_byte_table (get_byte_table
2621 (unsigned char)(ch >> 24)),
2622 (unsigned char) (ch >> 16)),
2623 (unsigned char) (ch >> 8)),
2624 (unsigned char) ch);
2627 val = ct->default_value;
2629 retval = (fn) (&rainj, val, arg);
2636 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset)
2637 - MIN_LEADING_BYTE];
2638 if (!CHAR_TABLE_ENTRYP (val))
2640 struct chartab_range rainj;
2642 rainj.type = CHARTAB_RANGE_ROW;
2643 rainj.charset = range->charset;
2644 rainj.row = range->row;
2645 return (fn) (&rainj, val, arg);
2648 return map_over_charset_row (XCHAR_TABLE_ENTRY (val),
2649 range->charset, range->row,
2652 #endif /* not UTF2000 */
2655 case CHARTAB_RANGE_CHAR:
2657 Emchar ch = range->ch;
2658 Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch);
2660 if (!UNBOUNDP (val))
2662 struct chartab_range rainj;
2664 rainj.type = CHARTAB_RANGE_CHAR;
2666 return (fn) (&rainj, val, arg);
2678 struct slow_map_char_table_arg
2680 Lisp_Object function;
2685 slow_map_char_table_fun (struct chartab_range *range,
2686 Lisp_Object val, void *arg)
2688 Lisp_Object ranjarg = Qnil;
2689 struct slow_map_char_table_arg *closure =
2690 (struct slow_map_char_table_arg *) arg;
2692 switch (range->type)
2694 case CHARTAB_RANGE_ALL:
2699 case CHARTAB_RANGE_DEFAULT:
2705 case CHARTAB_RANGE_CHARSET:
2706 ranjarg = XCHARSET_NAME (range->charset);
2709 case CHARTAB_RANGE_ROW:
2710 ranjarg = vector2 (XCHARSET_NAME (range->charset),
2711 make_int (range->row));
2714 case CHARTAB_RANGE_CHAR:
2715 ranjarg = make_char (range->ch);
2721 closure->retval = call2 (closure->function, ranjarg, val);
2722 return !NILP (closure->retval);
2725 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
2726 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
2727 each key and value in the table.
2729 RANGE specifies a subrange to map over and is in the same format as
2730 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
2733 (function, char_table, range))
2735 Lisp_Char_Table *ct;
2736 struct slow_map_char_table_arg slarg;
2737 struct gcpro gcpro1, gcpro2;
2738 struct chartab_range rainj;
2740 CHECK_CHAR_TABLE (char_table);
2741 ct = XCHAR_TABLE (char_table);
2744 decode_char_table_range (range, &rainj);
2745 slarg.function = function;
2746 slarg.retval = Qnil;
2747 GCPRO2 (slarg.function, slarg.retval);
2748 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
2751 return slarg.retval;
2755 /************************************************************************/
2756 /* Character Attributes */
2757 /************************************************************************/
2761 Lisp_Object Vchar_attribute_hash_table;
2763 /* We store the char-attributes in hash tables with the names as the
2764 key and the actual char-id-table object as the value. Occasionally
2765 we need to use them in a list format. These routines provide us
2767 struct char_attribute_list_closure
2769 Lisp_Object *char_attribute_list;
2773 add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
2774 void *char_attribute_list_closure)
2776 /* This function can GC */
2777 struct char_attribute_list_closure *calcl
2778 = (struct char_attribute_list_closure*) char_attribute_list_closure;
2779 Lisp_Object *char_attribute_list = calcl->char_attribute_list;
2781 *char_attribute_list = Fcons (key, *char_attribute_list);
2785 DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
2786 Return the list of all existing character attributes except coded-charsets.
2790 Lisp_Object char_attribute_list = Qnil;
2791 struct gcpro gcpro1;
2792 struct char_attribute_list_closure char_attribute_list_closure;
2794 GCPRO1 (char_attribute_list);
2795 char_attribute_list_closure.char_attribute_list = &char_attribute_list;
2796 elisp_maphash (add_char_attribute_to_list_mapper,
2797 Vchar_attribute_hash_table,
2798 &char_attribute_list_closure);
2800 return char_attribute_list;
2803 DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
2804 Return char-id-table corresponding to ATTRIBUTE.
2808 return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
2812 /* We store the char-id-tables in hash tables with the attributes as
2813 the key and the actual char-id-table object as the value. Each
2814 char-id-table stores values of an attribute corresponding with
2815 characters. Occasionally we need to get attributes of a character
2816 in a association-list format. These routines provide us with
2818 struct char_attribute_alist_closure
2821 Lisp_Object *char_attribute_alist;
2825 add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
2826 void *char_attribute_alist_closure)
2828 /* This function can GC */
2829 struct char_attribute_alist_closure *caacl =
2830 (struct char_attribute_alist_closure*) char_attribute_alist_closure;
2832 = get_char_id_table (XCHAR_TABLE(value), caacl->char_id);
2833 if (!UNBOUNDP (ret))
2835 Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
2836 *char_attribute_alist
2837 = Fcons (Fcons (key, ret), *char_attribute_alist);
2842 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
2843 Return the alist of attributes of CHARACTER.
2847 struct gcpro gcpro1;
2848 struct char_attribute_alist_closure char_attribute_alist_closure;
2849 Lisp_Object alist = Qnil;
2851 CHECK_CHAR (character);
2854 char_attribute_alist_closure.char_id = XCHAR (character);
2855 char_attribute_alist_closure.char_attribute_alist = &alist;
2856 elisp_maphash (add_char_attribute_alist_mapper,
2857 Vchar_attribute_hash_table,
2858 &char_attribute_alist_closure);
2864 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /*
2865 Return the value of CHARACTER's ATTRIBUTE.
2866 Return DEFAULT-VALUE if the value is not exist.
2868 (character, attribute, default_value))
2872 CHECK_CHAR (character);
2874 if (CHARSETP (attribute))
2875 attribute = XCHARSET_NAME (attribute);
2877 table = Fgethash (attribute, Vchar_attribute_hash_table,
2879 if (!UNBOUNDP (table))
2881 Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table),
2883 if (!UNBOUNDP (ret))
2886 return default_value;
2889 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
2890 Store CHARACTER's ATTRIBUTE with VALUE.
2892 (character, attribute, value))
2894 Lisp_Object ccs = Ffind_charset (attribute);
2898 CHECK_CHAR (character);
2899 value = put_char_ccs_code_point (character, ccs, value);
2901 else if (EQ (attribute, Q_decomposition))
2905 CHECK_CHAR (character);
2907 signal_simple_error ("Invalid value for ->decomposition",
2910 if (CONSP (Fcdr (value)))
2912 Lisp_Object rest = value;
2913 Lisp_Object table = Vcharacter_composition_table;
2917 GET_EXTERNAL_LIST_LENGTH (rest, len);
2918 seq = make_vector (len, Qnil);
2920 while (CONSP (rest))
2922 Lisp_Object v = Fcar (rest);
2925 = to_char_id (v, "Invalid value for ->decomposition", value);
2928 XVECTOR_DATA(seq)[i++] = v;
2930 XVECTOR_DATA(seq)[i++] = make_char (c);
2934 put_char_id_table (XCHAR_TABLE(table),
2935 make_char (c), character);
2940 ntable = get_char_id_table (XCHAR_TABLE(table), c);
2941 if (!CHAR_TABLEP (ntable))
2943 ntable = make_char_id_table (Qnil);
2944 put_char_id_table (XCHAR_TABLE(table),
2945 make_char (c), ntable);
2953 Lisp_Object v = Fcar (value);
2957 Emchar c = XINT (v);
2959 = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2962 if (NILP (Fmemq (v, ret)))
2964 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2965 make_char (c), Fcons (character, ret));
2968 seq = make_vector (1, v);
2972 else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs))
2977 CHECK_CHAR (character);
2979 signal_simple_error ("Invalid value for ->ucs", value);
2983 ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c);
2984 if (NILP (Fmemq (character, ret)))
2986 put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table),
2987 make_char (c), Fcons (character, ret));
2990 if (EQ (attribute, Q_ucs))
2991 attribute = Qto_ucs;
2995 Lisp_Object table = Fgethash (attribute,
2996 Vchar_attribute_hash_table,
3001 table = make_char_id_table (Qunbound);
3002 Fputhash (attribute, table, Vchar_attribute_hash_table);
3004 put_char_id_table (XCHAR_TABLE(table), character, value);
3009 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
3010 Remove CHARACTER's ATTRIBUTE.
3012 (character, attribute))
3016 CHECK_CHAR (character);
3017 ccs = Ffind_charset (attribute);
3020 return remove_char_ccs (character, ccs);
3024 Lisp_Object table = Fgethash (attribute,
3025 Vchar_attribute_hash_table,
3027 if (!UNBOUNDP (table))
3029 put_char_id_table (XCHAR_TABLE(table), character, Qunbound);
3036 DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /*
3037 Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
3038 each key and value in the table.
3040 RANGE specifies a subrange to map over and is in the same format as
3041 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
3044 (function, attribute, range))
3047 Lisp_Char_Table *ct;
3048 struct slow_map_char_table_arg slarg;
3049 struct gcpro gcpro1, gcpro2;
3050 struct chartab_range rainj;
3052 if (!NILP (ccs = Ffind_charset (attribute)))
3054 Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
3056 if (CHAR_TABLEP (encoding_table))
3057 ct = XCHAR_TABLE (encoding_table);
3063 Lisp_Object table = Fgethash (attribute,
3064 Vchar_attribute_hash_table,
3066 if (CHAR_TABLEP (table))
3067 ct = XCHAR_TABLE (table);
3073 decode_char_table_range (range, &rainj);
3074 slarg.function = function;
3075 slarg.retval = Qnil;
3076 GCPRO2 (slarg.function, slarg.retval);
3077 map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg);
3080 return slarg.retval;
3083 DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
3084 Store character's ATTRIBUTES.
3088 Lisp_Object rest = attributes;
3089 Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
3090 Lisp_Object character;
3094 while (CONSP (rest))
3096 Lisp_Object cell = Fcar (rest);
3100 signal_simple_error ("Invalid argument", attributes);
3101 if (!NILP (ccs = Ffind_charset (Fcar (cell)))
3102 && ((XCHARSET_FINAL (ccs) != 0) ||
3103 (XCHARSET_MAX_CODE (ccs) > 0) ||
3104 (EQ (ccs, Vcharset_chinese_big5))) )
3108 character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3110 character = Fdecode_char (ccs, cell, Qnil);
3111 if (!NILP (character))
3112 goto setup_attributes;
3116 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3117 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3121 signal_simple_error ("Invalid argument", attributes);
3123 character = make_char (XINT (code) + 0x100000);
3124 goto setup_attributes;
3128 else if (!INTP (code))
3129 signal_simple_error ("Invalid argument", attributes);
3131 character = make_char (XINT (code));
3135 while (CONSP (rest))
3137 Lisp_Object cell = Fcar (rest);
3140 signal_simple_error ("Invalid argument", attributes);
3142 Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
3148 DEFUN ("find-char", Ffind_char, 1, 1, 0, /*
3149 Retrieve the character of the given ATTRIBUTES.
3153 Lisp_Object rest = attributes;
3156 while (CONSP (rest))
3158 Lisp_Object cell = Fcar (rest);
3162 signal_simple_error ("Invalid argument", attributes);
3163 if (!NILP (ccs = Ffind_charset (Fcar (cell))))
3167 return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
3169 return Fdecode_char (ccs, cell, Qnil);
3173 if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ||
3174 (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) )
3177 signal_simple_error ("Invalid argument", attributes);
3179 return make_char (XINT (code) + 0x100000);
3187 /************************************************************************/
3188 /* Char table read syntax */
3189 /************************************************************************/
3192 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
3193 Error_behavior errb)
3195 /* #### should deal with ERRB */
3196 symbol_to_char_table_type (value);
3201 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
3202 Error_behavior errb)
3206 /* #### should deal with ERRB */
3207 EXTERNAL_LIST_LOOP (rest, value)
3209 Lisp_Object range = XCAR (rest);
3210 struct chartab_range dummy;
3214 signal_simple_error ("Invalid list format", value);
3217 if (!CONSP (XCDR (range))
3218 || !NILP (XCDR (XCDR (range))))
3219 signal_simple_error ("Invalid range format", range);
3220 decode_char_table_range (XCAR (range), &dummy);
3221 decode_char_table_range (XCAR (XCDR (range)), &dummy);
3224 decode_char_table_range (range, &dummy);
3231 chartab_instantiate (Lisp_Object data)
3233 Lisp_Object chartab;
3234 Lisp_Object type = Qgeneric;
3235 Lisp_Object dataval = Qnil;
3237 while (!NILP (data))
3239 Lisp_Object keyw = Fcar (data);
3245 if (EQ (keyw, Qtype))
3247 else if (EQ (keyw, Qdata))
3251 chartab = Fmake_char_table (type);
3254 while (!NILP (data))
3256 Lisp_Object range = Fcar (data);
3257 Lisp_Object val = Fcar (Fcdr (data));
3259 data = Fcdr (Fcdr (data));
3262 if (CHAR_OR_CHAR_INTP (XCAR (range)))
3264 Emchar first = XCHAR_OR_CHAR_INT (Fcar (range));
3265 Emchar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
3268 for (i = first; i <= last; i++)
3269 Fput_char_table (make_char (i), val, chartab);
3275 Fput_char_table (range, val, chartab);
3284 /************************************************************************/
3285 /* Category Tables, specifically */
3286 /************************************************************************/
3288 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
3289 Return t if OBJECT is a category table.
3290 A category table is a type of char table used for keeping track of
3291 categories. Categories are used for classifying characters for use
3292 in regexps -- you can refer to a category rather than having to use
3293 a complicated [] expression (and category lookups are significantly
3296 There are 95 different categories available, one for each printable
3297 character (including space) in the ASCII charset. Each category
3298 is designated by one such character, called a "category designator".
3299 They are specified in a regexp using the syntax "\\cX", where X is
3300 a category designator.
3302 A category table specifies, for each character, the categories that
3303 the character is in. Note that a character can be in more than one
3304 category. More specifically, a category table maps from a character
3305 to either the value nil (meaning the character is in no categories)
3306 or a 95-element bit vector, specifying for each of the 95 categories
3307 whether the character is in that category.
3309 Special Lisp functions are provided that abstract this, so you do not
3310 have to directly manipulate bit vectors.
3314 return (CHAR_TABLEP (object) &&
3315 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
3320 check_category_table (Lisp_Object object, Lisp_Object default_)
3324 while (NILP (Fcategory_table_p (object)))
3325 object = wrong_type_argument (Qcategory_table_p, object);
3330 check_category_char (Emchar ch, Lisp_Object table,
3331 unsigned int designator, unsigned int not_p)
3333 REGISTER Lisp_Object temp;
3334 Lisp_Char_Table *ctbl;
3335 #ifdef ERROR_CHECK_TYPECHECK
3336 if (NILP (Fcategory_table_p (table)))
3337 signal_simple_error ("Expected category table", table);
3339 ctbl = XCHAR_TABLE (table);
3340 temp = get_char_table (ch, ctbl);
3345 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
3348 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
3349 Return t if category of the character at POSITION includes DESIGNATOR.
3350 Optional third arg BUFFER specifies which buffer to use, and defaults
3351 to the current buffer.
3352 Optional fourth arg CATEGORY-TABLE specifies the category table to
3353 use, and defaults to BUFFER's category table.
3355 (position, designator, buffer, category_table))
3360 struct buffer *buf = decode_buffer (buffer, 0);
3362 CHECK_INT (position);
3363 CHECK_CATEGORY_DESIGNATOR (designator);
3364 des = XCHAR (designator);
3365 ctbl = check_category_table (category_table, Vstandard_category_table);
3366 ch = BUF_FETCH_CHAR (buf, XINT (position));
3367 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3370 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
3371 Return t if category of CHARACTER includes DESIGNATOR, else nil.
3372 Optional third arg CATEGORY-TABLE specifies the category table to use,
3373 and defaults to the standard category table.
3375 (character, designator, category_table))
3381 CHECK_CATEGORY_DESIGNATOR (designator);
3382 des = XCHAR (designator);
3383 CHECK_CHAR (character);
3384 ch = XCHAR (character);
3385 ctbl = check_category_table (category_table, Vstandard_category_table);
3386 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
3389 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
3390 Return BUFFER's current category table.
3391 BUFFER defaults to the current buffer.
3395 return decode_buffer (buffer, 0)->category_table;
3398 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
3399 Return the standard category table.
3400 This is the one used for new buffers.
3404 return Vstandard_category_table;
3407 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
3408 Return a new category table which is a copy of CATEGORY-TABLE.
3409 CATEGORY-TABLE defaults to the standard category table.
3413 if (NILP (Vstandard_category_table))
3414 return Fmake_char_table (Qcategory);
3417 check_category_table (category_table, Vstandard_category_table);
3418 return Fcopy_char_table (category_table);
3421 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
3422 Select CATEGORY-TABLE as the new category table for BUFFER.
3423 BUFFER defaults to the current buffer if omitted.
3425 (category_table, buffer))
3427 struct buffer *buf = decode_buffer (buffer, 0);
3428 category_table = check_category_table (category_table, Qnil);
3429 buf->category_table = category_table;
3430 /* Indicate that this buffer now has a specified category table. */
3431 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
3432 return category_table;
3435 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
3436 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
3440 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
3443 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
3444 Return t if OBJECT is a category table value.
3445 Valid values are nil or a bit vector of size 95.
3449 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
3453 #define CATEGORYP(x) \
3454 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
3456 #define CATEGORY_SET(c) \
3457 (get_char_table(c, XCHAR_TABLE(current_buffer->category_table)))
3459 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
3460 The faster version of `!NILP (Faref (category_set, category))'. */
3461 #define CATEGORY_MEMBER(category, category_set) \
3462 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
3464 /* Return 1 if there is a word boundary between two word-constituent
3465 characters C1 and C2 if they appear in this order, else return 0.
3466 Use the macro WORD_BOUNDARY_P instead of calling this function
3469 int word_boundary_p (Emchar c1, Emchar c2);
3471 word_boundary_p (Emchar c1, Emchar c2)
3473 Lisp_Object category_set1, category_set2;
3478 if (COMPOSITE_CHAR_P (c1))
3479 c1 = cmpchar_component (c1, 0, 1);
3480 if (COMPOSITE_CHAR_P (c2))
3481 c2 = cmpchar_component (c2, 0, 1);
3484 if (EQ (CHAR_CHARSET (c1), CHAR_CHARSET (c2)))
3486 tail = Vword_separating_categories;
3491 tail = Vword_combining_categories;
3495 category_set1 = CATEGORY_SET (c1);
3496 if (NILP (category_set1))
3497 return default_result;
3498 category_set2 = CATEGORY_SET (c2);
3499 if (NILP (category_set2))
3500 return default_result;
3502 for (; CONSP (tail); tail = XCONS (tail)->cdr)
3504 Lisp_Object elt = XCONS(tail)->car;
3507 && CATEGORYP (XCONS (elt)->car)
3508 && CATEGORYP (XCONS (elt)->cdr)
3509 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->car), category_set1)
3510 && CATEGORY_MEMBER (XCHAR (XCONS (elt)->cdr), category_set2))
3511 return !default_result;
3513 return default_result;
3519 syms_of_chartab (void)
3522 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table);
3523 INIT_LRECORD_IMPLEMENTATION (uint16_byte_table);
3524 INIT_LRECORD_IMPLEMENTATION (byte_table);
3526 defsymbol (&Qto_ucs, "=>ucs");
3527 defsymbol (&Q_ucs, "->ucs");
3528 defsymbol (&Q_decomposition, "->decomposition");
3529 defsymbol (&Qcompat, "compat");
3530 defsymbol (&Qisolated, "isolated");
3531 defsymbol (&Qinitial, "initial");
3532 defsymbol (&Qmedial, "medial");
3533 defsymbol (&Qfinal, "final");
3534 defsymbol (&Qvertical, "vertical");
3535 defsymbol (&QnoBreak, "noBreak");
3536 defsymbol (&Qfraction, "fraction");
3537 defsymbol (&Qsuper, "super");
3538 defsymbol (&Qsub, "sub");
3539 defsymbol (&Qcircle, "circle");
3540 defsymbol (&Qsquare, "square");
3541 defsymbol (&Qwide, "wide");
3542 defsymbol (&Qnarrow, "narrow");
3543 defsymbol (&Qsmall, "small");
3544 defsymbol (&Qfont, "font");
3546 DEFSUBR (Fchar_attribute_list);
3547 DEFSUBR (Ffind_char_attribute_table);
3548 DEFSUBR (Fchar_attribute_alist);
3549 DEFSUBR (Fget_char_attribute);
3550 DEFSUBR (Fput_char_attribute);
3551 DEFSUBR (Fremove_char_attribute);
3552 DEFSUBR (Fmap_char_attribute);
3553 DEFSUBR (Fdefine_char);
3554 DEFSUBR (Ffind_char);
3555 DEFSUBR (Fchar_variants);
3557 DEFSUBR (Fget_composite_char);
3560 INIT_LRECORD_IMPLEMENTATION (char_table);
3564 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
3567 defsymbol (&Qcategory_table_p, "category-table-p");
3568 defsymbol (&Qcategory_designator_p, "category-designator-p");
3569 defsymbol (&Qcategory_table_value_p, "category-table-value-p");
3572 defsymbol (&Qchar_table, "char-table");
3573 defsymbol (&Qchar_tablep, "char-table-p");
3575 DEFSUBR (Fchar_table_p);
3576 DEFSUBR (Fchar_table_type_list);
3577 DEFSUBR (Fvalid_char_table_type_p);
3578 DEFSUBR (Fchar_table_type);
3579 DEFSUBR (Freset_char_table);
3580 DEFSUBR (Fmake_char_table);
3581 DEFSUBR (Fcopy_char_table);
3582 DEFSUBR (Fget_char_table);
3583 DEFSUBR (Fget_range_char_table);
3584 DEFSUBR (Fvalid_char_table_value_p);
3585 DEFSUBR (Fcheck_valid_char_table_value);
3586 DEFSUBR (Fput_char_table);
3587 DEFSUBR (Fmap_char_table);
3590 DEFSUBR (Fcategory_table_p);
3591 DEFSUBR (Fcategory_table);
3592 DEFSUBR (Fstandard_category_table);
3593 DEFSUBR (Fcopy_category_table);
3594 DEFSUBR (Fset_category_table);
3595 DEFSUBR (Fcheck_category_at);
3596 DEFSUBR (Fchar_in_category_p);
3597 DEFSUBR (Fcategory_designator_p);
3598 DEFSUBR (Fcategory_table_value_p);
3604 vars_of_chartab (void)
3607 Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)");
3608 DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
3609 Version number of XEmacs UTF-2000.
3612 staticpro (&Vcharacter_composition_table);
3613 Vcharacter_composition_table = make_char_id_table (Qnil);
3615 staticpro (&Vcharacter_variant_table);
3616 Vcharacter_variant_table = make_char_id_table (Qnil);
3618 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
3619 Vall_syntax_tables = Qnil;
3620 dump_add_weak_object_chain (&Vall_syntax_tables);
3624 structure_type_create_chartab (void)
3626 struct structure_type *st;
3628 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
3630 define_structure_type_keyword (st, Qtype, chartab_type_validate);
3631 define_structure_type_keyword (st, Qdata, chartab_data_validate);
3635 complex_vars_of_chartab (void)
3638 staticpro (&Vchar_attribute_hash_table);
3639 Vchar_attribute_hash_table
3640 = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
3641 #endif /* UTF2000 */
3643 /* Set this now, so first buffer creation can refer to it. */
3644 /* Make it nil before calling copy-category-table
3645 so that copy-category-table will know not to try to copy from garbage */
3646 Vstandard_category_table = Qnil;
3647 Vstandard_category_table = Fcopy_category_table (Qnil);
3648 staticpro (&Vstandard_category_table);
3650 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
3651 List of pair (cons) of categories to determine word boundary.
3653 Emacs treats a sequence of word constituent characters as a single
3654 word (i.e. finds no word boundary between them) iff they belongs to
3655 the same charset. But, exceptions are allowed in the following cases.
3657 \(1) The case that characters are in different charsets is controlled
3658 by the variable `word-combining-categories'.
3660 Emacs finds no word boundary between characters of different charsets
3661 if they have categories matching some element of this list.
3663 More precisely, if an element of this list is a cons of category CAT1
3664 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3665 C2 which has CAT2, there's no word boundary between C1 and C2.
3667 For instance, to tell that ASCII characters and Latin-1 characters can
3668 form a single word, the element `(?l . ?l)' should be in this list
3669 because both characters have the category `l' (Latin characters).
3671 \(2) The case that character are in the same charset is controlled by
3672 the variable `word-separating-categories'.
3674 Emacs find a word boundary between characters of the same charset
3675 if they have categories matching some element of this list.
3677 More precisely, if an element of this list is a cons of category CAT1
3678 and CAT2, and a multibyte character C1 which has CAT1 is followed by
3679 C2 which has CAT2, there's a word boundary between C1 and C2.
3681 For instance, to tell that there's a word boundary between Japanese
3682 Hiragana and Japanese Kanji (both are in the same charset), the
3683 element `(?H . ?C) should be in this list.
3686 Vword_combining_categories = Qnil;
3688 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
3689 List of pair (cons) of categories to determine word boundary.
3690 See the documentation of the variable `word-combining-categories'.
3693 Vword_separating_categories = Qnil;