#endif
#ifdef UTF2000
+
static Lisp_Object
mark_char_byte_table (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
{ XD_END }
};
-DEFINE_LRECORD_IMPLEMENTATION ("char-code-table", char_byte_table,
+DEFINE_LRECORD_IMPLEMENTATION ("char-byte-table", char_byte_table,
mark_char_byte_table,
internal_object_printer,
0, char_byte_table_equal,
char_byte_table_description,
struct Lisp_Char_Byte_Table);
-
static Lisp_Object
make_char_byte_table (Lisp_Object initval)
{
return obj;
}
-#define make_char_code_table(initval) make_char_byte_table(initval)
+
+static Lisp_Object
+mark_char_code_table (Lisp_Object obj, void (*markobj) (Lisp_Object))
+{
+ struct Lisp_Char_Code_Table *cte = XCHAR_CODE_TABLE (obj);
+
+ return cte->table;
+}
+
+static int
+char_code_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+{
+ struct Lisp_Char_Code_Table *cte1 = XCHAR_CODE_TABLE (obj1);
+ struct Lisp_Char_Code_Table *cte2 = XCHAR_CODE_TABLE (obj2);
+
+ return char_byte_table_equal (cte1->table, cte2->table, depth + 1);
+}
+
+static unsigned long
+char_code_table_hash (Lisp_Object obj, int depth)
+{
+ struct Lisp_Char_Code_Table *cte = XCHAR_CODE_TABLE (obj);
+
+ return char_code_table_hash (cte->table, depth + 1);
+}
+
+static const struct lrecord_description char_code_table_description[] = {
+ { XD_LISP_OBJECT, offsetof(struct Lisp_Char_Code_Table, table), 1 },
+ { XD_END }
+};
+
+DEFINE_LRECORD_IMPLEMENTATION ("char-code-table", char_code_table,
+ mark_char_code_table,
+ internal_object_printer,
+ 0, char_code_table_equal,
+ char_code_table_hash,
+ char_code_table_description,
+ struct Lisp_Char_Code_Table);
+
+static Lisp_Object
+make_char_code_table (Lisp_Object initval)
+{
+ Lisp_Object obj;
+ struct Lisp_Char_Code_Table *cte =
+ alloc_lcrecord_type (struct Lisp_Char_Code_Table,
+ &lrecord_char_code_table);
+
+ cte->table = make_char_byte_table (initval);
+
+ XSETCHAR_CODE_TABLE (obj, cte);
+ return obj;
+}
+
+static Lisp_Object
+copy_char_code_table (Lisp_Object entry)
+{
+ struct Lisp_Char_Code_Table *cte = XCHAR_CODE_TABLE (entry);
+ Lisp_Object obj;
+ struct Lisp_Char_Code_Table *ctenew =
+ alloc_lcrecord_type (struct Lisp_Char_Code_Table,
+ &lrecord_char_code_table);
+
+ ctenew->table = copy_char_byte_table (cte->table);
+ XSETCHAR_CODE_TABLE (obj, ctenew);
+ return obj;
+}
+
Lisp_Object
get_char_code_table (Emchar ch, Lisp_Object table)
{
- struct Lisp_Char_Byte_Table* cpt = XCHAR_BYTE_TABLE (table);
+ struct Lisp_Char_Byte_Table* cpt
+ = XCHAR_BYTE_TABLE (XCHAR_CODE_TABLE (table)->table);
Lisp_Object ret = cpt->property [ch >> 24];
if (CHAR_BYTE_TABLE_P (ret))
void
put_char_code_table (Emchar ch, Lisp_Object value, Lisp_Object table)
{
- struct Lisp_Char_Byte_Table* cpt1 = XCHAR_BYTE_TABLE (table);
+ struct Lisp_Char_Byte_Table* cpt1
+ = XCHAR_BYTE_TABLE (XCHAR_CODE_TABLE (table)->table);
Lisp_Object ret = cpt1->property[ch >> 24];
if (CHAR_BYTE_TABLE_P (ret))
{
Lisp_Object ret
= get_char_code_table (XCHAR (character), Vcharacter_attribute_table);
+ Lisp_Object ccs;
if (EQ (ret, Qnil))
return Qnil;
-
+
+ if (!NILP (ccs = Ffind_charset (attribute)))
+ attribute = ccs;
+
return Fcdr (Fassq (attribute, ret));
}
-DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
-Store CHARACTER's ATTRIBUTE with VALUE.
-*/
- (character, attribute, value))
+Lisp_Object
+put_char_attribute (Lisp_Object character, Lisp_Object attribute,
+ Lisp_Object value)
{
Emchar char_code = XCHAR (character);
Lisp_Object ret
= get_char_code_table (char_code, Vcharacter_attribute_table);
- Lisp_Object cell = Fassq (attribute, ret);
+ Lisp_Object cell;
- if (EQ (cell, Qnil))
- ret = Fcons (Fcons (attribute, value), ret);
- else
- Fsetcdr (cell, value);
+ cell = Fassq (attribute, ret);
+
+ if (NILP (cell))
+ {
+ ret = Fcons (Fcons (attribute, value), ret);
+ }
+ else if (!EQ (Fcdr (cell), value))
+ {
+ Fsetcdr (cell, value);
+ }
put_char_code_table (char_code, ret, Vcharacter_attribute_table);
return ret;
}
+
+DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
+Store CHARACTER's ATTRIBUTE with VALUE.
+*/
+ (character, attribute, value))
+{
+ Lisp_Object ccs;
+
+ ccs = Ffind_charset (attribute);
+ if (!NILP (ccs))
+ {
+ Lisp_Object rest;
+ Lisp_Object v = XCHARSET_DECODING_TABLE (ccs);
+ Lisp_Object nv;
+ int i = -1;
+ int ccs_len;
+
+ /* ad-hoc method for `ascii' */
+ if ((XCHARSET_CHARS (ccs) == 94) &&
+ (XCHARSET_BYTE_OFFSET (ccs) != 33))
+ ccs_len = 128 - XCHARSET_BYTE_OFFSET (ccs);
+ else
+ ccs_len = XCHARSET_CHARS (ccs);
+
+ if (!CONSP (value))
+ signal_simple_error ("Invalid value for coded-charset",
+ value);
+
+ attribute = ccs;
+ rest = Fget_char_attribute (character, attribute);
+ if (VECTORP (v))
+ {
+ if (!NILP (rest))
+ {
+ while (!NILP (rest))
+ {
+ Lisp_Object ei = Fcar (rest);
+
+ i = XINT (ei) - XCHARSET_BYTE_OFFSET (ccs);
+ nv = XVECTOR_DATA(v)[i];
+ if (!VECTORP (nv))
+ break;
+ v = nv;
+ rest = Fcdr (rest);
+ }
+ if (i >= 0)
+ XVECTOR_DATA(v)[i] = Qnil;
+ v = XCHARSET_DECODING_TABLE (ccs);
+ }
+ }
+ else
+ {
+ XCHARSET_DECODING_TABLE (ccs) = v = make_vector (ccs_len, Qnil);
+ }
+
+ rest = value;
+ i = -1;
+ while (CONSP (rest))
+ {
+ Lisp_Object ei = Fcar (rest);
+
+ if (!INTP (ei))
+ signal_simple_error ("Invalid value for coded-charset",
+ value);
+ i = XINT (ei) - XCHARSET_BYTE_OFFSET (ccs);
+ nv = XVECTOR_DATA(v)[i];
+ rest = Fcdr (rest);
+ if (CONSP (rest))
+ {
+ if (!VECTORP (nv))
+ {
+ nv = (XVECTOR_DATA(v)[i] = make_vector (ccs_len, Qnil));
+ }
+ v = nv;
+ }
+ else
+ break;
+ }
+ XVECTOR_DATA(v)[i] = character;
+ }
+ return put_char_attribute (character, attribute, value);
+}
+
+Lisp_Object Qucs;
+DEFUN ("define-char", Fdefine_char, 1, 1, 0, /*
+Store character's ATTRIBUTES.
+*/
+ (attributes))
+{
+ Lisp_Object rest = attributes;
+ Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
+ Lisp_Object character;
+
+ if (NILP (code))
+ {
+ while (CONSP (rest))
+ {
+ Lisp_Object cell = Fcar (rest);
+ Lisp_Object ccs;
+
+ if (!LISTP (cell))
+ signal_simple_error ("Invalid argument", attributes);
+ if (!NILP (ccs = Ffind_charset (Fcar (cell)))
+ && XCHARSET_FINAL (ccs))
+ {
+ Emchar code;
+
+ if (XCHARSET_DIMENSION (ccs) == 1)
+ {
+ Lisp_Object eb1 = Fcar (Fcdr (cell));
+ int b1;
+
+ if (!INTP (eb1))
+ signal_simple_error ("Invalid argument", attributes);
+ b1 = XINT (eb1);
+ switch (XCHARSET_CHARS (ccs))
+ {
+ case 94:
+ code = MIN_CHAR_94
+ + (XCHARSET_FINAL (ccs) - '0') * 94 + (b1 - 33);
+ break;
+ case 96:
+ code = MIN_CHAR_96
+ + (XCHARSET_FINAL (ccs) - '0') * 96 + (b1 - 32);
+ break;
+ default:
+ abort ();
+ }
+ }
+ else if (XCHARSET_DIMENSION (ccs) == 2)
+ {
+ Lisp_Object eb1 = Fcar (Fcdr (cell));
+ Lisp_Object eb2 = Fcar (Fcdr (Fcdr (cell)));
+ int b1, b2;
+
+ if (!INTP (eb1))
+ signal_simple_error ("Invalid argument", attributes);
+ b1 = XINT (eb1);
+ if (!INTP (eb2))
+ signal_simple_error ("Invalid argument", attributes);
+ b2 = XINT (eb2);
+ switch (XCHARSET_CHARS (ccs))
+ {
+ case 94:
+ code = MIN_CHAR_94x94
+ + (XCHARSET_FINAL (ccs) - '0') * 94 * 94
+ + (b1 - 33) * 94 + (b2 - 33);
+ break;
+ case 96:
+ code = MIN_CHAR_96x96
+ + (XCHARSET_FINAL (ccs) - '0') * 96 * 96
+ + (b1 - 32) * 96 + (b2 - 32);
+ break;
+ default:
+ abort ();
+ }
+ }
+ else
+ {
+ rest = Fcdr (rest);
+ continue;
+ }
+ character = make_char (code);
+ goto setup_attributes;
+ }
+ rest = Fcdr (rest);
+ }
+ return Qnil;
+ }
+ else if (!INTP (code))
+ signal_simple_error ("Invalid argument", attributes);
+ else
+ character = make_char (XINT (code));
+
+ setup_attributes:
+ rest = attributes;
+ while (CONSP (rest))
+ {
+ Lisp_Object cell = Fcar (rest);
+
+ if (!LISTP (cell))
+ signal_simple_error ("Invalid argument", attributes);
+ Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
+ rest = Fcdr (rest);
+ }
+ return
+ get_char_code_table (XCHAR (character), Vcharacter_attribute_table);
+}
Lisp_Object Vutf_2000_version;
#endif
Lisp_Object rest, keyword, value;
Lisp_Object ccl_program = Qnil;
Lisp_Object short_name = Qnil, long_name = Qnil;
- unsigned char byte_offset = 0;
+ int byte_offset = -1;
CHECK_SYMBOL (name);
if (!NILP (doc_string))
if (columns == -1)
columns = dimension;
+
+ if (byte_offset < 0)
+ {
+ if (chars == 94)
+ byte_offset = 33;
+ else if (chars == 96)
+ byte_offset = 32;
+ else
+ byte_offset = 0;
+ }
+
charset = make_charset (id, name, type, columns, graphic,
final, direction, short_name, long_name,
doc_string, registry,
Lisp_Object c = XVECTOR_DATA(table)[i];
if (CHARP (c))
- Fput_char_attribute
+ put_char_attribute
(c, charset,
list1 (make_int (i + CHARSET_BYTE_OFFSET (cs))));
}
Lisp_Object c = XVECTOR_DATA(v)[j];
if (CHARP (c))
- Fput_char_attribute (c, charset,
- list2
- (make_int
- (i + CHARSET_BYTE_OFFSET (cs)),
- make_int
- (j + CHARSET_BYTE_OFFSET (cs))));
+ put_char_attribute (c, charset,
+ list2
+ (make_int
+ (i + CHARSET_BYTE_OFFSET (cs)),
+ make_int
+ (j + CHARSET_BYTE_OFFSET (cs))));
}
}
else if (CHARP (v))
- Fput_char_attribute (v, charset,
- list1
- (make_int (i + CHARSET_BYTE_OFFSET (cs))));
+ put_char_attribute (v, charset,
+ list1
+ (make_int (i + CHARSET_BYTE_OFFSET (cs))));
}
break;
}
DEFSUBR (Fchar_attribute_alist);
DEFSUBR (Fget_char_attribute);
DEFSUBR (Fput_char_attribute);
+ DEFSUBR (Fdefine_char);
DEFSUBR (Fcharset_mapping_table);
DEFSUBR (Fset_charset_mapping_table);
#endif
defsymbol (&Qchinese_cns11643_1, "chinese-cns11643-1");
defsymbol (&Qchinese_cns11643_2, "chinese-cns11643-2");
#ifdef UTF2000
+ defsymbol (&Qucs, "ucs");
defsymbol (&Qucs_bmp, "ucs-bmp");
defsymbol (&Qlatin_viscii, "latin-viscii");
defsymbol (&Qlatin_viscii_lower, "latin-viscii-lower");
#endif
#ifdef UTF2000
- Vutf_2000_version = build_string("0.10 (Yao)");
+ Vutf_2000_version = build_string("0.12 (Kashiwara)");
DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
Version number of UTF-2000.
*/ );
projects / chise / xemacs-chise.git / blobdiff