+static unsigned long
+byte_table_hash (Lisp_Object obj, int depth)
+{
+ Lisp_Byte_Table *cte = XBYTE_TABLE (obj);
+
+ return internal_array_hash (cte->property, 256, depth);
+}
+
+static const struct lrecord_description byte_table_description[] = {
+ { XD_LISP_OBJECT_ARRAY, offsetof(Lisp_Byte_Table, property), 256 },
+ { XD_END }
+};
+
+DEFINE_LRECORD_IMPLEMENTATION ("byte-table", byte_table,
+ mark_byte_table,
+ print_byte_table,
+ 0, byte_table_equal,
+ byte_table_hash,
+ byte_table_description,
+ Lisp_Byte_Table);
+
+static Lisp_Object
+make_byte_table (Lisp_Object initval)
+{
+ Lisp_Object obj;
+ int i;
+ Lisp_Byte_Table *cte;
+
+ cte = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table);
+
+ for (i = 0; i < 256; i++)
+ cte->property[i] = initval;
+
+ XSETBYTE_TABLE (obj, cte);
+ return obj;
+}
+
+static int
+byte_table_same_value_p (Lisp_Object obj)
+{
+ Lisp_Byte_Table *bte = XBYTE_TABLE (obj);
+ Lisp_Object v0 = bte->property[0];
+ int i;
+
+ for (i = 1; i < 256; i++)
+ {
+ if (!internal_equal (bte->property[i], v0, 0))
+ return 0;
+ }
+ return -1;
+}
+
+
+Lisp_Object get_byte_table (Lisp_Object table, unsigned char idx);
+Lisp_Object put_byte_table (Lisp_Object table, unsigned char idx,
+ Lisp_Object value);
+
+Lisp_Object
+get_byte_table (Lisp_Object table, unsigned char idx)
+{
+ if (UINT8_BYTE_TABLE_P (table))
+ return UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[idx]);
+ else if (UINT16_BYTE_TABLE_P (table))
+ return UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[idx]);
+ else if (BYTE_TABLE_P (table))
+ return XBYTE_TABLE(table)->property[idx];
+ else
+ return table;
+}
+
+Lisp_Object
+put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object value)
+{
+ if (UINT8_BYTE_TABLE_P (table))
+ {
+ if (UINT8_VALUE_P (value))
+ {
+ XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
+ if (!UINT8_BYTE_TABLE_P (value) &&
+ !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
+ && uint8_byte_table_same_value_p (table))
+ {
+ return value;
+ }
+ }
+ else if (UINT16_VALUE_P (value))
+ {
+ Lisp_Object new = expand_uint8_byte_table_to_uint16 (table);
+
+ XUINT16_BYTE_TABLE(new)->property[idx] = UINT16_ENCODE (value);
+ return new;
+ }
+ else
+ {
+ Lisp_Object new = make_byte_table (Qnil);
+ int i;
+
+ for (i = 0; i < 256; i++)
+ {
+ XBYTE_TABLE(new)->property[i]
+ = UINT8_DECODE (XUINT8_BYTE_TABLE(table)->property[i]);
+ }
+ XBYTE_TABLE(new)->property[idx] = value;
+ return new;
+ }
+ }
+ else if (UINT16_BYTE_TABLE_P (table))
+ {
+ if (UINT16_VALUE_P (value))
+ {
+ XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
+ if (!UINT8_BYTE_TABLE_P (value) &&
+ !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
+ && uint16_byte_table_same_value_p (table))
+ {
+ return value;
+ }
+ }
+ else
+ {
+ Lisp_Object new = make_byte_table (Qnil);
+ int i;
+
+ for (i = 0; i < 256; i++)
+ {
+ XBYTE_TABLE(new)->property[i]
+ = UINT16_DECODE (XUINT16_BYTE_TABLE(table)->property[i]);
+ }
+ XBYTE_TABLE(new)->property[idx] = value;
+ return new;
+ }
+ }
+ else if (BYTE_TABLE_P (table))
+ {
+ XBYTE_TABLE(table)->property[idx] = value;
+ if (!UINT8_BYTE_TABLE_P (value) &&
+ !UINT16_BYTE_TABLE_P (value) && !BYTE_TABLE_P (value)
+ && byte_table_same_value_p (table))
+ {
+ return value;
+ }
+ }
+ else if (!internal_equal (table, value, 0))
+ {
+ if (UINT8_VALUE_P (table) && UINT8_VALUE_P (value))
+ {
+ table = make_uint8_byte_table (UINT8_ENCODE (table));
+ XUINT8_BYTE_TABLE(table)->property[idx] = UINT8_ENCODE (value);
+ }
+ else if (UINT16_VALUE_P (table) && UINT16_VALUE_P (value))
+ {
+ table = make_uint16_byte_table (UINT16_ENCODE (table));
+ XUINT16_BYTE_TABLE(table)->property[idx] = UINT16_ENCODE (value);
+ }
+ else
+ {
+ table = make_byte_table (table);
+ XBYTE_TABLE(table)->property[idx] = value;
+ }
+ }
+ return table;
+}
+
+static Lisp_Object
+mark_char_id_table (Lisp_Object obj)
+{
+ Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj);
+
+ return cte->table;
+}
+
+static void
+print_char_id_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
+{
+ Lisp_Object table = XCHAR_ID_TABLE (obj)->table;
+ int i;
+ struct gcpro gcpro1, gcpro2;
+ GCPRO2 (obj, printcharfun);
+
+ write_c_string ("#<char-id-table ", printcharfun);
+ for (i = 0; i < 256; i++)
+ {
+ Lisp_Object elt = get_byte_table (table, i);
+ if (i != 0) write_c_string ("\n ", printcharfun);
+ if (EQ (elt, Qunbound))
+ write_c_string ("void", printcharfun);
+ else
+ print_internal (elt, printcharfun, escapeflag);
+ }
+ UNGCPRO;
+ write_c_string (">", printcharfun);
+}
+
+static int
+char_id_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+{
+ Lisp_Object table1 = XCHAR_ID_TABLE (obj1)->table;
+ Lisp_Object table2 = XCHAR_ID_TABLE (obj2)->table;
+ int i;
+
+ for (i = 0; i < 256; i++)
+ {
+ if (!internal_equal (get_byte_table (table1, i),
+ get_byte_table (table2, i), 0))
+ return 0;
+ }
+ return -1;
+}
+
+static unsigned long
+char_id_table_hash (Lisp_Object obj, int depth)
+{
+ Lisp_Char_ID_Table *cte = XCHAR_ID_TABLE (obj);
+
+ return char_id_table_hash (cte->table, depth + 1);
+}
+
+static const struct lrecord_description char_id_table_description[] = {
+ { XD_LISP_OBJECT, offsetof(Lisp_Char_ID_Table, table) },
+ { XD_END }
+};
+
+DEFINE_LRECORD_IMPLEMENTATION ("char-id-table", char_id_table,
+ mark_char_id_table,
+ print_char_id_table,
+ 0, char_id_table_equal,
+ char_id_table_hash,
+ char_id_table_description,
+ Lisp_Char_ID_Table);
+
+static Lisp_Object
+make_char_id_table (Lisp_Object initval)
+{
+ Lisp_Object obj;
+ Lisp_Char_ID_Table *cte;
+
+ cte = alloc_lcrecord_type (Lisp_Char_ID_Table, &lrecord_char_id_table);
+
+ cte->table = make_byte_table (initval);
+
+ XSETCHAR_ID_TABLE (obj, cte);
+ return obj;
+}
+
+
+Lisp_Object
+get_char_id_table (Emchar ch, Lisp_Object table)
+{
+ unsigned int code = ch;
+
+ return
+ get_byte_table
+ (get_byte_table
+ (get_byte_table
+ (get_byte_table
+ (XCHAR_ID_TABLE (table)->table,
+ (unsigned char)(code >> 24)),
+ (unsigned char) (code >> 16)),
+ (unsigned char) (code >> 8)),
+ (unsigned char) code);
+}
+
+void put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table);
+void
+put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table)
+{
+ unsigned int code = ch;
+ Lisp_Object table1, table2, table3, table4;
+
+ table1 = XCHAR_ID_TABLE (table)->table;
+ table2 = get_byte_table (table1, (unsigned char)(code >> 24));
+ table3 = get_byte_table (table2, (unsigned char)(code >> 16));
+ table4 = get_byte_table (table3, (unsigned char)(code >> 8));
+
+ table4 = put_byte_table (table4, (unsigned char)code, value);
+ table3 = put_byte_table (table3, (unsigned char)(code >> 8), table4);
+ table2 = put_byte_table (table2, (unsigned char)(code >> 16), table3);
+ XCHAR_ID_TABLE (table)->table
+ = put_byte_table (table1, (unsigned char)(code >> 24), table2);
+}
+
+
+Lisp_Object Vchar_attribute_hash_table;
+Lisp_Object Vcharacter_composition_table;
+Lisp_Object Vcharacter_variant_table;
+
+Lisp_Object Qideograph_daikanwa;
+Lisp_Object Q_decomposition;
+Lisp_Object Qucs;
+Lisp_Object Q_ucs;
+Lisp_Object Qcompat;
+Lisp_Object Qisolated;
+Lisp_Object Qinitial;
+Lisp_Object Qmedial;
+Lisp_Object Qfinal;
+Lisp_Object Qvertical;
+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 Qsmall;
+Lisp_Object Qfont;
+
+Emchar to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg);
+
+Lisp_Object put_char_ccs_code_point (Lisp_Object character,
+ Lisp_Object ccs, Lisp_Object value);
+Lisp_Object remove_char_ccs (Lisp_Object character, Lisp_Object ccs);
+
+Emchar
+to_char_id (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, Qisolated))
+ return -2;
+ else if (EQ (v, Qinitial))
+ return -3;
+ else if (EQ (v, Qmedial))
+ return -4;
+ else if (EQ (v, Qfinal))
+ return -5;
+ else if (EQ (v, Qvertical))
+ return -6;
+ else if (EQ (v, QnoBreak))
+ return -7;
+ else if (EQ (v, Qfraction))
+ return -8;
+ else if (EQ (v, Qsuper))
+ return -9;
+ else if (EQ (v, Qsub))
+ return -10;
+ else if (EQ (v, Qcircle))
+ return -11;
+ else if (EQ (v, Qsquare))
+ return -12;
+ else if (EQ (v, Qwide))
+ return -13;
+ else if (EQ (v, Qnarrow))
+ return -14;
+ else if (EQ (v, Qsmall))
+ return -15;
+ else if (EQ (v, Qfont))
+ return -16;
+ 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_id (v, "Invalid value for composition", list);
+
+ ret = get_char_id_table (c, table);
+
+ rest = Fcdr (rest);
+ if (NILP (rest))
+ {
+ if (!CHAR_ID_TABLE_P (ret))
+ return ret;
+ else
+ return Qt;
+ }
+ else if (!CONSP (rest))
+ break;
+ else if (CHAR_ID_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_id_table (XCHAR (character),
+ Vcharacter_variant_table));
+}
+
+
+/* We store the char-attributes in hash tables with the names as the
+ key and the actual char-id-table object as the value. Occasionally
+ we need to use them in a list format. These routines provide us
+ with that. */
+struct char_attribute_list_closure
+{
+ Lisp_Object *char_attribute_list;
+};
+
+static int
+add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
+ void *char_attribute_list_closure)
+{
+ /* This function can GC */
+ struct char_attribute_list_closure *calcl
+ = (struct char_attribute_list_closure*) char_attribute_list_closure;
+ Lisp_Object *char_attribute_list = calcl->char_attribute_list;
+
+ *char_attribute_list = Fcons (key, *char_attribute_list);
+ return 0;
+}
+
+DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
+Return the list of all existing character attributes except coded-charsets.
+*/
+ ())
+{
+ Lisp_Object char_attribute_list = Qnil;
+ struct gcpro gcpro1;
+ struct char_attribute_list_closure char_attribute_list_closure;
+
+ GCPRO1 (char_attribute_list);
+ char_attribute_list_closure.char_attribute_list = &char_attribute_list;
+ elisp_maphash (add_char_attribute_to_list_mapper,
+ Vchar_attribute_hash_table,
+ &char_attribute_list_closure);
+ UNGCPRO;
+ return char_attribute_list;
+}
+
+DEFUN ("find-char-attribute-table", Ffind_char_attribute_table, 1, 1, 0, /*
+Return char-id-table corresponding to ATTRIBUTE.
+*/
+ (attribute))
+{
+ return Fgethash (attribute, Vchar_attribute_hash_table, Qnil);
+}
+
+
+/* We store the char-id-tables in hash tables with the attributes as
+ the key and the actual char-id-table object as the value. Each
+ char-id-table stores values of an attribute corresponding with
+ characters. Occasionally we need to get attributes of a character
+ in a association-list format. These routines provide us with
+ that. */
+struct char_attribute_alist_closure
+{
+ Emchar char_id;
+ Lisp_Object *char_attribute_alist;
+};
+
+static int
+add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
+ void *char_attribute_alist_closure)
+{
+ /* This function can GC */
+ struct char_attribute_alist_closure *caacl =
+ (struct char_attribute_alist_closure*) char_attribute_alist_closure;
+ Lisp_Object ret = get_char_id_table (caacl->char_id, value);
+ if (!UNBOUNDP (ret))
+ {
+ Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
+ *char_attribute_alist
+ = Fcons (Fcons (key, ret), *char_attribute_alist);
+ }
+ return 0;
+}
+
+DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
+Return the alist of attributes of CHARACTER.
+*/
+ (character))
+{
+ Lisp_Object alist = Qnil;
+ int i;
+
+ CHECK_CHAR (character);
+ {
+ struct gcpro gcpro1;
+ struct char_attribute_alist_closure char_attribute_alist_closure;
+
+ GCPRO1 (alist);
+ char_attribute_alist_closure.char_id = XCHAR (character);
+ char_attribute_alist_closure.char_attribute_alist = &alist;
+ elisp_maphash (add_char_attribute_alist_mapper,
+ Vchar_attribute_hash_table,
+ &char_attribute_alist_closure);
+ UNGCPRO;
+ }
+
+ for (i = 0; i < countof (chlook->charset_by_leading_byte); i++)
+ {
+ Lisp_Object ccs = chlook->charset_by_leading_byte[i];
+
+ if (!NILP (ccs))
+ {
+ Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
+ Lisp_Object cpos;
+
+ if ( CHAR_ID_TABLE_P (encoding_table)
+ && INTP (cpos = get_char_id_table (XCHAR (character),
+ encoding_table)) )
+ {
+ alist = Fcons (Fcons (ccs, cpos), alist);
+ }
+ }
+ }
+ return alist;
+}
+
+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.
+*/
+ (character, attribute, default_value))
+{
+ Lisp_Object ccs;
+
+ CHECK_CHAR (character);
+ if (!NILP (ccs = Ffind_charset (attribute)))
+ {
+ Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
+
+ if (CHAR_ID_TABLE_P (encoding_table))
+ return get_char_id_table (XCHAR (character), encoding_table);
+ }
+ else
+ {
+ Lisp_Object table = Fgethash (attribute,
+ Vchar_attribute_hash_table,
+ Qunbound);
+ if (!UNBOUNDP (table))
+ {
+ Lisp_Object ret = get_char_id_table (XCHAR (character), table);
+ if (!UNBOUNDP (ret))
+ return ret;
+ }
+ }
+ return default_value;
+}
+
+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))
+ {
+ return put_char_ccs_code_point (character, ccs, value);
+ }
+ else if (EQ (attribute, Q_decomposition))
+ {
+ Lisp_Object seq;
+
+ if (!CONSP (value))
+ signal_simple_error ("Invalid value for ->decomposition",
+ value);
+
+ if (CONSP (Fcdr (value)))
+ {
+ Lisp_Object rest = value;
+ Lisp_Object table = Vcharacter_composition_table;
+ size_t len;
+ int i = 0;
+
+ GET_EXTERNAL_LIST_LENGTH (rest, len);
+ seq = make_vector (len, Qnil);
+
+ while (CONSP (rest))
+ {
+ Lisp_Object v = Fcar (rest);
+ Lisp_Object ntable;
+ Emchar c
+ = to_char_id (v, "Invalid value for ->decomposition", value);
+
+ if (c < 0)
+ XVECTOR_DATA(seq)[i++] = v;
+ else
+ XVECTOR_DATA(seq)[i++] = make_char (c);
+ rest = Fcdr (rest);
+ if (!CONSP (rest))
+ {
+ put_char_id_table (c, character, table);
+ break;
+ }
+ else
+ {
+ ntable = get_char_id_table (c, table);
+ if (!CHAR_ID_TABLE_P (ntable))
+ {
+ ntable = make_char_id_table (Qnil);
+ put_char_id_table (c, ntable, table);
+ }
+ table = ntable;
+ }
+ }
+ }
+ else
+ {
+ Lisp_Object v = Fcar (value);
+
+ if (INTP (v))
+ {
+ Emchar c = XINT (v);
+ Lisp_Object ret
+ = get_char_id_table (c, Vcharacter_variant_table);
+
+ if (NILP (Fmemq (v, ret)))
+ {
+ put_char_id_table (c, Fcons (character, ret),
+ Vcharacter_variant_table);
+ }
+ }
+ seq = make_vector (1, v);
+ }
+ value = seq;
+ }
+ 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_id_table (c, Vcharacter_variant_table);
+ if (NILP (Fmemq (character, ret)))
+ {
+ put_char_id_table (c, Fcons (character, ret),
+ Vcharacter_variant_table);
+ }
+ }
+ {
+ 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);
+ }
+ put_char_id_table (XCHAR (character), value, table);
+ return value;
+ }
+}
+
+DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
+Remove CHARACTER's ATTRIBUTE.
+*/
+ (character, attribute))
+{
+ Lisp_Object ccs;
+
+ CHECK_CHAR (character);
+ ccs = Ffind_charset (attribute);
+ if (!NILP (ccs))
+ {
+ return remove_char_ccs (character, ccs);
+ }
+ else
+ {
+ Lisp_Object table = Fgethash (attribute,
+ Vchar_attribute_hash_table,
+ Qunbound);
+ if (!UNBOUNDP (table))
+ {
+ put_char_id_table (XCHAR (character), Qunbound, table);
+ return Qt;
+ }
+ }
+ return Qnil;
+}
+
+INLINE_HEADER int CHARSET_BYTE_SIZE (Lisp_Charset* cs);
+INLINE_HEADER int
+CHARSET_BYTE_SIZE (Lisp_Charset* cs)