chartab.c 39.6 KB
Newer Older
1
/* chartab.c -- char-table support
2
   Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
3 4 5 6 7
     National Institute of Advanced Industrial Science and Technology (AIST)
     Registration Number H13PRO009

This file is part of GNU Emacs.

8
GNU Emacs is free software: you can redistribute it and/or modify
9
it under the terms of the GNU General Public License as published by
10 11
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.
12 13 14 15 16 17 18

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
19
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
20 21

#include <config.h>
22

23 24 25
#include "lisp.h"
#include "character.h"
#include "charset.h"
26 27 28 29 30 31 32 33 34 35 36 37

/* 64/16/32/128 */

/* Number of elements in Nth level char-table.  */
const int chartab_size[4] =
  { (1 << CHARTAB_SIZE_BITS_0),
    (1 << CHARTAB_SIZE_BITS_1),
    (1 << CHARTAB_SIZE_BITS_2),
    (1 << CHARTAB_SIZE_BITS_3) };

/* Number of characters each element of Nth level char-table
   covers.  */
38
static const int chartab_chars[4] =
39 40 41 42 43 44 45
  { (1 << (CHARTAB_SIZE_BITS_1 + CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3)),
    (1 << (CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3)),
    (1 << CHARTAB_SIZE_BITS_3),
    1 };

/* Number of characters (in bits) each element of Nth level char-table
   covers.  */
46
static const int chartab_bits[4] =
47 48 49 50 51 52 53 54
  { (CHARTAB_SIZE_BITS_1 + CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3),
    (CHARTAB_SIZE_BITS_2 + CHARTAB_SIZE_BITS_3),
    CHARTAB_SIZE_BITS_3,
    0 };

#define CHARTAB_IDX(c, depth, min_char)		\
  (((c) - (min_char)) >> chartab_bits[(depth)])

55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73

/* Preamble for uniprop (Unicode character property) tables.  See the
   comment of "Unicode character property tables".  */

/* Types of decoder and encoder functions for uniprop values.  */
typedef Lisp_Object (*uniprop_decoder_t) (Lisp_Object, Lisp_Object);
typedef Lisp_Object (*uniprop_encoder_t) (Lisp_Object, Lisp_Object);

static Lisp_Object uniprop_table_uncompress (Lisp_Object, int);
static uniprop_decoder_t uniprop_get_decoder (Lisp_Object);

/* 1 iff TABLE is a uniprop table.  */
#define UNIPROP_TABLE_P(TABLE)					\
  (EQ (XCHAR_TABLE (TABLE)->purpose, Qchar_code_property_table)	\
   && CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (TABLE)) == 5)

/* Return a decoder for values in the uniprop table TABLE.  */
#define UNIPROP_GET_DECODER(TABLE)	\
  (UNIPROP_TABLE_P (TABLE) ? uniprop_get_decoder (TABLE) : NULL)
74

75 76 77 78 79 80 81 82
/* Nonzero iff OBJ is a string representing uniprop values of 128
   succeeding characters (the bottom level of a char-table) by a
   compressed format.  We are sure that no property value has a string
   starting with '\001' nor '\002'.  */
#define UNIPROP_COMPRESSED_FORM_P(OBJ)	\
  (STRINGP (OBJ) && SCHARS (OBJ) > 0	\
   && ((SREF (OBJ, 0) == 1 || (SREF (OBJ, 0) == 2))))

83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
static void
CHECK_CHAR_TABLE (Lisp_Object x)
{
  CHECK_TYPE (CHAR_TABLE_P (x), Qchar_table_p, x);
}

static void
set_char_table_ascii (Lisp_Object table, Lisp_Object val)
{
  XCHAR_TABLE (table)->ascii = val;
}
static void
set_char_table_parent (Lisp_Object table, Lisp_Object val)
{
  XCHAR_TABLE (table)->parent = val;
}
99

Paul Eggert's avatar
Paul Eggert committed
100
DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
101
       doc: /* Return a newly created char-table, with purpose PURPOSE.
102 103
Each element is initialized to INIT, which defaults to nil.

104 105 106 107
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.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
108
  (register Lisp_Object purpose, Lisp_Object init)
109 110 111
{
  Lisp_Object vector;
  Lisp_Object n;
112
  int n_extras;
113 114 115
  int size;

  CHECK_SYMBOL (purpose);
116 117 118 119
  n = Fget (purpose, Qchar_table_extra_slots);
  if (NILP (n))
    n_extras = 0;
  else
120
    {
121
      CHECK_NATNUM (n);
122
      if (XINT (n) > 10)
123
	args_out_of_range (n, Qnil);
124
      n_extras = XINT (n);
125 126
    }

127
  size = CHAR_TABLE_STANDARD_SLOTS + n_extras;
128
  vector = Fmake_vector (make_number (size), init);
Miles Bader's avatar
Miles Bader committed
129
  XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
Paul Eggert's avatar
Paul Eggert committed
130 131
  set_char_table_parent (vector, Qnil);
  set_char_table_purpose (vector, purpose);
132 133 134 135 136
  XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
  return vector;
}

static Lisp_Object
137
make_sub_char_table (int depth, int min_char, Lisp_Object defalt)
138
{
139 140
  int i;
  Lisp_Object table = make_uninit_sub_char_table (depth, min_char);
141

142 143
  for (i = 0; i < chartab_size[depth]; i++)
    XSUB_CHAR_TABLE (table)->contents[i] = defalt;
144 145 146 147
  return table;
}

static Lisp_Object
148
char_table_ascii (Lisp_Object table)
149
{
150
  Lisp_Object sub, val;
151 152

  sub = XCHAR_TABLE (table)->contents[0];
153 154
  if (! SUB_CHAR_TABLE_P (sub))
    return sub;
155
  sub = XSUB_CHAR_TABLE (sub)->contents[0];
156 157
  if (! SUB_CHAR_TABLE_P (sub))
    return sub;
158 159 160 161
  val = XSUB_CHAR_TABLE (sub)->contents[0];
  if (UNIPROP_TABLE_P (table) && UNIPROP_COMPRESSED_FORM_P (val))
    val = uniprop_table_uncompress (sub, 0);
  return val;
162 163
}

164
static Lisp_Object
165
copy_sub_char_table (Lisp_Object table)
166
{
167 168
  int depth = XSUB_CHAR_TABLE (table)->depth;
  int min_char = XSUB_CHAR_TABLE (table)->min_char;
169
  Lisp_Object copy = make_sub_char_table (depth, min_char, Qnil);
170 171 172 173 174
  int i;

  /* Recursively copy any sub char-tables.  */
  for (i = 0; i < chartab_size[depth]; i++)
    {
175 176 177
      Lisp_Object val = XSUB_CHAR_TABLE (table)->contents[i];
      set_sub_char_table_contents
	(copy, i, SUB_CHAR_TABLE_P (val) ? copy_sub_char_table (val) : val);
178 179 180 181 182 183 184
    }

  return copy;
}


Lisp_Object
185
copy_char_table (Lisp_Object table)
186 187
{
  Lisp_Object copy;
188
  int size = XCHAR_TABLE (table)->header.size & PSEUDOVECTOR_SIZE_MASK;
189 190 191
  int i;

  copy = Fmake_vector (make_number (size), Qnil);
Miles Bader's avatar
Miles Bader committed
192
  XSETPVECTYPE (XVECTOR (copy), PVEC_CHAR_TABLE);
Paul Eggert's avatar
Paul Eggert committed
193 194 195
  set_char_table_defalt (copy, XCHAR_TABLE (table)->defalt);
  set_char_table_parent (copy, XCHAR_TABLE (table)->parent);
  set_char_table_purpose (copy, XCHAR_TABLE (table)->purpose);
196
  for (i = 0; i < chartab_size[0]; i++)
197
    set_char_table_contents
Paul Eggert's avatar
Paul Eggert committed
198
      (copy, i,
199 200 201
       (SUB_CHAR_TABLE_P (XCHAR_TABLE (table)->contents[i])
	? copy_sub_char_table (XCHAR_TABLE (table)->contents[i])
	: XCHAR_TABLE (table)->contents[i]));
Paul Eggert's avatar
Paul Eggert committed
202
  set_char_table_ascii (copy, char_table_ascii (copy));
203
  size -= CHAR_TABLE_STANDARD_SLOTS;
204
  for (i = 0; i < size; i++)
205
    set_char_table_extras (copy, i, XCHAR_TABLE (table)->extras[i]);
206 207 208 209 210

  XSETCHAR_TABLE (copy, XCHAR_TABLE (copy));
  return copy;
}

Andreas Schwab's avatar
Andreas Schwab committed
211
static Lisp_Object
212
sub_char_table_ref (Lisp_Object table, int c, bool is_uniprop)
213 214 215
{
  struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
  Lisp_Object val;
216
  int idx = CHARTAB_IDX (c, tbl->depth, tbl->min_char);
217

218 219 220
  val = tbl->contents[idx];
  if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val))
    val = uniprop_table_uncompress (table, idx);
221
  if (SUB_CHAR_TABLE_P (val))
222
    val = sub_char_table_ref (val, c, is_uniprop);
223 224 225 226
  return val;
}

Lisp_Object
227
char_table_ref (Lisp_Object table, int c)
228 229 230 231 232 233 234 235 236 237 238 239 240 241
{
  struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
  Lisp_Object val;

  if (ASCII_CHAR_P (c))
    {
      val = tbl->ascii;
      if (SUB_CHAR_TABLE_P (val))
	val = XSUB_CHAR_TABLE (val)->contents[c];
    }
  else
    {
      val = tbl->contents[CHARTAB_IDX (c, 0, 0)];
      if (SUB_CHAR_TABLE_P (val))
242
	val = sub_char_table_ref (val, c, UNIPROP_TABLE_P (table));
243 244 245 246 247 248 249 250
    }
  if (NILP (val))
    {
      val = tbl->defalt;
      if (NILP (val) && CHAR_TABLE_P (tbl->parent))
	val = char_table_ref (tbl->parent, c);
    }
  return val;
Kenichi Handa's avatar
Kenichi Handa committed
251
}
252 253

static Lisp_Object
254
sub_char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to,
255
			      Lisp_Object defalt, bool is_uniprop)
256 257
{
  struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
258
  int depth = tbl->depth, min_char = tbl->min_char;
259
  int chartab_idx = CHARTAB_IDX (c, depth, min_char), idx;
260
  Lisp_Object val;
Kenichi Handa's avatar
Kenichi Handa committed
261

262
  val = tbl->contents[chartab_idx];
263 264
  if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val))
    val = uniprop_table_uncompress (table, chartab_idx);
265
  if (SUB_CHAR_TABLE_P (val))
266
    val = sub_char_table_ref_and_range (val, c, from, to, defalt, is_uniprop);
267 268 269
  else if (NILP (val))
    val = defalt;

270
  idx = chartab_idx;
271
  while (idx > 0 && *from < min_char + idx * chartab_chars[depth])
272
    {
273 274
      Lisp_Object this_val;

275 276 277
      c = min_char + idx * chartab_chars[depth] - 1;
      idx--;
      this_val = tbl->contents[idx];
278 279
      if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val))
	this_val = uniprop_table_uncompress (table, idx);
280
      if (SUB_CHAR_TABLE_P (this_val))
281 282
	this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt,
						 is_uniprop);
283 284 285 286
      else if (NILP (this_val))
	this_val = defalt;

      if (! EQ (this_val, val))
287 288 289 290
	{
	  *from = c + 1;
	  break;
	}
291
    }
292 293 294
  while (((c = (chartab_idx + 1) * chartab_chars[depth])
	  < chartab_chars[depth - 1])
	 && (c += min_char) <= *to)
295
    {
296 297
      Lisp_Object this_val;

298 299
      chartab_idx++;
      this_val = tbl->contents[chartab_idx];
300 301
      if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val))
	this_val = uniprop_table_uncompress (table, chartab_idx);
302
      if (SUB_CHAR_TABLE_P (this_val))
303 304
	this_val = sub_char_table_ref_and_range (this_val, c, from, to, defalt,
						 is_uniprop);
305 306 307
      else if (NILP (this_val))
	this_val = defalt;
      if (! EQ (this_val, val))
308 309 310 311
	{
	  *to = c - 1;
	  break;
	}
312
    }
313

314 315 316 317
  return val;
}


318 319 320 321
/* Return the value for C in char-table TABLE.  Shrink the range *FROM
   and *TO to cover characters (containing C) that have the same value
   as C.  It is not assured that the values of (*FROM - 1) and (*TO +
   1) are different from that of C.  */
322

323
Lisp_Object
324
char_table_ref_and_range (Lisp_Object table, int c, int *from, int *to)
325 326
{
  struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);
327
  int chartab_idx = CHARTAB_IDX (c, 0, 0), idx;
328
  Lisp_Object val;
329
  bool is_uniprop = UNIPROP_TABLE_P (table);
330

331
  val = tbl->contents[chartab_idx];
332 333 334 335
  if (*from < 0)
    *from = 0;
  if (*to < 0)
    *to = MAX_CHAR;
336 337
  if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (val))
    val = uniprop_table_uncompress (table, chartab_idx);
338
  if (SUB_CHAR_TABLE_P (val))
339 340
    val = sub_char_table_ref_and_range (val, c, from, to, tbl->defalt,
					is_uniprop);
341 342
  else if (NILP (val))
    val = tbl->defalt;
343
  idx = chartab_idx;
344
  while (*from < idx * chartab_chars[0])
345
    {
346 347
      Lisp_Object this_val;

348 349 350
      c = idx * chartab_chars[0] - 1;
      idx--;
      this_val = tbl->contents[idx];
351 352
      if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val))
	this_val = uniprop_table_uncompress (table, idx);
353
      if (SUB_CHAR_TABLE_P (this_val))
354
	this_val = sub_char_table_ref_and_range (this_val, c, from, to,
355
						 tbl->defalt, is_uniprop);
356 357 358 359
      else if (NILP (this_val))
	this_val = tbl->defalt;

      if (! EQ (this_val, val))
360 361 362 363
	{
	  *from = c + 1;
	  break;
	}
364
    }
365
  while (*to >= (chartab_idx + 1) * chartab_chars[0])
366
    {
367 368
      Lisp_Object this_val;

369 370 371
      chartab_idx++;
      c = chartab_idx * chartab_chars[0];
      this_val = tbl->contents[chartab_idx];
372 373
      if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this_val))
	this_val = uniprop_table_uncompress (table, chartab_idx);
374
      if (SUB_CHAR_TABLE_P (this_val))
375
	this_val = sub_char_table_ref_and_range (this_val, c, from, to,
376
						 tbl->defalt, is_uniprop);
377 378 379
      else if (NILP (this_val))
	this_val = tbl->defalt;
      if (! EQ (this_val, val))
380 381 382 383
	{
	  *to = c - 1;
	  break;
	}
384 385 386
    }

  return val;
387
}
388 389 390


static void
391
sub_char_table_set (Lisp_Object table, int c, Lisp_Object val, bool is_uniprop)
392 393
{
  struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
394
  int depth = tbl->depth, min_char = tbl->min_char;
395 396
  int i = CHARTAB_IDX (c, depth, min_char);
  Lisp_Object sub;
Kenichi Handa's avatar
Kenichi Handa committed
397

398
  if (depth == 3)
399
    set_sub_char_table_contents (table, i, val);
400 401 402 403 404
  else
    {
      sub = tbl->contents[i];
      if (! SUB_CHAR_TABLE_P (sub))
	{
405 406 407 408 409 410 411
	  if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (sub))
	    sub = uniprop_table_uncompress (table, i);
	  else
	    {
	      sub = make_sub_char_table (depth + 1,
					 min_char + i * chartab_chars[depth],
					 sub);
412
	      set_sub_char_table_contents (table, i, sub);
413
	    }
414
	}
415
      sub_char_table_set (sub, c, val, is_uniprop);
416 417 418
    }
}

419
void
420
char_table_set (Lisp_Object table, int c, Lisp_Object val)
421 422 423 424 425
{
  struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);

  if (ASCII_CHAR_P (c)
      && SUB_CHAR_TABLE_P (tbl->ascii))
426
    set_sub_char_table_contents (tbl->ascii, c, val);
427 428 429 430 431 432 433 434 435
  else
    {
      int i = CHARTAB_IDX (c, 0, 0);
      Lisp_Object sub;

      sub = tbl->contents[i];
      if (! SUB_CHAR_TABLE_P (sub))
	{
	  sub = make_sub_char_table (1, i * chartab_chars[0], sub);
436
	  set_char_table_contents (table, i, sub);
437
	}
438
      sub_char_table_set (sub, c, val, UNIPROP_TABLE_P (table));
439
      if (ASCII_CHAR_P (c))
Paul Eggert's avatar
Paul Eggert committed
440
	set_char_table_ascii (table, char_table_ascii (table));
441 442 443 444
    }
}

static void
445
sub_char_table_set_range (Lisp_Object table, int from, int to, Lisp_Object val,
446
			  bool is_uniprop)
447
{
448
  struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
449
  int depth = tbl->depth, min_char = tbl->min_char;
450 451 452 453 454 455 456
  int chars_in_block = chartab_chars[depth];
  int i, c, lim = chartab_size[depth];

  if (from < min_char)
    from = min_char;
  i = CHARTAB_IDX (from, depth, min_char);
  c = min_char + chars_in_block * i;
457
  for (; i < lim; i++, c += chars_in_block)
458
    {
459 460 461
      if (c > to)
	break;
      if (from <= c && c + chars_in_block - 1 <= to)
462
	set_sub_char_table_contents (table, i, val);
463 464 465 466 467 468 469 470 471 472
      else
	{
	  Lisp_Object sub = tbl->contents[i];
	  if (! SUB_CHAR_TABLE_P (sub))
	    {
	      if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (sub))
		sub = uniprop_table_uncompress (table, i);
	      else
		{
		  sub = make_sub_char_table (depth + 1, c, sub);
473
		  set_sub_char_table_contents (table, i, sub);
474 475 476 477
		}
	    }
	  sub_char_table_set_range (sub, from, to, val, is_uniprop);
	}
478 479 480 481
    }
}


482
void
483
char_table_set_range (Lisp_Object table, int from, int to, Lisp_Object val)
484 485 486 487 488 489 490
{
  struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);

  if (from == to)
    char_table_set (table, from, val);
  else
    {
491
      bool is_uniprop = UNIPROP_TABLE_P (table);
492 493 494 495 496 497 498 499 500
      int lim = CHARTAB_IDX (to, 0, 0);
      int i, c;

      for (i = CHARTAB_IDX (from, 0, 0), c = 0; i <= lim;
	   i++, c += chartab_chars[0])
	{
	  if (c > to)
	    break;
	  if (from <= c && c + chartab_chars[0] - 1 <= to)
501
	    set_char_table_contents (table, i, val);
502 503 504 505 506 507
	  else
	    {
	      Lisp_Object sub = tbl->contents[i];
	      if (! SUB_CHAR_TABLE_P (sub))
		{
		  sub = make_sub_char_table (1, i * chartab_chars[0], sub);
508
		  set_char_table_contents (table, i, sub);
509 510 511 512
		}
	      sub_char_table_set_range (sub, from, to, val, is_uniprop);
	    }
	}
513
      if (ASCII_CHAR_P (from))
Paul Eggert's avatar
Paul Eggert committed
514
	set_char_table_ascii (table, char_table_ascii (table));
515 516 517 518 519 520 521 522
    }
}


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.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
523
  (Lisp_Object char_table)
524 525 526 527 528 529 530 531 532 533 534 535
{
  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
536
\(or from its parents, if necessary).  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
537
  (Lisp_Object char_table)
538 539 540 541 542 543
{
  CHECK_CHAR_TABLE (char_table);

  return XCHAR_TABLE (char_table)->parent;
}

Paul Eggert's avatar
Paul Eggert committed
544
DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
545 546
       2, 2, 0,
       doc: /* Set the parent char-table of CHAR-TABLE to PARENT.
Kenichi Handa's avatar
Kenichi Handa committed
547
Return PARENT.  PARENT must be either nil or another char-table.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
548
  (Lisp_Object char_table, Lisp_Object parent)
549 550 551 552 553 554 555 556 557 558 559 560 561 562
{
  Lisp_Object temp;

  CHECK_CHAR_TABLE (char_table);

  if (!NILP (parent))
    {
      CHECK_CHAR_TABLE (parent);

      for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
	if (EQ (temp, char_table))
	  error ("Attempt to make a chartable be its own parent");
    }

Paul Eggert's avatar
Paul Eggert committed
563
  set_char_table_parent (char_table, parent);
564 565 566 567

  return parent;
}

Paul Eggert's avatar
Paul Eggert committed
568
DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
569 570
       2, 2, 0,
       doc: /* Return the value of CHAR-TABLE's extra-slot number N.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
571
  (Lisp_Object char_table, Lisp_Object n)
572 573 574 575 576 577 578 579 580 581
{
  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)];
}

Paul Eggert's avatar
Paul Eggert committed
582
DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
583 584 585
       Sset_char_table_extra_slot,
       3, 3, 0,
       doc: /* Set CHAR-TABLE's extra-slot number N to VALUE.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
586
  (Lisp_Object char_table, Lisp_Object n, Lisp_Object value)
587 588 589 590 591 592 593
{
  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);

594
  set_char_table_extras (char_table, XINT (n), value);
595
  return value;
596 597 598 599 600 601 602
}

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 cons of character codes (for characters in the range), or a character code.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
603
  (Lisp_Object char_table, Lisp_Object range)
604 605 606 607 608 609
{
  Lisp_Object val;
  CHECK_CHAR_TABLE (char_table);

  if (EQ (range, Qnil))
    val = XCHAR_TABLE (char_table)->defalt;
610 611
  else if (CHARACTERP (range))
    val = CHAR_TABLE_REF (char_table, XFASTINT (range));
612 613 614 615
  else if (CONSP (range))
    {
      int from, to;

Kenichi Handa's avatar
Kenichi Handa committed
616 617
      CHECK_CHARACTER_CAR (range);
      CHECK_CHARACTER_CDR (range);
618 619 620
      from = XFASTINT (XCAR (range));
      to = XFASTINT (XCDR (range));
      val = char_table_ref_and_range (char_table, from, &from, &to);
621 622 623 624 625 626 627
      /* Not yet implemented. */
    }
  else
    error ("Invalid RANGE argument to `char-table-range'");
  return val;
}

Paul Eggert's avatar
Paul Eggert committed
628
DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
629
       3, 3, 0,
Kenichi Handa's avatar
Kenichi Handa committed
630
       doc: /* Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.
631
RANGE should be t (for all characters), nil (for the default value),
Kenichi Handa's avatar
Kenichi Handa committed
632 633
a cons of character codes (for characters in the range),
or a character code.  Return VALUE.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
634
  (Lisp_Object char_table, Lisp_Object range, Lisp_Object value)
635 636 637 638 639 640
{
  CHECK_CHAR_TABLE (char_table);
  if (EQ (range, Qt))
    {
      int i;

Paul Eggert's avatar
Paul Eggert committed
641
      set_char_table_ascii (char_table, value);
642
      for (i = 0; i < chartab_size[0]; i++)
643
	set_char_table_contents (char_table, i, value);
644 645
    }
  else if (EQ (range, Qnil))
Paul Eggert's avatar
Paul Eggert committed
646
    set_char_table_defalt (char_table, value);
647
  else if (CHARACTERP (range))
648 649 650
    char_table_set (char_table, XINT (range), value);
  else if (CONSP (range))
    {
Kenichi Handa's avatar
Kenichi Handa committed
651 652
      CHECK_CHARACTER_CAR (range);
      CHECK_CHARACTER_CDR (range);
653 654 655 656 657 658 659 660 661 662
      char_table_set_range (char_table,
			    XINT (XCAR (range)), XINT (XCDR (range)), value);
    }
  else
    error ("Invalid RANGE argument to `set-char-table-range'");

  return value;
}

static Lisp_Object
663
optimize_sub_char_table (Lisp_Object table, Lisp_Object test)
664 665
{
  struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
666
  int i, depth = tbl->depth;
667
  Lisp_Object elt, this;
668
  bool optimizable;
669 670 671

  elt = XSUB_CHAR_TABLE (table)->contents[0];
  if (SUB_CHAR_TABLE_P (elt))
672 673
    {
      elt = optimize_sub_char_table (elt, test);
674
      set_sub_char_table_contents (table, 0, elt);
675
    }
676
  optimizable = SUB_CHAR_TABLE_P (elt) ? 0 : 1;
677 678 679 680
  for (i = 1; i < chartab_size[depth]; i++)
    {
      this = XSUB_CHAR_TABLE (table)->contents[i];
      if (SUB_CHAR_TABLE_P (this))
681 682
	{
	  this = optimize_sub_char_table (this, test);
683
	  set_sub_char_table_contents (table, i, this);
684
	}
685 686
      if (optimizable
	  && (NILP (test) ? NILP (Fequal (this, elt)) /* defaults to `equal'. */
687 688
	      : EQ (test, Qeq) ? !EQ (this, elt)      /* Optimize `eq' case.  */
	      : NILP (call2 (test, this, elt))))
689
	optimizable = 0;
690 691
    }

692
  return (optimizable ? elt : table);
693 694
}

Paul Eggert's avatar
Paul Eggert committed
695
DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
696 697 698 699
       1, 2, 0,
       doc: /* Optimize CHAR-TABLE.
TEST is the comparison function used to decide whether two entries are
equivalent and can be merged.  It defaults to `equal'.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
700
  (Lisp_Object char_table, Lisp_Object test)
701 702 703 704 705 706 707 708 709 710
{
  Lisp_Object elt;
  int i;

  CHECK_CHAR_TABLE (char_table);

  for (i = 0; i < chartab_size[0]; i++)
    {
      elt = XCHAR_TABLE (char_table)->contents[i];
      if (SUB_CHAR_TABLE_P (elt))
711
	set_char_table_contents
712
	  (char_table, i, optimize_sub_char_table (elt, test));
713
    }
714
  /* Reset the `ascii' cache, in case it got optimized away.  */
Paul Eggert's avatar
Paul Eggert committed
715
  set_char_table_ascii (char_table, char_table_ascii (char_table));
716

717 718 719 720
  return Qnil;
}


721 722 723
/* Map C_FUNCTION or FUNCTION over TABLE (top or sub char-table),
   calling it for each character or group of characters that share a
   value.  RANGE is a cons (FROM . TO) specifying the range of target
724
   characters, VAL is a value of FROM in TABLE, TOP is the top
725 726 727 728 729
   char-table.

   ARG is passed to C_FUNCTION when that is called.

   It returns the value of last character covered by TABLE (not the
Paul Eggert's avatar
Paul Eggert committed
730
   value inherited from the parent), and by side-effect, the car part
731 732 733
   of RANGE is updated to the minimum character C where C and all the
   following characters in TABLE have the same value.  */

734
static Lisp_Object
735 736
map_sub_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
		    Lisp_Object function, Lisp_Object table, Lisp_Object arg, Lisp_Object val,
737
		    Lisp_Object range, Lisp_Object top)
738
{
739 740
  /* Depth of TABLE.  */
  int depth;
Juanma Barranquero's avatar
Juanma Barranquero committed
741
  /* Minimum and maximum characters covered by TABLE. */
742 743 744 745
  int min_char, max_char;
  /* Number of characters covered by one element of TABLE.  */
  int chars_in_block;
  int from = XINT (XCAR (range)), to = XINT (XCDR (range));
746
  int i, c;
747
  bool is_uniprop = UNIPROP_TABLE_P (top);
748
  uniprop_decoder_t decoder = UNIPROP_GET_DECODER (top);
749

750 751 752 753
  if (SUB_CHAR_TABLE_P (table))
    {
      struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);

754 755
      depth = tbl->depth;
      min_char = tbl->min_char;
756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774
      max_char = min_char + chartab_chars[depth - 1] - 1;
    }
  else
    {
      depth = 0;
      min_char = 0;
      max_char = MAX_CHAR;
    }
  chars_in_block = chartab_chars[depth];

  if (to < max_char)
    max_char = to;
  /* Set I to the index of the first element to check.  */
  if (from <= min_char)
    i = 0;
  else
    i = (from - min_char) / chars_in_block;
  for (c = min_char + chars_in_block * i; c <= max_char;
       i++, c += chars_in_block)
775
    {
776 777 778
      Lisp_Object this = (SUB_CHAR_TABLE_P (table)
			  ? XSUB_CHAR_TABLE (table)->contents[i]
			  : XCHAR_TABLE (table)->contents[i]);
779
      int nextc = c + chars_in_block;
780

781 782
      if (is_uniprop && UNIPROP_COMPRESSED_FORM_P (this))
	this = uniprop_table_uncompress (table, i);
783
      if (SUB_CHAR_TABLE_P (this))
784 785 786 787
	{
	  if (to >= nextc)
	    XSETCDR (range, make_number (nextc - 1));
	  val = map_sub_char_table (c_function, function, this, arg,
788
				    val, range, top);
789
	}
790
      else
791
	{
792
	  if (NILP (this))
793
	    this = XCHAR_TABLE (top)->defalt;
794
	  if (!EQ (val, this))
795
	    {
796
	      bool different_value = 1;
797 798 799

	      if (NILP (val))
		{
800
		  if (! NILP (XCHAR_TABLE (top)->parent))
801
		    {
802
		      Lisp_Object parent = XCHAR_TABLE (top)->parent;
803 804 805 806
		      Lisp_Object temp = XCHAR_TABLE (parent)->parent;

		      /* This is to get a value of FROM in PARENT
			 without checking the parent of PARENT.  */
Paul Eggert's avatar
Paul Eggert committed
807
		      set_char_table_parent (parent, Qnil);
808
		      val = CHAR_TABLE_REF (parent, from);
Paul Eggert's avatar
Paul Eggert committed
809
		      set_char_table_parent (parent, temp);
810 811 812
		      XSETCDR (range, make_number (c - 1));
		      val = map_sub_char_table (c_function, function,
						parent, arg, val, range,
813
						parent);
814
		      if (EQ (val, this))
815 816 817 818
			different_value = 0;
		    }
		}
	      if (! NILP (val) && different_value)
819
		{
Kenichi Handa's avatar
Kenichi Handa committed
820
		  XSETCDR (range, make_number (c - 1));
821
		  if (EQ (XCAR (range), XCDR (range)))
822 823 824 825
		    {
		      if (c_function)
			(*c_function) (arg, XCAR (range), val);
		      else
826 827 828 829 830
			{
			  if (decoder)
			    val = decoder (top, val);
			  call2 (function, XCAR (range), val);
			}
831
		    }
832
		  else
833 834 835 836
		    {
		      if (c_function)
			(*c_function) (arg, range, val);
		      else
837 838 839 840 841
			{
			  if (decoder)
			    val = decoder (top, val);
			  call2 (function, range, val);
			}
842
		    }
843
		}
844
	      val = this;
845
	      from = c;
Kenichi Handa's avatar
Kenichi Handa committed
846
	      XSETCAR (range, make_number (c));
847 848
	    }
	}
849
      XSETCDR (range, make_number (to));
850 851 852 853 854 855 856 857
    }
  return val;
}


/* Map C_FUNCTION or FUNCTION over TABLE, calling it for each
   character or group of characters that share a value.

Kenichi Handa's avatar
Kenichi Handa committed
858
   ARG is passed to C_FUNCTION when that is called.  */
859 860

void
861 862
map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
		Lisp_Object function, Lisp_Object table, Lisp_Object arg)
863
{
864 865
  Lisp_Object range, val, parent;
  uniprop_decoder_t decoder = UNIPROP_GET_DECODER (table);
866

867
  range = Fcons (make_number (0), make_number (MAX_CHAR));
868 869
  parent = XCHAR_TABLE (table)->parent;

870 871 872
  val = XCHAR_TABLE (table)->ascii;
  if (SUB_CHAR_TABLE_P (val))
    val = XSUB_CHAR_TABLE (val)->contents[0];
873
  val = map_sub_char_table (c_function, function, table, arg, val, range,
874 875
			    table);

876 877 878
  /* If VAL is nil and TABLE has a parent, we must consult the parent
     recursively.  */
  while (NILP (val) && ! NILP (XCHAR_TABLE (table)->parent))
879
    {
880
      Lisp_Object temp;
881 882
      int from = XINT (XCAR (range));

883 884
      parent = XCHAR_TABLE (table)->parent;
      temp = XCHAR_TABLE (parent)->parent;
885 886
      /* This is to get a value of FROM in PARENT without checking the
	 parent of PARENT.  */
Paul Eggert's avatar
Paul Eggert committed
887
      set_char_table_parent (parent, Qnil);
888
      val = CHAR_TABLE_REF (parent, from);
Paul Eggert's avatar
Paul Eggert committed
889
      set_char_table_parent (parent, temp);
890
      val = map_sub_char_table (c_function, function, parent, arg, val, range,
891
				parent);
892
      table = parent;
893
    }
894 895 896

  if (! NILP (val))
    {
897 898 899 900 901
      if (EQ (XCAR (range), XCDR (range)))
	{
	  if (c_function)
	    (*c_function) (arg, XCAR (range), val);
	  else
902 903 904 905 906
	    {
	      if (decoder)
		val = decoder (table, val);
	      call2 (function, XCAR (range), val);
	    }
907
	}
908
      else
909 910 911 912
	{
	  if (c_function)
	    (*c_function) (arg, range, val);
	  else
913 914 915 916 917
	    {
	      if (decoder)
		val = decoder (table, val);
	      call2 (function, range, val);
	    }
918
	}
919
    }
920 921 922 923
}

DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
  2, 2, 0,
Chong Yidong's avatar
Chong Yidong committed
924 925 926 927 928
       doc: /* Call FUNCTION for each character in CHAR-TABLE that has non-nil value.
FUNCTION is called with two arguments, KEY and VALUE.
KEY is a character code or a cons of character codes specifying a
range of characters that have the same value.
VALUE is what (char-table-range CHAR-TABLE KEY) returns.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
929
  (Lisp_Object function, Lisp_Object char_table)
930 931 932
{
  CHECK_CHAR_TABLE (char_table);

Kenichi Handa's avatar
Kenichi Handa committed
933
  map_char_table (NULL, function, char_table, char_table);
934 935 936
  return Qnil;
}

937 938

static void
939 940 941 942
map_sub_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
				Lisp_Object function, Lisp_Object table, Lisp_Object arg,
				Lisp_Object range, struct charset *charset,
				unsigned from, unsigned to)
943 944
{
  struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
945
  int i, c = tbl->min_char, depth = tbl->depth;
946 947

  if (depth < 3)
948
    for (i = 0; i < chartab_size[depth]; i++, c += chartab_chars[depth])
949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969
      {
	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
970
    for (i = 0; i < chartab_size[depth]; i++, c++)
971 972 973 974 975 976 977 978 97