Mercurial > hg > xemacs-beta

comparison src/casetab.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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.
4
5 This file is part of XEmacs.
6
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
10 later version.
11
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
15 for more details.
16
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. */
21
22 /* Synched up with: FSF 19.28. Between FSF 19.28 and 19.30, casetab.c
23 was rewritten to use junky RMS 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. */
27
28 /* Written by Howard Gayle. See some mythical and not-in-the-Emacs-
29 distribution file chartab.c for details. */
30
31 /* Modified for Mule by Ben Wing. */
32
33 /* #### We do not currently deal properly with translating non-ASCII
34 (including Latin-1!) characters under Mule. Getting this right is
35 *hard*, way fucking hard. So we at least preserve consistency by
36 sanitizing all the case tables to remove translations that would
37 get us into trouble and possibly result in inconsistent internal
38 text, which would likely lead to crashes. */
39
40 #include <config.h>
41 #include "lisp.h"
42 #include "buffer.h"
43 #include "opaque.h"
44
45 Lisp_Object Qcase_table_p;
46 Lisp_Object Vascii_downcase_table, Vascii_upcase_table;
47 Lisp_Object Vascii_canon_table, Vascii_eqv_table;
48 Lisp_Object Qtranslate_table;
49
50 static void compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse);
51
52 #define STRING256_P(obj) \
53 (STRINGP (obj) && string_char_length (XSTRING (obj)) == 256)
54
55 DEFUN ("case-table-p", Fcase_table_p, Scase_table_p, 1, 1, 0 /*
56 Return t iff ARG is a case table.
57 See `set-case-table' for more information on these data structures.
58 */ )
59 (table)
60 Lisp_Object table;
61 {
62 Lisp_Object down, up, canon, eqv;
63 down = Fcar_safe (table);
64 up = Fcar_safe (Fcdr_safe (table));
65 canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
66 eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
67
68 return (STRING256_P (down)
69 && (NILP (up) || STRING256_P (up))
70 && ((NILP (canon) && NILP (eqv))
71 || (STRING256_P (canon)
72 && (NILP (eqv) || STRING256_P (eqv))))
73 ? Qt : Qnil);
74 }
75
76 static Lisp_Object
77 check_case_table (Lisp_Object obj)
78 {
79 REGISTER Lisp_Object tem;
80
81 while (tem = Fcase_table_p (obj), NILP (tem))
82 obj = wrong_type_argument (Qcase_table_p, obj);
83 return (obj);
84 }
85
86 DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table,
87 0, 1, 0 /*
88 Return the case table of BUFFER, which defaults to the current buffer.
89 */ )
90 (buffer)
91 Lisp_Object buffer;
92 {
93 Lisp_Object down, up, canon, eqv;
94 struct buffer *buf = decode_buffer (buffer, 0);
95
96 down = buf->downcase_table;
97 up = buf->upcase_table;
98 canon = buf->case_canon_table;
99 eqv = buf->case_eqv_table;
100
101 return Fcons (down, Fcons (up, Fcons (canon, Fcons (eqv, Qnil))));
102 }
103
104 DEFUN ("standard-case-table", Fstandard_case_table,
105 Sstandard_case_table, 0, 0, 0 /*
106 Return the standard case table.
107 This is the one used for new buffers.
108 */ )
109 ()
110 {
111 return Fcons (Vascii_downcase_table,
112 Fcons (Vascii_upcase_table,
113 Fcons (Vascii_canon_table,
114 Fcons (Vascii_eqv_table,
115 Qnil))));
116 }
117
118 static Lisp_Object set_case_table (Lisp_Object table, int standard);
119
120
121 DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0 /*
122 Select a new case table for the current buffer.
123 A case table is a list (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)
124 where each element is either nil or a string of length 256.
125 DOWNCASE maps each character to its lower-case equivalent.
126 UPCASE maps each character to its upper-case equivalent;
127 if lower and upper case characters are in 1-1 correspondence,
128 you may use nil and the upcase table will be deduced from DOWNCASE.
129 CANONICALIZE maps each character to a canonical equivalent;
130 any two characters that are related by case-conversion have the same
131 canonical equivalent character; it may be nil, in which case it is
132 deduced from DOWNCASE and UPCASE.
133 EQUIVALENCES is a map that cyclicly permutes each equivalence class
134 (of characters with the same canonical equivalent); it may be nil,
135 in which case it is deduced from CANONICALIZE.
136 */ )
137 (table)
138 Lisp_Object table;
139 {
140 return set_case_table (table, 0);
141 }
142
143 DEFUN ("set-standard-case-table",
144 Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0 /*
145 Select a new standard case table for new buffers.
146 See `set-case-table' for more info on case tables.
147 */ )
148 (table)
149 Lisp_Object table;
150 {
151 return set_case_table (table, 1);
152 }
153
154 static Lisp_Object
155 set_case_table (Lisp_Object table, int standard)
156 {
157 Lisp_Object down, up, canon, eqv;
158 struct buffer *buf = current_buffer;
159
160 check_case_table (table);
161
162 down = Fcar_safe (table);
163 up = Fcar_safe (Fcdr_safe (table));
164 canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
165 eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
166
167 if (NILP (up))
168 {
169 up = MAKE_TRT_TABLE ();
170 compute_trt_inverse (down, up);
171 }
172
173 if (NILP (canon))
174 {
175 REGISTER Charcount i;
176
177 canon = MAKE_TRT_TABLE ();
178
179 /* Set up the CANON vector; for each character,
180 this sequence of upcasing and downcasing ought to
181 get the "preferred" lowercase equivalent. */
182 for (i = 0; i < 256; i++)
183 SET_TRT_TABLE_CHAR_1 (canon, i,
184 TRT_TABLE_CHAR_1
185 (down,
186 TRT_TABLE_CHAR_1
187 (up,
188 TRT_TABLE_CHAR_1 (down, i))));
189 }
190
191 if (NILP (eqv))
192 {
193 eqv = MAKE_TRT_TABLE ();
194
195 compute_trt_inverse (canon, eqv);
196 }
197
198 if (standard)
199 {
200 Vascii_downcase_table = down;
201 Vascii_upcase_table = up;
202 Vascii_canon_table = canon;
203 Vascii_eqv_table = eqv;
204 }
205 else
206 {
207 buf->downcase_table = down;
208 buf->upcase_table = up;
209 buf->case_canon_table = canon;
210 buf->case_eqv_table = eqv;
211 }
212 return table;
213 }
214
215 /* Given a translate table TRT, store the inverse mapping into INVERSE.
216 Since TRT is not one-to-one, INVERSE is not a simple mapping.
217 Instead, it divides the space of characters into equivalence classes.
218 All characters in a given class form one circular list, chained through
219 the elements of INVERSE. */
220
221 static void
222 compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse)
223 {
224 Charcount i = 0400;
225 Emchar c, q;
226
227 while (--i)
228 SET_TRT_TABLE_CHAR_1 (inverse, i, (Emchar) i);
229 i = 0400;
230 while (--i)
231 {
232 if ((q = TRT_TABLE_CHAR_1 (trt, i)) != (Emchar) i)
233 {
234 c = TRT_TABLE_CHAR_1 (inverse, q);
235 SET_TRT_TABLE_CHAR_1 (inverse, q, (Emchar) i);
236 SET_TRT_TABLE_CHAR_1 (inverse, i, c);
237 }
238 }
239 }
240
241
242 void
243 syms_of_casetab (void)
244 {
245 defsymbol (&Qcase_table_p, "case-table-p");
246 defsymbol (&Qtranslate_table, "translate-table");
247
248 defsubr (&Scase_table_p);
249 defsubr (&Scurrent_case_table);
250 defsubr (&Sstandard_case_table);
251 defsubr (&Sset_case_table);
252 defsubr (&Sset_standard_case_table);
253 }
254
255 void
256 complex_vars_of_casetab (void)
257 {
258 REGISTER Emchar i;
259 Lisp_Object tem;
260
261 staticpro (&Vascii_downcase_table);
262 staticpro (&Vascii_upcase_table);
263 staticpro (&Vascii_canon_table);
264 staticpro (&Vascii_eqv_table);
265
266 tem = MAKE_TRT_TABLE ();
267 Vascii_downcase_table = tem;
268 Vascii_canon_table = tem;
269
270 /* Under Mule, can't do set_string_char() until Vcharset_control_1
271 and Vcharset_ascii are initialized. */
272 for (i = 0; i < 256; i++)
273 {
274 unsigned char lowered = tolower (i);
275
276 SET_TRT_TABLE_CHAR_1 (tem, i, lowered);
277 }
278
279 tem = MAKE_TRT_TABLE ();
280 Vascii_upcase_table = tem;
281 Vascii_eqv_table = tem;
282
283 for (i = 0; i < 256; i++)
284 {
285 unsigned char flipped = (isupper (i) ? tolower (i)
286 : (islower (i) ? toupper (i) : i));
287
288 SET_TRT_TABLE_CHAR_1 (tem, i, flipped);
289 }
290
291 }