X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fchartab.c;h=7c1408ae227f3718f1b14b411614f0334e946b83;hb=8b6b965da075da197b3d654db3405aa6846bd3d8;hp=142c03a8d10942d0107bb8b44f91d7324d6acd80;hpb=b46558ef54593b88b68eb30d3d182093a8e6331c;p=chise%2Fxemacs-chise.git.1 diff --git a/src/chartab.c b/src/chartab.c index 142c03a..7c1408ae 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -4,7 +4,8 @@ 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,2003 MORIOKA Tomohiko + Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008, + 2010, 2011, 2012, 2013, 2015, 2016 MORIOKA Tomohiko This file is part of XEmacs. @@ -34,7 +35,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 + MORIOKA Tomohiko: Rewritten for XEmacs CHISE */ #include @@ -63,14 +64,27 @@ Lisp_Object Vword_combining_categories, Vword_separating_categories; #endif /* MULE */ +#ifdef HAVE_LIBCHISE +Lisp_Object Vchise_db_directory; +Lisp_Object Vchise_system_db_directory; + +CHISE_DS *default_chise_data_source = NULL; +#endif + #ifdef UTF2000 EXFUN (Fchar_refs_simplify_char_specs, 1); extern Lisp_Object Qideographic_structure; +Lisp_Object Vnext_defined_char_id; + EXFUN (Fmap_char_attribute, 3); -#if defined(HAVE_CHISE_CLIENT) +#ifdef HAVE_LIBCHISE +EXFUN (Fmount_char_attribute_table, 1); +#endif + +#ifdef HAVE_CHISE EXFUN (Fload_char_attribute_table, 1); Lisp_Object Vchar_db_stingy_mode; @@ -86,7 +100,7 @@ Lisp_Object Vchar_db_stingy_mode; INLINE_HEADER int INT_UINT8_P (Lisp_Object obj); INLINE_HEADER int UINT8_VALUE_P (Lisp_Object obj); INLINE_HEADER unsigned char UINT8_ENCODE (Lisp_Object obj); -INLINE_HEADER Lisp_Object UINT8_DECODE (unsigned char n); +/* INLINE_HEADER */ Lisp_Object UINT8_DECODE (unsigned char n); INLINE_HEADER unsigned short UINT8_TO_UINT16 (unsigned char n); INLINE_HEADER int @@ -124,7 +138,7 @@ UINT8_ENCODE (Lisp_Object obj) return XINT (obj); } -INLINE_HEADER Lisp_Object +/* INLINE_HEADER */ Lisp_Object UINT8_DECODE (unsigned char n) { if (n == BT_UINT8_unloaded) @@ -318,10 +332,14 @@ map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root, return retval; } -#ifdef HAVE_CHISE_CLIENT +#ifdef HAVE_CHISE static void save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root, +#ifdef HAVE_LIBCHISE + CHISE_Feature feature, +#else Lisp_Object db, +#endif Emchar ofs, int place, Lisp_Object (*filter)(Lisp_Object value)) { @@ -337,17 +355,25 @@ save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root, { if (ct->property[i] == BT_UINT8_unloaded) { - c1 = c + unit; + c += unit; } else if (ct->property[i] != BT_UINT8_unbound) { c1 = c + unit; for (; c < c1 && retval == 0; c++) { +#ifdef HAVE_LIBCHISE + chise_char_set_feature_value + (c, feature, + XSTRING_DATA + (Fprin1_to_string (UINT8_DECODE (ct->property[i]), + Qnil))); +#else Fput_database (Fprin1_to_string (make_char (c), Qnil), Fprin1_to_string (UINT8_DECODE (ct->property[i]), Qnil), db, Qt); +#endif } } else @@ -366,7 +392,7 @@ save_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Lisp_Char_Table* root, INLINE_HEADER int INT_UINT16_P (Lisp_Object obj); INLINE_HEADER int UINT16_VALUE_P (Lisp_Object obj); INLINE_HEADER unsigned short UINT16_ENCODE (Lisp_Object obj); -INLINE_HEADER Lisp_Object UINT16_DECODE (unsigned short us); +/* INLINE_HEADER */ Lisp_Object UINT16_DECODE (unsigned short us); INLINE_HEADER int INT_UINT16_P (Lisp_Object obj) @@ -403,7 +429,7 @@ UINT16_ENCODE (Lisp_Object obj) return XINT (obj); } -INLINE_HEADER Lisp_Object +/* INLINE_HEADER */ Lisp_Object UINT16_DECODE (unsigned short n) { if (n == BT_UINT16_unloaded) @@ -630,10 +656,14 @@ map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root, return retval; } -#ifdef HAVE_CHISE_CLIENT +#ifdef HAVE_CHISE static void save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root, +#ifdef HAVE_LIBCHISE + CHISE_Feature feature, +#else Lisp_Object db, +#endif Emchar ofs, int place, Lisp_Object (*filter)(Lisp_Object value)) { @@ -649,17 +679,25 @@ save_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Lisp_Char_Table* root, { if (ct->property[i] == BT_UINT16_unloaded) { - c1 = c + unit; + c += unit; } else if (ct->property[i] != BT_UINT16_unbound) { c1 = c + unit; for (; c < c1 && retval == 0; c++) { +#ifdef HAVE_LIBCHISE + chise_char_set_feature_value + (c, feature, + XSTRING_DATA + (Fprin1_to_string (UINT16_DECODE (ct->property[i]), + Qnil))); +#else Fput_database (Fprin1_to_string (make_char (c), Qnil), Fprin1_to_string (UINT16_DECODE (ct->property[i]), Qnil), db, Qt); +#endif } } else @@ -891,10 +929,14 @@ map_over_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root, return retval; } -#ifdef HAVE_CHISE_CLIENT +#ifdef HAVE_CHISE static void save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root, +#ifdef HAVE_LIBCHISE + CHISE_Feature feature, +#else Lisp_Object db, +#endif Emchar ofs, int place, Lisp_Object (*filter)(Lisp_Object value)) { @@ -908,19 +950,34 @@ save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root, v = ct->property[i]; if (UINT8_BYTE_TABLE_P (v)) { - save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, db, + save_uint8_byte_table (XUINT8_BYTE_TABLE(v), root, +#ifdef HAVE_LIBCHISE + feature, +#else + db, +#endif c, place - 1, filter); c += unit; } else if (UINT16_BYTE_TABLE_P (v)) { - save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, db, + save_uint16_byte_table (XUINT16_BYTE_TABLE(v), root, +#ifdef HAVE_LIBCHISE + feature, +#else + db, +#endif c, place - 1, filter); c += unit; } else if (BYTE_TABLE_P (v)) { - save_byte_table (XBYTE_TABLE(v), root, db, + save_byte_table (XBYTE_TABLE(v), root, +#ifdef HAVE_LIBCHISE + feature, +#else + db, +#endif c, place - 1, filter); c += unit; } @@ -940,9 +997,14 @@ save_byte_table (Lisp_Byte_Table *ct, Lisp_Char_Table* root, for (; c < c1 && retval == 0; c++) { +#ifdef HAVE_LIBCHISE + chise_char_set_feature_value + (c, feature, XSTRING_DATA (Fprin1_to_string (v, Qnil))); +#else Fput_database (Fprin1_to_string (make_char (c), Qnil), Fprin1_to_string (v, Qnil), db, Qt); +#endif } } else @@ -1068,10 +1130,24 @@ make_char_id_table (Lisp_Object initval) } -Lisp_Object Qsystem_char_id; - Lisp_Object Qcomposition; +Lisp_Object Qrep_decomposition; +Lisp_Object Qto_decomposition_at_superscript; +Lisp_Object Qto_decomposition_at_circled; +Lisp_Object Q_canonical; +Lisp_Object Q_halfwidth_of; +Lisp_Object Q_superscript_of; +Lisp_Object Q_subscript_of; +Lisp_Object Q_circled_of; Lisp_Object Q_decomposition; +Lisp_Object Q_identical; +Lisp_Object Q_identical_from; +Lisp_Object Q_denotational; +Lisp_Object Q_denotational_from; +Lisp_Object Q_subsumptive; +Lisp_Object Q_subsumptive_from; +Lisp_Object Q_component; +Lisp_Object Q_component_of; Lisp_Object Qto_ucs; Lisp_Object Q_ucs_unified; Lisp_Object Qcompat; @@ -1157,7 +1233,8 @@ Return character corresponding with list. modifier = Fcar (rest); rest = Fcdr (rest); base = Fcdr (Fassq (modifier, - Fget_char_attribute (base, Qcomposition, Qnil))); + Fchar_feature (base, Qcomposition, Qnil, + Qnil, Qnil))); } return base; } @@ -1167,14 +1244,16 @@ Return variants of CHARACTER. */ (character)) { - Lisp_Object ret; - CHECK_CHAR (character); - ret = Fget_char_attribute (character, Q_ucs_unified, Qnil); - if (CONSP (ret)) - return Fcopy_list (ret); - else - return Qnil; + return + nconc2 + (Fcopy_list (Fget_char_attribute (character, Q_subsumptive, Qnil)), + (nconc2 + (Fcopy_list (Fget_char_attribute (character, Q_denotational, Qnil)), + (nconc2 + (Fcopy_list (Fget_char_attribute (character, Q_identical, Qnil)), + Fcopy_list (Fchar_feature (character, Q_ucs_unified, Qnil, + Qnil, Qnil))))))); } #endif @@ -1272,7 +1351,9 @@ mark_char_table (Lisp_Object obj) mark_object (ct->table); mark_object (ct->name); +#ifndef HAVE_LIBCHISE mark_object (ct->db); +#endif #else int i; @@ -1320,7 +1401,7 @@ char_table_type_to_symbol (enum char_table_type type) { switch (type) { - default: abort(); + default: ABORT(); case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; @@ -1348,6 +1429,7 @@ symbol_to_char_table_type (Lisp_Object symbol) return CHAR_TABLE_TYPE_GENERIC; /* not reached */ } +#ifndef UTF2000 static void print_chartab_range (Emchar first, Emchar last, Lisp_Object val, Lisp_Object printcharfun) @@ -1368,6 +1450,7 @@ print_chartab_range (Emchar first, Emchar last, Lisp_Object val, } print_internal (val, printcharfun, 1); } +#endif #if defined(MULE)&&!defined(UTF2000) @@ -1602,7 +1685,9 @@ 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) }, +#ifndef HAVE_LIBCHISE { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, db) }, +#endif #else { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS }, #ifdef MULE @@ -1637,15 +1722,17 @@ once per character). When Mule support exists, the types of ranges that can be assigned values are --- all characters +-- all characters (represented by t) -- an entire charset --- a single row in a two-octet charset +-- a single row in a two-octet charset (represented by a vector of two + elements: a two-octet charset and a row number; the row must be an + integer, not a character) -- a single character When Mule support is not present, the types of ranges that can be assigned values are --- all characters +-- all characters (represented by t) -- a single character To create a char table, use `make-char-table'. @@ -1774,7 +1861,7 @@ Reset CHAR-TABLE to its default state. break; default: - abort (); + ABORT (); } return Qnil; @@ -1804,8 +1891,10 @@ and 'syntax. See `valid-char-table-type-p'. ct->mirror_table = Qnil; #else ct->name = Qnil; +#ifndef HAVE_LIBCHISE ct->db = Qnil; #endif +#endif ct->next_table = Qnil; XSETCHAR_TABLE (obj, ct); if (ty == CHAR_TABLE_TYPE_SYNTAX) @@ -1879,7 +1968,9 @@ 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; +#ifndef HAVE_LIBCHISE ctnew->db = ct->db; +#endif if (UINT8_BYTE_TABLE_P (ct->table)) { @@ -1953,7 +2044,7 @@ XCHARSET_CELL_RANGE (Lisp_Object ccs) return (0 << 8) | 255; #endif default: - abort (); + ABORT (); return 0; } } @@ -2015,7 +2106,7 @@ decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) } #endif else - abort (); + ABORT (); } else { @@ -2074,13 +2165,15 @@ get_char_table (Emchar ch, Lisp_Char_Table *ct) { Lisp_Object ret = get_char_id_table (ct, ch); -#ifdef HAVE_CHISE_CLIENT +#ifdef HAVE_CHISE if (NILP (ret)) { if (EQ (CHAR_TABLE_NAME (ct), Qdowncase)) - ret = Fget_char_attribute (make_char (ch), Q_lowercase, Qnil); + ret = Fchar_feature (make_char (ch), Q_lowercase, Qnil, + Qnil, Qnil); else if (EQ (CHAR_TABLE_NAME (ct), Qflippedcase)) - ret = Fget_char_attribute (make_char (ch), Q_uppercase, Qnil); + ret = Fchar_feature (make_char (ch), Q_uppercase, Qnil, + Qnil, Qnil); if (CONSP (ret)) { ret = XCAR (ret); @@ -2141,8 +2234,11 @@ Find value for CHARACTER in CHAR-TABLE. } DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /* -Find value for a range in CHAR-TABLE. +Find value for RANGE in CHAR-TABLE. If there is more than one value, return MULTI (defaults to nil). + +Valid values for RANGE are single characters, charsets, a row in a +two-octet charset, and all characters. See `put-char-table'. */ (range, char_table, multi)) { @@ -2246,8 +2342,13 @@ If there is more than one value, return MULTI (defaults to nil). #endif /* not UTF2000 */ #endif /* not MULE */ +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + return ct->default_value; +#endif /* not UTF2000 */ + default: - abort (); + ABORT (); } return Qnil; /* not reached */ @@ -2297,7 +2398,7 @@ check_valid_char_table_value (Lisp_Object value, enum char_table_type type, break; default: - abort (); + ABORT (); } return 0; /* not reached */ @@ -2373,7 +2474,6 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, switch (range->type) { case CHARTAB_RANGE_ALL: - /* printf ("put-char-table: range = all\n"); */ fill_char_table (ct, val); return; /* avoid the duplicate call to update_syntax_table() below, since fill_char_table() also did that. */ @@ -2390,9 +2490,6 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, { 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) ) { Lisp_Object mother = XCHARSET_MOTHER (range->charset); @@ -2455,7 +2552,8 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, cell_max = i & 0xFF; for (i = cell_min; i <= cell_max; i++) { - Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i); + Emchar ch + = DECODE_CHAR (range->charset, (range->row << 8) | i, 0); if ( charset_code_point (range->charset, ch, 0) >= 0 ) put_char_id_table_0 (ct, ch, val); @@ -2477,7 +2575,6 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, 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) @@ -2536,8 +2633,9 @@ 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 vector of two elements: a two-octet charset and a row number; the row + must be an integer, not a character (only allowed when Mule support is + present) -- A single character VALUE must be a value appropriate for the type of CHAR-TABLE. @@ -2747,7 +2845,7 @@ map_char_table_for_charset_fun (struct chartab_range *range, break; default: - abort (); + ABORT (); } return 0; @@ -2863,7 +2961,7 @@ map_char_table (Lisp_Char_Table *ct, struct chartab_range rainj; struct map_char_table_for_charset_arg mcarg; -#ifdef HAVE_CHISE_CLIENT +#ifdef HAVE_CHISE if (XCHAR_TABLE_UNLOADED(encoding_table)) Fload_char_attribute_table (XCHAR_TABLE_NAME (encoding_table)); #endif @@ -2897,7 +2995,8 @@ map_char_table (Lisp_Char_Table *ct, 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); + Emchar ch + = DECODE_CHAR (range->charset, (range->row << 8) | i, 0); if ( charset_code_point (range->charset, ch, 0) >= 0 ) { @@ -2957,7 +3056,7 @@ map_char_table (Lisp_Char_Table *ct, } default: - abort (); + ABORT (); } return 0; @@ -3003,7 +3102,7 @@ slow_map_char_table_fun (struct chartab_range *range, ranjarg = make_char (range->ch); break; default: - abort (); + ABORT (); } closure->retval = call2 (closure->function, ranjarg, val); @@ -3011,8 +3110,8 @@ slow_map_char_table_fun (struct chartab_range *range, } 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. +Map FUNCTION over CHAR-TABLE until it returns non-nil; return that value. +FUNCTION is called with two arguments, each key and entry 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 @@ -3070,15 +3169,37 @@ add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value, return 0; } +#ifdef HAVE_LIBCHISE +static int +char_attribute_list_reset_map_func (CHISE_DS *ds, unsigned char *name) +{ + Fmount_char_attribute_table (intern (name)); + return 0; +} + +DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 1, 0, /* +Return the list of all existing character attributes except coded-charsets. +*/ + (rehash)) +#else DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /* Return the list of all existing character attributes except coded-charsets. */ ()) +#endif { Lisp_Object char_attribute_list = Qnil; struct gcpro gcpro1; struct char_attribute_list_closure char_attribute_list_closure; +#ifdef HAVE_LIBCHISE + if (!NILP (rehash)) + { + open_chise_data_source_maybe (); + chise_ds_foreach_char_feature_name + (default_chise_data_source, &char_attribute_list_reset_map_func); + } +#endif GCPRO1 (char_attribute_list); char_attribute_list_closure.char_attribute_list = &char_attribute_list; elisp_maphash (add_char_attribute_to_list_mapper, @@ -3149,6 +3270,43 @@ Return the alist of attributes of CHARACTER. return alist; } +DEFUN ("char-feature-base-name=", Fchar_feature_base_name_eq, 2, 2, 0, /* +Return the alist of attributes of CHARACTER. +*/ + (base_name, feature_name)) +{ + Lisp_String *bn, *fn; + Bytecount len_bn, len_fn, i; + Bufbyte *ptr_bn, *ptr_fn; + + CHECK_SYMBOL (base_name); + CHECK_SYMBOL (feature_name); + + bn = XSYMBOL (base_name)->name; + fn = XSYMBOL (feature_name)->name; + len_bn = string_length (bn); + len_fn = string_length (fn); + + if ( len_bn > len_fn ) + return Qnil; + + ptr_bn = string_data (bn); + ptr_fn = string_data (fn); + for ( i = len_fn - 1; i >= 0; i-- ) + { + if ( ptr_fn[i] == '*' ) + return Qnil; + if ( ptr_fn[i] == '@' ) + break; + } + if ( i < 0 ) + i = len_fn; + if ( (len_bn == i) && (memcmp (ptr_bn, ptr_fn, len_bn) == 0) ) + return Qt; + else + return Qnil; +} + 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. @@ -3174,20 +3332,164 @@ Return DEFAULT-VALUE if the value is not exist. return default_value; } -void put_char_composition (Lisp_Object character, Lisp_Object value); -void +static Lisp_Object +find_char_feature_in_family (Lisp_Object character, + Lisp_Object con_feature, + Lisp_Object feature, + Lisp_Object feature_rel_max) +{ + Lisp_Object ancestors + = Fget_char_attribute (character, con_feature, Qnil); +#if 0 + + while (!NILP (ancestors)) + { + Lisp_Object ancestor = XCAR (ancestors); + Lisp_Object ret; + + if (EQ (ancestor, character)) + return Qunbound; + + ret = Fchar_feature (ancestor, feature, Qunbound, + Qnil, make_int (0)); + if (!UNBOUNDP (ret)) + return ret; + + ancestors = XCDR (ancestors); + + ret = Fget_char_attribute (ancestor, Q_subsumptive_from, Qnil); + if (!NILP (ret)) + ancestors = nconc2 (Fcopy_sequence (ancestors), ret); + + ret = Fget_char_attribute (ancestor, Q_denotational_from, Qnil); + if (!NILP (ret)) + ancestors = nconc2 (Fcopy_sequence (ancestors), ret); + } +#else + Lisp_Object ancestor; + + if (CONSP (ancestors)) + ancestor = XCAR (ancestors); + else + ancestor = ancestors; + + if (!NILP (ancestor)) + { + Lisp_Object ret; + Lisp_Object anc; + + if (EQ (ancestor, character)) + return Qunbound; + + ret = Fchar_feature (ancestor, feature, Qunbound, + Qnil, make_int (0)); + if (!UNBOUNDP (ret)) + return ret; + + ret = find_char_feature_in_family (ancestor, Q_subsumptive_from, + feature, feature_rel_max); + if (!UNBOUNDP (ret)) + return ret; + + ret = find_char_feature_in_family (ancestor, Q_denotational_from, + feature, feature_rel_max); + if (!UNBOUNDP (ret)) + return ret; + } +#endif + return Qunbound; +} + +DEFUN ("char-feature", Fchar_feature, 2, 5, 0, /* +Return the value of CHARACTER's FEATURE. +Return DEFAULT-VALUE if the value is not exist. +*/ + (character, attribute, default_value, + feature_rel_max, char_rel_max)) +{ + Lisp_Object ret + = Fget_char_attribute (character, attribute, Qunbound); + + if (!UNBOUNDP (ret)) + return ret; + +#if 0 + if (NILP (feature_rel_max) + || (INTP (feature_rel_max) && + XINT (feature_rel_max) > 0)) + { + Lisp_String* name = symbol_name (XSYMBOL (attribute)); + Bufbyte *name_str = string_data (name); + + if (name_str[0] == '=' && name_str[1] == '>') + { + Bytecount length = string_length (name) - 1; + Lisp_Object map_to = make_uninit_string (length); + + memcpy (XSTRING_DATA (map_to) + 1, name_str + 2, length - 1); + XSTRING_DATA(map_to)[0] = '='; + ret = Fchar_feature (character, Fintern (map_to, Qnil), + Qunbound, + NILP (feature_rel_max) + ? feature_rel_max + : make_int (XINT (feature_rel_max) - 1), + char_rel_max); + if (!UNBOUNDP (ret)) + return ret; + } + } +#endif + + if ( !(EQ (attribute, Q_identical)) && + !(EQ (attribute, Q_subsumptive_from)) && + !(EQ (attribute, Q_denotational_from)) && + ( (NILP (char_rel_max) + || (INTP (char_rel_max) && + XINT (char_rel_max) > 0)) ) ) + { +#if 0 + Lisp_String* name = symbol_name (XSYMBOL (attribute)); + Bufbyte *name_str = string_data (name); + + if ( (name_str[0] != '=') || (name_str[1] == '>') ) + { +#endif + ret = find_char_feature_in_family (character, Q_identical, + attribute, feature_rel_max); + if (!UNBOUNDP (ret)) + return ret; + + ret = find_char_feature_in_family (character, Q_subsumptive_from, + attribute, feature_rel_max); + if (!UNBOUNDP (ret)) + return ret; + + ret = find_char_feature_in_family (character, Q_denotational_from, + attribute, feature_rel_max); + if (!UNBOUNDP (ret)) + return ret; +#if 0 + } +#endif + } + return default_value; +} + +Lisp_Object +put_char_composition (Lisp_Object character, Lisp_Object value); +Lisp_Object put_char_composition (Lisp_Object character, Lisp_Object value) { if (!CONSP (value)) - signal_simple_error ("Invalid value for ->decomposition", + signal_simple_error ("Invalid value for =decomposition", value); - if (CONSP (Fcdr (value))) + if (CONSP (XCDR (value))) { - if (NILP (Fcdr (Fcdr (value)))) + if (NILP (Fcdr (XCDR (value)))) { - Lisp_Object base = Fcar (value); - Lisp_Object modifier = Fcar (Fcdr (value)); + Lisp_Object base = XCAR (value); + Lisp_Object modifier = XCAR (XCDR (value)); if (INTP (base)) { @@ -3197,12 +3499,13 @@ put_char_composition (Lisp_Object character, Lisp_Object value) if (INTP (modifier)) { modifier = make_char (XINT (modifier)); - Fsetcar (Fcdr (value), modifier); + Fsetcar (XCDR (value), modifier); } if (CHARP (base)) { Lisp_Object alist - = Fget_char_attribute (base, Qcomposition, Qnil); + = Fchar_feature (base, Qcomposition, Qnil, + Qnil, Qnil); Lisp_Object ret = Fassq (modifier, alist); if (NILP (ret)) @@ -3212,17 +3515,50 @@ put_char_composition (Lisp_Object character, Lisp_Object value) else Fsetcdr (ret, character); } + else if (EQ (base, Qnarrow)) + return Q_halfwidth_of; + else if (EQ (base, Qsuper)) + return Q_superscript_of; + else if (EQ (base, Qsub)) + return Q_subscript_of; + else if (EQ (base, Qcircle)) + return Q_circled_of; + else if ( EQ (base, Qisolated)|| + EQ (base, Qinitial) || + EQ (base, Qmedial) || + EQ (base, Qfinal) ) + return + Fintern (concat2 (build_string ("<-formed@"), + Fsymbol_name (base)), + Qnil); + else if (SYMBOLP (base)) + return + Fintern (concat2 (build_string ("<-"), + Fsymbol_name (base)), + Qnil); } + else if (EQ (XCAR (value), Qsuper)) + return Qto_decomposition_at_superscript; + else if (EQ (XCAR (value), Qcircle)) + return Qto_decomposition_at_circled; + else + return + Fintern (concat2 (build_string ("=>decomposition@"), + Fsymbol_name (XCAR (value))), + Qnil); } else { + return Q_canonical; +#if 0 Lisp_Object v = Fcar (value); if (INTP (v)) { - Emchar c = XINT (v); + Emchar c = DECODE_CHAR (Vcharset_ucs, XINT (v), 0); Lisp_Object ret - = Fget_char_attribute (make_char (c), Q_ucs_unified, Qnil); + = Fchar_feature (make_char (c), Q_ucs_unified, Qnil, + Qnil, Qnil); if (!CONSP (ret)) { @@ -3235,7 +3571,29 @@ put_char_composition (Lisp_Object character, Lisp_Object value) Fcons (character, ret)); } } +#endif + } + return Qrep_decomposition; +} + +static Lisp_Object +put_char_attribute (Lisp_Object character, Lisp_Object attribute, + Lisp_Object value) +{ + 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_CHISE + XCHAR_TABLE_NAME (table) = attribute; +#endif } + put_char_id_table (XCHAR_TABLE(table), character, value); + return value; } DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /* @@ -3249,11 +3607,36 @@ Store CHARACTER's ATTRIBUTE with VALUE. if (!NILP (ccs)) { - value = put_char_ccs_code_point (character, ccs, value); + if ( !NILP (value) ) + value = put_char_ccs_code_point (character, ccs, value); attribute = XCHARSET_NAME (ccs); } - else if (EQ (attribute, Q_decomposition)) - put_char_composition (character, value); + else if ( +#if 0 + EQ (attribute, Qrep_decomposition) || +#else + !NILP (Fchar_feature_base_name_eq (Qrep_decomposition, + attribute)) || +#endif + EQ (attribute, Q_decomposition) /* || */ +#if 0 + !NILP (Fstring_match (build_string ("^=decomposition@[^*]+$"), + Fsymbol_name (attribute), + Qnil, Qnil)) +#endif + ) + { + Lisp_Object ret; + + value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value)); + ret = put_char_composition (character, value); + if ( !EQ (ret, Qrep_decomposition) && + SYMBOLP (XCAR (value)) ) + { + attribute = ret; + value = XCDR (value); + } + } else if (EQ (attribute, Qto_ucs)) { Lisp_Object ret; @@ -3262,40 +3645,130 @@ Store CHARACTER's ATTRIBUTE with VALUE. if (!INTP (value)) signal_simple_error ("Invalid value for =>ucs", value); - c = XINT (value); + c = DECODE_CHAR (Vcharset_ucs, XINT (value), 0); - ret = Fget_char_attribute (make_char (c), Q_ucs_unified, Qnil); + ret = Fchar_feature (make_char (c), Q_ucs_unified, Qnil, + Qnil, Qnil); if (!CONSP (ret)) + put_char_attribute (make_char (c), Q_ucs_unified, + list1 (character)); + else if (NILP (Fmemq (character, ret))) + Fput_char_attribute (make_char (c), Q_ucs_unified, + Fcons (character, ret)); + } + if ( EQ (attribute, Q_subsumptive) || + EQ (attribute, Q_subsumptive_from) || + EQ (attribute, Q_denotational) || + EQ (attribute, Q_denotational_from) || + EQ (attribute, Q_identical) || + EQ (attribute, Q_identical_from) || + EQ (attribute, Q_canonical) || + EQ (attribute, Q_halfwidth_of) || + EQ (attribute, Q_superscript_of) || + EQ (attribute, Q_subscript_of) || + EQ (attribute, Q_circled_of) || + EQ (attribute, Q_component) || + EQ (attribute, Q_component_of) || + ( !EQ (attribute, Q_ucs_unified) + && !NILP (Fstring_match + (build_string ("^\\(<-\\|->\\)[^*]*$"), + Fsymbol_name (attribute), + Qnil, Qnil)) + ) + ) + { + Lisp_Object rest = value; + Lisp_Object ret; + Lisp_Object rev_feature = Qnil; + struct gcpro gcpro1; + GCPRO1 (rev_feature); + + if (EQ (attribute, Q_identical)) + rev_feature = Q_identical_from; + else if (EQ (attribute, Q_identical_from)) + rev_feature = Q_identical; + else if (EQ (attribute, Q_subsumptive)) + rev_feature = Q_subsumptive_from; + else if (EQ (attribute, Q_subsumptive_from)) + rev_feature = Q_subsumptive; + else if (EQ (attribute, Q_denotational)) + rev_feature = Q_denotational_from; + else if (EQ (attribute, Q_denotational_from)) + rev_feature = Q_denotational; + else if (EQ (attribute, Q_component)) + rev_feature = Q_component_of; + else if (EQ (attribute, Q_component_of)) + rev_feature = Q_component; + else { - Fput_char_attribute (make_char (c), Q_ucs_unified, - Fcons (character, Qnil)); + Lisp_String* name = symbol_name (XSYMBOL (attribute)); + Bufbyte *name_str = string_data (name); + + if ( (name_str[0] == '<' && name_str[1] == '-') || + (name_str[0] == '-' && name_str[1] == '>') ) + { + Bytecount length = string_length (name); + Bufbyte *rev_name_str = alloca (length + 1); + + memcpy (rev_name_str + 2, name_str + 2, length - 2); + if (name_str[0] == '<') + { + rev_name_str[0] = '-'; + rev_name_str[1] = '>'; + } + else + { + rev_name_str[0] = '<'; + rev_name_str[1] = '-'; + } + rev_name_str[length] = 0; + rev_feature = intern (rev_name_str); + } } - else if (NILP (Fmemq (character, ret))) + + while (CONSP (rest)) { - Fput_char_attribute (make_char (c), Q_ucs_unified, - Fcons (character, ret)); + ret = XCAR (rest); + + if (CONSP (ret)) + ret = Fdefine_char (ret); + else if (INTP (ret)) + { + int code_point = XINT (ret); + Emchar cid = DECODE_CHAR (Vcharset_ucs, code_point, 0); + + if (cid >= 0) + ret = make_char (cid); + else + ret = make_char (code_point); + } + + if ( !NILP (ret) && !EQ (ret, character) ) + { + Lisp_Object ffv; + + ffv = Fget_char_attribute (ret, rev_feature, Qnil); + if (!CONSP (ffv)) + put_char_attribute (ret, rev_feature, list1 (character)); + else if (NILP (Fmemq (character, ffv))) + put_char_attribute + (ret, rev_feature, + nconc2 (Fcopy_sequence (ffv), list1 (character))); + Fsetcar (rest, ret); + } + rest = XCDR (rest); } + UNGCPRO; } -#if 0 - else if (EQ (attribute, Qideographic_structure)) +#if 1 + else if ( EQ (attribute, Qideographic_structure) || + !NILP (Fstring_match + (build_string ("^=>decomposition\\(\\|@[^*]+\\)$"), + Fsymbol_name (attribute), + Qnil, Qnil)) ) value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value)); #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_CHISE_CLIENT - XCHAR_TABLE_NAME (table) = attribute; -#endif - } - put_char_id_table (XCHAR_TABLE(table), character, value); - return value; - } + return put_char_attribute (character, attribute, value); } DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /* @@ -3325,17 +3798,168 @@ Remove CHARACTER's ATTRIBUTE. return Qnil; } -#ifdef HAVE_CHISE_CLIENT +#ifdef HAVE_CHISE + +int char_table_open_db_maybe (Lisp_Char_Table* cit); +void char_table_close_db_maybe (Lisp_Char_Table* cit); +Lisp_Object char_table_get_db (Lisp_Char_Table* cit, Emchar ch); + +#ifdef HAVE_LIBCHISE +int +open_chise_data_source_maybe () +{ + if (default_chise_data_source == NULL) + { + int modemask = 0755; /* rwxr-xr-x */ + char* db_dir_name; + size_t len; + + if (STRINGP (Vdata_directory)) + { + char* dir_name = XSTRING_DATA (Vdata_directory); + + len = strlen (dir_name) + 8; + db_dir_name = alloca (len + 1); + strncpy (db_dir_name, dir_name, len); + } + else + { + if (STRINGP (current_buffer->directory)) + { + char* dir_name = XSTRING_DATA (current_buffer->directory); + + len = strlen (dir_name) + 7 + 8; + db_dir_name = alloca (len + 1); + strncpy (db_dir_name, dir_name, len); + strncat(db_dir_name, "../etc/", 15); + } + else + { + len = 7 + 8; + db_dir_name = alloca (len + 1); + strncpy (db_dir_name, "../etc/", len); + } + } + strncat(db_dir_name, "chise-db", 8); + + default_chise_data_source = CHISE_DS_open (CHISE_DS_Berkeley_DB, + db_dir_name, + 0 /* DB_HASH */, modemask); + if (default_chise_data_source == NULL) + return -1; + } + return 0; +} +#endif /* HAVE_LIBCHISE */ + +DEFUN ("close-char-data-source", Fclose_char_data_source, 0, 0, 0, /* +Close data-source of CHISE. +*/ + ()) +{ +#ifdef HAVE_LIBCHISE + int status = CHISE_DS_close (default_chise_data_source); + + default_chise_data_source = NULL; + if (status) + return Qt; +#endif /* HAVE_LIBCHISE */ + return Qnil; +} + +int +char_table_open_db_maybe (Lisp_Char_Table* cit) +{ + Lisp_Object attribute = CHAR_TABLE_NAME (cit); + + if (!NILP (attribute)) + { +#ifdef HAVE_LIBCHISE + if ( open_chise_data_source_maybe () ) + return -1; +#else /* HAVE_LIBCHISE */ + 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)) + return -1; + } +#endif /* not HAVE_LIBCHISE */ + return 0; + } + else + return -1; +} + +void +char_table_close_db_maybe (Lisp_Char_Table* cit) +{ +#ifndef HAVE_LIBCHISE + if (!NILP (cit->db)) + { + if (!NILP (Fdatabase_live_p (cit->db))) + Fclose_database (cit->db); + cit->db = Qnil; + } +#endif /* not HAVE_LIBCHISE */ +} + +Lisp_Object +char_table_get_db (Lisp_Char_Table* cit, Emchar ch) +{ + Lisp_Object val; +#ifdef HAVE_LIBCHISE + CHISE_Value value; + int status + = chise_ds_load_char_feature_value (default_chise_data_source, ch, + XSTRING_DATA(Fsymbol_name + (cit->name)), + &value); + + if (!status) + { + val = read_from_c_string (chise_value_data (&value), + chise_value_size (&value) ); + } + else + val = Qunbound; +#else /* HAVE_LIBCHISE */ + val = Fget_database (Fprin1_to_string (make_char (ch), Qnil), + cit->db, Qunbound); + if (!UNBOUNDP (val)) + val = Fread (val); + else + val = Qunbound; +#endif /* not HAVE_LIBCHISE */ + return val; +} + +#ifdef USE_CONCORD_OBJECT_SYSTEM +COS_object +char_table_get_db_cos (Lisp_Char_Table* cit, Emchar ch) +{ + return + concord_object_get_attribute + (cos_make_char (ch), + cos_intern (XSTRING_DATA (Fsymbol_name (cit->name)))); +} +#endif + +#ifndef HAVE_LIBCHISE Lisp_Object char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute, int writing_mode) { - Lisp_Object db_dir = Vexec_directory; + Lisp_Object db_dir = Vdata_directory; if (NILP (db_dir)) - db_dir = build_string ("../lib-src"); + db_dir = build_string ("../etc"); - db_dir = Fexpand_file_name (build_string ("char-db"), db_dir); + db_dir = Fexpand_file_name (build_string ("chise-db"), db_dir); if (writing_mode && NILP (Ffile_exists_p (db_dir))) Fmake_directory_internal (db_dir); @@ -3373,55 +3997,103 @@ char_attribute_system_db_file (Lisp_Object key_type, Lisp_Object attribute, UNGCPRO; return Fexpand_file_name (dest, db_dir); } -#if 0 - return Fexpand_file_name (Fsymbol_name (attribute), db_dir); -#endif } +#endif /* not HAVE_LIBCHISE */ DEFUN ("save-char-attribute-table", Fsave_char_attribute_table, 1, 1, 0, /* Save values of ATTRIBUTE into database file. */ (attribute)) { -#ifdef HAVE_CHISE_CLIENT Lisp_Object table = Fgethash (attribute, Vchar_attribute_hash_table, Qunbound); Lisp_Char_Table *ct; +#ifdef HAVE_LIBCHISE + CHISE_Feature feature; +#else /* HAVE_LIBCHISE */ Lisp_Object db_file; Lisp_Object db; +#endif /* not HAVE_LIBCHISE */ if (CHAR_TABLEP (table)) ct = XCHAR_TABLE (table); else return Qnil; +#ifdef HAVE_LIBCHISE + if ( open_chise_data_source_maybe () ) + return -1; + feature + = chise_ds_get_feature (default_chise_data_source, + XSTRING_DATA (Fsymbol_name (attribute))); +#else /* HAVE_LIBCHISE */ 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)) +#endif /* not HAVE_LIBCHISE */ + if ( +#ifdef HAVE_LIBCHISE + feature != NULL +#else /* HAVE_LIBCHISE */ + !NILP (db) +#endif /* not HAVE_LIBCHISE */ + ) { Lisp_Object (*filter)(Lisp_Object value); - if (EQ (attribute, Qideographic_structure)) + if ( !NILP (Ffind_charset (attribute)) ) + filter = NULL; + else if ( EQ (attribute, Qideographic_structure) || + EQ (attribute, Q_identical) || + EQ (attribute, Q_identical_from) || + EQ (attribute, Q_canonical) || + EQ (attribute, Q_halfwidth_of) || + EQ (attribute, Q_superscript_of) || + EQ (attribute, Q_subscript_of) || + EQ (attribute, Q_circled_of) || + !NILP (Fstring_match + (build_string ("^\\(<-\\|->\\)\\(simplified" + "\\|same\\|vulgar\\|wrong" + "\\|original\\|ancient" + "\\|Oracle-Bones\\)[^*]*$"), + Fsymbol_name (attribute), + Qnil, Qnil)) ) filter = &Fchar_refs_simplify_char_specs; else filter = NULL; if (UINT8_BYTE_TABLE_P (ct->table)) - save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, db, + save_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), ct, +#ifdef HAVE_LIBCHISE + feature, +#else /* HAVE_LIBCHISE */ + db, +#endif /* not HAVE_LIBCHISE */ 0, 3, filter); else if (UINT16_BYTE_TABLE_P (ct->table)) - save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, db, + save_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), ct, +#ifdef HAVE_LIBCHISE + feature, +#else /* HAVE_LIBCHISE */ + db, +#endif /* not HAVE_LIBCHISE */ 0, 3, filter); else if (BYTE_TABLE_P (ct->table)) - save_byte_table (XBYTE_TABLE(ct->table), ct, db, 0, 3, filter); + save_byte_table (XBYTE_TABLE(ct->table), ct, +#ifdef HAVE_LIBCHISE + feature, +#else /* HAVE_LIBCHISE */ + db, +#endif /* not HAVE_LIBCHISE */ + 0, 3, filter); +#ifdef HAVE_LIBCHISE + chise_feature_sync (feature); +#else /* HAVE_LIBCHISE */ Fclose_database (db); +#endif /* not HAVE_LIBCHISE */ return Qt; } else return Qnil; -#else - return Qnil; -#endif } DEFUN ("mount-char-attribute-table", Fmount_char_attribute_table, 1, 1, 0, /* @@ -3429,7 +4101,6 @@ Mount database file on char-attribute-table ATTRIBUTE. */ (attribute)) { -#ifdef HAVE_CHISE_CLIENT Lisp_Object table = Fgethash (attribute, Vchar_attribute_hash_table, Qunbound); @@ -3443,10 +4114,11 @@ Mount database file on char-attribute-table ATTRIBUTE. ct = XCHAR_TABLE (table); ct->table = Qunloaded; XCHAR_TABLE_UNLOADED(table) = 1; +#ifndef HAVE_LIBCHISE ct->db = Qnil; +#endif /* not HAVE_LIBCHISE */ return Qt; } -#endif return Qnil; } @@ -3455,7 +4127,6 @@ Close database of ATTRIBUTE. */ (attribute)) { -#ifdef HAVE_CHISE_CLIENT Lisp_Object table = Fgethash (attribute, Vchar_attribute_hash_table, Qunbound); Lisp_Char_Table *ct; @@ -3464,14 +4135,7 @@ Close database of ATTRIBUTE. 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 + char_table_close_db_maybe (ct); return Qnil; } @@ -3480,7 +4144,35 @@ Reset values of ATTRIBUTE with database file. */ (attribute)) { -#ifdef HAVE_CHISE_CLIENT +#ifdef HAVE_LIBCHISE + CHISE_Feature feature + = chise_ds_get_feature (default_chise_data_source, + XSTRING_DATA (Fsymbol_name + (attribute))); + + if (feature == NULL) + return Qnil; + + if (chise_feature_setup_db (feature, 0) == 0) + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, Qunbound); + Lisp_Char_Table *ct; + + chise_feature_sync (feature); + 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; + char_table_close_db_maybe (ct); + XCHAR_TABLE_UNLOADED(table) = 1; + return Qt; + } +#else Lisp_Object table = Fgethash (attribute, Vchar_attribute_hash_table, Qunbound); Lisp_Char_Table *ct; @@ -3497,9 +4189,7 @@ 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; + char_table_close_db_maybe (ct); XCHAR_TABLE_UNLOADED(table) = 1; return Qt; } @@ -3514,36 +4204,64 @@ load_char_attribute_maybe (Lisp_Char_Table* cit, Emchar ch) if (!NILP (attribute)) { - if (NILP (Fdatabase_live_p (cit->db))) - { - Lisp_Object db_file - = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + Lisp_Object val; - 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; - } + if (char_table_open_db_maybe (cit)) + return Qunbound; + + val = char_table_get_db (cit, ch); + + if (!NILP (Vchar_db_stingy_mode)) + char_table_close_db_maybe (cit); + + return val; } return Qunbound; } +#ifdef USE_CONCORD_OBJECT_SYSTEM +COS_object +load_char_attribute_maybe_cos (Lisp_Char_Table* cit, Emchar ch) +{ + Lisp_Object attribute = CHAR_TABLE_NAME (cit); + + if (!NILP (attribute)) + { + COS_object val; + + if (char_table_open_db_maybe (cit)) + return NULL; + + val = char_table_get_db_cos (cit, ch); + + return val; + } + return NULL; +} +#endif + Lisp_Char_Table* char_attribute_table_to_load; +#ifdef HAVE_LIBCHISE +int +load_char_attribute_table_map_func (CHISE_Char_ID cid, + CHISE_Feature feature, + CHISE_Value *value); +int +load_char_attribute_table_map_func (CHISE_Char_ID cid, + CHISE_Feature feature, + CHISE_Value *value) +{ + Emchar code = cid; + 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 (make_string ((Bufbyte *) value->data, + value->size))); + return 0; +} +#else /* HAVE_LIBCHISE */ Lisp_Object Qload_char_attribute_table_map_function; DEFUN ("load-char-attribute-table-map-function", @@ -3560,6 +4278,7 @@ For internal use. Don't use it. put_char_id_table_0 (char_attribute_table_to_load, code, Fread (value)); return Qnil; } +#endif /* not HAVE_LIBCHISE */ DEFUN ("load-char-attribute-table", Fload_char_attribute_table, 1, 1, 0, /* Load values of ATTRIBUTE into database file. @@ -3571,41 +4290,47 @@ Load values of ATTRIBUTE into database file. Qunbound); if (CHAR_TABLEP (table)) { - Lisp_Char_Table *ct = XCHAR_TABLE (table); + Lisp_Char_Table *cit = XCHAR_TABLE (table); - if (NILP (Fdatabase_live_p (ct->db))) - { - Lisp_Object db_file - = char_attribute_system_db_file (Qsystem_char_id, attribute, 0); + if (char_table_open_db_maybe (cit)) + return Qnil; - 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; - } + char_attribute_table_to_load = XCHAR_TABLE (table); + { + struct gcpro gcpro1; + + GCPRO1 (table); +#ifdef HAVE_LIBCHISE + chise_feature_foreach_char_with_value + (chise_ds_get_feature (default_chise_data_source, + XSTRING_DATA (Fsymbol_name (cit->name))), + &load_char_attribute_table_map_func); +#else /* HAVE_LIBCHISE */ + Fmap_database (Qload_char_attribute_table_map_function, cit->db); +#endif /* not HAVE_LIBCHISE */ + UNGCPRO; + } + char_table_close_db_maybe (cit); + XCHAR_TABLE_UNLOADED(table) = 0; + return Qt; } return Qnil; } -#endif +#endif /* HAVE_CHISE */ 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. +Map FUNCTION over ATTRIBUTE until it returns non-nil; return that value. +FUNCTION is called with two arguments, each key and entry 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 +RANGE specifies a subrange to map over. If omitted or t, it defaults to the entire table. + +Both RANGE and the keys passed to FUNCTION are in the same format as the +RANGE argument to `put-char-table'. N.B. This function does NOT map over +all characters in RANGE, but over the subranges that have been assigned to. +Thus this function is most suitable for searching a char-table, or for +populating one char-table based on the contents of another. The current +implementation does not coalesce ranges all of whose values are the same. */ (function, attribute, range)) { @@ -3637,7 +4362,7 @@ the entire table. if (NILP (range)) range = Qt; decode_char_table_range (range, &rainj); -#ifdef HAVE_CHISE_CLIENT +#ifdef HAVE_CHISE if (CHAR_TABLE_UNLOADED(ct)) Fload_char_attribute_table (attribute); #endif @@ -3650,50 +4375,83 @@ the entire table. return slarg.retval; } +static Lisp_Object +allocate_character () +{ + int cid = XINT (Vnext_defined_char_id); + + if (cid <= 0xE00000) + { + Vnext_defined_char_id = make_int (cid + 1); + return make_char (cid); + } + else + return Qnil; +} + DEFUN ("define-char", Fdefine_char, 1, 1, 0, /* Store character's ATTRIBUTES. */ (attributes)) { - Lisp_Object rest = attributes; - Lisp_Object code = Fcdr (Fassq (Qmap_ucs, attributes)); + Lisp_Object rest; + Lisp_Object code = Fcdr (Fassq (Qrep_ucs, attributes)); Lisp_Object character; if (NILP (code)) code = Fcdr (Fassq (Qucs, attributes)); + if (NILP (code)) { + rest = attributes; while (CONSP (rest)) { Lisp_Object cell = Fcar (rest); Lisp_Object ccs; - if (!LISTP (cell)) + 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))) ) + + ccs = Ffind_charset (Fcar (cell)); + if (!NILP (ccs)) { 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; + if (INTP (cell)) + { + character = Fdecode_char (ccs, cell, Qt, Qt); + if (!NILP (character)) + goto setup_attributes; + } + if ( (XCHARSET_FINAL (ccs) != 0) || + (XCHARSET_MAX_CODE (ccs) > 0) || + (EQ (ccs, Vcharset_chinese_big5)) ) + { + if (CONSP (cell)) + character + = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); + else + character = Fdecode_char (ccs, cell, Qnil, Qt); + if (!NILP (character)) + goto setup_attributes; + } } rest = Fcdr (rest); } - if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) ) - { - if (!INTP (code)) - signal_simple_error ("Invalid argument", attributes); - else - character = make_char (XINT (code) + 0x100000); - goto setup_attributes; - } - return Qnil; +#if 0 + { + int cid = XINT (Vnext_defined_char_id); + + if (cid <= 0xE00000) + { + character = make_char (cid); + Vnext_defined_char_id = make_int (cid + 1); + goto setup_attributes; + } + } +#else + if ( NILP (character = allocate_character ()) ) +#endif + return Qnil; } else if (!INTP (code)) signal_simple_error ("Invalid argument", attributes); @@ -3736,7 +4494,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, Qnil); + return Fdecode_char (ccs, cell, Qnil, Qnil); } rest = Fcdr (rest); } @@ -3754,6 +4512,62 @@ Retrieve the character of the given ATTRIBUTES. /************************************************************************/ +/* Character Feature Property */ +/************************************************************************/ + +#ifdef HAVE_LIBCHISE +DEFUN ("char-feature-property", Fchar_feature_property, 2, 3, 0, /* +Return the value of FEATURE's PROPERTY. +Return DEFAULT-VALUE if the value is not exist. +*/ + (feature, property, default_value)) +{ + unsigned char* feature_name; + unsigned char* property_name; + CHISE_Value value; + int status; + + feature_name = XSTRING_DATA (Fsymbol_name (feature)); + property_name = XSTRING_DATA (Fsymbol_name (property)); + status + = chise_feature_load_property_value (chise_ds_get_feature + (default_chise_data_source, + feature_name), + chise_ds_get_property + (default_chise_data_source, + property_name), + &value); + if (!status) + return read_from_c_string (chise_value_data (&value), + chise_value_size (&value) ); + else + return default_value; +} + +DEFUN ("put-char-feature-property", Fput_char_feature_property, 3, 3, 0, /* +Store FEATURE's PROPERTY with VALUE. +*/ + (feature, property, value)) +{ + unsigned char* feature_name; + unsigned char* property_name; + CHISE_Property prop; + + feature_name = XSTRING_DATA (Fsymbol_name (feature)); + property_name = XSTRING_DATA (Fsymbol_name (property)); + prop = chise_ds_get_property (default_chise_data_source, + property_name); + chise_feature_set_property_value + (chise_ds_get_feature (default_chise_data_source, feature_name), + prop, XSTRING_DATA (Fprin1_to_string + (value, Qnil))); + chise_property_sync (prop); + return Qnil; +} +#endif + + +/************************************************************************/ /* Char table read syntax */ /************************************************************************/ @@ -3838,7 +4652,7 @@ chartab_instantiate (Lisp_Object data) Fput_char_table (make_char (i), val, chartab); } else - abort (); + ABORT (); } else Fput_char_table (range, val, chartab); @@ -4091,16 +4905,33 @@ word_boundary_p (Emchar c1, Emchar c2) void syms_of_chartab (void) { +#if defined(UTF2000) || defined(HAVE_CONCORD) + defsymbol (&Q_subsumptive, "->subsumptive"); + defsymbol (&Q_subsumptive_from, "<-subsumptive"); + defsymbol (&Q_denotational, "->denotational"); + defsymbol (&Q_denotational_from, "<-denotational"); +#endif #ifdef UTF2000 INIT_LRECORD_IMPLEMENTATION (uint8_byte_table); 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_unified, "->ucs-unified"); + defsymbol (&Q_identical, "->identical"); + defsymbol (&Q_identical_from, "<-identical"); + defsymbol (&Q_component, "->ideographic-component-forms"); + defsymbol (&Q_component_of, "<-ideographic-component-forms"); defsymbol (&Qcomposition, "composition"); + defsymbol (&Qrep_decomposition, "=decomposition"); + defsymbol (&Qto_decomposition_at_superscript, + "=>decomposition@superscript"); + defsymbol (&Qto_decomposition_at_circled, "=>decomposition@circled"); + defsymbol (&Q_canonical, "->canonical"); + defsymbol (&Q_halfwidth_of, "<-halfwidth"); + defsymbol (&Q_superscript_of, "<-superscript"); + defsymbol (&Q_subscript_of, "<-subscript"); + defsymbol (&Q_circled_of, "<-circled"); defsymbol (&Q_decomposition, "->decomposition"); defsymbol (&Qcompat, "compat"); defsymbol (&Qisolated, "isolated"); @@ -4123,16 +4954,21 @@ 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_CHISE_CLIENT +#ifdef HAVE_CHISE DEFSUBR (Fsave_char_attribute_table); DEFSUBR (Fmount_char_attribute_table); DEFSUBR (Freset_char_attribute_table); DEFSUBR (Fclose_char_attribute_table); + DEFSUBR (Fclose_char_data_source); +#ifndef HAVE_LIBCHISE 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_feature_base_name_eq); + DEFSUBR (Fchar_feature); DEFSUBR (Fchar_attribute_alist); DEFSUBR (Fget_char_attribute); DEFSUBR (Fput_char_attribute); @@ -4143,6 +4979,10 @@ syms_of_chartab (void) DEFSUBR (Fchar_variants); DEFSUBR (Fget_composite_char); +#ifdef HAVE_LIBCHISE + DEFSUBR (Fchar_feature_property); + DEFSUBR (Fput_char_feature_property); +#endif /* HAVE_LIBCHISE */ #endif INIT_LRECORD_IMPLEMENTATION (char_table); @@ -4192,12 +5032,29 @@ void vars_of_chartab (void) { #ifdef UTF2000 -#ifdef HAVE_CHISE_CLIENT + DEFVAR_LISP ("next-defined-char-id", &Vnext_defined_char_id /* +*/ ); + Vnext_defined_char_id = make_int (0x0F0000); +#endif + +#ifdef HAVE_CHISE DEFVAR_LISP ("char-db-stingy-mode", &Vchar_db_stingy_mode /* */ ); Vchar_db_stingy_mode = Qt; -#endif /* HAVE_CHISE_CLIENT */ + +#ifdef HAVE_LIBCHISE + Vchise_db_directory = build_string(chise_db_dir); + DEFVAR_LISP ("chise-db-directory", &Vchise_db_directory /* +Directory of CHISE character databases. +*/ ); + + Vchise_system_db_directory = build_string(chise_system_db_dir); + DEFVAR_LISP ("chise-system-db-directory", &Vchise_system_db_directory /* +Directory of system character database of CHISE. +*/ ); #endif + +#endif /* HAVE_CHISE */ /* DO NOT staticpro this. It works just like Vweak_hash_tables. */ Vall_syntax_tables = Qnil; dump_add_weak_object_chain (&Vall_syntax_tables);