X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fchartab.c;h=6e12d840e5598646ea12bf7ca98b41b210313e61;hb=15fd1e6e063e07e811ab9d9e4611682baa4df555;hp=6cfecf1ad785cb978e42f28536a08a4740bc24b1;hpb=4ac7f614e1cb1ea373cb7c6db18984dff6d28f94;p=chise%2Fxemacs-chise.git diff --git a/src/chartab.c b/src/chartab.c index 6cfecf1..6e12d84 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. @@ -189,12 +190,16 @@ uint8_byte_table_hash (Lisp_Object obj, int depth) 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, - 0 /* uint8_byte_table_description */, + uint8_byte_table_description, Lisp_Uint8_Byte_Table); static Lisp_Object @@ -214,6 +219,25 @@ make_uint8_byte_table (unsigned char initval) 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) { @@ -230,22 +254,29 @@ uint8_byte_table_same_value_p (Lisp_Object obj) } static int -map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct, - int (*fn) (Emchar c, Lisp_Object val, void *arg), - void *arg, Emchar ofs, int place) +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++) - retval = (fn) (c, UINT8_DECODE (ct->property[i]), arg); + { + rainj.ch = c; + retval = (fn) (&rainj, UINT8_DECODE (ct->property[i]), arg); + } } else c += unit; @@ -388,12 +419,16 @@ uint16_byte_table_hash (Lisp_Object obj, int depth) 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, - 0 /* uint16_byte_table_description */, + uint16_byte_table_description, Lisp_Uint16_Byte_Table); static Lisp_Object @@ -414,6 +449,25 @@ make_uint16_byte_table (unsigned short initval) } 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; @@ -447,22 +501,29 @@ uint16_byte_table_same_value_p (Lisp_Object obj) } static int -map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct, - int (*fn) (Emchar c, Lisp_Object val, void *arg), - void *arg, Emchar ofs, int place) +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++) - retval = (fn) (c, UINT16_DECODE (ct->property[i]), arg); + { + rainj.ch = c; + retval = (fn) (&rainj, UINT16_DECODE (ct->property[i]), arg); + } } else c += unit; @@ -570,6 +631,37 @@ make_byte_table (Lisp_Object initval) 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) { @@ -586,9 +678,10 @@ byte_table_same_value_p (Lisp_Object obj) } static int -map_over_byte_table (Lisp_Byte_Table *ct, - int (*fn) (Emchar c, Lisp_Object val, void *arg), - void *arg, Emchar ofs, int place) +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; @@ -602,28 +695,34 @@ map_over_byte_table (Lisp_Byte_Table *ct, { retval = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), - fn, arg, c, place - 1); + c, place - 1, fn, arg); c += unit; } else if (UINT16_BYTE_TABLE_P (v)) { retval = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), - fn, arg, c, place - 1); + c, place - 1, fn, arg); c += unit; } else if (BYTE_TABLE_P (v)) { retval = map_over_byte_table (XBYTE_TABLE(v), - fn, arg, c, place - 1); + 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++) - retval = (fn) (c, v, arg); + { + rainj.ch = c; + retval = (fn) (&rainj, v, arg); + } } else c += unit; @@ -632,10 +731,6 @@ map_over_byte_table (Lisp_Byte_Table *ct, } -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) { @@ -742,174 +837,17 @@ put_byte_table (Lisp_Object table, unsigned char idx, Lisp_Object 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 ("#", 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); 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); + obj = Fmake_char_table (Qgeneric); + fill_char_table (XCHAR_TABLE (obj), initval); 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) -{ - 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); -} - -/* Map FN (with client data ARG) in char table CT. - Mapping stops the first time FN returns non-zero, and that value - becomes the return value of map_char_id_table(). */ -int -map_char_id_table (Lisp_Char_ID_Table *ct, - int (*fn) (Emchar c, Lisp_Object val, void *arg), - void *arg); -int -map_char_id_table (Lisp_Char_ID_Table *ct, - int (*fn) (Emchar c, Lisp_Object val, void *arg), - void *arg) -{ - Lisp_Object v = ct->table; - - if (UINT8_BYTE_TABLE_P (v)) - return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), fn, arg, 0, 3); - else if (UINT16_BYTE_TABLE_P (v)) - return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), fn, arg, 0, 3); - else if (BYTE_TABLE_P (v)) - return map_over_byte_table (XBYTE_TABLE(v), fn, arg, 0, 3); - else if (!UNBOUNDP (v)) - { - int unit = 1 << 24; - Emchar c = 0; - Emchar c1 = c + unit; - int retval; - - for (retval = 0; c < c1 && retval == 0; c++) - retval = (fn) (c, v, arg); - } - return 0; -} - -struct slow_map_char_id_table_arg -{ - Lisp_Object function; - Lisp_Object retval; -}; - -static int -slow_map_char_id_table_fun (Emchar c, Lisp_Object val, void *arg) -{ - struct slow_map_char_id_table_arg *closure = - (struct slow_map_char_id_table_arg *) arg; - - closure->retval = call2 (closure->function, make_char (c), val); - return !NILP (closure->retval); -} - - -Lisp_Object Vchar_attribute_hash_table; Lisp_Object Vcharacter_composition_table; Lisp_Object Vcharacter_variant_table; @@ -993,19 +931,19 @@ Return character corresponding with list. Lisp_Object ret; Emchar c = to_char_id (v, "Invalid value for composition", list); - ret = get_char_id_table (c, table); + ret = get_char_id_table (XCHAR_TABLE(table), c); rest = Fcdr (rest); if (NILP (rest)) { - if (!CHAR_ID_TABLE_P (ret)) + if (!CHAR_TABLEP (ret)) return ret; else return Qt; } else if (!CONSP (rest)) break; - else if (CHAR_ID_TABLE_P (ret)) + else if (CHAR_TABLEP (ret)) table = ret; else signal_simple_error ("Invalid table is found with", list); @@ -1019,749 +957,346 @@ Return variants of CHARACTER. (character)) { CHECK_CHAR (character); - return Fcopy_list (get_char_id_table (XCHAR (character), - Vcharacter_variant_table)); + return Fcopy_list (get_char_id_table + (XCHAR_TABLE(Vcharacter_variant_table), + XCHAR (character))); } +#endif -/* 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; -}; + +/* A char table maps from ranges of characters to values. -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; + Implementing a general data structure that maps from arbitrary + ranges of numbers to values is tricky to do efficiently. As it + happens, it should suffice (and is usually more convenient, anyway) + when dealing with characters to restrict the sorts of ranges that + can be assigned values, as follows: - *char_attribute_list = Fcons (key, *char_attribute_list); - return 0; -} + 1) All characters. + 2) All characters in a charset. + 3) All characters in a particular row of a charset, where a "row" + means all characters with the same first byte. + 4) A particular character in a charset. -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; -} + We use char tables to generalize the 256-element vectors now + littering the Emacs code. -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); -} + Possible uses (all should be converted at some point): + 1) category tables + 2) syntax tables + 3) display tables + 4) case tables + 5) keyboard-translate-table? -/* 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; -}; + We provide an + abstract type to generalize the Emacs vectors and Mule + vectors-of-vectors goo. + */ -static int -add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value, - void *char_attribute_alist_closure) +/************************************************************************/ +/* Char Table object */ +/************************************************************************/ + +#if defined(MULE)&&!defined(UTF2000) + +static Lisp_Object +mark_char_table_entry (Lisp_Object obj) { - /* 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_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); + int i; + + for (i = 0; i < 96; i++) { - Lisp_Object *char_attribute_alist = caacl->char_attribute_alist; - *char_attribute_alist - = Fcons (Fcons (key, ret), *char_attribute_alist); + mark_object (cte->level2[i]); } - return 0; + return Qnil; } -DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /* -Return the alist of attributes of CHARACTER. -*/ - (character)) +static int +char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - Lisp_Object alist = Qnil; + Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1); + Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2); 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; + for (i = 0; i < 96; i++) + if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1)) + return 0; - 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; + return 1; } -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)) +static unsigned long +char_table_entry_hash (Lisp_Object obj, int depth) { - Lisp_Object ccs; - - CHECK_CHAR (character); - if (!NILP (ccs = Ffind_charset (attribute))) - { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); - 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; + return internal_array_hash (cte->level2, 96, depth); } -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; +static const struct lrecord_description char_table_entry_description[] = { + { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 }, + { XD_END } +}; - if (!CONSP (value)) - signal_simple_error ("Invalid value for ->decomposition", - value); +DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry, + mark_char_table_entry, internal_object_printer, + 0, char_table_entry_equal, + char_table_entry_hash, + char_table_entry_description, + Lisp_Char_Table_Entry); +#endif /* MULE */ - if (CONSP (Fcdr (value))) - { - Lisp_Object rest = value; - Lisp_Object table = Vcharacter_composition_table; - size_t len; - int i = 0; +static Lisp_Object +mark_char_table (Lisp_Object obj) +{ + Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 - GET_EXTERNAL_LIST_LENGTH (rest, len); - seq = make_vector (len, Qnil); + mark_object (ct->table); +#else + int i; - while (CONSP (rest)) - { - Lisp_Object v = Fcar (rest); - Lisp_Object ntable; - Emchar c - = to_char_id (v, "Invalid value for ->decomposition", value); + for (i = 0; i < NUM_ASCII_CHARS; i++) + mark_object (ct->ascii[i]); +#ifdef MULE + 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 +} - 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); +/* WARNING: All functions of this nature need to be written extremely + carefully to avoid crashes during GC. Cf. prune_specifiers() + and prune_weak_hash_tables(). */ - if (INTP (v)) - { - Emchar c = XINT (v); - Lisp_Object ret - = get_char_id_table (c, Vcharacter_variant_table); +void +prune_syntax_tables (void) +{ + Lisp_Object rest, prev = Qnil; - 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, Qto_ucs) || EQ (attribute, Q_ucs)) + for (rest = Vall_syntax_tables; + !NILP (rest); + rest = XCHAR_TABLE (rest)->next_table) { - 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))) + if (! marked_p (rest)) { - put_char_id_table (c, Fcons (character, ret), - Vcharacter_variant_table); + /* This table is garbage. Remove it from the list. */ + if (NILP (prev)) + Vall_syntax_tables = XCHAR_TABLE (rest)->next_table; + else + XCHAR_TABLE (prev)->next_table = + XCHAR_TABLE (rest)->next_table; } -#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 (character), value, table); - return value; +static Lisp_Object +char_table_type_to_symbol (enum char_table_type type) +{ + switch (type) + { + default: abort(); + case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; + case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; + case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; + case CHAR_TABLE_TYPE_CHAR: return Qchar; +#ifdef MULE + case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; +#endif } } - -DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /* -Remove CHARACTER's ATTRIBUTE. -*/ - (character, attribute)) + +static enum char_table_type +symbol_to_char_table_type (Lisp_Object symbol) { - Lisp_Object ccs; + CHECK_SYMBOL (symbol); - CHECK_CHAR (character); - ccs = Ffind_charset (attribute); - if (!NILP (ccs)) + if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC; + if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX; + if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY; + if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR; +#ifdef MULE + if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY; +#endif + + signal_simple_error ("Unrecognized char table type", symbol); + return CHAR_TABLE_TYPE_GENERIC; /* not reached */ +} + +static void +print_chartab_range (Emchar first, Emchar last, Lisp_Object val, + Lisp_Object printcharfun) +{ + if (first != last) { - return remove_char_ccs (character, ccs); + write_c_string (" (", printcharfun); + print_internal (make_char (first), printcharfun, 0); + write_c_string (" ", printcharfun); + print_internal (make_char (last), printcharfun, 0); + write_c_string (") ", printcharfun); } else { - Lisp_Object table = Fgethash (attribute, - Vchar_attribute_hash_table, - Qunbound); - if (!UNBOUNDP (table)) - { - put_char_id_table (XCHAR (character), Qunbound, table); - return Qt; - } + write_c_string (" ", printcharfun); + print_internal (make_char (first), printcharfun, 0); + write_c_string (" ", printcharfun); } - return Qnil; + print_internal (val, printcharfun, 1); } -DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 2, 0, /* -Map FUNCTION over entries in ATTRIBUTE, calling it with two args, -each key and value in the table. -*/ - (function, attribute)) -{ - Lisp_Object ccs; - Lisp_Char_ID_Table *ct; - struct slow_map_char_id_table_arg slarg; - struct gcpro gcpro1, gcpro2; - - if (!NILP (ccs = Ffind_charset (attribute))) - { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); +#if defined(MULE)&&!defined(UTF2000) - if (CHAR_ID_TABLE_P (encoding_table)) - ct = XCHAR_ID_TABLE (encoding_table); - else - return Qnil; - } - else - { - Lisp_Object table = Fgethash (attribute, - Vchar_attribute_hash_table, - Qunbound); - if (CHAR_ID_TABLE_P (table)) - ct = XCHAR_ID_TABLE (table); - else - return Qnil; - } - slarg.function = function; - slarg.retval = Qnil; - GCPRO2 (slarg.function, slarg.retval); - map_char_id_table (ct, slow_map_char_id_table_fun, &slarg); - UNGCPRO; - - return slarg.retval; -} - -EXFUN (Fmake_char, 3); -EXFUN (Fdecode_char, 2); - -DEFUN ("define-char", Fdefine_char, 1, 1, 0, /* -Store character's ATTRIBUTES. -*/ - (attributes)) +static void +print_chartab_charset_row (Lisp_Object charset, + int row, + Lisp_Char_Table_Entry *cte, + Lisp_Object printcharfun) { - Lisp_Object rest = attributes; - Lisp_Object code = Fcdr (Fassq (Qucs, attributes)); - Lisp_Object character; + int i; + Lisp_Object cat = Qunbound; + int first = -1; - if (NILP (code)) + for (i = 32; i < 128; i++) { - while (CONSP (rest)) - { - Lisp_Object cell = Fcar (rest); - Lisp_Object ccs; + Lisp_Object pam = cte->level2[i - 32]; - if (!LISTP (cell)) - signal_simple_error ("Invalid argument", attributes); - if (!NILP (ccs = Ffind_charset (Fcar (cell))) - && ((XCHARSET_FINAL (ccs) != 0) || - (XCHARSET_UCS_MAX (ccs) > 0)) ) - { - cell = Fcdr (cell); - if (CONSP (cell)) - character = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); - else - character = Fdecode_char (ccs, cell); - if (!NILP (character)) - goto setup_attributes; - } - rest = Fcdr (rest); + if (first == -1) + { + first = i; + cat = pam; + continue; } - if ( (!NILP (code = Fcdr (Fassq (Qto_ucs, attributes)))) || - (!NILP (code = Fcdr (Fassq (Q_ucs, attributes)))) ) - + + if (!EQ (cat, pam)) { - if (!INTP (code)) - signal_simple_error ("Invalid argument", attributes); + if (row == -1) + print_chartab_range (MAKE_CHAR (charset, first, 0), + MAKE_CHAR (charset, i - 1, 0), + cat, printcharfun); else - character = make_char (XINT (code) + 0x100000); - goto setup_attributes; + print_chartab_range (MAKE_CHAR (charset, row, first), + MAKE_CHAR (charset, row, i - 1), + cat, printcharfun); + first = -1; + i--; } - 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)) + if (first != -1) { - 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); + if (row == -1) + print_chartab_range (MAKE_CHAR (charset, first, 0), + MAKE_CHAR (charset, i - 1, 0), + cat, printcharfun); + else + print_chartab_range (MAKE_CHAR (charset, row, first), + MAKE_CHAR (charset, row, i - 1), + cat, printcharfun); } - return character; } -DEFUN ("find-char", Ffind_char, 1, 1, 0, /* -Retrieve the character of the given ATTRIBUTES. -*/ - (attributes)) +static void +print_chartab_two_byte_charset (Lisp_Object charset, + Lisp_Char_Table_Entry *cte, + Lisp_Object printcharfun) { - Lisp_Object rest = attributes; - Lisp_Object code; + int i; - while (CONSP (rest)) + for (i = 32; i < 128; i++) { - Lisp_Object cell = Fcar (rest); - Lisp_Object ccs; + Lisp_Object jen = cte->level2[i - 32]; - if (!LISTP (cell)) - signal_simple_error ("Invalid argument", attributes); - if (!NILP (ccs = Ffind_charset (Fcar (cell)))) + if (!CHAR_TABLE_ENTRYP (jen)) { - cell = Fcdr (cell); - if (CONSP (cell)) - return Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); - else - return Fdecode_char (ccs, cell); + char buf[100]; + + write_c_string (" [", printcharfun); + print_internal (XCHARSET_NAME (charset), printcharfun, 0); + sprintf (buf, " %d] ", i); + write_c_string (buf, printcharfun); + print_internal (jen, printcharfun, 0); } - 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); + print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen), + printcharfun); } - return Qnil; } -#endif - - -/* A char table maps from ranges of characters to values. - - Implementing a general data structure that maps from arbitrary - ranges of numbers to values is tricky to do efficiently. As it - happens, it should suffice (and is usually more convenient, anyway) - when dealing with characters to restrict the sorts of ranges that - can be assigned values, as follows: - - 1) All characters. - 2) All characters in a charset. - 3) All characters in a particular row of a charset, where a "row" - means all characters with the same first byte. - 4) A particular character in a charset. - - We use char tables to generalize the 256-element vectors now - littering the Emacs code. - - Possible uses (all should be converted at some point): - - 1) category tables - 2) syntax tables - 3) display tables - 4) case tables - 5) keyboard-translate-table? - - We provide an - abstract type to generalize the Emacs vectors and Mule - vectors-of-vectors goo. - */ - -/************************************************************************/ -/* Char Table object */ -/************************************************************************/ - -#ifdef MULE +#endif /* MULE */ -static Lisp_Object -mark_char_table_entry (Lisp_Object obj) +static void +print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); + Lisp_Char_Table *ct = XCHAR_TABLE (obj); +#ifdef UTF2000 int i; + struct gcpro gcpro1, gcpro2; + GCPRO2 (obj, printcharfun); - for (i = 0; i < 96; i++) + 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++) { - mark_object (cte->level2[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); } - return Qnil; -} + UNGCPRO; +#else /* non UTF2000 */ + char buf[200]; -static int -char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) -{ - Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1); - Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2); - int i; + sprintf (buf, "#s(char-table type %s data (", + string_data (symbol_name (XSYMBOL + (char_table_type_to_symbol (ct->type))))); + write_c_string (buf, printcharfun); - for (i = 0; i < 96; i++) - if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1)) - return 0; + /* Now write out the ASCII/Control-1 stuff. */ + { + int i; + int first = -1; + Lisp_Object val = Qunbound; - return 1; -} + for (i = 0; i < NUM_ASCII_CHARS; i++) + { + if (first == -1) + { + first = i; + val = ct->ascii[i]; + continue; + } -static unsigned long -char_table_entry_hash (Lisp_Object obj, int depth) -{ - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); + if (!EQ (ct->ascii[i], val)) + { + print_chartab_range (first, i - 1, val, printcharfun); + first = -1; + i--; + } + } - return internal_array_hash (cte->level2, 96, depth); -} + if (first != -1) + print_chartab_range (first, i - 1, val, printcharfun); + } -static const struct lrecord_description char_table_entry_description[] = { - { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 }, - { XD_END } -}; - -DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry, - mark_char_table_entry, internal_object_printer, - 0, char_table_entry_equal, - char_table_entry_hash, - char_table_entry_description, - Lisp_Char_Table_Entry); -#endif /* MULE */ - -static Lisp_Object -mark_char_table (Lisp_Object obj) -{ - Lisp_Char_Table *ct = XCHAR_TABLE (obj); - int i; - - for (i = 0; i < NUM_ASCII_CHARS; i++) - mark_object (ct->ascii[i]); -#ifdef MULE - for (i = 0; i < NUM_LEADING_BYTES; i++) - mark_object (ct->level1[i]); -#endif - return ct->mirror_table; -} - -/* WARNING: All functions of this nature need to be written extremely - carefully to avoid crashes during GC. Cf. prune_specifiers() - and prune_weak_hash_tables(). */ - -void -prune_syntax_tables (void) -{ - Lisp_Object rest, prev = Qnil; - - for (rest = Vall_syntax_tables; - !NILP (rest); - rest = XCHAR_TABLE (rest)->next_table) - { - if (! marked_p (rest)) - { - /* This table is garbage. Remove it from the list. */ - if (NILP (prev)) - Vall_syntax_tables = XCHAR_TABLE (rest)->next_table; - else - XCHAR_TABLE (prev)->next_table = - XCHAR_TABLE (rest)->next_table; - } - } -} - -static Lisp_Object -char_table_type_to_symbol (enum char_table_type type) -{ - switch (type) - { - default: abort(); - case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; - case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; - case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; - case CHAR_TABLE_TYPE_CHAR: return Qchar; -#ifdef MULE - case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; -#endif - } -} - -static enum char_table_type -symbol_to_char_table_type (Lisp_Object symbol) -{ - CHECK_SYMBOL (symbol); - - if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC; - if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX; - if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY; - if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR; -#ifdef MULE - if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY; -#endif - - signal_simple_error ("Unrecognized char table type", symbol); - return CHAR_TABLE_TYPE_GENERIC; /* not reached */ -} - -static void -print_chartab_range (Emchar first, Emchar last, Lisp_Object val, - Lisp_Object printcharfun) -{ - if (first != last) - { - write_c_string (" (", printcharfun); - print_internal (make_char (first), printcharfun, 0); - write_c_string (" ", printcharfun); - print_internal (make_char (last), printcharfun, 0); - write_c_string (") ", printcharfun); - } - else - { - write_c_string (" ", printcharfun); - print_internal (make_char (first), printcharfun, 0); - write_c_string (" ", printcharfun); - } - print_internal (val, printcharfun, 1); -} - -#ifdef MULE - -static void -print_chartab_charset_row (Lisp_Object charset, - int row, - Lisp_Char_Table_Entry *cte, - Lisp_Object printcharfun) -{ - int i; - Lisp_Object cat = Qunbound; - int first = -1; - - for (i = 32; i < 128; i++) - { - Lisp_Object pam = cte->level2[i - 32]; - - if (first == -1) - { - first = i; - cat = pam; - continue; - } - - if (!EQ (cat, pam)) - { - if (row == -1) - print_chartab_range (MAKE_CHAR (charset, first, 0), - MAKE_CHAR (charset, i - 1, 0), - cat, printcharfun); - else - print_chartab_range (MAKE_CHAR (charset, row, first), - MAKE_CHAR (charset, row, i - 1), - cat, printcharfun); - first = -1; - i--; - } - } - - if (first != -1) - { - if (row == -1) - print_chartab_range (MAKE_CHAR (charset, first, 0), - MAKE_CHAR (charset, i - 1, 0), - cat, printcharfun); - else - print_chartab_range (MAKE_CHAR (charset, row, first), - MAKE_CHAR (charset, row, i - 1), - cat, printcharfun); - } -} - -static void -print_chartab_two_byte_charset (Lisp_Object charset, - Lisp_Char_Table_Entry *cte, - Lisp_Object printcharfun) -{ - int i; - - for (i = 32; i < 128; i++) - { - Lisp_Object jen = cte->level2[i - 32]; - - if (!CHAR_TABLE_ENTRYP (jen)) - { - char buf[100]; - - write_c_string (" [", printcharfun); - print_internal (XCHARSET_NAME (charset), printcharfun, 0); - sprintf (buf, " %d] ", i); - write_c_string (buf, printcharfun); - print_internal (jen, printcharfun, 0); - } - else - print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen), - printcharfun); - } -} - -#endif /* MULE */ - -static void -print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) -{ - Lisp_Char_Table *ct = XCHAR_TABLE (obj); - char buf[200]; - - sprintf (buf, "#s(char-table type %s data (", - string_data (symbol_name (XSYMBOL - (char_table_type_to_symbol (ct->type))))); - write_c_string (buf, printcharfun); - - /* Now write out the ASCII/Control-1 stuff. */ - { - int i; - int first = -1; - Lisp_Object val = Qunbound; - - for (i = 0; i < NUM_ASCII_CHARS; i++) - { - if (first == -1) - { - first = i; - val = ct->ascii[i]; - continue; - } - - if (!EQ (ct->ascii[i], val)) - { - print_chartab_range (first, i - 1, val, printcharfun); - first = -1; - i--; - } - } - - if (first != -1) - print_chartab_range (first, i - 1, val, printcharfun); - } - -#ifdef MULE - { - Charset_ID i; +#ifdef MULE + { + Charset_ID i; for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; i++) @@ -1791,6 +1326,7 @@ print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) } } #endif /* MULE */ +#endif /* non UTF2000 */ write_c_string ("))", printcharfun); } @@ -1805,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; @@ -1814,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; } @@ -1822,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 @@ -1829,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 } }; @@ -1950,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++) @@ -1958,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, /* @@ -1994,881 +1557,1517 @@ Reset CHAR-TABLE to its default state. abort (); } - return Qnil; -} + return Qnil; +} + +DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /* +Return a new, empty char table of type TYPE. +Currently recognized types are 'char, 'category, 'display, 'generic, +and 'syntax. See `valid-char-table-type-p'. +*/ + (type)) +{ + Lisp_Char_Table *ct; + Lisp_Object obj; + enum char_table_type ty = symbol_to_char_table_type (type); + + 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); + fill_char_table (XCHAR_TABLE (ct->mirror_table), + make_int (Spunct)); + } + else + ct->mirror_table = Qnil; +#endif + ct->next_table = Qnil; + XSETCHAR_TABLE (obj, ct); + if (ty == CHAR_TABLE_TYPE_SYNTAX) + { + ct->next_table = Vall_syntax_tables; + Vall_syntax_tables = obj; + } + Freset_char_table (obj); + return obj; +} + +#if defined(MULE)&&!defined(UTF2000) + +static Lisp_Object +make_char_table_entry (Lisp_Object initval) +{ + Lisp_Object obj; + int i; + Lisp_Char_Table_Entry *cte = + alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); + + for (i = 0; i < 96; i++) + cte->level2[i] = initval; + + XSETCHAR_TABLE_ENTRY (obj, cte); + return obj; +} + +static Lisp_Object +copy_char_table_entry (Lisp_Object entry) +{ + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry); + Lisp_Object obj; + int i; + Lisp_Char_Table_Entry *ctenew = + alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); + + for (i = 0; i < 96; i++) + { + Lisp_Object new = cte->level2[i]; + if (CHAR_TABLE_ENTRYP (new)) + ctenew->level2[i] = copy_char_table_entry (new); + else + ctenew->level2[i] = new; + } + + XSETCHAR_TABLE_ENTRY (obj, ctenew); + return obj; +} + +#endif /* MULE */ + +DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /* +Return a new char table which is a copy of CHAR-TABLE. +It will contain the same values for the same characters and ranges +as CHAR-TABLE. The values will not themselves be copied. +*/ + (char_table)) +{ + 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++) + { + Lisp_Object new = ct->ascii[i]; +#ifdef MULE + assert (! (CHAR_TABLE_ENTRYP (new))); +#endif /* MULE */ + ctnew->ascii[i] = new; + } + +#ifdef MULE + + for (i = 0; i < NUM_LEADING_BYTES; i++) + { + Lisp_Object new = ct->level1[i]; + if (CHAR_TABLE_ENTRYP (new)) + ctnew->level1[i] = copy_char_table_entry (new); + else + ctnew->level1[i] = new; + } + +#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) + { + ctnew->next_table = Vall_syntax_tables; + Vall_syntax_tables = obj; + } + return obj; +} + +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; + else if (EQ (range, Qnil)) + outrange->type = CHARTAB_RANGE_DEFAULT; + else if (CHAR_OR_CHAR_INTP (range)) + { + outrange->type = CHARTAB_RANGE_CHAR; + outrange->ch = XCHAR_OR_CHAR_INT (range); + } +#ifndef MULE + else + signal_simple_error ("Range must be t or a character", range); +#else /* MULE */ + else if (VECTORP (range)) + { + Lisp_Vector *vec = XVECTOR (range); + Lisp_Object *elts = vector_data (vec); + 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) + signal_simple_error ("Charset in row vector must be multi-byte", + outrange->charset); + else + { + 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 + abort (); + } + else + { + if (!CHARSETP (range) && !SYMBOLP (range)) + signal_simple_error + ("Char table range must be t, charset, char, or vector", range); + outrange->type = CHARTAB_RANGE_CHARSET; + outrange->charset = Fget_charset (range); + } +#endif /* MULE */ +} + +#if defined(MULE)&&!defined(UTF2000) + +/* called from CHAR_TABLE_VALUE(). */ +Lisp_Object +get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte, + Emchar c) +{ + Lisp_Object val; +#ifdef UTF2000 + Lisp_Object charset; +#else + Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte); +#endif + int byte1, byte2; + +#ifdef UTF2000 + BREAKUP_CHAR (c, charset, byte1, byte2); +#else + BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2); +#endif + val = ct->level1[leading_byte - MIN_LEADING_BYTE]; + if (CHAR_TABLE_ENTRYP (val)) + { + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); + val = cte->level2[byte1 - 32]; + if (CHAR_TABLE_ENTRYP (val)) + { + cte = XCHAR_TABLE_ENTRY (val); + assert (byte2 >= 32); + val = cte->level2[byte2 - 32]; + assert (!CHAR_TABLE_ENTRYP (val)); + } + } + + return val; +} + +#endif /* MULE */ + +Lisp_Object +get_char_table (Emchar ch, Lisp_Char_Table *ct) +{ +#ifdef UTF2000 + return get_char_id_table (ct, ch); +#elif defined(MULE) + { + Lisp_Object charset; + int byte1, byte2; + Lisp_Object val; + + BREAKUP_CHAR (ch, charset, byte1, byte2); + + if (EQ (charset, Vcharset_ascii)) + val = ct->ascii[byte1]; + else if (EQ (charset, Vcharset_control_1)) + val = ct->ascii[byte1 + 128]; + else + { + int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; + val = ct->level1[lb]; + if (CHAR_TABLE_ENTRYP (val)) + { + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); + val = cte->level2[byte1 - 32]; + if (CHAR_TABLE_ENTRYP (val)) + { + cte = XCHAR_TABLE_ENTRY (val); + assert (byte2 >= 32); + val = cte->level2[byte2 - 32]; + assert (!CHAR_TABLE_ENTRYP (val)); + } + } + } + + return val; + } +#else /* not MULE */ + return ct->ascii[(unsigned char)ch]; +#endif /* not MULE */ +} + + +DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /* +Find value for CHARACTER in CHAR-TABLE. +*/ + (character, char_table)) +{ + CHECK_CHAR_TABLE (char_table); + CHECK_CHAR_COERCE_INT (character); + + return get_char_table (XCHAR (character), XCHAR_TABLE (char_table)); +} + +DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /* +Find value for a range in CHAR-TABLE. +If there is more than one value, return MULTI (defaults to nil). +*/ + (range, char_table, multi)) +{ + Lisp_Char_Table *ct; + struct chartab_range rainj; + + if (CHAR_OR_CHAR_INTP (range)) + return Fget_char_table (range, char_table); + CHECK_CHAR_TABLE (char_table); + ct = XCHAR_TABLE (char_table); + + decode_char_table_range (range, &rainj); + switch (rainj.type) + { + 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]; + + for (i = 1; i < NUM_ASCII_CHARS; i++) + if (!EQ (first, ct->ascii[i])) + return multi; + +#ifdef MULE + for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; + i++) + { + if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i)) + || i == LEADING_BYTE_ASCII + || i == LEADING_BYTE_CONTROL_1) + continue; + if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE])) + return multi; + } +#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; + Lisp_Object first = ct->ascii[0]; + + for (i = 1; i < 128; i++) + if (!EQ (first, ct->ascii[i])) + return multi; + return first; + } + + if (EQ (rainj.charset, Vcharset_control_1)) + { + int i; + Lisp_Object first = ct->ascii[128]; + + for (i = 129; i < 160; i++) + if (!EQ (first, ct->ascii[i])) + return multi; + return first; + } + + { + Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - + MIN_LEADING_BYTE]; + if (CHAR_TABLE_ENTRYP (val)) + 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]; + if (!CHAR_TABLE_ENTRYP (val)) + return val; + val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32]; + if (CHAR_TABLE_ENTRYP (val)) + return multi; + return val; + } +#endif /* not UTF2000 */ +#endif /* not MULE */ + + default: + abort (); + } + + return Qnil; /* not reached */ +} + +static int +check_valid_char_table_value (Lisp_Object value, enum char_table_type type, + Error_behavior errb) +{ + switch (type) + { + case CHAR_TABLE_TYPE_SYNTAX: + if (!ERRB_EQ (errb, ERROR_ME)) + return INTP (value) || (CONSP (value) && INTP (XCAR (value)) + && CHAR_OR_CHAR_INTP (XCDR (value))); + if (CONSP (value)) + { + Lisp_Object cdr = XCDR (value); + CHECK_INT (XCAR (value)); + CHECK_CHAR_COERCE_INT (cdr); + } + else + CHECK_INT (value); + break; + +#ifdef MULE + case CHAR_TABLE_TYPE_CATEGORY: + if (!ERRB_EQ (errb, ERROR_ME)) + return CATEGORY_TABLE_VALUEP (value); + CHECK_CATEGORY_TABLE_VALUE (value); + break; +#endif /* MULE */ + + case CHAR_TABLE_TYPE_GENERIC: + return 1; + + case CHAR_TABLE_TYPE_DISPLAY: + /* #### fix this */ + maybe_signal_simple_error ("Display char tables not yet implemented", + value, Qchar_table, errb); + return 0; + + case CHAR_TABLE_TYPE_CHAR: + if (!ERRB_EQ (errb, ERROR_ME)) + return CHAR_OR_CHAR_INTP (value); + CHECK_CHAR_COERCE_INT (value); + break; + + default: + abort (); + } + + return 0; /* not reached */ +} + +static Lisp_Object +canonicalize_char_table_value (Lisp_Object value, enum char_table_type type) +{ + switch (type) + { + case CHAR_TABLE_TYPE_SYNTAX: + if (CONSP (value)) + { + Lisp_Object car = XCAR (value); + Lisp_Object cdr = XCDR (value); + CHECK_CHAR_COERCE_INT (cdr); + return Fcons (car, cdr); + } + break; + case CHAR_TABLE_TYPE_CHAR: + CHECK_CHAR_COERCE_INT (value); + break; + default: + break; + } + return value; +} + +DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /* +Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE. +*/ + (value, char_table_type)) +{ + enum char_table_type type = symbol_to_char_table_type (char_table_type); + + return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil; +} + +DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /* +Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE. +*/ + (value, char_table_type)) +{ + enum char_table_type type = symbol_to_char_table_type (char_table_type); + + check_valid_char_table_value (value, type, ERROR_ME); + return Qnil; +} + +/* Assign VAL to all characters in RANGE in char table CT. */ + +void +put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, + Lisp_Object val) +{ + 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; + for (i = 0; i < 128; i++) + ct->ascii[i] = val; + } + else if (EQ (range->charset, Vcharset_control_1)) + { + int i; + for (i = 128; i < 160; i++) + ct->ascii[i] = val; + } + else + { + 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; + /* make sure that there is a separate entry for the row. */ + if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) + ct->level1[lb] = make_char_table_entry (ct->level1[lb]); + cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); + cte->level2[range->row - 32] = val; + } +#endif /* not UTF2000 */ + break; +#endif /* MULE */ + + case CHARTAB_RANGE_CHAR: +#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; + + BREAKUP_CHAR (range->ch, charset, byte1, byte2); + if (EQ (charset, Vcharset_ascii)) + ct->ascii[byte1] = val; + else if (EQ (charset, Vcharset_control_1)) + ct->ascii[byte1 + 128] = val; + else + { + Lisp_Char_Table_Entry *cte; + int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; + /* make sure that there is a separate entry for the row. */ + if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) + ct->level1[lb] = make_char_table_entry (ct->level1[lb]); + cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); + /* now CTE is a char table entry for the charset; + each entry is for a single row (or character of + a one-octet charset). */ + if (XCHARSET_DIMENSION (charset) == 1) + cte->level2[byte1 - 32] = val; + else + { + /* assigning to one character in a two-octet charset. */ + /* make sure that the charset row contains a separate + entry for each character. */ + if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32])) + cte->level2[byte1 - 32] = + make_char_table_entry (cte->level2[byte1 - 32]); + cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]); + cte->level2[byte2 - 32] = val; + } + } + } +#else /* not MULE */ + ct->ascii[(unsigned char) (range->ch)] = val; + break; +#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, /* +Set the value for chars in RANGE to be VALUE in CHAR-TABLE. + +RANGE specifies one or more characters to be affected and should be +one of the following: -DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /* -Return a new, empty char table of type TYPE. -Currently recognized types are 'char, 'category, 'display, 'generic, -and 'syntax. See `valid-char-table-type-p'. +-- t (all characters are affected) +-- A charset (only allowed when Mule support is present) +-- A vector of two elements: a two-octet charset and a row number + (only allowed when Mule support is present) +-- A single character + +VALUE must be a value appropriate for the type of CHAR-TABLE. +See `valid-char-table-type-p'. */ - (type)) + (range, value, char_table)) { Lisp_Char_Table *ct; - Lisp_Object obj; - enum char_table_type ty = symbol_to_char_table_type (type); + struct chartab_range rainj; - ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); - ct->type = ty; - if (ty == CHAR_TABLE_TYPE_SYNTAX) - { - ct->mirror_table = Fmake_char_table (Qgeneric); - fill_char_table (XCHAR_TABLE (ct->mirror_table), - make_int (Spunct)); - } - else - ct->mirror_table = Qnil; - ct->next_table = Qnil; - XSETCHAR_TABLE (obj, ct); - if (ty == CHAR_TABLE_TYPE_SYNTAX) - { - ct->next_table = Vall_syntax_tables; - Vall_syntax_tables = obj; - } - Freset_char_table (obj); - return obj; + CHECK_CHAR_TABLE (char_table); + ct = XCHAR_TABLE (char_table); + check_valid_char_table_value (value, ct->type, ERROR_ME); + decode_char_table_range (range, &rainj); + value = canonicalize_char_table_value (value, ct->type); + put_char_table (ct, &rainj, value); + return Qnil; } -#ifdef MULE +#ifndef UTF2000 +/* Map FN over the ASCII chars in CT. */ -static Lisp_Object -make_char_table_entry (Lisp_Object initval) +static int +map_over_charset_ascii (Lisp_Char_Table *ct, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) { - Lisp_Object obj; - int i; - Lisp_Char_Table_Entry *cte = - alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); - - for (i = 0; i < 96; i++) - cte->level2[i] = initval; - - XSETCHAR_TABLE_ENTRY (obj, cte); - return obj; -} + struct chartab_range rainj; + int i, retval; + int start = 0; +#ifdef MULE + int stop = 128; +#else + int stop = 256; +#endif -static Lisp_Object -copy_char_table_entry (Lisp_Object entry) -{ - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry); - Lisp_Object obj; - int i; - Lisp_Char_Table_Entry *ctenew = - alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); + rainj.type = CHARTAB_RANGE_CHAR; - for (i = 0; i < 96; i++) + for (i = start, retval = 0; i < stop && retval == 0; i++) { - Lisp_Object new = cte->level2[i]; - if (CHAR_TABLE_ENTRYP (new)) - ctenew->level2[i] = copy_char_table_entry (new); - else - ctenew->level2[i] = new; + rainj.ch = (Emchar) i; + retval = (fn) (&rainj, ct->ascii[i], arg); } - XSETCHAR_TABLE_ENTRY (obj, ctenew); - return obj; + return retval; } -#endif /* MULE */ +#ifdef MULE -DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /* -Return a new char table which is a copy of CHAR-TABLE. -It will contain the same values for the same characters and ranges -as CHAR-TABLE. The values will not themselves be copied. -*/ - (char_table)) +/* Map FN over the Control-1 chars in CT. */ + +static int +map_over_charset_control_1 (Lisp_Char_Table *ct, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) { - Lisp_Char_Table *ct, *ctnew; - Lisp_Object obj; - int i; + struct chartab_range rainj; + int i, retval; + int start = 128; + int stop = start + 32; - CHECK_CHAR_TABLE (char_table); - ct = XCHAR_TABLE (char_table); - ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); - ctnew->type = ct->type; + rainj.type = CHARTAB_RANGE_CHAR; - for (i = 0; i < NUM_ASCII_CHARS; i++) + for (i = start, retval = 0; i < stop && retval == 0; i++) { - Lisp_Object new = ct->ascii[i]; -#ifdef MULE - assert (! (CHAR_TABLE_ENTRYP (new))); -#endif /* MULE */ - ctnew->ascii[i] = new; + rainj.ch = (Emchar) (i); + retval = (fn) (&rainj, ct->ascii[i], arg); } -#ifdef MULE + return retval; +} - for (i = 0; i < NUM_LEADING_BYTES; i++) - { - Lisp_Object new = ct->level1[i]; - if (CHAR_TABLE_ENTRYP (new)) - ctnew->level1[i] = copy_char_table_entry (new); - else - ctnew->level1[i] = new; - } +/* Map FN over the row ROW of two-byte charset CHARSET. + There must be a separate value for that row in the char table. + CTE specifies the char table entry for CHARSET. */ -#endif /* MULE */ +static int +map_over_charset_row (Lisp_Char_Table_Entry *cte, + Lisp_Object charset, int row, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) +{ + Lisp_Object val = cte->level2[row - 32]; - if (CHAR_TABLEP (ct->mirror_table)) - ctnew->mirror_table = Fcopy_char_table (ct->mirror_table); - else - ctnew->mirror_table = ct->mirror_table; - ctnew->next_table = Qnil; - XSETCHAR_TABLE (obj, ctnew); - if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX) + if (!CHAR_TABLE_ENTRYP (val)) { - ctnew->next_table = Vall_syntax_tables; - Vall_syntax_tables = obj; - } - return obj; -} + struct chartab_range rainj; -static void -decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) -{ - if (EQ (range, Qt)) - outrange->type = CHARTAB_RANGE_ALL; - else if (CHAR_OR_CHAR_INTP (range)) - { - outrange->type = CHARTAB_RANGE_CHAR; - outrange->ch = XCHAR_OR_CHAR_INT (range); + rainj.type = CHARTAB_RANGE_ROW; + rainj.charset = charset; + rainj.row = row; + return (fn) (&rainj, val, arg); } -#ifndef MULE else - signal_simple_error ("Range must be t or a character", range); -#else /* MULE */ - else if (VECTORP (range)) { - 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); - 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) + struct chartab_range rainj; + int i, retval; + int charset94_p = (XCHARSET_CHARS (charset) == 94); + int start = charset94_p ? 33 : 32; + int stop = charset94_p ? 127 : 128; + + cte = XCHAR_TABLE_ENTRY (val); + + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = start, retval = 0; i < stop && retval == 0; i++) { - 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 (); - } + rainj.ch = MAKE_CHAR (charset, row, i); + retval = (fn) (&rainj, cte->level2[i - 32], arg); } - else - signal_simple_error ("Charset in row vector must be multi-byte", - outrange->charset); - } - else - { - if (!CHARSETP (range) && !SYMBOLP (range)) - signal_simple_error - ("Char table range must be t, charset, char, or vector", range); - outrange->type = CHARTAB_RANGE_CHARSET; - outrange->charset = Fget_charset (range); + return retval; } -#endif /* MULE */ } -#ifdef MULE -/* called from CHAR_TABLE_VALUE(). */ -Lisp_Object -get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte, - Emchar c) +static int +map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) { - Lisp_Object val; -#ifdef UTF2000 - Lisp_Object charset; -#else - Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte); -#endif - int byte1, byte2; - -#ifdef UTF2000 - BREAKUP_CHAR (c, charset, byte1, byte2); -#else - BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2); -#endif - val = ct->level1[leading_byte - MIN_LEADING_BYTE]; - if (CHAR_TABLE_ENTRYP (val)) - { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); - val = cte->level2[byte1 - 32]; - if (CHAR_TABLE_ENTRYP (val)) - { - cte = XCHAR_TABLE_ENTRY (val); - assert (byte2 >= 32); - val = cte->level2[byte2 - 32]; - assert (!CHAR_TABLE_ENTRYP (val)); - } - } + Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE]; + Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb); - return val; -} + if (!CHARSETP (charset) + || lb == LEADING_BYTE_ASCII + || lb == LEADING_BYTE_CONTROL_1) + return 0; -#endif /* MULE */ + if (!CHAR_TABLE_ENTRYP (val)) + { + struct chartab_range rainj; -Lisp_Object -get_char_table (Emchar ch, Lisp_Char_Table *ct) -{ -#ifdef MULE - { - Lisp_Object charset; - int byte1, byte2; - Lisp_Object val; + rainj.type = CHARTAB_RANGE_CHARSET; + rainj.charset = charset; + return (fn) (&rainj, val, arg); + } - BREAKUP_CHAR (ch, charset, byte1, byte2); + { + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); + int charset94_p = (XCHARSET_CHARS (charset) == 94); + int start = charset94_p ? 33 : 32; + int stop = charset94_p ? 127 : 128; + int i, retval; - if (EQ (charset, Vcharset_ascii)) - val = ct->ascii[byte1]; - else if (EQ (charset, Vcharset_control_1)) - val = ct->ascii[byte1 + 128]; - else + if (XCHARSET_DIMENSION (charset) == 1) { - int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; - val = ct->level1[lb]; - if (CHAR_TABLE_ENTRYP (val)) + struct chartab_range rainj; + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = start, retval = 0; i < stop && retval == 0; i++) { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); - val = cte->level2[byte1 - 32]; - if (CHAR_TABLE_ENTRYP (val)) - { - cte = XCHAR_TABLE_ENTRY (val); - assert (byte2 >= 32); - val = cte->level2[byte2 - 32]; - assert (!CHAR_TABLE_ENTRYP (val)); - } + rainj.ch = MAKE_CHAR (charset, i, 0); + retval = (fn) (&rainj, cte->level2[i - 32], arg); } } + else + { + for (i = start, retval = 0; i < stop && retval == 0; i++) + retval = map_over_charset_row (cte, charset, i, fn, arg); + } - return val; + return retval; } -#else /* not MULE */ - return ct->ascii[(unsigned char)ch]; -#endif /* not MULE */ } +#endif /* MULE */ +#endif /* not UTF2000 */ -DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /* -Find value for CHARACTER in CHAR-TABLE. -*/ - (character, char_table)) -{ - CHECK_CHAR_TABLE (char_table); - CHECK_CHAR_COERCE_INT (character); - - return get_char_table (XCHAR (character), XCHAR_TABLE (char_table)); -} - -DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /* -Find value for a range in CHAR-TABLE. -If there is more than one value, return MULTI (defaults to nil). -*/ - (range, char_table, multi)) +#ifdef UTF2000 +struct map_char_table_for_charset_arg { + int (*fn) (struct chartab_range *range, Lisp_Object val, void *arg); Lisp_Char_Table *ct; - struct chartab_range rainj; + void *arg; +}; - if (CHAR_OR_CHAR_INTP (range)) - return Fget_char_table (range, char_table); - CHECK_CHAR_TABLE (char_table); - ct = XCHAR_TABLE (char_table); +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; - decode_char_table_range (range, &rainj); - switch (rainj.type) + switch (range->type) { case CHARTAB_RANGE_ALL: - { - int i; - Lisp_Object first = ct->ascii[0]; + break; - for (i = 1; i < NUM_ASCII_CHARS; i++) - if (!EQ (first, ct->ascii[i])) - return multi; + case CHARTAB_RANGE_DEFAULT: + break; -#ifdef MULE - for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; - i++) - { - if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i)) - || i == LEADING_BYTE_ASCII - || i == LEADING_BYTE_CONTROL_1) - continue; - if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE])) - return multi; - } -#endif /* MULE */ + case CHARTAB_RANGE_CHARSET: + break; - return first; - } + case CHARTAB_RANGE_ROW: + break; -#ifdef MULE - case CHARTAB_RANGE_CHARSET: - if (EQ (rainj.charset, Vcharset_ascii)) + 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 + becomes the return value of map_char_table(). */ + +int +map_char_table (Lisp_Char_Table *ct, + struct chartab_range *range, + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), + void *arg) +{ + switch (range->type) + { + case CHARTAB_RANGE_ALL: +#ifdef UTF2000 + if (!UNBOUNDP (ct->default_value)) { - int i; - Lisp_Object first = ct->ascii[0]; + struct chartab_range rainj; + int retval; - for (i = 1; i < 128; i++) - if (!EQ (first, ct->ascii[i])) - return multi; - return first; + 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; - if (EQ (rainj.charset, Vcharset_control_1)) + 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; + + retval = map_over_charset_ascii (ct, fn, arg); + if (retval) + return retval; +#ifdef MULE + retval = map_over_charset_control_1 (ct, fn, arg); + if (retval) + return retval; { - int i; - Lisp_Object first = ct->ascii[128]; + Charset_ID i; + Charset_ID start = MIN_LEADING_BYTE; + Charset_ID stop = start + NUM_LEADING_BYTES; - for (i = 129; i < 160; i++) - if (!EQ (first, ct->ascii[i])) - return multi; - return first; + for (i = start, retval = 0; i < stop && retval == 0; i++) + { + retval = map_over_other_charset (ct, i, fn, arg); + } } +#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 val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - - MIN_LEADING_BYTE]; - if (CHAR_TABLE_ENTRYP (val)) - return multi; - return val; + 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 { - Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - - MIN_LEADING_BYTE]; - if (!CHAR_TABLE_ENTRYP (val)) - return val; - val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32]; - if (CHAR_TABLE_ENTRYP (val)) - return multi; - return val; - } -#endif /* not MULE */ - - default: - abort (); - } - - return Qnil; /* not reached */ -} + int cell_min, cell_max, i; + int retval; + struct chartab_range rainj; -static int -check_valid_char_table_value (Lisp_Object value, enum char_table_type type, - Error_behavior errb) -{ - switch (type) - { - case CHAR_TABLE_TYPE_SYNTAX: - if (!ERRB_EQ (errb, ERROR_ME)) - return INTP (value) || (CONSP (value) && INTP (XCAR (value)) - && CHAR_OR_CHAR_INTP (XCDR (value))); - if (CONSP (value)) - { - Lisp_Object cdr = XCDR (value); - CHECK_INT (XCAR (value)); - CHECK_CHAR_COERCE_INT (cdr); - } - else - CHECK_INT (value); - break; + 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); -#ifdef MULE - case CHAR_TABLE_TYPE_CATEGORY: - if (!ERRB_EQ (errb, ERROR_ME)) - return CATEGORY_TABLE_VALUEP (value); - CHECK_CATEGORY_TABLE_VALUE (value); - break; + 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]; + if (!CHAR_TABLE_ENTRYP (val)) + { + struct chartab_range rainj; + + rainj.type = CHARTAB_RANGE_ROW; + rainj.charset = range->charset; + rainj.row = range->row; + return (fn) (&rainj, val, arg); + } + else + return map_over_charset_row (XCHAR_TABLE_ENTRY (val), + range->charset, range->row, + fn, arg); + } +#endif /* not UTF2000 */ #endif /* MULE */ - case CHAR_TABLE_TYPE_GENERIC: - return 1; + case CHARTAB_RANGE_CHAR: + { + Emchar ch = range->ch; + Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch); - case CHAR_TABLE_TYPE_DISPLAY: - /* #### fix this */ - maybe_signal_simple_error ("Display char tables not yet implemented", - value, Qchar_table, errb); - return 0; + if (!UNBOUNDP (val)) + { + struct chartab_range rainj; - case CHAR_TABLE_TYPE_CHAR: - if (!ERRB_EQ (errb, ERROR_ME)) - return CHAR_OR_CHAR_INTP (value); - CHECK_CHAR_COERCE_INT (value); - break; + rainj.type = CHARTAB_RANGE_CHAR; + rainj.ch = ch; + return (fn) (&rainj, val, arg); + } + return 0; + } default: abort (); } - return 0; /* not reached */ -} - -static Lisp_Object -canonicalize_char_table_value (Lisp_Object value, enum char_table_type type) -{ - switch (type) - { - case CHAR_TABLE_TYPE_SYNTAX: - if (CONSP (value)) - { - Lisp_Object car = XCAR (value); - Lisp_Object cdr = XCDR (value); - CHECK_CHAR_COERCE_INT (cdr); - return Fcons (car, cdr); - } - break; - case CHAR_TABLE_TYPE_CHAR: - CHECK_CHAR_COERCE_INT (value); - break; - default: - break; - } - return value; + return 0; } -DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /* -Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE. -*/ - (value, char_table_type)) +struct slow_map_char_table_arg { - enum char_table_type type = symbol_to_char_table_type (char_table_type); - - return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil; -} + Lisp_Object function; + Lisp_Object retval; +}; -DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /* -Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE. -*/ - (value, char_table_type)) +static int +slow_map_char_table_fun (struct chartab_range *range, + Lisp_Object val, void *arg) { - enum char_table_type type = symbol_to_char_table_type (char_table_type); - - check_valid_char_table_value (value, type, ERROR_ME); - return Qnil; -} - -/* Assign VAL to all characters in RANGE in char table CT. */ + Lisp_Object ranjarg = Qnil; + struct slow_map_char_table_arg *closure = + (struct slow_map_char_table_arg *) arg; -void -put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, - Lisp_Object val) -{ switch (range->type) { case CHARTAB_RANGE_ALL: - fill_char_table (ct, val); - return; /* avoid the duplicate call to update_syntax_table() below, - since fill_char_table() also did that. */ + ranjarg = Qt; + break; + +#ifdef UTF2000 + case CHARTAB_RANGE_DEFAULT: + ranjarg = Qnil; + break; +#endif #ifdef MULE case CHARTAB_RANGE_CHARSET: - if (EQ (range->charset, Vcharset_ascii)) - { - int i; - for (i = 0; i < 128; i++) - ct->ascii[i] = val; - } - else if (EQ (range->charset, Vcharset_control_1)) - { - int i; - for (i = 128; i < 160; i++) - ct->ascii[i] = val; - } - else - { - int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; - ct->level1[lb] = val; - } + ranjarg = XCHARSET_NAME (range->charset); break; case CHARTAB_RANGE_ROW: - { - Lisp_Char_Table_Entry *cte; - int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; - /* make sure that there is a separate entry for the row. */ - if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) - ct->level1[lb] = make_char_table_entry (ct->level1[lb]); - cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); - cte->level2[range->row - 32] = val; - } + ranjarg = vector2 (XCHARSET_NAME (range->charset), + make_int (range->row)); break; #endif /* MULE */ - case CHARTAB_RANGE_CHAR: -#ifdef MULE - { - Lisp_Object charset; - int byte1, byte2; - - BREAKUP_CHAR (range->ch, charset, byte1, byte2); - if (EQ (charset, Vcharset_ascii)) - ct->ascii[byte1] = val; - else if (EQ (charset, Vcharset_control_1)) - ct->ascii[byte1 + 128] = val; - else - { - Lisp_Char_Table_Entry *cte; - int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; - /* make sure that there is a separate entry for the row. */ - if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) - ct->level1[lb] = make_char_table_entry (ct->level1[lb]); - cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); - /* now CTE is a char table entry for the charset; - each entry is for a single row (or character of - a one-octet charset). */ - if (XCHARSET_DIMENSION (charset) == 1) - cte->level2[byte1 - 32] = val; - else - { - /* assigning to one character in a two-octet charset. */ - /* make sure that the charset row contains a separate - entry for each character. */ - if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32])) - cte->level2[byte1 - 32] = - make_char_table_entry (cte->level2[byte1 - 32]); - cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]); - cte->level2[byte2 - 32] = val; - } - } - } -#else /* not MULE */ - ct->ascii[(unsigned char) (range->ch)] = val; + ranjarg = make_char (range->ch); break; -#endif /* not MULE */ + default: + abort (); } - if (ct->type == CHAR_TABLE_TYPE_SYNTAX) - update_syntax_table (ct); + closure->retval = call2 (closure->function, ranjarg, val); + return !NILP (closure->retval); } -DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /* -Set the value for chars in RANGE to be VALUE in CHAR-TABLE. - -RANGE specifies one or more characters to be affected and should be -one of the following: - --- t (all characters are affected) --- A charset (only allowed when Mule support is present) --- A vector of two elements: a two-octet charset and a row number - (only allowed when Mule support is present) --- A single character +DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /* +Map FUNCTION over entries in CHAR-TABLE, calling it with two args, +each key and value in the table. -VALUE must be a value appropriate for the type of CHAR-TABLE. -See `valid-char-table-type-p'. +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. */ - (range, value, char_table)) + (function, char_table, range)) { Lisp_Char_Table *ct; + struct slow_map_char_table_arg slarg; + struct gcpro gcpro1, gcpro2; struct chartab_range rainj; CHECK_CHAR_TABLE (char_table); ct = XCHAR_TABLE (char_table); - check_valid_char_table_value (value, ct->type, ERROR_ME); + if (NILP (range)) + range = Qt; decode_char_table_range (range, &rainj); - value = canonicalize_char_table_value (value, ct->type); - put_char_table (ct, &rainj, value); - return Qnil; -} - -/* Map FN over the ASCII chars in CT. */ - -static int -map_over_charset_ascii (Lisp_Char_Table *ct, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) -{ - struct chartab_range rainj; - int i, retval; - int start = 0; -#ifdef MULE - int stop = 128; -#else - int stop = 256; -#endif - - rainj.type = CHARTAB_RANGE_CHAR; - - for (i = start, retval = 0; i < stop && retval == 0; i++) - { - rainj.ch = (Emchar) i; - retval = (fn) (&rainj, ct->ascii[i], arg); - } + slarg.function = function; + slarg.retval = Qnil; + GCPRO2 (slarg.function, slarg.retval); + map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg); + UNGCPRO; - return retval; + return slarg.retval; } -#ifdef MULE + +/************************************************************************/ +/* Character Attributes */ +/************************************************************************/ -/* Map FN over the Control-1 chars in CT. */ +#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 -map_over_charset_control_1 (Lisp_Char_Table *ct, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) +add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value, + void *char_attribute_list_closure) { - struct chartab_range rainj; - int i, retval; - int start = 128; - int stop = start + 32; + /* 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; - rainj.type = CHARTAB_RANGE_CHAR; + *char_attribute_list = Fcons (key, *char_attribute_list); + return 0; +} - for (i = start, retval = 0; i < stop && retval == 0; i++) - { - rainj.ch = (Emchar) (i); - retval = (fn) (&rainj, ct->ascii[i], arg); - } +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; +} - return retval; +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); } -/* Map FN over the row ROW of two-byte charset CHARSET. - There must be a separate value for that row in the char table. - CTE specifies the char table entry for CHARSET. */ -static int -map_over_charset_row (Lisp_Char_Table_Entry *cte, - Lisp_Object charset, int row, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) +/* 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 { - Lisp_Object val = cte->level2[row - 32]; + Emchar char_id; + Lisp_Object *char_attribute_alist; +}; - if (!CHAR_TABLE_ENTRYP (val)) +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)) { - struct chartab_range rainj; - - rainj.type = CHARTAB_RANGE_ROW; - rainj.charset = charset; - rainj.row = row; - return (fn) (&rainj, val, arg); + Lisp_Object *char_attribute_alist = caacl->char_attribute_alist; + *char_attribute_alist + = Fcons (Fcons (key, ret), *char_attribute_alist); } - else - { - struct chartab_range rainj; - int i, retval; - int charset94_p = (XCHARSET_CHARS (charset) == 94); - int start = charset94_p ? 33 : 32; - int stop = charset94_p ? 127 : 128; + return 0; +} - cte = XCHAR_TABLE_ENTRY (val); +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; - rainj.type = CHARTAB_RANGE_CHAR; + CHECK_CHAR (character); - for (i = start, retval = 0; i < stop && retval == 0; i++) - { - rainj.ch = MAKE_CHAR (charset, row, i); - retval = (fn) (&rainj, cte->level2[i - 32], arg); - } - return retval; - } -} + 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; +} -static int -map_over_other_charset (Lisp_Char_Table *ct, Charset_ID lb, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) +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 val = ct->level1[lb - MIN_LEADING_BYTE]; - Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb); + Lisp_Object table; - if (!CHARSETP (charset) - || lb == LEADING_BYTE_ASCII - || lb == LEADING_BYTE_CONTROL_1) - return 0; + CHECK_CHAR (character); - if (!CHAR_TABLE_ENTRYP (val)) - { - struct chartab_range rainj; + if (CHARSETP (attribute)) + attribute = XCHARSET_NAME (attribute); - rainj.type = CHARTAB_RANGE_CHARSET; - rainj.charset = charset; - return (fn) (&rainj, val, arg); + 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; +} - { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); - int charset94_p = (XCHARSET_CHARS (charset) == 94); - int start = charset94_p ? 33 : 32; - int stop = charset94_p ? 127 : 128; - int i, retval; - - if (XCHARSET_DIMENSION (charset) == 1) - { - struct chartab_range rainj; - rainj.type = CHARTAB_RANGE_CHAR; +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); - for (i = start, retval = 0; i < stop && retval == 0; i++) - { - rainj.ch = MAKE_CHAR (charset, i, 0); - retval = (fn) (&rainj, cte->level2[i - 32], arg); - } - } - else - { - for (i = start, retval = 0; i < stop && retval == 0; i++) - retval = map_over_charset_row (cte, charset, i, fn, arg); - } + if (!NILP (ccs)) + { + CHECK_CHAR (character); + value = put_char_ccs_code_point (character, ccs, value); + } + else if (EQ (attribute, Q_decomposition)) + { + Lisp_Object seq; - return retval; - } -} + CHECK_CHAR (character); + if (!CONSP (value)) + signal_simple_error ("Invalid value for ->decomposition", + value); -#endif /* MULE */ + if (CONSP (Fcdr (value))) + { + Lisp_Object rest = value; + Lisp_Object table = Vcharacter_composition_table; + size_t len; + int i = 0; -/* 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 - becomes the return value of map_char_table(). */ + GET_EXTERNAL_LIST_LENGTH (rest, len); + seq = make_vector (len, Qnil); -int -map_char_table (Lisp_Char_Table *ct, - struct chartab_range *range, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) -{ - switch (range->type) - { - case CHARTAB_RANGE_ALL: - { - int retval; + while (CONSP (rest)) + { + Lisp_Object v = Fcar (rest); + Lisp_Object ntable; + Emchar c + = to_char_id (v, "Invalid value for ->decomposition", value); - retval = map_over_charset_ascii (ct, fn, arg); - if (retval) - return retval; -#ifdef MULE - retval = map_over_charset_control_1 (ct, fn, arg); - if (retval) - return retval; + 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 { - Charset_ID i; - Charset_ID start = MIN_LEADING_BYTE; - Charset_ID stop = start + NUM_LEADING_BYTES; + Lisp_Object v = Fcar (value); - for (i = start, retval = 0; i < stop && retval == 0; i++) + if (INTP (v)) { - retval = map_over_other_charset (ct, i, fn, arg); + 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); } -#endif /* MULE */ - return retval; - } + value = seq; + } + else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs)) + { + Lisp_Object ret; + Emchar c; -#ifdef MULE - case CHARTAB_RANGE_CHARSET: - return map_over_other_charset (ct, - XCHARSET_LEADING_BYTE (range->charset), - fn, arg); + CHECK_CHAR (character); + if (!INTP (value)) + signal_simple_error ("Invalid value for ->ucs", value); - case CHARTAB_RANGE_ROW: - { - Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - - MIN_LEADING_BYTE]; - if (!CHAR_TABLE_ENTRYP (val)) - { - struct chartab_range rainj; + c = XINT (value); - rainj.type = CHARTAB_RANGE_ROW; - rainj.charset = range->charset; - rainj.row = range->row; - return (fn) (&rainj, val, arg); - } - else - return map_over_charset_row (XCHAR_TABLE_ENTRY (val), - range->charset, range->row, - fn, arg); - } -#endif /* MULE */ + 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); - case CHARTAB_RANGE_CHAR: + if (NILP (table)) { - 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); + table = make_char_id_table (Qunbound); + Fputhash (attribute, table, Vchar_attribute_hash_table); } - - default: - abort (); - } - - return 0; + put_char_id_table (XCHAR_TABLE(table), character, value); + return value; + } } - -struct slow_map_char_table_arg -{ - Lisp_Object function; - Lisp_Object retval; -}; - -static int -slow_map_char_table_fun (struct chartab_range *range, - Lisp_Object val, void *arg) + +DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /* +Remove CHARACTER's ATTRIBUTE. +*/ + (character, attribute)) { - Lisp_Object ranjarg = Qnil; - struct slow_map_char_table_arg *closure = - (struct slow_map_char_table_arg *) arg; + Lisp_Object ccs; - switch (range->type) + CHECK_CHAR (character); + ccs = Ffind_charset (attribute); + if (!NILP (ccs)) { - case CHARTAB_RANGE_ALL: - ranjarg = Qt; - break; - -#ifdef MULE - case CHARTAB_RANGE_CHARSET: - ranjarg = XCHARSET_NAME (range->charset); - break; - - case CHARTAB_RANGE_ROW: - ranjarg = vector2 (XCHARSET_NAME (range->charset), - make_int (range->row)); - break; -#endif /* MULE */ - case CHARTAB_RANGE_CHAR: - ranjarg = make_char (range->ch); - break; - default: - abort (); + return remove_char_ccs (character, ccs); } - - closure->retval = call2 (closure->function, ranjarg, val); - return !NILP (closure->retval); + 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-table", Fmap_char_table, 2, 3, 0, /* -Map FUNCTION over entries in CHAR-TABLE, calling it with two args, +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, char_table, range)) + (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; - CHECK_CHAR_TABLE (char_table); - ct = XCHAR_TABLE (char_table); + 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); @@ -2881,6 +3080,108 @@ the entire table. 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 (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) != 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 /************************************************************************/ @@ -3027,7 +3328,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; @@ -3038,10 +3339,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, /* @@ -3221,7 +3522,6 @@ syms_of_chartab (void) INIT_LRECORD_IMPLEMENTATION (uint8_byte_table); INIT_LRECORD_IMPLEMENTATION (uint16_byte_table); INIT_LRECORD_IMPLEMENTATION (byte_table); - INIT_LRECORD_IMPLEMENTATION (char_id_table); defsymbol (&Qto_ucs, "=>ucs"); defsymbol (&Q_ucs, "->ucs"); @@ -3260,7 +3560,9 @@ syms_of_chartab (void) 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"); @@ -3302,7 +3604,7 @@ void vars_of_chartab (void) { #ifdef UTF2000 - Vutf_2000_version = build_string("0.17 (Hōryūji)"); + Vutf_2000_version = build_string("0.18 (Yamato-Koizumi)"); DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /* Version number of XEmacs UTF-2000. */ );