-\f
-DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
- 1, 1, 0,
- doc: /* Return the subtype of char-table CHAR-TABLE. The value is a symbol. */)
- (char_table)
- Lisp_Object char_table;
-{
- CHECK_CHAR_TABLE (char_table);
-
- return XCHAR_TABLE (char_table)->purpose;
-}
-
-DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
- 1, 1, 0,
- doc: /* Return the parent char-table of CHAR-TABLE.
-The value is either nil or another char-table.
-If CHAR-TABLE holds nil for a given character,
-then the actual applicable value is inherited from the parent char-table
-\(or from its parents, if necessary). */)
- (char_table)
- Lisp_Object char_table;
-{
- CHECK_CHAR_TABLE (char_table);
-
- return XCHAR_TABLE (char_table)->parent;
-}
-
-DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
- 2, 2, 0,
- doc: /* Set the parent char-table of CHAR-TABLE to PARENT.
-Return PARENT. PARENT must be either nil or another char-table. */)
- (char_table, parent)
- Lisp_Object char_table, parent;
-{
- Lisp_Object temp;
-
- CHECK_CHAR_TABLE (char_table);
-
- if (!NILP (parent))
- {
- CHECK_CHAR_TABLE (parent);
-
- for (temp = parent; CHAR_TABLE_P (temp);
- temp = XCHAR_TABLE (temp)->parent)
- if (EQ (temp, char_table))
- error ("Attempt to make a chartable be its own parent");
- }
-
- XCHAR_TABLE (char_table)->parent = parent;
-
- return parent;
-}
-
-DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
- 2, 2, 0,
- doc: /* Return the value of CHAR-TABLE's extra-slot number N. */)
- (char_table, n)
- Lisp_Object char_table, n;
-{
- CHECK_CHAR_TABLE (char_table);
- CHECK_NUMBER (n);
- if (XINT (n) < 0
- || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
- args_out_of_range (char_table, n);
-
- return XCHAR_TABLE (char_table)->extras[XINT (n)];
-}
-
-DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
- Sset_char_table_extra_slot,
- 3, 3, 0,
- doc: /* Set CHAR-TABLE's extra-slot number N to VALUE. */)
- (char_table, n, value)
- Lisp_Object char_table, n, value;
-{
- CHECK_CHAR_TABLE (char_table);
- CHECK_NUMBER (n);
- if (XINT (n) < 0
- || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
- args_out_of_range (char_table, n);
-
- return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
-}
-\f
-static Lisp_Object
-char_table_range (table, from, to, defalt)
- Lisp_Object table;
- int from, to;
- Lisp_Object defalt;
-{
- Lisp_Object val;
-
- if (! NILP (XCHAR_TABLE (table)->defalt))
- defalt = XCHAR_TABLE (table)->defalt;
- val = XCHAR_TABLE (table)->contents[from];
- if (SUB_CHAR_TABLE_P (val))
- val = char_table_range (val, 32, 127, defalt);
- else if (NILP (val))
- val = defalt;
- for (from++; from <= to; from++)
- {
- Lisp_Object this_val;
-
- this_val = XCHAR_TABLE (table)->contents[from];
- if (SUB_CHAR_TABLE_P (this_val))
- this_val = char_table_range (this_val, 32, 127, defalt);
- else if (NILP (this_val))
- this_val = defalt;
- if (! EQ (val, this_val))
- error ("Characters in the range have inconsistent values");
- }
- return val;
-}
-
-
-DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
- 2, 2, 0,
- doc: /* Return the value in CHAR-TABLE for a range of characters RANGE.
-RANGE should be nil (for the default value),
-a vector which identifies a character set or a row of a character set,
-a character set name, or a character code.
-If the characters in the specified range have different values,
-an error is signaled.
-
-Note that this function doesn't check the parent of CHAR-TABLE. */)
- (char_table, range)
- Lisp_Object char_table, range;
-{
- int charset_id, c1 = 0, c2 = 0;
- int size;
- Lisp_Object ch, val, current_default;
-
- CHECK_CHAR_TABLE (char_table);
-
- if (EQ (range, Qnil))
- return XCHAR_TABLE (char_table)->defalt;
- if (INTEGERP (range))
- {
- int c = XINT (range);
- if (! CHAR_VALID_P (c, 0))
- error ("Invalid character code: %d", c);
- ch = range;
- SPLIT_CHAR (c, charset_id, c1, c2);
- }
- else if (SYMBOLP (range))
- {
- Lisp_Object charset_info;
-
- charset_info = Fget (range, Qcharset);
- CHECK_VECTOR (charset_info);
- charset_id = XINT (AREF (charset_info, 0));
- ch = Fmake_char_internal (make_number (charset_id),
- make_number (0), make_number (0));
- }
- else if (VECTORP (range))
- {
- size = ASIZE (range);
- if (size == 0)
- args_out_of_range (range, make_number (0));
- CHECK_NUMBER (AREF (range, 0));
- charset_id = XINT (AREF (range, 0));
- if (size > 1)
- {
- CHECK_NUMBER (AREF (range, 1));
- c1 = XINT (AREF (range, 1));
- if (size > 2)
- {
- CHECK_NUMBER (AREF (range, 2));
- c2 = XINT (AREF (range, 2));
- }
- }
-
- /* This checks if charset_id, c0, and c1 are all valid or not. */
- ch = Fmake_char_internal (make_number (charset_id),
- make_number (c1), make_number (c2));
- }
- else
- error ("Invalid RANGE argument to `char-table-range'");
-
- if (c1 > 0 && (CHARSET_DIMENSION (charset_id) == 1 || c2 > 0))
- {
- /* Fully specified character. */
- Lisp_Object parent = XCHAR_TABLE (char_table)->parent;
-
- XCHAR_TABLE (char_table)->parent = Qnil;
- val = Faref (char_table, ch);
- XCHAR_TABLE (char_table)->parent = parent;
- return val;
- }
-
- current_default = XCHAR_TABLE (char_table)->defalt;
- if (charset_id == CHARSET_ASCII
- || charset_id == CHARSET_8_BIT_CONTROL
- || charset_id == CHARSET_8_BIT_GRAPHIC)
- {
- int from, to, defalt;
-
- if (charset_id == CHARSET_ASCII)
- from = 0, to = 127, defalt = CHAR_TABLE_DEFAULT_SLOT_ASCII;
- else if (charset_id == CHARSET_8_BIT_CONTROL)
- from = 128, to = 159, defalt = CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL;
- else
- from = 160, to = 255, defalt = CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC;
- if (! NILP (XCHAR_TABLE (char_table)->contents[defalt]))
- current_default = XCHAR_TABLE (char_table)->contents[defalt];
- return char_table_range (char_table, from, to, current_default);
- }
-
- val = XCHAR_TABLE (char_table)->contents[128 + charset_id];
- if (! SUB_CHAR_TABLE_P (val))
- return (NILP (val) ? current_default : val);
- if (! NILP (XCHAR_TABLE (val)->defalt))
- current_default = XCHAR_TABLE (val)->defalt;
- if (c1 == 0)
- return char_table_range (val, 32, 127, current_default);
- val = XCHAR_TABLE (val)->contents[c1];
- if (! SUB_CHAR_TABLE_P (val))
- return (NILP (val) ? current_default : val);
- if (! NILP (XCHAR_TABLE (val)->defalt))
- current_default = XCHAR_TABLE (val)->defalt;
- return char_table_range (val, 32, 127, current_default);
-}
-
-DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
- 3, 3, 0,
- doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
-RANGE should be t (for all characters), nil (for the default value),
-a character set, a vector which identifies a character set, a row of a
-character set, or a character code. Return VALUE. */)
- (char_table, range, value)
- Lisp_Object char_table, range, value;
-{
- int i;
-
- CHECK_CHAR_TABLE (char_table);
-
- if (EQ (range, Qt))
- for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
- {
- /* Don't set these special slots used for default values of
- ascii, eight-bit-control, and eight-bit-graphic. */
- if (i != CHAR_TABLE_DEFAULT_SLOT_ASCII
- && i != CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
- && i != CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC)
- XCHAR_TABLE (char_table)->contents[i] = value;
- }
- else if (EQ (range, Qnil))
- XCHAR_TABLE (char_table)->defalt = value;
- else if (SYMBOLP (range))
- {
- Lisp_Object charset_info;
- int charset_id;
-
- charset_info = Fget (range, Qcharset);
- if (! VECTORP (charset_info)
- || ! NATNUMP (AREF (charset_info, 0))
- || (charset_id = XINT (AREF (charset_info, 0)),
- ! CHARSET_DEFINED_P (charset_id)))
- error ("Invalid charset: %s", SDATA (SYMBOL_NAME (range)));
-
- if (charset_id == CHARSET_ASCII)
- for (i = 0; i < 128; i++)
- XCHAR_TABLE (char_table)->contents[i] = value;
- else if (charset_id == CHARSET_8_BIT_CONTROL)
- for (i = 128; i < 160; i++)
- XCHAR_TABLE (char_table)->contents[i] = value;
- else if (charset_id == CHARSET_8_BIT_GRAPHIC)
- for (i = 160; i < 256; i++)
- XCHAR_TABLE (char_table)->contents[i] = value;
- else
- XCHAR_TABLE (char_table)->contents[charset_id + 128] = value;
- }
- else if (INTEGERP (range))
- Faset (char_table, range, value);
- else if (VECTORP (range))
- {
- int size = ASIZE (range);
- Lisp_Object *val = XVECTOR (range)->contents;
- Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
- size <= 1 ? Qnil : val[1],
- size <= 2 ? Qnil : val[2]);
- Faset (char_table, ch, value);
- }
- else
- error ("Invalid RANGE argument to `set-char-table-range'");
-
- return value;
-}
-
-DEFUN ("set-char-table-default", Fset_char_table_default,
- Sset_char_table_default, 3, 3, 0,
- doc: /* Set the default value in CHAR-TABLE for generic character CH to VALUE.
-The generic character specifies the group of characters.
-If CH is a normal character, set the default value for a group of
-characters to which CH belongs.
-See also the documentation of `make-char'. */)
- (char_table, ch, value)
- Lisp_Object char_table, ch, value;
-{
- int c, charset, code1, code2;
- Lisp_Object temp;
-
- CHECK_CHAR_TABLE (char_table);
- CHECK_NUMBER (ch);
-
- c = XINT (ch);
- SPLIT_CHAR (c, charset, code1, code2);
-
- /* Since we may want to set the default value for a character set
- not yet defined, we check only if the character set is in the
- valid range or not, instead of it is already defined or not. */
- if (! CHARSET_VALID_P (charset))
- invalid_character (c);
-
- if (SINGLE_BYTE_CHAR_P (c))
- {
- /* We use special slots for the default values of single byte
- characters. */
- int default_slot
- = (c < 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII
- : c < 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL
- : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC);
-
- return (XCHAR_TABLE (char_table)->contents[default_slot] = value);
- }
-
- /* Even if C is not a generic char, we had better behave as if a
- generic char is specified. */
- if (!CHARSET_DEFINED_P (charset) || CHARSET_DIMENSION (charset) == 1)
- code1 = 0;
- temp = XCHAR_TABLE (char_table)->contents[charset + 128];
- if (! SUB_CHAR_TABLE_P (temp))
- {
- temp = make_sub_char_table (temp);
- XCHAR_TABLE (char_table)->contents[charset + 128] = temp;
- }
- if (!code1)
- {
- XCHAR_TABLE (temp)->defalt = value;
- return value;
- }
- char_table = temp;
- temp = XCHAR_TABLE (char_table)->contents[code1];
- if (SUB_CHAR_TABLE_P (temp))
- XCHAR_TABLE (temp)->defalt = value;
- else
- XCHAR_TABLE (char_table)->contents[code1] = value;
- return value;
-}
-
-/* Look up the element in TABLE at index CH,
- and return it as an integer.
- If the element is nil, return CH itself.
- (Actually we do that for any non-integer.) */
-
-int
-char_table_translate (table, ch)
- Lisp_Object table;
- int ch;
-{
- Lisp_Object value;
- value = Faref (table, make_number (ch));
- if (! INTEGERP (value))
- return ch;
- return XINT (value);
-}
-
-static void
-optimize_sub_char_table (table, chars)
- Lisp_Object *table;
- int chars;
-{
- Lisp_Object elt;
- int from, to;
-
- if (chars == 94)
- from = 33, to = 127;
- else
- from = 32, to = 128;
-
- if (!SUB_CHAR_TABLE_P (*table)
- || ! NILP (XCHAR_TABLE (*table)->defalt))
- return;
- elt = XCHAR_TABLE (*table)->contents[from++];
- for (; from < to; from++)
- if (NILP (Fequal (elt, XCHAR_TABLE (*table)->contents[from])))
- return;
- *table = elt;
-}
-
-DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
- 1, 1, 0, doc: /* Optimize char table TABLE. */)
- (table)
- Lisp_Object table;
-{
- Lisp_Object elt;
- int dim, chars;
- int i, j;
-
- CHECK_CHAR_TABLE (table);
-
- for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
- {
- elt = XCHAR_TABLE (table)->contents[i];
- if (!SUB_CHAR_TABLE_P (elt))
- continue;
- dim = CHARSET_DIMENSION (i - 128);
- chars = CHARSET_CHARS (i - 128);
- if (dim == 2)
- for (j = 32; j < SUB_CHAR_TABLE_ORDINARY_SLOTS; j++)
- optimize_sub_char_table (XCHAR_TABLE (elt)->contents + j, chars);
- optimize_sub_char_table (XCHAR_TABLE (table)->contents + i, chars);
- }
- return Qnil;
-}
-
-\f
-/* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
- character or group of characters that share a value.
- DEPTH is the current depth in the originally specified
- chartable, and INDICES contains the vector indices
- for the levels our callers have descended.
-
- ARG is passed to C_FUNCTION when that is called. */
-
-void
-map_char_table (c_function, function, table, subtable, arg, depth, indices)
- void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
- Lisp_Object function, table, subtable, arg;
- int depth, *indices;
-{
- int i, to;
- struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
-
- GCPRO4 (arg, table, subtable, function);
-
- if (depth == 0)
- {
- /* At first, handle ASCII and 8-bit European characters. */
- for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
- {
- Lisp_Object elt= XCHAR_TABLE (subtable)->contents[i];
- if (NILP (elt))
- elt = XCHAR_TABLE (subtable)->defalt;
- if (NILP (elt))
- elt = Faref (subtable, make_number (i));
- if (c_function)
- (*c_function) (arg, make_number (i), elt);
- else
- call2 (function, make_number (i), elt);
- }
-#if 0 /* If the char table has entries for higher characters,
- we should report them. */
- if (NILP (current_buffer->enable_multibyte_characters))
- {
- UNGCPRO;
- return;
- }
-#endif
- to = CHAR_TABLE_ORDINARY_SLOTS;
- }
- else
- {
- int charset = indices[0] - 128;
-
- i = 32;
- to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
- if (CHARSET_CHARS (charset) == 94)
- i++, to--;
- }
-
- for (; i < to; i++)
- {
- Lisp_Object elt;
- int charset;
-
- elt = XCHAR_TABLE (subtable)->contents[i];
- indices[depth] = i;
- charset = indices[0] - 128;
- if (depth == 0
- && (!CHARSET_DEFINED_P (charset)
- || charset == CHARSET_8_BIT_CONTROL
- || charset == CHARSET_8_BIT_GRAPHIC))
- continue;
-
- if (SUB_CHAR_TABLE_P (elt))
- {
- if (depth >= 3)
- error ("Too deep char table");
- map_char_table (c_function, function, table, elt, arg, depth + 1, indices);
- }
- else
- {
- int c1, c2, c;
-
- c1 = depth >= 1 ? indices[1] : 0;
- c2 = depth >= 2 ? indices[2] : 0;
- c = MAKE_CHAR (charset, c1, c2);
-
- if (NILP (elt))
- elt = XCHAR_TABLE (subtable)->defalt;
- if (NILP (elt))
- elt = Faref (table, make_number (c));
-
- if (c_function)
- (*c_function) (arg, make_number (c), elt);
- else
- call2 (function, make_number (c), elt);
- }
- }
- UNGCPRO;
-}
-
-static void void_call2 P_ ((Lisp_Object a, Lisp_Object b, Lisp_Object c));
-static void
-void_call2 (a, b, c)
- Lisp_Object a, b, c;
-{
- call2 (a, b, c);
-}
-
-DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
- 2, 2, 0,
- doc: /* Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.
-FUNCTION is called with two arguments--a key and a value.
-The key is always a possible IDX argument to `aref'. */)
- (function, char_table)
- Lisp_Object function, char_table;
-{
- /* The depth of char table is at most 3. */
- int indices[3];
-
- CHECK_CHAR_TABLE (char_table);
-
- /* When Lisp_Object is represented as a union, `call2' cannot directly
- be passed to map_char_table because it returns a Lisp_Object rather
- than returning nothing.
- Casting leads to crashes on some architectures. --Stef */
- map_char_table (void_call2, Qnil, char_table, char_table, function, 0, indices);
- return Qnil;
-}
-
-/* Return a value for character C in char-table TABLE. Store the
- actual index for that value in *IDX. Ignore the default value of
- TABLE. */
-
-Lisp_Object
-char_table_ref_and_index (table, c, idx)
- Lisp_Object table;
- int c, *idx;
-{
- int charset, c1, c2;
- Lisp_Object elt;
-
- if (SINGLE_BYTE_CHAR_P (c))
- {
- *idx = c;
- return XCHAR_TABLE (table)->contents[c];
- }
- SPLIT_CHAR (c, charset, c1, c2);
- elt = XCHAR_TABLE (table)->contents[charset + 128];
- *idx = MAKE_CHAR (charset, 0, 0);
- if (!SUB_CHAR_TABLE_P (elt))
- return elt;
- if (c1 < 32 || NILP (XCHAR_TABLE (elt)->contents[c1]))
- return XCHAR_TABLE (elt)->defalt;
- elt = XCHAR_TABLE (elt)->contents[c1];
- *idx = MAKE_CHAR (charset, c1, 0);
- if (!SUB_CHAR_TABLE_P (elt))
- return elt;
- if (c2 < 32 || NILP (XCHAR_TABLE (elt)->contents[c2]))
- return XCHAR_TABLE (elt)->defalt;
- *idx = c;
- return XCHAR_TABLE (elt)->contents[c2];
-}
-