From: tomo Date: Fri, 17 Aug 2001 11:44:07 +0000 (+0000) Subject: (map_over_uint8_byte_table): Change interface of mapping function to X-Git-Tag: r21-2-41-utf-2000-0_17-2~121 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=b68a73c1d2d20e85519109fc5001cf7a71d32e7e;p=chise%2Fxemacs-chise.git- (map_over_uint8_byte_table): Change interface of mapping function to use struct chartab_range instead of Emchar. (map_over_uint16_byte_table): Likewise. (map_over_byte_table): Likewise. (map_char_id_table): Likewise. (struct slow_map_char_id_table_arg): Deleted. (slow_map_char_id_table_fun): Deleted. (Fmap_char_attribute): Use struct `slow_map_char_table_arg' and function `slow_map_char_table_fun' instead of struct `slow_map_char_id_table_arg' and function `slow_map_char_id_table_fun'. --- diff --git a/src/chartab.c b/src/chartab.c index 6cfecf1..844f570 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -231,21 +231,28 @@ 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), + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), void *arg, Emchar ofs, int place) { + 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; @@ -448,21 +455,28 @@ 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), + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), void *arg, Emchar ofs, int place) { + 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; @@ -587,7 +601,8 @@ 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), + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), void *arg, Emchar ofs, int place) { int i, retval; @@ -620,10 +635,16 @@ map_over_byte_table (Lisp_Byte_Table *ct, } 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; @@ -864,11 +885,13 @@ put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table) 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), + int (*fn) (struct chartab_range *range, + 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), + int (*fn) (struct chartab_range *range, + Lisp_Object val, void *arg), void *arg) { Lisp_Object v = ct->table; @@ -881,35 +904,24 @@ map_char_id_table (Lisp_Char_ID_Table *ct, return map_over_byte_table (XBYTE_TABLE(v), fn, arg, 0, 3); else if (!UNBOUNDP (v)) { + struct chartab_range rainj; int unit = 1 << 24; Emchar c = 0; Emchar c1 = c + unit; int retval; + rainj.type = CHARTAB_RANGE_CHAR; + for (retval = 0; c < c1 && retval == 0; c++) - retval = (fn) (c, v, arg); + { + rainj.ch = c; + retval = (fn) (&rainj, 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; @@ -1023,1864 +1035,1873 @@ Return variants of CHARACTER. Vcharacter_variant_table)); } +#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 provide an + abstract type to generalize the Emacs vectors and Mule + vectors-of-vectors goo. + */ -/* 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; -}; +/************************************************************************/ +/* Char Table object */ +/************************************************************************/ -static int -add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value, - void *char_attribute_alist_closure) +#ifdef MULE + +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 < 96; i++) + if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1)) + return 0; - for (i = 0; i < countof (chlook->charset_by_leading_byte); i++) - { - Lisp_Object ccs = chlook->charset_by_leading_byte[i]; + return 1; +} - if (!NILP (ccs)) - { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); - Lisp_Object cpos; +static unsigned long +char_table_entry_hash (Lisp_Object obj, int depth) +{ + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); - 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 internal_array_hash (cte->level2, 96, depth); } -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 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_Object ccs; + Lisp_Char_Table *ct = XCHAR_TABLE (obj); + int i; - CHECK_CHAR (character); - if (!NILP (ccs = Ffind_charset (attribute))) - { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + 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; +} - if (CHAR_ID_TABLE_P (encoding_table)) - return get_char_id_table (XCHAR (character), encoding_table); - } - else +/* 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) { - Lisp_Object table = Fgethash (attribute, - Vchar_attribute_hash_table, - Qunbound); - if (!UNBOUNDP (table)) + if (! marked_p (rest)) { - Lisp_Object ret = get_char_id_table (XCHAR (character), table); - if (!UNBOUNDP (ret)) - return ret; + /* 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; } } - return default_value; } -DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /* -Store CHARACTER's ATTRIBUTE with VALUE. -*/ - (character, attribute, value)) -{ - Lisp_Object ccs; +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 + } +} - CHECK_CHAR (character); - ccs = Ffind_charset (attribute); - if (!NILP (ccs)) +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) { - return put_char_ccs_code_point (character, ccs, value); + 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 if (EQ (attribute, Q_decomposition)) + else { - Lisp_Object seq; - - if (!CONSP (value)) - signal_simple_error ("Invalid value for ->decomposition", - value); + write_c_string (" ", printcharfun); + print_internal (make_char (first), printcharfun, 0); + write_c_string (" ", printcharfun); + } + print_internal (val, printcharfun, 1); +} - if (CONSP (Fcdr (value))) - { - Lisp_Object rest = value; - Lisp_Object table = Vcharacter_composition_table; - size_t len; - int i = 0; +#ifdef MULE - GET_EXTERNAL_LIST_LENGTH (rest, len); - seq = make_vector (len, Qnil); +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; - while (CONSP (rest)) - { - Lisp_Object v = Fcar (rest); - Lisp_Object ntable; - Emchar c - = to_char_id (v, "Invalid value for ->decomposition", value); + for (i = 32; i < 128; i++) + { + Lisp_Object pam = cte->level2[i - 32]; - 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 + if (first == -1) { - Lisp_Object v = Fcar (value); - - if (INTP (v)) - { - Emchar c = XINT (v); - Lisp_Object ret - = get_char_id_table (c, Vcharacter_variant_table); - - if (NILP (Fmemq (v, ret))) - { - put_char_id_table (c, Fcons (character, ret), - Vcharacter_variant_table); - } - } - seq = make_vector (1, v); + first = i; + cat = pam; + continue; } - value = seq; - } - else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs)) - { - Lisp_Object ret; - Emchar c; - - if (!INTP (value)) - signal_simple_error ("Invalid value for ->ucs", value); - - c = XINT (value); - ret = get_char_id_table (c, Vcharacter_variant_table); - if (NILP (Fmemq (character, ret))) + if (!EQ (cat, pam)) { - put_char_id_table (c, Fcons (character, ret), - Vcharacter_variant_table); + 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 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; - } -} - -DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /* -Remove CHARACTER's ATTRIBUTE. -*/ - (character, attribute)) -{ - Lisp_Object ccs; - CHECK_CHAR (character); - ccs = Ffind_charset (attribute); - if (!NILP (ccs)) - { - return remove_char_ccs (character, ccs); - } - else + if (first != -1) { - Lisp_Object table = Fgethash (attribute, - Vchar_attribute_hash_table, - Qunbound); - if (!UNBOUNDP (table)) - { - put_char_id_table (XCHAR (character), Qunbound, table); - return Qt; - } + 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 Qnil; } -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)) +static void +print_chartab_two_byte_charset (Lisp_Object charset, + Lisp_Char_Table_Entry *cte, + Lisp_Object printcharfun) { - Lisp_Object ccs; - Lisp_Char_ID_Table *ct; - struct slow_map_char_id_table_arg slarg; - struct gcpro gcpro1, gcpro2; + int i; - if (!NILP (ccs = Ffind_charset (attribute))) + for (i = 32; i < 128; i++) { - Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + Lisp_Object jen = cte->level2[i - 32]; - 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); + 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 - return Qnil; + print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen), + printcharfun); } - 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); +#endif /* MULE */ -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_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 ( (!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)) +static void +print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - 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); - } - 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 - - -/* 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. + Lisp_Char_Table *ct = XCHAR_TABLE (obj); + char buf[200]; - We use char tables to generalize the 256-element vectors now - littering the Emacs code. + 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); - Possible uses (all should be converted at some point): + /* Now write out the ASCII/Control-1 stuff. */ + { + int i; + int first = -1; + Lisp_Object val = Qunbound; - 1) category tables - 2) syntax tables - 3) display tables - 4) case tables - 5) keyboard-translate-table? + for (i = 0; i < NUM_ASCII_CHARS; i++) + { + if (first == -1) + { + first = i; + val = ct->ascii[i]; + continue; + } - We provide an - abstract type to generalize the Emacs vectors and Mule - vectors-of-vectors goo. - */ + if (!EQ (ct->ascii[i], val)) + { + print_chartab_range (first, i - 1, val, printcharfun); + first = -1; + i--; + } + } -/************************************************************************/ -/* Char Table object */ -/************************************************************************/ + if (first != -1) + print_chartab_range (first, i - 1, val, printcharfun); + } #ifdef MULE + { + Charset_ID i; -static Lisp_Object -mark_char_table_entry (Lisp_Object obj) -{ - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); - int i; + for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; + i++) + { + Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE]; + Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i); - for (i = 0; i < 96; i++) - { - mark_object (cte->level2[i]); - } - return Qnil; + if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII + || i == LEADING_BYTE_CONTROL_1) + continue; + if (!CHAR_TABLE_ENTRYP (ann)) + { + write_c_string (" ", printcharfun); + print_internal (XCHARSET_NAME (charset), + printcharfun, 0); + write_c_string (" ", printcharfun); + print_internal (ann, printcharfun, 0); + } + else + { + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (ann); + if (XCHARSET_DIMENSION (charset) == 1) + print_chartab_charset_row (charset, -1, cte, printcharfun); + else + print_chartab_two_byte_charset (charset, cte, printcharfun); + } + } + } +#endif /* MULE */ + + write_c_string ("))", printcharfun); } static int -char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +char_table_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); + Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1); + Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2); int i; - for (i = 0; i < 96; i++) - if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1)) + if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2)) + return 0; + + for (i = 0; i < NUM_ASCII_CHARS; i++) + if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1)) + return 0; + +#ifdef MULE + for (i = 0; i < NUM_LEADING_BYTES; i++) + if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1)) return 0; +#endif /* MULE */ return 1; } static unsigned long -char_table_entry_hash (Lisp_Object obj, int depth) +char_table_hash (Lisp_Object obj, int depth) { - Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); - - return internal_array_hash (cte->level2, 96, depth); + Lisp_Char_Table *ct = XCHAR_TABLE (obj); + unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS, + depth); +#ifdef MULE + hashval = HASH2 (hashval, + internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth)); +#endif /* MULE */ + return hashval; } -static const struct lrecord_description char_table_entry_description[] = { - { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 }, +static const struct lrecord_description char_table_description[] = { + { 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 + { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) }, + { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) }, { 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 */ +DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table, + mark_char_table, print_char_table, 0, + char_table_equal, char_table_hash, + char_table_description, + Lisp_Char_Table); -static Lisp_Object -mark_char_table (Lisp_Object obj) +DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /* +Return non-nil if OBJECT is a char table. + +A char table is a table that maps characters (or ranges of characters) +to values. Char tables are specialized for characters, only allowing +particular sorts of ranges to be assigned values. Although this +loses in generality, it makes for extremely fast (constant-time) +lookups, and thus is feasible for applications that do an extremely +large number of lookups (e.g. scanning a buffer for a character in +a particular syntax, where a lookup in the syntax table must occur +once per character). + +When Mule support exists, the types of ranges that can be assigned +values are + +-- all characters +-- an entire charset +-- a single row in a two-octet charset +-- a single character + +When Mule support is not present, the types of ranges that can be +assigned values are + +-- all characters +-- a single character + +To create a char table, use `make-char-table'. +To modify a char table, use `put-char-table' or `remove-char-table'. +To retrieve the value for a particular character, use `get-char-table'. +See also `map-char-table', `clear-char-table', `copy-char-table', +`valid-char-table-type-p', `char-table-type-list', +`valid-char-table-value-p', and `check-char-table-value'. +*/ + (object)) { - Lisp_Char_Table *ct = XCHAR_TABLE (obj); - int i; + return CHAR_TABLEP (object) ? Qt : Qnil; +} - for (i = 0; i < NUM_ASCII_CHARS; i++) - mark_object (ct->ascii[i]); +DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /* +Return a list of the recognized char table types. +See `valid-char-table-type-p'. +*/ + ()) +{ #ifdef MULE - for (i = 0; i < NUM_LEADING_BYTES; i++) - mark_object (ct->level1[i]); + return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax); +#else + return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax); #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(). */ +DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /* +Return t if TYPE if a recognized char table type. -void -prune_syntax_tables (void) +Each char table type is used for a different purpose and allows different +sorts of values. The different char table types are + +`category' + Used for category tables, which specify the regexp categories + that a character is in. The valid values are nil or a + bit vector of 95 elements. Higher-level Lisp functions are + provided for working with category tables. Currently categories + and category tables only exist when Mule support is present. +`char' + A generalized char table, for mapping from one character to + another. Used for case tables, syntax matching tables, + `keyboard-translate-table', etc. The valid values are characters. +`generic' + An even more generalized char table, for mapping from a + character to anything. +`display' + Used for display tables, which specify how a particular character + is to appear when displayed. #### Not yet implemented. +`syntax' + Used for syntax tables, which specify the syntax of a particular + character. Higher-level Lisp functions are provided for + working with syntax tables. The valid values are integers. + +*/ + (type)) { - Lisp_Object rest, prev = Qnil; + return (EQ (type, Qchar) || +#ifdef MULE + EQ (type, Qcategory) || +#endif + EQ (type, Qdisplay) || + EQ (type, Qgeneric) || + EQ (type, Qsyntax)) ? Qt : 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; - } - } +DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /* +Return the type of CHAR-TABLE. +See `valid-char-table-type-p'. +*/ + (char_table)) +{ + CHECK_CHAR_TABLE (char_table); + return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type); } -static Lisp_Object -char_table_type_to_symbol (enum char_table_type type) +void +fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) { - 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; + int i; + + for (i = 0; i < NUM_ASCII_CHARS; i++) + ct->ascii[i] = value; #ifdef MULE - case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; -#endif - } + for (i = 0; i < NUM_LEADING_BYTES; i++) + ct->level1[i] = value; +#endif /* MULE */ + + if (ct->type == CHAR_TABLE_TYPE_SYNTAX) + update_syntax_table (ct); } -static enum char_table_type -symbol_to_char_table_type (Lisp_Object symbol) +DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /* +Reset CHAR-TABLE to its default state. +*/ + (char_table)) { - CHECK_SYMBOL (symbol); + Lisp_Char_Table *ct; - 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; + CHECK_CHAR_TABLE (char_table); + ct = XCHAR_TABLE (char_table); + + switch (ct->type) + { + case CHAR_TABLE_TYPE_CHAR: + fill_char_table (ct, make_char (0)); + break; + case CHAR_TABLE_TYPE_DISPLAY: + case CHAR_TABLE_TYPE_GENERIC: #ifdef MULE - if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY; -#endif + case CHAR_TABLE_TYPE_CATEGORY: +#endif /* MULE */ + fill_char_table (ct, Qnil); + break; - signal_simple_error ("Unrecognized char table type", symbol); - return CHAR_TABLE_TYPE_GENERIC; /* not reached */ + case CHAR_TABLE_TYPE_SYNTAX: + fill_char_table (ct, make_int (Sinherit)); + break; + + default: + abort (); + } + + return Qnil; } -static void -print_chartab_range (Emchar first, Emchar last, Lisp_Object val, - Lisp_Object printcharfun) +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)) { - if (first != last) + 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; + if (ty == CHAR_TABLE_TYPE_SYNTAX) { - 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); + 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) { - write_c_string (" ", printcharfun); - print_internal (make_char (first), printcharfun, 0); - write_c_string (" ", printcharfun); + ct->next_table = Vall_syntax_tables; + Vall_syntax_tables = obj; } - print_internal (val, printcharfun, 1); + Freset_char_table (obj); + return obj; } #ifdef MULE -static void -print_chartab_charset_row (Lisp_Object charset, - int row, - Lisp_Char_Table_Entry *cte, - Lisp_Object printcharfun) +static Lisp_Object +make_char_table_entry (Lisp_Object initval) { + Lisp_Object obj; int i; - Lisp_Object cat = Qunbound; - int first = -1; + Lisp_Char_Table_Entry *cte = + alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); - for (i = 32; i < 128; i++) - { - Lisp_Object pam = cte->level2[i - 32]; + for (i = 0; i < 96; i++) + cte->level2[i] = initval; - if (first == -1) - { - first = i; - cat = pam; - continue; - } + XSETCHAR_TABLE_ENTRY (obj, cte); + return obj; +} - 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--; - } - } +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); - if (first != -1) + for (i = 0; i < 96; i++) { - if (row == -1) - print_chartab_range (MAKE_CHAR (charset, first, 0), - MAKE_CHAR (charset, i - 1, 0), - cat, printcharfun); + Lisp_Object new = cte->level2[i]; + if (CHAR_TABLE_ENTRYP (new)) + ctenew->level2[i] = copy_char_table_entry (new); else - print_chartab_range (MAKE_CHAR (charset, row, first), - MAKE_CHAR (charset, row, i - 1), - cat, printcharfun); + ctenew->level2[i] = new; } + + XSETCHAR_TABLE_ENTRY (obj, ctenew); + return obj; } -static void -print_chartab_two_byte_charset (Lisp_Object charset, - Lisp_Char_Table_Entry *cte, - Lisp_Object printcharfun) +#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; int i; - for (i = 32; i < 128; i++) + CHECK_CHAR_TABLE (char_table); + ct = XCHAR_TABLE (char_table); + ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); + ctnew->type = ct->type; + + for (i = 0; i < NUM_ASCII_CHARS; i++) { - Lisp_Object jen = cte->level2[i - 32]; + Lisp_Object new = ct->ascii[i]; +#ifdef MULE + assert (! (CHAR_TABLE_ENTRYP (new))); +#endif /* MULE */ + ctnew->ascii[i] = new; + } - if (!CHAR_TABLE_ENTRYP (jen)) - { - char buf[100]; +#ifdef MULE - 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); - } + 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 - print_chartab_charset_row (charset, i, XCHAR_TABLE_ENTRY (jen), - printcharfun); + ctnew->level1[i] = new; } -} #endif /* MULE */ + 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) + { + ctnew->next_table = Vall_syntax_tables; + Vall_syntax_tables = obj; + } + return obj; +} + static void -print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) { - Lisp_Char_Table *ct = XCHAR_TABLE (obj); - char buf[200]; + 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); + } +#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) + { + 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 (); + } + } + 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); + } +#endif /* MULE */ +} - 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); +#ifdef MULE - /* Now write out the ASCII/Control-1 stuff. */ - { - int i; - int first = -1; - Lisp_Object val = Qunbound; +/* 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; - for (i = 0; i < NUM_ASCII_CHARS; i++) - { - if (first == -1) - { - first = i; - val = ct->ascii[i]; - continue; - } +#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)); + } + } - if (!EQ (ct->ascii[i], val)) - { - print_chartab_range (first, i - 1, val, printcharfun); - first = -1; - i--; - } - } + return val; +} - if (first != -1) - print_chartab_range (first, i - 1, val, printcharfun); - } +#endif /* MULE */ +Lisp_Object +get_char_table (Emchar ch, Lisp_Char_Table *ct) +{ #ifdef MULE { - Charset_ID i; + Lisp_Object charset; + int byte1, byte2; + Lisp_Object val; - for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; - i++) - { - Lisp_Object ann = ct->level1[i - MIN_LEADING_BYTE]; - Lisp_Object charset = CHARSET_BY_LEADING_BYTE (i); + BREAKUP_CHAR (ch, charset, byte1, byte2); - if (!CHARSETP (charset) || i == LEADING_BYTE_ASCII - || i == LEADING_BYTE_CONTROL_1) - continue; - if (!CHAR_TABLE_ENTRYP (ann)) - { - write_c_string (" ", printcharfun); - print_internal (XCHARSET_NAME (charset), - printcharfun, 0); - write_c_string (" ", printcharfun); - print_internal (ann, printcharfun, 0); - } - else + 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 (ann); - if (XCHARSET_DIMENSION (charset) == 1) - print_chartab_charset_row (charset, -1, cte, printcharfun); - else - print_chartab_two_byte_charset (charset, cte, printcharfun); + 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 */ +#else /* not MULE */ + return ct->ascii[(unsigned char)ch]; +#endif /* not MULE */ +} - write_c_string ("))", printcharfun); + +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)); } -static int -char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +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 *ct1 = XCHAR_TABLE (obj1); - Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2); - int i; + Lisp_Char_Table *ct; + struct chartab_range rainj; - if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2)) - return 0; + if (CHAR_OR_CHAR_INTP (range)) + return Fget_char_table (range, char_table); + CHECK_CHAR_TABLE (char_table); + ct = XCHAR_TABLE (char_table); - for (i = 0; i < NUM_ASCII_CHARS; i++) - if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1)) - return 0; + decode_char_table_range (range, &rainj); + switch (rainj.type) + { + case CHARTAB_RANGE_ALL: + { + 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 = 0; i < NUM_LEADING_BYTES; i++) - if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1)) - return 0; + 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 1; -} + return first; + } -static unsigned long -char_table_hash (Lisp_Object obj, int depth) -{ - Lisp_Char_Table *ct = XCHAR_TABLE (obj); - unsigned long hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS, - depth); #ifdef MULE - hashval = HASH2 (hashval, - internal_array_hash (ct->level1, NUM_LEADING_BYTES, depth)); -#endif /* MULE */ - return hashval; + case CHARTAB_RANGE_CHARSET: + 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; + } + + case CHARTAB_RANGE_ROW: + { + 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 */ } -static const struct lrecord_description char_table_description[] = { - { 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 - { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) }, - { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) }, - { XD_END } -}; +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; -DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table, - mark_char_table, print_char_table, 0, - char_table_equal, char_table_hash, - char_table_description, - Lisp_Char_Table); +#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 */ -DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /* -Return non-nil if OBJECT is a char table. + case CHAR_TABLE_TYPE_GENERIC: + return 1; -A char table is a table that maps characters (or ranges of characters) -to values. Char tables are specialized for characters, only allowing -particular sorts of ranges to be assigned values. Although this -loses in generality, it makes for extremely fast (constant-time) -lookups, and thus is feasible for applications that do an extremely -large number of lookups (e.g. scanning a buffer for a character in -a particular syntax, where a lookup in the syntax table must occur -once per character). + case CHAR_TABLE_TYPE_DISPLAY: + /* #### fix this */ + maybe_signal_simple_error ("Display char tables not yet implemented", + value, Qchar_table, errb); + return 0; -When Mule support exists, the types of ranges that can be assigned -values are + case CHAR_TABLE_TYPE_CHAR: + if (!ERRB_EQ (errb, ERROR_ME)) + return CHAR_OR_CHAR_INTP (value); + CHECK_CHAR_COERCE_INT (value); + break; --- all characters --- an entire charset --- a single row in a two-octet charset --- a single character + default: + abort (); + } -When Mule support is not present, the types of ranges that can be -assigned values are + return 0; /* not reached */ +} --- all characters --- a single character +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; +} -To create a char table, use `make-char-table'. -To modify a char table, use `put-char-table' or `remove-char-table'. -To retrieve the value for a particular character, use `get-char-table'. -See also `map-char-table', `clear-char-table', `copy-char-table', -`valid-char-table-type-p', `char-table-type-list', -`valid-char-table-value-p', and `check-char-table-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. */ - (object)) + (value, char_table_type)) { - return CHAR_TABLEP (object) ? Qt : Qnil; + 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 ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /* -Return a list of the recognized char table types. -See `valid-char-table-type-p'. +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)) { -#ifdef MULE - return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax); -#else - return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax); -#endif -} + enum char_table_type type = symbol_to_char_table_type (char_table_type); -DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /* -Return t if TYPE if a recognized char table type. + check_valid_char_table_value (value, type, ERROR_ME); + return Qnil; +} -Each char table type is used for a different purpose and allows different -sorts of values. The different char table types are - -`category' - Used for category tables, which specify the regexp categories - that a character is in. The valid values are nil or a - bit vector of 95 elements. Higher-level Lisp functions are - provided for working with category tables. Currently categories - and category tables only exist when Mule support is present. -`char' - A generalized char table, for mapping from one character to - another. Used for case tables, syntax matching tables, - `keyboard-translate-table', etc. The valid values are characters. -`generic' - An even more generalized char table, for mapping from a - character to anything. -`display' - Used for display tables, which specify how a particular character - is to appear when displayed. #### Not yet implemented. -`syntax' - Used for syntax tables, which specify the syntax of a particular - character. Higher-level Lisp functions are provided for - working with syntax tables. The valid values are integers. - -*/ - (type)) -{ - return (EQ (type, Qchar) || -#ifdef MULE - EQ (type, Qcategory) || -#endif - EQ (type, Qdisplay) || - EQ (type, Qgeneric) || - EQ (type, Qsyntax)) ? Qt : Qnil; -} - -DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /* -Return the type of CHAR-TABLE. -See `valid-char-table-type-p'. -*/ - (char_table)) -{ - CHECK_CHAR_TABLE (char_table); - return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type); -} +/* Assign VAL to all characters in RANGE in char table CT. */ void -fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) +put_char_table (Lisp_Char_Table *ct, struct chartab_range *range, + Lisp_Object val) { - int i; + 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. */ - for (i = 0; i < NUM_ASCII_CHARS; i++) - ct->ascii[i] = value; #ifdef MULE - for (i = 0; i < NUM_LEADING_BYTES; i++) - ct->level1[i] = value; + 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; + } + 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; + } + 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; + break; +#endif /* not MULE */ + } + if (ct->type == CHAR_TABLE_TYPE_SYNTAX) update_syntax_table (ct); } -DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /* -Reset CHAR-TABLE to its default state. +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 + +VALUE must be a value appropriate for the type of CHAR-TABLE. +See `valid-char-table-type-p'. */ - (char_table)) + (range, value, char_table)) { Lisp_Char_Table *ct; + struct chartab_range rainj; 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; +} - switch (ct->type) - { - case CHAR_TABLE_TYPE_CHAR: - fill_char_table (ct, make_char (0)); - break; - case CHAR_TABLE_TYPE_DISPLAY: - case CHAR_TABLE_TYPE_GENERIC: +/* 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 - case CHAR_TABLE_TYPE_CATEGORY: -#endif /* MULE */ - fill_char_table (ct, Qnil); - break; + int stop = 128; +#else + int stop = 256; +#endif - case CHAR_TABLE_TYPE_SYNTAX: - fill_char_table (ct, make_int (Sinherit)); - break; + rainj.type = CHARTAB_RANGE_CHAR; - default: - abort (); + for (i = start, retval = 0; i < stop && retval == 0; i++) + { + rainj.ch = (Emchar) i; + retval = (fn) (&rainj, ct->ascii[i], arg); } - return Qnil; + return retval; } -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)) +#ifdef MULE + +/* 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; - Lisp_Object obj; - enum char_table_type ty = symbol_to_char_table_type (type); + struct chartab_range rainj; + int i, retval; + int start = 128; + int stop = start + 32; - 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) + rainj.type = CHARTAB_RANGE_CHAR; + + for (i = start, retval = 0; i < stop && retval == 0; i++) { - ct->next_table = Vall_syntax_tables; - Vall_syntax_tables = obj; + rainj.ch = (Emchar) (i); + retval = (fn) (&rainj, ct->ascii[i], arg); } - Freset_char_table (obj); - return obj; + + return retval; } -#ifdef MULE +/* 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 Lisp_Object -make_char_table_entry (Lisp_Object initval) +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 obj; - int i; - Lisp_Char_Table_Entry *cte = - alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry); + Lisp_Object val = cte->level2[row - 32]; - 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++) + if (!CHAR_TABLE_ENTRYP (val)) { - 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; - int i; - - CHECK_CHAR_TABLE (char_table); - ct = XCHAR_TABLE (char_table); - ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table); - ctnew->type = ct->type; + struct chartab_range rainj; - 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; + rainj.type = CHARTAB_RANGE_ROW; + rainj.charset = charset; + rainj.row = row; + return (fn) (&rainj, val, arg); } - -#ifdef MULE - - for (i = 0; i < NUM_LEADING_BYTES; i++) + else { - Lisp_Object new = ct->level1[i]; - if (CHAR_TABLE_ENTRYP (new)) - ctnew->level1[i] = copy_char_table_entry (new); - else - ctnew->level1[i] = new; - } + 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; -#endif /* MULE */ + cte = XCHAR_TABLE_ENTRY (val); - 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) - { - ctnew->next_table = Vall_syntax_tables; - Vall_syntax_tables = obj; - } - return obj; -} + rainj.type = CHARTAB_RANGE_CHAR; -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); - } -#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) + 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; + Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE]; + Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb); -#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)); - } - } + if (!CHARSETP (charset) + || lb == LEADING_BYTE_ASCII + || lb == LEADING_BYTE_CONTROL_1) + return 0; - return val; -} + if (!CHAR_TABLE_ENTRYP (val)) + { + struct chartab_range rainj; -#endif /* MULE */ + rainj.type = CHARTAB_RANGE_CHARSET; + rainj.charset = charset; + return (fn) (&rainj, val, arg); + } -Lisp_Object -get_char_table (Emchar ch, Lisp_Char_Table *ct) -{ -#ifdef MULE { - Lisp_Object charset; - int byte1, byte2; - Lisp_Object val; - - 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 */ -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)); -} +/* 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(). */ -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)) +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) { - 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) + switch (range->type) { case CHARTAB_RANGE_ALL: { - int i; - Lisp_Object first = ct->ascii[0]; - - for (i = 1; i < NUM_ASCII_CHARS; i++) - if (!EQ (first, ct->ascii[i])) - return multi; + int retval; + retval = map_over_charset_ascii (ct, fn, arg); + if (retval) + return retval; #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 */ + retval = map_over_charset_control_1 (ct, fn, arg); + if (retval) + return retval; + { + Charset_ID i; + Charset_ID start = MIN_LEADING_BYTE; + Charset_ID stop = start + NUM_LEADING_BYTES; - 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; } #ifdef MULE case CHARTAB_RANGE_CHARSET: - 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; - } + return map_over_other_charset (ct, + XCHARSET_LEADING_BYTE (range->charset), + fn, arg); + case CHARTAB_RANGE_ROW: { - Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) - - MIN_LEADING_BYTE]; - if (CHAR_TABLE_ENTRYP (val)) - return multi; - return val; + 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 /* MULE */ - case CHARTAB_RANGE_ROW: + case CHARTAB_RANGE_CHAR: { - 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; + 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); } -#endif /* not MULE */ default: abort (); } - return Qnil; /* not reached */ + return 0; } +struct slow_map_char_table_arg +{ + Lisp_Object function; + Lisp_Object retval; +}; + static int -check_valid_char_table_value (Lisp_Object value, enum char_table_type type, - Error_behavior errb) +slow_map_char_table_fun (struct chartab_range *range, + Lisp_Object val, void *arg) { - switch (type) + Lisp_Object ranjarg = Qnil; + struct slow_map_char_table_arg *closure = + (struct slow_map_char_table_arg *) arg; + + switch (range->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); + case CHARTAB_RANGE_ALL: + ranjarg = Qt; break; #ifdef MULE - case CHAR_TABLE_TYPE_CATEGORY: - if (!ERRB_EQ (errb, ERROR_ME)) - return CATEGORY_TABLE_VALUEP (value); - CHECK_CATEGORY_TABLE_VALUE (value); + case CHARTAB_RANGE_CHARSET: + ranjarg = XCHARSET_NAME (range->charset); 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); + 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 0; /* not reached */ + closure->retval = call2 (closure->function, ranjarg, val); + return !NILP (closure->retval); } -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 ("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. -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. +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. */ - (value, char_table_type)) + (function, char_table, range)) { - enum char_table_type type = symbol_to_char_table_type (char_table_type); + Lisp_Char_Table *ct; + struct slow_map_char_table_arg slarg; + struct gcpro gcpro1, gcpro2; + struct chartab_range rainj; - return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil; + CHECK_CHAR_TABLE (char_table); + ct = XCHAR_TABLE (char_table); + if (NILP (range)) + range = Qt; + decode_char_table_range (range, &rainj); + slarg.function = function; + slarg.retval = Qnil; + GCPRO2 (slarg.function, slarg.retval); + map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg); + UNGCPRO; + + return slarg.retval; } -DEFUN ("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); + +/************************************************************************/ +/* Character Attributes */ +/************************************************************************/ - check_valid_char_table_value (value, type, ERROR_ME); - return Qnil; -} +#ifdef UTF2000 -/* Assign VAL to all characters in RANGE in char table CT. */ +Lisp_Object Vchar_attribute_hash_table; -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. */ - -#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; - } - break; +/* 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; +}; - 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; - } - break; -#endif /* MULE */ +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; - case CHARTAB_RANGE_CHAR: -#ifdef MULE - { - Lisp_Object charset; - int byte1, byte2; + *char_attribute_list = Fcons (key, *char_attribute_list); + return 0; +} - 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 */ - } +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; +} - if (ct->type == CHAR_TABLE_TYPE_SYNTAX) - update_syntax_table (ct); +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); } -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: +/* 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; +}; --- 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 +static int +add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value, + void *char_attribute_alist_closure) +{ + /* This function can GC */ + struct char_attribute_alist_closure *caacl = + (struct char_attribute_alist_closure*) char_attribute_alist_closure; + Lisp_Object ret = get_char_id_table (caacl->char_id, value); + if (!UNBOUNDP (ret)) + { + Lisp_Object *char_attribute_alist = caacl->char_attribute_alist; + *char_attribute_alist + = Fcons (Fcons (key, ret), *char_attribute_alist); + } + return 0; +} -VALUE must be a value appropriate for the type of CHAR-TABLE. -See `valid-char-table-type-p'. +DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /* +Return the alist of attributes of CHARACTER. */ - (range, value, char_table)) + (character)) { - Lisp_Char_Table *ct; - struct chartab_range rainj; + Lisp_Object alist = Qnil; + int i; - 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; -} + 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; + } -/* Map FN over the ASCII chars in CT. */ + for (i = 0; i < countof (chlook->charset_by_leading_byte); i++) + { + Lisp_Object ccs = chlook->charset_by_leading_byte[i]; -static int -map_over_charset_ascii (Lisp_Char_Table *ct, - int (*fn) (struct chartab_range *range, - Lisp_Object val, void *arg), - void *arg) + if (!NILP (ccs)) + { + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); + Lisp_Object cpos; + + if ( CHAR_ID_TABLE_P (encoding_table) + && INTP (cpos = get_char_id_table (XCHAR (character), + encoding_table)) ) + { + alist = Fcons (Fcons (ccs, cpos), alist); + } + } + } + return alist; +} + +DEFUN ("get-char-attribute", Fget_char_attribute, 2, 3, 0, /* +Return the value of CHARACTER's ATTRIBUTE. +Return DEFAULT-VALUE if the value is not exist. +*/ + (character, attribute, default_value)) { - struct chartab_range rainj; - int i, retval; - int start = 0; -#ifdef MULE - int stop = 128; -#else - int stop = 256; -#endif + Lisp_Object ccs; - rainj.type = CHARTAB_RANGE_CHAR; + CHECK_CHAR (character); + if (!NILP (ccs = Ffind_charset (attribute))) + { + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); - for (i = start, retval = 0; i < stop && retval == 0; i++) + if (CHAR_ID_TABLE_P (encoding_table)) + return get_char_id_table (XCHAR (character), encoding_table); + } + else { - rainj.ch = (Emchar) i; - retval = (fn) (&rainj, ct->ascii[i], arg); + 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 retval; + return default_value; } -#ifdef MULE - -/* 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) +DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /* +Store CHARACTER's ATTRIBUTE with VALUE. +*/ + (character, attribute, value)) { - struct chartab_range rainj; - int i, retval; - int start = 128; - int stop = start + 32; - - rainj.type = CHARTAB_RANGE_CHAR; + Lisp_Object ccs; - for (i = start, retval = 0; i < stop && retval == 0; i++) + CHECK_CHAR (character); + ccs = Ffind_charset (attribute); + if (!NILP (ccs)) { - rainj.ch = (Emchar) (i); - retval = (fn) (&rainj, ct->ascii[i], arg); + return put_char_ccs_code_point (character, ccs, value); } + else if (EQ (attribute, Q_decomposition)) + { + Lisp_Object seq; - return retval; -} + if (!CONSP (value)) + signal_simple_error ("Invalid value for ->decomposition", + value); -/* 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. */ + if (CONSP (Fcdr (value))) + { + Lisp_Object rest = value; + Lisp_Object table = Vcharacter_composition_table; + size_t len; + int i = 0; -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]; + GET_EXTERNAL_LIST_LENGTH (rest, len); + seq = make_vector (len, Qnil); - if (!CHAR_TABLE_ENTRYP (val)) - { - struct chartab_range rainj; + while (CONSP (rest)) + { + Lisp_Object v = Fcar (rest); + Lisp_Object ntable; + Emchar c + = to_char_id (v, "Invalid value for ->decomposition", value); - rainj.type = CHARTAB_RANGE_ROW; - rainj.charset = charset; - rainj.row = row; - return (fn) (&rainj, val, arg); + if (c < 0) + XVECTOR_DATA(seq)[i++] = v; + else + XVECTOR_DATA(seq)[i++] = make_char (c); + rest = Fcdr (rest); + if (!CONSP (rest)) + { + put_char_id_table (c, character, table); + break; + } + else + { + ntable = get_char_id_table (c, table); + if (!CHAR_ID_TABLE_P (ntable)) + { + ntable = make_char_id_table (Qnil); + put_char_id_table (c, ntable, table); + } + table = ntable; + } + } + } + else + { + Lisp_Object v = Fcar (value); + + if (INTP (v)) + { + Emchar c = XINT (v); + Lisp_Object ret + = get_char_id_table (c, Vcharacter_variant_table); + + if (NILP (Fmemq (v, ret))) + { + put_char_id_table (c, Fcons (character, ret), + Vcharacter_variant_table); + } + } + seq = make_vector (1, v); + } + value = seq; } - else + else if (EQ (attribute, Qto_ucs) || EQ (attribute, Q_ucs)) { - 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; + Lisp_Object ret; + Emchar c; - cte = XCHAR_TABLE_ENTRY (val); + if (!INTP (value)) + signal_simple_error ("Invalid value for ->ucs", value); - rainj.type = CHARTAB_RANGE_CHAR; + c = XINT (value); - for (i = start, retval = 0; i < stop && retval == 0; i++) + ret = get_char_id_table (c, Vcharacter_variant_table); + if (NILP (Fmemq (character, ret))) { - rainj.ch = MAKE_CHAR (charset, row, i); - retval = (fn) (&rainj, cte->level2[i - 32], arg); + put_char_id_table (c, Fcons (character, ret), + Vcharacter_variant_table); } - return retval; +#if 0 + if (EQ (attribute, Q_ucs)) + attribute = Qto_ucs; +#endif } -} - + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qnil); -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) + if (NILP (table)) + { + table = make_char_id_table (Qunbound); + Fputhash (attribute, table, Vchar_attribute_hash_table); + } + put_char_id_table (XCHAR (character), value, table); + return value; + } +} + +DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /* +Remove CHARACTER's ATTRIBUTE. +*/ + (character, attribute)) { - Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE]; - Lisp_Object charset = CHARSET_BY_LEADING_BYTE (lb); - - if (!CHARSETP (charset) - || lb == LEADING_BYTE_ASCII - || lb == LEADING_BYTE_CONTROL_1) - return 0; + Lisp_Object ccs; - if (!CHAR_TABLE_ENTRYP (val)) + CHECK_CHAR (character); + ccs = Ffind_charset (attribute); + if (!NILP (ccs)) { - struct chartab_range rainj; - - rainj.type = CHARTAB_RANGE_CHARSET; - rainj.charset = charset; - return (fn) (&rainj, val, arg); + return remove_char_ccs (character, ccs); + } + else + { + Lisp_Object table = Fgethash (attribute, + Vchar_attribute_hash_table, + Qunbound); + if (!UNBOUNDP (table)) + { + put_char_id_table (XCHAR (character), Qunbound, table); + return Qt; + } } + return Qnil; +} - { - 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; +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_table_arg slarg; + struct gcpro gcpro1, gcpro2; - if (XCHARSET_DIMENSION (charset) == 1) - { - struct chartab_range rainj; - rainj.type = CHARTAB_RANGE_CHAR; + if (!NILP (ccs = Ffind_charset (attribute))) + { + Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs); - 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 (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_table_fun, &slarg); + UNGCPRO; - return retval; - } + return slarg.retval; } -#endif /* MULE */ - -/* 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(). */ +EXFUN (Fmake_char, 3); +EXFUN (Fdecode_char, 2); -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) +DEFUN ("define-char", Fdefine_char, 1, 1, 0, /* +Store character's ATTRIBUTES. +*/ + (attributes)) { - switch (range->type) - { - case CHARTAB_RANGE_ALL: - { - int retval; + Lisp_Object rest = attributes; + Lisp_Object code = Fcdr (Fassq (Qucs, attributes)); + Lisp_Object character; - 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 (NILP (code)) + { + while (CONSP (rest)) { - Charset_ID i; - Charset_ID start = MIN_LEADING_BYTE; - Charset_ID stop = start + NUM_LEADING_BYTES; + Lisp_Object cell = Fcar (rest); + Lisp_Object ccs; - for (i = start, retval = 0; i < stop && retval == 0; i++) + 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)) ) { - retval = map_over_other_charset (ct, i, fn, arg); + 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); } -#endif /* MULE */ - return retval; - } - -#ifdef MULE - case CHARTAB_RANGE_CHARSET: - return map_over_other_charset (ct, - XCHARSET_LEADING_BYTE (range->charset), - fn, arg); - - 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; - - 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 */ - - case CHARTAB_RANGE_CHAR: - { - Emchar ch = range->ch; - Lisp_Object val = CHAR_TABLE_VALUE_UNSAFE (ct, ch); - struct chartab_range rainj; - - rainj.type = CHARTAB_RANGE_CHAR; - rainj.ch = ch; - return (fn) (&rainj, val, arg); - } - - default: - abort (); + 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)); - return 0; -} - -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) -{ - Lisp_Object ranjarg = Qnil; - struct slow_map_char_table_arg *closure = - (struct slow_map_char_table_arg *) arg; - - switch (range->type) + setup_attributes: + rest = attributes; + while (CONSP (rest)) { - case CHARTAB_RANGE_ALL: - ranjarg = Qt; - break; + Lisp_Object cell = Fcar (rest); -#ifdef MULE - case CHARTAB_RANGE_CHARSET: - ranjarg = XCHARSET_NAME (range->charset); - break; + if (!LISTP (cell)) + signal_simple_error ("Invalid argument", attributes); - 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 (); + Fput_char_attribute (character, Fcar (cell), Fcdr (cell)); + rest = Fcdr (rest); } - - closure->retval = call2 (closure->function, ranjarg, val); - return !NILP (closure->retval); + return 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. - -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. +DEFUN ("find-char", Ffind_char, 1, 1, 0, /* +Retrieve the character of the given ATTRIBUTES. */ - (function, char_table, range)) + (attributes)) { - Lisp_Char_Table *ct; - struct slow_map_char_table_arg slarg; - struct gcpro gcpro1, gcpro2; - struct chartab_range rainj; + Lisp_Object rest = attributes; + Lisp_Object code; - CHECK_CHAR_TABLE (char_table); - ct = XCHAR_TABLE (char_table); - if (NILP (range)) - range = Qt; - decode_char_table_range (range, &rainj); - slarg.function = function; - slarg.retval = Qnil; - GCPRO2 (slarg.function, slarg.retval); - map_char_table (ct, &rainj, slow_map_char_table_fun, &slarg); - UNGCPRO; + while (CONSP (rest)) + { + Lisp_Object cell = Fcar (rest); + Lisp_Object ccs; - return slarg.retval; + 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); + } + 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 /************************************************************************/