X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fchartab.c;h=1a22127101394a3ee43582676336b86669e5285c;hb=edb1d7f5d06e1f3ca783853fe435f41eaa32ea8e;hp=2c4f3680120de634369f7d7c3966068579e1c0f6;hpb=80fe243443289831be6afb94e0614c7708e34a95;p=chise%2Fxemacs-chise.git- diff --git a/src/chartab.c b/src/chartab.c index 2c4f368..1a22127 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -4,7 +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 MORIOKA Tomohiko + Copyright (C) 1999,2000,2001,2002 MORIOKA Tomohiko This file is part of XEmacs. @@ -34,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 @@ -42,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; @@ -67,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); @@ -95,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; @@ -115,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; @@ -190,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 @@ -250,7 +265,8 @@ uint8_byte_table_same_value_p (Lisp_Object obj) } static int -map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place, +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) @@ -265,7 +281,26 @@ map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place, for (i = 0, retval = 0; i < 256 && retval == 0; i++) { - if (ct->property[i] != BT_UINT8_unbound) + if (ct->property[i] == BT_UINT8_unloaded) + { +#if 0 + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + 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++) @@ -280,11 +315,49 @@ map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place, return retval; } +#ifdef HAVE_DATABASE +static void +save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root, + Lisp_Object db, + Emchar ofs, int place) +{ + struct chartab_range rainj; + int i, retval; + int unit = 1 << (8 * place); + Emchar c = ofs; + Emchar c1; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + if (ct->property[i] == BT_UINT8_unloaded) + { + c1 = c + unit; + } + else if (ct->property[i] != BT_UINT8_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + Fput_database (Fprin1_to_string (make_char (c), Qnil), + Fprin1_to_string (UINT8_DECODE (ct->property[i]), + Qnil), + db, Qt); + } + } + 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); @@ -307,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; @@ -327,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; @@ -340,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; @@ -415,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 @@ -493,7 +576,8 @@ uint16_byte_table_same_value_p (Lisp_Object obj) } static int -map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place, +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) @@ -508,7 +592,26 @@ map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place, for (i = 0, retval = 0; i < 256 && retval == 0; i++) { - if (ct->property[i] != BT_UINT16_unbound) + if (ct->property[i] == BT_UINT16_unloaded) + { +#if 0 + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + 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++) @@ -523,6 +626,43 @@ map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place, return retval; } +#ifdef HAVE_DATABASE +static void +save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root, + Lisp_Object db, + Emchar ofs, int place) +{ + struct chartab_range rainj; + int i, retval; + int unit = 1 << (8 * place); + Emchar c = ofs; + Emchar c1; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + if (ct->property[i] == BT_UINT16_unloaded) + { + c1 = c + unit; + } + else if (ct->property[i] != BT_UINT16_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + Fput_database (Fprin1_to_string (make_char (c), Qnil), + Fprin1_to_string (UINT16_DECODE (ct->property[i]), + Qnil), + db, Qt); + } + } + else + c += unit; + } +} +#endif + static Lisp_Object mark_byte_table (Lisp_Object obj) @@ -670,7 +810,8 @@ byte_table_same_value_p (Lisp_Object obj) } static int -map_over_byte_table (Lisp_Byte_Table *ct, 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) @@ -686,23 +827,46 @@ map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place, if (UINT8_BYTE_TABLE_P (v)) { retval - = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), + = 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), + = 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), + 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; @@ -722,6 +886,61 @@ map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place, return retval; } +#ifdef HAVE_DATABASE +static void +save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root, + Lisp_Object db, + Emchar ofs, int place) +{ + int i, retval; + Lisp_Object v; + int unit = 1 << (8 * place); + Emchar c = ofs; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + v = ct->property[i]; + if (UINT8_BYTE_TABLE_P (v)) + { + save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db, + c, place - 1); + c += unit; + } + else if (UINT16_BYTE_TABLE_P (v)) + { + save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db, + c, place - 1); + c += unit; + } + else if (BYTE_TABLE_P (v)) + { + save_byte_table (XBYTE_TABLE(v), root, db, + c, place - 1); + c += unit; + } + else if (EQ (v, Qunloaded)) + { + c += unit; + } + else if (!UNBOUNDP (v)) + { + struct chartab_range rainj; + Emchar c1 = c + unit; + + rainj.type = CHARTAB_RANGE_CHAR; + + 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) @@ -840,13 +1059,13 @@ make_char_id_table (Lisp_Object initval) } -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; @@ -914,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 (XCHAR_TABLE(table), c); - + 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_TABLEP (ret)) - return ret; - else - return Qt; - } - else if (!CONSP (rest)) - break; - else if (CHAR_TABLEP (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, /* @@ -948,10 +1159,14 @@ Return variants of CHARACTER. */ (character)) { + Lisp_Object ret; + CHECK_CHAR (character); - return Fcopy_list (get_char_id_table - (XCHAR_TABLE(Vcharacter_variant_table), - XCHAR (character))); + ret = Fget_char_attribute (character, Q_ucs_variants, Qnil); + if (CONSP (ret)) + return Fcopy_list (ret); + else + return Qnil; } #endif @@ -1048,6 +1263,8 @@ mark_char_table (Lisp_Object obj) #ifdef UTF2000 mark_object (ct->table); + mark_object (ct->name); + mark_object (ct->db); #else int i; @@ -1376,6 +1593,8 @@ 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 @@ -1501,6 +1720,7 @@ fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) #ifdef UTF2000 ct->table = Qunbound; ct->default_value = value; + ct->unloaded = 0; #else int i; @@ -1574,6 +1794,9 @@ and 'syntax. See `valid-char-table-type-p'. } else ct->mirror_table = Qnil; +#else + ct->name = Qnil; + ct->db = Qnil; #endif ct->next_table = Qnil; XSETCHAR_TABLE (obj, ct); @@ -1646,6 +1869,9 @@ as CHAR-TABLE. The values will not themselves be copied. 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 (UINT8_BYTE_TABLE_P (ct->table)) { @@ -2092,6 +2318,22 @@ Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE. return Qnil; } +#ifdef UTF2000 +Lisp_Char_Table* char_attribute_table_to_put; +Lisp_Object Qput_char_table_map_function; +Lisp_Object value_to_put; + +DEFUN ("put-char-table-map-function", + Fput_char_table_map_function, 2, 2, 0, /* +For internal use. Don't use it. +*/ + (c, value)) +{ + put_char_id_table_0 (char_attribute_table_to_put, c, value_to_put); + return Qnil; +} +#endif + /* Assign VAL to all characters in RANGE in char table CT. */ void @@ -2124,12 +2366,20 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, */ 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 { @@ -2468,6 +2718,7 @@ map_char_table_for_charset_fun (struct chartab_range *range, return 0; } + #endif /* Map FN (with client data ARG) over range RANGE in char table CT. @@ -2496,17 +2747,17 @@ map_char_table (Lisp_Char_Table *ct, return retval; } if (UINT8_BYTE_TABLE_P (ct->table)) - return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(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), + 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), + return map_over_byte_table (XBYTE_TABLE(ct->table), ct, 0, 3, fn, arg); - else if (!UNBOUNDP (ct->table)) -#if 0 + else if (EQ (ct->table, Qunloaded)) { +#if 0 struct chartab_range rainj; int unit = 1 << 30; Emchar c = 0; @@ -2517,14 +2768,21 @@ map_char_table (Lisp_Char_Table *ct, for (retval = 0; c < c1 && retval == 0; c++) { - rainj.ch = c; - retval = (fn) (&rainj, ct->table, arg); + Lisp_Object ret = get_char_id_table (ct, c); + + if (!UNBOUNDP (ret)) + { + rainj.ch = c; + retval = (fn) (&rainj, ct->table, arg); + } } return retval; - } #else - return (fn) (range, ct->table, arg); + ct->table = Qunbound; #endif + } + else if (!UNBOUNDP (ct->table)) + return (fn) (range, ct->table, arg); return 0; #else { @@ -2571,6 +2829,10 @@ map_char_table (Lisp_Char_Table *ct, 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; @@ -2836,41 +3098,20 @@ Return the alist of attributes of CHARACTER. */ (character)) { + struct gcpro gcpro1; + struct char_attribute_alist_closure char_attribute_alist_closure; Lisp_Object alist = Qnil; - int i; CHECK_CHAR (character); - { - struct gcpro gcpro1; - struct char_attribute_alist_closure char_attribute_alist_closure; - - GCPRO1 (alist); - char_attribute_alist_closure.char_id = XCHAR (character); - char_attribute_alist_closure.char_attribute_alist = &alist; - elisp_maphash (add_char_attribute_alist_mapper, - Vchar_attribute_hash_table, - &char_attribute_alist_closure); - UNGCPRO; - } - for (i = 0; i < countof (chlook->charset_by_leading_byte); i++) - { - Lisp_Object ccs = chlook->charset_by_leading_byte[i]; - - if (!NILP (ccs)) - { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); - Lisp_Object cpos; + GCPRO1 (alist); + char_attribute_alist_closure.char_id = XCHAR (character); + char_attribute_alist_closure.char_attribute_alist = &alist; + elisp_maphash (add_char_attribute_alist_mapper, + Vchar_attribute_hash_table, + &char_attribute_alist_closure); + UNGCPRO; - if ( CHAR_TABLEP (encoding_table) - && INTP (cpos - = get_char_id_table (XCHAR_TABLE(encoding_table), - XCHAR (character))) ) - { - alist = Fcons (Fcons (ccs, cpos), alist); - } - } - } return alist; } @@ -2880,29 +3121,21 @@ Return DEFAULT-VALUE if the value is not exist. */ (character, attribute, default_value)) { - Lisp_Object ccs; + Lisp_Object table; CHECK_CHAR (character); - if (!NILP (ccs = Ffind_charset (attribute))) - { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); - if (CHAR_TABLEP (encoding_table)) - return get_char_id_table (XCHAR_TABLE(encoding_table), - XCHAR (character)); - } - else + if (CHARSETP (attribute)) + attribute = XCHARSET_NAME (attribute); + + table = Fgethash (attribute, Vchar_attribute_hash_table, + Qunbound); + if (!UNBOUNDP (table)) { - Lisp_Object table = Fgethash (attribute, - Vchar_attribute_hash_table, - Qunbound); - if (!UNBOUNDP (table)) - { - Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table), - XCHAR (character)); - if (!UNBOUNDP (ret)) - return ret; - } + Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table), + XCHAR (character)); + if (!UNBOUNDP (ret)) + return ret; } return default_value; } @@ -2912,18 +3145,15 @@ Store CHARACTER's ATTRIBUTE with VALUE. */ (character, attribute, value)) { - Lisp_Object ccs; + Lisp_Object ccs = Ffind_charset (attribute); - ccs = Ffind_charset (attribute); if (!NILP (ccs)) { CHECK_CHAR (character); - return put_char_ccs_code_point (character, ccs, value); + value = put_char_ccs_code_point (character, ccs, value); } else if (EQ (attribute, Q_decomposition)) { - Lisp_Object seq; - CHECK_CHAR (character); if (!CONSP (value)) signal_simple_error ("Invalid value for ->decomposition", @@ -2931,42 +3161,31 @@ Store CHARACTER's ATTRIBUTE with 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)) + if (NILP (Fcdr (Fcdr (value)))) { - Lisp_Object v = Fcar (rest); - Lisp_Object ntable; - Emchar c - = to_char_id (v, "Invalid value for ->decomposition", value); + Lisp_Object base = Fcar (value); + Lisp_Object modifier = Fcar (Fcdr (value)); - if (c < 0) - XVECTOR_DATA(seq)[i++] = v; - else - XVECTOR_DATA(seq)[i++] = make_char (c); - rest = Fcdr (rest); - if (!CONSP (rest)) + if (INTP (base)) { - put_char_id_table (XCHAR_TABLE(table), - make_char (c), character); - break; + base = make_char (XINT (base)); + Fsetcar (value, base); } - else + if (INTP (modifier)) { - ntable = get_char_id_table (XCHAR_TABLE(table), c); - if (!CHAR_TABLEP (ntable)) - { - ntable = make_char_id_table (Qnil); - put_char_id_table (XCHAR_TABLE(table), - make_char (c), ntable); - } - table = ntable; + 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); } } } @@ -2978,18 +3197,20 @@ Store CHARACTER's ATTRIBUTE with VALUE. { Emchar c = XINT (v); Lisp_Object ret - = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), - c); + = Fget_char_attribute (make_char (c), Q_ucs_variants, Qnil); - if (NILP (Fmemq (v, ret))) + if (!CONSP (ret)) { - put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), - make_char (c), Fcons (character, 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)); } } - seq = make_vector (1, v); } - value = seq; } else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs)) { @@ -3002,11 +3223,16 @@ Store CHARACTER's ATTRIBUTE with VALUE. c = XINT (value); - ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c); - if (NILP (Fmemq (character, ret))) + 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))) { - put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), - make_char (c), Fcons (character, ret)); + Fput_char_attribute (make_char (c), Q_ucs_variants, + Fcons (character, ret)); } #if 0 if (EQ (attribute, Q_ucs)) @@ -3022,6 +3248,9 @@ Store CHARACTER's ATTRIBUTE with VALUE. { table = make_char_id_table (Qunbound); Fputhash (attribute, table, Vchar_attribute_hash_table); +#ifdef HAVE_DATABASE + XCHAR_TABLE_NAME (table) = attribute; +#endif } put_char_id_table (XCHAR_TABLE(table), character, value); return value; @@ -3055,6 +3284,271 @@ Remove CHARACTER's ATTRIBUTE. return Qnil; } +#ifdef HAVE_DATABASE +Lisp_Object +char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute, + int writing_mode) +{ + Lisp_Object db_dir = Vexec_directory; + + if (NILP (db_dir)) + db_dir = build_string ("../lib-src"); + + db_dir = Fexpand_file_name (build_string ("char-db"), db_dir); + if (writing_mode && NILP (Ffile_exists_p (db_dir))) + Fmake_directory_internal (db_dir); + + db_dir = Fexpand_file_name (Fsymbol_name (key_type), db_dir); + if (writing_mode && NILP (Ffile_exists_p (db_dir))) + Fmake_directory_internal (db_dir); + + { + Lisp_Object attribute_name = Fsymbol_name (attribute); + Lisp_Object dest = Qnil, ret; + int base = 0; + struct gcpro gcpro1, gcpro2; + int len = XSTRING_CHAR_LENGTH (attribute_name); + int i; + + GCPRO2 (dest, ret); + for (i = 0; i < len; i++) + { + Emchar c = string_char (XSTRING (attribute_name), i); + + if ( (c == '/') || (c == '%') ) + { + char str[4]; + + sprintf (str, "%%%02X", c); + dest = concat3 (dest, + Fsubstring (attribute_name, + make_int (base), make_int (i)), + build_string (str)); + base = i + 1; + } + } + ret = Fsubstring (attribute_name, make_int (base), make_int (len)); + dest = concat2 (dest, ret); + UNGCPRO; + return Fexpand_file_name (dest, db_dir); + } +#if 0 + return Fexpand_file_name (Fsymbol_name (attribute), db_dir); +#endif +} + +DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /* +Save values of ATTRIBUTE into database file. +*/ + (attribute)) +{ +#ifdef HAVE_DATABASE + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, Qunbound); + Lisp_Char_Table *ct; + Lisp_Object db_file; + Lisp_Object db; + + 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; +} + +DEFUN ("reset-char-attribute-table", Freset_char_attribute_table, 1, 1, 0, /* +Reset values of ATTRIBUTE with database file. +*/ + (attribute)) +{ +#ifdef HAVE_DATABASE + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, Qunbound); + Lisp_Char_Table *ct; + Lisp_Object db_file + = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + + if (!NILP (Ffile_exists_p (db_file))) + { + if (UNBOUNDP (table)) + { + table = make_char_id_table (Qunbound); + Fputhash (attribute, table, Vchar_attribute_hash_table); + XCHAR_TABLE_NAME(table) = attribute; + } + ct = XCHAR_TABLE (table); + ct->table = Qunloaded; + if (!NILP (Fdatabase_live_p (ct->db))) + Fclose_database (ct->db); + ct->db = Qnil; + XCHAR_TABLE_UNLOADED(table) = 1; + return Qt; + } +#endif + return Qnil; +} + +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))) + { + Lisp_Object db_file + = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + + 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)) + { + Fclose_database (cit->db); + cit->db = Qnil; + } + return val; + } + } + return Qunbound; +} + +Lisp_Char_Table* char_attribute_table_to_load; + +Lisp_Object Qload_char_attribute_table_map_function; + +DEFUN ("load-char-attribute-table-map-function", + Fload_char_attribute_table_map_function, 2, 2, 0, /* +For internal use. Don't use it. +*/ + (key, value)) +{ + Lisp_Object c = Fread (key); + Emchar code = XCHAR (c); + Lisp_Object ret = get_char_id_table_0 (char_attribute_table_to_load, code); + + if (EQ (ret, Qunloaded)) + put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value)); + return Qnil; +} + +DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /* +Load values of ATTRIBUTE into database file. +*/ + (attribute)) +{ + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + if (CHAR_TABLEP (table)) + { + Lisp_Char_Table *ct = XCHAR_TABLE (table); + + if (NILP (Fdatabase_live_p (ct->db))) + { + Lisp_Object db_file + = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + + 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; + } + } + return Qnil; +} +#endif + DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /* Map FUNCTION over entries in ATTRIBUTE, calling it with two args, each key and value in the table. @@ -3093,6 +3587,10 @@ the entire table. 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); @@ -3102,9 +3600,6 @@ the entire table. return slarg.retval; } -EXFUN (Fmake_char, 3); -EXFUN (Fdecode_char, 2); - DEFUN ("define-char", Fdefine_char, 1, 1, 0, /* Store character's ATTRIBUTES. */ @@ -3125,13 +3620,14 @@ Store character's ATTRIBUTES. signal_simple_error ("Invalid argument", attributes); if (!NILP (ccs = Ffind_charset (Fcar (cell))) && ((XCHARSET_FINAL (ccs) != 0) || - (XCHARSET_UCS_MAX (ccs) > 0)) ) + (XCHARSET_MAX_CODE (ccs) > 0) || + (EQ (ccs, Vcharset_chinese_big5))) ) { cell = Fcdr (cell); if (CONSP (cell)) character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); else - character = Fdecode_char (ccs, cell); + character = Fdecode_char (ccs, cell, Qnil); if (!NILP (character)) goto setup_attributes; } @@ -3190,7 +3686,7 @@ Retrieve the character of the given ATTRIBUTES. if (CONSP (cell)) return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); else - return Fdecode_char (ccs, cell); + return Fdecode_char (ccs, cell, Qnil); } rest = Fcdr (rest); } @@ -3352,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; @@ -3363,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, /* @@ -3547,8 +4043,12 @@ syms_of_chartab (void) INIT_LRECORD_IMPLEMENTATION (uint16_byte_table); INIT_LRECORD_IMPLEMENTATION (byte_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"); @@ -3569,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); @@ -3628,16 +4140,11 @@ void vars_of_chartab (void) { #ifdef UTF2000 - Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)"); - 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;