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 <https://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_FIXNAT (n);
Tom Tromey's avatar
Tom Tromey committed
122
      if (XFIXNUM (n) > 10)
123
	args_out_of_range (n, Qnil);
Tom Tromey's avatar
Tom Tromey committed
124
      n_extras = XFIXNUM (n);
125 126
    }

127
  size = CHAR_TABLE_STANDARD_SLOTS + n_extras;
128
  vector = make_vector (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
  int size = PVSIZE (table);
188
  Lisp_Object copy = make_nil_vector (size);
Miles Bader's avatar
Miles Bader committed
189
  XSETPVECTYPE (XVECTOR (copy), PVEC_CHAR_TABLE);
Paul Eggert's avatar
Paul Eggert committed
190 191 192
  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);
193
  for (int i = 0; i < chartab_size[0]; i++)
194
    set_char_table_contents
Paul Eggert's avatar
Paul Eggert committed
195
      (copy, i,
196 197 198
       (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
199
  set_char_table_ascii (copy, char_table_ascii (copy));
200
  size -= CHAR_TABLE_STANDARD_SLOTS;
201
  for (int i = 0; i < size; i++)
202
    set_char_table_extras (copy, i, XCHAR_TABLE (table)->extras[i]);
203 204 205 206 207

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

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

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

Lisp_Object
224
char_table_ref (Lisp_Object table, int c)
225 226 227 228 229 230 231 232 233 234 235 236 237 238
{
  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))
239
	val = sub_char_table_ref (val, c, UNIPROP_TABLE_P (table));
240 241 242 243 244 245 246 247
    }
  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
248
}
249 250

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

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

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

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

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

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

311 312 313 314
  return val;
}


315 316 317 318
/* 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.  */
319

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

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

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

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

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

  return val;
384
}
385 386 387


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

395
  if (depth == 3)
396
    set_sub_char_table_contents (table, i, val);
397 398 399 400 401
  else
    {
      sub = tbl->contents[i];
      if (! SUB_CHAR_TABLE_P (sub))
	{
402 403 404 405 406 407 408
	  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);
409
	      set_sub_char_table_contents (table, i, sub);
410
	    }
411
	}
412
      sub_char_table_set (sub, c, val, is_uniprop);
413 414 415
    }
}

416
void
417
char_table_set (Lisp_Object table, int c, Lisp_Object val)
418 419 420 421 422
{
  struct Lisp_Char_Table *tbl = XCHAR_TABLE (table);

  if (ASCII_CHAR_P (c)
      && SUB_CHAR_TABLE_P (tbl->ascii))
423
    set_sub_char_table_contents (tbl->ascii, c, val);
424 425 426 427 428 429 430 431 432
  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);
433
	  set_char_table_contents (table, i, sub);
434
	}
435
      sub_char_table_set (sub, c, val, UNIPROP_TABLE_P (table));
436
      if (ASCII_CHAR_P (c))
Paul Eggert's avatar
Paul Eggert committed
437
	set_char_table_ascii (table, char_table_ascii (table));
438 439 440 441
    }
}

static void
442
sub_char_table_set_range (Lisp_Object table, int from, int to, Lisp_Object val,
443
			  bool is_uniprop)
444
{
445
  struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);
446
  int depth = tbl->depth, min_char = tbl->min_char;
447 448 449 450 451 452 453
  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;
454
  for (; i < lim; i++, c += chars_in_block)
455
    {
456 457 458
      if (c > to)
	break;
      if (from <= c && c + chars_in_block - 1 <= to)
459
	set_sub_char_table_contents (table, i, val);
460 461 462 463 464 465 466 467 468 469
      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);
470
		  set_sub_char_table_contents (table, i, sub);
471 472 473 474
		}
	    }
	  sub_char_table_set_range (sub, from, to, val, is_uniprop);
	}
475 476 477 478
    }
}


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

  if (from == to)
    char_table_set (table, from, val);
  else
    {
488
      bool is_uniprop = UNIPROP_TABLE_P (table);
489 490 491
      int lim = CHARTAB_IDX (to, 0, 0);
      int i, c;

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

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

  return XCHAR_TABLE (char_table)->parent;
}

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

  return parent;
}

Paul Eggert's avatar
Paul Eggert committed
565
DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
566 567
       2, 2, 0,
       doc: /* Return the value of CHAR-TABLE's extra-slot number N.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
568
  (Lisp_Object char_table, Lisp_Object n)
569 570
{
  CHECK_CHAR_TABLE (char_table);
571
  CHECK_FIXNUM (n);
Tom Tromey's avatar
Tom Tromey committed
572 573
  if (XFIXNUM (n) < 0
      || XFIXNUM (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
574 575
    args_out_of_range (char_table, n);

Tom Tromey's avatar
Tom Tromey committed
576
  return XCHAR_TABLE (char_table)->extras[XFIXNUM (n)];
577 578
}

Paul Eggert's avatar
Paul Eggert committed
579
DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
580 581 582
       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
583
  (Lisp_Object char_table, Lisp_Object n, Lisp_Object value)
584 585
{
  CHECK_CHAR_TABLE (char_table);
586
  CHECK_FIXNUM (n);
Tom Tromey's avatar
Tom Tromey committed
587 588
  if (XFIXNUM (n) < 0
      || XFIXNUM (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
589 590
    args_out_of_range (char_table, n);

Tom Tromey's avatar
Tom Tromey committed
591
  set_char_table_extras (char_table, XFIXNUM (n), value);
592
  return value;
593 594 595 596 597 598 599
}

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
600
  (Lisp_Object char_table, Lisp_Object range)
601 602 603 604
{
  Lisp_Object val;
  CHECK_CHAR_TABLE (char_table);

Paul Eggert's avatar
Paul Eggert committed
605
  if (NILP (range))
606
    val = XCHAR_TABLE (char_table)->defalt;
607
  else if (CHARACTERP (range))
Tom Tromey's avatar
Tom Tromey committed
608
    val = CHAR_TABLE_REF (char_table, XFIXNAT (range));
609 610 611 612
  else if (CONSP (range))
    {
      int from, to;

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

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

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

  return value;
}

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

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

689
  return (optimizable ? elt : table);
690 691
}

Paul Eggert's avatar
Paul Eggert committed
692
DEFUN ("optimize-char-table", Foptimize_char_table, Soptimize_char_table,
693 694 695 696
       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
697
  (Lisp_Object char_table, Lisp_Object test)
698 699 700 701 702 703 704 705 706 707
{
  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))
708
	set_char_table_contents
709
	  (char_table, i, optimize_sub_char_table (elt, test));
710
    }
711
  /* Reset the `ascii' cache, in case it got optimized away.  */
Paul Eggert's avatar
Paul Eggert committed
712
  set_char_table_ascii (char_table, char_table_ascii (char_table));
713

714 715 716 717
  return Qnil;
}


718 719 720
/* 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
721
   characters, VAL is a value of FROM in TABLE, TOP is the top
722 723 724 725 726
   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
727
   value inherited from the parent), and by side-effect, the car part
728 729 730
   of RANGE is updated to the minimum character C where C and all the
   following characters in TABLE have the same value.  */

731
static Lisp_Object
732 733
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,
734
		    Lisp_Object range, Lisp_Object top)
735
{
736 737
  /* Depth of TABLE.  */
  int depth;
Juanma Barranquero's avatar
Juanma Barranquero committed
738
  /* Minimum and maximum characters covered by TABLE. */
739 740 741
  int min_char, max_char;
  /* Number of characters covered by one element of TABLE.  */
  int chars_in_block;
Tom Tromey's avatar
Tom Tromey committed
742
  int from = XFIXNUM (XCAR (range)), to = XFIXNUM (XCDR (range));
743
  int i, c;
744
  bool is_uniprop = UNIPROP_TABLE_P (top);
745
  uniprop_decoder_t decoder = UNIPROP_GET_DECODER (top);
746

747 748 749 750
  if (SUB_CHAR_TABLE_P (table))
    {
      struct Lisp_Sub_Char_Table *tbl = XSUB_CHAR_TABLE (table);

751 752
      depth = tbl->depth;
      min_char = tbl->min_char;
753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771
      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)
772
    {
773 774 775
      Lisp_Object this = (SUB_CHAR_TABLE_P (table)
			  ? XSUB_CHAR_TABLE (table)->contents[i]
			  : XCHAR_TABLE (table)->contents[i]);
776
      int nextc = c + chars_in_block;
777

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

	      if (NILP (val))
		{
797
		  if (! NILP (XCHAR_TABLE (top)->parent))
798
		    {
799
		      Lisp_Object parent = XCHAR_TABLE (top)->parent;
800 801 802 803
		      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
804
		      set_char_table_parent (parent, Qnil);
805
		      val = CHAR_TABLE_REF (parent, from);
Paul Eggert's avatar
Paul Eggert committed
806
		      set_char_table_parent (parent, temp);
807
		      XSETCDR (range, make_fixnum (c - 1));
808 809
		      val = map_sub_char_table (c_function, function,
						parent, arg, val, range,
810
						parent);
811
		      if (EQ (val, this))
812 813 814 815
			different_value = 0;
		    }
		}
	      if (! NILP (val) && different_value)
816
		{
817
		  XSETCDR (range, make_fixnum (c - 1));
818
		  if (EQ (XCAR (range), XCDR (range)))
819 820 821 822
		    {
		      if (c_function)
			(*c_function) (arg, XCAR (range), val);
		      else
823 824 825 826 827
			{
			  if (decoder)
			    val = decoder (top, val);
			  call2 (function, XCAR (range), val);
			}
828
		    }
829
		  else
830 831 832 833
		    {
		      if (c_function)
			(*c_function) (arg, range, val);
		      else
834 835 836 837 838
			{
			  if (decoder)
			    val = decoder (top, val);
			  call2 (function, range, val);
			}
839
		    }
840
		}
841
	      val = this;
842
	      from = c;
843
	      XSETCAR (range, make_fixnum (c));
844 845
	    }
	}
846
      XSETCDR (range, make_fixnum (to));
847 848 849 850 851 852 853 854
    }
  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
855
   ARG is passed to C_FUNCTION when that is called.  */
856 857

void
858 859
map_char_table (void (*c_function) (Lisp_Object, Lisp_Object, Lisp_Object),
		Lisp_Object function, Lisp_Object table, Lisp_Object arg)
860
{
861 862
  Lisp_Object range, val, parent;
  uniprop_decoder_t decoder = UNIPROP_GET_DECODER (table);
863

864
  range = Fcons (make_fixnum (0), make_fixnum (MAX_CHAR));
865 866
  parent = XCHAR_TABLE (table)->parent;

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

873 874 875
  /* If VAL is nil and TABLE has a parent, we must consult the parent
     recursively.  */
  while (NILP (val) && ! NILP (XCHAR_TABLE (table)->parent))
876
    {
877
      Lisp_Object temp;
Tom Tromey's avatar
Tom Tromey committed
878
      int from = XFIXNUM (XCAR (range));
879

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

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

DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
  2, 2, 0,
Chong Yidong's avatar
Chong Yidong committed
921 922 923 924 925
       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
926
  (Lisp_Object function, Lisp_Object char_table)
927 928 929
{
  CHECK_CHAR_TABLE (char_table);

Kenichi Handa's avatar
Kenichi Handa committed
930
  map_char_table (NULL, function, char_table, char_table);
931 932 93