X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fchartab.c;h=2f5c6b5185f4399426855b89f19420b5e858e98a;hb=c62fbf831d31717fb71a04dd0c8041195940f93b;hp=d87ca6c1b9ab93b17bebe2bee3e77e682d7697c9;hpb=4836e869212eaa972d5a2bdfe61730d8af7b2c61;p=chise%2Fxemacs-chise.git- diff --git a/src/chartab.c b/src/chartab.c index d87ca6c..2f5c6b5 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -4,6 +4,7 @@ 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 MORIOKA Tomohiko This file is part of XEmacs. @@ -42,20 +43,926 @@ Boston, MA 02111-1307, USA. */ #include "chartab.h" #include "syntax.h" +#ifdef UTF2000 +#include "elhash.h" + +Lisp_Object Vutf_2000_version; +#endif /* UTF2000 */ + Lisp_Object Qchar_tablep, Qchar_table; -Lisp_Object Vall_syntax_tables; +Lisp_Object Vall_syntax_tables; + +#ifdef MULE +Lisp_Object Qcategory_table_p; +Lisp_Object Qcategory_designator_p; +Lisp_Object Qcategory_table_value_p; + +Lisp_Object Vstandard_category_table; + +/* Variables to determine word boundary. */ +Lisp_Object Vword_combining_categories, Vword_separating_categories; +#endif /* MULE */ + + +#ifdef UTF2000 + +#define BT_UINT8_MIN 0 +#define BT_UINT8_MAX (UCHAR_MAX - 3) +#define BT_UINT8_t (UCHAR_MAX - 2) +#define BT_UINT8_nil (UCHAR_MAX - 1) +#define BT_UINT8_unbound UCHAR_MAX + +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 unsigned short UINT8_TO_UINT16 (unsigned char n); + +INLINE_HEADER int +INT_UINT8_P (Lisp_Object obj) +{ + if (INTP (obj)) + { + int num = XINT (obj); + + return (BT_UINT8_MIN <= num) && (num <= BT_UINT8_MAX); + } + else + return 0; +} + +INLINE_HEADER int +UINT8_VALUE_P (Lisp_Object obj) +{ + return EQ (obj, Qunbound) + || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT8_P (obj); +} + +INLINE_HEADER unsigned char +UINT8_ENCODE (Lisp_Object obj) +{ + if (EQ (obj, Qunbound)) + return BT_UINT8_unbound; + else if (EQ (obj, Qnil)) + return BT_UINT8_nil; + else if (EQ (obj, Qt)) + return BT_UINT8_t; + else + return XINT (obj); +} + +INLINE_HEADER Lisp_Object +UINT8_DECODE (unsigned char n) +{ + if (n == BT_UINT8_unbound) + return Qunbound; + else if (n == BT_UINT8_nil) + return Qnil; + else if (n == BT_UINT8_t) + return Qt; + else + return make_int (n); +} + +static Lisp_Object +mark_uint8_byte_table (Lisp_Object obj) +{ + return Qnil; +} + +static void +print_uint8_byte_table (Lisp_Object obj, + Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj); + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("\n#property[i]; + if ( (i & 15) == 0 ) + write_c_string ("\n ", printcharfun); + write_c_string (" ", printcharfun); + if (n == BT_UINT8_unbound) + write_c_string ("void", printcharfun); + else if (n == BT_UINT8_nil) + write_c_string ("nil", printcharfun); + else if (n == BT_UINT8_t) + write_c_string ("t", printcharfun); + else + { + char buf[4]; + + sprintf (buf, "%hd", n); + write_c_string (buf, printcharfun); + } + } + UNGCPRO; + write_c_string (">", printcharfun); +} + +static int +uint8_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Uint8_Byte_Table *te1 = XUINT8_BYTE_TABLE (obj1); + Lisp_Uint8_Byte_Table *te2 = XUINT8_BYTE_TABLE (obj2); + int i; + + for (i = 0; i < 256; i++) + if (te1->property[i] != te2->property[i]) + return 0; + return 1; +} + +static unsigned long +uint8_byte_table_hash (Lisp_Object obj, int depth) +{ + Lisp_Uint8_Byte_Table *te = XUINT8_BYTE_TABLE (obj); + int i; + hashcode_t hash = 0; + + for (i = 0; i < 256; i++) + hash = HASH2 (hash, te->property[i]); + return hash; +} + +static const struct lrecord_description uint8_byte_table_description[] = { + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("uint8-byte-table", uint8_byte_table, + mark_uint8_byte_table, + print_uint8_byte_table, + 0, uint8_byte_table_equal, + uint8_byte_table_hash, + uint8_byte_table_description, + Lisp_Uint8_Byte_Table); + +static Lisp_Object +make_uint8_byte_table (unsigned char initval) +{ + Lisp_Object obj; + int i; + Lisp_Uint8_Byte_Table *cte; + + cte = alloc_lcrecord_type (Lisp_Uint8_Byte_Table, + &lrecord_uint8_byte_table); + + for (i = 0; i < 256; i++) + cte->property[i] = initval; + + XSETUINT8_BYTE_TABLE (obj, cte); + return obj; +} + +static Lisp_Object +copy_uint8_byte_table (Lisp_Object entry) +{ + Lisp_Uint8_Byte_Table *cte = XUINT8_BYTE_TABLE (entry); + Lisp_Object obj; + int i; + Lisp_Uint8_Byte_Table *ctenew + = alloc_lcrecord_type (Lisp_Uint8_Byte_Table, + &lrecord_uint8_byte_table); + + for (i = 0; i < 256; i++) + { + ctenew->property[i] = cte->property[i]; + } + + XSETUINT8_BYTE_TABLE (obj, ctenew); + return obj; +} + +static int +uint8_byte_table_same_value_p (Lisp_Object obj) +{ + Lisp_Uint8_Byte_Table *bte = XUINT8_BYTE_TABLE (obj); + unsigned char v0 = bte->property[0]; + int i; + + for (i = 1; i < 256; i++) + { + if (bte->property[i] != v0) + return 0; + } + return -1; +} + +static int +map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, Emchar ofs, int place, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) +{ + struct chartab_range rainj; + int i, retval; + int unit = 1 << (8 * place); + Emchar c = ofs; + Emchar c1; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + if (ct->property[i] != BT_UINT8_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + rainj.ch = c; + retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg); + } + } + else + c += unit; + } + return retval; +} + +#define BT_UINT16_MIN 0 +#define BT_UINT16_MAX (USHRT_MAX - 3) +#define BT_UINT16_t (USHRT_MAX - 2) +#define BT_UINT16_nil (USHRT_MAX - 1) +#define BT_UINT16_unbound USHRT_MAX + +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 int +INT_UINT16_P (Lisp_Object obj) +{ + if (INTP (obj)) + { + int num = XINT (obj); + + return (BT_UINT16_MIN <= num) && (num <= BT_UINT16_MAX); + } + else + return 0; +} + +INLINE_HEADER int +UINT16_VALUE_P (Lisp_Object obj) +{ + return EQ (obj, Qunbound) + || EQ (obj, Qnil) || EQ (obj, Qt) || INT_UINT16_P (obj); +} + +INLINE_HEADER unsigned short +UINT16_ENCODE (Lisp_Object obj) +{ + if (EQ (obj, Qunbound)) + return BT_UINT16_unbound; + else if (EQ (obj, Qnil)) + return BT_UINT16_nil; + else if (EQ (obj, Qt)) + return BT_UINT16_t; + else + return XINT (obj); +} + +INLINE_HEADER Lisp_Object +UINT16_DECODE (unsigned short n) +{ + if (n == BT_UINT16_unbound) + return Qunbound; + else if (n == BT_UINT16_nil) + return Qnil; + else if (n == BT_UINT16_t) + return Qt; + else + return make_int (n); +} + +INLINE_HEADER unsigned short +UINT8_TO_UINT16 (unsigned char n) +{ + if (n == BT_UINT8_unbound) + return BT_UINT16_unbound; + else if (n == BT_UINT8_nil) + return BT_UINT16_nil; + else if (n == BT_UINT8_t) + return BT_UINT16_t; + else + return n; +} + +static Lisp_Object +mark_uint16_byte_table (Lisp_Object obj) +{ + return Qnil; +} + +static void +print_uint16_byte_table (Lisp_Object obj, + Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj); + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("\n#property[i]; + if ( (i & 15) == 0 ) + write_c_string ("\n ", printcharfun); + write_c_string (" ", printcharfun); + if (n == BT_UINT16_unbound) + write_c_string ("void", printcharfun); + else if (n == BT_UINT16_nil) + write_c_string ("nil", printcharfun); + else if (n == BT_UINT16_t) + write_c_string ("t", printcharfun); + else + { + char buf[7]; + + sprintf (buf, "%hd", n); + write_c_string (buf, printcharfun); + } + } + UNGCPRO; + write_c_string (">", printcharfun); +} + +static int +uint16_byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Uint16_Byte_Table *te1 = XUINT16_BYTE_TABLE (obj1); + Lisp_Uint16_Byte_Table *te2 = XUINT16_BYTE_TABLE (obj2); + int i; + + for (i = 0; i < 256; i++) + if (te1->property[i] != te2->property[i]) + return 0; + return 1; +} + +static unsigned long +uint16_byte_table_hash (Lisp_Object obj, int depth) +{ + Lisp_Uint16_Byte_Table *te = XUINT16_BYTE_TABLE (obj); + int i; + hashcode_t hash = 0; + + for (i = 0; i < 256; i++) + hash = HASH2 (hash, te->property[i]); + return hash; +} + +static const struct lrecord_description uint16_byte_table_description[] = { + { XD_END } +}; + +DEFINE_LRECORD_IMPLEMENTATION ("uint16-byte-table", uint16_byte_table, + mark_uint16_byte_table, + print_uint16_byte_table, + 0, uint16_byte_table_equal, + uint16_byte_table_hash, + uint16_byte_table_description, + Lisp_Uint16_Byte_Table); + +static Lisp_Object +make_uint16_byte_table (unsigned short initval) +{ + Lisp_Object obj; + int i; + Lisp_Uint16_Byte_Table *cte; + + cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table, + &lrecord_uint16_byte_table); + + for (i = 0; i < 256; i++) + cte->property[i] = initval; + + XSETUINT16_BYTE_TABLE (obj, cte); + return obj; +} + +static Lisp_Object +copy_uint16_byte_table (Lisp_Object entry) +{ + Lisp_Uint16_Byte_Table *cte = XUINT16_BYTE_TABLE (entry); + Lisp_Object obj; + int i; + Lisp_Uint16_Byte_Table *ctenew + = alloc_lcrecord_type (Lisp_Uint16_Byte_Table, + &lrecord_uint16_byte_table); + + for (i = 0; i < 256; i++) + { + ctenew->property[i] = cte->property[i]; + } + + XSETUINT16_BYTE_TABLE (obj, ctenew); + return obj; +} + +static Lisp_Object +expand_uint8_byte_table_to_uint16 (Lisp_Object table) +{ + Lisp_Object obj; + int i; + Lisp_Uint8_Byte_Table* bte = XUINT8_BYTE_TABLE(table); + Lisp_Uint16_Byte_Table* cte; + + cte = alloc_lcrecord_type (Lisp_Uint16_Byte_Table, + &lrecord_uint16_byte_table); + for (i = 0; i < 256; i++) + { + cte->property[i] = UINT8_TO_UINT16 (bte->property[i]); + } + XSETUINT16_BYTE_TABLE (obj, cte); + return obj; +} + +static int +uint16_byte_table_same_value_p (Lisp_Object obj) +{ + Lisp_Uint16_Byte_Table *bte = XUINT16_BYTE_TABLE (obj); + unsigned short v0 = bte->property[0]; + int i; + + for (i = 1; i < 256; i++) + { + if (bte->property[i] != v0) + return 0; + } + return -1; +} + +static int +map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, Emchar ofs, int place, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) +{ + struct chartab_range rainj; + int i, retval; + int unit = 1 << (8 * place); + Emchar c = ofs; + Emchar c1; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + if (ct->property[i] != BT_UINT16_unbound) + { + c1 = c + unit; + for (; c < c1 && retval == 0; c++) + { + rainj.ch = c; + retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg); + } + } + else + c += unit; + } + return retval; +} + + +static Lisp_Object +mark_byte_table (Lisp_Object obj) +{ + Lisp_Byte_Table *cte = XBYTE_TABLE (obj); + int i; + + for (i = 0; i < 256; i++) + { + mark_object (cte->property[i]); + } + return Qnil; +} + +static void +print_byte_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +{ + Lisp_Byte_Table *bte = XBYTE_TABLE (obj); + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("\n#property[i]; + if ( (i & 15) == 0 ) + write_c_string ("\n ", printcharfun); + write_c_string (" ", printcharfun); + if (EQ (elt, Qunbound)) + write_c_string ("void", printcharfun); + else + print_internal (elt, printcharfun, escapeflag); + } + UNGCPRO; + write_c_string (">", printcharfun); +} + +static int +byte_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Byte_Table *cte1 = XBYTE_TABLE (obj1); + Lisp_Byte_Table *cte2 = XBYTE_TABLE (obj2); + int i; + + for (i = 0; i < 256; i++) + if (BYTE_TABLE_P (cte1->property[i])) + { + if (BYTE_TABLE_P (cte2->property[i])) + { + if (!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 +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 Lisp_Object +copy_byte_table (Lisp_Object entry) +{ + Lisp_Byte_Table *cte = XBYTE_TABLE (entry); + Lisp_Object obj; + int i; + Lisp_Byte_Table *ctnew + = alloc_lcrecord_type (Lisp_Byte_Table, &lrecord_byte_table); + + for (i = 0; i < 256; i++) + { + if (UINT8_BYTE_TABLE_P (cte->property[i])) + { + ctnew->property[i] = copy_uint8_byte_table (cte->property[i]); + } + else if (UINT16_BYTE_TABLE_P (cte->property[i])) + { + ctnew->property[i] = copy_uint16_byte_table (cte->property[i]); + } + else if (BYTE_TABLE_P (cte->property[i])) + { + ctnew->property[i] = copy_byte_table (cte->property[i]); + } + else + ctnew->property[i] = cte->property[i]; + } + + XSETBYTE_TABLE (obj, ctnew); + 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; -#ifdef MULE -Lisp_Object Qcategory_table_p; -Lisp_Object Qcategory_designator_p; -Lisp_Object Qcategory_table_value_p; + for (i = 1; i < 256; i++) + { + if (!internal_equal (bte->property[i], v0, 0)) + return 0; + } + return -1; +} -Lisp_Object Vstandard_category_table; +static int +map_over_byte_table (Lisp_Byte_Table *ct, Emchar ofs, int place, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) +{ + int i, retval; + Lisp_Object v; + int unit = 1 << (8 * place); + Emchar c = ofs; -/* Variables to determine word boundary. */ -Lisp_Object Vword_combining_categories, Vword_separating_categories; -#endif /* MULE */ + for (i = 0, retval = 0; i < 256 && retval == 0; i++) + { + v = ct->property[i]; + if (UINT8_BYTE_TABLE_P (v)) + { + retval + = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), + c, place - 1, fn, arg); + c += unit; + } + else if (UINT16_BYTE_TABLE_P (v)) + { + retval + = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), + c, place - 1, fn, arg); + c += unit; + } + else if (BYTE_TABLE_P (v)) + { + retval = map_over_byte_table (XBYTE_TABLE(v), + c, place - 1, fn, arg); + c += unit; + } + else if (!UNBOUNDP (v)) + { + struct chartab_range rainj; + Emchar c1 = c + unit; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (; c < c1 && retval == 0; c++) + { + rainj.ch = c; + retval = (fn) (&rainj, v, arg); + } + } + else + c += unit; + } + return retval; +} + + +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; +} + + +Lisp_Object +make_char_id_table (Lisp_Object initval) +{ + Lisp_Object obj; + obj = Fmake_char_table (Qgeneric); + fill_char_table (XCHAR_TABLE (obj), initval); + return obj; +} + + +Lisp_Object Vcharacter_composition_table; +Lisp_Object Vcharacter_variant_table; + + +Lisp_Object Q_decomposition; +Lisp_Object Qto_ucs; +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); + +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 (XCHAR_TABLE(table), c); + + rest = Fcdr (rest); + if (NILP (rest)) + { + if (!CHAR_TABLEP (ret)) + return ret; + else + return Qt; + } + else if (!CONSP (rest)) + break; + else if (CHAR_TABLEP (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_TABLE(Vcharacter_variant_table), + XCHAR (character))); +} + +#endif /* A char table maps from ranges of characters to values. @@ -92,7 +999,7 @@ Lisp_Object Vword_combining_categories, Vword_separating_categories; /* Char Table object */ /************************************************************************/ -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) static Lisp_Object mark_char_table_entry (Lisp_Object obj) @@ -146,6 +1053,10 @@ static Lisp_Object mark_char_table (Lisp_Object obj) { Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 + + mark_object (ct->table); +#else int i; for (i = 0; i < NUM_ASCII_CHARS; i++) @@ -154,7 +1065,12 @@ mark_char_table (Lisp_Object obj) for (i = 0; i < NUM_LEADING_BYTES; i++) mark_object (ct->level1[i]); #endif +#endif +#ifdef UTF2000 + return ct->default_value; +#else return ct->mirror_table; +#endif } /* WARNING: All functions of this nature need to be written extremely @@ -236,7 +1152,7 @@ print_chartab_range (Emchar first, Emchar last, Lisp_Object val, print_internal (val, printcharfun, 1); } -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) static void print_chartab_charset_row (Lisp_Object charset, @@ -320,6 +1236,30 @@ static void print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 + int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); + + write_c_string ("#s(char-table ", printcharfun); + write_c_string (" ", printcharfun); + write_c_string (string_data + (symbol_name + (XSYMBOL (char_table_type_to_symbol (ct->type)))), + printcharfun); + write_c_string ("\n ", printcharfun); + print_internal (ct->default_value, printcharfun, escapeflag); + for (i = 0; i < 256; i++) + { + Lisp_Object elt = get_byte_table (ct->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; +#else /* non UTF2000 */ char buf[200]; sprintf (buf, "#s(char-table type %s data (", @@ -386,6 +1326,7 @@ print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) } } #endif /* MULE */ +#endif /* non UTF2000 */ write_c_string ("))", printcharfun); } @@ -400,6 +1341,14 @@ char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2)) return 0; +#ifdef UTF2000 + for (i = 0; i < 256; i++) + { + if (!internal_equal (get_byte_table (ct1->table, i), + get_byte_table (ct2->table, i), 0)) + return 0; + } +#else for (i = 0; i < NUM_ASCII_CHARS; i++) if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1)) return 0; @@ -409,6 +1358,7 @@ char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1)) return 0; #endif /* MULE */ +#endif /* non UTF2000 */ return 1; } @@ -417,6 +1367,9 @@ static unsigned long char_table_hash (Lisp_Object obj, int depth) { Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 + return byte_table_hash (ct->table, depth + 1); +#else unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS, depth); #ifdef MULE @@ -424,14 +1377,22 @@ char_table_hash (Lisp_Object obj, int depth) internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth)); #endif /* MULE */ return hashval; +#endif } static const struct lrecord_description char_table_description[] = { +#ifdef UTF2000 + { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, table) }, + { XD_LISP_OBJECT, offsetof(Lisp_Char_Table, default_value) }, +#else { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS }, #ifdef MULE { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES }, #endif +#endif +#ifndef UTF2000 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) }, +#endif { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) }, { XD_END } }; @@ -545,6 +1506,10 @@ See `valid-char-table-type-p'. void fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) { +#ifdef UTF2000 + ct->table = Qunbound; + ct->default_value = value; +#else int i; for (i = 0; i < NUM_ASCII_CHARS; i++) @@ -553,9 +1518,12 @@ fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) for (i = 0; i < NUM_LEADING_BYTES; i++) ct->level1[i] = value; #endif /* MULE */ +#endif +#ifndef UTF2000 if (ct->type == CHAR_TABLE_TYPE_SYNTAX) update_syntax_table (ct); +#endif } DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /* @@ -605,6 +1573,7 @@ and 'syntax. See `valid-char-table-type-p'. ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); ct->type = ty; +#ifndef UTF2000 if (ty == CHAR_TABLE_TYPE_SYNTAX) { ct->mirror_table = Fmake_char_table (Qgeneric); @@ -613,6 +1582,7 @@ and 'syntax. See `valid-char-table-type-p'. } else ct->mirror_table = Qnil; +#endif ct->next_table = Qnil; XSETCHAR_TABLE (obj, ct); if (ty == CHAR_TABLE_TYPE_SYNTAX) @@ -624,7 +1594,7 @@ and 'syntax. See `valid-char-table-type-p'. return obj; } -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) static Lisp_Object make_char_table_entry (Lisp_Object initval) @@ -674,12 +1644,32 @@ as CHAR-TABLE. The values will not themselves be copied. { Lisp_Char_Table *ct, *ctnew; Lisp_Object obj; +#ifndef UTF2000 int i; +#endif CHECK_CHAR_TABLE (char_table); ct = XCHAR_TABLE (char_table); ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); ctnew->type = ct->type; +#ifdef UTF2000 + ctnew->default_value = ct->default_value; + + if (UINT8_BYTE_TABLE_P (ct->table)) + { + ctnew->table = copy_uint8_byte_table (ct->table); + } + else if (UINT16_BYTE_TABLE_P (ct->table)) + { + ctnew->table = copy_uint16_byte_table (ct->table); + } + else if (BYTE_TABLE_P (ct->table)) + { + ctnew->table = copy_byte_table (ct->table); + } + else if (!UNBOUNDP (ct->table)) + ctnew->table = ct->table; +#else /* non UTF2000 */ for (i = 0; i < NUM_ASCII_CHARS; i++) { @@ -702,11 +1692,14 @@ as CHAR-TABLE. The values will not themselves be copied. } #endif /* MULE */ +#endif /* non UTF2000 */ +#ifndef UTF2000 if (CHAR_TABLEP (ct->mirror_table)) ctnew->mirror_table = Fcopy_char_table (ct->mirror_table); else ctnew->mirror_table = ct->mirror_table; +#endif ctnew->next_table = Qnil; XSETCHAR_TABLE (obj, ctnew); if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX) @@ -717,11 +1710,40 @@ as CHAR-TABLE. The values will not themselves be copied. return obj; } -static void +INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs); +INLINE_HEADER int +XCHARSET_CELL_RANGE (Lisp_Object ccs) +{ + switch (XCHARSET_CHARS (ccs)) + { + case 94: + return (33 << 8) | 126; + case 96: + return (32 << 8) | 127; +#ifdef UTF2000 + case 128: + return (0 << 8) | 127; + case 256: + return (0 << 8) | 255; +#endif + default: + abort (); + return 0; + } +} + +#ifndef UTF2000 +static +#endif +void decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) { if (EQ (range, Qt)) outrange->type = CHARTAB_RANGE_ALL; +#ifdef UTF2000 + else if (EQ (range, Qnil)) + outrange->type = CHARTAB_RANGE_DEFAULT; +#endif else if (CHAR_OR_CHAR_INTP (range)) { outrange->type = CHARTAB_RANGE_CHAR; @@ -735,30 +1757,39 @@ decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) { Lisp_Vector *vec = XVECTOR (range); Lisp_Object *elts = vector_data (vec); - if (vector_length (vec) != 2) - signal_simple_error ("Length of charset row vector must be 2", - range); + int cell_min, cell_max; + outrange->type = CHARTAB_RANGE_ROW; outrange->charset = Fget_charset (elts[0]); CHECK_INT (elts[1]); outrange->row = XINT (elts[1]); - if (XCHARSET_DIMENSION (outrange->charset) >= 2) + if (XCHARSET_DIMENSION (outrange->charset) < 2) + signal_simple_error ("Charset in row vector must be multi-byte", + outrange->charset); + else { - switch (XCHARSET_CHARS (outrange->charset)) - { - case 94: - check_int_range (outrange->row, 33, 126); - break; - case 96: - check_int_range (outrange->row, 32, 127); - break; - default: - abort (); - } + int ret = XCHARSET_CELL_RANGE (outrange->charset); + + cell_min = ret >> 8; + cell_max = ret & 0xFF; + } + if (XCHARSET_DIMENSION (outrange->charset) == 2) + check_int_range (outrange->row, cell_min, cell_max); +#ifdef UTF2000 + else if (XCHARSET_DIMENSION (outrange->charset) == 3) + { + check_int_range (outrange->row >> 8 , cell_min, cell_max); + check_int_range (outrange->row & 0xFF, cell_min, cell_max); + } + else if (XCHARSET_DIMENSION (outrange->charset) == 4) + { + check_int_range ( outrange->row >> 16 , cell_min, cell_max); + check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max); + check_int_range ( outrange->row & 0xFF, cell_min, cell_max); } +#endif else - signal_simple_error ("Charset in row vector must be multi-byte", - outrange->charset); + abort (); } else { @@ -771,7 +1802,7 @@ decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) #endif /* MULE */ } -#ifdef MULE +#if defined(MULE)&&!defined(UTF2000) /* called from CHAR_TABLE_VALUE(). */ Lisp_Object @@ -813,7 +1844,9 @@ get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte, Lisp_Object get_char_table (Emchar ch, Lisp_Char_Table *ct) { -#ifdef MULE +#ifdef UTF2000 + return get_char_id_table (ct, ch); +#elif defined(MULE) { Lisp_Object charset; int byte1, byte2; @@ -881,6 +1914,16 @@ If there is more than one value, return MULTI (defaults to nil). { case CHARTAB_RANGE_ALL: { +#ifdef UTF2000 + if (UINT8_BYTE_TABLE_P (ct->table)) + return multi; + else if (UINT16_BYTE_TABLE_P (ct->table)) + return multi; + else if (BYTE_TABLE_P (ct->table)) + return multi; + else + return ct->table; +#else /* non UTF2000 */ int i; Lisp_Object first = ct->ascii[0]; @@ -902,10 +1945,14 @@ If there is more than one value, return MULTI (defaults to nil). #endif /* MULE */ return first; +#endif /* non UTF2000 */ } #ifdef MULE case CHARTAB_RANGE_CHARSET: +#ifdef UTF2000 + return multi; +#else if (EQ (rainj.charset, Vcharset_ascii)) { int i; @@ -935,8 +1982,12 @@ If there is more than one value, return MULTI (defaults to nil). return multi; return val; } +#endif case CHARTAB_RANGE_ROW: +#ifdef UTF2000 + return multi; +#else { Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - MIN_LEADING_BYTE]; @@ -947,6 +1998,7 @@ If there is more than one value, return MULTI (defaults to nil). return multi; return val; } +#endif /* not UTF2000 */ #endif /* not MULE */ default: @@ -1059,12 +2111,46 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, 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. */ +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + ct->default_value = val; + return; +#endif + #ifdef MULE case CHARTAB_RANGE_CHARSET: +#ifdef UTF2000 + { + Emchar c; + 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) ) + { + for (c = 0; c < 1 << 24; c++) + { + if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table), + c)) ) + put_char_id_table_0 (ct, c, val); + } + } + else + { + for (c = 0; c < 1 << 24; c++) + { + if ( charset_code_point (range->charset, c, 0) >= 0 ) + put_char_id_table_0 (ct, c, val); + } + } + } +#else if (EQ (range->charset, Vcharset_ascii)) { int i; @@ -1082,9 +2168,26 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; ct->level1[lb] = val; } +#endif break; case CHARTAB_RANGE_ROW: +#ifdef UTF2000 + { + int cell_min, cell_max, i; + + i = XCHARSET_CELL_RANGE (range->charset); + cell_min = i >> 8; + cell_max = i & 0xFF; + for (i = cell_min; i <= cell_max; i++) + { + Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i); + + if ( charset_code_point (range->charset, ch, 0) >= 0 ) + put_char_id_table_0 (ct, ch, val); + } + } +#else { Lisp_Char_Table_Entry *cte; int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; @@ -1094,11 +2197,16 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); cte->level2[range->row - 32] = val; } +#endif /* not UTF2000 */ break; #endif /* MULE */ case CHARTAB_RANGE_CHAR: -#ifdef MULE +#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) { Lisp_Object charset; int byte1, byte2; @@ -1140,8 +2248,10 @@ put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, #endif /* not MULE */ } +#ifndef UTF2000 if (ct->type == CHAR_TABLE_TYPE_SYNTAX) update_syntax_table (ct); +#endif } DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /* @@ -1173,6 +2283,7 @@ See `valid-char-table-type-p'. return Qnil; } +#ifndef UTF2000 /* Map FN over the ASCII chars in CT. */ static int @@ -1318,11 +2429,56 @@ map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb, retval = map_over_charset_row (cte, charset, i, fn, arg); } - return retval; - } -} + return retval; + } +} + +#endif /* MULE */ +#endif /* not UTF2000 */ + +#ifdef UTF2000 +struct map_char_table_for_charset_arg +{ + int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg); + Lisp_Char_Table *ct; + void *arg; +}; + +static int +map_char_table_for_charset_fun (struct chartab_range *range, + Lisp_Object val, void *arg) +{ + struct map_char_table_for_charset_arg *closure = + (struct map_char_table_for_charset_arg *) arg; + Lisp_Object ret; + + switch (range->type) + { + case CHARTAB_RANGE_ALL: + break; + + case CHARTAB_RANGE_DEFAULT: + break; + + case CHARTAB_RANGE_CHARSET: + break; + + case CHARTAB_RANGE_ROW: + break; -#endif /* MULE */ + case CHARTAB_RANGE_CHAR: + ret = get_char_table (range->ch, closure->ct); + if (!UNBOUNDP (ret)) + return (closure->fn) (range, ret, closure->arg); + break; + + default: + abort (); + } + + return 0; +} +#endif /* Map FN (with client data ARG) over range RANGE in char table CT. Mapping stops the first time FN returns non-zero, and that value @@ -1338,6 +2494,49 @@ map_char_table (Lisp_Char_Table *ct, switch (range->type) { case CHARTAB_RANGE_ALL: +#ifdef UTF2000 + if (!UNBOUNDP (ct->default_value)) + { + struct chartab_range rainj; + int retval; + + rainj.type = CHARTAB_RANGE_DEFAULT; + retval = (fn) (&rainj, ct->default_value, arg); + if (retval != 0) + return retval; + } + if (UINT8_BYTE_TABLE_P (ct->table)) + return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(ct->table), + 0, 3, fn, arg); + else if (UINT16_BYTE_TABLE_P (ct->table)) + return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(ct->table), + 0, 3, fn, arg); + else if (BYTE_TABLE_P (ct->table)) + return map_over_byte_table (XBYTE_TABLE(ct->table), + 0, 3, fn, arg); + else if (!UNBOUNDP (ct->table)) +#if 0 + { + struct chartab_range rainj; + int unit = 1 << 30; + Emchar c = 0; + Emchar c1 = c + unit; + int retval; + + rainj.type = CHARTAB_RANGE_CHAR; + + for (retval = 0; c < c1 && retval == 0; c++) + { + rainj.ch = c; + retval = (fn) (&rainj, ct->table, arg); + } + return retval; + } +#else + return (fn) (range, ct->table, arg); +#endif + return 0; +#else { int retval; @@ -1361,14 +2560,80 @@ map_char_table (Lisp_Char_Table *ct, #endif /* MULE */ return retval; } +#endif + +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + if (!UNBOUNDP (ct->default_value)) + return (fn) (range, ct->default_value, arg); + return 0; +#endif #ifdef MULE case CHARTAB_RANGE_CHARSET: +#ifdef UTF2000 + { + Lisp_Object encoding_table + = XCHARSET_ENCODING_TABLE (range->charset); + + if (!NILP (encoding_table)) + { + struct chartab_range rainj; + struct map_char_table_for_charset_arg mcarg; + + mcarg.fn = fn; + mcarg.ct = ct; + mcarg.arg = arg; + rainj.type = CHARTAB_RANGE_ALL; + return map_char_table (XCHAR_TABLE(encoding_table), + &rainj, + &map_char_table_for_charset_fun, + &mcarg); + } + } + return 0; +#else return map_over_other_charset (ct, XCHARSET_LEADING_BYTE (range->charset), fn, arg); +#endif case CHARTAB_RANGE_ROW: +#ifdef UTF2000 + { + int cell_min, cell_max, i; + int retval; + struct chartab_range rainj; + + i = XCHARSET_CELL_RANGE (range->charset); + cell_min = i >> 8; + cell_max = i & 0xFF; + rainj.type = CHARTAB_RANGE_CHAR; + for (retval =0, i = cell_min; i <= cell_max && retval == 0; i++) + { + Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i); + + if ( charset_code_point (range->charset, ch, 0) >= 0 ) + { + Lisp_Object val + = get_byte_table (get_byte_table + (get_byte_table + (get_byte_table + (ct->table, + (unsigned char)(ch >> 24)), + (unsigned char) (ch >> 16)), + (unsigned char) (ch >> 8)), + (unsigned char) ch); + + if (UNBOUNDP (val)) + val = ct->default_value; + rainj.ch = ch; + retval = (fn) (&rainj, val, arg); + } + } + return retval; + } +#else { Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE]; @@ -1386,17 +2651,23 @@ map_char_table (Lisp_Char_Table *ct, range->charset, range->row, fn, arg); } +#endif /* not UTF2000 */ #endif /* MULE */ case CHARTAB_RANGE_CHAR: { Emchar ch = range->ch; Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch); - struct chartab_range rainj; - rainj.type = CHARTAB_RANGE_CHAR; - rainj.ch = ch; - return (fn) (&rainj, val, arg); + if (!UNBOUNDP (val)) + { + struct chartab_range rainj; + + rainj.type = CHARTAB_RANGE_CHAR; + rainj.ch = ch; + return (fn) (&rainj, val, arg); + } + return 0; } default: @@ -1426,6 +2697,12 @@ slow_map_char_table_fun (struct chartab_range *range, ranjarg = Qt; break; +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + ranjarg = Qnil; + break; +#endif + #ifdef MULE case CHARTAB_RANGE_CHARSET: ranjarg = XCHARSET_NAME (range->charset); @@ -1476,6 +2753,440 @@ the entire table. return slarg.retval; } + +/************************************************************************/ +/* Character Attributes */ +/************************************************************************/ + +#ifdef UTF2000 + +Lisp_Object Vchar_attribute_hash_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 (XCHAR_TABLE(value), caacl->char_id); + 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)) +{ + struct gcpro gcpro1; + struct char_attribute_alist_closure char_attribute_alist_closure; + Lisp_Object alist = Qnil; + + CHECK_CHAR (character); + + 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; + + 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 table; + + CHECK_CHAR (character); + + if (CHARSETP (attribute)) + attribute = XCHARSET_NAME (attribute); + + table = Fgethash (attribute, Vchar_attribute_hash_table, + Qunbound); + if (!UNBOUNDP (table)) + { + Lisp_Object ret = get_char_id_table (XCHAR_TABLE(table), + XCHAR (character)); + 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 = Ffind_charset (attribute); + + if (!NILP (ccs)) + { + CHECK_CHAR (character); + value = put_char_ccs_code_point (character, ccs, value); + attribute = XCHARSET_NAME (ccs); + } + else if (EQ (attribute, Q_decomposition)) + { + Lisp_Object seq; + + CHECK_CHAR (character); + 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 (XCHAR_TABLE(table), + make_char (c), character); + break; + } + else + { + ntable = get_char_id_table (XCHAR_TABLE(table), c); + if (!CHAR_TABLEP (ntable)) + { + ntable = make_char_id_table (Qnil); + put_char_id_table (XCHAR_TABLE(table), + make_char (c), ntable); + } + table = ntable; + } + } + } + else + { + Lisp_Object v = Fcar (value); + + if (INTP (v)) + { + Emchar c = XINT (v); + Lisp_Object ret + = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + c); + + if (NILP (Fmemq (v, ret))) + { + put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + make_char (c), Fcons (character, ret)); + } + } + seq = make_vector (1, v); + } + value = seq; + } + else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs)) + { + Lisp_Object ret; + Emchar c; + + CHECK_CHAR (character); + if (!INTP (value)) + signal_simple_error ("Invalid value for ->ucs", value); + + c = XINT (value); + + ret = get_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), c); + if (NILP (Fmemq (character, ret))) + { + put_char_id_table (XCHAR_TABLE(Vcharacter_variant_table), + make_char (c), Fcons (character, ret)); + } +#if 0 + if (EQ (attribute, Q_ucs)) + attribute = Qto_ucs; +#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); + } + put_char_id_table (XCHAR_TABLE(table), character, value); + 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_TABLE(table), character, Qunbound); + return Qt; + } + } + return Qnil; +} + +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. + +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 +the entire table. +*/ + (function, attribute, range)) +{ + Lisp_Object ccs; + Lisp_Char_Table *ct; + struct slow_map_char_table_arg slarg; + struct gcpro gcpro1, gcpro2; + struct chartab_range rainj; + + if (!NILP (ccs = Ffind_charset (attribute))) + { + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + + if (CHAR_TABLEP (encoding_table)) + ct = XCHAR_TABLE (encoding_table); + else + return Qnil; + } + else + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + if (CHAR_TABLEP (table)) + ct = XCHAR_TABLE (table); + else + return Qnil; + } + if (NILP (range)) + range = Qt; + decode_char_table_range (range, &rainj); + slarg.function = function; + slarg.retval = Qnil; + GCPRO2 (slarg.function, slarg.retval); + map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg); + UNGCPRO; + + return slarg.retval; +} + +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 character; + + if (NILP (code)) + code = Fcdr (Fassq (Qucs, attributes)); + 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) != 0) || + (XCHARSET_MAX_CODE (ccs) > 0) || + (EQ (ccs, Vcharset_chinese_big5))) ) + { + cell = Fcdr (cell); + if (CONSP (cell)) + character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); + else + character = Fdecode_char (ccs, cell, Qnil); + if (!NILP (character)) + goto setup_attributes; + } + rest = Fcdr (rest); + } + if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) || + (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) ) + + { + if (!INTP (code)) + signal_simple_error ("Invalid argument", attributes); + else + character = make_char (XINT (code) + 0x100000); + goto setup_attributes; + } + 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 character; +} + +DEFUN ("find-char", Ffind_char, 1, 1, 0, /* +Retrieve the character of the given ATTRIBUTES. +*/ + (attributes)) +{ + Lisp_Object rest = attributes; + Lisp_Object 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); + if (CONSP (cell)) + return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); + else + return Fdecode_char (ccs, cell, Qnil); + } + rest = Fcdr (rest); + } + if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) || + (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) ) + { + if (!INTP (code)) + signal_simple_error ("Invalid argument", attributes); + else + return make_char (XINT (code) + 0x100000); + } + return Qnil; +} + +#endif /************************************************************************/ @@ -1622,7 +3333,7 @@ check_category_table (Lisp_Object object, Lisp_Object default_) int check_category_char (Emchar ch, Lisp_Object table, - unsigned int designator, unsigned int not) + unsigned int designator, unsigned int not_p) { REGISTER Lisp_Object temp; Lisp_Char_Table *ctbl; @@ -1633,10 +3344,10 @@ check_category_char (Emchar ch, Lisp_Object table, ctbl = XCHAR_TABLE (table); temp = get_char_table (ch, ctbl); if (NILP (temp)) - return not; + return not_p; designator -= ' '; - return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not : not; + return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p; } DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /* @@ -1812,10 +3523,51 @@ word_boundary_p (Emchar c1, Emchar c2) void syms_of_chartab (void) { +#ifdef UTF2000 + INIT_LRECORD_IMPLEMENTATION (uint8_byte_table); + INIT_LRECORD_IMPLEMENTATION (uint16_byte_table); + INIT_LRECORD_IMPLEMENTATION (byte_table); + + defsymbol (&Qto_ucs, "=>ucs"); + defsymbol (&Q_ucs, "->ucs"); + defsymbol (&Q_decomposition, "->decomposition"); + defsymbol (&Qcompat, "compat"); + defsymbol (&Qisolated, "isolated"); + defsymbol (&Qinitial, "initial"); + defsymbol (&Qmedial, "medial"); + defsymbol (&Qfinal, "final"); + defsymbol (&Qvertical, "vertical"); + defsymbol (&QnoBreak, "noBreak"); + defsymbol (&Qfraction, "fraction"); + defsymbol (&Qsuper, "super"); + defsymbol (&Qsub, "sub"); + defsymbol (&Qcircle, "circle"); + defsymbol (&Qsquare, "square"); + defsymbol (&Qwide, "wide"); + defsymbol (&Qnarrow, "narrow"); + defsymbol (&Qsmall, "small"); + defsymbol (&Qfont, "font"); + + DEFSUBR (Fchar_attribute_list); + DEFSUBR (Ffind_char_attribute_table); + DEFSUBR (Fchar_attribute_alist); + DEFSUBR (Fget_char_attribute); + DEFSUBR (Fput_char_attribute); + DEFSUBR (Fremove_char_attribute); + DEFSUBR (Fmap_char_attribute); + DEFSUBR (Fdefine_char); + DEFSUBR (Ffind_char); + DEFSUBR (Fchar_variants); + + DEFSUBR (Fget_composite_char); +#endif + INIT_LRECORD_IMPLEMENTATION (char_table); #ifdef MULE +#ifndef UTF2000 INIT_LRECORD_IMPLEMENTATION (char_table_entry); +#endif defsymbol (&Qcategory_table_p, "category-table-p"); defsymbol (&Qcategory_designator_p, "category-designator-p"); @@ -1856,6 +3608,18 @@ syms_of_chartab (void) void vars_of_chartab (void) { +#ifdef UTF2000 + Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)"); + DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /* +Version number of XEmacs UTF-2000. +*/ ); + + staticpro (&Vcharacter_composition_table); + Vcharacter_composition_table = make_char_id_table (Qnil); + + staticpro (&Vcharacter_variant_table); + Vcharacter_variant_table = make_char_id_table (Qnil); +#endif /* DO NOT staticpro this. It works just like Vweak_hash_tables. */ Vall_syntax_tables = Qnil; dump_add_weak_object_chain (&Vall_syntax_tables); @@ -1875,6 +3639,11 @@ structure_type_create_chartab (void) void complex_vars_of_chartab (void) { +#ifdef UTF2000 + staticpro (&Vchar_attribute_hash_table); + Vchar_attribute_hash_table + = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); +#endif /* UTF2000 */ #ifdef MULE /* Set this now, so first buffer creation can refer to it. */ /* Make it nil before calling copy-category-table