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);
75 error("printing unreadable object #<case-table 0x%x",
77 write_c_string("#<case-table ", printcharfun);
78 sprintf(buf, "0x%x>", ct->header.uid);
79 write_c_string(buf, printcharfun);
82 static const struct lrecord_description case_table_description[] = {
83 {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, downcase_table)},
84 {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, upcase_table)},
85 {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, case_canon_table)},
86 {XD_LISP_OBJECT, offsetof(Lisp_Case_Table, case_eqv_table)},
90 DEFINE_LRECORD_IMPLEMENTATION("case-table", case_table,
91 mark_case_table, print_case_table, 0,
92 0, 0, case_table_description, Lisp_Case_Table);
94 static Lisp_Object allocate_case_table(void)
98 alloc_lcrecord_type(Lisp_Case_Table, &lrecord_case_table);
100 SET_CASE_TABLE_DOWNCASE(ct, Qnil);
101 SET_CASE_TABLE_UPCASE(ct, Qnil);
102 SET_CASE_TABLE_CANON(ct, Qnil);
103 SET_CASE_TABLE_EQV(ct, Qnil);
105 XSETCASE_TABLE(val, ct);
109 DEFUN("case-table-p", Fcase_table_p, 1, 1, 0, /*
110 Return t if OBJECT is a case table.
111 See `set-case-table' for more information on these data structures.
115 if (CASE_TABLEP(object))
118 Lisp_Object down, up, canon, eqv;
122 object = XCDR(object);
126 object = XCDR(object);
129 canon = XCAR(object);
130 object = XCDR(object);
135 return ((STRING256_P(down)
136 && (NILP(up) || STRING256_P(up))
137 && ((NILP(canon) && NILP(eqv))
138 || STRING256_P(canon))
139 && (NILP(eqv) || STRING256_P(eqv)))
145 static Lisp_Object check_case_table(Lisp_Object object)
147 /* This function can GC */
148 while (NILP(Fcase_table_p(object)))
149 object = wrong_type_argument(Qcase_tablep, object);
153 Lisp_Object case_table_char(Lisp_Object ch, Lisp_Object table)
156 ct_char = get_char_table(XCHAR(ch), XCHAR_TABLE(table));
163 DEFUN("get-case-table", Fget_case_table, 3, 3, 0, /*
164 Return CHAR-CASE version of CHARACTER in CASE-TABLE.
166 CHAR-CASE is either downcase or upcase.
168 (char_case, character, case_table))
170 CHECK_CHAR(character);
171 CHECK_CASE_TABLE(case_table);
172 if (EQ(char_case, Qdowncase))
173 return case_table_char(character,
174 XCASE_TABLE_DOWNCASE(case_table));
175 else if (EQ(char_case, Qupcase))
176 return case_table_char(character,
177 XCASE_TABLE_UPCASE(case_table));
179 signal_simple_error("Char case must be downcase or upcase",
182 return Qnil; /* Not reached. */
185 DEFUN("put-case-table", Fput_case_table, 4, 4, 0, /*
186 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE.
188 CHAR-CASE is either downcase or upcase.
189 See also `put-case-table-pair'.
191 (char_case, character, value, case_table))
193 CHECK_CHAR(character);
196 if (EQ(char_case, Qdowncase)) {
197 Fput_char_table(character, value,
198 XCASE_TABLE_DOWNCASE(case_table));
199 /* This one is not at all intuitive. */
200 Fput_char_table(character, value,
201 XCASE_TABLE_UPCASE(case_table));
202 Fput_char_table(character, value,
203 XCASE_TABLE_CANON(case_table));
204 Fput_char_table(value, value, XCASE_TABLE_CANON(case_table));
205 Fput_char_table(value, character, XCASE_TABLE_EQV(case_table));
206 Fput_char_table(character, value, XCASE_TABLE_EQV(case_table));
207 } else if (EQ(char_case, Qupcase)) {
208 Fput_char_table(character, value,
209 XCASE_TABLE_UPCASE(case_table));
210 Fput_char_table(character, character,
211 XCASE_TABLE_DOWNCASE(case_table));
212 Fput_char_table(character, character,
213 XCASE_TABLE_CANON(case_table));
214 Fput_char_table(value, character,
215 XCASE_TABLE_CANON(case_table));
216 Fput_char_table(value, character, XCASE_TABLE_EQV(case_table));
217 Fput_char_table(character, value, XCASE_TABLE_EQV(case_table));
219 signal_simple_error("Char case must be downcase or upcase",
225 DEFUN("put-case-table-pair", Fput_case_table_pair, 3, 3, 0, /*
226 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE.
227 UC is an uppercase character and LC is a downcase character.
229 (uc, lc, case_table))
233 CHECK_CASE_TABLE(case_table);
235 Fput_char_table(lc, lc, XCASE_TABLE_DOWNCASE(case_table));
236 Fput_char_table(uc, lc, XCASE_TABLE_UPCASE(case_table));
237 Fput_char_table(uc, lc, XCASE_TABLE_DOWNCASE(case_table));
238 Fput_char_table(lc, uc, XCASE_TABLE_UPCASE(case_table));
240 Fput_char_table(lc, lc, XCASE_TABLE_CANON(case_table));
241 Fput_char_table(uc, lc, XCASE_TABLE_CANON(case_table));
242 Fput_char_table(uc, lc, XCASE_TABLE_EQV(case_table));
243 Fput_char_table(lc, uc, XCASE_TABLE_EQV(case_table));
247 DEFUN("copy-case-table", Fcopy_case_table, 1, 1, 0, /*
248 Return a new case table which is a copy of CASE-TABLE
253 CHECK_CASE_TABLE(case_table);
255 new_obj = allocate_case_table();
256 XSET_CASE_TABLE_DOWNCASE
257 (new_obj, Fcopy_char_table(XCASE_TABLE_DOWNCASE(case_table)));
258 XSET_CASE_TABLE_UPCASE
259 (new_obj, Fcopy_char_table(XCASE_TABLE_UPCASE(case_table)));
260 XSET_CASE_TABLE_CANON
261 (new_obj, Fcopy_char_table(XCASE_TABLE_CANON(case_table)));
263 (new_obj, Fcopy_char_table(XCASE_TABLE_EQV(case_table)));
267 DEFUN("current-case-table", Fcurrent_case_table, 0, 1, 0, /*
268 Return the case table of BUFFER, which defaults to the current buffer.
272 struct buffer *buf = decode_buffer(buffer, 0);
274 return buf->case_table;
277 DEFUN("standard-case-table", Fstandard_case_table, 0, 0, 0, /*
278 Return the standard case table.
279 This is the one used for new buffers.
283 return Vstandard_case_table;
286 static Lisp_Object set_case_table(Lisp_Object table, int standard);
288 DEFUN("set-case-table", Fset_case_table, 1, 1, 0, /*
289 Select CASE-TABLE as the new case table for the current buffer.
290 A case table is a case-table object or list
291 DOWNCASE UPCASE CANONICALIZE EQUIVALENCES
292 where each element is either nil or a string of length 256.
293 The latter is provided for backward-compatibility.
294 DOWNCASE maps each character to its lower-case equivalent.
295 UPCASE maps each character to its upper-case equivalent,
296 if lower and upper case characters are in 1-1 correspondence,
297 you may use nil and the upcase table will be deduced from DOWNCASE.
298 CANONICALIZE maps each character to a canonical equivalent,
299 any two characters that are related by case-conversion have the same
300 canonical equivalent character, it may be nil, in which case it is
301 deduced from DOWNCASE and UPCASE.
302 EQUIVALENCES is a map that cyclicly permutes each equivalence class
303 of characters with the same canonical equivalent it may be nil,
304 in which case it is deduced from CANONICALIZE.
306 See also `get-case-table', `put-case-table' and `put-case-table-pair'.
310 /* This function can GC */
311 return set_case_table(case_table, 0);
314 DEFUN("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /*
315 Select CASE-TABLE as the new standard case table for new buffers.
316 See `set-case-table' for more info on case tables.
320 /* This function can GC */
321 return set_case_table(case_table, 1);
324 static Lisp_Object set_case_table(Lisp_Object table, int standard)
326 /* This function can GC */
328 standard ? XBUFFER(Vbuffer_defaults) : current_buffer;
330 check_case_table(table);
332 if (CASE_TABLEP(table)) {
334 Vstandard_case_table = table;
336 buf->case_table = table;
338 /* For backward compatibility. */
339 Lisp_Object down, up, canon, eqv, tail = table;
352 down = MAKE_TRT_TABLE();
353 for (i = 0; i < 256; i++)
354 SET_TRT_TABLE_CHAR_1(down, i,
355 string_char(XSTRING(temp), i));
358 up = MAKE_TRT_TABLE();
359 compute_trt_inverse(down, up);
362 up = MAKE_TRT_TABLE();
363 for (i = 0; i < 256; i++)
364 SET_TRT_TABLE_CHAR_1(up, i,
365 string_char(XSTRING(temp),
369 canon = MAKE_TRT_TABLE();
371 /* Set up the CANON table; for each character,
372 this sequence of upcasing and downcasing ought to
373 get the "preferred" lowercase equivalent. */
374 for (i = 0; i < 256; i++)
375 SET_TRT_TABLE_CHAR_1(canon, i,
380 TRT_TABLE_CHAR_1(down,
384 canon = MAKE_TRT_TABLE();
385 for (i = 0; i < 256; i++)
386 SET_TRT_TABLE_CHAR_1(canon, i,
387 string_char(XSTRING(temp),
392 eqv = MAKE_TRT_TABLE();
393 compute_trt_inverse(canon, eqv);
396 eqv = MAKE_TRT_TABLE();
397 for (i = 0; i < 256; i++)
398 SET_TRT_TABLE_CHAR_1(eqv, i,
399 string_char(XSTRING(temp),
404 XSET_CASE_TABLE_DOWNCASE(Vstandard_case_table, down);
405 XSET_CASE_TABLE_UPCASE(Vstandard_case_table, up);
406 XSET_CASE_TABLE_CANON(Vstandard_case_table, canon);
407 XSET_CASE_TABLE_EQV(Vstandard_case_table, eqv);
410 buf->case_table = allocate_case_table();
411 XSET_CASE_TABLE_DOWNCASE(buf->case_table, down);
412 XSET_CASE_TABLE_UPCASE(buf->case_table, up);
413 XSET_CASE_TABLE_CANON(buf->case_table, canon);
414 XSET_CASE_TABLE_EQV(buf->case_table, eqv);
417 return buf->case_table;
420 /* Given a translate table TRT, store the inverse mapping into INVERSE.
421 Since TRT is not one-to-one, INVERSE is not a simple mapping.
422 Instead, it divides the space of characters into equivalence classes.
423 All characters in a given class form one circular list, chained through
424 the elements of INVERSE. */
426 static void compute_trt_inverse(Lisp_Object trt, Lisp_Object inverse)
432 SET_TRT_TABLE_CHAR_1(inverse, i, (Emchar) i);
435 if ((q = TRT_TABLE_CHAR_1(trt, i)) != (Emchar) i) {
436 c = TRT_TABLE_CHAR_1(inverse, q);
437 SET_TRT_TABLE_CHAR_1(inverse, q, (Emchar) i);
438 SET_TRT_TABLE_CHAR_1(inverse, i, c);
443 void syms_of_casetab(void)
445 INIT_LRECORD_IMPLEMENTATION(case_table);
447 defsymbol(&Qcase_tablep, "case-table-p");
448 defsymbol(&Qdowncase, "downcase");
449 defsymbol(&Qupcase, "upcase");
451 DEFSUBR(Fcase_table_p);
452 DEFSUBR(Fget_case_table);
453 DEFSUBR(Fput_case_table);
454 DEFSUBR(Fput_case_table_pair);
455 DEFSUBR(Fcurrent_case_table);
456 DEFSUBR(Fstandard_case_table);
457 DEFSUBR(Fcopy_case_table);
458 DEFSUBR(Fset_case_table);
459 DEFSUBR(Fset_standard_case_table);
462 void complex_vars_of_casetab(void)
467 staticpro(&Vstandard_case_table);
469 Vstandard_case_table = allocate_case_table();
471 tem = MAKE_TRT_TABLE();
472 XSET_CASE_TABLE_DOWNCASE(Vstandard_case_table, tem);
473 XSET_CASE_TABLE_CANON(Vstandard_case_table, tem);
475 /* Under Mule, can't do set_string_char() until Vcharset_control_1
476 and Vcharset_ascii are initialized. */
477 for (i = 0; i < 256; i++) {
478 unsigned char lowered = tolower(i);
480 SET_TRT_TABLE_CHAR_1(tem, i, lowered);
483 tem = MAKE_TRT_TABLE();
484 XSET_CASE_TABLE_UPCASE(Vstandard_case_table, tem);
485 XSET_CASE_TABLE_EQV(Vstandard_case_table, tem);
487 for (i = 0; i < 256; i++) {
488 unsigned char flipped = (isupper(i) ? tolower(i)
489 : (islower(i) ? toupper(i) : i));
491 SET_TRT_TABLE_CHAR_1(tem, i, flipped);