casetab.c 8.76 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* GNU Emacs routines to deal with case tables.
2
   Copyright (C) 1993-1994, 2001-2012  Free Software Foundation, Inc.
Glenn Morris's avatar
Glenn Morris committed
3 4

Author: Howard Gayle
Jim Blandy's avatar
Jim Blandy committed
5 6 7

This file is part of GNU Emacs.

8
GNU Emacs is free software: you can redistribute it and/or modify
Jim Blandy's avatar
Jim Blandy committed
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.
Jim Blandy's avatar
Jim Blandy committed
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/>.  */
Jim Blandy's avatar
Jim Blandy committed
20

21
#include <config.h>
22
#include <setjmp.h>
Jim Blandy's avatar
Jim Blandy committed
23
#include "lisp.h"
24
#include "character.h"
25
#include "buffer.h"
Jim Blandy's avatar
Jim Blandy committed
26

27
static Lisp_Object Qcase_table_p, Qcase_table;
28 29 30 31
Lisp_Object Vascii_downcase_table;
static Lisp_Object Vascii_upcase_table;
Lisp_Object Vascii_canon_table;
static Lisp_Object Vascii_eqv_table;
Jim Blandy's avatar
Jim Blandy committed
32

33 34 35
static void set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt);
static void set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt);
static void shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt);
Jim Blandy's avatar
Jim Blandy committed
36 37

DEFUN ("case-table-p", Fcase_table_p, Scase_table_p, 1, 1, 0,
Glenn Morris's avatar
Glenn Morris committed
38
       doc: /* Return t if OBJECT is a case table.
39
See `set-case-table' for more information on these data structures.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
40
  (Lisp_Object object)
Jim Blandy's avatar
Jim Blandy committed
41
{
42
  Lisp_Object up, canon, eqv;
Jim Blandy's avatar
Jim Blandy committed
43

44
  if (! CHAR_TABLE_P (object))
45
    return Qnil;
46
  if (! EQ (XCHAR_TABLE (object)->purpose, Qcase_table))
47
    return Qnil;
Jim Blandy's avatar
Jim Blandy committed
48

49 50 51
  up = XCHAR_TABLE (object)->extras[0];
  canon = XCHAR_TABLE (object)->extras[1];
  eqv = XCHAR_TABLE (object)->extras[2];
52 53

  return ((NILP (up) || CHAR_TABLE_P (up))
Jim Blandy's avatar
Jim Blandy committed
54
	  && ((NILP (canon) && NILP (eqv))
55 56
 	      || (CHAR_TABLE_P (canon)
		  && (NILP (eqv) || CHAR_TABLE_P (eqv))))
Jim Blandy's avatar
Jim Blandy committed
57 58 59 60
	  ? Qt : Qnil);
}

static Lisp_Object
61
check_case_table (Lisp_Object obj)
Jim Blandy's avatar
Jim Blandy committed
62
{
63
  CHECK_TYPE (!NILP (Fcase_table_p (obj)), Qcase_table_p, obj);
Jim Blandy's avatar
Jim Blandy committed
64
  return (obj);
65
}
Jim Blandy's avatar
Jim Blandy committed
66 67

DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
68
       doc: /* Return the case table of the current buffer.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
69
  (void)
Jim Blandy's avatar
Jim Blandy committed
70
{
Tom Tromey's avatar
Tom Tromey committed
71
  return BVAR (current_buffer, downcase_table);
Jim Blandy's avatar
Jim Blandy committed
72 73
}

74
DEFUN ("standard-case-table", Fstandard_case_table, Sstandard_case_table, 0, 0, 0,
75 76
       doc: /* Return the standard case table.
This is the one used for new buffers.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
77
  (void)
Jim Blandy's avatar
Jim Blandy committed
78
{
79
  return Vascii_downcase_table;
Jim Blandy's avatar
Jim Blandy committed
80 81
}

82
static Lisp_Object set_case_table (Lisp_Object table, int standard);
83

Paul Eggert's avatar
Paul Eggert committed
84
DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
85 86 87 88 89
       doc: /* Select a new case table for the current buffer.
A case table is a char-table which maps characters
to their lower-case equivalents.  It also has three \"extra\" slots
which may be additional char-tables or nil.
These slots are called UPCASE, CANONICALIZE and EQUIVALENCES.
90 91 92
UPCASE maps each non-upper-case character to its upper-case equivalent.
 (The value in UPCASE for an upper-case character is never used.)
 If lower and upper case characters are in 1-1 correspondence,
93 94 95 96 97
 you may use nil and the upcase table will be deduced from DOWNCASE.
CANONICALIZE maps each character to a canonical equivalent;
 any two characters that are related by case-conversion have the same
 canonical equivalent character; it may be nil, in which case it is
 deduced from DOWNCASE and UPCASE.
Juanma Barranquero's avatar
Juanma Barranquero committed
98
EQUIVALENCES is a map that cyclically permutes each equivalence class
99 100
 (of characters with the same canonical equivalent); it may be nil,
 in which case it is deduced from CANONICALIZE.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
101
  (Lisp_Object table)
Jim Blandy's avatar
Jim Blandy committed
102
{
103
  return set_case_table (table, 0);
Jim Blandy's avatar
Jim Blandy committed
104 105
}

Paul Eggert's avatar
Paul Eggert committed
106
DEFUN ("set-standard-case-table", Fset_standard_case_table,
107
       Sset_standard_case_table, 1, 1, 0,
108 109
       doc: /* Select a new standard case table for new buffers.
See `set-case-table' for more info on case tables.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
110
  (Lisp_Object table)
Jim Blandy's avatar
Jim Blandy committed
111
{
112
  return set_case_table (table, 1);
Jim Blandy's avatar
Jim Blandy committed
113 114
}

115
static Lisp_Object
116
set_case_table (Lisp_Object table, int standard)
Jim Blandy's avatar
Jim Blandy committed
117
{
118
  Lisp_Object up, canon, eqv;
Jim Blandy's avatar
Jim Blandy committed
119 120 121

  check_case_table (table);

122 123 124
  up = XCHAR_TABLE (table)->extras[0];
  canon = XCHAR_TABLE (table)->extras[1];
  eqv = XCHAR_TABLE (table)->extras[2];
Jim Blandy's avatar
Jim Blandy committed
125

Jim Blandy's avatar
Jim Blandy committed
126
  if (NILP (up))
Jim Blandy's avatar
Jim Blandy committed
127
    {
128
      up = Fmake_char_table (Qcase_table, Qnil);
Kenichi Handa's avatar
Kenichi Handa committed
129 130
      map_char_table (set_identity, Qnil, table, up);
      map_char_table (shuffle, Qnil, table, up);
131
      char_table_set_extras (table, 0, up);
Jim Blandy's avatar
Jim Blandy committed
132 133
    }

Jim Blandy's avatar
Jim Blandy committed
134
  if (NILP (canon))
Jim Blandy's avatar
Jim Blandy committed
135
    {
136
      canon = Fmake_char_table (Qcase_table, Qnil);
137
      char_table_set_extras (table, 1, canon);
Kenichi Handa's avatar
Kenichi Handa committed
138
      map_char_table (set_canon, Qnil, table, table);
139 140 141 142
    }

  if (NILP (eqv))
    {
143
      eqv = Fmake_char_table (Qcase_table, Qnil);
Kenichi Handa's avatar
Kenichi Handa committed
144 145
      map_char_table (set_identity, Qnil, canon, eqv);
      map_char_table (shuffle, Qnil, canon, eqv);
146
      char_table_set_extras (table, 2, eqv);
Jim Blandy's avatar
Jim Blandy committed
147 148
    }

149
  /* This is so set_image_of_range_1 in regex.c can find the EQV table.  */
150
  char_table_set_extras (canon, 2, eqv);
151

Jim Blandy's avatar
Jim Blandy committed
152
  if (standard)
153 154 155 156 157 158
    {
      Vascii_downcase_table = table;
      Vascii_upcase_table = up;
      Vascii_canon_table = canon;
      Vascii_eqv_table = eqv;
    }
Jim Blandy's avatar
Jim Blandy committed
159
  else
160
    {
161 162 163 164
      BSET (current_buffer, downcase_table, table);
      BSET (current_buffer, upcase_table, up);
      BSET (current_buffer, case_canon_table, canon);
      BSET (current_buffer, case_eqv_table, eqv);
165
    }
166

Jim Blandy's avatar
Jim Blandy committed
167 168 169
  return table;
}

170 171
/* The following functions are called in map_char_table.  */

Kenichi Handa's avatar
Kenichi Handa committed
172 173 174 175
/* Set CANON char-table element for characters in RANGE to a
   translated ELT by UP and DOWN char-tables.  This is done only when
   ELT is a character.  The char-tables CANON, UP, and DOWN are in
   CASE_TABLE.  */
176

Karl Heuer's avatar
Karl Heuer committed
177
static void
178
set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt)
Karl Heuer's avatar
Karl Heuer committed
179
{
180 181
  Lisp_Object up = XCHAR_TABLE (case_table)->extras[0];
  Lisp_Object canon = XCHAR_TABLE (case_table)->extras[1];
Karl Heuer's avatar
Karl Heuer committed
182

183
  if (NATNUMP (elt))
184
    Fset_char_table_range (canon, range, Faref (case_table, Faref (up, elt)));
Karl Heuer's avatar
Karl Heuer committed
185
}
Jim Blandy's avatar
Jim Blandy committed
186

Kenichi Handa's avatar
Kenichi Handa committed
187 188 189 190
/* Set elements of char-table TABLE for C to C itself.  C may be a
   cons specifying a character range.  In that case, set characters in
   that range to themselves.  This is done only when ELT is a
   character.  This is called in map_char_table.  */
191

192
static void
193
set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
Jim Blandy's avatar
Jim Blandy committed
194
{
195
  if (NATNUMP (elt))
196
    {
197
      int from, to;
Kenichi Handa's avatar
Kenichi Handa committed
198 199

      if (CONSP (c))
200
	{
Kenichi Handa's avatar
Kenichi Handa committed
201 202
	  from = XINT (XCAR (c));
	  to = XINT (XCDR (c));
203 204
	}
      else
Kenichi Handa's avatar
Kenichi Handa committed
205
	from = to = XINT (c);
206 207 208 209

      to++;
      lint_assume (to <= MAX_CHAR + 1);
      for (; from < to; from++)
210
	CHAR_TABLE_SET (table, from, make_number (from));
211
    }
Jim Blandy's avatar
Jim Blandy committed
212
}
Karl Heuer's avatar
Karl Heuer committed
213

214 215 216 217
/* Permute the elements of TABLE (which is initially an identity
   mapping) so that it has one cycle for each equivalence class
   induced by the translation table on which map_char_table is
   operated.  */
Karl Heuer's avatar
Karl Heuer committed
218 219

static void
220
shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
Karl Heuer's avatar
Karl Heuer committed
221
{
222
  if (NATNUMP (elt))
223
    {
224
      int from, to;
225

Kenichi Handa's avatar
Kenichi Handa committed
226
      if (CONSP (c))
227
	{
Kenichi Handa's avatar
Kenichi Handa committed
228 229
	  from = XINT (XCAR (c));
	  to = XINT (XCDR (c));
230 231
	}
      else
Kenichi Handa's avatar
Kenichi Handa committed
232
	from = to = XINT (c);
233

234 235 236
      to++;
      lint_assume (to <= MAX_CHAR + 1);
      for (; from < to; from++)
237 238 239 240 241
	{
	  Lisp_Object tem = Faref (table, elt);
	  Faset (table, elt, make_number (from));
	  Faset (table, make_number (from), tem);
	}
242
    }
Karl Heuer's avatar
Karl Heuer committed
243
}
Jim Blandy's avatar
Jim Blandy committed
244

Andreas Schwab's avatar
Andreas Schwab committed
245
void
246
init_casetab_once (void)
Jim Blandy's avatar
Jim Blandy committed
247 248
{
  register int i;
249
  Lisp_Object down, up;
250
  DEFSYM (Qcase_table, "case-table");
251 252 253 254

  /* Intern this now in case it isn't already done.
     Setting this variable twice is harmless.
     But don't staticpro it here--that is done in alloc.c.  */
Dan Nicolaescu's avatar
Dan Nicolaescu committed
255
  Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
Jim Blandy's avatar
Jim Blandy committed
256

257 258
  /* Now we are ready to set up this property, so we can
     create char tables.  */
259
  Fput (Qcase_table, Qchar_table_extra_slots, make_number (3));
260 261 262

  down = Fmake_char_table (Qcase_table, Qnil);
  Vascii_downcase_table = down;
263
  CSET (XCHAR_TABLE (down), purpose, Qcase_table);
Jim Blandy's avatar
Jim Blandy committed
264

265
  for (i = 0; i < 128; i++)
Kenichi Handa's avatar
Kenichi Handa committed
266 267 268 269
    {
      int c = (i >= 'A' && i <= 'Z') ? i + ('a' - 'A') : i;
      CHAR_TABLE_SET (down, i, make_number (c));
    }
270

271
  char_table_set_extras (down, 1, Fcopy_sequence (down));
Jim Blandy's avatar
Jim Blandy committed
272

273
  up = Fmake_char_table (Qcase_table, Qnil);
274
  char_table_set_extras (down, 0, up);
Jim Blandy's avatar
Jim Blandy committed
275

276
  for (i = 0; i < 128; i++)
Kenichi Handa's avatar
Kenichi Handa committed
277 278 279
    {
      int c = ((i >= 'A' && i <= 'Z') ? i + ('a' - 'A')
	       : ((i >= 'a' && i <= 'z') ? i + ('A' - 'a')
280
		  : i));
Kenichi Handa's avatar
Kenichi Handa committed
281 282
      CHAR_TABLE_SET (up, i, make_number (c));
    }
283

284
  char_table_set_extras (down, 2, Fcopy_sequence (up));
285 286 287

  /* Fill in what isn't filled in.  */
  set_case_table (down, 1);
Jim Blandy's avatar
Jim Blandy committed
288 289
}

Andreas Schwab's avatar
Andreas Schwab committed
290
void
291
syms_of_casetab (void)
Jim Blandy's avatar
Jim Blandy committed
292
{
293
  DEFSYM (Qcase_table_p, "case-table-p");
294

295
  staticpro (&Vascii_canon_table);
Jim Blandy's avatar
Jim Blandy committed
296
  staticpro (&Vascii_downcase_table);
297 298
  staticpro (&Vascii_eqv_table);
  staticpro (&Vascii_upcase_table);
Jim Blandy's avatar
Jim Blandy committed
299 300 301 302 303 304 305

  defsubr (&Scase_table_p);
  defsubr (&Scurrent_case_table);
  defsubr (&Sstandard_case_table);
  defsubr (&Sset_case_table);
  defsubr (&Sset_standard_case_table);
}