X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fchartab.c;h=66ff5bc03f04cd1e0a69ca2844b7a8fd6b53aa98;hb=7edd70c9f9aed4de8014b6b63a7e7316f8e695f7;hp=82fce672d597030fd4226e2ff4038e4f9d6626a0;hpb=bdbf322fda10f6dcfae7d04c81ff0862e41ecc56;p=chise%2Fxemacs-chise.git- diff --git a/src/chartab.c b/src/chartab.c index 82fce67..66ff5bc 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -4,6 +4,7 @@ Copyright (C) 1995, 1996 Ben Wing. Copyright (C) 1995, 1997, 1999 Electrotechnical Laboratory, JAPAN. Licensed to the Free Software Foundation. + Copyright (C) 1999,2000,2001,2002 MORIOKA Tomohiko This file is part of XEmacs. @@ -41,11 +42,8 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" #include "chartab.h" #include "syntax.h" - #ifdef UTF2000 #include "elhash.h" - -Lisp_Object Vutf_2000_version; #endif /* UTF2000 */ Lisp_Object Qchar_tablep, Qchar_table; @@ -67,10 +65,11 @@ Lisp_Object Vword_combining_categories, Vword_separating_categories; #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 +#define BT_UINT8_MAX (UCHAR_MAX - 4) +#define BT_UINT8_t (UCHAR_MAX - 3) +#define BT_UINT8_nil (UCHAR_MAX - 2) +#define BT_UINT8_unbound (UCHAR_MAX - 1) +#define BT_UINT8_unloaded UCHAR_MAX INLINE_HEADER int INT_UINT8_P (Lisp_Object obj); INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj); @@ -94,14 +93,16 @@ INT_UINT8_P (Lisp_Object obj) INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj) { - return EQ (obj, Qunbound) + return EQ (obj, Qunloaded) || 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)) + if (EQ (obj, Qunloaded)) + return BT_UINT8_unloaded; + else if (EQ (obj, Qunbound)) return BT_UINT8_unbound; else if (EQ (obj, Qnil)) return BT_UINT8_nil; @@ -114,7 +115,9 @@ UINT8_ENCODE (Lisp_Object obj) INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n) { - if (n == BT_UINT8_unbound) + if (n == BT_UINT8_unloaded) + return Qunloaded; + else if (n == BT_UINT8_unbound) return Qunbound; else if (n == BT_UINT8_nil) return Qnil; @@ -189,12 +192,16 @@ uint8_byte_table_hash (Lisp_Object obj, int depth) return hash; } +static const struct lrecord_description uint8_byte_table_description[] = { + { XD_END } +}; + 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 */, + uint8_byte_table_description, Lisp_Uint8_Byte_Table); static Lisp_Object @@ -214,6 +221,25 @@ make_uint8_byte_table (unsigned char initval) return obj; } +static Lisp_Object +copy_uint8_byte_table (Lisp_Object entry) +{ + Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry); + Lisp_Object obj; + int i; + Lisp_Uint8_Byte_Table *ctenew + = alloc_lcrecord_type (Lisp_Uint8_Byte_Table, + &lrecord_uint8_byte_table); + + for (i = 0; i < 256; i++) + { + ctenew->property[i] = cte->property[i]; + } + + XSETUINT8_BYTE_TABLE (obj, ctenew); + return obj; +} + static int uint8_byte_table_same_value_p (Lisp_Object obj) { @@ -230,8 +256,8 @@ uint8_byte_table_same_value_p (Lisp_Object obj) } static int -map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place, - Lisp_Object ccs, +map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root, + Emchar ofs, int place, int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg), void *arg) @@ -246,17 +272,33 @@ map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place, for (i = 0, retval = 0; i < 256 && retval == 0; i++) { - if (ct->property[i] != BT_UINT8_unbound) + if (ct->property[i] == BT_UINT8_unloaded) { +#if 0 c1 = c + unit; for (; c < c1 && retval == 0; c++) { - if ( NILP (ccs) || charset_code_point (ccs, c) >= 0 ) + Lisp_Object ret = get_char_id_table (root, c); + + if (!UNBOUNDP (ret)) { rainj.ch = c; - retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg); + retval = (fn) (&rainj, ret, arg); } } +#else + ct->property[i] = BT_UINT8_unbound; + c += unit; +#endif + } + else if (ct->property[i] != BT_UINT8_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + rainj.ch = c; + retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg); + } } else c += unit; @@ -264,11 +306,50 @@ map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place, return retval; } +#ifdef HAVE_DATABASE +static void +save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root, + Lisp_Object db, + Emchar ofs, int place) +{ + struct chartab_range rainj; + int i, retval; + int unit = 1 << (8 * place); + Emchar c = ofs; + Emchar c1; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + if (ct->property[i] == BT_UINT8_unloaded) + { + c1 = c + unit; + } + else if (ct->property[i] != BT_UINT8_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + Fput_database (Fprin1_to_string (make_char (c), Qnil), + Fprin1_to_string (UINT8_DECODE (ct->property[i]), + Qnil), + db, Qt); + put_char_id_table (root, make_char (c), Qunloaded); + } + } + else + c += unit; + } +} +#endif + #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 +#define BT_UINT16_MAX (USHRT_MAX - 4) +#define BT_UINT16_t (USHRT_MAX - 3) +#define BT_UINT16_nil (USHRT_MAX - 2) +#define BT_UINT16_unbound (USHRT_MAX - 1) +#define BT_UINT16_unloaded USHRT_MAX INLINE_HEADER int INT_UINT16_P (Lisp_Object obj); INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj); @@ -291,14 +372,16 @@ INT_UINT16_P (Lisp_Object obj) INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj) { - return EQ (obj, Qunbound) + return EQ (obj, Qunloaded) || 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)) + if (EQ (obj, Qunloaded)) + return BT_UINT16_unloaded; + else if (EQ (obj, Qunbound)) return BT_UINT16_unbound; else if (EQ (obj, Qnil)) return BT_UINT16_nil; @@ -311,7 +394,9 @@ UINT16_ENCODE (Lisp_Object obj) INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short n) { - if (n == BT_UINT16_unbound) + if (n == BT_UINT16_unloaded) + return Qunloaded; + else if (n == BT_UINT16_unbound) return Qunbound; else if (n == BT_UINT16_nil) return Qnil; @@ -324,7 +409,9 @@ UINT16_DECODE (unsigned short n) INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n) { - if (n == BT_UINT8_unbound) + if (n == BT_UINT8_unloaded) + return BT_UINT16_unloaded; + else if (n == BT_UINT8_unbound) return BT_UINT16_unbound; else if (n == BT_UINT8_nil) return BT_UINT16_nil; @@ -399,12 +486,16 @@ uint16_byte_table_hash (Lisp_Object obj, int depth) return hash; } +static const struct lrecord_description uint16_byte_table_description[] = { + { XD_END } +}; + 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 */, + uint16_byte_table_description, Lisp_Uint16_Byte_Table); static Lisp_Object @@ -425,6 +516,25 @@ make_uint16_byte_table (unsigned short initval) } static Lisp_Object +copy_uint16_byte_table (Lisp_Object entry) +{ + Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry); + Lisp_Object obj; + int i; + Lisp_Uint16_Byte_Table *ctenew + = alloc_lcrecord_type (Lisp_Uint16_Byte_Table, + &lrecord_uint16_byte_table); + + for (i = 0; i < 256; i++) + { + ctenew->property[i] = cte->property[i]; + } + + XSETUINT16_BYTE_TABLE (obj, ctenew); + return obj; +} + +static Lisp_Object expand_uint8_byte_table_to_uint16 (Lisp_Object table) { Lisp_Object obj; @@ -458,8 +568,8 @@ uint16_byte_table_same_value_p (Lisp_Object obj) } static int -map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place, - Lisp_Object ccs, +map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root, + Emchar ofs, int place, int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg), void *arg) @@ -474,18 +584,33 @@ map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place, for (i = 0, retval = 0; i < 256 && retval == 0; i++) { - if (ct->property[i] != BT_UINT16_unbound) + if (ct->property[i] == BT_UINT16_unloaded) { +#if 0 c1 = c + unit; for (; c < c1 && retval == 0; c++) { - if ( NILP (ccs) || charset_code_point (ccs, c) >= 0 ) + Lisp_Object ret = get_char_id_table (root, c); + + if (!UNBOUNDP (ret)) { rainj.ch = c; - retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), - arg); + retval = (fn) (&rainj, ret, arg); } } +#else + ct->property[i] = BT_UINT16_unbound; + c += unit; +#endif + } + else if (ct->property[i] != BT_UINT16_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + rainj.ch = c; + retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg); + } } else c += unit; @@ -493,6 +618,44 @@ map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place, return retval; } +#ifdef HAVE_DATABASE +static void +save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root, + Lisp_Object db, + Emchar ofs, int place) +{ + struct chartab_range rainj; + int i, retval; + int unit = 1 << (8 * place); + Emchar c = ofs; + Emchar c1; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + if (ct->property[i] == BT_UINT16_unloaded) + { + c1 = c + unit; + } + else if (ct->property[i] != BT_UINT16_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + Fput_database (Fprin1_to_string (make_char (c), Qnil), + Fprin1_to_string (UINT16_DECODE (ct->property[i]), + Qnil), + db, Qt); + put_char_id_table (root, make_char (c), Qunloaded); + } + } + else + c += unit; + } +} +#endif + static Lisp_Object mark_byte_table (Lisp_Object obj) @@ -593,6 +756,37 @@ make_byte_table (Lisp_Object initval) return obj; } +static Lisp_Object +copy_byte_table (Lisp_Object entry) +{ + Lisp_Byte_Table *cte = XBYTE_TABLE (entry); + Lisp_Object obj; + int i; + Lisp_Byte_Table *ctnew + = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table); + + for (i = 0; i < 256; i++) + { + if (UINT8_BYTE_TABLE_P (cte->property[i])) + { + ctnew->property[i] = copy_uint8_byte_table (cte->property[i]); + } + else if (UINT16_BYTE_TABLE_P (cte->property[i])) + { + ctnew->property[i] = copy_uint16_byte_table (cte->property[i]); + } + else if (BYTE_TABLE_P (cte->property[i])) + { + ctnew->property[i] = copy_byte_table (cte->property[i]); + } + else + ctnew->property[i] = cte->property[i]; + } + + XSETBYTE_TABLE (obj, ctnew); + return obj; +} + static int byte_table_same_value_p (Lisp_Object obj) { @@ -609,8 +803,8 @@ byte_table_same_value_p (Lisp_Object obj) } static int -map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place, - Lisp_Object ccs, +map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root, + Emchar ofs, int place, int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg), void *arg) @@ -626,25 +820,26 @@ map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place, if (UINT8_BYTE_TABLE_P (v)) { retval - = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), - c, place - 1, ccs, fn, arg); + = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, + c, place - 1, fn, arg); c += unit; } else if (UINT16_BYTE_TABLE_P (v)) { retval - = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), - c, place - 1, ccs, fn, arg); + = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, + c, place - 1, fn, arg); c += unit; } else if (BYTE_TABLE_P (v)) { - retval = map_over_byte_table (XBYTE_TABLE(v), - c, place - 1, ccs, fn, arg); + retval = map_over_byte_table (XBYTE_TABLE(v), root, + c, place - 1, fn, arg); c += unit; } - else if (!UNBOUNDP (v)) + else if (EQ (v, Qunloaded)) { +#if 0 struct chartab_range rainj; Emchar c1 = c + unit; @@ -652,12 +847,31 @@ map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place, for (; c < c1 && retval == 0; c++) { - if ( NILP (ccs) || charset_code_point (ccs, c) >= 0 ) + Lisp_Object ret = get_char_id_table (root, c); + + if (!UNBOUNDP (ret)) { rainj.ch = c; - retval = (fn) (&rainj, v, arg); + retval = (fn) (&rainj, ret, arg); } } +#else + ct->property[i] = Qunbound; + c += unit; +#endif + } + else if (!UNBOUNDP (v)) + { + struct chartab_range rainj; + Emchar c1 = c + unit; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (; c < c1 && retval == 0; c++) + { + rainj.ch = c; + retval = (fn) (&rainj, v, arg); + } } else c += unit; @@ -665,10 +879,62 @@ map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place, return retval; } +#ifdef HAVE_DATABASE +static void +save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root, + Lisp_Object db, + 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)) + { + save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db, + c, place - 1); + c += unit; + } + else if (UINT16_BYTE_TABLE_P (v)) + { + save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db, + c, place - 1); + c += unit; + } + else if (BYTE_TABLE_P (v)) + { + save_byte_table (XBYTE_TABLE(v), root, db, + c, place - 1); + c += unit; + } + else if (EQ (v, Qunloaded)) + { + c += unit; + } + else if (!UNBOUNDP (v)) + { + struct chartab_range rainj; + Emchar c1 = c + unit; + + rainj.type = CHARTAB_RANGE_CHAR; -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); + for (; c < c1 && retval == 0; c++) + { + Fput_database (Fprin1_to_string (make_char (c), Qnil), + Fprin1_to_string (v, Qnil), + db, Qt); + put_char_id_table (root, make_char (c), Qunloaded); + } + } + else + c += unit; + } +} +#endif Lisp_Object get_byte_table (Lisp_Object table, unsigned char idx) @@ -776,303 +1042,27 @@ put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object 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); -} - -static const struct lrecord_description char_id_table_description[] = { - { XD_LISP_OBJECT, offsetof(Lisp_Char_ID_Table, table) }, - { XD_END } -}; - -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); 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); + obj = Fmake_char_table (Qgeneric); + fill_char_table (XCHAR_TABLE (obj), initval); 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, - struct chartab_range *range, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg); -int -map_char_id_table (Lisp_Char_ID_Table *ct, - struct chartab_range *range, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) -{ - Lisp_Object v = ct->table; - - switch (range->type) - { - case CHARTAB_RANGE_ALL: - if (UINT8_BYTE_TABLE_P (v)) - return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), 0, 3, - Qnil, fn, arg); - else if (UINT16_BYTE_TABLE_P (v)) - return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), 0, 3, - Qnil, fn, arg); - else if (BYTE_TABLE_P (v)) - return map_over_byte_table (XBYTE_TABLE(v), 0, 3, Qnil, fn, arg); - else if (!UNBOUNDP (v)) - { - struct chartab_range rainj; - int unit = 1 << 24; - Emchar c = 0; - Emchar c1 = c + unit; - int retval; - - rainj.type = CHARTAB_RANGE_CHAR; - - for (retval = 0; c < c1 && retval == 0; c++) - { - rainj.ch = c; - retval = (fn) (&rainj, v, arg); - } - } - return 0; - case CHARTAB_RANGE_CHARSET: - if (UINT8_BYTE_TABLE_P (v)) - return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), 0, 3, - range->charset, fn, arg); - else if (UINT16_BYTE_TABLE_P (v)) - return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), 0, 3, - range->charset, fn, arg); - else if (BYTE_TABLE_P (v)) - return map_over_byte_table (XBYTE_TABLE(v), 0, 3, - range->charset, fn, arg); - else if (!UNBOUNDP (v)) - { - struct chartab_range rainj; - int unit = 1 << 24; - Emchar c = 0; - Emchar c1 = c + unit; - int retval; - - rainj.type = CHARTAB_RANGE_CHAR; - - for (retval = 0; c < c1 && retval == 0; c++) - { - if ( charset_code_point (range->charset, c) >= 0 ) - { - rainj.ch = c; - retval = (fn) (&rainj, v, arg); - } - } - } - return 0; - case CHARTAB_RANGE_ROW: - { - int cell_min, cell_max, i; - int retval; - struct chartab_range rainj; - - if (XCHARSET_DIMENSION (range->charset) < 2) - signal_simple_error ("Charset in row vector must be multi-byte", - range->charset); - else - { - switch (XCHARSET_CHARS (range->charset)) - { - case 94: - cell_min = 33; cell_max = 126; - break; - case 96: - cell_min = 32; cell_max = 127; - break; - case 128: - cell_min = 0; cell_max = 127; - break; - case 256: - cell_min = 0; cell_max = 255; - break; - default: - abort (); - } - } - if (XCHARSET_DIMENSION (range->charset) == 2) - check_int_range (range->row, cell_min, cell_max); - else if (XCHARSET_DIMENSION (range->charset) == 3) - { - check_int_range (range->row >> 8 , cell_min, cell_max); - check_int_range (range->row & 0xFF, cell_min, cell_max); - } - else if (XCHARSET_DIMENSION (range->charset) == 4) - { - check_int_range ( range->row >> 16 , cell_min, cell_max); - check_int_range ((range->row >> 8) & 0xFF, cell_min, cell_max); - check_int_range ( range->row & 0xFF, cell_min, cell_max); - } - else - abort (); - - rainj.type = CHARTAB_RANGE_CHAR; - for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++) - { - Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i); - Lisp_Object val - = get_byte_table (get_byte_table - (get_byte_table - (get_byte_table - (v, - (unsigned char)(ch >> 24)), - (unsigned char) (ch >> 16)), - (unsigned char) (ch >> 8)), - (unsigned char) ch); - - if (!UNBOUNDP (val)) - { - rainj.ch = ch; - retval = (fn) (&rainj, val, arg); - } - } - return retval; - } - case CHARTAB_RANGE_CHAR: - { - Emchar ch = range->ch; - Lisp_Object val - = get_byte_table (get_byte_table - (get_byte_table - (get_byte_table - (v, - (unsigned char)(ch >> 24)), - (unsigned char) (ch >> 16)), - (unsigned char) (ch >> 8)), - (unsigned char) ch); - struct chartab_range rainj; - - if (!UNBOUNDP (val)) - { - rainj.type = CHARTAB_RANGE_CHAR; - rainj.ch = ch; - return (fn) (&rainj, val, arg); - } - else - return 0; - } - default: - abort (); - } - return 0; -} - - Lisp_Object Vcharacter_composition_table; Lisp_Object Vcharacter_variant_table; +Lisp_Object Qsystem_char_id; + Lisp_Object Q_decomposition; Lisp_Object Qto_ucs; Lisp_Object Q_ucs; +Lisp_Object Q_ucs_variants; Lisp_Object Qcompat; Lisp_Object Qisolated; Lisp_Object Qinitial; @@ -1149,19 +1139,19 @@ Return character corresponding with list. Lisp_Object ret; Emchar c = to_char_id (v, "Invalid value for composition", list); - ret = get_char_id_table (c, table); + ret = get_char_id_table (XCHAR_TABLE(table), c); rest = Fcdr (rest); if (NILP (rest)) { - if (!CHAR_ID_TABLE_P (ret)) + if (!CHAR_TABLEP (ret)) return ret; else return Qt; } else if (!CONSP (rest)) break; - else if (CHAR_ID_TABLE_P (ret)) + else if (CHAR_TABLEP (ret)) table = ret; else signal_simple_error ("Invalid table is found with", list); @@ -1174,9 +1164,15 @@ Return variants of CHARACTER. */ (character)) { + Lisp_Object ret; + CHECK_CHAR (character); - return Fcopy_list (get_char_id_table (XCHAR (character), - Vcharacter_variant_table)); + ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + XCHAR(character)); + if (CONSP (ret)) + return Fcopy_list (ret); + else + return Qnil; } #endif @@ -1216,7 +1212,7 @@ Return variants of CHARACTER. /* Char Table object */ /************************************************************************/ -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) static Lisp_Object mark_char_table_entry (Lisp_Object obj) @@ -1270,6 +1266,11 @@ static Lisp_Object mark_char_table (Lisp_Object obj) { Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 + + mark_object (ct->table); + mark_object (ct->name); +#else int i; for (i = 0; i < NUM_ASCII_CHARS; i++) @@ -1278,7 +1279,12 @@ mark_char_table (Lisp_Object obj) for (i = 0; i < NUM_LEADING_BYTES; i++) mark_object (ct->level1[i]); #endif +#endif +#ifdef UTF2000 + return ct->default_value; +#else return ct->mirror_table; +#endif } /* WARNING: All functions of this nature need to be written extremely @@ -1360,7 +1366,7 @@ print_chartab_range (Emchar first, Emchar last, Lisp_Object val, print_internal (val, printcharfun, 1); } -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) static void print_chartab_charset_row (Lisp_Object charset, @@ -1444,6 +1450,30 @@ static void print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("#s(char-table ", printcharfun); + write_c_string (" ", printcharfun); + write_c_string (string_data + (symbol_name + (XSYMBOL (char_table_type_to_symbol (ct->type)))), + printcharfun); + write_c_string ("\n ", printcharfun); + print_internal (ct->default_value, printcharfun, escapeflag); + for (i = 0; i < 256; i++) + { + Lisp_Object elt = get_byte_table (ct->table, i); + if (i != 0) write_c_string ("\n ", printcharfun); + if (EQ (elt, Qunbound)) + write_c_string ("void", printcharfun); + else + print_internal (elt, printcharfun, escapeflag); + } + UNGCPRO; +#else /* non UTF2000 */ char buf[200]; sprintf (buf, "#s(char-table type %s data (", @@ -1510,6 +1540,7 @@ print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) } } #endif /* MULE */ +#endif /* non UTF2000 */ write_c_string ("))", printcharfun); } @@ -1524,6 +1555,14 @@ char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2)) return 0; +#ifdef UTF2000 + for (i = 0; i < 256; i++) + { + if (!internal_equal (get_byte_table (ct1->table, i), + get_byte_table (ct2->table, i), 0)) + return 0; + } +#else for (i = 0; i < NUM_ASCII_CHARS; i++) if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1)) return 0; @@ -1533,6 +1572,7 @@ char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1)) return 0; #endif /* MULE */ +#endif /* non UTF2000 */ return 1; } @@ -1541,6 +1581,9 @@ static unsigned long char_table_hash (Lisp_Object obj, int depth) { Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 + return byte_table_hash (ct->table, depth + 1); +#else unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS, depth); #ifdef MULE @@ -1548,14 +1591,23 @@ char_table_hash (Lisp_Object obj, int depth) internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth)); #endif /* MULE */ return hashval; +#endif } static const struct lrecord_description char_table_description[] = { +#ifdef UTF2000 + { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) }, + { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) }, + { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, name) }, +#else { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS }, #ifdef MULE { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES }, #endif +#endif +#ifndef UTF2000 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) }, +#endif { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) }, { XD_END } }; @@ -1669,6 +1721,11 @@ See `valid-char-table-type-p'. void fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) { +#ifdef UTF2000 + ct->table = Qunbound; + ct->default_value = value; + ct->unloaded = 0; +#else int i; for (i = 0; i < NUM_ASCII_CHARS; i++) @@ -1677,9 +1734,12 @@ fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) for (i = 0; i < NUM_LEADING_BYTES; i++) ct->level1[i] = value; #endif /* MULE */ +#endif +#ifndef UTF2000 if (ct->type == CHAR_TABLE_TYPE_SYNTAX) update_syntax_table (ct); +#endif } DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /* @@ -1729,6 +1789,7 @@ and 'syntax. See `valid-char-table-type-p'. ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); ct->type = ty; +#ifndef UTF2000 if (ty == CHAR_TABLE_TYPE_SYNTAX) { ct->mirror_table = Fmake_char_table (Qgeneric); @@ -1737,6 +1798,9 @@ and 'syntax. See `valid-char-table-type-p'. } else ct->mirror_table = Qnil; +#else + ct->name = Qnil; +#endif ct->next_table = Qnil; XSETCHAR_TABLE (obj, ct); if (ty == CHAR_TABLE_TYPE_SYNTAX) @@ -1748,7 +1812,7 @@ and 'syntax. See `valid-char-table-type-p'. return obj; } -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) static Lisp_Object make_char_table_entry (Lisp_Object initval) @@ -1798,12 +1862,34 @@ as CHAR-TABLE. The values will not themselves be copied. { Lisp_Char_Table *ct, *ctnew; Lisp_Object obj; +#ifndef UTF2000 int i; +#endif CHECK_CHAR_TABLE (char_table); ct = XCHAR_TABLE (char_table); ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); ctnew->type = ct->type; +#ifdef UTF2000 + ctnew->default_value = ct->default_value; + /* [tomo:2002-01-21] Perhaps this code seems wrong */ + ctnew->name = ct->name; + + if (UINT8_BYTE_TABLE_P (ct->table)) + { + ctnew->table = copy_uint8_byte_table (ct->table); + } + else if (UINT16_BYTE_TABLE_P (ct->table)) + { + ctnew->table = copy_uint16_byte_table (ct->table); + } + else if (BYTE_TABLE_P (ct->table)) + { + ctnew->table = copy_byte_table (ct->table); + } + else if (!UNBOUNDP (ct->table)) + ctnew->table = ct->table; +#else /* non UTF2000 */ for (i = 0; i < NUM_ASCII_CHARS; i++) { @@ -1826,11 +1912,14 @@ as CHAR-TABLE. The values will not themselves be copied. } #endif /* MULE */ +#endif /* non UTF2000 */ +#ifndef UTF2000 if (CHAR_TABLEP (ct->mirror_table)) ctnew->mirror_table = Fcopy_char_table (ct->mirror_table); else ctnew->mirror_table = ct->mirror_table; +#endif ctnew->next_table = Qnil; XSETCHAR_TABLE (obj, ctnew); if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX) @@ -1841,11 +1930,38 @@ as CHAR-TABLE. The values will not themselves be copied. return obj; } -static void +INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs); +INLINE_HEADER int +XCHARSET_CELL_RANGE (Lisp_Object ccs) +{ + switch (XCHARSET_CHARS (ccs)) + { + case 94: + return (33 << 8) | 126; + case 96: + return (32 << 8) | 127; +#ifdef UTF2000 + case 128: + return (0 << 8) | 127; + case 256: + return (0 << 8) | 255; +#endif + default: + abort (); + return 0; + } +} + +#ifndef UTF2000 +static +#endif +void decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) { if (EQ (range, Qt)) outrange->type = CHARTAB_RANGE_ALL; + else if (EQ (range, Qnil)) + outrange->type = CHARTAB_RANGE_DEFAULT; else if (CHAR_OR_CHAR_INTP (range)) { outrange->type = CHARTAB_RANGE_CHAR; @@ -1859,30 +1975,39 @@ decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) { Lisp_Vector *vec = XVECTOR (range); Lisp_Object *elts = vector_data (vec); - if (vector_length (vec) != 2) - signal_simple_error ("Length of charset row vector must be 2", - range); + int cell_min, cell_max; + outrange->type = CHARTAB_RANGE_ROW; outrange->charset = Fget_charset (elts[0]); CHECK_INT (elts[1]); outrange->row = XINT (elts[1]); - if (XCHARSET_DIMENSION (outrange->charset) >= 2) + if (XCHARSET_DIMENSION (outrange->charset) < 2) + signal_simple_error ("Charset in row vector must be multi-byte", + outrange->charset); + else { - switch (XCHARSET_CHARS (outrange->charset)) - { - case 94: - check_int_range (outrange->row, 33, 126); - break; - case 96: - check_int_range (outrange->row, 32, 127); - break; - default: - abort (); - } + int ret = XCHARSET_CELL_RANGE (outrange->charset); + + cell_min = ret >> 8; + cell_max = ret & 0xFF; } + if (XCHARSET_DIMENSION (outrange->charset) == 2) + check_int_range (outrange->row, cell_min, cell_max); +#ifdef UTF2000 + else if (XCHARSET_DIMENSION (outrange->charset) == 3) + { + check_int_range (outrange->row >> 8 , cell_min, cell_max); + check_int_range (outrange->row & 0xFF, cell_min, cell_max); + } + else if (XCHARSET_DIMENSION (outrange->charset) == 4) + { + check_int_range ( outrange->row >> 16 , cell_min, cell_max); + check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max); + check_int_range ( outrange->row & 0xFF, cell_min, cell_max); + } +#endif else - signal_simple_error ("Charset in row vector must be multi-byte", - outrange->charset); + abort (); } else { @@ -1895,7 +2020,7 @@ decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) #endif /* MULE */ } -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) /* called from CHAR_TABLE_VALUE(). */ Lisp_Object @@ -1937,7 +2062,9 @@ get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte, Lisp_Object get_char_table (Emchar ch, Lisp_Char_Table *ct) { -#ifdef MULE +#ifdef UTF2000 + return get_char_id_table (ct, ch); +#elif defined(MULE) { Lisp_Object charset; int byte1, byte2; @@ -2005,6 +2132,16 @@ If there is more than one value, return MULTI (defaults to nil). { case CHARTAB_RANGE_ALL: { +#ifdef UTF2000 + if (UINT8_BYTE_TABLE_P (ct->table)) + return multi; + else if (UINT16_BYTE_TABLE_P (ct->table)) + return multi; + else if (BYTE_TABLE_P (ct->table)) + return multi; + else + return ct->table; +#else /* non UTF2000 */ int i; Lisp_Object first = ct->ascii[0]; @@ -2026,10 +2163,14 @@ If there is more than one value, return MULTI (defaults to nil). #endif /* MULE */ return first; +#endif /* non UTF2000 */ } #ifdef MULE case CHARTAB_RANGE_CHARSET: +#ifdef UTF2000 + return multi; +#else if (EQ (rainj.charset, Vcharset_ascii)) { int i; @@ -2059,8 +2200,12 @@ If there is more than one value, return MULTI (defaults to nil). return multi; return val; } +#endif case CHARTAB_RANGE_ROW: +#ifdef UTF2000 + return multi; +#else { Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - MIN_LEADING_BYTE]; @@ -2071,6 +2216,7 @@ If there is more than one value, return MULTI (defaults to nil). return multi; return val; } +#endif /* not UTF2000 */ #endif /* not MULE */ default: @@ -2174,6 +2320,22 @@ Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE. return Qnil; } +#ifdef UTF2000 +Lisp_Char_Table* char_attribute_table_to_put; +Lisp_Object Qput_char_table_map_function; +Lisp_Object value_to_put; + +DEFUN ("put-char-table-map-function", + Fput_char_table_map_function, 2, 2, 0, /* +For internal use. Don't use it. +*/ + (c, value)) +{ + put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put); + return Qnil; +} +#endif + /* Assign VAL to all characters in RANGE in char table CT. */ void @@ -2183,12 +2345,54 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, switch (range->type) { case CHARTAB_RANGE_ALL: + /* printf ("put-char-table: range = all\n"); */ fill_char_table (ct, val); return; /* avoid the duplicate call to update_syntax_table() below, since fill_char_table() also did that. */ +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + ct->default_value = val; + return; +#endif + #ifdef MULE case CHARTAB_RANGE_CHARSET: +#ifdef UTF2000 + { + Emchar c; + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset); + + /* printf ("put-char-table: range = charset: %d\n", + XCHARSET_LEADING_BYTE (range->charset)); + */ + if ( CHAR_TABLEP (encoding_table) ) + { +#if 1 + char_attribute_table_to_put = ct; + value_to_put = val; + Fmap_char_attribute (Qput_char_table_map_function, + XCHAR_TABLE_NAME (encoding_table), + Qnil); +#else + for (c = 0; c < 1 << 24; c++) + { + if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table), + c)) ) + put_char_id_table_0 (ct, c, val); + } +#endif + } + else + { + for (c = 0; c < 1 << 24; c++) + { + if ( charset_code_point (range->charset, c) >= 0 ) + put_char_id_table_0 (ct, c, val); + } + } + } +#else if (EQ (range->charset, Vcharset_ascii)) { int i; @@ -2206,9 +2410,26 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; ct->level1[lb] = val; } +#endif break; - case CHARTAB_RANGE_ROW: + case CHARTAB_RANGE_ROW: +#ifdef UTF2000 + { + int cell_min, cell_max, i; + + i = XCHARSET_CELL_RANGE (range->charset); + cell_min = i >> 8; + cell_max = i & 0xFF; + for (i = cell_min; i <= cell_max; i++) + { + Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i); + + if ( charset_code_point (range->charset, ch) >= 0 ) + put_char_id_table_0 (ct, ch, val); + } + } +#else { Lisp_Char_Table_Entry *cte; int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; @@ -2218,11 +2439,16 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); cte->level2[range->row - 32] = val; } +#endif /* not UTF2000 */ break; #endif /* MULE */ case CHARTAB_RANGE_CHAR: -#ifdef MULE +#ifdef UTF2000 + /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */ + put_char_id_table_0 (ct, range->ch, val); + break; +#elif defined(MULE) { Lisp_Object charset; int byte1, byte2; @@ -2264,8 +2490,10 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, #endif /* not MULE */ } +#ifndef UTF2000 if (ct->type == CHAR_TABLE_TYPE_SYNTAX) update_syntax_table (ct); +#endif } DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /* @@ -2297,6 +2525,7 @@ See `valid-char-table-type-p'. return Qnil; } +#ifndef UTF2000 /* Map FN over the ASCII chars in CT. */ static int @@ -2447,6 +2676,56 @@ map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb, } #endif /* MULE */ +#endif /* not UTF2000 */ + +#ifdef UTF2000 +struct map_char_table_for_charset_arg +{ + int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg); + Lisp_Char_Table *ct; + void *arg; +}; + +static int +map_char_table_for_charset_fun (struct chartab_range *range, + Lisp_Object val, void *arg) +{ + struct map_char_table_for_charset_arg *closure = + (struct map_char_table_for_charset_arg *) arg; + Lisp_Object ret; + + switch (range->type) + { + case CHARTAB_RANGE_ALL: + break; + + case CHARTAB_RANGE_DEFAULT: + break; + + case CHARTAB_RANGE_CHARSET: + break; + + case CHARTAB_RANGE_ROW: + break; + + case CHARTAB_RANGE_CHAR: + ret = get_char_table (range->ch, closure->ct); + if (!UNBOUNDP (ret)) + return (closure->fn) (range, ret, closure->arg); + break; + + default: + abort (); + } + + return 0; +} + +#if defined(HAVE_DATABASE) +EXFUN (Fload_char_attribute_table, 1); +#endif + +#endif /* Map FN (with client data ARG) over range RANGE in char table CT. Mapping stops the first time FN returns non-zero, and that value @@ -2462,6 +2741,56 @@ map_char_table (Lisp_Char_Table *ct, switch (range->type) { case CHARTAB_RANGE_ALL: +#ifdef UTF2000 + if (!UNBOUNDP (ct->default_value)) + { + struct chartab_range rainj; + int retval; + + rainj.type = CHARTAB_RANGE_DEFAULT; + retval = (fn) (&rainj, ct->default_value, arg); + if (retval != 0) + return retval; + } + if (UINT8_BYTE_TABLE_P (ct->table)) + return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, + 0, 3, fn, arg); + else if (UINT16_BYTE_TABLE_P (ct->table)) + return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, + 0, 3, fn, arg); + else if (BYTE_TABLE_P (ct->table)) + return map_over_byte_table (XBYTE_TABLE(ct->table), ct, + 0, 3, fn, arg); + else if (EQ (ct->table, Qunloaded)) + { +#if 0 + struct chartab_range rainj; + int unit = 1 << 30; + Emchar c = 0; + Emchar c1 = c + unit; + int retval; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (retval = 0; c < c1 && retval == 0; c++) + { + Lisp_Object ret = get_char_id_table (ct, c); + + if (!UNBOUNDP (ret)) + { + rainj.ch = c; + retval = (fn) (&rainj, ct->table, arg); + } + } + return retval; +#else + ct->table = Qunbound; +#endif + } + else if (!UNBOUNDP (ct->table)) + return (fn) (range, ct->table, arg); + return 0; +#else { int retval; @@ -2485,14 +2814,84 @@ map_char_table (Lisp_Char_Table *ct, #endif /* MULE */ return retval; } +#endif + +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + if (!UNBOUNDP (ct->default_value)) + return (fn) (range, ct->default_value, arg); + return 0; +#endif #ifdef MULE case CHARTAB_RANGE_CHARSET: +#ifdef UTF2000 + { + Lisp_Object encoding_table + = XCHARSET_ENCODING_TABLE (range->charset); + + if (!NILP (encoding_table)) + { + struct chartab_range rainj; + struct map_char_table_for_charset_arg mcarg; + +#ifdef HAVE_DATABASE + if (XCHAR_TABLE_UNLOADED(encoding_table)) + Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table)); +#endif + mcarg.fn = fn; + mcarg.ct = ct; + mcarg.arg = arg; + rainj.type = CHARTAB_RANGE_ALL; + return map_char_table (XCHAR_TABLE(encoding_table), + &rainj, + &map_char_table_for_charset_fun, + &mcarg); + } + } + return 0; +#else return map_over_other_charset (ct, XCHARSET_LEADING_BYTE (range->charset), fn, arg); +#endif case CHARTAB_RANGE_ROW: +#ifdef UTF2000 + { + int cell_min, cell_max, i; + int retval; + struct chartab_range rainj; + + i = XCHARSET_CELL_RANGE (range->charset); + cell_min = i >> 8; + cell_max = i & 0xFF; + rainj.type = CHARTAB_RANGE_CHAR; + for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++) + { + Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i); + + if ( charset_code_point (range->charset, ch) >= 0 ) + { + Lisp_Object val + = get_byte_table (get_byte_table + (get_byte_table + (get_byte_table + (ct->table, + (unsigned char)(ch >> 24)), + (unsigned char) (ch >> 16)), + (unsigned char) (ch >> 8)), + (unsigned char) ch); + + if (UNBOUNDP (val)) + val = ct->default_value; + rainj.ch = ch; + retval = (fn) (&rainj, val, arg); + } + } + return retval; + } +#else { Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE]; @@ -2510,17 +2909,23 @@ map_char_table (Lisp_Char_Table *ct, range->charset, range->row, fn, arg); } +#endif /* not UTF2000 */ #endif /* MULE */ case CHARTAB_RANGE_CHAR: { Emchar ch = range->ch; Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch); - struct chartab_range rainj; - rainj.type = CHARTAB_RANGE_CHAR; - rainj.ch = ch; - return (fn) (&rainj, val, arg); + if (!UNBOUNDP (val)) + { + struct chartab_range rainj; + + rainj.type = CHARTAB_RANGE_CHAR; + rainj.ch = ch; + return (fn) (&rainj, val, arg); + } + return 0; } default: @@ -2550,6 +2955,12 @@ slow_map_char_table_fun (struct chartab_range *range, ranjarg = Qt; break; +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + ranjarg = Qnil; + break; +#endif + #ifdef MULE case CHARTAB_RANGE_CHARSET: ranjarg = XCHARSET_NAME (range->charset); @@ -2677,7 +3088,8 @@ add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value, /* 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); + Lisp_Object ret + = get_char_id_table (XCHAR_TABLE(value), caacl->char_id); if (!UNBOUNDP (ret)) { Lisp_Object *char_attribute_alist = caacl->char_attribute_alist; @@ -2692,40 +3104,20 @@ Return the alist of attributes of CHARACTER. */ (character)) { + struct gcpro gcpro1; + struct char_attribute_alist_closure char_attribute_alist_closure; 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; + 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; - 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; } @@ -2735,27 +3127,21 @@ Return DEFAULT-VALUE if the value is not exist. */ (character, attribute, default_value)) { - Lisp_Object ccs; + Lisp_Object table; 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 + if (CHARSETP (attribute)) + attribute = XCHARSET_NAME (attribute); + + table = Fgethash (attribute, Vchar_attribute_hash_table, + Qunbound); + if (!UNBOUNDP (table)) { - 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; - } + Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table), + XCHAR (character)); + if (!UNBOUNDP (ret)) + return ret; } return default_value; } @@ -2765,18 +3151,18 @@ Store CHARACTER's ATTRIBUTE with VALUE. */ (character, attribute, value)) { - Lisp_Object ccs; + Lisp_Object ccs = Ffind_charset (attribute); - CHECK_CHAR (character); - ccs = Ffind_charset (attribute); if (!NILP (ccs)) { - return put_char_ccs_code_point (character, ccs, value); + CHECK_CHAR (character); + value = put_char_ccs_code_point (character, ccs, value); } else if (EQ (attribute, Q_decomposition)) { Lisp_Object seq; + CHECK_CHAR (character); if (!CONSP (value)) signal_simple_error ("Invalid value for ->decomposition", value); @@ -2805,16 +3191,18 @@ Store CHARACTER's ATTRIBUTE with VALUE. rest = Fcdr (rest); if (!CONSP (rest)) { - put_char_id_table (c, character, table); + put_char_id_table (XCHAR_TABLE(table), + make_char (c), character); break; } else { - ntable = get_char_id_table (c, table); - if (!CHAR_ID_TABLE_P (ntable)) + ntable = get_char_id_table (XCHAR_TABLE(table), c); + if (!CHAR_TABLEP (ntable)) { ntable = make_char_id_table (Qnil); - put_char_id_table (c, ntable, table); + put_char_id_table (XCHAR_TABLE(table), + make_char (c), ntable); } table = ntable; } @@ -2828,12 +3216,18 @@ Store CHARACTER's ATTRIBUTE with VALUE. { Emchar c = XINT (v); Lisp_Object ret - = get_char_id_table (c, Vcharacter_variant_table); + = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + c); - if (NILP (Fmemq (v, ret))) + if (!CONSP (ret)) + { + put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + make_char (c), Fcons (character, Qnil)); + } + else if (NILP (Fmemq (v, ret))) { - put_char_id_table (c, Fcons (character, ret), - Vcharacter_variant_table); + put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + make_char (c), Fcons (character, ret)); } } seq = make_vector (1, v); @@ -2845,16 +3239,22 @@ Store CHARACTER's ATTRIBUTE with VALUE. Lisp_Object ret; Emchar c; + CHECK_CHAR (character); 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))) + ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c); + if (!CONSP (ret)) + { + put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + make_char (c), Fcons (character, Qnil)); + } + else if (NILP (Fmemq (character, ret))) { - put_char_id_table (c, Fcons (character, ret), - Vcharacter_variant_table); + put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + make_char (c), Fcons (character, ret)); } #if 0 if (EQ (attribute, Q_ucs)) @@ -2870,8 +3270,11 @@ Store CHARACTER's ATTRIBUTE with VALUE. { table = make_char_id_table (Qunbound); Fputhash (attribute, table, Vchar_attribute_hash_table); +#ifdef HAVE_DATABASE + XCHAR_TABLE_NAME (table) = attribute; +#endif } - put_char_id_table (XCHAR (character), value, table); + put_char_id_table (XCHAR_TABLE(table), character, value); return value; } } @@ -2896,13 +3299,213 @@ Remove CHARACTER's ATTRIBUTE. Qunbound); if (!UNBOUNDP (table)) { - put_char_id_table (XCHAR (character), Qunbound, table); + put_char_id_table (XCHAR_TABLE(table), character, Qunbound); return Qt; } } return Qnil; } +Lisp_Object +char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute, + int writing_mode) +{ + Lisp_Object db_dir = Vexec_directory; + + if (NILP (db_dir)) + db_dir = build_string ("../lib-src"); + + db_dir = Fexpand_file_name (build_string ("char-db"), db_dir); + if (writing_mode && NILP (Ffile_exists_p (db_dir))) + Fmake_directory_internal (db_dir); + + db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir); + if (writing_mode && NILP (Ffile_exists_p (db_dir))) + Fmake_directory_internal (db_dir); + + { + Lisp_Object attribute_name = Fsymbol_name (attribute); + Lisp_Object dest = Qnil, ret; + int base = 0; + struct gcpro gcpro1, gcpro2; + int len = XSTRING_CHAR_LENGTH (attribute_name); + int i; + + GCPRO2 (dest, ret); + for (i = 0; i < len; i++) + { + Emchar c = string_char (XSTRING (attribute_name), i); + + if ( (c == '/') || (c == '%') ) + { + char str[4]; + + sprintf (str, "%%%02X", c); + dest = concat3 (dest, + Fsubstring (attribute_name, + make_int (base), make_int (i)), + build_string (str)); + base = i + 1; + } + } + ret = Fsubstring (attribute_name, make_int (base), make_int (len)); + dest = concat2 (dest, ret); + UNGCPRO; + return Fexpand_file_name (dest, db_dir); + } +#if 0 + return Fexpand_file_name (Fsymbol_name (attribute), db_dir); +#endif +} + +DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /* +Save values of ATTRIBUTE into database file. +*/ + (attribute)) +{ +#ifdef HAVE_DATABASE + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, Qunbound); + Lisp_Char_Table *ct; + Lisp_Object db; + Lisp_Object db_file; + + if (CHAR_TABLEP (table)) + ct = XCHAR_TABLE (table); + else + return Qnil; + + db_file = char_attribute_system_db_file (Qsystem_char_id, attribute, 1); + db = Fopen_database (db_file, Qnil, Qnil, Qnil, Qnil); + if (!NILP (db)) + { + if (UINT8_BYTE_TABLE_P (ct->table)) + save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db, 0, 3); + else if (UINT16_BYTE_TABLE_P (ct->table)) + save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db, 0, 3); + else if (BYTE_TABLE_P (ct->table)) + save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3); + Fclose_database (db); + return Qt; + } + else + return Qnil; +#else + return Qnil; +#endif +} + +DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /* +Reset values of ATTRIBUTE with database file. +*/ + (attribute)) +{ +#ifdef HAVE_DATABASE + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, Qunbound); + Lisp_Char_Table *ct; + Lisp_Object db_file + = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + + if (!NILP (Ffile_exists_p (db_file))) + { + if (UNBOUNDP (table)) + { + table = make_char_id_table (Qunbound); + Fputhash (attribute, table, Vchar_attribute_hash_table); + XCHAR_TABLE_NAME(table) = attribute; + } + ct = XCHAR_TABLE (table); + ct->table = Qunloaded; + XCHAR_TABLE_UNLOADED(table) = 1; + return Qt; + } +#endif + return Qnil; +} + +#ifdef HAVE_DATABASE +Lisp_Object +load_char_attribute_maybe (Emchar ch, Lisp_Object attribute) +{ + Lisp_Object db; + Lisp_Object db_file + = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + + db = Fopen_database (db_file, Qnil, Qnil, Qnil, Qnil); + if (!NILP (db)) + { + Lisp_Object val + = Fget_database (Fprin1_to_string (make_char (ch), Qnil), + db, Qunbound); + if (!UNBOUNDP (val)) + val = Fread (val); + else + val = Qunbound; + Fclose_database (db); + return val; + } + else + return Qunbound; +} + +Lisp_Char_Table* char_attribute_table_to_load; + +Lisp_Object Qload_char_attribute_table_map_function; + +DEFUN ("load-char-attribute-table-map-function", + Fload_char_attribute_table_map_function, 2, 2, 0, /* +For internal use. Don't use it. +*/ + (key, value)) +{ + Lisp_Object c = Fread (key); + Emchar code = XCHAR (c); + Lisp_Object ret = get_char_id_table (char_attribute_table_to_load, code); + + if (EQ (ret, Qunloaded)) + put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value)); + return Qnil; +} +#endif + +DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /* +Load values of ATTRIBUTE into database file. +*/ + (attribute)) +{ +#ifdef HAVE_DATABASE + Lisp_Object db; + Lisp_Object db_file + = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + + db = Fopen_database (db_file, Qnil, Qnil, Qnil, Qnil); + if (!NILP (db)) + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + struct gcpro gcpro1, gcpro2; + + if (CHAR_TABLEP (table)) + char_attribute_table_to_load = XCHAR_TABLE (table); + else + { + Fclose_database (db); + return Qnil; + } + GCPRO2 (db, table); + Fmap_database (Qload_char_attribute_table_map_function, db); + UNGCPRO; + Fclose_database (db); + XCHAR_TABLE_UNLOADED(table) = 0; + return Qt; + } + else + return Qnil; +#endif +} + DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /* Map FUNCTION over entries in ATTRIBUTE, calling it with two args, each key and value in the table. @@ -2914,7 +3517,7 @@ the entire table. (function, attribute, range)) { Lisp_Object ccs; - Lisp_Char_ID_Table *ct; + Lisp_Char_Table *ct; struct slow_map_char_table_arg slarg; struct gcpro gcpro1, gcpro2; struct chartab_range rainj; @@ -2923,8 +3526,8 @@ the entire table. { Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); - if (CHAR_ID_TABLE_P (encoding_table)) - ct = XCHAR_ID_TABLE (encoding_table); + if (CHAR_TABLEP (encoding_table)) + ct = XCHAR_TABLE (encoding_table); else return Qnil; } @@ -2933,26 +3536,27 @@ the entire table. Lisp_Object table = Fgethash (attribute, Vchar_attribute_hash_table, Qunbound); - if (CHAR_ID_TABLE_P (table)) - ct = XCHAR_ID_TABLE (table); + if (CHAR_TABLEP (table)) + ct = XCHAR_TABLE (table); else return Qnil; } if (NILP (range)) range = Qt; decode_char_table_range (range, &rainj); +#ifdef HAVE_DATABASE + if (CHAR_TABLE_UNLOADED(ct)) + Fload_char_attribute_table (attribute); +#endif slarg.function = function; slarg.retval = Qnil; GCPRO2 (slarg.function, slarg.retval); - map_char_id_table (ct, &rainj, slow_map_char_table_fun, &slarg); + map_char_table (ct, &rainj, slow_map_char_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. */ @@ -2973,13 +3577,14 @@ Store character's ATTRIBUTES. signal_simple_error ("Invalid argument", attributes); if (!NILP (ccs = Ffind_charset (Fcar (cell))) && ((XCHARSET_FINAL (ccs) != 0) || - (XCHARSET_UCS_MAX (ccs) > 0)) ) + (XCHARSET_MAX_CODE (ccs) > 0) || + (EQ (ccs, Vcharset_chinese_big5))) ) { cell = Fcdr (cell); if (CONSP (cell)) character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); else - character = Fdecode_char (ccs, cell); + character = Fdecode_char (ccs, cell, Qnil); if (!NILP (character)) goto setup_attributes; } @@ -3038,7 +3643,7 @@ Retrieve the character of the given ATTRIBUTES. if (CONSP (cell)) return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); else - return Fdecode_char (ccs, cell); + return Fdecode_char (ccs, cell, Qnil); } rest = Fcdr (rest); } @@ -3200,7 +3805,7 @@ check_category_table (Lisp_Object object, Lisp_Object default_) int check_category_char (Emchar ch, Lisp_Object table, - unsigned int designator, unsigned int not) + unsigned int designator, unsigned int not_p) { REGISTER Lisp_Object temp; Lisp_Char_Table *ctbl; @@ -3211,10 +3816,10 @@ check_category_char (Emchar ch, Lisp_Object table, ctbl = XCHAR_TABLE (table); temp = get_char_table (ch, ctbl); if (NILP (temp)) - return not; + return not_p; designator -= ' '; - return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not; + return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p; } DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /* @@ -3394,10 +3999,12 @@ syms_of_chartab (void) INIT_LRECORD_IMPLEMENTATION (uint8_byte_table); INIT_LRECORD_IMPLEMENTATION (uint16_byte_table); INIT_LRECORD_IMPLEMENTATION (byte_table); - INIT_LRECORD_IMPLEMENTATION (char_id_table); + + defsymbol (&Qsystem_char_id, "system-char-id"); defsymbol (&Qto_ucs, "=>ucs"); defsymbol (&Q_ucs, "->ucs"); + defsymbol (&Q_ucs_variants, "->ucs-variants"); defsymbol (&Q_decomposition, "->decomposition"); defsymbol (&Qcompat, "compat"); defsymbol (&Qisolated, "isolated"); @@ -3418,6 +4025,16 @@ syms_of_chartab (void) DEFSUBR (Fchar_attribute_list); DEFSUBR (Ffind_char_attribute_table); + defsymbol (&Qput_char_table_map_function, "put-char-table-map-function"); + DEFSUBR (Fput_char_table_map_function); + DEFSUBR (Fsave_char_attribute_table); + DEFSUBR (Freset_char_attribute_table); +#ifdef HAVE_DATABASE + defsymbol (&Qload_char_attribute_table_map_function, + "load-char-attribute-table-map-function"); + DEFSUBR (Fload_char_attribute_table_map_function); +#endif + DEFSUBR (Fload_char_attribute_table); DEFSUBR (Fchar_attribute_alist); DEFSUBR (Fget_char_attribute); DEFSUBR (Fput_char_attribute); @@ -3433,7 +4050,9 @@ syms_of_chartab (void) INIT_LRECORD_IMPLEMENTATION (char_table); #ifdef MULE +#ifndef UTF2000 INIT_LRECORD_IMPLEMENTATION (char_table_entry); +#endif defsymbol (&Qcategory_table_p, "category-table-p"); defsymbol (&Qcategory_designator_p, "category-designator-p"); @@ -3475,16 +4094,11 @@ 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); + Vcharacter_variant_table = make_char_id_table (Qunbound); #endif /* DO NOT staticpro this. It works just like Vweak_hash_tables. */ Vall_syntax_tables = Qnil; @@ -3509,6 +4123,11 @@ complex_vars_of_chartab (void) staticpro (&Vchar_attribute_hash_table); Vchar_attribute_hash_table = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); +#ifdef HAVE_DATABASE + Fputhash (Q_ucs_variants, Vcharacter_variant_table, + Vchar_attribute_hash_table); + XCHAR_TABLE_NAME (Vcharacter_variant_table) = Q_ucs_variants; +#endif /* HAVE_DATABASE */ #endif /* UTF2000 */ #ifdef MULE /* Set this now, so first buffer creation can refer to it. */