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,2005 MORIOKA Tomohiko
+ Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008,
+ 2010 MORIOKA Tomohiko
This file is part of XEmacs.
{
if (ct->property[i] == BT_UINT8_unloaded)
{
- c1 = c + unit;
+ c += unit;
}
else if (ct->property[i] != BT_UINT8_unbound)
{
{
if (ct->property[i] == BT_UINT16_unloaded)
{
- c1 = c + unit;
+ c += unit;
}
else if (ct->property[i] != BT_UINT16_unbound)
{
Lisp_Object Qcomposition;
-Lisp_Object Qmap_decomposition;
+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;
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'.
}
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))
{
-- 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.
}
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
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))
{
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
{
}
#endif
}
- return Qmap_decomposition;
+ return Qrep_decomposition;
}
static Lisp_Object
value = put_char_ccs_code_point (character, ccs, value);
attribute = XCHARSET_NAME (ccs);
}
- else if ( EQ (attribute, Qmap_decomposition) ||
+ 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))
{
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) ||
- !NILP (Fstring_match
- (build_string ("^\\(<-\\|->\\)\\("
- "fullwidth\\|halfwidth"
- "\\|simplified\\|vulgar\\|wrong"
- "\\|same\\|original\\|ancient"
- "\\|Oracle-Bones\\)[^*]*$"),
- Fsymbol_name (attribute),
- Qnil, Qnil)) )
+ ( !EQ (attribute, Q_ucs_unified)
+ && !NILP (Fstring_match
+ (build_string ("^\\(<-\\|->\\)[^*]*$"),
+ Fsymbol_name (attribute),
+ Qnil, Qnil))
+ )
+ )
{
Lisp_Object rest = value;
Lisp_Object ret;
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);
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"
#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;
- Lisp_Object code = Fcdr (Fassq (Qmap_ucs, attributes));
+ Lisp_Object code = Fcdr (Fassq (Qrep_ucs, attributes));
Lisp_Object character;
if (NILP (code))
}
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 */
/************************************************************************/
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);
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 (&Qcomposition, "composition");
- defsymbol (&Qmap_decomposition, "=decomposition");
+ 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");
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);
projects / chise / xemacs-chise.git.1 / blobdiff