+#endif
+
+#ifdef UTF2000
+
+static Lisp_Object
+mark_char_byte_table (Lisp_Object obj, void (*markobj) (Lisp_Object))
+{
+ struct Lisp_Char_Byte_Table *cte = XCHAR_BYTE_TABLE (obj);
+ int i;
+
+ for (i = 0; i < 256; i++)
+ {
+ markobj (cte->property[i]);
+ }
+ return Qnil;
+}
+
+static int
+char_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+{
+ struct Lisp_Char_Byte_Table *cte1 = XCHAR_BYTE_TABLE (obj1);
+ struct Lisp_Char_Byte_Table *cte2 = XCHAR_BYTE_TABLE (obj2);
+ int i;
+
+ for (i = 0; i < 256; i++)
+ if (CHAR_BYTE_TABLE_P (cte1->property[i]))
+ {
+ if (CHAR_BYTE_TABLE_P (cte2->property[i]))
+ {
+ if (!char_byte_table_equal (cte1->property[i],
+ cte2->property[i], depth + 1))
+ return 0;
+ }
+ else
+ return 0;
+ }
+ else
+ if (!internal_equal (cte1->property[i], cte2->property[i], depth + 1))
+ return 0;
+ return 1;
+}
+
+static unsigned long
+char_byte_table_hash (Lisp_Object obj, int depth)
+{
+ struct Lisp_Char_Byte_Table *cte = XCHAR_BYTE_TABLE (obj);
+
+ return internal_array_hash (cte->property, 256, depth);
+}
+
+static const struct lrecord_description char_byte_table_description[] = {
+ { XD_LISP_OBJECT, offsetof(struct Lisp_Char_Byte_Table, property), 256 },
+ { XD_END }
+};
+
+DEFINE_LRECORD_IMPLEMENTATION ("char-byte-table", char_byte_table,
+ mark_char_byte_table,
+ internal_object_printer,
+ 0, char_byte_table_equal,
+ char_byte_table_hash,
+ char_byte_table_description,
+ struct Lisp_Char_Byte_Table);
+
+static Lisp_Object
+make_char_byte_table (Lisp_Object initval)
+{
+ Lisp_Object obj;
+ int i;
+ struct Lisp_Char_Byte_Table *cte =
+ alloc_lcrecord_type (struct Lisp_Char_Byte_Table,
+ &lrecord_char_byte_table);
+
+ for (i = 0; i < 256; i++)
+ cte->property[i] = initval;
+
+ XSETCHAR_BYTE_TABLE (obj, cte);
+ return obj;
+}
+
+static Lisp_Object
+copy_char_byte_table (Lisp_Object entry)
+{
+ struct Lisp_Char_Byte_Table *cte = XCHAR_BYTE_TABLE (entry);
+ Lisp_Object obj;
+ int i;
+ struct Lisp_Char_Byte_Table *ctenew =
+ alloc_lcrecord_type (struct Lisp_Char_Byte_Table,
+ &lrecord_char_byte_table);
+
+ for (i = 0; i < 256; i++)
+ {
+ Lisp_Object new = cte->property[i];
+ if (CHAR_BYTE_TABLE_P (new))
+ ctenew->property[i] = copy_char_byte_table (new);
+ else
+ ctenew->property[i] = new;
+ }
+
+ XSETCHAR_BYTE_TABLE (obj, ctenew);
+ return obj;
+}
+
+
+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)
+{
+ unsigned int code = ch;
+ struct Lisp_Char_Byte_Table* cpt
+ = XCHAR_BYTE_TABLE (XCHAR_CODE_TABLE (table)->table);
+ Lisp_Object ret = cpt->property [(unsigned char)(code >> 24)];
+
+ if (CHAR_BYTE_TABLE_P (ret))
+ cpt = XCHAR_BYTE_TABLE (ret);
+ else
+ return ret;
+
+ ret = cpt->property [(unsigned char) (code >> 16)];
+ if (CHAR_BYTE_TABLE_P (ret))
+ cpt = XCHAR_BYTE_TABLE (ret);
+ else
+ return ret;
+
+ ret = cpt->property [(unsigned char) (code >> 8)];
+ if (CHAR_BYTE_TABLE_P (ret))
+ cpt = XCHAR_BYTE_TABLE (ret);
+ else
+ return ret;
+
+ return cpt->property [(unsigned char) code];
+}
+
+void
+put_char_code_table (Emchar ch, Lisp_Object value, Lisp_Object table)
+{
+ unsigned int code = ch;
+ struct Lisp_Char_Byte_Table* cpt1
+ = XCHAR_BYTE_TABLE (XCHAR_CODE_TABLE (table)->table);
+ Lisp_Object ret = cpt1->property[(unsigned char)(code >> 24)];
+
+ if (CHAR_BYTE_TABLE_P (ret))
+ {
+ struct Lisp_Char_Byte_Table* cpt2 = XCHAR_BYTE_TABLE (ret);
+
+ ret = cpt2->property[(unsigned char)(code >> 16)];
+ if (CHAR_BYTE_TABLE_P (ret))
+ {
+ struct Lisp_Char_Byte_Table* cpt3 = XCHAR_BYTE_TABLE (ret);
+
+ ret = cpt3->property[(unsigned char)(code >> 8)];
+ if (CHAR_BYTE_TABLE_P (ret))
+ {
+ struct Lisp_Char_Byte_Table* cpt4
+ = XCHAR_BYTE_TABLE (ret);
+
+ cpt4->property[(unsigned char)code] = value;
+ }
+ else if (!EQ (ret, value))
+ {
+ Lisp_Object cpt4 = make_char_byte_table (ret);
+
+ XCHAR_BYTE_TABLE(cpt4)->property[(unsigned char)code] = value;
+ cpt3->property[(unsigned char)(code >> 8)] = cpt4;
+ }
+ }
+ else if (!EQ (ret, value))
+ {
+ Lisp_Object cpt3 = make_char_byte_table (ret);
+ Lisp_Object cpt4 = make_char_byte_table (ret);
+
+ XCHAR_BYTE_TABLE(cpt4)->property[(unsigned char)code] = value;
+ XCHAR_BYTE_TABLE(cpt3)->property[(unsigned char)(code >> 8)]
+ = cpt4;
+ cpt2->property[(unsigned char)(code >> 16)] = cpt3;
+ }
+ }
+ else if (!EQ (ret, value))
+ {
+ Lisp_Object cpt2 = make_char_byte_table (ret);
+ Lisp_Object cpt3 = make_char_byte_table (ret);
+ Lisp_Object cpt4 = make_char_byte_table (ret);
+
+ XCHAR_BYTE_TABLE(cpt4)->property[(unsigned char)code] = value;
+ XCHAR_BYTE_TABLE(cpt3)->property[(unsigned char)(code >> 8)] = cpt4;
+ XCHAR_BYTE_TABLE(cpt2)->property[(unsigned char)(code >> 16)] = cpt3;
+ cpt1->property[(unsigned char)(code >> 24)] = cpt2;
+ }
+}
+
+
+Lisp_Object Vcharacter_attribute_table;
+Lisp_Object Vcharacter_composition_table;
+Lisp_Object Vcharacter_variant_table;
+
+Lisp_Object Q_decomposition;
+Lisp_Object Q_ucs;
+Lisp_Object Qcompat;
+Lisp_Object QnoBreak;
+Lisp_Object Qfraction;
+Lisp_Object Qsuper;
+Lisp_Object Qsub;
+Lisp_Object Qcircle;
+Lisp_Object Qsquare;
+Lisp_Object Qwide;
+Lisp_Object Qnarrow;
+Lisp_Object Qfont;
+
+Emchar
+to_char_code (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
+{
+ if (INTP (v))
+ return XINT (v);
+ if (CHARP (v))
+ return XCHAR (v);
+ else if (EQ (v, Qcompat))
+ return -1;
+ else if (EQ (v, QnoBreak))
+ return -2;
+ else if (EQ (v, Qfraction))
+ return -3;
+ else if (EQ (v, Qsuper))
+ return -4;
+ else if (EQ (v, Qsub))
+ return -5;
+ else if (EQ (v, Qcircle))
+ return -6;
+ else if (EQ (v, Qsquare))
+ return -7;
+ else if (EQ (v, Qwide))
+ return -8;
+ else if (EQ (v, Qnarrow))
+ return -9;
+ else if (EQ (v, Qfont))
+ return -10;
+ else
+ signal_simple_error (err_msg, err_arg);
+}
+
+DEFUN ("get-composite-char", Fget_composite_char, 1, 1, 0, /*
+Return character corresponding with list.
+*/
+ (list))
+{
+ Lisp_Object table = Vcharacter_composition_table;
+ Lisp_Object rest = list;
+
+ while (CONSP (rest))
+ {
+ Lisp_Object v = Fcar (rest);
+ Lisp_Object ret;
+ Emchar c = to_char_code (v, "Invalid value for composition", list);
+
+ ret = get_char_code_table (c, table);
+
+ rest = Fcdr (rest);
+ if (NILP (rest))
+ {
+ if (!CHAR_CODE_TABLE_P (ret))
+ return ret;
+ else
+ return Qt;
+ }
+ else if (!CONSP (rest))
+ break;
+ else if (CHAR_CODE_TABLE_P (ret))
+ table = ret;
+ else
+ signal_simple_error ("Invalid table is found with", list);
+ }
+ signal_simple_error ("Invalid value for composition", list);
+}
+
+DEFUN ("char-variants", Fchar_variants, 1, 1, 0, /*
+Return variants of CHARACTER.
+*/
+ (character))
+{
+ CHECK_CHAR (character);
+ return Fcopy_list (get_char_code_table (XCHAR (character),
+ Vcharacter_variant_table));
+}
+
+DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
+Return the alist of attributes of CHARACTER.
+*/
+ (character))
+{
+ CHECK_CHAR (character);
+ return Fcopy_alist (get_char_code_table (XCHAR (character),
+ Vcharacter_attribute_table));
+}
+
+DEFUN ("get-char-attribute", Fget_char_attribute, 2, 2, 0, /*
+Return the value of CHARACTER's ATTRIBUTE.
+*/
+ (character, attribute))
+{
+ Lisp_Object ret;
+ Lisp_Object ccs;
+
+ CHECK_CHAR (character);
+ ret = get_char_code_table (XCHAR (character),
+ Vcharacter_attribute_table);
+ if (EQ (ret, Qnil))
+ return Qnil;
+
+ if (!NILP (ccs = Ffind_charset (attribute)))
+ attribute = ccs;
+
+ return Fcdr (Fassq (attribute, ret));
+}
+
+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;
+
+ 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;
+
+ CHECK_CHAR (character);
+ 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);
+ }
+
+ if (XCHARSET_GRAPHIC (ccs) == 1)
+ value = Fcopy_list (value);
+ 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);
+ if ((i < 0) || (255 < i))
+ signal_simple_error ("Invalid value for coded-charset", value);
+ if (XCHARSET_GRAPHIC (ccs) == 1)
+ {
+ i &= 0x7F;
+ Fsetcar (rest, make_int (i));
+ }
+ i -= 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;
+ }
+ else if (EQ (attribute, Q_decomposition))
+ {
+ Lisp_Object rest = value;
+ Lisp_Object table = Vcharacter_composition_table;
+
+ if (!CONSP (value))
+ signal_simple_error ("Invalid value for ->decomposition",
+ value);
+
+ while (CONSP (rest))
+ {
+ Lisp_Object v = Fcar (rest);
+ Lisp_Object ntable;
+ Emchar c
+ = to_char_code (v, "Invalid value for ->decomposition", value);
+
+ rest = Fcdr (rest);
+ if (!CONSP (rest))
+ {
+ put_char_code_table (c, character, table);
+ break;
+ }
+ else
+ {
+ ntable = get_char_code_table (c, table);
+ if (!CHAR_CODE_TABLE_P (ntable))
+ {
+ ntable = make_char_code_table (Qnil);
+ put_char_code_table (c, ntable, table);
+ }
+ table = ntable;
+ }
+ }
+ }
+ else if (EQ (attribute, Q_ucs))
+ {
+ Lisp_Object ret;
+ Emchar c;
+
+ if (!INTP (value))
+ signal_simple_error ("Invalid value for ->ucs", value);
+
+ c = XINT (value);
+
+ ret = get_char_code_table (c, Vcharacter_variant_table);
+ if (NILP (Fmemq (character, ret)))
+ {
+ put_char_code_table (c, Fcons (character, ret),
+ Vcharacter_variant_table);
+ }
+ }
+ return put_char_attribute (character, attribute, value);
+}
+
+Lisp_Object Qucs;
+
+EXFUN (Fmake_char, 3);
+
+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))))
+ {
+ cell = Fcdr (cell);
+ character = Fmake_char (ccs, Fcar (cell),
+ Fcar (Fcdr (cell)));
+ 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
+
+#ifndef UTF2000
+int leading_code_private_11;
+#endif
projects / chise / xemacs-chise.git- / blobdiff