1 /* XEmacs 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 XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: FSF 19.28. Between FSF 19.28 and 19.30, casetab.c
23 was rewritten to use junky FSF char tables. Meanwhile I rewrote it
24 to use more logical char tables. RMS also discards the "list of four
25 tables" format and instead stuffs the other tables as "extra slots"
26 in the downcase table. I've kept the four-lists format for now. */
28 /* Written by Howard Gayle. See some mythical and not-in-the-Emacs-
29 distribution file chartab.c for details. */
31 /* Modified for Mule by Ben Wing. */
33 /* Case table consists of four char-table. Those are for downcase,
34 upcase, canonical and equivalent respectively.
36 It's entry is like this:
38 downcase: a -> a, A -> a.
39 upcase: a -> A, A -> a. (The latter is for NOCASEP.)
40 canon: a -> a, A -> a.
51 Lisp_Object Qcase_tablep, Qdowncase, Qupcase;
52 Lisp_Object Vstandard_case_table;
54 static void compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse);
55 Lisp_Object case_table_char (Lisp_Object ch, Lisp_Object table);
57 #define STRING256_P(obj) ((STRINGP (obj) && XSTRING_CHAR_LENGTH (obj) == 256))
60 mark_case_table (Lisp_Object obj)
62 Lisp_Case_Table *ct = XCASE_TABLE (obj);
64 mark_object (CASE_TABLE_DOWNCASE (ct));
65 mark_object (CASE_TABLE_UPCASE (ct));
66 mark_object (CASE_TABLE_CANON (ct));
67 mark_object (CASE_TABLE_EQV (ct));
72 print_case_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
74 Lisp_Case_Table *ct = XCASE_TABLE (obj);
77 error ("printing unreadable object #<case-table 0x%x", ct->header.uid);
78 write_c_string ("#<case-table ", printcharfun);
79 sprintf (buf, "0x%x>", ct->header.uid);
80 write_c_string (buf, printcharfun);
83 static const struct lrecord_description case_table_description [] = {
84 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, downcase_table) },
85 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, upcase_table) },
86 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_canon_table) },
87 { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_eqv_table) },
91 DEFINE_LRECORD_IMPLEMENTATION ("case-table", case_table,
92 mark_case_table, print_case_table, 0,
93 0, 0, case_table_description, Lisp_Case_Table);
96 allocate_case_table (void)
100 alloc_lcrecord_type (Lisp_Case_Table, &lrecord_case_table);
102 SET_CASE_TABLE_DOWNCASE (ct, Qnil);
103 SET_CASE_TABLE_UPCASE (ct, Qnil);
104 SET_CASE_TABLE_CANON (ct, Qnil);
105 SET_CASE_TABLE_EQV (ct, Qnil);
107 XSETCASE_TABLE (val, ct);
111 DEFUN ("case-table-p", Fcase_table_p, 1, 1, 0, /*
112 Return t if OBJECT is a case table.
113 See `set-case-table' for more information on these data structures.
117 if (CASE_TABLEP (object))
121 Lisp_Object down, up, canon, eqv;
124 down = XCAR (object); object = XCDR (object);
127 up = XCAR (object); object = XCDR (object);
130 canon = XCAR (object); 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)))
146 check_case_table (Lisp_Object object)
148 /* This function can GC */
149 while (NILP (Fcase_table_p (object)))
150 object = wrong_type_argument (Qcase_tablep, object);
155 case_table_char (Lisp_Object ch, Lisp_Object table)
158 ct_char = get_char_table (XCHAR (ch), XCHAR_TABLE (table));
165 DEFUN ("get-case-table", Fget_case_table, 3, 3, 0, /*
166 Return CHAR-CASE version of CHARACTER in CASE-TABLE.
168 CHAR-CASE is either downcase or upcase.
170 (char_case, character, case_table))
172 CHECK_CHAR (character);
173 CHECK_CASE_TABLE (case_table);
174 if (EQ (char_case, Qdowncase))
175 return case_table_char (character, XCASE_TABLE_DOWNCASE (case_table));
176 else if (EQ (char_case, Qupcase))
177 return case_table_char (character, XCASE_TABLE_UPCASE (case_table));
179 signal_simple_error ("Char case must be downcase or upcase", char_case);
181 return Qnil; /* Not reached. */
184 DEFUN ("put-case-table", Fput_case_table, 4, 4, 0, /*
185 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE.
187 CHAR-CASE is either downcase or upcase.
188 See also `put-case-table-pair'.
190 (char_case, character, value, case_table))
192 CHECK_CHAR (character);
195 if (EQ (char_case, Qdowncase))
197 Fput_char_table (character, value, XCASE_TABLE_DOWNCASE (case_table));
198 /* This one is not at all intuitive. */
199 Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table));
200 Fput_char_table (character, value, 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));
205 else if (EQ (char_case, Qupcase))
207 Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table));
208 Fput_char_table (character, character, XCASE_TABLE_DOWNCASE (case_table));
209 Fput_char_table (character, character, XCASE_TABLE_CANON (case_table));
210 Fput_char_table (value, character, XCASE_TABLE_CANON (case_table));
211 Fput_char_table (value, character, XCASE_TABLE_EQV (case_table));
212 Fput_char_table (character, value, XCASE_TABLE_EQV (case_table));
215 signal_simple_error ("Char case must be downcase or upcase", char_case);
220 DEFUN ("put-case-table-pair", Fput_case_table_pair, 3, 3, 0, /*
221 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE.
222 UC is an uppercase character and LC is a downcase character.
224 (uc, lc, case_table))
228 CHECK_CASE_TABLE (case_table);
230 Fput_char_table (lc, lc, XCASE_TABLE_DOWNCASE (case_table));
231 Fput_char_table (uc, lc, XCASE_TABLE_UPCASE (case_table));
232 Fput_char_table (uc, lc, XCASE_TABLE_DOWNCASE (case_table));
233 Fput_char_table (lc, uc, XCASE_TABLE_UPCASE (case_table));
235 Fput_char_table (lc, lc, XCASE_TABLE_CANON (case_table));
236 Fput_char_table (uc, lc, XCASE_TABLE_CANON (case_table));
237 Fput_char_table (uc, lc, XCASE_TABLE_EQV (case_table));
238 Fput_char_table (lc, uc, XCASE_TABLE_EQV (case_table));
242 DEFUN ("copy-case-table", Fcopy_case_table, 1, 1, 0, /*
243 Return a new case table which is a copy of CASE-TABLE
248 CHECK_CASE_TABLE (case_table);
250 new_obj = allocate_case_table ();
251 XSET_CASE_TABLE_DOWNCASE
252 (new_obj, Fcopy_char_table (XCASE_TABLE_DOWNCASE (case_table)));
253 XSET_CASE_TABLE_UPCASE
254 (new_obj, Fcopy_char_table (XCASE_TABLE_UPCASE (case_table)));
255 XSET_CASE_TABLE_CANON
256 (new_obj, Fcopy_char_table (XCASE_TABLE_CANON (case_table)));
258 (new_obj, Fcopy_char_table (XCASE_TABLE_EQV (case_table)));
262 DEFUN ("current-case-table", Fcurrent_case_table, 0, 1, 0, /*
263 Return the case table of BUFFER, which defaults to the current buffer.
267 struct buffer *buf = decode_buffer (buffer, 0);
269 return buf->case_table;
272 DEFUN ("standard-case-table", Fstandard_case_table, 0, 0, 0, /*
273 Return the standard case table.
274 This is the one used for new buffers.
278 return Vstandard_case_table;
281 static Lisp_Object set_case_table (Lisp_Object table, int standard);
283 DEFUN ("set-case-table", Fset_case_table, 1, 1, 0, /*
284 Select CASE-TABLE as the new case table for the current buffer.
285 A case table is a case-table object or list
286 (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)
287 where each element is either nil or a string of length 256.
288 The latter is provided for backward-compatibility.
289 DOWNCASE maps each character to its lower-case equivalent.
290 UPCASE maps each character to its upper-case equivalent;
291 if lower and upper case characters are in 1-1 correspondence,
292 you may use nil and the upcase table will be deduced from DOWNCASE.
293 CANONICALIZE maps each character to a canonical equivalent;
294 any two characters that are related by case-conversion have the same
295 canonical equivalent character; it may be nil, in which case it is
296 deduced from DOWNCASE and UPCASE.
297 EQUIVALENCES is a map that cyclicly permutes each equivalence class
298 (of characters with the same canonical equivalent); it may be nil,
299 in which case it is deduced from CANONICALIZE.
301 See also `get-case-table', `put-case-table' and `put-case-table-pair'.
305 /* This function can GC */
306 return set_case_table (case_table, 0);
309 DEFUN ("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /*
310 Select CASE-TABLE as the new standard case table for new buffers.
311 See `set-case-table' for more info on case tables.
315 /* This function can GC */
316 return set_case_table (case_table, 1);
320 set_case_table (Lisp_Object table, int standard)
322 /* This function can GC */
324 standard ? XBUFFER(Vbuffer_defaults) : current_buffer;
326 check_case_table (table);
328 if (CASE_TABLEP (table))
331 Vstandard_case_table = table;
333 buf->case_table = table;
337 /* For backward compatibility. */
338 Lisp_Object down, up, canon, eqv, tail = table;
342 down = XCAR (tail); tail = XCDR (tail);
343 up = XCAR (tail); tail = XCDR (tail);
344 canon = XCAR (tail); tail = XCDR (tail);
348 down = MAKE_TRT_TABLE ();
349 for (i = 0; i < 256; i++)
350 SET_TRT_TABLE_CHAR_1 (down, i, string_char (XSTRING (temp), i));
354 up = MAKE_TRT_TABLE ();
355 compute_trt_inverse (down, up);
360 up = MAKE_TRT_TABLE ();
361 for (i = 0; i < 256; i++)
362 SET_TRT_TABLE_CHAR_1 (up, i, string_char (XSTRING (temp), i));
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, i))));
382 canon = MAKE_TRT_TABLE ();
383 for (i = 0; i < 256; i++)
384 SET_TRT_TABLE_CHAR_1 (canon, i, string_char (XSTRING (temp), i));
389 eqv = MAKE_TRT_TABLE ();
390 compute_trt_inverse (canon, eqv);
395 eqv = MAKE_TRT_TABLE ();
396 for (i = 0; i < 256; i++)
397 SET_TRT_TABLE_CHAR_1 (eqv, i, string_char (XSTRING (temp), i));
402 XSET_CASE_TABLE_DOWNCASE (Vstandard_case_table, down);
403 XSET_CASE_TABLE_UPCASE (Vstandard_case_table, up);
404 XSET_CASE_TABLE_CANON (Vstandard_case_table, canon);
405 XSET_CASE_TABLE_EQV (Vstandard_case_table, eqv);
408 buf->case_table = allocate_case_table ();
409 XSET_CASE_TABLE_DOWNCASE (buf->case_table, down);
410 XSET_CASE_TABLE_UPCASE (buf->case_table, up);
411 XSET_CASE_TABLE_CANON (buf->case_table, canon);
412 XSET_CASE_TABLE_EQV (buf->case_table, eqv);
415 return buf->case_table;
418 /* Given a translate table TRT, store the inverse mapping into INVERSE.
419 Since TRT is not one-to-one, INVERSE is not a simple mapping.
420 Instead, it divides the space of characters into equivalence classes.
421 All characters in a given class form one circular list, chained through
422 the elements of INVERSE. */
425 compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse)
431 SET_TRT_TABLE_CHAR_1 (inverse, i, (Emchar) i);
435 if ((q = TRT_TABLE_CHAR_1 (trt, i)) != (Emchar) i)
437 c = TRT_TABLE_CHAR_1 (inverse, q);
438 SET_TRT_TABLE_CHAR_1 (inverse, q, (Emchar) i);
439 SET_TRT_TABLE_CHAR_1 (inverse, i, c);
446 syms_of_casetab (void)
448 INIT_LRECORD_IMPLEMENTATION (case_table);
450 defsymbol (&Qcase_tablep, "case-table-p");
451 defsymbol (&Qdowncase, "downcase");
452 defsymbol (&Qupcase, "upcase");
454 DEFSUBR (Fcase_table_p);
455 DEFSUBR (Fget_case_table);
456 DEFSUBR (Fput_case_table);
457 DEFSUBR (Fput_case_table_pair);
458 DEFSUBR (Fcurrent_case_table);
459 DEFSUBR (Fstandard_case_table);
460 DEFSUBR (Fcopy_case_table);
461 DEFSUBR (Fset_case_table);
462 DEFSUBR (Fset_standard_case_table);
466 complex_vars_of_casetab (void)
471 staticpro (&Vstandard_case_table);
473 Vstandard_case_table = allocate_case_table ();
475 tem = MAKE_TRT_TABLE ();
476 XSET_CASE_TABLE_DOWNCASE (Vstandard_case_table, tem);
477 XSET_CASE_TABLE_CANON (Vstandard_case_table, tem);
479 /* Under Mule, can't do set_string_char() until Vcharset_control_1
480 and Vcharset_ascii are initialized. */
481 for (i = 0; i < 256; i++)
483 unsigned char lowered = tolower (i);
485 SET_TRT_TABLE_CHAR_1 (tem, i, lowered);
488 tem = MAKE_TRT_TABLE ();
489 XSET_CASE_TABLE_UPCASE (Vstandard_case_table, tem);
490 XSET_CASE_TABLE_EQV (Vstandard_case_table, tem);
492 for (i = 0; i < 256; i++)
494 unsigned char flipped = (isupper (i) ? tolower (i)
495 : (islower (i) ? toupper (i) : i));
497 SET_TRT_TABLE_CHAR_1 (tem, i, flipped);