1 /* SXEmacs routines to deal with case tables.
2 Copyright (C) 1987, 1992, 1993, 1994 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
5 This file is part of SXEmacs
7 SXEmacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 SXEmacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
21 /* Synched up with: FSF 19.28. Between FSF 19.28 and 19.30, casetab.c
22 was rewritten to use junky FSF char tables. Meanwhile I rewrote it
23 to use more logical char tables. RMS also discards the "list of four
24 tables" format and instead stuffs the other tables as "extra slots"
25 in the downcase table. I've kept the four-lists format for now. */
27 /* Written by Howard Gayle. See some mythical and not-in-the-Emacs-
28 distribution file chartab.c for details. */
30 /* Modified for Mule by Ben Wing. */
32 /* Case table consists of four char-table. Those are for downcase,
33 upcase, canonical and equivalent respectively.
35 It's entry is like this:
37 downcase: a -> a, A -> a.
38 upcase: a -> A, A -> a. (The latter is for NOCASEP.)
39 canon: a -> a, A -> a.
50 Lisp_Object Qcase_tablep, Qdowncase, Qupcase;
51 Lisp_Object Vstandard_case_table;
53 static void compute_trt_inverse(Lisp_Object trt, Lisp_Object inverse);
54 Lisp_Object case_table_char(Lisp_Object ch, Lisp_Object table);
56 #define STRING256_P(obj) ((STRINGP (obj) && XSTRING_CHAR_LENGTH (obj) == 256))
58 static Lisp_Object mark_case_table(Lisp_Object obj)
60 Lisp_Case_Table *ct = XCASE_TABLE(obj);
62 mark_object(CASE_TABLE_DOWNCASE(ct));
63 mark_object(CASE_TABLE_UPCASE(ct));
64 mark_object(CASE_TABLE_CANON(ct));
65 mark_object(CASE_TABLE_EQV(ct));
70 print_case_table(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
72 Lisp_Case_Table *ct = XCASE_TABLE(obj);
74 error("printing unreadable object #<case-table 0x%x",
76 write_fmt_str(printcharfun, "#<case-table 0x%x>", ct->header.uid);
79 static const struct lrecord_description case_table_description[] = {
80 {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, downcase_table)},
81 {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, upcase_table)},
82 {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, case_canon_table)},
83 {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, case_eqv_table)},
87 DEFINE_LRECORD_IMPLEMENTATION("case-table", case_table,
88 mark_case_table, print_case_table, 0,
89 0, 0, case_table_description, Lisp_Case_Table);
91 static Lisp_Object allocate_case_table(void)
95 alloc_lcrecord_type(Lisp_Case_Table, &lrecord_case_table);
97 SET_CASE_TABLE_DOWNCASE(ct, Qnil);
98 SET_CASE_TABLE_UPCASE(ct, Qnil);
99 SET_CASE_TABLE_CANON(ct, Qnil);
100 SET_CASE_TABLE_EQV(ct, Qnil);
102 XSETCASE_TABLE(val, ct);
106 DEFUN("case-table-p", Fcase_table_p, 1, 1, 0, /*
107 Return t if OBJECT is a case table.
108 See `set-case-table' for more information on these data structures.
112 if (CASE_TABLEP(object))
115 Lisp_Object down, up, canon, eqv;
119 object = XCDR(object);
123 object = XCDR(object);
126 canon = XCAR(object);
127 object = XCDR(object);
132 return ((STRING256_P(down)
133 && (NILP(up) || STRING256_P(up))
134 && ((NILP(canon) && NILP(eqv))
135 || STRING256_P(canon))
136 && (NILP(eqv) || STRING256_P(eqv)))
142 static Lisp_Object check_case_table(Lisp_Object object)
144 /* This function can GC */
145 while (NILP(Fcase_table_p(object)))
146 object = wrong_type_argument(Qcase_tablep, object);
150 Lisp_Object case_table_char(Lisp_Object ch, Lisp_Object table)
153 ct_char = get_char_table(XCHAR(ch), XCHAR_TABLE(table));
160 DEFUN("get-case-table", Fget_case_table, 3, 3, 0, /*
161 Return CHAR-CASE version of CHARACTER in CASE-TABLE.
163 CHAR-CASE is either downcase or upcase.
165 (char_case, character, case_table))
167 CHECK_CHAR(character);
168 CHECK_CASE_TABLE(case_table);
169 if (EQ(char_case, Qdowncase))
170 return case_table_char(character,
171 XCASE_TABLE_DOWNCASE(case_table));
172 else if (EQ(char_case, Qupcase))
173 return case_table_char(character,
174 XCASE_TABLE_UPCASE(case_table));
176 signal_simple_error("Char case must be downcase or upcase",
179 return Qnil; /* Not reached. */
182 DEFUN("put-case-table", Fput_case_table, 4, 4, 0, /*
183 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE.
185 CHAR-CASE is either downcase or upcase.
186 See also `put-case-table-pair'.
188 (char_case, character, value, case_table))
190 CHECK_CHAR(character);
193 if (EQ(char_case, Qdowncase)) {
194 Fput_char_table(character, value,
195 XCASE_TABLE_DOWNCASE(case_table));
196 /* This one is not at all intuitive. */
197 Fput_char_table(character, value,
198 XCASE_TABLE_UPCASE(case_table));
199 Fput_char_table(character, value,
200 XCASE_TABLE_CANON(case_table));
201 Fput_char_table(value, value, XCASE_TABLE_CANON(case_table));
202 Fput_char_table(value, character, XCASE_TABLE_EQV(case_table));
203 Fput_char_table(character, value, XCASE_TABLE_EQV(case_table));
204 } else if (EQ(char_case, Qupcase)) {
205 Fput_char_table(character, value,
206 XCASE_TABLE_UPCASE(case_table));
207 Fput_char_table(character, character,
208 XCASE_TABLE_DOWNCASE(case_table));
209 Fput_char_table(character, character,
210 XCASE_TABLE_CANON(case_table));
211 Fput_char_table(value, character,
212 XCASE_TABLE_CANON(case_table));
213 Fput_char_table(value, character, XCASE_TABLE_EQV(case_table));
214 Fput_char_table(character, value, XCASE_TABLE_EQV(case_table));
216 signal_simple_error("Char case must be downcase or upcase",
222 DEFUN("put-case-table-pair", Fput_case_table_pair, 3, 3, 0, /*
223 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE.
224 UC is an uppercase character and LC is a downcase character.
226 (uc, lc, case_table))
230 CHECK_CASE_TABLE(case_table);
232 Fput_char_table(lc, lc, XCASE_TABLE_DOWNCASE(case_table));
233 Fput_char_table(uc, lc, XCASE_TABLE_UPCASE(case_table));
234 Fput_char_table(uc, lc, XCASE_TABLE_DOWNCASE(case_table));
235 Fput_char_table(lc, uc, XCASE_TABLE_UPCASE(case_table));
237 Fput_char_table(lc, lc, XCASE_TABLE_CANON(case_table));
238 Fput_char_table(uc, lc, XCASE_TABLE_CANON(case_table));
239 Fput_char_table(uc, lc, XCASE_TABLE_EQV(case_table));
240 Fput_char_table(lc, uc, XCASE_TABLE_EQV(case_table));
244 DEFUN("copy-case-table", Fcopy_case_table, 1, 1, 0, /*
245 Return a new case table which is a copy of CASE-TABLE
250 CHECK_CASE_TABLE(case_table);
252 new_obj = allocate_case_table();
253 XSET_CASE_TABLE_DOWNCASE
254 (new_obj, Fcopy_char_table(XCASE_TABLE_DOWNCASE(case_table)));
255 XSET_CASE_TABLE_UPCASE
256 (new_obj, Fcopy_char_table(XCASE_TABLE_UPCASE(case_table)));
257 XSET_CASE_TABLE_CANON
258 (new_obj, Fcopy_char_table(XCASE_TABLE_CANON(case_table)));
260 (new_obj, Fcopy_char_table(XCASE_TABLE_EQV(case_table)));
264 DEFUN("current-case-table", Fcurrent_case_table, 0, 1, 0, /*
265 Return the case table of BUFFER, which defaults to the current buffer.
269 struct buffer *buf = decode_buffer(buffer, 0);
271 return buf->case_table;
274 DEFUN("standard-case-table", Fstandard_case_table, 0, 0, 0, /*
275 Return the standard case table.
276 This is the one used for new buffers.
280 return Vstandard_case_table;
283 static Lisp_Object set_case_table(Lisp_Object table, int standard);
285 DEFUN("set-case-table", Fset_case_table, 1, 1, 0, /*
286 Select CASE-TABLE as the new case table for the current buffer.
287 A case table is a case-table object or list
288 DOWNCASE UPCASE CANONICALIZE EQUIVALENCES
289 where each element is either nil or a string of length 256.
290 The latter is provided for backward-compatibility.
291 DOWNCASE maps each character to its lower-case equivalent.
292 UPCASE maps each character to its upper-case equivalent,
293 if lower and upper case characters are in 1-1 correspondence,
294 you may use nil and the upcase table will be deduced from DOWNCASE.
295 CANONICALIZE maps each character to a canonical equivalent,
296 any two characters that are related by case-conversion have the same
297 canonical equivalent character, it may be nil, in which case it is
298 deduced from DOWNCASE and UPCASE.
299 EQUIVALENCES is a map that cyclicly permutes each equivalence class
300 of characters with the same canonical equivalent it may be nil,
301 in which case it is deduced from CANONICALIZE.
303 See also `get-case-table', `put-case-table' and `put-case-table-pair'.
307 /* This function can GC */
308 return set_case_table(case_table, 0);
311 DEFUN("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /*
312 Select CASE-TABLE as the new standard case table for new buffers.
313 See `set-case-table' for more info on case tables.
317 /* This function can GC */
318 return set_case_table(case_table, 1);
321 static Lisp_Object set_case_table(Lisp_Object table, int standard)
323 /* This function can GC */
325 standard ? XBUFFER(Vbuffer_defaults) : current_buffer;
327 check_case_table(table);
329 if (CASE_TABLEP(table)) {
331 Vstandard_case_table = table;
333 buf->case_table = table;
335 /* For backward compatibility. */
336 Lisp_Object down, up, canon, eqv, tail = table;
349 down = MAKE_TRT_TABLE();
350 for (i = 0; i < 256; i++)
351 SET_TRT_TABLE_CHAR_1(down, i,
352 string_char(XSTRING(temp), i));
355 up = MAKE_TRT_TABLE();
356 compute_trt_inverse(down, up);
359 up = MAKE_TRT_TABLE();
360 for (i = 0; i < 256; i++)
361 SET_TRT_TABLE_CHAR_1(up, i,
362 string_char(XSTRING(temp),
366 canon = MAKE_TRT_TABLE();
368 /* Set up the CANON table; for each character,
369 this sequence of upcasing and downcasing ought to
370 get the "preferred" lowercase equivalent. */
371 for (i = 0; i < 256; i++)
372 SET_TRT_TABLE_CHAR_1(canon, i,
377 TRT_TABLE_CHAR_1(down,
381 canon = MAKE_TRT_TABLE();
382 for (i = 0; i < 256; i++)
383 SET_TRT_TABLE_CHAR_1(canon, i,
384 string_char(XSTRING(temp),
389 eqv = MAKE_TRT_TABLE();
390 compute_trt_inverse(canon, eqv);
393 eqv = MAKE_TRT_TABLE();
394 for (i = 0; i < 256; i++)
395 SET_TRT_TABLE_CHAR_1(eqv, i,
396 string_char(XSTRING(temp),
401 XSET_CASE_TABLE_DOWNCASE(Vstandard_case_table, down);
402 XSET_CASE_TABLE_UPCASE(Vstandard_case_table, up);
403 XSET_CASE_TABLE_CANON(Vstandard_case_table, canon);
404 XSET_CASE_TABLE_EQV(Vstandard_case_table, eqv);
407 buf->case_table = allocate_case_table();
408 XSET_CASE_TABLE_DOWNCASE(buf->case_table, down);
409 XSET_CASE_TABLE_UPCASE(buf->case_table, up);
410 XSET_CASE_TABLE_CANON(buf->case_table, canon);
411 XSET_CASE_TABLE_EQV(buf->case_table, eqv);
414 return buf->case_table;
417 /* Given a translate table TRT, store the inverse mapping into INVERSE.
418 Since TRT is not one-to-one, INVERSE is not a simple mapping.
419 Instead, it divides the space of characters into equivalence classes.
420 All characters in a given class form one circular list, chained through
421 the elements of INVERSE. */
423 static void compute_trt_inverse(Lisp_Object trt, Lisp_Object inverse)
429 SET_TRT_TABLE_CHAR_1(inverse, i, (Emchar) i);
432 if ((q = TRT_TABLE_CHAR_1(trt, i)) != (Emchar) i) {
433 c = TRT_TABLE_CHAR_1(inverse, q);
434 SET_TRT_TABLE_CHAR_1(inverse, q, (Emchar) i);
435 SET_TRT_TABLE_CHAR_1(inverse, i, c);
440 void syms_of_casetab(void)
442 INIT_LRECORD_IMPLEMENTATION(case_table);
444 defsymbol(&Qcase_tablep, "case-table-p");
445 defsymbol(&Qdowncase, "downcase");
446 defsymbol(&Qupcase, "upcase");
448 DEFSUBR(Fcase_table_p);
449 DEFSUBR(Fget_case_table);
450 DEFSUBR(Fput_case_table);
451 DEFSUBR(Fput_case_table_pair);
452 DEFSUBR(Fcurrent_case_table);
453 DEFSUBR(Fstandard_case_table);
454 DEFSUBR(Fcopy_case_table);
455 DEFSUBR(Fset_case_table);
456 DEFSUBR(Fset_standard_case_table);
459 void complex_vars_of_casetab(void)
464 staticpro(&Vstandard_case_table);
466 Vstandard_case_table = allocate_case_table();
468 tem = MAKE_TRT_TABLE();
469 XSET_CASE_TABLE_DOWNCASE(Vstandard_case_table, tem);
470 XSET_CASE_TABLE_CANON(Vstandard_case_table, tem);
472 /* Under Mule, can't do set_string_char() until Vcharset_control_1
473 and Vcharset_ascii are initialized. */
474 for (i = 0; i < 256; i++) {
475 unsigned char lowered = tolower(i);
477 SET_TRT_TABLE_CHAR_1(tem, i, lowered);
480 tem = MAKE_TRT_TABLE();
481 XSET_CASE_TABLE_UPCASE(Vstandard_case_table, tem);
482 XSET_CASE_TABLE_EQV(Vstandard_case_table, tem);
484 for (i = 0; i < 256; i++) {
485 unsigned char flipped = (isupper(i) ? tolower(i)
486 : (islower(i) ? toupper(i) : i));
488 SET_TRT_TABLE_CHAR_1(tem, i, flipped);