X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fchartab.c;h=37598ca623a3203937d66264db01cdfb86337d03;hb=153c92fa2a3b77ce954a1e54a5dc9ec15370cfd6;hp=66ff5bc03f04cd1e0a69ca2844b7a8fd6b53aa98;hpb=798c2ae3170adc2992f77dff16c7072b98b3fcdc;p=chise%2Fxemacs-chise.git- diff --git a/src/chartab.c b/src/chartab.c index 66ff5bc..37598ca 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -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 @@ -64,6 +65,14 @@ 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 - 4) #define BT_UINT8_t (UCHAR_MAX - 3) @@ -335,7 +344,6 @@ save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root, Fprin1_to_string (UINT8_DECODE (ct->property[i]), Qnil), db, Qt); - put_char_id_table (root, make_char (c), Qunloaded); } } else @@ -647,7 +655,6 @@ save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root, Fprin1_to_string (UINT16_DECODE (ct->property[i]), Qnil), db, Qt); - put_char_id_table (root, make_char (c), Qunloaded); } } else @@ -927,7 +934,6 @@ save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root, Fput_database (Fprin1_to_string (make_char (c), Qnil), Fprin1_to_string (v, Qnil), db, Qt); - put_char_id_table (root, make_char (c), Qunloaded); } } else @@ -1053,12 +1059,11 @@ 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; @@ -1130,33 +1135,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, /* @@ -1270,6 +1267,7 @@ mark_char_table (Lisp_Object obj) mark_object (ct->table); mark_object (ct->name); + mark_object (ct->db); #else int i; @@ -1599,6 +1597,7 @@ static const struct lrecord_description char_table_description[] = { { 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 @@ -1800,6 +1799,7 @@ and 'syntax. See `valid-char-table-type-p'. ct->mirror_table = Qnil; #else ct->name = Qnil; + ct->db = Qnil; #endif ct->next_table = Qnil; XSETCHAR_TABLE (obj, ct); @@ -1874,6 +1874,7 @@ as CHAR-TABLE. The values will not themselves be copied. 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)) { @@ -2721,10 +2722,6 @@ map_char_table_for_charset_fun (struct chartab_range *range, return 0; } -#if defined(HAVE_DATABASE) -EXFUN (Fload_char_attribute_table, 1); -#endif - #endif /* Map FN (with client data ARG) over range RANGE in char table CT. @@ -3160,8 +3157,6 @@ Store CHARACTER's ATTRIBUTE with VALUE. } else if (EQ (attribute, Q_decomposition)) { - Lisp_Object seq; - CHECK_CHAR (character); if (!CONSP (value)) signal_simple_error ("Invalid value for ->decomposition", @@ -3169,42 +3164,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)) + { + modifier = make_char (XINT (modifier)); + Fsetcar (Fcdr (value), modifier); + } + if (CHARP (base)) { - 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; + 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); } } } @@ -3230,9 +3214,7 @@ Store CHARACTER's ATTRIBUTE with VALUE. make_char (c), Fcons (character, ret)); } } - seq = make_vector (1, v); } - value = seq; } else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs)) { @@ -3306,6 +3288,7 @@ 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) @@ -3357,7 +3340,7 @@ char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute, 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. */ @@ -3367,16 +3350,16 @@ Save values of ATTRIBUTE into database file. Lisp_Object table = Fgethash (attribute, Vchar_attribute_hash_table, Qunbound); Lisp_Char_Table *ct; - Lisp_Object db; 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, Qnil, Qnil); + db = Fopen_database (db_file, Qnil, Qnil, build_string ("w+"), Qnil); if (!NILP (db)) { if (UINT8_BYTE_TABLE_P (ct->table)) @@ -3395,6 +3378,57 @@ Save values of ATTRIBUTE into database file. #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. */ @@ -3417,6 +3451,9 @@ Reset values of ATTRIBUTE with database file. } 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; } @@ -3424,29 +3461,39 @@ Reset values of ATTRIBUTE with database file. return Qnil; } -#ifdef HAVE_DATABASE Lisp_Object -load_char_attribute_maybe (Emchar ch, Lisp_Object attribute) +load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch) { - Lisp_Object db; - Lisp_Object db_file - = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + Lisp_Object attribute = CHAR_TABLE_NAME (cit); - db = Fopen_database (db_file, Qnil, Qnil, Qnil, Qnil); - if (!NILP (db)) + if (!NILP (attribute)) { - Lisp_Object val - = Fget_database (Fprin1_to_string (make_char (ch), Qnil), - db, Qunbound); - if (!UNBOUNDP (val)) - val = Fread (val); - else - val = Qunbound; - Fclose_database (db); - return val; + 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; + } } - else - return Qunbound; + return Qunbound; } Lisp_Char_Table* char_attribute_table_to_load; @@ -3461,50 +3508,50 @@ For internal use. Don't use it. { Lisp_Object c = Fread (key); Emchar code = XCHAR (c); - Lisp_Object ret = get_char_id_table (char_attribute_table_to_load, code); + 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; } -#endif DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /* Load values of ATTRIBUTE into database file. */ (attribute)) { -#ifdef HAVE_DATABASE - Lisp_Object db; - Lisp_Object db_file - = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); - - db = Fopen_database (db_file, Qnil, Qnil, Qnil, Qnil); - if (!NILP (db)) + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + if (CHAR_TABLEP (table)) { - Lisp_Object table = Fgethash (attribute, - Vchar_attribute_hash_table, - Qunbound); - struct gcpro gcpro1, gcpro2; + Lisp_Char_Table *ct = XCHAR_TABLE (table); - if (CHAR_TABLEP (table)) - char_attribute_table_to_load = XCHAR_TABLE (table); - else + if (NILP (Fdatabase_live_p (ct->db))) { - Fclose_database (db); - return Qnil; + 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; } - GCPRO2 (db, table); - Fmap_database (Qload_char_attribute_table_map_function, db); - UNGCPRO; - Fclose_database (db); - XCHAR_TABLE_UNLOADED(table) = 0; - return Qt; } - else - return Qnil; -#endif + return Qnil; } +#endif DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 3, 0, /* Map FUNCTION over entries in ATTRIBUTE, calling it with two args, @@ -4005,6 +4052,7 @@ syms_of_chartab (void) 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"); @@ -4027,14 +4075,16 @@ syms_of_chartab (void) 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); -#ifdef HAVE_DATABASE + 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); -#endif DEFSUBR (Fload_char_attribute_table); +#endif DEFSUBR (Fchar_attribute_alist); DEFSUBR (Fget_char_attribute); DEFSUBR (Fput_char_attribute); @@ -4094,11 +4144,14 @@ void vars_of_chartab (void) { #ifdef UTF2000 - staticpro (&Vcharacter_composition_table); - Vcharacter_composition_table = make_char_id_table (Qnil); - staticpro (&Vcharacter_variant_table); Vcharacter_variant_table = make_char_id_table (Qunbound); + +#ifdef HAVE_DATABASE + DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /* +*/ ); + Vchar_db_stingy_mode = Qt; +#endif /* HAVE_DATABASE */ #endif /* DO NOT staticpro this. It works just like Vweak_hash_tables. */ Vall_syntax_tables = Qnil;