/* chartab.c -- char-table support
- Copyright (C) 2001, 2002
+ Copyright (C) 2003
National Institute of Advanced Industrial Science and Technology (AIST)
Registration Number H13PRO009
Boston, MA 02111-1307, USA. */
#include <config.h>
-#include <lisp.h>
-#include <character.h>
-#include <charset.h>
-#include <ccl.h>
+#include "lisp.h"
+#include "character.h"
+#include "charset.h"
+#include "ccl.h"
/* 64/16/32/128 */
DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
- doc: /* Return a newly created char-table.
+ doc: /* Return a newly created char-table, with purpose PURPOSE.
Each element is initialized to INIT, which defaults to nil.
-Optional second argument PURPOSE, if non-nil, should be a symbol
-which has a `char-table-extra-slots' property.
-The property's value should be an integer between 0 and 10
-that specify how many extra slots the char-table has.
-By default, the char-table has no extra slot. */)
+PURPOSE should be a symbol. If it has a `char-table-extra-slots'
+property, the property's value should be an integer between 0 and 10
+that specifies how many extra slots the char-table has. Otherwise,
+the char-table has no extra slot. */)
(purpose, init)
register Lisp_Object purpose, init;
{
Lisp_Object vector;
Lisp_Object n;
- int n_extras = 0;
+ int n_extras;
int size;
CHECK_SYMBOL (purpose);
- if (! NILP (purpose))
+ n = Fget (purpose, Qchar_table_extra_slots);
+ if (NILP (n))
+ n_extras = 0;
+ else
{
- n = Fget (purpose, Qchar_table_extra_slots);
- if (INTEGERP (n))
- {
- if (XINT (n) < 0 || XINT (n) > 10)
- args_out_of_range (n, Qnil);
- n_extras = XINT (n);
- }
+ CHECK_NATNUM (n);
+ n_extras = XINT (n);
+ if (n_extras > 10)
+ args_out_of_range (n, Qnil);
}
size = VECSIZE (struct Lisp_Char_Table) - 1 + n_extras;
{
Lisp_Object table;
int size = VECSIZE (struct Lisp_Sub_Char_Table) - 1 + chartab_size[depth];
- int i;
table = Fmake_vector (make_number (size), defalt);
XSUB_CHAR_TABLE (table)->depth = make_number (depth);
Lisp_Object sub;
sub = XCHAR_TABLE (table)->contents[0];
+ if (! SUB_CHAR_TABLE_P (sub))
+ return sub;
sub = XSUB_CHAR_TABLE (sub)->contents[0];
+ if (! SUB_CHAR_TABLE_P (sub))
+ return sub;
return XSUB_CHAR_TABLE (sub)->contents[0];
}
val = char_table_ref (tbl->parent, c);
}
return val;
-}
+}
static Lisp_Object
-sub_char_table_ref_and_range (table, c, from, to)
+sub_char_table_ref_and_range (table, c, from, to, defalt)
Lisp_Object table;
int c;
int *from, *to;
+ Lisp_Object defalt;
{
struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
int depth = XINT (tbl->depth);
int min_char = XINT (tbl->min_char);
+ int max_char = min_char + chartab_chars[depth - 1] - 1;
+ int index = CHARTAB_IDX (c, depth, min_char);
Lisp_Object val;
-
- val = tbl->contents[CHARTAB_IDX (c, depth, min_char)];
- if (depth == 3)
+
+ val = tbl->contents[index];
+ *from = min_char + index * chartab_chars[depth];
+ *to = *from + chartab_chars[depth] - 1;
+ if (SUB_CHAR_TABLE_P (val))
+ val = sub_char_table_ref_and_range (val, c, from, to, defalt);
+ else if (NILP (val))
+ val = defalt;
+
+ while (*from > min_char
+ && *from == min_char + index * chartab_chars[depth])
{
- *from = *to = c;
+ Lisp_Object this_val;
+ int this_from = *from - chartab_chars[depth];
+ int this_to = *from - 1;
+
+ index--;
+ this_val = tbl->contents[index];
+ if (SUB_CHAR_TABLE_P (this_val))
+ this_val = sub_char_table_ref_and_range (this_val, this_to,
+ &this_from, &this_to,
+ defalt);
+ else if (NILP (this_val))
+ this_val = defalt;
+
+ if (! EQ (this_val, val))
+ break;
+ *from = this_from;
}
- else if (SUB_CHAR_TABLE_P (val))
+ index = CHARTAB_IDX (c, depth, min_char);
+ while (*to < max_char
+ && *to == min_char + (index + 1) * chartab_chars[depth] - 1)
{
- val = sub_char_table_ref_and_range (val, c, from, to);
- }
- else
- {
- *from = (CHARTAB_IDX (c, depth, min_char) * chartab_chars[depth]
- + min_char);
- *to = *from + chartab_chars[depth] - 1;
+ Lisp_Object this_val;
+ int this_from = *to + 1;
+ int this_to = this_from + chartab_chars[depth] - 1;
+
+ index++;
+ this_val = tbl->contents[index];
+ if (SUB_CHAR_TABLE_P (this_val))
+ this_val = sub_char_table_ref_and_range (this_val, this_from,
+ &this_from, &this_to,
+ defalt);
+ else if (NILP (this_val))
+ this_val = defalt;
+ if (! EQ (this_val, val))
+ break;
+ *to = this_to;
}
+
return val;
}
+/* Return the value for C in char-table TABLE. Set *FROM and *TO to
+ the range of characters (containing C) that have the same value as
+ C. It is not assured that the value of (*FROM - 1) and (*TO + 1)
+ is different from that of C. */
+
Lisp_Object
char_table_ref_and_range (table, c, from, to)
Lisp_Object table;
int *from, *to;
{
struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
+ int index = CHARTAB_IDX (c, 0, 0);
Lisp_Object val;
- if (ASCII_CHAR_P (c))
+ val = tbl->contents[index];
+ *from = index * chartab_chars[0];
+ *to = *from + chartab_chars[0] - 1;
+ if (SUB_CHAR_TABLE_P (val))
+ val = sub_char_table_ref_and_range (val, c, from, to, tbl->defalt);
+ else if (NILP (val))
+ val = tbl->defalt;
+
+ while (*from > 0 && *from == index * chartab_chars[0])
{
- val = tbl->ascii;
- if (SUB_CHAR_TABLE_P (val))
- {
- val = XSUB_CHAR_TABLE (val)->contents[c];
- *from = *to = c;
- }
- else
- {
- *from = 0, *to = 127;
- }
+ Lisp_Object this_val;
+ int this_from = *from - chartab_chars[0];
+ int this_to = *from - 1;
+
+ index--;
+ this_val = tbl->contents[index];
+ if (SUB_CHAR_TABLE_P (this_val))
+ this_val = sub_char_table_ref_and_range (this_val, this_to,
+ &this_from, &this_to,
+ tbl->defalt);
+ else if (NILP (this_val))
+ this_val = tbl->defalt;
+
+ if (! EQ (this_val, val))
+ break;
+ *from = this_from;
}
- else
+ while (*to < MAX_CHAR && *to == (index + 1) * chartab_chars[0] - 1)
{
- val = tbl->contents[CHARTAB_IDX (c, 0, 0)];
- if (SUB_CHAR_TABLE_P (val))
- {
- val = sub_char_table_ref_and_range (val, c, from, to);
- }
- else
- {
- *from = CHARTAB_IDX (c, 0, 0) * chartab_chars[0];
- *to = *from + chartab_chars[0] - 1;
- }
+ Lisp_Object this_val;
+ int this_from = *to + 1;
+ int this_to = this_from + chartab_chars[0] - 1;
+
+ index++;
+ this_val = tbl->contents[index];
+ if (SUB_CHAR_TABLE_P (this_val))
+ this_val = sub_char_table_ref_and_range (this_val, this_from,
+ &this_from, &this_to,
+ tbl->defalt);
+ else if (NILP (this_val))
+ this_val = tbl->defalt;
+ if (! EQ (this_val, val))
+ break;
+ *to = this_to;
}
- if (NILP (val))
- {
- val = tbl->defalt;
- *from = 0, *to = MAX_CHAR;
- if (NILP (val) && CHAR_TABLE_P (tbl->parent))
- val = char_table_ref_and_range (tbl->parent, c, from, to);
- }
return val;
-}
+}
#define ASET_RANGE(ARRAY, FROM, TO, LIMIT, VAL) \
int min_char = XINT ((tbl)->min_char);
int i = CHARTAB_IDX (c, depth, min_char);
Lisp_Object sub;
-
+
if (depth == 3)
tbl->contents[i] = val;
else
}
sub_char_table_set (sub, c, val);
if (ASCII_CHAR_P (c))
- tbl->ascii = char_table_ascii (tbl);
+ tbl->ascii = char_table_ascii (table);
}
return val;
}
{
int max_char = min_char + chartab_chars[depth] - 1;
- if (from <= min_char && to >= max_char)
+ if (depth == 3 || (from <= min_char && to >= max_char))
*table = val;
else
{
from = min_char;
if (to > max_char)
to = max_char;
+ i = CHARTAB_IDX (from, depth, min_char);
j = CHARTAB_IDX (to, depth, min_char);
- for (i = CHARTAB_IDX (from, depth, min_char); i <= j; i++)
+ min_char += chartab_chars[depth] * i;
+ for (; i <= j; i++, min_char += chartab_chars[depth])
sub_char_table_set_range (XSUB_CHAR_TABLE (*table)->contents + i,
- depth,
- min_char + chartab_chars[depth] * i,
- from, to, val);
+ depth, min_char, from, to, val);
}
}
i++, min_char += chartab_chars[0])
sub_char_table_set_range (contents + i, 0, min_char, from, to, val);
if (ASCII_CHAR_P (from))
- tbl->ascii = char_table_ascii (tbl);
+ tbl->ascii = char_table_ascii (table);
}
return val;
}
{
int from, to;
- CHECK_CHARACTER (XCAR (range));
- CHECK_CHARACTER (XCDR (range));
+ CHECK_CHARACTER_CAR (range);
+ CHECK_CHARACTER_CDR (range);
val = char_table_ref_and_range (char_table, XINT (XCAR (range)),
&from, &to);
/* Not yet implemented. */
char_table_set (char_table, XINT (range), value);
else if (CONSP (range))
{
- CHECK_CHARACTER (XCAR (range));
- CHECK_CHARACTER (XCDR (range));
+ CHECK_CHARACTER_CAR (range);
+ CHECK_CHARACTER_CDR (range);
char_table_set_range (char_table,
XINT (XCAR (range)), XINT (XCDR (range)), 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 a generic character CHAR to VALUE.
-The generic character specifies the group of characters.
-See also the documentation of make-char. */)
+This function is obsolete and has no effect. */)
(char_table, ch, value)
Lisp_Object char_table, ch, 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.) */
+ integer. If the element is not a character, return CH itself. */
int
char_table_translate (table, ch)
{
Lisp_Object value;
value = Faref (table, make_number (ch));
- if (! INTEGERP (value))
+ if (! CHARACTERP (value))
return ch;
return XINT (value);
}
\f
static Lisp_Object
-map_sub_char_table (c_function, function, table, arg, val, range)
+map_sub_char_table (c_function, function, table, arg, val, range,
+ default_val, parent)
void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
- Lisp_Object function, table, arg, val, range;
+ Lisp_Object function, table, arg, val, range, default_val, parent;
{
struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
int depth = XINT (tbl->depth);
this = tbl->contents[i];
if (SUB_CHAR_TABLE_P (this))
- val = map_sub_char_table (c_function, function, this, arg, val, range);
- else if (NILP (Fequal (val, this)))
+ val = map_sub_char_table (c_function, function, this, arg, val, range,
+ default_val, parent);
+ else
{
- if (! NILP (val))
+ if (NILP (this))
+ this = default_val;
+ if (NILP (this) && ! NILP (parent))
+ this = CHAR_TABLE_REF (parent, c);
+ if (NILP (Fequal (val, this)))
{
- XCDR (range) = make_number (c - 1);
- if (depth == 3
- && EQ (XCAR (range), XCDR (range)))
+ if (! NILP (val))
{
- if (c_function)
- (*c_function) (arg, XCAR (range), val);
+ XSETCDR (range, make_number (c - 1));
+ if (depth == 3
+ && EQ (XCAR (range), XCDR (range)))
+ {
+ if (c_function)
+ (*c_function) (arg, XCAR (range), val);
+ else
+ call2 (function, XCAR (range), val);
+ }
else
- call2 (function, XCAR (range), val);
- }
- else
- {
- if (c_function)
- (*c_function) (arg, range, val);
- else
- call2 (function, range, val);
+ {
+ if (c_function)
+ (*c_function) (arg, range, val);
+ else
+ call2 (function, range, val);
+ }
}
+ val = this;
+ XSETCAR (range, make_number (c));
}
- val = this;
- XCAR (range) = make_number (c);
}
}
return val;
/* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
character or group of characters that share a value.
- ARG is passed to C_FUNCTION when that is called.
-
- DEPTH and INDICES are ignored. They are removed in the new
- feature. */
+ ARG is passed to C_FUNCTION when that is called. */
void
-map_char_table (c_function, function, table, arg, depth, indices)
+map_char_table (c_function, function, table, arg)
void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
- Lisp_Object function, table, arg, *indices;
- int depth;
+ Lisp_Object function, table, arg;
{
Lisp_Object range, val;
int c, i;
+ struct gcpro gcpro1;
range = Fcons (make_number (0), Qnil);
- val = char_table_ref (table, 0);
+ GCPRO1 (range);
+ val = XCHAR_TABLE (table)->ascii;
+ if (SUB_CHAR_TABLE_P (val))
+ val = XSUB_CHAR_TABLE (val)->contents[0];
for (i = 0, c = 0; i < chartab_size[0]; i++, c += chartab_chars[0])
{
this = XCHAR_TABLE (table)->contents[i];
if (SUB_CHAR_TABLE_P (this))
- val = map_sub_char_table (c_function, function, this, arg, val, range);
- else if (NILP (Fequal (val, this)))
+ val = map_sub_char_table (c_function, function, this, arg, val, range,
+ XCHAR_TABLE (table)->defalt,
+ XCHAR_TABLE (table)->parent);
+ else
{
- if (! NILP (val))
+ if (NILP (this))
+ this = XCHAR_TABLE (table)->defalt;
+ if (NILP (this) && ! NILP (XCHAR_TABLE (table)->parent))
+ this = CHAR_TABLE_REF (XCHAR_TABLE (table)->parent, c);
+ if (NILP (Fequal (val, this)))
{
- XCDR (range) = make_number (c - 1);
- if (c_function)
- (*c_function) (arg, range, val);
- else
- call2 (function, range, val);
+ if (! NILP (val))
+ {
+ XSETCDR (range, make_number (c - 1));
+ if (c_function)
+ (*c_function) (arg, range, val);
+ else
+ call2 (function, range, val);
+ }
+ val = this;
+ XSETCAR (range, make_number (c));
}
- val = this;
- XCAR (range) = make_number (c);
}
}
+
+ if (! NILP (val))
+ {
+ XSETCDR (range, make_number (c - 1));
+ if (c_function)
+ (*c_function) (arg, range, val);
+ else
+ call2 (function, range, val);
+ }
+
+ UNGCPRO;
}
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.
+Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
FUNCTION is called with two arguments--a key and a value.
-The key is always a possible IDX argument to `aref'. */)
+The key is a character code or a cons of character codes specifying a
+range of characters that have the same value. */)
(function, char_table)
Lisp_Object function, char_table;
{
CHECK_CHAR_TABLE (char_table);
- map_char_table (NULL, function, char_table, char_table, 0, NULL);
+ map_char_table (NULL, function, char_table, char_table);
return Qnil;
}
-\f
-#if 0
-Lisp_Object
-make_class_table (purpose)
- Lisp_Object purpose;
+
+static void
+map_sub_char_table_for_charset (c_function, function, table, arg, range,
+ charset, from, to)
+ void (*c_function) P_ ((Lisp_Object, Lisp_Object));
+ Lisp_Object function, table, arg, range;
+ struct charset *charset;
+ unsigned from, to;
{
- Lisp_Object table;
- Lisp_Object args[4];
-
- args[0] = purpose;
- args[1] = Qnil;
- args[2] = QCextra_slots;
- args[3] = Fmake_vector (make_number (2), Qnil);
- ASET (args[3], 0, Fmakehash (Qequal));
- table = Fmake_char_table (4, args);
- return table;
+ struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
+ int depth = XINT (tbl->depth);
+ int c, i;
+
+ if (depth < 3)
+ for (i = 0, c = XINT (tbl->min_char); i < chartab_size[depth];
+ i++, c += chartab_chars[depth])
+ {
+ Lisp_Object this;
+
+ this = tbl->contents[i];
+ if (SUB_CHAR_TABLE_P (this))
+ map_sub_char_table_for_charset (c_function, function, this, arg,
+ range, charset, from, to);
+ else
+ {
+ if (! NILP (XCAR (range)))
+ {
+ XSETCDR (range, make_number (c - 1));
+ if (c_function)
+ (*c_function) (arg, range);
+ else
+ call2 (function, range, arg);
+ }
+ XSETCAR (range, Qnil);
+ }
+ }
+ else
+ for (i = 0, c = XINT (tbl->min_char); i < chartab_size[depth]; i++, c ++)
+ {
+ Lisp_Object this;
+ unsigned code;
+
+ this = tbl->contents[i];
+ if (NILP (this)
+ || (charset
+ && (code = ENCODE_CHAR (charset, c),
+ (code < from || code > to))))
+ {
+ if (! NILP (XCAR (range)))
+ {
+ XSETCDR (range, make_number (c - 1));
+ if (c_function)
+ (*c_function) (arg, range);
+ else
+ call2 (function, range, arg);
+ XSETCAR (range, Qnil);
+ }
+ }
+ else
+ {
+ if (NILP (XCAR (range)))
+ XSETCAR (range, make_number (c));
+ }
+ }
}
-Lisp_Object
-modify_class_entry (c, val, table, set)
- int c;
- Lisp_Object val, table, set;
+
+void
+map_char_table_for_charset (c_function, function, table, arg,
+ charset, from, to)
+ void (*c_function) P_ ((Lisp_Object, Lisp_Object));
+ Lisp_Object function, table, arg;
+ struct charset *charset;
+ unsigned from, to;
{
- Lisp_Object classes, hash, canon;
- int i, ival;
+ Lisp_Object range;
+ int c, i;
+ struct gcpro gcpro1;
- hash = XCHAR_TABLE (table)->extras[0];
- classes = CHAR_TABLE_REF (table, c);
+ range = Fcons (Qnil, Qnil);
+ GCPRO1 (range);
- if (! BOOL_VECTOR_P (classes))
- classes = (NILP (set)
- ? Qnil
- : Fmake_bool_vector (make_number ((ival / 8) * 8 + 8), Qnil));
- else if (ival < XBOOL_VECTOR (classes)->size)
- {
- Lisp_Object old;
- old = classes;
- classes = Fmake_bool_vector (make_number ((ival / 8) * 8 + 8), Qnil);
- for (i = 0; i < XBOOL_VECTOR (classes)->size; i++)
- Faset (classes, make_number (i), Faref (old, make_number (i)));
- Faset (classes, val, set);
- }
- else if (NILP (Faref (classes, val)) != NILP (set))
+ for (i = 0, c = 0; i < chartab_size[0]; i++, c += chartab_chars[0])
{
- classes = Fcopy_sequence (classes);
- Faset (classes, val, set);
- }
- else
- classes = Qnil;
+ Lisp_Object this;
- if (!NILP (classes))
- {
- canon = Fgethash (classes, hash, Qnil);
- if (NILP (canon))
+ this = XCHAR_TABLE (table)->contents[i];
+ if (SUB_CHAR_TABLE_P (this))
+ map_sub_char_table_for_charset (c_function, function, this, arg,
+ range, charset, from, to);
+ else
{
- canon = classes;
- Fputhash (canon, canon, hash);
+ if (! NILP (XCAR (range)))
+ {
+ XSETCDR (range, make_number (c - 1));
+ if (c_function)
+ (*c_function) (arg, range);
+ else
+ call2 (function, range, arg);
+ }
+ XSETCAR (range, Qnil);
}
- char_table_set (table, c, canon);
+ }
+ if (! NILP (XCAR (range)))
+ {
+ XSETCDR (range, make_number (c - 1));
+ if (c_function)
+ (*c_function) (arg, range);
+ else
+ call2 (function, range, arg);
}
- return val;
+ UNGCPRO;
}
-#endif
\f
void
HCoop / bpt / emacs.git / blobdiff