Merge from trunk
[bpt/emacs.git] / src / casetab.c
CommitLineData
dcfdbac7 1/* GNU Emacs routines to deal with case tables.
8deda4af 2 Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
114f9c96 3 2008, 2009, 2010 Free Software Foundation, Inc.
8deda4af
GM
4
5Author: Howard Gayle
dcfdbac7
JB
6
7This file is part of GNU Emacs.
8
9ec0b715 9GNU Emacs is free software: you can redistribute it and/or modify
dcfdbac7 10it under the terms of the GNU General Public License as published by
9ec0b715
GM
11the Free Software Foundation, either version 3 of the License, or
12(at your option) any later version.
dcfdbac7
JB
13
14GNU Emacs is distributed in the hope that it will be useful,
15but WITHOUT ANY WARRANTY; without even the implied warranty of
16MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17GNU General Public License for more details.
18
19You should have received a copy of the GNU General Public License
9ec0b715 20along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
dcfdbac7 21
18160b98 22#include <config.h>
d7306fe6 23#include <setjmp.h>
dcfdbac7
JB
24#include "lisp.h"
25#include "buffer.h"
e961d439 26#include "character.h"
dcfdbac7 27
7f7fef04 28Lisp_Object Qcase_table_p, Qcase_table;
dcfdbac7
JB
29Lisp_Object Vascii_downcase_table, Vascii_upcase_table;
30Lisp_Object Vascii_canon_table, Vascii_eqv_table;
31
da2795b2
KH
32/* Used as a temporary in DOWNCASE and other macros in lisp.h. No
33 need to mark it, since it is used only very temporarily. */
2e34157c
RS
34int case_temp1;
35Lisp_Object case_temp2;
da2795b2 36
971de7fb
DN
37static void set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt);
38static void set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt);
39static void shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt);
dcfdbac7
JB
40
41DEFUN ("case-table-p", Fcase_table_p, Scase_table_p, 1, 1, 0,
e0f24100 42 doc: /* Return t if OBJECT is a case table.
fdb82f93 43See `set-case-table' for more information on these data structures. */)
5842a27b 44 (Lisp_Object object)
dcfdbac7 45{
4b3bd052 46 Lisp_Object up, canon, eqv;
dcfdbac7 47
2858a1c1 48 if (! CHAR_TABLE_P (object))
7f7fef04 49 return Qnil;
2858a1c1 50 if (! EQ (XCHAR_TABLE (object)->purpose, Qcase_table))
7f7fef04 51 return Qnil;
dcfdbac7 52
2858a1c1
EN
53 up = XCHAR_TABLE (object)->extras[0];
54 canon = XCHAR_TABLE (object)->extras[1];
55 eqv = XCHAR_TABLE (object)->extras[2];
7f7fef04
RS
56
57 return ((NILP (up) || CHAR_TABLE_P (up))
d427b66a 58 && ((NILP (canon) && NILP (eqv))
7f7fef04
RS
59 || (CHAR_TABLE_P (canon)
60 && (NILP (eqv) || CHAR_TABLE_P (eqv))))
dcfdbac7
JB
61 ? Qt : Qnil);
62}
63
64static Lisp_Object
971de7fb 65check_case_table (Lisp_Object obj)
dcfdbac7 66{
a5f07f6d 67 CHECK_TYPE (!NILP (Fcase_table_p (obj)), Qcase_table_p, obj);
dcfdbac7 68 return (obj);
177c0ea7 69}
dcfdbac7
JB
70
71DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
fdb82f93 72 doc: /* Return the case table of the current buffer. */)
5842a27b 73 (void)
dcfdbac7 74{
7f7fef04 75 return current_buffer->downcase_table;
dcfdbac7
JB
76}
77
a1de6b4b 78DEFUN ("standard-case-table", Fstandard_case_table, Sstandard_case_table, 0, 0, 0,
fdb82f93
PJ
79 doc: /* Return the standard case table.
80This is the one used for new buffers. */)
5842a27b 81 (void)
dcfdbac7 82{
7f7fef04 83 return Vascii_downcase_table;
dcfdbac7
JB
84}
85
971de7fb 86static Lisp_Object set_case_table (Lisp_Object table, int standard);
d9da9451 87
dcfdbac7 88DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
fdb82f93
PJ
89 doc: /* Select a new case table for the current buffer.
90A case table is a char-table which maps characters
91to their lower-case equivalents. It also has three \"extra\" slots
92which may be additional char-tables or nil.
93These slots are called UPCASE, CANONICALIZE and EQUIVALENCES.
f6a18aa2
RS
94UPCASE maps each non-upper-case character to its upper-case equivalent.
95 (The value in UPCASE for an upper-case character is never used.)
96 If lower and upper case characters are in 1-1 correspondence,
fdb82f93
PJ
97 you may use nil and the upcase table will be deduced from DOWNCASE.
98CANONICALIZE maps each character to a canonical equivalent;
99 any two characters that are related by case-conversion have the same
100 canonical equivalent character; it may be nil, in which case it is
101 deduced from DOWNCASE and UPCASE.
102EQUIVALENCES is a map that cyclicly permutes each equivalence class
103 (of characters with the same canonical equivalent); it may be nil,
104 in which case it is deduced from CANONICALIZE. */)
5842a27b 105 (Lisp_Object table)
dcfdbac7 106{
d9da9451 107 return set_case_table (table, 0);
dcfdbac7
JB
108}
109
a1de6b4b 110DEFUN ("set-standard-case-table", Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0,
fdb82f93
PJ
111 doc: /* Select a new standard case table for new buffers.
112See `set-case-table' for more info on case tables. */)
5842a27b 113 (Lisp_Object table)
dcfdbac7 114{
d9da9451 115 return set_case_table (table, 1);
dcfdbac7
JB
116}
117
d9da9451 118static Lisp_Object
971de7fb 119set_case_table (Lisp_Object table, int standard)
dcfdbac7 120{
4b3bd052 121 Lisp_Object up, canon, eqv;
dcfdbac7
JB
122
123 check_case_table (table);
124
7f7fef04
RS
125 up = XCHAR_TABLE (table)->extras[0];
126 canon = XCHAR_TABLE (table)->extras[1];
127 eqv = XCHAR_TABLE (table)->extras[2];
dcfdbac7 128
d427b66a 129 if (NILP (up))
dcfdbac7 130 {
7f7fef04 131 up = Fmake_char_table (Qcase_table, Qnil);
8f924df7
KH
132 map_char_table (set_identity, Qnil, table, up);
133 map_char_table (shuffle, Qnil, table, up);
7f7fef04 134 XCHAR_TABLE (table)->extras[0] = up;
dcfdbac7
JB
135 }
136
d427b66a 137 if (NILP (canon))
dcfdbac7 138 {
4b3bd052 139 canon = Fmake_char_table (Qcase_table, Qnil);
7f7fef04 140 XCHAR_TABLE (table)->extras[1] = canon;
8f924df7 141 map_char_table (set_canon, Qnil, table, table);
5a0fd72f
RS
142 }
143
144 if (NILP (eqv))
145 {
7f7fef04 146 eqv = Fmake_char_table (Qcase_table, Qnil);
8f924df7
KH
147 map_char_table (set_identity, Qnil, canon, eqv);
148 map_char_table (shuffle, Qnil, canon, eqv);
4b3bd052 149 XCHAR_TABLE (table)->extras[2] = eqv;
dcfdbac7
JB
150 }
151
426f6c23
RS
152 /* This is so set_image_of_range_1 in regex.c can find the EQV table. */
153 XCHAR_TABLE (canon)->extras[2] = eqv;
154
dcfdbac7 155 if (standard)
f79609dc
KH
156 {
157 Vascii_downcase_table = table;
158 Vascii_upcase_table = up;
159 Vascii_canon_table = canon;
160 Vascii_eqv_table = eqv;
161 }
dcfdbac7 162 else
6c6fcbf8
RS
163 {
164 current_buffer->downcase_table = table;
165 current_buffer->upcase_table = up;
166 current_buffer->case_canon_table = canon;
167 current_buffer->case_eqv_table = eqv;
168 }
7f7fef04 169
dcfdbac7
JB
170 return table;
171}
172\f
da2795b2
KH
173/* The following functions are called in map_char_table. */
174
8f924df7
KH
175/* Set CANON char-table element for characters in RANGE to a
176 translated ELT by UP and DOWN char-tables. This is done only when
177 ELT is a character. The char-tables CANON, UP, and DOWN are in
178 CASE_TABLE. */
e16696ba 179
c0c15b93 180static void
971de7fb 181set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt)
c0c15b93 182{
da2795b2
KH
183 Lisp_Object up = XCHAR_TABLE (case_table)->extras[0];
184 Lisp_Object canon = XCHAR_TABLE (case_table)->extras[1];
c0c15b93 185
da2795b2 186 if (NATNUMP (elt))
405b0b5a 187 Fset_char_table_range (canon, range, Faref (case_table, Faref (up, elt)));
c0c15b93 188}
dcfdbac7 189
8f924df7
KH
190/* Set elements of char-table TABLE for C to C itself. C may be a
191 cons specifying a character range. In that case, set characters in
192 that range to themselves. This is done only when ELT is a
193 character. This is called in map_char_table. */
e16696ba 194
7f7fef04 195static void
971de7fb 196set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
dcfdbac7 197{
da2795b2 198 if (NATNUMP (elt))
e961d439 199 {
8f924df7
KH
200 int from, to;
201
202 if (CONSP (c))
e961d439 203 {
8f924df7
KH
204 from = XINT (XCAR (c));
205 to = XINT (XCDR (c));
e961d439
KH
206 }
207 else
8f924df7 208 from = to = XINT (c);
e961d439 209 for (; from <= to; from++)
405b0b5a 210 CHAR_TABLE_SET (table, from, make_number (from));
e961d439 211 }
dcfdbac7 212}
c0c15b93 213
da2795b2
KH
214/* Permute the elements of TABLE (which is initially an identity
215 mapping) so that it has one cycle for each equivalence class
216 induced by the translation table on which map_char_table is
217 operated. */
c0c15b93
KH
218
219static void
971de7fb 220shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
c0c15b93 221{
e961d439 222 if (NATNUMP (elt))
da2795b2 223 {
8f924df7 224 int from, to;
e961d439 225
8f924df7 226 if (CONSP (c))
e961d439 227 {
8f924df7
KH
228 from = XINT (XCAR (c));
229 to = XINT (XCDR (c));
e961d439
KH
230 }
231 else
8f924df7 232 from = to = XINT (c);
e961d439
KH
233
234 for (; from <= to; from++)
fa055055
KH
235 {
236 Lisp_Object tem = Faref (table, elt);
237 Faset (table, elt, make_number (from));
238 Faset (table, make_number (from), tem);
239 }
da2795b2 240 }
c0c15b93 241}
dcfdbac7 242\f
dfcf069d 243void
971de7fb 244init_casetab_once (void)
dcfdbac7
JB
245{
246 register int i;
7f7fef04 247 Lisp_Object down, up;
d67b4f80 248 Qcase_table = intern_c_string ("case-table");
7f7fef04
RS
249 staticpro (&Qcase_table);
250
251 /* Intern this now in case it isn't already done.
252 Setting this variable twice is harmless.
253 But don't staticpro it here--that is done in alloc.c. */
d67b4f80 254 Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
dcfdbac7 255
7f7fef04
RS
256 /* Now we are ready to set up this property, so we can
257 create char tables. */
4b3bd052 258 Fput (Qcase_table, Qchar_table_extra_slots, make_number (3));
7f7fef04
RS
259
260 down = Fmake_char_table (Qcase_table, Qnil);
261 Vascii_downcase_table = down;
e1b490ca 262 XCHAR_TABLE (down)->purpose = Qcase_table;
dcfdbac7 263
e961d439 264 for (i = 0; i < 128; i++)
8f924df7
KH
265 {
266 int c = (i >= 'A' && i <= 'Z') ? i + ('a' - 'A') : i;
267 CHAR_TABLE_SET (down, i, make_number (c));
268 }
7f7fef04
RS
269
270 XCHAR_TABLE (down)->extras[1] = Fcopy_sequence (down);
dcfdbac7 271
7f7fef04
RS
272 up = Fmake_char_table (Qcase_table, Qnil);
273 XCHAR_TABLE (down)->extras[0] = up;
dcfdbac7 274
e961d439 275 for (i = 0; i < 128; i++)
8f924df7
KH
276 {
277 int c = ((i >= 'A' && i <= 'Z') ? i + ('a' - 'A')
278 : ((i >= 'a' && i <= 'z') ? i + ('A' - 'a')
8510724d 279 : i));
8f924df7
KH
280 CHAR_TABLE_SET (up, i, make_number (c));
281 }
7f7fef04
RS
282
283 XCHAR_TABLE (down)->extras[2] = Fcopy_sequence (up);
66aa138d
RS
284
285 /* Fill in what isn't filled in. */
286 set_case_table (down, 1);
dcfdbac7
JB
287}
288
dfcf069d 289void
971de7fb 290syms_of_casetab (void)
dcfdbac7 291{
d67b4f80 292 Qcase_table_p = intern_c_string ("case-table-p");
dcfdbac7 293 staticpro (&Qcase_table_p);
7f7fef04 294
8f84b1a1 295 staticpro (&Vascii_canon_table);
dcfdbac7 296 staticpro (&Vascii_downcase_table);
8f84b1a1
EN
297 staticpro (&Vascii_eqv_table);
298 staticpro (&Vascii_upcase_table);
dcfdbac7
JB
299
300 defsubr (&Scase_table_p);
301 defsubr (&Scurrent_case_table);
302 defsubr (&Sstandard_case_table);
303 defsubr (&Sset_case_table);
304 defsubr (&Sset_standard_case_table);
dcfdbac7 305}
6b61353c
KH
306
307/* arch-tag: e06388ad-99fe-40ec-ba67-9d010fcc4916
308 (do not change this comment) */