X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fchartab.c;h=95d0a15355c08c28171ee9dc335b3ce62297415d;hb=1634394e3d54370865457b09ac9b14357261e87c;hp=1ce7474ec0b22a1d6535039d14c25aeae2aeccd3;hpb=0de6b9b1086e3a55fb2bfb10fce8a3023c499ceb;p=chise%2Fxemacs-chise.git.1 diff --git a/src/chartab.c b/src/chartab.c index 1ce7474..95d0a15 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,2002,2003,2004 MORIOKA Tomohiko + Copyright (C) 1999,2000,2001,2002,2003,2004,2005,2006,2008 MORIOKA Tomohiko This file is part of XEmacs. @@ -76,7 +76,6 @@ EXFUN (Fchar_refs_simplify_char_specs, 1); extern Lisp_Object Qideographic_structure; Lisp_Object Vnext_defined_char_id; -EXFUN (Fdefine_char, 1); EXFUN (Fmap_char_attribute, 3); @@ -1130,11 +1129,15 @@ make_char_id_table (Lisp_Object initval) } -#if defined(HAVE_CHISE) && !defined(HAVE_LIBCHISE_LIBCHISE) -Lisp_Object Qsystem_char_id; -#endif - 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; @@ -1144,8 +1147,6 @@ Lisp_Object Q_subsumptive; Lisp_Object Q_subsumptive_from; Lisp_Object Q_component; Lisp_Object Q_component_of; -Lisp_Object Q_same; -Lisp_Object Q_same_of; Lisp_Object Qto_ucs; Lisp_Object Q_ucs_unified; Lisp_Object Qcompat; @@ -1242,15 +1243,16 @@ Return variants of CHARACTER. */ (character)) { - Lisp_Object ret; - CHECK_CHAR (character); - ret = Fchar_feature (character, Q_ucs_unified, Qnil, - Qnil, 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 @@ -1398,7 +1400,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; @@ -1719,15 +1721,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'. @@ -1856,7 +1860,7 @@ Reset CHAR-TABLE to its default state. break; default: - abort (); + ABORT (); } return Qnil; @@ -2039,7 +2043,7 @@ XCHARSET_CELL_RANGE (Lisp_Object ccs) return (0 << 8) | 255; #endif default: - abort (); + ABORT (); return 0; } } @@ -2101,7 +2105,7 @@ decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) } #endif else - abort (); + ABORT (); } else { @@ -2229,8 +2233,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)) { @@ -2334,8 +2341,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 */ @@ -2385,7 +2397,7 @@ check_valid_char_table_value (Lisp_Object value, enum char_table_type type, break; default: - abort (); + ABORT (); } return 0; /* not reached */ @@ -2620,8 +2632,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. @@ -2831,7 +2844,7 @@ map_char_table_for_charset_fun (struct chartab_range *range, break; default: - abort (); + ABORT (); } return 0; @@ -3042,7 +3055,7 @@ map_char_table (Lisp_Char_Table *ct, } default: - abort (); + ABORT (); } return 0; @@ -3088,7 +3101,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); @@ -3096,8 +3109,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 @@ -3385,20 +3398,21 @@ Return DEFAULT-VALUE if the value is not exist. return default_value; } -void put_char_composition (Lisp_Object character, Lisp_Object value); -void +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)) { @@ -3408,7 +3422,7 @@ 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)) { @@ -3424,15 +3438,47 @@ 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 = Fchar_feature (make_char (c), Q_ucs_unified, Qnil, Qnil, Qnil); @@ -3448,7 +3494,9 @@ put_char_composition (Lisp_Object character, Lisp_Object value) Fcons (character, ret)); } } +#endif } + return Qrep_decomposition; } static Lisp_Object @@ -3485,8 +3533,15 @@ Store CHARACTER's ATTRIBUTE with 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 ( EQ (attribute, Qrep_decomposition) || + EQ (attribute, Q_decomposition) ) + { + value = Fcopy_sequence (Fchar_refs_simplify_char_specs (value)); + attribute = put_char_composition (character, value); + if ( !EQ (attribute, Qrep_decomposition) && + SYMBOLP (XCAR (value)) ) + value = XCDR (value); + } else if (EQ (attribute, Qto_ucs)) { Lisp_Object ret; @@ -3495,7 +3550,7 @@ 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 = Fchar_feature (make_char (c), Q_ucs_unified, Qnil, Qnil, Qnil); @@ -3506,19 +3561,26 @@ Store CHARACTER's ATTRIBUTE with VALUE. Fput_char_attribute (make_char (c), Q_ucs_unified, Fcons (character, ret)); } - else 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_component) || - EQ (attribute, Q_component_of) || - EQ (attribute, Q_same) || - EQ (attribute, Q_same_of) || - !NILP (Fstring_match (build_string ("^<-simplified[^*]*$"), - Fsymbol_name (attribute), - Qnil, Qnil)) ) + 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; @@ -3542,23 +3604,28 @@ Store CHARACTER's ATTRIBUTE with VALUE. rev_feature = Q_component_of; else if (EQ (attribute, Q_component_of)) rev_feature = Q_component; - else if (EQ (attribute, Q_same)) - rev_feature = Q_same_of; - else if (EQ (attribute, Q_same_of)) - rev_feature = Q_same; else { Lisp_String* name = symbol_name (XSYMBOL (attribute)); Bufbyte *name_str = string_data (name); - if (name_str[0] == '<' && name_str[1] == '-') + 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); - rev_name_str[0] = '-'; - rev_name_str[1] = '>'; + 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); } @@ -3570,7 +3637,17 @@ Store CHARACTER's ATTRIBUTE with VALUE. 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; @@ -3579,8 +3656,9 @@ Store CHARACTER's ATTRIBUTE with VALUE. if (!CONSP (ffv)) put_char_attribute (ret, rev_feature, list1 (character)); else if (NILP (Fmemq (character, ffv))) - put_char_attribute (ret, rev_feature, - Fcons (character, ffv)); + put_char_attribute + (ret, rev_feature, + nconc2 (Fcopy_sequence (ffv), list1 (character))); Fsetcar (rest, ret); } rest = XCDR (rest); @@ -3588,7 +3666,11 @@ Store CHARACTER's ATTRIBUTE with VALUE. UNGCPRO; } #if 1 - else if (EQ (attribute, Qideographic_structure)) + 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 return put_char_attribute (character, attribute, value); @@ -3633,11 +3715,11 @@ open_chise_data_source_maybe () { if (default_chise_data_source == NULL) { - Lisp_Object db_dir = Vexec_directory; + Lisp_Object db_dir = Vdata_directory; int modemask = 0755; /* rwxr-xr-x */ if (NILP (db_dir)) - db_dir = build_string ("../lib-src"); + db_dir = build_string ("../etc"); db_dir = Fexpand_file_name (build_string ("chise-db"), db_dir); default_chise_data_source @@ -3645,6 +3727,10 @@ open_chise_data_source_maybe () 0 /* DB_HASH */, modemask); if (default_chise_data_source == NULL) return -1; +#if 0 + chise_ds_set_make_string_function (default_chise_data_source, + &make_string); +#endif } return 0; } @@ -3720,8 +3806,13 @@ char_table_get_db (Lisp_Char_Table* cit, Emchar ch) if (!status) { +#if 0 val = Fread (make_string (chise_value_data (&value), chise_value_size (&value) )); +#else + val = read_from_c_string (chise_value_data (&value), + chise_value_size (&value) ); +#endif } else val = Qunbound; @@ -3741,10 +3832,10 @@ 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 ("chise-db"), db_dir); if (writing_mode && NILP (Ffile_exists_p (db_dir))) @@ -3827,15 +3918,23 @@ Save values of ATTRIBUTE into database file. { Lisp_Object (*filter)(Lisp_Object value); - if ( EQ (attribute, Qideographic_structure) - || EQ (attribute, Q_identical) - || EQ (attribute, Q_identical_from) - || EQ (attribute, Q_same) - || EQ (attribute, Q_same_of) - || !NILP (Fstring_match - (build_string ("^\\(<-\\|->\\)simplified[^*]*$"), - Fsymbol_name (attribute), - Qnil, Qnil)) ) + 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; @@ -4077,12 +4176,18 @@ Load values of ATTRIBUTE into database file. #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)) { @@ -4133,7 +4238,7 @@ Store character's ATTRIBUTES. (attributes)) { Lisp_Object rest; - Lisp_Object code = Fcdr (Fassq (Qmap_ucs, attributes)); + Lisp_Object code = Fcdr (Fassq (Qrep_ucs, attributes)); Lisp_Object character; if (NILP (code)) @@ -4257,6 +4362,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 */ /************************************************************************/ @@ -4341,7 +4502,7 @@ chartab_instantiate (Lisp_Object data) Fput_char_table (make_char (i), val, chartab); } else - abort (); + ABORT (); } else Fput_char_table (range, val, chartab); @@ -4594,28 +4755,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); -#if defined(HAVE_CHISE) && !defined(HAVE_LIBCHISE_LIBCHISE) - defsymbol (&Qsystem_char_id, "system-char-id"); -#endif - defsymbol (&Qto_ucs, "=>ucs"); defsymbol (&Q_ucs_unified, "->ucs-unified"); - defsymbol (&Q_subsumptive, "->subsumptive"); - defsymbol (&Q_subsumptive_from, "<-subsumptive"); - defsymbol (&Q_denotational, "->denotational"); - defsymbol (&Q_denotational_from, "<-denotational"); defsymbol (&Q_identical, "->identical"); defsymbol (&Q_identical_from, "<-identical"); defsymbol (&Q_component, "->ideographic-component-forms"); defsymbol (&Q_component_of, "<-ideographic-component-forms"); - defsymbol (&Q_same, "->same"); - defsymbol (&Q_same_of, "<-same"); 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"); @@ -4662,6 +4828,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);