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,
+ 2010, 2011, 2012, 2013 MORIOKA Tomohiko
This file is part of XEmacs.
extern Lisp_Object Qideographic_structure;
Lisp_Object Vnext_defined_char_id;
-EXFUN (Fdefine_char, 1);
EXFUN (Fmap_char_attribute, 3);
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
return XINT (obj);
}
-INLINE_HEADER Lisp_Object
+/* INLINE_HEADER */ Lisp_Object
UINT8_DECODE (unsigned char n)
{
if (n == BT_UINT8_unloaded)
{
if (ct->property[i] == BT_UINT8_unloaded)
{
- c1 = c + unit;
+ c += unit;
}
else if (ct->property[i] != BT_UINT8_unbound)
{
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)
return XINT (obj);
}
-INLINE_HEADER Lisp_Object
+/* INLINE_HEADER */ Lisp_Object
UINT16_DECODE (unsigned short n)
{
if (n == BT_UINT16_unloaded)
{
if (ct->property[i] == BT_UINT16_unloaded)
{
- c1 = c + unit;
+ c += unit;
}
else if (ct->property[i] != BT_UINT16_unbound)
{
}
-#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_unified;
-Lisp_Object Q_unified_from;
+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;
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;
}
*/
(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
{
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;
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'.
break;
default:
- abort ();
+ ABORT ();
}
return Qnil;
return (0 << 8) | 255;
#endif
default:
- abort ();
+ ABORT ();
return 0;
}
}
}
#endif
else
- abort ();
+ ABORT ();
}
else
{
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);
}
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))
{
#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 */
break;
default:
- abort ();
+ ABORT ();
}
return 0; /* not reached */
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. */
{
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);
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)
-- 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.
break;
default:
- abort ();
+ ABORT ();
}
return 0;
}
default:
- abort ();
+ ABORT ();
}
return 0;
ranjarg = make_char (range->ch);
break;
default:
- abort ();
+ ABORT ();
}
closure->retval = call2 (closure->function, ranjarg, val);
}
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
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.
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 (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;
+ }
+ }
+
+ 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)) ) )
+ {
+ Lisp_String* name = symbol_name (XSYMBOL (attribute));
+ Bufbyte *name_str = string_data (name);
+
+ if ( (name_str[0] != '=') || (name_str[1] == '>') )
+ {
+ 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;
+ }
+ }
+ 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))
{
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))
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))
{
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, /*
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;
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))
- {
- Fput_char_attribute (make_char (c), Q_ucs_unified,
- Fcons (character, Qnil));
- }
+ 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));
- }
+ Fput_char_attribute (make_char (c), Q_ucs_unified,
+ Fcons (character, ret));
}
- else if (EQ (attribute, Q_unified))
+ 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
+ {
+ 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);
+ }
+ }
while (CONSP (rest))
{
if (CONSP (ret))
ret = Fdefine_char (ret);
-
- if (!NILP (ret))
+ else if (INTP (ret))
{
- Fput_char_attribute (ret, Q_unified_from, list1 (character));
+ 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
- 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, /*
{
if (default_chise_data_source == NULL)
{
- Lisp_Object db_dir = Vexec_directory;
int modemask = 0755; /* rwxr-xr-x */
+ char* db_dir_name;
+ size_t len;
+
+ if (STRINGP (Vdata_directory))
+ {
+ char* dir_name = XSTRING_DATA (Vdata_directory);
- if (NILP (db_dir))
- db_dir = build_string ("../lib-src");
- db_dir = Fexpand_file_name (build_string ("chise-db"), db_dir);
+ 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, XSTRING_DATA (db_dir),
- 0 /* DB_HASH */, modemask);
+ 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;
}
if (!status)
{
- val = Fread (make_string (chise_value_data (&value),
- chise_value_size (&value) ));
+ val = read_from_c_string (chise_value_data (&value),
+ chise_value_size (&value) );
}
else
val = Qunbound;
return val;
}
+#ifdef HAVE_LIBCHISE
+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 ("chise-db"), db_dir);
if (writing_mode && NILP (Ffile_exists_p (db_dir)))
{
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;
return Qunbound;
}
+#ifdef HAVE_LIBCHISE
+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
#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))
{
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, Qt);
- 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 1
+#if 0
{
int cid = XINT (Vnext_defined_char_id);
}
}
#else
- 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;
- }
+ if ( NILP (character = allocate_character ()) )
#endif
- return Qnil;
+ return Qnil;
}
else if (!INTP (code))
signal_simple_error ("Invalid argument", attributes);
\f
/************************************************************************/
+/* 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
+
+\f
+/************************************************************************/
/* Char table read syntax */
/************************************************************************/
Fput_char_table (make_char (i), val, chartab);
}
else
- abort ();
+ ABORT ();
}
else
Fput_char_table (range, val, chartab);
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_unified, "->unified");
- defsymbol (&Q_unified_from, "<-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");
#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);
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);