X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fchartab.c;h=1a22127101394a3ee43582676336b86669e5285c;hb=edb1d7f5d06e1f3ca783853fe435f41eaa32ea8e;hp=6cfecf1ad785cb978e42f28536a08a4740bc24b1;hpb=4ac7f614e1cb1ea373cb7c6db18984dff6d28f94;p=chise%2Fxemacs-chise.git- diff --git a/src/chartab.c b/src/chartab.c index 6cfecf1..1a22127 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. @@ -33,6 +34,7 @@ Boston, MA 02111-1307, USA. */ loosely based on the original Mule. Jareth Hein: fixed a couple of bugs in the implementation, and added regex support for categories with check_category_at + MORIOKA Tomohiko: Rewritten for XEmacs UTF-2000 */ #include @@ -41,11 +43,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; @@ -66,11 +65,20 @@ Lisp_Object Vword_combining_categories, Vword_separating_categories; #ifdef UTF2000 +EXFUN (Fmap_char_attribute, 3); + +#if defined(HAVE_DATABASE) +EXFUN (Fload_char_attribute_table, 1); + +Lisp_Object Vchar_db_stingy_mode; +#endif + #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 +102,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 +124,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 +201,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 +230,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,22 +265,49 @@ uint8_byte_table_same_value_p (Lisp_Object obj) } 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) +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) { + 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_unbound) + if (ct->property[i] == BT_UINT8_unloaded) + { +#if 0 + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + Lisp_Object ret = get_char_id_table (root, c); + + if (!UNBOUNDP (ret)) + { + rainj.ch = c; + 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++) - retval = (fn) (c, UINT8_DECODE (ct->property[i]), arg); + { + rainj.ch = c; + retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg); + } } else c += unit; @@ -253,11 +315,49 @@ map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, 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); + } + } + 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); @@ -280,14 +380,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; @@ -300,7 +402,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; @@ -313,7 +417,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; @@ -388,12 +494,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 @@ -414,6 +524,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; @@ -447,22 +576,49 @@ uint16_byte_table_same_value_p (Lisp_Object obj) } 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) +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) { + 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_unbound) + if (ct->property[i] == BT_UINT16_unloaded) + { +#if 0 + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + Lisp_Object ret = get_char_id_table (root, c); + + if (!UNBOUNDP (ret)) + { + rainj.ch = c; + 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++) - retval = (fn) (c, UINT16_DECODE (ct->property[i]), arg); + { + rainj.ch = c; + retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg); + } } else c += unit; @@ -470,6 +626,43 @@ map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, 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); + } + } + else + c += unit; + } +} +#endif + static Lisp_Object mark_byte_table (Lisp_Object obj) @@ -570,6 +763,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) { @@ -586,9 +810,11 @@ byte_table_same_value_p (Lisp_Object obj) } 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) +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) { int i, retval; Lisp_Object v; @@ -601,29 +827,58 @@ map_over_byte_table (Lisp_Byte_Table *ct, if (UINT8_BYTE_TABLE_P (v)) { retval - = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), - fn, arg, c, place - 1); + = 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), - fn, arg, c, place - 1); + = 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), - fn, arg, c, place - 1); + retval = map_over_byte_table (XBYTE_TABLE(v), root, + c, place - 1, fn, arg); + c += unit; + } + else if (EQ (v, Qunloaded)) + { +#if 0 + struct chartab_range rainj; + Emchar c1 = c + unit; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (; c < c1 && retval == 0; c++) + { + Lisp_Object ret = get_char_id_table (root, c); + + if (!UNBOUNDP (ret)) + { + rainj.ch = c; + 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++) - retval = (fn) (c, v, arg); + { + rainj.ch = c; + retval = (fn) (&rainj, v, arg); + } } else c += unit; @@ -631,10 +886,61 @@ map_over_byte_table (Lisp_Byte_Table *ct, 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); + } + } + else + c += unit; + } +} +#endif Lisp_Object get_byte_table (Lisp_Object table, unsigned char idx) @@ -742,181 +1048,24 @@ 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, - 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 Qsystem_char_id; +Lisp_Object Qcomposition; 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; @@ -984,33 +1133,25 @@ Return character corresponding with list. */ (list)) { - Lisp_Object table = Vcharacter_composition_table; - Lisp_Object rest = list; + Lisp_Object base, modifier; + Lisp_Object rest; - while (CONSP (rest)) + if (!CONSP (list)) + signal_simple_error ("Invalid value for composition", list); + base = Fcar (list); + rest = Fcdr (list); + while (!NILP (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); - + if (!CHARP (base)) + return Qnil; + if (!CONSP (rest)) + signal_simple_error ("Invalid value for composition", list); + modifier = Fcar (rest); 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); + base = Fcdr (Fassq (modifier, + Fget_char_attribute (base, Qcomposition, Qnil))); } - signal_simple_error ("Invalid value for composition", list); + return base; } DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /* @@ -1018,1860 +1159,2438 @@ Return variants of CHARACTER. */ (character)) { + Lisp_Object ret; + CHECK_CHAR (character); - return Fcopy_list (get_char_id_table (XCHAR (character), - Vcharacter_variant_table)); + ret = Fget_char_attribute (character, Q_ucs_variants, Qnil); + if (CONSP (ret)) + return Fcopy_list (ret); + else + return Qnil; } +#endif -/* 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; -}; + +/* A char table maps from ranges of characters to values. -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; + Implementing a general data structure that maps from arbitrary + ranges of numbers to values is tricky to do efficiently. As it + happens, it should suffice (and is usually more convenient, anyway) + when dealing with characters to restrict the sorts of ranges that + can be assigned values, as follows: - *char_attribute_list = Fcons (key, *char_attribute_list); - return 0; -} + 1) All characters. + 2) All characters in a charset. + 3) All characters in a particular row of a charset, where a "row" + means all characters with the same first byte. + 4) A particular character in a charset. -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; -} + We use char tables to generalize the 256-element vectors now + littering the Emacs code. -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); -} + Possible uses (all should be converted at some point): + 1) category tables + 2) syntax tables + 3) display tables + 4) case tables + 5) keyboard-translate-table? -/* 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; -}; + We provide an + abstract type to generalize the Emacs vectors and Mule + vectors-of-vectors goo. + */ -static int -add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value, - void *char_attribute_alist_closure) +/************************************************************************/ +/* Char Table object */ +/************************************************************************/ + +#if defined(MULE)&&!defined(UTF2000) + +static Lisp_Object +mark_char_table_entry (Lisp_Object obj) { - /* 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_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); + int i; + + for (i = 0; i < 96; i++) { - Lisp_Object *char_attribute_alist = caacl->char_attribute_alist; - *char_attribute_alist - = Fcons (Fcons (key, ret), *char_attribute_alist); + mark_object (cte->level2[i]); } - return 0; + return Qnil; } -DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /* -Return the alist of attributes of CHARACTER. -*/ - (character)) +static int +char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - Lisp_Object alist = Qnil; + Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1); + Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2); 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 < 96; i++) + if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1)) + return 0; - for (i = 0; i < countof (chlook->charset_by_leading_byte); i++) - { - Lisp_Object ccs = chlook->charset_by_leading_byte[i]; + return 1; +} - if (!NILP (ccs)) - { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); - Lisp_Object cpos; +static unsigned long +char_table_entry_hash (Lisp_Object obj, int depth) +{ + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); - 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; + return internal_array_hash (cte->level2, 96, depth); } -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)) +static const struct lrecord_description char_table_entry_description[] = { + { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 }, + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry, + mark_char_table_entry, internal_object_printer, + 0, char_table_entry_equal, + char_table_entry_hash, + char_table_entry_description, + Lisp_Char_Table_Entry); +#endif /* MULE */ + +static Lisp_Object +mark_char_table (Lisp_Object obj) { - Lisp_Object ccs; + Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 - CHECK_CHAR (character); - if (!NILP (ccs = Ffind_charset (attribute))) - { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + mark_object (ct->table); + mark_object (ct->name); + mark_object (ct->db); +#else + int i; - if (CHAR_ID_TABLE_P (encoding_table)) - return get_char_id_table (XCHAR (character), encoding_table); - } - else + for (i = 0; i < NUM_ASCII_CHARS; i++) + mark_object (ct->ascii[i]); +#ifdef MULE + 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 + carefully to avoid crashes during GC. Cf. prune_specifiers() + and prune_weak_hash_tables(). */ + +void +prune_syntax_tables (void) +{ + Lisp_Object rest, prev = Qnil; + + for (rest = Vall_syntax_tables; + !NILP (rest); + rest = XCHAR_TABLE (rest)->next_table) { - Lisp_Object table = Fgethash (attribute, - Vchar_attribute_hash_table, - Qunbound); - if (!UNBOUNDP (table)) + if (! marked_p (rest)) { - Lisp_Object ret = get_char_id_table (XCHAR (character), table); - if (!UNBOUNDP (ret)) - return ret; + /* This table is garbage. Remove it from the list. */ + if (NILP (prev)) + Vall_syntax_tables = XCHAR_TABLE (rest)->next_table; + else + XCHAR_TABLE (prev)->next_table = + XCHAR_TABLE (rest)->next_table; } } - return default_value; } -DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /* -Store CHARACTER's ATTRIBUTE with VALUE. -*/ - (character, attribute, value)) +static Lisp_Object +char_table_type_to_symbol (enum char_table_type type) { - 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 - } + switch (type) { - 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; + default: abort(); + case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; + case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; + case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; + case CHAR_TABLE_TYPE_CHAR: return Qchar; +#ifdef MULE + case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; +#endif } } - -DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /* -Remove CHARACTER's ATTRIBUTE. -*/ - (character, attribute)) + +static enum char_table_type +symbol_to_char_table_type (Lisp_Object symbol) { - Lisp_Object ccs; + CHECK_SYMBOL (symbol); - 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; + if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC; + if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX; + if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY; + if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR; +#ifdef MULE + if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY; +#endif + + signal_simple_error ("Unrecognized char table type", symbol); + return CHAR_TABLE_TYPE_GENERIC; /* not reached */ } -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)) +static void +print_chartab_range (Emchar first, Emchar last, Lisp_Object val, + Lisp_Object printcharfun) { - 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))) + if (first != last) { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); - - if (CHAR_ID_TABLE_P (encoding_table)) - ct = XCHAR_ID_TABLE (encoding_table); - else - return Qnil; + write_c_string (" (", printcharfun); + print_internal (make_char (first), printcharfun, 0); + write_c_string (" ", printcharfun); + print_internal (make_char (last), printcharfun, 0); + write_c_string (") ", printcharfun); } 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; + write_c_string (" ", printcharfun); + print_internal (make_char (first), printcharfun, 0); + write_c_string (" ", printcharfun); } - 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; + print_internal (val, printcharfun, 1); } -EXFUN (Fmake_char, 3); -EXFUN (Fdecode_char, 2); +#if defined(MULE)&&!defined(UTF2000) -DEFUN ("define-char", Fdefine_char, 1, 1, 0, /* -Store character's ATTRIBUTES. -*/ - (attributes)) +static void +print_chartab_charset_row (Lisp_Object charset, + int row, + Lisp_Char_Table_Entry *cte, + Lisp_Object printcharfun) { - Lisp_Object rest = attributes; - Lisp_Object code = Fcdr (Fassq (Qucs, attributes)); - Lisp_Object character; + int i; + Lisp_Object cat = Qunbound; + int first = -1; - if (NILP (code)) + for (i = 32; i < 128; i++) { - while (CONSP (rest)) - { - Lisp_Object cell = Fcar (rest); - Lisp_Object ccs; + Lisp_Object pam = cte->level2[i - 32]; - 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 (first == -1) + { + first = i; + cat = pam; + continue; } - if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) || - (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) ) - + + if (!EQ (cat, pam)) { - if (!INTP (code)) - signal_simple_error ("Invalid argument", attributes); + if (row == -1) + print_chartab_range (MAKE_CHAR (charset, first, 0), + MAKE_CHAR (charset, i - 1, 0), + cat, printcharfun); else - character = make_char (XINT (code) + 0x100000); - goto setup_attributes; + print_chartab_range (MAKE_CHAR (charset, row, first), + MAKE_CHAR (charset, row, i - 1), + cat, printcharfun); + first = -1; + i--; } - 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)) + if (first != -1) { - 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); + if (row == -1) + print_chartab_range (MAKE_CHAR (charset, first, 0), + MAKE_CHAR (charset, i - 1, 0), + cat, printcharfun); + else + print_chartab_range (MAKE_CHAR (charset, row, first), + MAKE_CHAR (charset, row, i - 1), + cat, printcharfun); } - return character; } -DEFUN ("find-char", Ffind_char, 1, 1, 0, /* -Retrieve the character of the given ATTRIBUTES. -*/ - (attributes)) +static void +print_chartab_two_byte_charset (Lisp_Object charset, + Lisp_Char_Table_Entry *cte, + Lisp_Object printcharfun) { - Lisp_Object rest = attributes; - Lisp_Object code; + int i; - while (CONSP (rest)) + for (i = 32; i < 128; i++) { - Lisp_Object cell = Fcar (rest); - Lisp_Object ccs; + Lisp_Object jen = cte->level2[i - 32]; - if (!LISTP (cell)) - signal_simple_error ("Invalid argument", attributes); - if (!NILP (ccs = Ffind_charset (Fcar (cell)))) + if (!CHAR_TABLE_ENTRYP (jen)) { - 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); + char buf[100]; + + write_c_string (" [", printcharfun); + print_internal (XCHARSET_NAME (charset), printcharfun, 0); + sprintf (buf, " %d] ", i); + write_c_string (buf, printcharfun); + print_internal (jen, printcharfun, 0); + } else - return make_char (XINT (code) + 0x100000); + print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen), + printcharfun); } - return Qnil; } -#endif - - -/* A char table maps from ranges of characters to values. +#endif /* MULE */ - Implementing a general data structure that maps from arbitrary - ranges of numbers to values is tricky to do efficiently. As it - happens, it should suffice (and is usually more convenient, anyway) - when dealing with characters to restrict the sorts of ranges that - can be assigned values, as follows: +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); - 1) All characters. - 2) All characters in a charset. - 3) All characters in a particular row of a charset, where a "row" - means all characters with the same first byte. - 4) A particular character in a charset. + 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]; - We use char tables to generalize the 256-element vectors now - littering the Emacs code. + sprintf (buf, "#s(char-table type %s data (", + string_data (symbol_name (XSYMBOL + (char_table_type_to_symbol (ct->type))))); + write_c_string (buf, printcharfun); - Possible uses (all should be converted at some point): + /* Now write out the ASCII/Control-1 stuff. */ + { + int i; + int first = -1; + Lisp_Object val = Qunbound; - 1) category tables - 2) syntax tables - 3) display tables - 4) case tables - 5) keyboard-translate-table? + for (i = 0; i < NUM_ASCII_CHARS; i++) + { + if (first == -1) + { + first = i; + val = ct->ascii[i]; + continue; + } - We provide an - abstract type to generalize the Emacs vectors and Mule - vectors-of-vectors goo. - */ + if (!EQ (ct->ascii[i], val)) + { + print_chartab_range (first, i - 1, val, printcharfun); + first = -1; + i--; + } + } -/************************************************************************/ -/* Char Table object */ -/************************************************************************/ + if (first != -1) + print_chartab_range (first, i - 1, val, printcharfun); + } #ifdef MULE + { + Charset_ID i; -static Lisp_Object -mark_char_table_entry (Lisp_Object obj) -{ - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); - int i; + for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; + i++) + { + Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE]; + Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i); - for (i = 0; i < 96; i++) - { - mark_object (cte->level2[i]); - } - return Qnil; + if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII + || i == LEADING_BYTE_CONTROL_1) + continue; + if (!CHAR_TABLE_ENTRYP (ann)) + { + write_c_string (" ", printcharfun); + print_internal (XCHARSET_NAME (charset), + printcharfun, 0); + write_c_string (" ", printcharfun); + print_internal (ann, printcharfun, 0); + } + else + { + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann); + if (XCHARSET_DIMENSION (charset) == 1) + print_chartab_charset_row (charset, -1, cte, printcharfun); + else + print_chartab_two_byte_charset (charset, cte, printcharfun); + } + } + } +#endif /* MULE */ +#endif /* non UTF2000 */ + + write_c_string ("))", printcharfun); } static int -char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1); - Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2); + Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1); + Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2); int i; - for (i = 0; i < 96; i++) - if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1)) + 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; + +#ifdef MULE + for (i = 0; i < NUM_LEADING_BYTES; i++) + if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1)) return 0; +#endif /* MULE */ +#endif /* non UTF2000 */ return 1; } static unsigned long -char_table_entry_hash (Lisp_Object obj, int depth) +char_table_hash (Lisp_Object obj, int depth) { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); - - return internal_array_hash (cte->level2, 96, 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 + hashval = HASH2 (hashval, + internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth)); +#endif /* MULE */ + return hashval; +#endif } -static const struct lrecord_description char_table_entry_description[] = { - { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 }, +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) }, + { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) }, +#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 } }; -DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry, - mark_char_table_entry, internal_object_printer, - 0, char_table_entry_equal, - char_table_entry_hash, - char_table_entry_description, - Lisp_Char_Table_Entry); -#endif /* MULE */ +DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table, + mark_char_table, print_char_table, 0, + char_table_equal, char_table_hash, + char_table_description, + Lisp_Char_Table); -static Lisp_Object -mark_char_table (Lisp_Object obj) +DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /* +Return non-nil if OBJECT is a char table. + +A char table is a table that maps characters (or ranges of characters) +to values. Char tables are specialized for characters, only allowing +particular sorts of ranges to be assigned values. Although this +loses in generality, it makes for extremely fast (constant-time) +lookups, and thus is feasible for applications that do an extremely +large number of lookups (e.g. scanning a buffer for a character in +a particular syntax, where a lookup in the syntax table must occur +once per character). + +When Mule support exists, the types of ranges that can be assigned +values are + +-- all characters +-- an entire charset +-- a single row in a two-octet charset +-- a single character + +When Mule support is not present, the types of ranges that can be +assigned values are + +-- all characters +-- a single character + +To create a char table, use `make-char-table'. +To modify a char table, use `put-char-table' or `remove-char-table'. +To retrieve the value for a particular character, use `get-char-table'. +See also `map-char-table', `clear-char-table', `copy-char-table', +`valid-char-table-type-p', `char-table-type-list', +`valid-char-table-value-p', and `check-char-table-value'. +*/ + (object)) { - Lisp_Char_Table *ct = XCHAR_TABLE (obj); - int i; + return CHAR_TABLEP (object) ? Qt : Qnil; +} - for (i = 0; i < NUM_ASCII_CHARS; i++) - mark_object (ct->ascii[i]); +DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /* +Return a list of the recognized char table types. +See `valid-char-table-type-p'. +*/ + ()) +{ #ifdef MULE - for (i = 0; i < NUM_LEADING_BYTES; i++) - mark_object (ct->level1[i]); + return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax); +#else + return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax); #endif - return ct->mirror_table; } -/* WARNING: All functions of this nature need to be written extremely - carefully to avoid crashes during GC. Cf. prune_specifiers() - and prune_weak_hash_tables(). */ - -void -prune_syntax_tables (void) +DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /* +Return t if TYPE if a recognized char table type. + +Each char table type is used for a different purpose and allows different +sorts of values. The different char table types are + +`category' + Used for category tables, which specify the regexp categories + that a character is in. The valid values are nil or a + bit vector of 95 elements. Higher-level Lisp functions are + provided for working with category tables. Currently categories + and category tables only exist when Mule support is present. +`char' + A generalized char table, for mapping from one character to + another. Used for case tables, syntax matching tables, + `keyboard-translate-table', etc. The valid values are characters. +`generic' + An even more generalized char table, for mapping from a + character to anything. +`display' + Used for display tables, which specify how a particular character + is to appear when displayed. #### Not yet implemented. +`syntax' + Used for syntax tables, which specify the syntax of a particular + character. Higher-level Lisp functions are provided for + working with syntax tables. The valid values are integers. + +*/ + (type)) { - Lisp_Object rest, prev = Qnil; + return (EQ (type, Qchar) || +#ifdef MULE + EQ (type, Qcategory) || +#endif + EQ (type, Qdisplay) || + EQ (type, Qgeneric) || + EQ (type, Qsyntax)) ? Qt : Qnil; +} - for (rest = Vall_syntax_tables; - !NILP (rest); - rest = XCHAR_TABLE (rest)->next_table) - { - if (! marked_p (rest)) - { - /* This table is garbage. Remove it from the list. */ - if (NILP (prev)) - Vall_syntax_tables = XCHAR_TABLE (rest)->next_table; - else - XCHAR_TABLE (prev)->next_table = - XCHAR_TABLE (rest)->next_table; - } - } +DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /* +Return the type of CHAR-TABLE. +See `valid-char-table-type-p'. +*/ + (char_table)) +{ + CHECK_CHAR_TABLE (char_table); + return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type); } -static Lisp_Object -char_table_type_to_symbol (enum char_table_type type) +void +fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) { - switch (type) - { - default: abort(); - case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; - case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; - case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; - case CHAR_TABLE_TYPE_CHAR: return Qchar; +#ifdef UTF2000 + ct->table = Qunbound; + ct->default_value = value; + ct->unloaded = 0; +#else + int i; + + for (i = 0; i < NUM_ASCII_CHARS; i++) + ct->ascii[i] = value; #ifdef MULE - case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; + 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 - } } -static enum char_table_type -symbol_to_char_table_type (Lisp_Object symbol) +DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /* +Reset CHAR-TABLE to its default state. +*/ + (char_table)) { - CHECK_SYMBOL (symbol); + Lisp_Char_Table *ct; - if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC; - if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX; - if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY; - if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR; + CHECK_CHAR_TABLE (char_table); + ct = XCHAR_TABLE (char_table); + + switch (ct->type) + { + case CHAR_TABLE_TYPE_CHAR: + fill_char_table (ct, make_char (0)); + break; + case CHAR_TABLE_TYPE_DISPLAY: + case CHAR_TABLE_TYPE_GENERIC: #ifdef MULE - if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY; -#endif + case CHAR_TABLE_TYPE_CATEGORY: +#endif /* MULE */ + fill_char_table (ct, Qnil); + break; - signal_simple_error ("Unrecognized char table type", symbol); - return CHAR_TABLE_TYPE_GENERIC; /* not reached */ + case CHAR_TABLE_TYPE_SYNTAX: + fill_char_table (ct, make_int (Sinherit)); + break; + + default: + abort (); + } + + return Qnil; } -static void -print_chartab_range (Emchar first, Emchar last, Lisp_Object val, - Lisp_Object printcharfun) +DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /* +Return a new, empty char table of type TYPE. +Currently recognized types are 'char, 'category, 'display, 'generic, +and 'syntax. See `valid-char-table-type-p'. +*/ + (type)) { - if (first != last) + Lisp_Char_Table *ct; + Lisp_Object obj; + enum char_table_type ty = symbol_to_char_table_type (type); + + ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); + ct->type = ty; +#ifndef UTF2000 + if (ty == CHAR_TABLE_TYPE_SYNTAX) { - write_c_string (" (", printcharfun); - print_internal (make_char (first), printcharfun, 0); - write_c_string (" ", printcharfun); - print_internal (make_char (last), printcharfun, 0); - write_c_string (") ", printcharfun); + ct->mirror_table = Fmake_char_table (Qgeneric); + fill_char_table (XCHAR_TABLE (ct->mirror_table), + make_int (Spunct)); } else + ct->mirror_table = Qnil; +#else + ct->name = Qnil; + ct->db = Qnil; +#endif + ct->next_table = Qnil; + XSETCHAR_TABLE (obj, ct); + if (ty == CHAR_TABLE_TYPE_SYNTAX) { - write_c_string (" ", printcharfun); - print_internal (make_char (first), printcharfun, 0); - write_c_string (" ", printcharfun); + ct->next_table = Vall_syntax_tables; + Vall_syntax_tables = obj; } - print_internal (val, printcharfun, 1); + Freset_char_table (obj); + return obj; } -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) -static void -print_chartab_charset_row (Lisp_Object charset, - int row, - Lisp_Char_Table_Entry *cte, - Lisp_Object printcharfun) +static Lisp_Object +make_char_table_entry (Lisp_Object initval) { + Lisp_Object obj; int i; - Lisp_Object cat = Qunbound; - int first = -1; - - for (i = 32; i < 128; i++) - { - Lisp_Object pam = cte->level2[i - 32]; - - if (first == -1) - { - first = i; - cat = pam; - continue; - } + Lisp_Char_Table_Entry *cte = + alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); - if (!EQ (cat, pam)) - { - if (row == -1) - print_chartab_range (MAKE_CHAR (charset, first, 0), - MAKE_CHAR (charset, i - 1, 0), - cat, printcharfun); - else - print_chartab_range (MAKE_CHAR (charset, row, first), - MAKE_CHAR (charset, row, i - 1), - cat, printcharfun); - first = -1; - i--; - } - } + for (i = 0; i < 96; i++) + cte->level2[i] = initval; - if (first != -1) - { - if (row == -1) - print_chartab_range (MAKE_CHAR (charset, first, 0), - MAKE_CHAR (charset, i - 1, 0), - cat, printcharfun); - else - print_chartab_range (MAKE_CHAR (charset, row, first), - MAKE_CHAR (charset, row, i - 1), - cat, printcharfun); - } + XSETCHAR_TABLE_ENTRY (obj, cte); + return obj; } -static void -print_chartab_two_byte_charset (Lisp_Object charset, - Lisp_Char_Table_Entry *cte, - Lisp_Object printcharfun) +static Lisp_Object +copy_char_table_entry (Lisp_Object entry) { + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry); + Lisp_Object obj; int i; + Lisp_Char_Table_Entry *ctenew = + alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); - for (i = 32; i < 128; i++) + for (i = 0; i < 96; i++) { - Lisp_Object jen = cte->level2[i - 32]; - - if (!CHAR_TABLE_ENTRYP (jen)) - { - char buf[100]; - - write_c_string (" [", printcharfun); - print_internal (XCHARSET_NAME (charset), printcharfun, 0); - sprintf (buf, " %d] ", i); - write_c_string (buf, printcharfun); - print_internal (jen, printcharfun, 0); - } + Lisp_Object new = cte->level2[i]; + if (CHAR_TABLE_ENTRYP (new)) + ctenew->level2[i] = copy_char_table_entry (new); else - print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen), - printcharfun); + ctenew->level2[i] = new; } + + XSETCHAR_TABLE_ENTRY (obj, ctenew); + return obj; } #endif /* MULE */ -static void -print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) -{ - Lisp_Char_Table *ct = XCHAR_TABLE (obj); - char buf[200]; - - sprintf (buf, "#s(char-table type %s data (", - string_data (symbol_name (XSYMBOL - (char_table_type_to_symbol (ct->type))))); - write_c_string (buf, printcharfun); - - /* Now write out the ASCII/Control-1 stuff. */ - { - int i; - int first = -1; - Lisp_Object val = Qunbound; +DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /* +Return a new char table which is a copy of CHAR-TABLE. +It will contain the same values for the same characters and ranges +as CHAR-TABLE. The values will not themselves be copied. +*/ + (char_table)) +{ + Lisp_Char_Table *ct, *ctnew; + Lisp_Object obj; +#ifndef UTF2000 + int i; +#endif - for (i = 0; i < NUM_ASCII_CHARS; i++) - { - if (first == -1) - { - first = i; - val = ct->ascii[i]; - continue; - } + 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; + ctnew->db = ct->db; - if (!EQ (ct->ascii[i], val)) - { - print_chartab_range (first, i - 1, val, printcharfun); - first = -1; - i--; - } - } + 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 */ - if (first != -1) - print_chartab_range (first, i - 1, val, printcharfun); - } + for (i = 0; i < NUM_ASCII_CHARS; i++) + { + Lisp_Object new = ct->ascii[i]; +#ifdef MULE + assert (! (CHAR_TABLE_ENTRYP (new))); +#endif /* MULE */ + ctnew->ascii[i] = new; + } #ifdef MULE - { - Charset_ID i; - for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; - i++) - { - Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE]; - Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i); + for (i = 0; i < NUM_LEADING_BYTES; i++) + { + Lisp_Object new = ct->level1[i]; + if (CHAR_TABLE_ENTRYP (new)) + ctnew->level1[i] = copy_char_table_entry (new); + else + ctnew->level1[i] = new; + } - if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII - || i == LEADING_BYTE_CONTROL_1) - continue; - if (!CHAR_TABLE_ENTRYP (ann)) - { - write_c_string (" ", printcharfun); - print_internal (XCHARSET_NAME (charset), - printcharfun, 0); - write_c_string (" ", printcharfun); - print_internal (ann, printcharfun, 0); - } - else - { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann); - if (XCHARSET_DIMENSION (charset) == 1) - print_chartab_charset_row (charset, -1, cte, printcharfun); - else - print_chartab_two_byte_charset (charset, cte, printcharfun); - } - } - } #endif /* MULE */ +#endif /* non UTF2000 */ - write_c_string ("))", printcharfun); +#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) + { + ctnew->next_table = Vall_syntax_tables; + Vall_syntax_tables = obj; + } + return obj; } -static int -char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs); +INLINE_HEADER int +XCHARSET_CELL_RANGE (Lisp_Object ccs) { - Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1); - Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2); - int i; + 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; + } +} - if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2)) - 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; + outrange->ch = XCHAR_OR_CHAR_INT (range); + } +#ifndef MULE + else + signal_simple_error ("Range must be t or a character", range); +#else /* MULE */ + else if (VECTORP (range)) + { + Lisp_Vector *vec = XVECTOR (range); + Lisp_Object *elts = vector_data (vec); + int cell_min, cell_max; - for (i = 0; i < NUM_ASCII_CHARS; i++) - if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1)) - return 0; + 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) + signal_simple_error ("Charset in row vector must be multi-byte", + outrange->charset); + else + { + int ret = XCHARSET_CELL_RANGE (outrange->charset); -#ifdef MULE - for (i = 0; i < NUM_LEADING_BYTES; i++) - if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1)) - return 0; + 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 + abort (); + } + else + { + if (!CHARSETP (range) && !SYMBOLP (range)) + signal_simple_error + ("Char table range must be t, charset, char, or vector", range); + outrange->type = CHARTAB_RANGE_CHARSET; + outrange->charset = Fget_charset (range); + } #endif /* MULE */ - - return 1; } -static unsigned long -char_table_hash (Lisp_Object obj, int depth) +#if defined(MULE)&&!defined(UTF2000) + +/* called from CHAR_TABLE_VALUE(). */ +Lisp_Object +get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte, + Emchar c) { - Lisp_Char_Table *ct = XCHAR_TABLE (obj); - unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS, - depth); -#ifdef MULE - hashval = HASH2 (hashval, - internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth)); -#endif /* MULE */ - return hashval; -} + Lisp_Object val; +#ifdef UTF2000 + Lisp_Object charset; +#else + Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte); +#endif + int byte1, byte2; -static const struct lrecord_description char_table_description[] = { - { 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 }, +#ifdef UTF2000 + BREAKUP_CHAR (c, charset, byte1, byte2); +#else + BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2); #endif - { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) }, - { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) }, - { XD_END } -}; + val = ct->level1[leading_byte - MIN_LEADING_BYTE]; + if (CHAR_TABLE_ENTRYP (val)) + { + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); + val = cte->level2[byte1 - 32]; + if (CHAR_TABLE_ENTRYP (val)) + { + cte = XCHAR_TABLE_ENTRY (val); + assert (byte2 >= 32); + val = cte->level2[byte2 - 32]; + assert (!CHAR_TABLE_ENTRYP (val)); + } + } -DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table, - mark_char_table, print_char_table, 0, - char_table_equal, char_table_hash, - char_table_description, - Lisp_Char_Table); + return val; +} -DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /* -Return non-nil if OBJECT is a char table. +#endif /* MULE */ -A char table is a table that maps characters (or ranges of characters) -to values. Char tables are specialized for characters, only allowing -particular sorts of ranges to be assigned values. Although this -loses in generality, it makes for extremely fast (constant-time) -lookups, and thus is feasible for applications that do an extremely -large number of lookups (e.g. scanning a buffer for a character in -a particular syntax, where a lookup in the syntax table must occur -once per character). +Lisp_Object +get_char_table (Emchar ch, Lisp_Char_Table *ct) +{ +#ifdef UTF2000 + return get_char_id_table (ct, ch); +#elif defined(MULE) + { + Lisp_Object charset; + int byte1, byte2; + Lisp_Object val; -When Mule support exists, the types of ranges that can be assigned -values are + BREAKUP_CHAR (ch, charset, byte1, byte2); --- all characters --- an entire charset --- a single row in a two-octet charset --- a single character + if (EQ (charset, Vcharset_ascii)) + val = ct->ascii[byte1]; + else if (EQ (charset, Vcharset_control_1)) + val = ct->ascii[byte1 + 128]; + else + { + int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; + val = ct->level1[lb]; + if (CHAR_TABLE_ENTRYP (val)) + { + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); + val = cte->level2[byte1 - 32]; + if (CHAR_TABLE_ENTRYP (val)) + { + cte = XCHAR_TABLE_ENTRY (val); + assert (byte2 >= 32); + val = cte->level2[byte2 - 32]; + assert (!CHAR_TABLE_ENTRYP (val)); + } + } + } -When Mule support is not present, the types of ranges that can be -assigned values are + return val; + } +#else /* not MULE */ + return ct->ascii[(unsigned char)ch]; +#endif /* not MULE */ +} --- all characters --- a single character -To create a char table, use `make-char-table'. -To modify a char table, use `put-char-table' or `remove-char-table'. -To retrieve the value for a particular character, use `get-char-table'. -See also `map-char-table', `clear-char-table', `copy-char-table', -`valid-char-table-type-p', `char-table-type-list', -`valid-char-table-value-p', and `check-char-table-value'. +DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /* +Find value for CHARACTER in CHAR-TABLE. */ - (object)) + (character, char_table)) { - return CHAR_TABLEP (object) ? Qt : Qnil; + CHECK_CHAR_TABLE (char_table); + CHECK_CHAR_COERCE_INT (character); + + return get_char_table (XCHAR (character), XCHAR_TABLE (char_table)); } -DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /* -Return a list of the recognized char table types. -See `valid-char-table-type-p'. +DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /* +Find value for a range in CHAR-TABLE. +If there is more than one value, return MULTI (defaults to nil). */ - ()) + (range, char_table, multi)) { -#ifdef MULE - return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax); -#else - return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax); -#endif -} + Lisp_Char_Table *ct; + struct chartab_range rainj; -DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /* -Return t if TYPE if a recognized char table type. + if (CHAR_OR_CHAR_INTP (range)) + return Fget_char_table (range, char_table); + CHECK_CHAR_TABLE (char_table); + ct = XCHAR_TABLE (char_table); -Each char table type is used for a different purpose and allows different -sorts of values. The different char table types are + decode_char_table_range (range, &rainj); + switch (rainj.type) + { + 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]; -`category' - Used for category tables, which specify the regexp categories - that a character is in. The valid values are nil or a - bit vector of 95 elements. Higher-level Lisp functions are - provided for working with category tables. Currently categories - and category tables only exist when Mule support is present. -`char' - A generalized char table, for mapping from one character to - another. Used for case tables, syntax matching tables, - `keyboard-translate-table', etc. The valid values are characters. -`generic' - An even more generalized char table, for mapping from a - character to anything. -`display' - Used for display tables, which specify how a particular character - is to appear when displayed. #### Not yet implemented. -`syntax' - Used for syntax tables, which specify the syntax of a particular - character. Higher-level Lisp functions are provided for - working with syntax tables. The valid values are integers. + for (i = 1; i < NUM_ASCII_CHARS; i++) + if (!EQ (first, ct->ascii[i])) + return multi; -*/ - (type)) -{ - return (EQ (type, Qchar) || #ifdef MULE - EQ (type, Qcategory) || -#endif - EQ (type, Qdisplay) || - EQ (type, Qgeneric) || - EQ (type, Qsyntax)) ? Qt : Qnil; -} - -DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /* -Return the type of CHAR-TABLE. -See `valid-char-table-type-p'. -*/ - (char_table)) -{ - CHECK_CHAR_TABLE (char_table); - return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type); -} + for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; + i++) + { + if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i)) + || i == LEADING_BYTE_ASCII + || i == LEADING_BYTE_CONTROL_1) + continue; + if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE])) + return multi; + } +#endif /* MULE */ -void -fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) -{ - int i; + return first; +#endif /* non UTF2000 */ + } - for (i = 0; i < NUM_ASCII_CHARS; i++) - ct->ascii[i] = value; #ifdef MULE - for (i = 0; i < NUM_LEADING_BYTES; i++) - ct->level1[i] = value; -#endif /* MULE */ + case CHARTAB_RANGE_CHARSET: +#ifdef UTF2000 + return multi; +#else + if (EQ (rainj.charset, Vcharset_ascii)) + { + int i; + Lisp_Object first = ct->ascii[0]; - if (ct->type == CHAR_TABLE_TYPE_SYNTAX) - update_syntax_table (ct); -} + for (i = 1; i < 128; i++) + if (!EQ (first, ct->ascii[i])) + return multi; + return first; + } -DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /* -Reset CHAR-TABLE to its default state. -*/ - (char_table)) -{ - Lisp_Char_Table *ct; + if (EQ (rainj.charset, Vcharset_control_1)) + { + int i; + Lisp_Object first = ct->ascii[128]; - CHECK_CHAR_TABLE (char_table); - ct = XCHAR_TABLE (char_table); + for (i = 129; i < 160; i++) + if (!EQ (first, ct->ascii[i])) + return multi; + return first; + } + + { + Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - + MIN_LEADING_BYTE]; + if (CHAR_TABLE_ENTRYP (val)) + 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]; + if (!CHAR_TABLE_ENTRYP (val)) + return val; + val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32]; + if (CHAR_TABLE_ENTRYP (val)) + return multi; + return val; + } +#endif /* not UTF2000 */ +#endif /* not MULE */ + + default: + abort (); + } + + return Qnil; /* not reached */ +} - switch (ct->type) +static int +check_valid_char_table_value (Lisp_Object value, enum char_table_type type, + Error_behavior errb) +{ + switch (type) { - case CHAR_TABLE_TYPE_CHAR: - fill_char_table (ct, make_char (0)); + case CHAR_TABLE_TYPE_SYNTAX: + if (!ERRB_EQ (errb, ERROR_ME)) + return INTP (value) || (CONSP (value) && INTP (XCAR (value)) + && CHAR_OR_CHAR_INTP (XCDR (value))); + if (CONSP (value)) + { + Lisp_Object cdr = XCDR (value); + CHECK_INT (XCAR (value)); + CHECK_CHAR_COERCE_INT (cdr); + } + else + CHECK_INT (value); break; - case CHAR_TABLE_TYPE_DISPLAY: - case CHAR_TABLE_TYPE_GENERIC: + #ifdef MULE case CHAR_TABLE_TYPE_CATEGORY: -#endif /* MULE */ - fill_char_table (ct, Qnil); + if (!ERRB_EQ (errb, ERROR_ME)) + return CATEGORY_TABLE_VALUEP (value); + CHECK_CATEGORY_TABLE_VALUE (value); break; +#endif /* MULE */ - case CHAR_TABLE_TYPE_SYNTAX: - fill_char_table (ct, make_int (Sinherit)); + case CHAR_TABLE_TYPE_GENERIC: + return 1; + + case CHAR_TABLE_TYPE_DISPLAY: + /* #### fix this */ + maybe_signal_simple_error ("Display char tables not yet implemented", + value, Qchar_table, errb); + return 0; + + case CHAR_TABLE_TYPE_CHAR: + if (!ERRB_EQ (errb, ERROR_ME)) + return CHAR_OR_CHAR_INTP (value); + CHECK_CHAR_COERCE_INT (value); break; default: abort (); } - return Qnil; + return 0; /* not reached */ } -DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /* -Return a new, empty char table of type TYPE. -Currently recognized types are 'char, 'category, 'display, 'generic, -and 'syntax. See `valid-char-table-type-p'. -*/ - (type)) +static Lisp_Object +canonicalize_char_table_value (Lisp_Object value, enum char_table_type type) { - Lisp_Char_Table *ct; - Lisp_Object obj; - enum char_table_type ty = symbol_to_char_table_type (type); - - ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); - ct->type = ty; - if (ty == CHAR_TABLE_TYPE_SYNTAX) - { - ct->mirror_table = Fmake_char_table (Qgeneric); - fill_char_table (XCHAR_TABLE (ct->mirror_table), - make_int (Spunct)); - } - else - ct->mirror_table = Qnil; - ct->next_table = Qnil; - XSETCHAR_TABLE (obj, ct); - if (ty == CHAR_TABLE_TYPE_SYNTAX) + switch (type) { - ct->next_table = Vall_syntax_tables; - Vall_syntax_tables = obj; + case CHAR_TABLE_TYPE_SYNTAX: + if (CONSP (value)) + { + Lisp_Object car = XCAR (value); + Lisp_Object cdr = XCDR (value); + CHECK_CHAR_COERCE_INT (cdr); + return Fcons (car, cdr); + } + break; + case CHAR_TABLE_TYPE_CHAR: + CHECK_CHAR_COERCE_INT (value); + break; + default: + break; } - Freset_char_table (obj); - return obj; + return value; } -#ifdef MULE - -static Lisp_Object -make_char_table_entry (Lisp_Object initval) +DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /* +Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE. +*/ + (value, char_table_type)) { - Lisp_Object obj; - int i; - Lisp_Char_Table_Entry *cte = - alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); + enum char_table_type type = symbol_to_char_table_type (char_table_type); - for (i = 0; i < 96; i++) - cte->level2[i] = initval; + return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil; +} - XSETCHAR_TABLE_ENTRY (obj, cte); - return obj; +DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /* +Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE. +*/ + (value, char_table_type)) +{ + enum char_table_type type = symbol_to_char_table_type (char_table_type); + + check_valid_char_table_value (value, type, ERROR_ME); + return Qnil; } -static Lisp_Object -copy_char_table_entry (Lisp_Object entry) +#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)) { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry); - Lisp_Object obj; - int i; - Lisp_Char_Table_Entry *ctenew = - alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); + put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put); + return Qnil; +} +#endif - for (i = 0; i < 96; i++) +/* Assign VAL to all characters in RANGE in char table CT. */ + +void +put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, + Lisp_Object val) +{ + switch (range->type) { - Lisp_Object new = cte->level2[i]; - if (CHAR_TABLE_ENTRYP (new)) - ctenew->level2[i] = copy_char_table_entry (new); + 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; + for (i = 0; i < 128; i++) + ct->ascii[i] = val; + } + else if (EQ (range->charset, Vcharset_control_1)) + { + int i; + for (i = 128; i < 160; i++) + ct->ascii[i] = val; + } else - ctenew->level2[i] = new; + { + int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; + ct->level1[lb] = val; + } +#endif + break; + + 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; + /* make sure that there is a separate entry for the row. */ + if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) + ct->level1[lb] = make_char_table_entry (ct->level1[lb]); + cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); + cte->level2[range->row - 32] = val; + } +#endif /* not UTF2000 */ + break; +#endif /* MULE */ + + case CHARTAB_RANGE_CHAR: +#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; + + BREAKUP_CHAR (range->ch, charset, byte1, byte2); + if (EQ (charset, Vcharset_ascii)) + ct->ascii[byte1] = val; + else if (EQ (charset, Vcharset_control_1)) + ct->ascii[byte1 + 128] = val; + else + { + Lisp_Char_Table_Entry *cte; + int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; + /* make sure that there is a separate entry for the row. */ + if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) + ct->level1[lb] = make_char_table_entry (ct->level1[lb]); + cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); + /* now CTE is a char table entry for the charset; + each entry is for a single row (or character of + a one-octet charset). */ + if (XCHARSET_DIMENSION (charset) == 1) + cte->level2[byte1 - 32] = val; + else + { + /* assigning to one character in a two-octet charset. */ + /* make sure that the charset row contains a separate + entry for each character. */ + if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32])) + cte->level2[byte1 - 32] = + make_char_table_entry (cte->level2[byte1 - 32]); + cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]); + cte->level2[byte2 - 32] = val; + } + } + } +#else /* not MULE */ + ct->ascii[(unsigned char) (range->ch)] = val; + break; +#endif /* not MULE */ } - XSETCHAR_TABLE_ENTRY (obj, ctenew); - return obj; +#ifndef UTF2000 + if (ct->type == CHAR_TABLE_TYPE_SYNTAX) + update_syntax_table (ct); +#endif } -#endif /* MULE */ +DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /* +Set the value for chars in RANGE to be VALUE in CHAR-TABLE. -DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /* -Return a new char table which is a copy of CHAR-TABLE. -It will contain the same values for the same characters and ranges -as CHAR-TABLE. The values will not themselves be copied. +RANGE specifies one or more characters to be affected and should be +one of the following: + +-- t (all characters are affected) +-- A charset (only allowed when Mule support is present) +-- A vector of two elements: a two-octet charset and a row number + (only allowed when Mule support is present) +-- A single character + +VALUE must be a value appropriate for the type of CHAR-TABLE. +See `valid-char-table-type-p'. */ - (char_table)) + (range, value, char_table)) { - Lisp_Char_Table *ct, *ctnew; - Lisp_Object obj; - int i; + Lisp_Char_Table *ct; + struct chartab_range rainj; CHECK_CHAR_TABLE (char_table); ct = XCHAR_TABLE (char_table); - ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); - ctnew->type = ct->type; + check_valid_char_table_value (value, ct->type, ERROR_ME); + decode_char_table_range (range, &rainj); + value = canonicalize_char_table_value (value, ct->type); + put_char_table (ct, &rainj, value); + return Qnil; +} - for (i = 0; i < NUM_ASCII_CHARS; i++) - { - Lisp_Object new = ct->ascii[i]; -#ifdef MULE - assert (! (CHAR_TABLE_ENTRYP (new))); -#endif /* MULE */ - ctnew->ascii[i] = new; - } +#ifndef UTF2000 +/* Map FN over the ASCII chars in CT. */ +static int +map_over_charset_ascii (Lisp_Char_Table *ct, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) +{ + struct chartab_range rainj; + int i, retval; + int start = 0; #ifdef MULE + int stop = 128; +#else + int stop = 256; +#endif - for (i = 0; i < NUM_LEADING_BYTES; i++) + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = start, retval = 0; i < stop && retval == 0; i++) { - Lisp_Object new = ct->level1[i]; - if (CHAR_TABLE_ENTRYP (new)) - ctnew->level1[i] = copy_char_table_entry (new); - else - ctnew->level1[i] = new; + rainj.ch = (Emchar) i; + retval = (fn) (&rainj, ct->ascii[i], arg); } -#endif /* MULE */ + return retval; +} - if (CHAR_TABLEP (ct->mirror_table)) - ctnew->mirror_table = Fcopy_char_table (ct->mirror_table); - else - ctnew->mirror_table = ct->mirror_table; - ctnew->next_table = Qnil; - XSETCHAR_TABLE (obj, ctnew); - if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX) +#ifdef MULE + +/* Map FN over the Control-1 chars in CT. */ + +static int +map_over_charset_control_1 (Lisp_Char_Table *ct, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) +{ + struct chartab_range rainj; + int i, retval; + int start = 128; + int stop = start + 32; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = start, retval = 0; i < stop && retval == 0; i++) { - ctnew->next_table = Vall_syntax_tables; - Vall_syntax_tables = obj; + rainj.ch = (Emchar) (i); + retval = (fn) (&rainj, ct->ascii[i], arg); } - return obj; + + return retval; } -static void -decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) +/* Map FN over the row ROW of two-byte charset CHARSET. + There must be a separate value for that row in the char table. + CTE specifies the char table entry for CHARSET. */ + +static int +map_over_charset_row (Lisp_Char_Table_Entry *cte, + Lisp_Object charset, int row, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) { - if (EQ (range, Qt)) - outrange->type = CHARTAB_RANGE_ALL; - else if (CHAR_OR_CHAR_INTP (range)) + Lisp_Object val = cte->level2[row - 32]; + + if (!CHAR_TABLE_ENTRYP (val)) { - outrange->type = CHARTAB_RANGE_CHAR; - outrange->ch = XCHAR_OR_CHAR_INT (range); + struct chartab_range rainj; + + rainj.type = CHARTAB_RANGE_ROW; + rainj.charset = charset; + rainj.row = row; + return (fn) (&rainj, val, arg); } -#ifndef MULE else - signal_simple_error ("Range must be t or a character", range); -#else /* MULE */ - else if (VECTORP (range)) { - 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); - 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) + struct chartab_range rainj; + int i, retval; + int charset94_p = (XCHARSET_CHARS (charset) == 94); + int start = charset94_p ? 33 : 32; + int stop = charset94_p ? 127 : 128; + + cte = XCHAR_TABLE_ENTRY (val); + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = start, retval = 0; i < stop && retval == 0; i++) { - 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 (); - } + rainj.ch = MAKE_CHAR (charset, row, i); + retval = (fn) (&rainj, cte->level2[i - 32], arg); } - else - signal_simple_error ("Charset in row vector must be multi-byte", - outrange->charset); - } - else - { - if (!CHARSETP (range) && !SYMBOLP (range)) - signal_simple_error - ("Char table range must be t, charset, char, or vector", range); - outrange->type = CHARTAB_RANGE_CHARSET; - outrange->charset = Fget_charset (range); + return retval; } -#endif /* MULE */ } -#ifdef MULE -/* called from CHAR_TABLE_VALUE(). */ -Lisp_Object -get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte, - Emchar c) +static int +map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) { - Lisp_Object val; -#ifdef UTF2000 - Lisp_Object charset; -#else - Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte); -#endif - int byte1, byte2; + Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE]; + Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb); -#ifdef UTF2000 - BREAKUP_CHAR (c, charset, byte1, byte2); -#else - BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2); -#endif - val = ct->level1[leading_byte - MIN_LEADING_BYTE]; - if (CHAR_TABLE_ENTRYP (val)) - { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); - val = cte->level2[byte1 - 32]; - if (CHAR_TABLE_ENTRYP (val)) - { - cte = XCHAR_TABLE_ENTRY (val); - assert (byte2 >= 32); - val = cte->level2[byte2 - 32]; - assert (!CHAR_TABLE_ENTRYP (val)); - } - } + if (!CHARSETP (charset) + || lb == LEADING_BYTE_ASCII + || lb == LEADING_BYTE_CONTROL_1) + return 0; - return val; -} + if (!CHAR_TABLE_ENTRYP (val)) + { + struct chartab_range rainj; -#endif /* MULE */ + rainj.type = CHARTAB_RANGE_CHARSET; + rainj.charset = charset; + return (fn) (&rainj, val, arg); + } -Lisp_Object -get_char_table (Emchar ch, Lisp_Char_Table *ct) -{ -#ifdef MULE { - Lisp_Object charset; - int byte1, byte2; - Lisp_Object val; - - BREAKUP_CHAR (ch, charset, byte1, byte2); + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); + int charset94_p = (XCHARSET_CHARS (charset) == 94); + int start = charset94_p ? 33 : 32; + int stop = charset94_p ? 127 : 128; + int i, retval; - if (EQ (charset, Vcharset_ascii)) - val = ct->ascii[byte1]; - else if (EQ (charset, Vcharset_control_1)) - val = ct->ascii[byte1 + 128]; - else + if (XCHARSET_DIMENSION (charset) == 1) { - int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; - val = ct->level1[lb]; - if (CHAR_TABLE_ENTRYP (val)) + struct chartab_range rainj; + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = start, retval = 0; i < stop && retval == 0; i++) { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); - val = cte->level2[byte1 - 32]; - if (CHAR_TABLE_ENTRYP (val)) - { - cte = XCHAR_TABLE_ENTRY (val); - assert (byte2 >= 32); - val = cte->level2[byte2 - 32]; - assert (!CHAR_TABLE_ENTRYP (val)); - } + rainj.ch = MAKE_CHAR (charset, i, 0); + retval = (fn) (&rainj, cte->level2[i - 32], arg); } } + else + { + for (i = start, retval = 0; i < stop && retval == 0; i++) + retval = map_over_charset_row (cte, charset, i, fn, arg); + } - return val; + return retval; } -#else /* not MULE */ - return ct->ascii[(unsigned char)ch]; -#endif /* not MULE */ } +#endif /* MULE */ +#endif /* not UTF2000 */ -DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /* -Find value for CHARACTER in CHAR-TABLE. -*/ - (character, char_table)) -{ - CHECK_CHAR_TABLE (char_table); - CHECK_CHAR_COERCE_INT (character); - - return get_char_table (XCHAR (character), XCHAR_TABLE (char_table)); -} - -DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /* -Find value for a range in CHAR-TABLE. -If there is more than one value, return MULTI (defaults to nil). -*/ - (range, char_table, multi)) +#ifdef UTF2000 +struct map_char_table_for_charset_arg { + int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg); Lisp_Char_Table *ct; - struct chartab_range rainj; + void *arg; +}; - if (CHAR_OR_CHAR_INTP (range)) - return Fget_char_table (range, char_table); - CHECK_CHAR_TABLE (char_table); - ct = XCHAR_TABLE (char_table); +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; - decode_char_table_range (range, &rainj); - switch (rainj.type) + switch (range->type) { case CHARTAB_RANGE_ALL: - { - int i; - Lisp_Object first = ct->ascii[0]; + break; - for (i = 1; i < NUM_ASCII_CHARS; i++) - if (!EQ (first, ct->ascii[i])) - return multi; + case CHARTAB_RANGE_DEFAULT: + break; -#ifdef MULE - for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; - i++) - { - if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i)) - || i == LEADING_BYTE_ASCII - || i == LEADING_BYTE_CONTROL_1) - continue; - if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE])) - return multi; - } -#endif /* MULE */ + case CHARTAB_RANGE_CHARSET: + break; - return first; - } + case CHARTAB_RANGE_ROW: + break; -#ifdef MULE - case CHARTAB_RANGE_CHARSET: - if (EQ (rainj.charset, Vcharset_ascii)) + 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; +} + +#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 + becomes the return value of map_char_table(). */ + +int +map_char_table (Lisp_Char_Table *ct, + struct chartab_range *range, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) +{ + switch (range->type) + { + case CHARTAB_RANGE_ALL: +#ifdef UTF2000 + if (!UNBOUNDP (ct->default_value)) { - int i; - Lisp_Object first = ct->ascii[0]; + struct chartab_range rainj; + int retval; - for (i = 1; i < 128; i++) - if (!EQ (first, ct->ascii[i])) - return multi; - return first; + 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; - if (EQ (rainj.charset, Vcharset_control_1)) + 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; + + retval = map_over_charset_ascii (ct, fn, arg); + if (retval) + return retval; +#ifdef MULE + retval = map_over_charset_control_1 (ct, fn, arg); + if (retval) + return retval; { - int i; - Lisp_Object first = ct->ascii[128]; + Charset_ID i; + Charset_ID start = MIN_LEADING_BYTE; + Charset_ID stop = start + NUM_LEADING_BYTES; - for (i = 129; i < 160; i++) - if (!EQ (first, ct->ascii[i])) - return multi; - return first; + for (i = start, retval = 0; i < stop && retval == 0; i++) + { + retval = map_over_other_charset (ct, i, fn, arg); + } } +#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 val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - - MIN_LEADING_BYTE]; - if (CHAR_TABLE_ENTRYP (val)) - return multi; - return val; + 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 { - Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - - MIN_LEADING_BYTE]; - if (!CHAR_TABLE_ENTRYP (val)) - return val; - val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32]; - if (CHAR_TABLE_ENTRYP (val)) - return multi; - return val; - } -#endif /* not MULE */ - - default: - abort (); - } + int cell_min, cell_max, i; + int retval; + struct chartab_range rainj; - return Qnil; /* not reached */ -} + 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); -static int -check_valid_char_table_value (Lisp_Object value, enum char_table_type type, - Error_behavior errb) -{ - switch (type) - { - case CHAR_TABLE_TYPE_SYNTAX: - if (!ERRB_EQ (errb, ERROR_ME)) - return INTP (value) || (CONSP (value) && INTP (XCAR (value)) - && CHAR_OR_CHAR_INTP (XCDR (value))); - if (CONSP (value)) - { - Lisp_Object cdr = XCDR (value); - CHECK_INT (XCAR (value)); - CHECK_CHAR_COERCE_INT (cdr); - } - else - CHECK_INT (value); - break; + 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]; + if (!CHAR_TABLE_ENTRYP (val)) + { + struct chartab_range rainj; -#ifdef MULE - case CHAR_TABLE_TYPE_CATEGORY: - if (!ERRB_EQ (errb, ERROR_ME)) - return CATEGORY_TABLE_VALUEP (value); - CHECK_CATEGORY_TABLE_VALUE (value); - break; + rainj.type = CHARTAB_RANGE_ROW; + rainj.charset = range->charset; + rainj.row = range->row; + return (fn) (&rainj, val, arg); + } + else + return map_over_charset_row (XCHAR_TABLE_ENTRY (val), + range->charset, range->row, + fn, arg); + } +#endif /* not UTF2000 */ #endif /* MULE */ - case CHAR_TABLE_TYPE_GENERIC: - return 1; + case CHARTAB_RANGE_CHAR: + { + Emchar ch = range->ch; + Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch); - case CHAR_TABLE_TYPE_DISPLAY: - /* #### fix this */ - maybe_signal_simple_error ("Display char tables not yet implemented", - value, Qchar_table, errb); - return 0; + if (!UNBOUNDP (val)) + { + struct chartab_range rainj; - case CHAR_TABLE_TYPE_CHAR: - if (!ERRB_EQ (errb, ERROR_ME)) - return CHAR_OR_CHAR_INTP (value); - CHECK_CHAR_COERCE_INT (value); - break; + rainj.type = CHARTAB_RANGE_CHAR; + rainj.ch = ch; + return (fn) (&rainj, val, arg); + } + return 0; + } default: abort (); } - return 0; /* not reached */ -} - -static Lisp_Object -canonicalize_char_table_value (Lisp_Object value, enum char_table_type type) -{ - switch (type) - { - case CHAR_TABLE_TYPE_SYNTAX: - if (CONSP (value)) - { - Lisp_Object car = XCAR (value); - Lisp_Object cdr = XCDR (value); - CHECK_CHAR_COERCE_INT (cdr); - return Fcons (car, cdr); - } - break; - case CHAR_TABLE_TYPE_CHAR: - CHECK_CHAR_COERCE_INT (value); - break; - default: - break; - } - return value; + return 0; } -DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /* -Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE. -*/ - (value, char_table_type)) +struct slow_map_char_table_arg { - enum char_table_type type = symbol_to_char_table_type (char_table_type); - - return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil; -} + Lisp_Object function; + Lisp_Object retval; +}; -DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /* -Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE. -*/ - (value, char_table_type)) +static int +slow_map_char_table_fun (struct chartab_range *range, + Lisp_Object val, void *arg) { - enum char_table_type type = symbol_to_char_table_type (char_table_type); - - check_valid_char_table_value (value, type, ERROR_ME); - return Qnil; -} - -/* Assign VAL to all characters in RANGE in char table CT. */ + Lisp_Object ranjarg = Qnil; + struct slow_map_char_table_arg *closure = + (struct slow_map_char_table_arg *) arg; -void -put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, - Lisp_Object val) -{ switch (range->type) { case CHARTAB_RANGE_ALL: - fill_char_table (ct, val); - return; /* avoid the duplicate call to update_syntax_table() below, - since fill_char_table() also did that. */ + ranjarg = Qt; + break; + +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + ranjarg = Qnil; + break; +#endif #ifdef MULE case CHARTAB_RANGE_CHARSET: - if (EQ (range->charset, Vcharset_ascii)) - { - int i; - for (i = 0; i < 128; i++) - ct->ascii[i] = val; - } - else if (EQ (range->charset, Vcharset_control_1)) - { - int i; - for (i = 128; i < 160; i++) - ct->ascii[i] = val; - } - else - { - int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; - ct->level1[lb] = val; - } + ranjarg = XCHARSET_NAME (range->charset); break; case CHARTAB_RANGE_ROW: - { - Lisp_Char_Table_Entry *cte; - int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; - /* make sure that there is a separate entry for the row. */ - if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) - ct->level1[lb] = make_char_table_entry (ct->level1[lb]); - cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); - cte->level2[range->row - 32] = val; - } + ranjarg = vector2 (XCHARSET_NAME (range->charset), + make_int (range->row)); break; #endif /* MULE */ - case CHARTAB_RANGE_CHAR: -#ifdef MULE - { - Lisp_Object charset; - int byte1, byte2; - - BREAKUP_CHAR (range->ch, charset, byte1, byte2); - if (EQ (charset, Vcharset_ascii)) - ct->ascii[byte1] = val; - else if (EQ (charset, Vcharset_control_1)) - ct->ascii[byte1 + 128] = val; - else - { - Lisp_Char_Table_Entry *cte; - int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; - /* make sure that there is a separate entry for the row. */ - if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) - ct->level1[lb] = make_char_table_entry (ct->level1[lb]); - cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); - /* now CTE is a char table entry for the charset; - each entry is for a single row (or character of - a one-octet charset). */ - if (XCHARSET_DIMENSION (charset) == 1) - cte->level2[byte1 - 32] = val; - else - { - /* assigning to one character in a two-octet charset. */ - /* make sure that the charset row contains a separate - entry for each character. */ - if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32])) - cte->level2[byte1 - 32] = - make_char_table_entry (cte->level2[byte1 - 32]); - cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]); - cte->level2[byte2 - 32] = val; - } - } - } -#else /* not MULE */ - ct->ascii[(unsigned char) (range->ch)] = val; + ranjarg = make_char (range->ch); break; -#endif /* not MULE */ + default: + abort (); } - if (ct->type == CHAR_TABLE_TYPE_SYNTAX) - update_syntax_table (ct); + closure->retval = call2 (closure->function, ranjarg, val); + return !NILP (closure->retval); } -DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /* -Set the value for chars in RANGE to be VALUE in CHAR-TABLE. - -RANGE specifies one or more characters to be affected and should be -one of the following: - --- t (all characters are affected) --- A charset (only allowed when Mule support is present) --- A vector of two elements: a two-octet charset and a row number - (only allowed when Mule support is present) --- A single character +DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /* +Map FUNCTION over entries in CHAR-TABLE, calling it with two args, +each key and value in the table. -VALUE must be a value appropriate for the type of CHAR-TABLE. -See `valid-char-table-type-p'. +RANGE specifies a subrange to map over and is in the same format as +the RANGE argument to `put-range-table'. If omitted or t, it defaults to +the entire table. */ - (range, value, char_table)) + (function, char_table, range)) { Lisp_Char_Table *ct; + struct slow_map_char_table_arg slarg; + struct gcpro gcpro1, gcpro2; struct chartab_range rainj; CHECK_CHAR_TABLE (char_table); ct = XCHAR_TABLE (char_table); - check_valid_char_table_value (value, ct->type, ERROR_ME); + if (NILP (range)) + range = Qt; decode_char_table_range (range, &rainj); - value = canonicalize_char_table_value (value, ct->type); - put_char_table (ct, &rainj, value); - return Qnil; + slarg.function = function; + slarg.retval = Qnil; + GCPRO2 (slarg.function, slarg.retval); + map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg); + UNGCPRO; + + return slarg.retval; } -/* Map FN over the ASCII chars in CT. */ + +/************************************************************************/ +/* Character Attributes */ +/************************************************************************/ + +#ifdef UTF2000 + +Lisp_Object Vchar_attribute_hash_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 -map_over_charset_ascii (Lisp_Char_Table *ct, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) +add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value, + void *char_attribute_list_closure) { - struct chartab_range rainj; - int i, retval; - int start = 0; -#ifdef MULE - int stop = 128; -#else - int stop = 256; -#endif + /* 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; - rainj.type = CHARTAB_RANGE_CHAR; + *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; +}; - for (i = start, retval = 0; i < stop && retval == 0; i++) +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 (XCHAR_TABLE(value), caacl->char_id); + if (!UNBOUNDP (ret)) { - rainj.ch = (Emchar) i; - retval = (fn) (&rainj, ct->ascii[i], arg); + Lisp_Object *char_attribute_alist = caacl->char_attribute_alist; + *char_attribute_alist + = Fcons (Fcons (key, ret), *char_attribute_alist); } - - return retval; + return 0; } -#ifdef MULE +DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /* +Return the alist of attributes of CHARACTER. +*/ + (character)) +{ + struct gcpro gcpro1; + struct char_attribute_alist_closure char_attribute_alist_closure; + Lisp_Object alist = Qnil; -/* Map FN over the Control-1 chars in CT. */ + CHECK_CHAR (character); -static int -map_over_charset_control_1 (Lisp_Char_Table *ct, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) + 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; + + 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)) { - struct chartab_range rainj; - int i, retval; - int start = 128; - int stop = start + 32; + Lisp_Object table; - rainj.type = CHARTAB_RANGE_CHAR; + CHECK_CHAR (character); - for (i = start, retval = 0; i < stop && retval == 0; i++) + if (CHARSETP (attribute)) + attribute = XCHARSET_NAME (attribute); + + table = Fgethash (attribute, Vchar_attribute_hash_table, + Qunbound); + if (!UNBOUNDP (table)) { - rainj.ch = (Emchar) (i); - retval = (fn) (&rainj, ct->ascii[i], arg); + Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table), + XCHAR (character)); + if (!UNBOUNDP (ret)) + return ret; } - - return retval; + return default_value; } -/* Map FN over the row ROW of two-byte charset CHARSET. - There must be a separate value for that row in the char table. - CTE specifies the char table entry for CHARSET. */ - -static int -map_over_charset_row (Lisp_Char_Table_Entry *cte, - Lisp_Object charset, int row, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) +DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /* +Store CHARACTER's ATTRIBUTE with VALUE. +*/ + (character, attribute, value)) { - Lisp_Object val = cte->level2[row - 32]; + Lisp_Object ccs = Ffind_charset (attribute); - if (!CHAR_TABLE_ENTRYP (val)) + if (!NILP (ccs)) { - struct chartab_range rainj; + CHECK_CHAR (character); + value = put_char_ccs_code_point (character, ccs, value); + } + else if (EQ (attribute, Q_decomposition)) + { + CHECK_CHAR (character); + if (!CONSP (value)) + signal_simple_error ("Invalid value for ->decomposition", + value); - rainj.type = CHARTAB_RANGE_ROW; - rainj.charset = charset; - rainj.row = row; - return (fn) (&rainj, val, arg); + if (CONSP (Fcdr (value))) + { + if (NILP (Fcdr (Fcdr (value)))) + { + Lisp_Object base = Fcar (value); + Lisp_Object modifier = Fcar (Fcdr (value)); + + if (INTP (base)) + { + base = make_char (XINT (base)); + Fsetcar (value, base); + } + if (INTP (modifier)) + { + modifier = make_char (XINT (modifier)); + Fsetcar (Fcdr (value), modifier); + } + if (CHARP (base)) + { + Lisp_Object alist = Fget_char_attribute (base, Qcomposition, Qnil); + Lisp_Object ret = Fassq (modifier, alist); + + if (NILP (ret)) + Fput_char_attribute (base, Qcomposition, + Fcons (Fcons (modifier, character), alist)); + else + Fsetcdr (ret, character); + } + } + } + else + { + Lisp_Object v = Fcar (value); + + if (INTP (v)) + { + Emchar c = XINT (v); + Lisp_Object ret + = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil); + + if (!CONSP (ret)) + { + Fput_char_attribute (make_char (c), Q_ucs_variants, + Fcons (character, Qnil)); + } + else if (NILP (Fmemq (character, ret))) + { + Fput_char_attribute (make_char (c), Q_ucs_variants, + Fcons (character, ret)); + } + } + } } - else + else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs)) { - struct chartab_range rainj; - int i, retval; - int charset94_p = (XCHARSET_CHARS (charset) == 94); - int start = charset94_p ? 33 : 32; - int stop = charset94_p ? 127 : 128; + Lisp_Object ret; + Emchar c; - cte = XCHAR_TABLE_ENTRY (val); + CHECK_CHAR (character); + if (!INTP (value)) + signal_simple_error ("Invalid value for ->ucs", value); - rainj.type = CHARTAB_RANGE_CHAR; + c = XINT (value); - for (i = start, retval = 0; i < stop && retval == 0; i++) + ret = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil); + if (!CONSP (ret)) { - rainj.ch = MAKE_CHAR (charset, row, i); - retval = (fn) (&rainj, cte->level2[i - 32], arg); + Fput_char_attribute (make_char (c), Q_ucs_variants, + Fcons (character, Qnil)); } - return retval; + else if (NILP (Fmemq (character, ret))) + { + Fput_char_attribute (make_char (c), Q_ucs_variants, + Fcons (character, ret)); + } +#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); +#ifdef HAVE_DATABASE + XCHAR_TABLE_NAME (table) = attribute; +#endif + } + put_char_id_table (XCHAR_TABLE(table), character, value); + 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_TABLE(table), character, Qunbound); + return Qt; + } + } + return Qnil; +} -static int -map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) +#ifdef HAVE_DATABASE +Lisp_Object +char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute, + int writing_mode) { - Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE]; - Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb); + Lisp_Object db_dir = Vexec_directory; - if (!CHARSETP (charset) - || lb == LEADING_BYTE_ASCII - || lb == LEADING_BYTE_CONTROL_1) - return 0; + if (NILP (db_dir)) + db_dir = build_string ("../lib-src"); - if (!CHAR_TABLE_ENTRYP (val)) - { - struct chartab_range rainj; + 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); - rainj.type = CHARTAB_RANGE_CHARSET; - rainj.charset = charset; - return (fn) (&rainj, val, arg); - } + 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_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); - int charset94_p = (XCHARSET_CHARS (charset) == 94); - int start = charset94_p ? 33 : 32; - int stop = charset94_p ? 127 : 128; - int i, retval; + 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; - if (XCHARSET_DIMENSION (charset) == 1) + GCPRO2 (dest, ret); + for (i = 0; i < len; i++) { - struct chartab_range rainj; - rainj.type = CHARTAB_RANGE_CHAR; + Emchar c = string_char (XSTRING (attribute_name), i); - for (i = start, retval = 0; i < stop && retval == 0; i++) + if ( (c == '/') || (c == '%') ) { - rainj.ch = MAKE_CHAR (charset, i, 0); - retval = (fn) (&rainj, cte->level2[i - 32], arg); + 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; } } - else - { - for (i = start, retval = 0; i < stop && retval == 0; i++) - retval = map_over_charset_row (cte, charset, i, fn, arg); - } - - return retval; + 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 } -#endif /* MULE */ +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_file; + Lisp_Object db; -/* 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 - becomes the return value of map_char_table(). */ + 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, build_string ("w+"), 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 ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /* +Mount database file on char-attribute-table ATTRIBUTE. +*/ + (attribute)) +{ +#ifdef HAVE_DATABASE + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, Qunbound); + + if (UNBOUNDP (table)) + { + Lisp_Char_Table *ct; + + 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; + ct->db = Qnil; + return Qt; + } +#endif + return Qnil; +} + +DEFUN ("close-char-attribute-table", Fclose_char_attribute_table, 1, 1, 0, /* +Close database of ATTRIBUTE. +*/ + (attribute)) +{ +#ifdef HAVE_DATABASE + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, Qunbound); + Lisp_Char_Table *ct; + + if (CHAR_TABLEP (table)) + ct = XCHAR_TABLE (table); + else + return Qnil; + + if (!NILP (ct->db)) + { + if (!NILP (Fdatabase_live_p (ct->db))) + Fclose_database (ct->db); + ct->db = Qnil; + } +#endif + return Qnil; +} -int -map_char_table (Lisp_Char_Table *ct, - struct chartab_range *range, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) +DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /* +Reset values of ATTRIBUTE with database file. +*/ + (attribute)) { - switch (range->type) +#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))) { - case CHARTAB_RANGE_ALL: - { - int retval; + 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; + if (!NILP (Fdatabase_live_p (ct->db))) + Fclose_database (ct->db); + ct->db = Qnil; + XCHAR_TABLE_UNLOADED(table) = 1; + return Qt; + } +#endif + return Qnil; +} - retval = map_over_charset_ascii (ct, fn, arg); - if (retval) - return retval; -#ifdef MULE - retval = map_over_charset_control_1 (ct, fn, arg); - if (retval) - return retval; +Lisp_Object +load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch) +{ + Lisp_Object attribute = CHAR_TABLE_NAME (cit); + + if (!NILP (attribute)) + { + if (NILP (Fdatabase_live_p (cit->db))) { - Charset_ID i; - Charset_ID start = MIN_LEADING_BYTE; - Charset_ID stop = start + NUM_LEADING_BYTES; + Lisp_Object db_file + = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); - for (i = start, retval = 0; i < stop && retval == 0; i++) + cit->db = Fopen_database (db_file, Qnil, Qnil, + build_string ("r"), Qnil); + } + if (!NILP (cit->db)) + { + Lisp_Object val + = Fget_database (Fprin1_to_string (make_char (ch), Qnil), + cit->db, Qunbound); + if (!UNBOUNDP (val)) + val = Fread (val); + else + val = Qunbound; + if (!NILP (Vchar_db_stingy_mode)) { - retval = map_over_other_charset (ct, i, fn, arg); + Fclose_database (cit->db); + cit->db = Qnil; } + return val; } -#endif /* MULE */ - return retval; - } - -#ifdef MULE - case CHARTAB_RANGE_CHARSET: - return map_over_other_charset (ct, - XCHARSET_LEADING_BYTE (range->charset), - fn, arg); - - case CHARTAB_RANGE_ROW: - { - Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - - MIN_LEADING_BYTE]; - if (!CHAR_TABLE_ENTRYP (val)) - { - struct chartab_range rainj; - - rainj.type = CHARTAB_RANGE_ROW; - rainj.charset = range->charset; - rainj.row = range->row; - return (fn) (&rainj, val, arg); - } - else - return map_over_charset_row (XCHAR_TABLE_ENTRY (val), - range->charset, range->row, - fn, arg); - } -#endif /* MULE */ + } + return Qunbound; +} - case CHARTAB_RANGE_CHAR: - { - Emchar ch = range->ch; - Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch); - struct chartab_range rainj; +Lisp_Char_Table* char_attribute_table_to_load; - rainj.type = CHARTAB_RANGE_CHAR; - rainj.ch = ch; - return (fn) (&rainj, val, arg); - } +Lisp_Object Qload_char_attribute_table_map_function; - default: - abort (); - } +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_0 (char_attribute_table_to_load, code); - return 0; + if (EQ (ret, Qunloaded)) + put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value)); + return Qnil; } -struct slow_map_char_table_arg -{ - Lisp_Object function; - Lisp_Object retval; -}; - -static int -slow_map_char_table_fun (struct chartab_range *range, - Lisp_Object val, void *arg) +DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /* +Load values of ATTRIBUTE into database file. +*/ + (attribute)) { - Lisp_Object ranjarg = Qnil; - struct slow_map_char_table_arg *closure = - (struct slow_map_char_table_arg *) arg; - - switch (range->type) + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + if (CHAR_TABLEP (table)) { - case CHARTAB_RANGE_ALL: - ranjarg = Qt; - break; + Lisp_Char_Table *ct = XCHAR_TABLE (table); -#ifdef MULE - case CHARTAB_RANGE_CHARSET: - ranjarg = XCHARSET_NAME (range->charset); - break; + if (NILP (Fdatabase_live_p (ct->db))) + { + Lisp_Object db_file + = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); - case CHARTAB_RANGE_ROW: - ranjarg = vector2 (XCHARSET_NAME (range->charset), - make_int (range->row)); - break; -#endif /* MULE */ - case CHARTAB_RANGE_CHAR: - ranjarg = make_char (range->ch); - break; - default: - abort (); + ct->db = Fopen_database (db_file, Qnil, Qnil, + build_string ("r"), Qnil); + } + if (!NILP (ct->db)) + { + struct gcpro gcpro1; + + char_attribute_table_to_load = XCHAR_TABLE (table); + GCPRO1 (table); + Fmap_database (Qload_char_attribute_table_map_function, ct->db); + UNGCPRO; + Fclose_database (ct->db); + ct->db = Qnil; + XCHAR_TABLE_UNLOADED(table) = 0; + return Qt; + } } - - closure->retval = call2 (closure->function, ranjarg, val); - return !NILP (closure->retval); + return Qnil; } +#endif -DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /* -Map FUNCTION over entries in CHAR-TABLE, calling it with two args, +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. RANGE specifies a subrange to map over and is in the same format as the RANGE argument to `put-range-table'. If omitted or t, it defaults to the entire table. */ - (function, char_table, range)) + (function, attribute, range)) { + Lisp_Object ccs; Lisp_Char_Table *ct; struct slow_map_char_table_arg slarg; struct gcpro gcpro1, gcpro2; struct chartab_range rainj; - CHECK_CHAR_TABLE (char_table); - ct = XCHAR_TABLE (char_table); + if (!NILP (ccs = Ffind_charset (attribute))) + { + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + + if (CHAR_TABLEP (encoding_table)) + ct = XCHAR_TABLE (encoding_table); + else + return Qnil; + } + else + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + 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); @@ -2881,6 +3600,108 @@ the entire table. return slarg.retval; } +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_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, Qnil); + 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, Qnil); + } + 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 /************************************************************************/ @@ -3027,7 +3848,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; @@ -3038,10 +3859,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, /* @@ -3221,10 +4042,13 @@ 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 (&Qcomposition, "composition"); defsymbol (&Q_decomposition, "->decomposition"); defsymbol (&Qcompat, "compat"); defsymbol (&Qisolated, "isolated"); @@ -3245,6 +4069,18 @@ 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); +#ifdef HAVE_DATABASE + DEFSUBR (Fsave_char_attribute_table); + DEFSUBR (Fmount_char_attribute_table); + DEFSUBR (Freset_char_attribute_table); + DEFSUBR (Fclose_char_attribute_table); + defsymbol (&Qload_char_attribute_table_map_function, + "load-char-attribute-table-map-function"); + DEFSUBR (Fload_char_attribute_table_map_function); + DEFSUBR (Fload_char_attribute_table); +#endif DEFSUBR (Fchar_attribute_alist); DEFSUBR (Fget_char_attribute); DEFSUBR (Fput_char_attribute); @@ -3260,7 +4096,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"); @@ -3302,16 +4140,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. +#ifdef HAVE_DATABASE + DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /* */ ); - - staticpro (&Vcharacter_composition_table); - Vcharacter_composition_table = make_char_id_table (Qnil); - - staticpro (&Vcharacter_variant_table); - Vcharacter_variant_table = make_char_id_table (Qnil); + Vchar_db_stingy_mode = Qt; +#endif /* HAVE_DATABASE */ #endif /* DO NOT staticpro this. It works just like Vweak_hash_tables. */ Vall_syntax_tables = Qnil;