From: tomo Date: Thu, 16 Aug 2001 17:45:17 +0000 (+0000) Subject: Move char-id-table related code from mule-charset.c. X-Git-Tag: r21-2-41-utf-2000-0_17-2~126 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=1d0ce2d1bcd9825a1ba000164671f1a8612fa7e8;p=chise%2Fxemacs-chise.git- Move char-id-table related code from mule-charset.c. (Vutf_2000_version): Moved from mule-charset.c. --- diff --git a/src/chartab.c b/src/chartab.c index d87ca6c..93ce1de 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -42,20 +42,1425 @@ Boston, MA 02111-1307, USA. */ #include "chartab.h" #include "syntax.h" +#ifdef UTF2000 +#include "elhash.h" + +Lisp_Object Vutf_2000_version; +#endif /* UTF2000 */ + Lisp_Object Qchar_tablep, Qchar_table; -Lisp_Object Vall_syntax_tables; +Lisp_Object Vall_syntax_tables; + +#ifdef MULE +Lisp_Object Qcategory_table_p; +Lisp_Object Qcategory_designator_p; +Lisp_Object Qcategory_table_value_p; + +Lisp_Object Vstandard_category_table; + +/* Variables to determine word boundary. */ +Lisp_Object Vword_combining_categories, Vword_separating_categories; +#endif /* MULE */ + + +#ifdef UTF2000 + +#define BT_UINT8_MIN 0 +#define BT_UINT8_MAX (UCHAR_MAX - 3) +#define BT_UINT8_t (UCHAR_MAX - 2) +#define BT_UINT8_nil (UCHAR_MAX - 1) +#define BT_UINT8_unbound UCHAR_MAX + +INLINE_HEADER int INT_UINT8_P (Lisp_Object obj); +INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj); +INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj); +INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n); +INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n); + +INLINE_HEADER int +INT_UINT8_P (Lisp_Object obj) +{ + if (INTP (obj)) + { + int num = XINT (obj); + + return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX); + } + else + return 0; +} + +INLINE_HEADER int +UINT8_VALUE_P (Lisp_Object obj) +{ + return EQ (obj, Qunbound) + || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj); +} + +INLINE_HEADER unsigned char +UINT8_ENCODE (Lisp_Object obj) +{ + if (EQ (obj, Qunbound)) + return BT_UINT8_unbound; + else if (EQ (obj, Qnil)) + return BT_UINT8_nil; + else if (EQ (obj, Qt)) + return BT_UINT8_t; + else + return XINT (obj); +} + +INLINE_HEADER Lisp_Object +UINT8_DECODE (unsigned char n) +{ + if (n == BT_UINT8_unbound) + return Qunbound; + else if (n == BT_UINT8_nil) + return Qnil; + else if (n == BT_UINT8_t) + return Qt; + else + return make_int (n); +} + +static Lisp_Object +mark_uint8_byte_table (Lisp_Object obj) +{ + return Qnil; +} + +static void +print_uint8_byte_table (Lisp_Object obj, + Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj); + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("\n#property[i]; + if ( (i & 15) == 0 ) + write_c_string ("\n ", printcharfun); + write_c_string (" ", printcharfun); + if (n == BT_UINT8_unbound) + write_c_string ("void", printcharfun); + else if (n == BT_UINT8_nil) + write_c_string ("nil", printcharfun); + else if (n == BT_UINT8_t) + write_c_string ("t", printcharfun); + else + { + char buf[4]; + + sprintf (buf, "%hd", n); + write_c_string (buf, printcharfun); + } + } + UNGCPRO; + write_c_string (">", printcharfun); +} + +static int +uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1); + Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2); + int i; + + for (i = 0; i < 256; i++) + if (te1->property[i] != te2->property[i]) + return 0; + return 1; +} + +static unsigned long +uint8_byte_table_hash (Lisp_Object obj, int depth) +{ + Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj); + int i; + hashcode_t hash = 0; + + for (i = 0; i < 256; i++) + hash = HASH2 (hash, te->property[i]); + return hash; +} + +DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table, + mark_uint8_byte_table, + print_uint8_byte_table, + 0, uint8_byte_table_equal, + uint8_byte_table_hash, + 0 /* uint8_byte_table_description */, + Lisp_Uint8_Byte_Table); + +static Lisp_Object +make_uint8_byte_table (unsigned char initval) +{ + Lisp_Object obj; + int i; + Lisp_Uint8_Byte_Table *cte; + + cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table, + &lrecord_uint8_byte_table); + + for (i = 0; i < 256; i++) + cte->property[i] = initval; + + XSETUINT8_BYTE_TABLE (obj, cte); + return obj; +} + +static int +uint8_byte_table_same_value_p (Lisp_Object obj) +{ + Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj); + unsigned char v0 = bte->property[0]; + int i; + + for (i = 1; i < 256; i++) + { + if (bte->property[i] != v0) + return 0; + } + return -1; +} + +static int +map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, + int (*fn) (Emchar c, Lisp_Object val, void *arg), + void *arg, Emchar ofs, int place) +{ + int i, retval; + int unit = 1 << (8 * place); + Emchar c = ofs; + Emchar c1; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + if (ct->property[i] != BT_UINT8_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + retval = (fn) (c, UINT8_DECODE (ct->property[i]), arg); + } + else + c += unit; + } + return retval; +} + +#define BT_UINT16_MIN 0 +#define BT_UINT16_MAX (USHRT_MAX - 3) +#define BT_UINT16_t (USHRT_MAX - 2) +#define BT_UINT16_nil (USHRT_MAX - 1) +#define BT_UINT16_unbound USHRT_MAX + +INLINE_HEADER int INT_UINT16_P (Lisp_Object obj); +INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj); +INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj); +INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us); + +INLINE_HEADER int +INT_UINT16_P (Lisp_Object obj) +{ + if (INTP (obj)) + { + int num = XINT (obj); + + return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX); + } + else + return 0; +} + +INLINE_HEADER int +UINT16_VALUE_P (Lisp_Object obj) +{ + return EQ (obj, Qunbound) + || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj); +} + +INLINE_HEADER unsigned short +UINT16_ENCODE (Lisp_Object obj) +{ + if (EQ (obj, Qunbound)) + return BT_UINT16_unbound; + else if (EQ (obj, Qnil)) + return BT_UINT16_nil; + else if (EQ (obj, Qt)) + return BT_UINT16_t; + else + return XINT (obj); +} + +INLINE_HEADER Lisp_Object +UINT16_DECODE (unsigned short n) +{ + if (n == BT_UINT16_unbound) + return Qunbound; + else if (n == BT_UINT16_nil) + return Qnil; + else if (n == BT_UINT16_t) + return Qt; + else + return make_int (n); +} + +INLINE_HEADER unsigned short +UINT8_TO_UINT16 (unsigned char n) +{ + if (n == BT_UINT8_unbound) + return BT_UINT16_unbound; + else if (n == BT_UINT8_nil) + return BT_UINT16_nil; + else if (n == BT_UINT8_t) + return BT_UINT16_t; + else + return n; +} + +static Lisp_Object +mark_uint16_byte_table (Lisp_Object obj) +{ + return Qnil; +} + +static void +print_uint16_byte_table (Lisp_Object obj, + Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj); + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("\n#property[i]; + if ( (i & 15) == 0 ) + write_c_string ("\n ", printcharfun); + write_c_string (" ", printcharfun); + if (n == BT_UINT16_unbound) + write_c_string ("void", printcharfun); + else if (n == BT_UINT16_nil) + write_c_string ("nil", printcharfun); + else if (n == BT_UINT16_t) + write_c_string ("t", printcharfun); + else + { + char buf[7]; + + sprintf (buf, "%hd", n); + write_c_string (buf, printcharfun); + } + } + UNGCPRO; + write_c_string (">", printcharfun); +} + +static int +uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1); + Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2); + int i; + + for (i = 0; i < 256; i++) + if (te1->property[i] != te2->property[i]) + return 0; + return 1; +} + +static unsigned long +uint16_byte_table_hash (Lisp_Object obj, int depth) +{ + Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj); + int i; + hashcode_t hash = 0; + + for (i = 0; i < 256; i++) + hash = HASH2 (hash, te->property[i]); + return hash; +} + +DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table, + mark_uint16_byte_table, + print_uint16_byte_table, + 0, uint16_byte_table_equal, + uint16_byte_table_hash, + 0 /* uint16_byte_table_description */, + Lisp_Uint16_Byte_Table); + +static Lisp_Object +make_uint16_byte_table (unsigned short initval) +{ + Lisp_Object obj; + int i; + Lisp_Uint16_Byte_Table *cte; + + cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table, + &lrecord_uint16_byte_table); + + for (i = 0; i < 256; i++) + cte->property[i] = initval; + + XSETUINT16_BYTE_TABLE (obj, cte); + return obj; +} + +static Lisp_Object +expand_uint8_byte_table_to_uint16 (Lisp_Object table) +{ + Lisp_Object obj; + int i; + Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table); + Lisp_Uint16_Byte_Table* cte; + + cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table, + &lrecord_uint16_byte_table); + for (i = 0; i < 256; i++) + { + cte->property[i] = UINT8_TO_UINT16 (bte->property[i]); + } + XSETUINT16_BYTE_TABLE (obj, cte); + return obj; +} + +static int +uint16_byte_table_same_value_p (Lisp_Object obj) +{ + Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj); + unsigned short v0 = bte->property[0]; + int i; + + for (i = 1; i < 256; i++) + { + if (bte->property[i] != v0) + return 0; + } + return -1; +} + +static int +map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, + int (*fn) (Emchar c, Lisp_Object val, void *arg), + void *arg, Emchar ofs, int place) +{ + int i, retval; + int unit = 1 << (8 * place); + Emchar c = ofs; + Emchar c1; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + if (ct->property[i] != BT_UINT16_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + retval = (fn) (c, UINT16_DECODE (ct->property[i]), arg); + } + else + c += unit; + } + return retval; +} + + +static Lisp_Object +mark_byte_table (Lisp_Object obj) +{ + Lisp_Byte_Table *cte = XBYTE_TABLE (obj); + int i; + + for (i = 0; i < 256; i++) + { + mark_object (cte->property[i]); + } + return Qnil; +} + +static void +print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Byte_Table *bte = XBYTE_TABLE (obj); + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("\n#property[i]; + if ( (i & 15) == 0 ) + write_c_string ("\n ", printcharfun); + write_c_string (" ", printcharfun); + if (EQ (elt, Qunbound)) + write_c_string ("void", printcharfun); + else + print_internal (elt, printcharfun, escapeflag); + } + UNGCPRO; + write_c_string (">", printcharfun); +} + +static int +byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1); + Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2); + int i; + + for (i = 0; i < 256; i++) + if (BYTE_TABLE_P (cte1->property[i])) + { + if (BYTE_TABLE_P (cte2->property[i])) + { + if (!byte_table_equal (cte1->property[i], + cte2->property[i], depth + 1)) + return 0; + } + else + return 0; + } + else + if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1)) + return 0; + return 1; +} + +static unsigned long +byte_table_hash (Lisp_Object obj, int depth) +{ + Lisp_Byte_Table *cte = XBYTE_TABLE (obj); + + return internal_array_hash (cte->property, 256, depth); +} + +static const struct lrecord_description byte_table_description[] = { + { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 }, + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table, + mark_byte_table, + print_byte_table, + 0, byte_table_equal, + byte_table_hash, + byte_table_description, + Lisp_Byte_Table); + +static Lisp_Object +make_byte_table (Lisp_Object initval) +{ + Lisp_Object obj; + int i; + Lisp_Byte_Table *cte; + + cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table); + + for (i = 0; i < 256; i++) + cte->property[i] = initval; + + XSETBYTE_TABLE (obj, cte); + return obj; +} + +static int +byte_table_same_value_p (Lisp_Object obj) +{ + Lisp_Byte_Table *bte = XBYTE_TABLE (obj); + Lisp_Object v0 = bte->property[0]; + int i; + + for (i = 1; i < 256; i++) + { + if (!internal_equal (bte->property[i], v0, 0)) + return 0; + } + return -1; +} + +static int +map_over_byte_table (Lisp_Byte_Table *ct, + int (*fn) (Emchar c, Lisp_Object val, void *arg), + void *arg, Emchar ofs, int place) +{ + int i, retval; + Lisp_Object v; + int unit = 1 << (8 * place); + Emchar c = ofs; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + v = ct->property[i]; + if (UINT8_BYTE_TABLE_P (v)) + { + retval + = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), + fn, arg, c, place - 1); + c += unit; + } + else if (UINT16_BYTE_TABLE_P (v)) + { + retval + = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), + fn, arg, c, place - 1); + c += unit; + } + else if (BYTE_TABLE_P (v)) + { + retval = map_over_byte_table (XBYTE_TABLE(v), + fn, arg, c, place - 1); + c += unit; + } + else if (!UNBOUNDP (v)) + { + Emchar c1 = c + unit; + + for (; c < c1 && retval == 0; c++) + retval = (fn) (c, v, arg); + } + else + c += unit; + } + return retval; +} + + +Lisp_Object get_byte_table (Lisp_Object table, unsigned char idx); +Lisp_Object put_byte_table (Lisp_Object table, unsigned char idx, + Lisp_Object value); + +Lisp_Object +get_byte_table (Lisp_Object table, unsigned char idx) +{ + if (UINT8_BYTE_TABLE_P (table)) + return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]); + else if (UINT16_BYTE_TABLE_P (table)) + return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]); + else if (BYTE_TABLE_P (table)) + return XBYTE_TABLE(table)->property[idx]; + else + return table; +} + +Lisp_Object +put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value) +{ + if (UINT8_BYTE_TABLE_P (table)) + { + if (UINT8_VALUE_P (value)) + { + XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value); + if (!UINT8_BYTE_TABLE_P (value) && + !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value) + && uint8_byte_table_same_value_p (table)) + { + return value; + } + } + else if (UINT16_VALUE_P (value)) + { + Lisp_Object new = expand_uint8_byte_table_to_uint16 (table); + + XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value); + return new; + } + else + { + Lisp_Object new = make_byte_table (Qnil); + int i; + + for (i = 0; i < 256; i++) + { + XBYTE_TABLE(new)->property[i] + = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]); + } + XBYTE_TABLE(new)->property[idx] = value; + return new; + } + } + else if (UINT16_BYTE_TABLE_P (table)) + { + if (UINT16_VALUE_P (value)) + { + XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value); + if (!UINT8_BYTE_TABLE_P (value) && + !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value) + && uint16_byte_table_same_value_p (table)) + { + return value; + } + } + else + { + Lisp_Object new = make_byte_table (Qnil); + int i; + + for (i = 0; i < 256; i++) + { + XBYTE_TABLE(new)->property[i] + = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]); + } + XBYTE_TABLE(new)->property[idx] = value; + return new; + } + } + else if (BYTE_TABLE_P (table)) + { + XBYTE_TABLE(table)->property[idx] = value; + if (!UINT8_BYTE_TABLE_P (value) && + !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value) + && byte_table_same_value_p (table)) + { + return value; + } + } + else if (!internal_equal (table, value, 0)) + { + if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value)) + { + table = make_uint8_byte_table (UINT8_ENCODE (table)); + XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value); + } + else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value)) + { + table = make_uint16_byte_table (UINT16_ENCODE (table)); + XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value); + } + else + { + table = make_byte_table (table); + XBYTE_TABLE(table)->property[idx] = value; + } + } + return table; +} + +static Lisp_Object +mark_char_id_table (Lisp_Object obj) +{ + Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj); + + return cte->table; +} + +static void +print_char_id_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Object table = XCHAR_ID_TABLE (obj)->table; + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("#", printcharfun); +} + +static int +char_id_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Object table1 = XCHAR_ID_TABLE (obj1)->table; + Lisp_Object table2 = XCHAR_ID_TABLE (obj2)->table; + int i; + + for (i = 0; i < 256; i++) + { + if (!internal_equal (get_byte_table (table1, i), + get_byte_table (table2, i), 0)) + return 0; + } + return -1; +} + +static unsigned long +char_id_table_hash (Lisp_Object obj, int depth) +{ + Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj); + + return char_id_table_hash (cte->table, depth + 1); +} -#ifdef MULE -Lisp_Object Qcategory_table_p; -Lisp_Object Qcategory_designator_p; -Lisp_Object Qcategory_table_value_p; +static const struct lrecord_description char_id_table_description[] = { + { XD_LISP_OBJECT, offsetof(Lisp_Char_ID_Table, table) }, + { XD_END } +}; -Lisp_Object Vstandard_category_table; +DEFINE_LRECORD_IMPLEMENTATION ("char-id-table", char_id_table, + mark_char_id_table, + print_char_id_table, + 0, char_id_table_equal, + char_id_table_hash, + char_id_table_description, + Lisp_Char_ID_Table); -/* Variables to determine word boundary. */ -Lisp_Object Vword_combining_categories, Vword_separating_categories; -#endif /* MULE */ +Lisp_Object +make_char_id_table (Lisp_Object initval) +{ + Lisp_Object obj; + Lisp_Char_ID_Table *cte; + + cte = alloc_lcrecord_type (Lisp_Char_ID_Table, &lrecord_char_id_table); + + cte->table = make_byte_table (initval); + + XSETCHAR_ID_TABLE (obj, cte); + return obj; +} + + +Lisp_Object +get_char_id_table (Emchar ch, Lisp_Object table) +{ + unsigned int code = ch; + + return + get_byte_table + (get_byte_table + (get_byte_table + (get_byte_table + (XCHAR_ID_TABLE (table)->table, + (unsigned char)(code >> 24)), + (unsigned char) (code >> 16)), + (unsigned char) (code >> 8)), + (unsigned char) code); +} + +void +put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table) +{ + unsigned int code = ch; + Lisp_Object table1, table2, table3, table4; + + table1 = XCHAR_ID_TABLE (table)->table; + table2 = get_byte_table (table1, (unsigned char)(code >> 24)); + table3 = get_byte_table (table2, (unsigned char)(code >> 16)); + table4 = get_byte_table (table3, (unsigned char)(code >> 8)); + + table4 = put_byte_table (table4, (unsigned char)code, value); + table3 = put_byte_table (table3, (unsigned char)(code >> 8), table4); + table2 = put_byte_table (table2, (unsigned char)(code >> 16), table3); + XCHAR_ID_TABLE (table)->table + = put_byte_table (table1, (unsigned char)(code >> 24), table2); +} + +/* Map FN (with client data ARG) in char table CT. + Mapping stops the first time FN returns non-zero, and that value + becomes the return value of map_char_id_table(). */ +int +map_char_id_table (Lisp_Char_ID_Table *ct, + int (*fn) (Emchar c, Lisp_Object val, void *arg), + void *arg); +int +map_char_id_table (Lisp_Char_ID_Table *ct, + int (*fn) (Emchar c, Lisp_Object val, void *arg), + void *arg) +{ + Lisp_Object v = ct->table; + + if (UINT8_BYTE_TABLE_P (v)) + return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), fn, arg, 0, 3); + else if (UINT16_BYTE_TABLE_P (v)) + return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), fn, arg, 0, 3); + else if (BYTE_TABLE_P (v)) + return map_over_byte_table (XBYTE_TABLE(v), fn, arg, 0, 3); + else if (!UNBOUNDP (v)) + { + int unit = 1 << 24; + Emchar c = 0; + Emchar c1 = c + unit; + int retval; + + for (retval = 0; c < c1 && retval == 0; c++) + retval = (fn) (c, v, arg); + } + return 0; +} + +struct slow_map_char_id_table_arg +{ + Lisp_Object function; + Lisp_Object retval; +}; + +static int +slow_map_char_id_table_fun (Emchar c, Lisp_Object val, void *arg) +{ + struct slow_map_char_id_table_arg *closure = + (struct slow_map_char_id_table_arg *) arg; + + closure->retval = call2 (closure->function, make_char (c), val); + return !NILP (closure->retval); +} + + +Lisp_Object Vchar_attribute_hash_table; +Lisp_Object Vcharacter_composition_table; +Lisp_Object Vcharacter_variant_table; + + +Lisp_Object Q_decomposition; +Lisp_Object Qto_ucs; +Lisp_Object Q_ucs; +Lisp_Object Qcompat; +Lisp_Object Qisolated; +Lisp_Object Qinitial; +Lisp_Object Qmedial; +Lisp_Object Qfinal; +Lisp_Object Qvertical; +Lisp_Object QnoBreak; +Lisp_Object Qfraction; +Lisp_Object Qsuper; +Lisp_Object Qsub; +Lisp_Object Qcircle; +Lisp_Object Qsquare; +Lisp_Object Qwide; +Lisp_Object Qnarrow; +Lisp_Object Qsmall; +Lisp_Object Qfont; + +Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg); + +Emchar +to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg) +{ + if (INTP (v)) + return XINT (v); + if (CHARP (v)) + return XCHAR (v); + else if (EQ (v, Qcompat)) + return -1; + else if (EQ (v, Qisolated)) + return -2; + else if (EQ (v, Qinitial)) + return -3; + else if (EQ (v, Qmedial)) + return -4; + else if (EQ (v, Qfinal)) + return -5; + else if (EQ (v, Qvertical)) + return -6; + else if (EQ (v, QnoBreak)) + return -7; + else if (EQ (v, Qfraction)) + return -8; + else if (EQ (v, Qsuper)) + return -9; + else if (EQ (v, Qsub)) + return -10; + else if (EQ (v, Qcircle)) + return -11; + else if (EQ (v, Qsquare)) + return -12; + else if (EQ (v, Qwide)) + return -13; + else if (EQ (v, Qnarrow)) + return -14; + else if (EQ (v, Qsmall)) + return -15; + else if (EQ (v, Qfont)) + return -16; + else + signal_simple_error (err_msg, err_arg); +} + +DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /* +Return character corresponding with list. +*/ + (list)) +{ + Lisp_Object table = Vcharacter_composition_table; + Lisp_Object rest = list; + + while (CONSP (rest)) + { + Lisp_Object v = Fcar (rest); + Lisp_Object ret; + Emchar c = to_char_id (v, "Invalid value for composition", list); + + ret = get_char_id_table (c, table); + + rest = Fcdr (rest); + if (NILP (rest)) + { + if (!CHAR_ID_TABLE_P (ret)) + return ret; + else + return Qt; + } + else if (!CONSP (rest)) + break; + else if (CHAR_ID_TABLE_P (ret)) + table = ret; + else + signal_simple_error ("Invalid table is found with", list); + } + signal_simple_error ("Invalid value for composition", list); +} + +DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /* +Return variants of CHARACTER. +*/ + (character)) +{ + CHECK_CHAR (character); + return Fcopy_list (get_char_id_table (XCHAR (character), + Vcharacter_variant_table)); +} + + +/* We store the char-attributes in hash tables with the names as the + key and the actual char-id-table object as the value. Occasionally + we need to use them in a list format. These routines provide us + with that. */ +struct char_attribute_list_closure +{ + Lisp_Object *char_attribute_list; +}; + +static int +add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value, + void *char_attribute_list_closure) +{ + /* This function can GC */ + struct char_attribute_list_closure *calcl + = (struct char_attribute_list_closure*) char_attribute_list_closure; + Lisp_Object *char_attribute_list = calcl->char_attribute_list; + + *char_attribute_list = Fcons (key, *char_attribute_list); + return 0; +} + +DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /* +Return the list of all existing character attributes except coded-charsets. +*/ + ()) +{ + Lisp_Object char_attribute_list = Qnil; + struct gcpro gcpro1; + struct char_attribute_list_closure char_attribute_list_closure; + + GCPRO1 (char_attribute_list); + char_attribute_list_closure.char_attribute_list = &char_attribute_list; + elisp_maphash (add_char_attribute_to_list_mapper, + Vchar_attribute_hash_table, + &char_attribute_list_closure); + UNGCPRO; + return char_attribute_list; +} + +DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /* +Return char-id-table corresponding to ATTRIBUTE. +*/ + (attribute)) +{ + return Fgethash (attribute, Vchar_attribute_hash_table, Qnil); +} + + +/* We store the char-id-tables in hash tables with the attributes as + the key and the actual char-id-table object as the value. Each + char-id-table stores values of an attribute corresponding with + characters. Occasionally we need to get attributes of a character + in a association-list format. These routines provide us with + that. */ +struct char_attribute_alist_closure +{ + Emchar char_id; + Lisp_Object *char_attribute_alist; +}; + +static int +add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value, + void *char_attribute_alist_closure) +{ + /* This function can GC */ + struct char_attribute_alist_closure *caacl = + (struct char_attribute_alist_closure*) char_attribute_alist_closure; + Lisp_Object ret = get_char_id_table (caacl->char_id, value); + if (!UNBOUNDP (ret)) + { + Lisp_Object *char_attribute_alist = caacl->char_attribute_alist; + *char_attribute_alist + = Fcons (Fcons (key, ret), *char_attribute_alist); + } + return 0; +} + +DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /* +Return the alist of attributes of CHARACTER. +*/ + (character)) +{ + Lisp_Object alist = Qnil; + int i; + + CHECK_CHAR (character); + { + struct gcpro gcpro1; + struct char_attribute_alist_closure char_attribute_alist_closure; + + GCPRO1 (alist); + char_attribute_alist_closure.char_id = XCHAR (character); + char_attribute_alist_closure.char_attribute_alist = &alist; + elisp_maphash (add_char_attribute_alist_mapper, + Vchar_attribute_hash_table, + &char_attribute_alist_closure); + UNGCPRO; + } + + for (i = 0; i < countof (chlook->charset_by_leading_byte); i++) + { + Lisp_Object ccs = chlook->charset_by_leading_byte[i]; + + if (!NILP (ccs)) + { + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + Lisp_Object cpos; + + if ( CHAR_ID_TABLE_P (encoding_table) + && INTP (cpos = get_char_id_table (XCHAR (character), + encoding_table)) ) + { + alist = Fcons (Fcons (ccs, cpos), alist); + } + } + } + return alist; +} + +DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /* +Return the value of CHARACTER's ATTRIBUTE. +Return DEFAULT-VALUE if the value is not exist. +*/ + (character, attribute, default_value)) +{ + Lisp_Object ccs; + + CHECK_CHAR (character); + if (!NILP (ccs = Ffind_charset (attribute))) + { + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + + if (CHAR_ID_TABLE_P (encoding_table)) + return get_char_id_table (XCHAR (character), encoding_table); + } + else + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + if (!UNBOUNDP (table)) + { + Lisp_Object ret = get_char_id_table (XCHAR (character), table); + if (!UNBOUNDP (ret)) + return ret; + } + } + return default_value; +} + +DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /* +Store CHARACTER's ATTRIBUTE with VALUE. +*/ + (character, attribute, value)) +{ + Lisp_Object ccs; + + CHECK_CHAR (character); + ccs = Ffind_charset (attribute); + if (!NILP (ccs)) + { + return put_char_ccs_code_point (character, ccs, value); + } + else if (EQ (attribute, Q_decomposition)) + { + Lisp_Object seq; + + if (!CONSP (value)) + signal_simple_error ("Invalid value for ->decomposition", + value); + + if (CONSP (Fcdr (value))) + { + Lisp_Object rest = value; + Lisp_Object table = Vcharacter_composition_table; + size_t len; + int i = 0; + + GET_EXTERNAL_LIST_LENGTH (rest, len); + seq = make_vector (len, Qnil); + + while (CONSP (rest)) + { + Lisp_Object v = Fcar (rest); + Lisp_Object ntable; + Emchar c + = to_char_id (v, "Invalid value for ->decomposition", value); + + if (c < 0) + XVECTOR_DATA(seq)[i++] = v; + else + XVECTOR_DATA(seq)[i++] = make_char (c); + rest = Fcdr (rest); + if (!CONSP (rest)) + { + put_char_id_table (c, character, table); + break; + } + else + { + ntable = get_char_id_table (c, table); + if (!CHAR_ID_TABLE_P (ntable)) + { + ntable = make_char_id_table (Qnil); + put_char_id_table (c, ntable, table); + } + table = ntable; + } + } + } + else + { + Lisp_Object v = Fcar (value); + + if (INTP (v)) + { + Emchar c = XINT (v); + Lisp_Object ret + = get_char_id_table (c, Vcharacter_variant_table); + + if (NILP (Fmemq (v, ret))) + { + put_char_id_table (c, Fcons (character, ret), + Vcharacter_variant_table); + } + } + seq = make_vector (1, v); + } + value = seq; + } + else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs)) + { + Lisp_Object ret; + Emchar c; + + if (!INTP (value)) + signal_simple_error ("Invalid value for ->ucs", value); + + c = XINT (value); + + ret = get_char_id_table (c, Vcharacter_variant_table); + if (NILP (Fmemq (character, ret))) + { + put_char_id_table (c, Fcons (character, ret), + Vcharacter_variant_table); + } +#if 0 + if (EQ (attribute, Q_ucs)) + attribute = Qto_ucs; +#endif + } + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qnil); + + if (NILP (table)) + { + table = make_char_id_table (Qunbound); + Fputhash (attribute, table, Vchar_attribute_hash_table); + } + put_char_id_table (XCHAR (character), value, table); + return value; + } +} + +DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /* +Remove CHARACTER's ATTRIBUTE. +*/ + (character, attribute)) +{ + Lisp_Object ccs; + + CHECK_CHAR (character); + ccs = Ffind_charset (attribute); + if (!NILP (ccs)) + { + return remove_char_ccs (character, ccs); + } + else + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + if (!UNBOUNDP (table)) + { + put_char_id_table (XCHAR (character), Qunbound, table); + return Qt; + } + } + return Qnil; +} + +DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 2, 0, /* +Map FUNCTION over entries in ATTRIBUTE, calling it with two args, +each key and value in the table. +*/ + (function, attribute)) +{ + Lisp_Object ccs; + Lisp_Char_ID_Table *ct; + struct slow_map_char_id_table_arg slarg; + struct gcpro gcpro1, gcpro2; + + if (!NILP (ccs = Ffind_charset (attribute))) + { + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + + if (CHAR_ID_TABLE_P (encoding_table)) + ct = XCHAR_ID_TABLE (encoding_table); + else + return Qnil; + } + else + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + if (CHAR_ID_TABLE_P (table)) + ct = XCHAR_ID_TABLE (table); + else + return Qnil; + } + slarg.function = function; + slarg.retval = Qnil; + GCPRO2 (slarg.function, slarg.retval); + map_char_id_table (ct, slow_map_char_id_table_fun, &slarg); + UNGCPRO; + + return slarg.retval; +} + +EXFUN (Fmake_char, 3); +EXFUN (Fdecode_char, 2); + +DEFUN ("define-char", Fdefine_char, 1, 1, 0, /* +Store character's ATTRIBUTES. +*/ + (attributes)) +{ + Lisp_Object rest = attributes; + Lisp_Object code = Fcdr (Fassq (Qucs, attributes)); + Lisp_Object character; + + if (NILP (code)) + { + while (CONSP (rest)) + { + Lisp_Object cell = Fcar (rest); + Lisp_Object ccs; + + if (!LISTP (cell)) + signal_simple_error ("Invalid argument", attributes); + if (!NILP (ccs = Ffind_charset (Fcar (cell))) + && ((XCHARSET_FINAL (ccs) != 0) || + (XCHARSET_UCS_MAX (ccs) > 0)) ) + { + cell = Fcdr (cell); + if (CONSP (cell)) + character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); + else + character = Fdecode_char (ccs, cell); + if (!NILP (character)) + goto setup_attributes; + } + rest = Fcdr (rest); + } + if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) || + (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) ) + + { + if (!INTP (code)) + signal_simple_error ("Invalid argument", attributes); + else + character = make_char (XINT (code) + 0x100000); + goto setup_attributes; + } + return Qnil; + } + else if (!INTP (code)) + signal_simple_error ("Invalid argument", attributes); + else + character = make_char (XINT (code)); + + setup_attributes: + rest = attributes; + while (CONSP (rest)) + { + Lisp_Object cell = Fcar (rest); + + if (!LISTP (cell)) + signal_simple_error ("Invalid argument", attributes); + + Fput_char_attribute (character, Fcar (cell), Fcdr (cell)); + rest = Fcdr (rest); + } + return character; +} + +DEFUN ("find-char", Ffind_char, 1, 1, 0, /* +Retrieve the character of the given ATTRIBUTES. +*/ + (attributes)) +{ + Lisp_Object rest = attributes; + Lisp_Object code; + + while (CONSP (rest)) + { + Lisp_Object cell = Fcar (rest); + Lisp_Object ccs; + + if (!LISTP (cell)) + signal_simple_error ("Invalid argument", attributes); + if (!NILP (ccs = Ffind_charset (Fcar (cell)))) + { + cell = Fcdr (cell); + if (CONSP (cell)) + return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); + else + return Fdecode_char (ccs, cell); + } + rest = Fcdr (rest); + } + if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) || + (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) ) + { + if (!INTP (code)) + signal_simple_error ("Invalid argument", attributes); + else + return make_char (XINT (code) + 0x100000); + } + return Qnil; +} + +#endif /* A char table maps from ranges of characters to values. @@ -1812,6 +3217,46 @@ word_boundary_p (Emchar c1, Emchar c2) void syms_of_chartab (void) { +#ifdef UTF2000 + INIT_LRECORD_IMPLEMENTATION (uint8_byte_table); + INIT_LRECORD_IMPLEMENTATION (uint16_byte_table); + INIT_LRECORD_IMPLEMENTATION (byte_table); + INIT_LRECORD_IMPLEMENTATION (char_id_table); + + defsymbol (&Qto_ucs, "=>ucs"); + defsymbol (&Q_ucs, "->ucs"); + defsymbol (&Q_decomposition, "->decomposition"); + defsymbol (&Qcompat, "compat"); + defsymbol (&Qisolated, "isolated"); + defsymbol (&Qinitial, "initial"); + defsymbol (&Qmedial, "medial"); + defsymbol (&Qfinal, "final"); + defsymbol (&Qvertical, "vertical"); + defsymbol (&QnoBreak, "noBreak"); + defsymbol (&Qfraction, "fraction"); + defsymbol (&Qsuper, "super"); + defsymbol (&Qsub, "sub"); + defsymbol (&Qcircle, "circle"); + defsymbol (&Qsquare, "square"); + defsymbol (&Qwide, "wide"); + defsymbol (&Qnarrow, "narrow"); + defsymbol (&Qsmall, "small"); + defsymbol (&Qfont, "font"); + + DEFSUBR (Fchar_attribute_list); + DEFSUBR (Ffind_char_attribute_table); + DEFSUBR (Fchar_attribute_alist); + DEFSUBR (Fget_char_attribute); + DEFSUBR (Fput_char_attribute); + DEFSUBR (Fremove_char_attribute); + DEFSUBR (Fmap_char_attribute); + DEFSUBR (Fdefine_char); + DEFSUBR (Ffind_char); + DEFSUBR (Fchar_variants); + + DEFSUBR (Fget_composite_char); +#endif + INIT_LRECORD_IMPLEMENTATION (char_table); #ifdef MULE @@ -1856,6 +3301,22 @@ syms_of_chartab (void) void vars_of_chartab (void) { +#ifdef UTF2000 + Vutf_2000_version = build_string("0.17 (Hōryūji)"); + DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /* +Version number of XEmacs UTF-2000. +*/ ); + + staticpro (&Vcharacter_composition_table); + Vcharacter_composition_table = make_char_id_table (Qnil); + + staticpro (&Vcharacter_variant_table); + Vcharacter_variant_table = make_char_id_table (Qnil); + + staticpro (&Vchar_attribute_hash_table); + Vchar_attribute_hash_table + = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); +#endif /* DO NOT staticpro this. It works just like Vweak_hash_tables. */ Vall_syntax_tables = Qnil; dump_add_weak_object_chain (&Vall_syntax_tables);