|
428
|
1 /* XEmacs routines to deal with char tables.
|
|
|
2 Copyright (C) 1992, 1995 Free Software Foundation, Inc.
|
|
|
3 Copyright (C) 1995 Sun Microsystems, Inc.
|
|
788
|
4 Copyright (C) 1995, 1996, 2002 Ben Wing.
|
|
428
|
5 Copyright (C) 1995, 1997, 1999 Electrotechnical Laboratory, JAPAN.
|
|
|
6 Licensed to the Free Software Foundation.
|
|
|
7
|
|
|
8 This file is part of XEmacs.
|
|
|
9
|
|
|
10 XEmacs is free software; you can redistribute it and/or modify it
|
|
|
11 under the terms of the GNU General Public License as published by the
|
|
|
12 Free Software Foundation; either version 2, or (at your option) any
|
|
|
13 later version.
|
|
|
14
|
|
|
15 XEmacs is distributed in the hope that it will be useful, but WITHOUT
|
|
|
16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
|
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
|
18 for more details.
|
|
|
19
|
|
|
20 You should have received a copy of the GNU General Public License
|
|
|
21 along with XEmacs; see the file COPYING. If not, write to
|
|
|
22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
23 Boston, MA 02111-1307, USA. */
|
|
|
24
|
|
|
25 /* Synched up with: Mule 2.3. Not synched with FSF.
|
|
|
26
|
|
|
27 This file was written independently of the FSF implementation,
|
|
|
28 and is not compatible. */
|
|
|
29
|
|
|
30 /* Authorship:
|
|
|
31
|
|
|
32 Ben Wing: wrote, for 19.13 (Mule). Some category table stuff
|
|
|
33 loosely based on the original Mule.
|
|
|
34 Jareth Hein: fixed a couple of bugs in the implementation, and
|
|
|
35 added regex support for categories with check_category_at
|
|
|
36 */
|
|
|
37
|
|
|
38 #include <config.h>
|
|
|
39 #include "lisp.h"
|
|
|
40
|
|
|
41 #include "buffer.h"
|
|
|
42 #include "chartab.h"
|
|
|
43 #include "syntax.h"
|
|
|
44
|
|
|
45 Lisp_Object Qchar_tablep, Qchar_table;
|
|
|
46
|
|
|
47 Lisp_Object Vall_syntax_tables;
|
|
|
48
|
|
|
49 #ifdef MULE
|
|
|
50 Lisp_Object Qcategory_table_p;
|
|
|
51 Lisp_Object Qcategory_designator_p;
|
|
|
52 Lisp_Object Qcategory_table_value_p;
|
|
|
53
|
|
|
54 Lisp_Object Vstandard_category_table;
|
|
|
55
|
|
|
56 /* Variables to determine word boundary. */
|
|
|
57 Lisp_Object Vword_combining_categories, Vword_separating_categories;
|
|
|
58 #endif /* MULE */
|
|
|
59
|
|
826
|
60 static int check_valid_char_table_value (Lisp_Object value,
|
|
|
61 enum char_table_type type,
|
|
|
62 Error_Behavior errb);
|
|
|
63
|
|
428
|
64
|
|
|
65 /* A char table maps from ranges of characters to values.
|
|
|
66
|
|
|
67 Implementing a general data structure that maps from arbitrary
|
|
|
68 ranges of numbers to values is tricky to do efficiently. As it
|
|
|
69 happens, it should suffice (and is usually more convenient, anyway)
|
|
|
70 when dealing with characters to restrict the sorts of ranges that
|
|
|
71 can be assigned values, as follows:
|
|
|
72
|
|
|
73 1) All characters.
|
|
|
74 2) All characters in a charset.
|
|
|
75 3) All characters in a particular row of a charset, where a "row"
|
|
|
76 means all characters with the same first byte.
|
|
|
77 4) A particular character in a charset.
|
|
|
78
|
|
|
79 We use char tables to generalize the 256-element vectors now
|
|
|
80 littering the Emacs code.
|
|
|
81
|
|
|
82 Possible uses (all should be converted at some point):
|
|
|
83
|
|
|
84 1) category tables
|
|
|
85 2) syntax tables
|
|
|
86 3) display tables
|
|
|
87 4) case tables
|
|
|
88 5) keyboard-translate-table?
|
|
|
89
|
|
|
90 We provide an
|
|
|
91 abstract type to generalize the Emacs vectors and Mule
|
|
|
92 vectors-of-vectors goo.
|
|
|
93 */
|
|
|
94
|
|
|
95 /************************************************************************/
|
|
|
96 /* Char Table object */
|
|
|
97 /************************************************************************/
|
|
|
98
|
|
|
99 #ifdef MULE
|
|
|
100
|
|
|
101 static Lisp_Object
|
|
|
102 mark_char_table_entry (Lisp_Object obj)
|
|
|
103 {
|
|
440
|
104 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
|
|
428
|
105 int i;
|
|
|
106
|
|
|
107 for (i = 0; i < 96; i++)
|
|
|
108 {
|
|
|
109 mark_object (cte->level2[i]);
|
|
|
110 }
|
|
|
111 return Qnil;
|
|
|
112 }
|
|
|
113
|
|
|
114 static int
|
|
|
115 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
|
|
|
116 {
|
|
440
|
117 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1);
|
|
|
118 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2);
|
|
428
|
119 int i;
|
|
|
120
|
|
|
121 for (i = 0; i < 96; i++)
|
|
|
122 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1))
|
|
|
123 return 0;
|
|
|
124
|
|
|
125 return 1;
|
|
|
126 }
|
|
|
127
|
|
665
|
128 static Hashcode
|
|
428
|
129 char_table_entry_hash (Lisp_Object obj, int depth)
|
|
|
130 {
|
|
440
|
131 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj);
|
|
428
|
132
|
|
826
|
133 return internal_array_hash (cte->level2, 96, depth + 1);
|
|
428
|
134 }
|
|
|
135
|
|
|
136 static const struct lrecord_description char_table_entry_description[] = {
|
|
440
|
137 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 },
|
|
428
|
138 { XD_END }
|
|
|
139 };
|
|
|
140
|
|
|
141 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry,
|
|
|
142 mark_char_table_entry, internal_object_printer,
|
|
|
143 0, char_table_entry_equal,
|
|
|
144 char_table_entry_hash,
|
|
|
145 char_table_entry_description,
|
|
440
|
146 Lisp_Char_Table_Entry);
|
|
428
|
147 #endif /* MULE */
|
|
|
148
|
|
|
149 static Lisp_Object
|
|
|
150 mark_char_table (Lisp_Object obj)
|
|
|
151 {
|
|
440
|
152 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
|
|
428
|
153 int i;
|
|
|
154
|
|
|
155 for (i = 0; i < NUM_ASCII_CHARS; i++)
|
|
|
156 mark_object (ct->ascii[i]);
|
|
|
157 #ifdef MULE
|
|
|
158 for (i = 0; i < NUM_LEADING_BYTES; i++)
|
|
|
159 mark_object (ct->level1[i]);
|
|
|
160 #endif
|
|
793
|
161 mark_object (ct->parent);
|
|
|
162 mark_object (ct->default_);
|
|
428
|
163 return ct->mirror_table;
|
|
|
164 }
|
|
|
165
|
|
|
166 /* WARNING: All functions of this nature need to be written extremely
|
|
|
167 carefully to avoid crashes during GC. Cf. prune_specifiers()
|
|
|
168 and prune_weak_hash_tables(). */
|
|
|
169
|
|
|
170 void
|
|
|
171 prune_syntax_tables (void)
|
|
|
172 {
|
|
|
173 Lisp_Object rest, prev = Qnil;
|
|
|
174
|
|
|
175 for (rest = Vall_syntax_tables;
|
|
|
176 !NILP (rest);
|
|
|
177 rest = XCHAR_TABLE (rest)->next_table)
|
|
|
178 {
|
|
|
179 if (! marked_p (rest))
|
|
|
180 {
|
|
|
181 /* This table is garbage. Remove it from the list. */
|
|
|
182 if (NILP (prev))
|
|
|
183 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table;
|
|
|
184 else
|
|
|
185 XCHAR_TABLE (prev)->next_table =
|
|
|
186 XCHAR_TABLE (rest)->next_table;
|
|
|
187 }
|
|
|
188 }
|
|
|
189 }
|
|
|
190
|
|
|
191 static Lisp_Object
|
|
|
192 char_table_type_to_symbol (enum char_table_type type)
|
|
|
193 {
|
|
|
194 switch (type)
|
|
|
195 {
|
|
|
196 default: abort();
|
|
|
197 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
|
|
|
198 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
|
|
|
199 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
|
|
|
200 case CHAR_TABLE_TYPE_CHAR: return Qchar;
|
|
|
201 #ifdef MULE
|
|
|
202 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
|
|
|
203 #endif
|
|
|
204 }
|
|
|
205 }
|
|
|
206
|
|
|
207 static enum char_table_type
|
|
|
208 symbol_to_char_table_type (Lisp_Object symbol)
|
|
|
209 {
|
|
|
210 CHECK_SYMBOL (symbol);
|
|
|
211
|
|
|
212 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC;
|
|
|
213 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX;
|
|
|
214 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY;
|
|
|
215 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR;
|
|
|
216 #ifdef MULE
|
|
|
217 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY;
|
|
|
218 #endif
|
|
|
219
|
|
563
|
220 invalid_constant ("Unrecognized char table type", symbol);
|
|
801
|
221 RETURN_NOT_REACHED (CHAR_TABLE_TYPE_GENERIC)
|
|
428
|
222 }
|
|
|
223
|
|
|
224 static void
|
|
826
|
225 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
|
|
428
|
226 {
|
|
826
|
227 if (EQ (range, Qt))
|
|
|
228 outrange->type = CHARTAB_RANGE_ALL;
|
|
|
229 else if (CHAR_OR_CHAR_INTP (range))
|
|
|
230 {
|
|
|
231 outrange->type = CHARTAB_RANGE_CHAR;
|
|
|
232 outrange->ch = XCHAR_OR_CHAR_INT (range);
|
|
|
233 }
|
|
|
234 #ifndef MULE
|
|
428
|
235 else
|
|
826
|
236 sferror ("Range must be t or a character", range);
|
|
|
237 #else /* MULE */
|
|
|
238 else if (VECTORP (range))
|
|
|
239 {
|
|
|
240 Lisp_Vector *vec = XVECTOR (range);
|
|
|
241 Lisp_Object *elts = vector_data (vec);
|
|
|
242 if (vector_length (vec) != 2)
|
|
|
243 sferror ("Length of charset row vector must be 2",
|
|
|
244 range);
|
|
|
245 outrange->type = CHARTAB_RANGE_ROW;
|
|
|
246 outrange->charset = Fget_charset (elts[0]);
|
|
|
247 CHECK_INT (elts[1]);
|
|
|
248 outrange->row = XINT (elts[1]);
|
|
|
249 switch (XCHARSET_TYPE (outrange->charset))
|
|
|
250 {
|
|
|
251 case CHARSET_TYPE_94:
|
|
|
252 case CHARSET_TYPE_96:
|
|
|
253 sferror ("Charset in row vector must be multi-byte",
|
|
|
254 outrange->charset);
|
|
|
255 case CHARSET_TYPE_94X94:
|
|
|
256 check_int_range (outrange->row, 33, 126);
|
|
|
257 break;
|
|
|
258 case CHARSET_TYPE_96X96:
|
|
|
259 check_int_range (outrange->row, 32, 127);
|
|
|
260 break;
|
|
|
261 default:
|
|
|
262 abort ();
|
|
|
263 }
|
|
|
264 }
|
|
|
265 else
|
|
|
266 {
|
|
|
267 if (!CHARSETP (range) && !SYMBOLP (range))
|
|
|
268 sferror
|
|
|
269 ("Char table range must be t, charset, char, or vector", range);
|
|
|
270 outrange->type = CHARTAB_RANGE_CHARSET;
|
|
|
271 outrange->charset = Fget_charset (range);
|
|
|
272 }
|
|
|
273 #endif /* MULE */
|
|
428
|
274 }
|
|
|
275
|
|
826
|
276 static Lisp_Object
|
|
|
277 encode_char_table_range (struct chartab_range *range)
|
|
428
|
278 {
|
|
826
|
279 switch (range->type)
|
|
428
|
280 {
|
|
826
|
281 case CHARTAB_RANGE_ALL:
|
|
|
282 return Qt;
|
|
|
283
|
|
|
284 #ifdef MULE
|
|
|
285 case CHARTAB_RANGE_CHARSET:
|
|
|
286 return XCHARSET_NAME (Fget_charset (range->charset));
|
|
428
|
287
|
|
826
|
288 case CHARTAB_RANGE_ROW:
|
|
|
289 return vector2 (XCHARSET_NAME (Fget_charset (range->charset)),
|
|
|
290 make_int (range->row));
|
|
|
291 #endif
|
|
|
292 case CHARTAB_RANGE_CHAR:
|
|
|
293 return make_char (range->ch);
|
|
|
294 default:
|
|
|
295 abort ();
|
|
428
|
296 }
|
|
826
|
297 return Qnil; /* not reached */
|
|
428
|
298 }
|
|
|
299
|
|
826
|
300 struct ptemap
|
|
428
|
301 {
|
|
826
|
302 Lisp_Object printcharfun;
|
|
|
303 int first;
|
|
|
304 };
|
|
428
|
305
|
|
826
|
306 static int
|
|
|
307 print_table_entry (struct chartab_range *range, Lisp_Object table,
|
|
|
308 Lisp_Object val, void *arg)
|
|
|
309 {
|
|
|
310 struct ptemap *a = (struct ptemap *) arg;
|
|
|
311 struct gcpro gcpro1;
|
|
|
312 Lisp_Object lisprange;
|
|
|
313 if (!a->first)
|
|
|
314 write_c_string (a->printcharfun, " ");
|
|
|
315 a->first = 0;
|
|
|
316 lisprange = encode_char_table_range (range);
|
|
|
317 GCPRO1 (lisprange);
|
|
|
318 write_fmt_string_lisp (a->printcharfun, "%s %s", 2, lisprange, val);
|
|
|
319 UNGCPRO;
|
|
|
320 return 0;
|
|
428
|
321 }
|
|
|
322
|
|
|
323 static void
|
|
|
324 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
|
|
|
325 {
|
|
440
|
326 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
|
|
826
|
327 struct chartab_range range;
|
|
|
328 struct ptemap arg;
|
|
|
329
|
|
|
330 range.type = CHARTAB_RANGE_ALL;
|
|
|
331 arg.printcharfun = printcharfun;
|
|
|
332 arg.first = 1;
|
|
428
|
333
|
|
793
|
334 write_fmt_string_lisp (printcharfun, "#s(char-table type %s data (",
|
|
|
335 1, char_table_type_to_symbol (ct->type));
|
|
826
|
336 map_char_table (obj, &range, print_table_entry, &arg);
|
|
|
337 write_c_string (printcharfun, "))");
|
|
428
|
338
|
|
826
|
339 /* #### need to print and read the default; but that will allow the
|
|
|
340 default to be modified, which we don't (yet) support -- but FSF does */
|
|
428
|
341 }
|
|
|
342
|
|
|
343 static int
|
|
|
344 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
|
|
|
345 {
|
|
440
|
346 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1);
|
|
|
347 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2);
|
|
428
|
348 int i;
|
|
|
349
|
|
|
350 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2))
|
|
|
351 return 0;
|
|
|
352
|
|
|
353 for (i = 0; i < NUM_ASCII_CHARS; i++)
|
|
|
354 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1))
|
|
|
355 return 0;
|
|
|
356
|
|
|
357 #ifdef MULE
|
|
|
358 for (i = 0; i < NUM_LEADING_BYTES; i++)
|
|
|
359 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1))
|
|
|
360 return 0;
|
|
|
361 #endif /* MULE */
|
|
|
362
|
|
826
|
363 return internal_equal (ct1->default_, ct2->default_, depth + 1);
|
|
428
|
364 }
|
|
|
365
|
|
665
|
366 static Hashcode
|
|
428
|
367 char_table_hash (Lisp_Object obj, int depth)
|
|
|
368 {
|
|
440
|
369 Lisp_Char_Table *ct = XCHAR_TABLE (obj);
|
|
665
|
370 Hashcode hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS,
|
|
826
|
371 depth + 1);
|
|
428
|
372 #ifdef MULE
|
|
|
373 hashval = HASH2 (hashval,
|
|
826
|
374 internal_array_hash (ct->level1, NUM_LEADING_BYTES,
|
|
|
375 depth + 1));
|
|
428
|
376 #endif /* MULE */
|
|
826
|
377 return HASH2 (hashval, internal_hash (ct->default_, depth + 1));
|
|
428
|
378 }
|
|
|
379
|
|
|
380 static const struct lrecord_description char_table_description[] = {
|
|
440
|
381 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS },
|
|
428
|
382 #ifdef MULE
|
|
440
|
383 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES },
|
|
428
|
384 #endif
|
|
793
|
385 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, parent) },
|
|
|
386 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, default_) },
|
|
440
|
387 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) },
|
|
|
388 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) },
|
|
428
|
389 { XD_END }
|
|
|
390 };
|
|
|
391
|
|
|
392 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table,
|
|
|
393 mark_char_table, print_char_table, 0,
|
|
|
394 char_table_equal, char_table_hash,
|
|
|
395 char_table_description,
|
|
440
|
396 Lisp_Char_Table);
|
|
428
|
397
|
|
|
398 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /*
|
|
|
399 Return non-nil if OBJECT is a char table.
|
|
|
400 */
|
|
|
401 (object))
|
|
|
402 {
|
|
|
403 return CHAR_TABLEP (object) ? Qt : Qnil;
|
|
|
404 }
|
|
|
405
|
|
|
406 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /*
|
|
|
407 Return a list of the recognized char table types.
|
|
800
|
408 See `make-char-table'.
|
|
428
|
409 */
|
|
|
410 ())
|
|
|
411 {
|
|
|
412 #ifdef MULE
|
|
|
413 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax);
|
|
|
414 #else
|
|
|
415 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax);
|
|
|
416 #endif
|
|
|
417 }
|
|
|
418
|
|
|
419 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /*
|
|
|
420 Return t if TYPE if a recognized char table type.
|
|
800
|
421 See `make-char-table'.
|
|
428
|
422 */
|
|
|
423 (type))
|
|
|
424 {
|
|
|
425 return (EQ (type, Qchar) ||
|
|
|
426 #ifdef MULE
|
|
|
427 EQ (type, Qcategory) ||
|
|
|
428 #endif
|
|
|
429 EQ (type, Qdisplay) ||
|
|
|
430 EQ (type, Qgeneric) ||
|
|
|
431 EQ (type, Qsyntax)) ? Qt : Qnil;
|
|
|
432 }
|
|
|
433
|
|
|
434 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /*
|
|
444
|
435 Return the type of CHAR-TABLE.
|
|
800
|
436 See `make-char-table'.
|
|
428
|
437 */
|
|
444
|
438 (char_table))
|
|
428
|
439 {
|
|
444
|
440 CHECK_CHAR_TABLE (char_table);
|
|
|
441 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type);
|
|
428
|
442 }
|
|
|
443
|
|
|
444 void
|
|
826
|
445 set_char_table_default (Lisp_Object table, Lisp_Object value)
|
|
|
446 {
|
|
|
447 Lisp_Char_Table *ct = XCHAR_TABLE (table);
|
|
|
448 ct->default_ = value;
|
|
|
449 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
|
|
|
450 update_syntax_table (table);
|
|
|
451 }
|
|
|
452
|
|
|
453 static void
|
|
440
|
454 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value)
|
|
428
|
455 {
|
|
|
456 int i;
|
|
|
457
|
|
|
458 for (i = 0; i < NUM_ASCII_CHARS; i++)
|
|
|
459 ct->ascii[i] = value;
|
|
|
460 #ifdef MULE
|
|
|
461 for (i = 0; i < NUM_LEADING_BYTES; i++)
|
|
|
462 ct->level1[i] = value;
|
|
|
463 #endif /* MULE */
|
|
|
464
|
|
|
465 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
|
|
826
|
466 update_syntax_table (wrap_char_table (ct));
|
|
428
|
467 }
|
|
|
468
|
|
|
469 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /*
|
|
444
|
470 Reset CHAR-TABLE to its default state.
|
|
428
|
471 */
|
|
444
|
472 (char_table))
|
|
428
|
473 {
|
|
440
|
474 Lisp_Char_Table *ct;
|
|
826
|
475 Lisp_Object def;
|
|
428
|
476
|
|
444
|
477 CHECK_CHAR_TABLE (char_table);
|
|
|
478 ct = XCHAR_TABLE (char_table);
|
|
428
|
479
|
|
|
480 switch (ct->type)
|
|
|
481 {
|
|
|
482 case CHAR_TABLE_TYPE_CHAR:
|
|
826
|
483 def = make_char (0);
|
|
428
|
484 break;
|
|
|
485 case CHAR_TABLE_TYPE_DISPLAY:
|
|
|
486 case CHAR_TABLE_TYPE_GENERIC:
|
|
|
487 #ifdef MULE
|
|
|
488 case CHAR_TABLE_TYPE_CATEGORY:
|
|
|
489 #endif /* MULE */
|
|
826
|
490 def = Qnil;
|
|
428
|
491 break;
|
|
|
492
|
|
|
493 case CHAR_TABLE_TYPE_SYNTAX:
|
|
826
|
494 def = make_int (Sinherit);
|
|
428
|
495 break;
|
|
|
496
|
|
|
497 default:
|
|
|
498 abort ();
|
|
826
|
499 def = Qnil;
|
|
|
500 break;
|
|
428
|
501 }
|
|
|
502
|
|
826
|
503 /* Avoid doubly updating the syntax table by setting the default ourselves,
|
|
|
504 since set_char_table_default() also updates. */
|
|
|
505 ct->default_ = def;
|
|
|
506 fill_char_table (ct, Qunbound);
|
|
|
507
|
|
428
|
508 return Qnil;
|
|
|
509 }
|
|
|
510
|
|
|
511 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /*
|
|
|
512 Return a new, empty char table of type TYPE.
|
|
800
|
513
|
|
|
514 A char table is a table that maps characters (or ranges of characters)
|
|
|
515 to values. Char tables are specialized for characters, only allowing
|
|
|
516 particular sorts of ranges to be assigned values. Although this
|
|
|
517 loses in generality, it makes for extremely fast (constant-time)
|
|
|
518 lookups, and thus is feasible for applications that do an extremely
|
|
|
519 large number of lookups (e.g. scanning a buffer for a character in
|
|
|
520 a particular syntax, where a lookup in the syntax table must occur
|
|
|
521 once per character).
|
|
|
522
|
|
|
523 When Mule support exists, the types of ranges that can be assigned
|
|
|
524 values are
|
|
|
525
|
|
|
526 -- all characters
|
|
|
527 -- an entire charset
|
|
|
528 -- a single row in a two-octet charset
|
|
|
529 -- a single character
|
|
|
530
|
|
|
531 When Mule support is not present, the types of ranges that can be
|
|
|
532 assigned values are
|
|
|
533
|
|
|
534 -- all characters
|
|
|
535 -- a single character
|
|
|
536
|
|
|
537 To create a char table, use `make-char-table'.
|
|
|
538 To modify a char table, use `put-char-table' or `remove-char-table'.
|
|
|
539 To retrieve the value for a particular character, use `get-char-table'.
|
|
826
|
540 See also `map-char-table', `reset-char-table', `copy-char-table',
|
|
800
|
541 `char-table-p', `valid-char-table-type-p', `char-table-type-list',
|
|
|
542 `valid-char-table-value-p', and `check-char-table-value'.
|
|
|
543
|
|
|
544 Each char table type is used for a different purpose and allows different
|
|
|
545 sorts of values. The different char table types are
|
|
|
546
|
|
|
547 `category'
|
|
|
548 Used for category tables, which specify the regexp categories
|
|
|
549 that a character is in. The valid values are nil or a
|
|
|
550 bit vector of 95 elements. Higher-level Lisp functions are
|
|
|
551 provided for working with category tables. Currently categories
|
|
|
552 and category tables only exist when Mule support is present.
|
|
|
553 `char'
|
|
|
554 A generalized char table, for mapping from one character to
|
|
|
555 another. Used for case tables, syntax matching tables,
|
|
|
556 `keyboard-translate-table', etc. The valid values are characters.
|
|
|
557 `generic'
|
|
|
558 An even more generalized char table, for mapping from a
|
|
|
559 character to anything.
|
|
|
560 `display'
|
|
|
561 Used for display tables, which specify how a particular character
|
|
|
562 is to appear when displayed. #### Not yet implemented.
|
|
|
563 `syntax'
|
|
|
564 Used for syntax tables, which specify the syntax of a particular
|
|
|
565 character. Higher-level Lisp functions are provided for
|
|
|
566 working with syntax tables. The valid values are integers.
|
|
428
|
567 */
|
|
|
568 (type))
|
|
|
569 {
|
|
440
|
570 Lisp_Char_Table *ct;
|
|
428
|
571 Lisp_Object obj;
|
|
|
572 enum char_table_type ty = symbol_to_char_table_type (type);
|
|
|
573
|
|
440
|
574 ct = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
|
|
428
|
575 ct->type = ty;
|
|
|
576 if (ty == CHAR_TABLE_TYPE_SYNTAX)
|
|
|
577 {
|
|
826
|
578 /* Qgeneric not Qsyntax because a syntax table has a mirror table
|
|
|
579 and we don't want infinite recursion */
|
|
428
|
580 ct->mirror_table = Fmake_char_table (Qgeneric);
|
|
826
|
581 set_char_table_default (ct->mirror_table, make_int (Spunct));
|
|
428
|
582 }
|
|
|
583 else
|
|
|
584 ct->mirror_table = Qnil;
|
|
|
585 ct->next_table = Qnil;
|
|
793
|
586 ct->parent = Qnil;
|
|
|
587 ct->default_ = Qnil;
|
|
|
588 obj = wrap_char_table (ct);
|
|
428
|
589 if (ty == CHAR_TABLE_TYPE_SYNTAX)
|
|
|
590 {
|
|
|
591 ct->next_table = Vall_syntax_tables;
|
|
|
592 Vall_syntax_tables = obj;
|
|
|
593 }
|
|
|
594 Freset_char_table (obj);
|
|
|
595 return obj;
|
|
|
596 }
|
|
|
597
|
|
|
598 #ifdef MULE
|
|
|
599
|
|
|
600 static Lisp_Object
|
|
|
601 make_char_table_entry (Lisp_Object initval)
|
|
|
602 {
|
|
|
603 int i;
|
|
440
|
604 Lisp_Char_Table_Entry *cte =
|
|
|
605 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
|
|
428
|
606
|
|
|
607 for (i = 0; i < 96; i++)
|
|
|
608 cte->level2[i] = initval;
|
|
|
609
|
|
793
|
610 return wrap_char_table_entry (cte);
|
|
428
|
611 }
|
|
|
612
|
|
|
613 static Lisp_Object
|
|
|
614 copy_char_table_entry (Lisp_Object entry)
|
|
|
615 {
|
|
440
|
616 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
|
|
428
|
617 int i;
|
|
440
|
618 Lisp_Char_Table_Entry *ctenew =
|
|
|
619 alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
|
|
428
|
620
|
|
|
621 for (i = 0; i < 96; i++)
|
|
|
622 {
|
|
|
623 Lisp_Object new = cte->level2[i];
|
|
|
624 if (CHAR_TABLE_ENTRYP (new))
|
|
|
625 ctenew->level2[i] = copy_char_table_entry (new);
|
|
|
626 else
|
|
|
627 ctenew->level2[i] = new;
|
|
|
628 }
|
|
|
629
|
|
793
|
630 return wrap_char_table_entry (ctenew);
|
|
428
|
631 }
|
|
|
632
|
|
|
633 #endif /* MULE */
|
|
|
634
|
|
|
635 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
|
|
444
|
636 Return a new char table which is a copy of CHAR-TABLE.
|
|
428
|
637 It will contain the same values for the same characters and ranges
|
|
444
|
638 as CHAR-TABLE. The values will not themselves be copied.
|
|
428
|
639 */
|
|
444
|
640 (char_table))
|
|
428
|
641 {
|
|
440
|
642 Lisp_Char_Table *ct, *ctnew;
|
|
428
|
643 Lisp_Object obj;
|
|
|
644 int i;
|
|
|
645
|
|
444
|
646 CHECK_CHAR_TABLE (char_table);
|
|
|
647 ct = XCHAR_TABLE (char_table);
|
|
440
|
648 ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
|
|
428
|
649 ctnew->type = ct->type;
|
|
793
|
650 ctnew->parent = ct->parent;
|
|
|
651 ctnew->default_ = ct->default_;
|
|
428
|
652
|
|
|
653 for (i = 0; i < NUM_ASCII_CHARS; i++)
|
|
|
654 {
|
|
|
655 Lisp_Object new = ct->ascii[i];
|
|
|
656 #ifdef MULE
|
|
|
657 assert (! (CHAR_TABLE_ENTRYP (new)));
|
|
|
658 #endif /* MULE */
|
|
|
659 ctnew->ascii[i] = new;
|
|
|
660 }
|
|
|
661
|
|
|
662 #ifdef MULE
|
|
|
663
|
|
|
664 for (i = 0; i < NUM_LEADING_BYTES; i++)
|
|
|
665 {
|
|
|
666 Lisp_Object new = ct->level1[i];
|
|
|
667 if (CHAR_TABLE_ENTRYP (new))
|
|
|
668 ctnew->level1[i] = copy_char_table_entry (new);
|
|
|
669 else
|
|
|
670 ctnew->level1[i] = new;
|
|
|
671 }
|
|
|
672
|
|
|
673 #endif /* MULE */
|
|
|
674
|
|
|
675 if (CHAR_TABLEP (ct->mirror_table))
|
|
|
676 ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
|
|
|
677 else
|
|
|
678 ctnew->mirror_table = ct->mirror_table;
|
|
|
679 ctnew->next_table = Qnil;
|
|
793
|
680 obj = wrap_char_table (ctnew);
|
|
428
|
681 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
|
|
|
682 {
|
|
|
683 ctnew->next_table = Vall_syntax_tables;
|
|
|
684 Vall_syntax_tables = obj;
|
|
|
685 }
|
|
|
686 return obj;
|
|
|
687 }
|
|
|
688
|
|
|
689 #ifdef MULE
|
|
|
690
|
|
826
|
691 /* called from get_char_table(). */
|
|
428
|
692 Lisp_Object
|
|
440
|
693 get_non_ascii_char_table_value (Lisp_Char_Table *ct, int leading_byte,
|
|
867
|
694 Ichar c)
|
|
428
|
695 {
|
|
|
696 Lisp_Object val;
|
|
826
|
697 Lisp_Object charset = charset_by_leading_byte (leading_byte);
|
|
428
|
698 int byte1, byte2;
|
|
|
699
|
|
867
|
700 BREAKUP_ICHAR_1_UNSAFE (c, charset, byte1, byte2);
|
|
428
|
701 val = ct->level1[leading_byte - MIN_LEADING_BYTE];
|
|
|
702 if (CHAR_TABLE_ENTRYP (val))
|
|
|
703 {
|
|
440
|
704 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
|
|
428
|
705 val = cte->level2[byte1 - 32];
|
|
|
706 if (CHAR_TABLE_ENTRYP (val))
|
|
|
707 {
|
|
|
708 cte = XCHAR_TABLE_ENTRY (val);
|
|
|
709 assert (byte2 >= 32);
|
|
|
710 val = cte->level2[byte2 - 32];
|
|
|
711 assert (!CHAR_TABLE_ENTRYP (val));
|
|
|
712 }
|
|
|
713 }
|
|
|
714
|
|
|
715 return val;
|
|
|
716 }
|
|
|
717
|
|
|
718 #endif /* MULE */
|
|
|
719
|
|
826
|
720 DEFUN ("char-table-default", Fchar_table_default, 1, 1, 0, /*
|
|
|
721 Return the default value for CHAR-TABLE. When an entry for a character
|
|
|
722 does not exist, the default is returned.
|
|
|
723 */
|
|
|
724 (char_table))
|
|
428
|
725 {
|
|
826
|
726 CHECK_CHAR_TABLE (char_table);
|
|
|
727 return XCHAR_TABLE (char_table)->default_;
|
|
428
|
728 }
|
|
|
729
|
|
826
|
730 DEFUN ("set-char-table-default", Fset_char_table_default, 2, 2, 0, /*
|
|
|
731 Set the default value for CHAR-TABLE to DEFAULT.
|
|
|
732 Currently, the default value for syntax tables cannot be changed.
|
|
|
733 (This policy might change in the future.)
|
|
|
734 */
|
|
|
735 (char_table, default_))
|
|
|
736 {
|
|
|
737 CHECK_CHAR_TABLE (char_table);
|
|
|
738 if (XCHAR_TABLE_TYPE (char_table) == CHAR_TABLE_TYPE_SYNTAX)
|
|
|
739 invalid_change ("Can't change default for syntax tables", char_table);
|
|
|
740 check_valid_char_table_value (default_, XCHAR_TABLE_TYPE (char_table),
|
|
|
741 ERROR_ME);
|
|
|
742 set_char_table_default (char_table, default_);
|
|
|
743 return Qnil;
|
|
|
744 }
|
|
428
|
745
|
|
|
746 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
|
|
444
|
747 Find value for CHARACTER in CHAR-TABLE.
|
|
428
|
748 */
|
|
444
|
749 (character, char_table))
|
|
428
|
750 {
|
|
444
|
751 CHECK_CHAR_TABLE (char_table);
|
|
|
752 CHECK_CHAR_COERCE_INT (character);
|
|
428
|
753
|
|
826
|
754 return get_char_table (XCHAR (character), char_table);
|
|
|
755 }
|
|
|
756
|
|
|
757 static int
|
|
|
758 copy_mapper (struct chartab_range *range, Lisp_Object table,
|
|
|
759 Lisp_Object val, void *arg)
|
|
|
760 {
|
|
|
761 put_char_table (VOID_TO_LISP (arg), range, val);
|
|
|
762 return 0;
|
|
|
763 }
|
|
|
764
|
|
|
765 void
|
|
|
766 copy_char_table_range (Lisp_Object from, Lisp_Object to,
|
|
|
767 struct chartab_range *range)
|
|
|
768 {
|
|
|
769 map_char_table (from, range, copy_mapper, LISP_TO_VOID (to));
|
|
|
770 }
|
|
|
771
|
|
|
772 Lisp_Object
|
|
|
773 get_range_char_table (struct chartab_range *range, Lisp_Object table,
|
|
|
774 Lisp_Object multi)
|
|
|
775 {
|
|
|
776 Lisp_Char_Table *ct = XCHAR_TABLE (table);
|
|
|
777 Lisp_Object retval = Qnil;
|
|
|
778
|
|
|
779 switch (range->type)
|
|
|
780 {
|
|
|
781 case CHARTAB_RANGE_CHAR:
|
|
|
782 return get_char_table (range->ch, table);
|
|
|
783
|
|
|
784 case CHARTAB_RANGE_ALL:
|
|
|
785 {
|
|
|
786 int i;
|
|
|
787 retval = ct->ascii[0];
|
|
|
788
|
|
|
789 for (i = 1; i < NUM_ASCII_CHARS; i++)
|
|
|
790 if (!EQ (retval, ct->ascii[i]))
|
|
|
791 return multi;
|
|
|
792
|
|
|
793 #ifdef MULE
|
|
|
794 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
|
|
|
795 i++)
|
|
|
796 {
|
|
|
797 if (!CHARSETP (charset_by_leading_byte (i))
|
|
|
798 || i == LEADING_BYTE_ASCII
|
|
|
799 || i == LEADING_BYTE_CONTROL_1)
|
|
|
800 continue;
|
|
|
801 if (!EQ (retval, ct->level1[i - MIN_LEADING_BYTE]))
|
|
|
802 return multi;
|
|
|
803 }
|
|
|
804 #endif /* MULE */
|
|
|
805
|
|
|
806 break;
|
|
|
807 }
|
|
|
808
|
|
|
809 #ifdef MULE
|
|
|
810 case CHARTAB_RANGE_CHARSET:
|
|
|
811 if (EQ (range->charset, Vcharset_ascii))
|
|
|
812 {
|
|
|
813 int i;
|
|
|
814 retval = ct->ascii[0];
|
|
|
815
|
|
|
816 for (i = 1; i < 128; i++)
|
|
|
817 if (!EQ (retval, ct->ascii[i]))
|
|
|
818 return multi;
|
|
|
819 break;
|
|
|
820 }
|
|
|
821
|
|
|
822 if (EQ (range->charset, Vcharset_control_1))
|
|
|
823 {
|
|
|
824 int i;
|
|
|
825 retval = ct->ascii[128];
|
|
|
826
|
|
|
827 for (i = 129; i < 160; i++)
|
|
|
828 if (!EQ (retval, ct->ascii[i]))
|
|
|
829 return multi;
|
|
|
830 break;
|
|
|
831 }
|
|
|
832
|
|
|
833 {
|
|
|
834 retval = ct->level1[XCHARSET_LEADING_BYTE (range->charset) -
|
|
|
835 MIN_LEADING_BYTE];
|
|
|
836 if (CHAR_TABLE_ENTRYP (retval))
|
|
|
837 return multi;
|
|
|
838 break;
|
|
|
839 }
|
|
|
840
|
|
|
841 case CHARTAB_RANGE_ROW:
|
|
|
842 {
|
|
|
843 retval = ct->level1[XCHARSET_LEADING_BYTE (range->charset) -
|
|
|
844 MIN_LEADING_BYTE];
|
|
|
845 if (!CHAR_TABLE_ENTRYP (retval))
|
|
|
846 break;
|
|
|
847 retval = XCHAR_TABLE_ENTRY (retval)->level2[range->row - 32];
|
|
|
848 if (CHAR_TABLE_ENTRYP (retval))
|
|
|
849 return multi;
|
|
|
850 break;
|
|
|
851 }
|
|
|
852 #endif /* not MULE */
|
|
|
853
|
|
|
854 default:
|
|
|
855 abort ();
|
|
|
856 }
|
|
|
857
|
|
|
858 if (UNBOUNDP (retval))
|
|
|
859 return ct->default_;
|
|
|
860 return retval;
|
|
428
|
861 }
|
|
|
862
|
|
|
863 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
|
|
444
|
864 Find value for a range in CHAR-TABLE.
|
|
428
|
865 If there is more than one value, return MULTI (defaults to nil).
|
|
|
866 */
|
|
444
|
867 (range, char_table, multi))
|
|
428
|
868 {
|
|
|
869 struct chartab_range rainj;
|
|
|
870
|
|
|
871 if (CHAR_OR_CHAR_INTP (range))
|
|
444
|
872 return Fget_char_table (range, char_table);
|
|
|
873 CHECK_CHAR_TABLE (char_table);
|
|
428
|
874
|
|
|
875 decode_char_table_range (range, &rainj);
|
|
826
|
876 return get_range_char_table (&rainj, char_table, multi);
|
|
428
|
877 }
|
|
826
|
878
|
|
428
|
879 static int
|
|
|
880 check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
|
|
578
|
881 Error_Behavior errb)
|
|
428
|
882 {
|
|
|
883 switch (type)
|
|
|
884 {
|
|
|
885 case CHAR_TABLE_TYPE_SYNTAX:
|
|
|
886 if (!ERRB_EQ (errb, ERROR_ME))
|
|
|
887 return INTP (value) || (CONSP (value) && INTP (XCAR (value))
|
|
|
888 && CHAR_OR_CHAR_INTP (XCDR (value)));
|
|
|
889 if (CONSP (value))
|
|
|
890 {
|
|
|
891 Lisp_Object cdr = XCDR (value);
|
|
|
892 CHECK_INT (XCAR (value));
|
|
|
893 CHECK_CHAR_COERCE_INT (cdr);
|
|
|
894 }
|
|
|
895 else
|
|
|
896 CHECK_INT (value);
|
|
|
897 break;
|
|
|
898
|
|
|
899 #ifdef MULE
|
|
|
900 case CHAR_TABLE_TYPE_CATEGORY:
|
|
|
901 if (!ERRB_EQ (errb, ERROR_ME))
|
|
|
902 return CATEGORY_TABLE_VALUEP (value);
|
|
|
903 CHECK_CATEGORY_TABLE_VALUE (value);
|
|
|
904 break;
|
|
|
905 #endif /* MULE */
|
|
|
906
|
|
|
907 case CHAR_TABLE_TYPE_GENERIC:
|
|
|
908 return 1;
|
|
|
909
|
|
|
910 case CHAR_TABLE_TYPE_DISPLAY:
|
|
|
911 /* #### fix this */
|
|
563
|
912 maybe_signal_error (Qunimplemented,
|
|
|
913 "Display char tables not yet implemented",
|
|
|
914 value, Qchar_table, errb);
|
|
428
|
915 return 0;
|
|
|
916
|
|
|
917 case CHAR_TABLE_TYPE_CHAR:
|
|
|
918 if (!ERRB_EQ (errb, ERROR_ME))
|
|
|
919 return CHAR_OR_CHAR_INTP (value);
|
|
|
920 CHECK_CHAR_COERCE_INT (value);
|
|
|
921 break;
|
|
|
922
|
|
|
923 default:
|
|
|
924 abort ();
|
|
|
925 }
|
|
|
926
|
|
801
|
927 return 0; /* not (usually) reached */
|
|
428
|
928 }
|
|
|
929
|
|
|
930 static Lisp_Object
|
|
|
931 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
|
|
|
932 {
|
|
|
933 switch (type)
|
|
|
934 {
|
|
|
935 case CHAR_TABLE_TYPE_SYNTAX:
|
|
|
936 if (CONSP (value))
|
|
|
937 {
|
|
|
938 Lisp_Object car = XCAR (value);
|
|
|
939 Lisp_Object cdr = XCDR (value);
|
|
|
940 CHECK_CHAR_COERCE_INT (cdr);
|
|
|
941 return Fcons (car, cdr);
|
|
|
942 }
|
|
|
943 break;
|
|
|
944 case CHAR_TABLE_TYPE_CHAR:
|
|
|
945 CHECK_CHAR_COERCE_INT (value);
|
|
|
946 break;
|
|
|
947 default:
|
|
|
948 break;
|
|
|
949 }
|
|
|
950 return value;
|
|
|
951 }
|
|
|
952
|
|
|
953 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
|
|
|
954 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
|
|
|
955 */
|
|
|
956 (value, char_table_type))
|
|
|
957 {
|
|
|
958 enum char_table_type type = symbol_to_char_table_type (char_table_type);
|
|
|
959
|
|
|
960 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
|
|
|
961 }
|
|
|
962
|
|
|
963 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
|
|
|
964 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
|
|
|
965 */
|
|
|
966 (value, char_table_type))
|
|
|
967 {
|
|
|
968 enum char_table_type type = symbol_to_char_table_type (char_table_type);
|
|
|
969
|
|
|
970 check_valid_char_table_value (value, type, ERROR_ME);
|
|
|
971 return Qnil;
|
|
|
972 }
|
|
|
973
|
|
826
|
974 /* Assign VAL to all characters in RANGE in char table TABLE. */
|
|
428
|
975
|
|
|
976 void
|
|
826
|
977 put_char_table (Lisp_Object table, struct chartab_range *range,
|
|
428
|
978 Lisp_Object val)
|
|
|
979 {
|
|
826
|
980 Lisp_Char_Table *ct = XCHAR_TABLE (table);
|
|
|
981
|
|
428
|
982 switch (range->type)
|
|
|
983 {
|
|
|
984 case CHARTAB_RANGE_ALL:
|
|
|
985 fill_char_table (ct, val);
|
|
|
986 return; /* avoid the duplicate call to update_syntax_table() below,
|
|
|
987 since fill_char_table() also did that. */
|
|
|
988
|
|
|
989 #ifdef MULE
|
|
|
990 case CHARTAB_RANGE_CHARSET:
|
|
|
991 if (EQ (range->charset, Vcharset_ascii))
|
|
|
992 {
|
|
|
993 int i;
|
|
|
994 for (i = 0; i < 128; i++)
|
|
|
995 ct->ascii[i] = val;
|
|
|
996 }
|
|
|
997 else if (EQ (range->charset, Vcharset_control_1))
|
|
|
998 {
|
|
|
999 int i;
|
|
|
1000 for (i = 128; i < 160; i++)
|
|
|
1001 ct->ascii[i] = val;
|
|
|
1002 }
|
|
|
1003 else
|
|
|
1004 {
|
|
|
1005 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
|
|
|
1006 ct->level1[lb] = val;
|
|
|
1007 }
|
|
|
1008 break;
|
|
|
1009
|
|
|
1010 case CHARTAB_RANGE_ROW:
|
|
|
1011 {
|
|
440
|
1012 Lisp_Char_Table_Entry *cte;
|
|
428
|
1013 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
|
|
|
1014 /* make sure that there is a separate entry for the row. */
|
|
|
1015 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
|
|
|
1016 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
|
|
|
1017 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
|
|
|
1018 cte->level2[range->row - 32] = val;
|
|
|
1019 }
|
|
|
1020 break;
|
|
|
1021 #endif /* MULE */
|
|
|
1022
|
|
|
1023 case CHARTAB_RANGE_CHAR:
|
|
|
1024 #ifdef MULE
|
|
|
1025 {
|
|
|
1026 Lisp_Object charset;
|
|
|
1027 int byte1, byte2;
|
|
|
1028
|
|
867
|
1029 BREAKUP_ICHAR (range->ch, charset, byte1, byte2);
|
|
428
|
1030 if (EQ (charset, Vcharset_ascii))
|
|
|
1031 ct->ascii[byte1] = val;
|
|
|
1032 else if (EQ (charset, Vcharset_control_1))
|
|
|
1033 ct->ascii[byte1 + 128] = val;
|
|
|
1034 else
|
|
|
1035 {
|
|
440
|
1036 Lisp_Char_Table_Entry *cte;
|
|
428
|
1037 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
|
|
|
1038 /* make sure that there is a separate entry for the row. */
|
|
|
1039 if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
|
|
|
1040 ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
|
|
|
1041 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
|
|
|
1042 /* now CTE is a char table entry for the charset;
|
|
|
1043 each entry is for a single row (or character of
|
|
|
1044 a one-octet charset). */
|
|
|
1045 if (XCHARSET_DIMENSION (charset) == 1)
|
|
|
1046 cte->level2[byte1 - 32] = val;
|
|
|
1047 else
|
|
|
1048 {
|
|
|
1049 /* assigning to one character in a two-octet charset. */
|
|
|
1050 /* make sure that the charset row contains a separate
|
|
|
1051 entry for each character. */
|
|
|
1052 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
|
|
|
1053 cte->level2[byte1 - 32] =
|
|
|
1054 make_char_table_entry (cte->level2[byte1 - 32]);
|
|
|
1055 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
|
|
|
1056 cte->level2[byte2 - 32] = val;
|
|
|
1057 }
|
|
|
1058 }
|
|
|
1059 }
|
|
|
1060 #else /* not MULE */
|
|
|
1061 ct->ascii[(unsigned char) (range->ch)] = val;
|
|
|
1062 break;
|
|
|
1063 #endif /* not MULE */
|
|
|
1064 }
|
|
|
1065
|
|
|
1066 if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
|
|
826
|
1067 update_syntax_table (wrap_char_table (ct));
|
|
428
|
1068 }
|
|
|
1069
|
|
|
1070 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /*
|
|
444
|
1071 Set the value for chars in RANGE to be VALUE in CHAR-TABLE.
|
|
428
|
1072
|
|
|
1073 RANGE specifies one or more characters to be affected and should be
|
|
|
1074 one of the following:
|
|
|
1075
|
|
|
1076 -- t (all characters are affected)
|
|
|
1077 -- A charset (only allowed when Mule support is present)
|
|
|
1078 -- A vector of two elements: a two-octet charset and a row number
|
|
|
1079 (only allowed when Mule support is present)
|
|
|
1080 -- A single character
|
|
|
1081
|
|
444
|
1082 VALUE must be a value appropriate for the type of CHAR-TABLE.
|
|
800
|
1083 See `make-char-table'.
|
|
428
|
1084 */
|
|
444
|
1085 (range, value, char_table))
|
|
428
|
1086 {
|
|
440
|
1087 Lisp_Char_Table *ct;
|
|
428
|
1088 struct chartab_range rainj;
|
|
|
1089
|
|
444
|
1090 CHECK_CHAR_TABLE (char_table);
|
|
|
1091 ct = XCHAR_TABLE (char_table);
|
|
|
1092 check_valid_char_table_value (value, ct->type, ERROR_ME);
|
|
428
|
1093 decode_char_table_range (range, &rainj);
|
|
444
|
1094 value = canonicalize_char_table_value (value, ct->type);
|
|
826
|
1095 put_char_table (char_table, &rainj, value);
|
|
|
1096 return Qnil;
|
|
|
1097 }
|
|
|
1098
|
|
|
1099 DEFUN ("remove-char-table", Fremove_char_table, 2, 2, 0, /*
|
|
|
1100 Remove any value from chars in RANGE in CHAR-TABLE.
|
|
|
1101
|
|
|
1102 RANGE specifies one or more characters to be affected and should be
|
|
|
1103 one of the following:
|
|
|
1104
|
|
|
1105 -- t (all characters are affected)
|
|
|
1106 -- A charset (only allowed when Mule support is present)
|
|
|
1107 -- A vector of two elements: a two-octet charset and a row number
|
|
|
1108 (only allowed when Mule support is present)
|
|
|
1109 -- A single character
|
|
|
1110
|
|
|
1111 With the values removed, the default value will be returned.
|
|
|
1112 */
|
|
|
1113 (range, char_table))
|
|
|
1114 {
|
|
|
1115 struct chartab_range rainj;
|
|
|
1116
|
|
|
1117 CHECK_CHAR_TABLE (char_table);
|
|
|
1118 decode_char_table_range (range, &rainj);
|
|
|
1119 put_char_table (char_table, &rainj, Qunbound);
|
|
428
|
1120 return Qnil;
|
|
|
1121 }
|
|
|
1122
|
|
|
1123 /* Map FN over the ASCII chars in CT. */
|
|
|
1124
|
|
|
1125 static int
|
|
826
|
1126 map_over_charset_ascii_1 (Lisp_Char_Table *ct,
|
|
|
1127 int start, int stop,
|
|
|
1128 int (*fn) (struct chartab_range *range,
|
|
|
1129 Lisp_Object table, Lisp_Object val,
|
|
|
1130 void *arg),
|
|
|
1131 void *arg)
|
|
|
1132 {
|
|
|
1133 struct chartab_range rainj;
|
|
|
1134 int i, retval;
|
|
|
1135
|
|
|
1136 rainj.type = CHARTAB_RANGE_CHAR;
|
|
|
1137
|
|
|
1138 for (i = start, retval = 0; i <= stop && retval == 0; i++)
|
|
|
1139 {
|
|
867
|
1140 rainj.ch = (Ichar) i;
|
|
826
|
1141 if (!UNBOUNDP (ct->ascii[i]))
|
|
|
1142 retval = (fn) (&rainj, wrap_char_table (ct), ct->ascii[i], arg);
|
|
|
1143 }
|
|
|
1144
|
|
|
1145 return retval;
|
|
|
1146 }
|
|
|
1147
|
|
|
1148
|
|
|
1149 /* Map FN over the ASCII chars in CT. */
|
|
|
1150
|
|
|
1151 static int
|
|
440
|
1152 map_over_charset_ascii (Lisp_Char_Table *ct,
|
|
428
|
1153 int (*fn) (struct chartab_range *range,
|
|
826
|
1154 Lisp_Object table, Lisp_Object val,
|
|
|
1155 void *arg),
|
|
428
|
1156 void *arg)
|
|
|
1157 {
|
|
826
|
1158 return map_over_charset_ascii_1 (ct, 0,
|
|
428
|
1159 #ifdef MULE
|
|
826
|
1160 127,
|
|
428
|
1161 #else
|
|
826
|
1162 255,
|
|
428
|
1163 #endif
|
|
826
|
1164 fn, arg);
|
|
428
|
1165 }
|
|
|
1166
|
|
|
1167 #ifdef MULE
|
|
|
1168
|
|
|
1169 /* Map FN over the Control-1 chars in CT. */
|
|
|
1170
|
|
|
1171 static int
|
|
440
|
1172 map_over_charset_control_1 (Lisp_Char_Table *ct,
|
|
428
|
1173 int (*fn) (struct chartab_range *range,
|
|
826
|
1174 Lisp_Object table, Lisp_Object val,
|
|
|
1175 void *arg),
|
|
428
|
1176 void *arg)
|
|
|
1177 {
|
|
826
|
1178 return map_over_charset_ascii_1 (ct, 128, 159, fn, arg);
|
|
428
|
1179 }
|
|
|
1180
|
|
|
1181 /* Map FN over the row ROW of two-byte charset CHARSET.
|
|
|
1182 There must be a separate value for that row in the char table.
|
|
|
1183 CTE specifies the char table entry for CHARSET. */
|
|
|
1184
|
|
|
1185 static int
|
|
826
|
1186 map_over_charset_row (Lisp_Char_Table *ct,
|
|
|
1187 Lisp_Char_Table_Entry *cte,
|
|
428
|
1188 Lisp_Object charset, int row,
|
|
|
1189 int (*fn) (struct chartab_range *range,
|
|
826
|
1190 Lisp_Object table, Lisp_Object val,
|
|
|
1191 void *arg),
|
|
428
|
1192 void *arg)
|
|
|
1193 {
|
|
|
1194 Lisp_Object val = cte->level2[row - 32];
|
|
|
1195
|
|
826
|
1196 if (UNBOUNDP (val))
|
|
|
1197 return 0;
|
|
|
1198 else if (!CHAR_TABLE_ENTRYP (val))
|
|
428
|
1199 {
|
|
|
1200 struct chartab_range rainj;
|
|
826
|
1201
|
|
428
|
1202 rainj.type = CHARTAB_RANGE_ROW;
|
|
|
1203 rainj.charset = charset;
|
|
|
1204 rainj.row = row;
|
|
826
|
1205 return (fn) (&rainj, wrap_char_table (ct), val, arg);
|
|
428
|
1206 }
|
|
|
1207 else
|
|
|
1208 {
|
|
|
1209 struct chartab_range rainj;
|
|
|
1210 int i, retval;
|
|
826
|
1211 int start, stop;
|
|
|
1212
|
|
|
1213 get_charset_limits (charset, &start, &stop);
|
|
428
|
1214
|
|
|
1215 cte = XCHAR_TABLE_ENTRY (val);
|
|
|
1216
|
|
|
1217 rainj.type = CHARTAB_RANGE_CHAR;
|
|
|
1218
|
|
826
|
1219 for (i = start, retval = 0; i <= stop && retval == 0; i++)
|
|
428
|
1220 {
|
|
867
|
1221 rainj.ch = make_ichar (charset, row, i);
|
|
826
|
1222 if (!UNBOUNDP (cte->level2[i - 32]))
|
|
|
1223 retval = (fn) (&rainj, wrap_char_table (ct), cte->level2[i - 32],
|
|
|
1224 arg);
|
|
428
|
1225 }
|
|
|
1226 return retval;
|
|
|
1227 }
|
|
|
1228 }
|
|
|
1229
|
|
|
1230
|
|
|
1231 static int
|
|
440
|
1232 map_over_other_charset (Lisp_Char_Table *ct, int lb,
|
|
428
|
1233 int (*fn) (struct chartab_range *range,
|
|
826
|
1234 Lisp_Object table, Lisp_Object val,
|
|
|
1235 void *arg),
|
|
428
|
1236 void *arg)
|
|
|
1237 {
|
|
|
1238 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE];
|
|
826
|
1239 Lisp_Object charset = charset_by_leading_byte (lb);
|
|
428
|
1240
|
|
|
1241 if (!CHARSETP (charset)
|
|
|
1242 || lb == LEADING_BYTE_ASCII
|
|
|
1243 || lb == LEADING_BYTE_CONTROL_1)
|
|
|
1244 return 0;
|
|
|
1245
|
|
826
|
1246 if (UNBOUNDP (val))
|
|
|
1247 return 0;
|
|
428
|
1248 if (!CHAR_TABLE_ENTRYP (val))
|
|
|
1249 {
|
|
|
1250 struct chartab_range rainj;
|
|
|
1251
|
|
|
1252 rainj.type = CHARTAB_RANGE_CHARSET;
|
|
|
1253 rainj.charset = charset;
|
|
826
|
1254 return (fn) (&rainj, wrap_char_table (ct), val, arg);
|
|
428
|
1255 }
|
|
|
1256 {
|
|
440
|
1257 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
|
|
826
|
1258 int start, stop;
|
|
428
|
1259 int i, retval;
|
|
|
1260
|
|
826
|
1261 get_charset_limits (charset, &start, &stop);
|
|
428
|
1262 if (XCHARSET_DIMENSION (charset) == 1)
|
|
|
1263 {
|
|
|
1264 struct chartab_range rainj;
|
|
|
1265 rainj.type = CHARTAB_RANGE_CHAR;
|
|
|
1266
|
|
826
|
1267 for (i = start, retval = 0; i <= stop && retval == 0; i++)
|
|
428
|
1268 {
|
|
867
|
1269 rainj.ch = make_ichar (charset, i, 0);
|
|
826
|
1270 if (!UNBOUNDP (cte->level2[i - 32]))
|
|
|
1271 retval = (fn) (&rainj, wrap_char_table (ct), cte->level2[i - 32],
|
|
|
1272 arg);
|
|
428
|
1273 }
|
|
|
1274 }
|
|
|
1275 else
|
|
|
1276 {
|
|
826
|
1277 for (i = start, retval = 0; i <= stop && retval == 0; i++)
|
|
|
1278 retval = map_over_charset_row (ct, cte, charset, i, fn, arg);
|
|
428
|
1279 }
|
|
|
1280
|
|
|
1281 return retval;
|
|
|
1282 }
|
|
|
1283 }
|
|
|
1284
|
|
|
1285 #endif /* MULE */
|
|
|
1286
|
|
|
1287 /* Map FN (with client data ARG) over range RANGE in char table CT.
|
|
|
1288 Mapping stops the first time FN returns non-zero, and that value
|
|
826
|
1289 becomes the return value of map_char_table().
|
|
|
1290
|
|
|
1291 #### This mapping code is way ugly. The FSF version, in contrast,
|
|
|
1292 is short and sweet, and much more recursive. There should be some way
|
|
|
1293 of cleaning this up. */
|
|
428
|
1294
|
|
|
1295 int
|
|
826
|
1296 map_char_table (Lisp_Object table,
|
|
428
|
1297 struct chartab_range *range,
|
|
|
1298 int (*fn) (struct chartab_range *range,
|
|
826
|
1299 Lisp_Object table, Lisp_Object val, void *arg),
|
|
428
|
1300 void *arg)
|
|
|
1301 {
|
|
826
|
1302 Lisp_Char_Table *ct = XCHAR_TABLE (table);
|
|
428
|
1303 switch (range->type)
|
|
|
1304 {
|
|
|
1305 case CHARTAB_RANGE_ALL:
|
|
|
1306 {
|
|
|
1307 int retval;
|
|
|
1308
|
|
|
1309 retval = map_over_charset_ascii (ct, fn, arg);
|
|
|
1310 if (retval)
|
|
|
1311 return retval;
|
|
|
1312 #ifdef MULE
|
|
|
1313 retval = map_over_charset_control_1 (ct, fn, arg);
|
|
|
1314 if (retval)
|
|
|
1315 return retval;
|
|
|
1316 {
|
|
|
1317 int i;
|
|
|
1318 int start = MIN_LEADING_BYTE;
|
|
|
1319 int stop = start + NUM_LEADING_BYTES;
|
|
|
1320
|
|
|
1321 for (i = start, retval = 0; i < stop && retval == 0; i++)
|
|
|
1322 {
|
|
771
|
1323 if (i != LEADING_BYTE_ASCII && i != LEADING_BYTE_CONTROL_1)
|
|
|
1324 retval = map_over_other_charset (ct, i, fn, arg);
|
|
428
|
1325 }
|
|
|
1326 }
|
|
|
1327 #endif /* MULE */
|
|
|
1328 return retval;
|
|
|
1329 }
|
|
|
1330
|
|
|
1331 #ifdef MULE
|
|
|
1332 case CHARTAB_RANGE_CHARSET:
|
|
|
1333 return map_over_other_charset (ct,
|
|
|
1334 XCHARSET_LEADING_BYTE (range->charset),
|
|
|
1335 fn, arg);
|
|
|
1336
|
|
|
1337 case CHARTAB_RANGE_ROW:
|
|
|
1338 {
|
|
771
|
1339 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) -
|
|
|
1340 MIN_LEADING_BYTE];
|
|
826
|
1341
|
|
|
1342 if (CHAR_TABLE_ENTRYP (val))
|
|
|
1343 return map_over_charset_row (ct, XCHAR_TABLE_ENTRY (val),
|
|
|
1344 range->charset, range->row, fn, arg);
|
|
|
1345 else if (!UNBOUNDP (val))
|
|
428
|
1346 {
|
|
|
1347 struct chartab_range rainj;
|
|
|
1348
|
|
|
1349 rainj.type = CHARTAB_RANGE_ROW;
|
|
|
1350 rainj.charset = range->charset;
|
|
|
1351 rainj.row = range->row;
|
|
826
|
1352 return (fn) (&rainj, table, val, arg);
|
|
428
|
1353 }
|
|
|
1354 else
|
|
826
|
1355 return 0;
|
|
428
|
1356 }
|
|
|
1357 #endif /* MULE */
|
|
|
1358
|
|
|
1359 case CHARTAB_RANGE_CHAR:
|
|
|
1360 {
|
|
867
|
1361 Ichar ch = range->ch;
|
|
826
|
1362 Lisp_Object val = get_char_table (ch, table);
|
|
428
|
1363 struct chartab_range rainj;
|
|
|
1364
|
|
826
|
1365 if (!UNBOUNDP (val))
|
|
|
1366 {
|
|
|
1367 rainj.type = CHARTAB_RANGE_CHAR;
|
|
|
1368 rainj.ch = ch;
|
|
|
1369 return (fn) (&rainj, table, val, arg);
|
|
|
1370 }
|
|
|
1371 else
|
|
|
1372 return 0;
|
|
428
|
1373 }
|
|
|
1374
|
|
|
1375 default:
|
|
|
1376 abort ();
|
|
|
1377 }
|
|
|
1378
|
|
|
1379 return 0;
|
|
|
1380 }
|
|
|
1381
|
|
|
1382 struct slow_map_char_table_arg
|
|
|
1383 {
|
|
|
1384 Lisp_Object function;
|
|
|
1385 Lisp_Object retval;
|
|
|
1386 };
|
|
|
1387
|
|
|
1388 static int
|
|
|
1389 slow_map_char_table_fun (struct chartab_range *range,
|
|
826
|
1390 Lisp_Object table, Lisp_Object val, void *arg)
|
|
428
|
1391 {
|
|
|
1392 struct slow_map_char_table_arg *closure =
|
|
|
1393 (struct slow_map_char_table_arg *) arg;
|
|
|
1394
|
|
826
|
1395 closure->retval = call2 (closure->function, encode_char_table_range (range),
|
|
|
1396 val);
|
|
428
|
1397 return !NILP (closure->retval);
|
|
|
1398 }
|
|
|
1399
|
|
|
1400 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /*
|
|
444
|
1401 Map FUNCTION over entries in CHAR-TABLE, calling it with two args,
|
|
428
|
1402 each key and value in the table.
|
|
|
1403
|
|
|
1404 RANGE specifies a subrange to map over and is in the same format as
|
|
|
1405 the RANGE argument to `put-range-table'. If omitted or t, it defaults to
|
|
|
1406 the entire table.
|
|
|
1407 */
|
|
444
|
1408 (function, char_table, range))
|
|
428
|
1409 {
|
|
|
1410 struct slow_map_char_table_arg slarg;
|
|
|
1411 struct gcpro gcpro1, gcpro2;
|
|
|
1412 struct chartab_range rainj;
|
|
|
1413
|
|
444
|
1414 CHECK_CHAR_TABLE (char_table);
|
|
428
|
1415 if (NILP (range))
|
|
|
1416 range = Qt;
|
|
|
1417 decode_char_table_range (range, &rainj);
|
|
|
1418 slarg.function = function;
|
|
|
1419 slarg.retval = Qnil;
|
|
|
1420 GCPRO2 (slarg.function, slarg.retval);
|
|
826
|
1421 map_char_table (char_table, &rainj, slow_map_char_table_fun, &slarg);
|
|
428
|
1422 UNGCPRO;
|
|
|
1423
|
|
|
1424 return slarg.retval;
|
|
|
1425 }
|
|
|
1426
|
|
|
1427
|
|
|
1428
|
|
|
1429 /************************************************************************/
|
|
|
1430 /* Char table read syntax */
|
|
|
1431 /************************************************************************/
|
|
|
1432
|
|
|
1433 static int
|
|
|
1434 chartab_type_validate (Lisp_Object keyword, Lisp_Object value,
|
|
578
|
1435 Error_Behavior errb)
|
|
428
|
1436 {
|
|
|
1437 /* #### should deal with ERRB */
|
|
|
1438 symbol_to_char_table_type (value);
|
|
|
1439 return 1;
|
|
|
1440 }
|
|
|
1441
|
|
826
|
1442 /* #### Document the print/read format; esp. what's this cons element? */
|
|
|
1443
|
|
428
|
1444 static int
|
|
|
1445 chartab_data_validate (Lisp_Object keyword, Lisp_Object value,
|
|
578
|
1446 Error_Behavior errb)
|
|
428
|
1447 {
|
|
|
1448 Lisp_Object rest;
|
|
|
1449
|
|
|
1450 /* #### should deal with ERRB */
|
|
|
1451 EXTERNAL_LIST_LOOP (rest, value)
|
|
|
1452 {
|
|
|
1453 Lisp_Object range = XCAR (rest);
|
|
|
1454 struct chartab_range dummy;
|
|
|
1455
|
|
|
1456 rest = XCDR (rest);
|
|
|
1457 if (!CONSP (rest))
|
|
563
|
1458 signal_error (Qlist_formation_error, "Invalid list format", value);
|
|
428
|
1459 if (CONSP (range))
|
|
|
1460 {
|
|
|
1461 if (!CONSP (XCDR (range))
|
|
|
1462 || !NILP (XCDR (XCDR (range))))
|
|
563
|
1463 sferror ("Invalid range format", range);
|
|
428
|
1464 decode_char_table_range (XCAR (range), &dummy);
|
|
|
1465 decode_char_table_range (XCAR (XCDR (range)), &dummy);
|
|
|
1466 }
|
|
|
1467 else
|
|
|
1468 decode_char_table_range (range, &dummy);
|
|
|
1469 }
|
|
|
1470
|
|
|
1471 return 1;
|
|
|
1472 }
|
|
|
1473
|
|
|
1474 static Lisp_Object
|
|
|
1475 chartab_instantiate (Lisp_Object data)
|
|
|
1476 {
|
|
|
1477 Lisp_Object chartab;
|
|
|
1478 Lisp_Object type = Qgeneric;
|
|
|
1479 Lisp_Object dataval = Qnil;
|
|
|
1480
|
|
|
1481 while (!NILP (data))
|
|
|
1482 {
|
|
|
1483 Lisp_Object keyw = Fcar (data);
|
|
|
1484 Lisp_Object valw;
|
|
|
1485
|
|
|
1486 data = Fcdr (data);
|
|
|
1487 valw = Fcar (data);
|
|
|
1488 data = Fcdr (data);
|
|
|
1489 if (EQ (keyw, Qtype))
|
|
|
1490 type = valw;
|
|
|
1491 else if (EQ (keyw, Qdata))
|
|
|
1492 dataval = valw;
|
|
|
1493 }
|
|
|
1494
|
|
|
1495 chartab = Fmake_char_table (type);
|
|
|
1496
|
|
|
1497 data = dataval;
|
|
|
1498 while (!NILP (data))
|
|
|
1499 {
|
|
|
1500 Lisp_Object range = Fcar (data);
|
|
|
1501 Lisp_Object val = Fcar (Fcdr (data));
|
|
|
1502
|
|
|
1503 data = Fcdr (Fcdr (data));
|
|
|
1504 if (CONSP (range))
|
|
|
1505 {
|
|
|
1506 if (CHAR_OR_CHAR_INTP (XCAR (range)))
|
|
|
1507 {
|
|
867
|
1508 Ichar first = XCHAR_OR_CHAR_INT (Fcar (range));
|
|
|
1509 Ichar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range)));
|
|
|
1510 Ichar i;
|
|
428
|
1511
|
|
|
1512 for (i = first; i <= last; i++)
|
|
|
1513 Fput_char_table (make_char (i), val, chartab);
|
|
|
1514 }
|
|
|
1515 else
|
|
|
1516 abort ();
|
|
|
1517 }
|
|
|
1518 else
|
|
|
1519 Fput_char_table (range, val, chartab);
|
|
|
1520 }
|
|
|
1521
|
|
|
1522 return chartab;
|
|
|
1523 }
|
|
|
1524
|
|
|
1525 #ifdef MULE
|
|
|
1526
|
|
|
1527
|
|
|
1528 /************************************************************************/
|
|
|
1529 /* Category Tables, specifically */
|
|
|
1530 /************************************************************************/
|
|
|
1531
|
|
|
1532 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /*
|
|
444
|
1533 Return t if OBJECT is a category table.
|
|
428
|
1534 A category table is a type of char table used for keeping track of
|
|
|
1535 categories. Categories are used for classifying characters for use
|
|
|
1536 in regexps -- you can refer to a category rather than having to use
|
|
|
1537 a complicated [] expression (and category lookups are significantly
|
|
|
1538 faster).
|
|
|
1539
|
|
|
1540 There are 95 different categories available, one for each printable
|
|
|
1541 character (including space) in the ASCII charset. Each category
|
|
|
1542 is designated by one such character, called a "category designator".
|
|
|
1543 They are specified in a regexp using the syntax "\\cX", where X is
|
|
|
1544 a category designator.
|
|
|
1545
|
|
|
1546 A category table specifies, for each character, the categories that
|
|
|
1547 the character is in. Note that a character can be in more than one
|
|
|
1548 category. More specifically, a category table maps from a character
|
|
|
1549 to either the value nil (meaning the character is in no categories)
|
|
|
1550 or a 95-element bit vector, specifying for each of the 95 categories
|
|
|
1551 whether the character is in that category.
|
|
|
1552
|
|
|
1553 Special Lisp functions are provided that abstract this, so you do not
|
|
|
1554 have to directly manipulate bit vectors.
|
|
|
1555 */
|
|
444
|
1556 (object))
|
|
428
|
1557 {
|
|
444
|
1558 return (CHAR_TABLEP (object) &&
|
|
|
1559 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ?
|
|
428
|
1560 Qt : Qnil;
|
|
|
1561 }
|
|
|
1562
|
|
|
1563 static Lisp_Object
|
|
444
|
1564 check_category_table (Lisp_Object object, Lisp_Object default_)
|
|
428
|
1565 {
|
|
444
|
1566 if (NILP (object))
|
|
|
1567 object = default_;
|
|
|
1568 while (NILP (Fcategory_table_p (object)))
|
|
|
1569 object = wrong_type_argument (Qcategory_table_p, object);
|
|
|
1570 return object;
|
|
428
|
1571 }
|
|
|
1572
|
|
|
1573 int
|
|
867
|
1574 check_category_char (Ichar ch, Lisp_Object table,
|
|
647
|
1575 int designator, int not_p)
|
|
428
|
1576 {
|
|
|
1577 REGISTER Lisp_Object temp;
|
|
|
1578 if (NILP (Fcategory_table_p (table)))
|
|
563
|
1579 wtaerror ("Expected category table", table);
|
|
826
|
1580 temp = get_char_table (ch, table);
|
|
428
|
1581 if (NILP (temp))
|
|
458
|
1582 return not_p;
|
|
428
|
1583
|
|
|
1584 designator -= ' ';
|
|
458
|
1585 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p;
|
|
428
|
1586 }
|
|
|
1587
|
|
|
1588 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /*
|
|
444
|
1589 Return t if category of the character at POSITION includes DESIGNATOR.
|
|
|
1590 Optional third arg BUFFER specifies which buffer to use, and defaults
|
|
|
1591 to the current buffer.
|
|
|
1592 Optional fourth arg CATEGORY-TABLE specifies the category table to
|
|
|
1593 use, and defaults to BUFFER's category table.
|
|
428
|
1594 */
|
|
444
|
1595 (position, designator, buffer, category_table))
|
|
428
|
1596 {
|
|
|
1597 Lisp_Object ctbl;
|
|
867
|
1598 Ichar ch;
|
|
647
|
1599 int des;
|
|
428
|
1600 struct buffer *buf = decode_buffer (buffer, 0);
|
|
|
1601
|
|
444
|
1602 CHECK_INT (position);
|
|
428
|
1603 CHECK_CATEGORY_DESIGNATOR (designator);
|
|
|
1604 des = XCHAR (designator);
|
|
788
|
1605 ctbl = check_category_table (category_table, buf->category_table);
|
|
444
|
1606 ch = BUF_FETCH_CHAR (buf, XINT (position));
|
|
428
|
1607 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
|
|
|
1608 }
|
|
|
1609
|
|
|
1610 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /*
|
|
788
|
1611 Return non-nil if category of CHARACTER includes DESIGNATOR.
|
|
444
|
1612 Optional third arg CATEGORY-TABLE specifies the category table to use,
|
|
788
|
1613 and defaults to the current buffer's category table.
|
|
428
|
1614 */
|
|
444
|
1615 (character, designator, category_table))
|
|
428
|
1616 {
|
|
|
1617 Lisp_Object ctbl;
|
|
867
|
1618 Ichar ch;
|
|
647
|
1619 int des;
|
|
428
|
1620
|
|
|
1621 CHECK_CATEGORY_DESIGNATOR (designator);
|
|
|
1622 des = XCHAR (designator);
|
|
444
|
1623 CHECK_CHAR (character);
|
|
|
1624 ch = XCHAR (character);
|
|
788
|
1625 ctbl = check_category_table (category_table, current_buffer->category_table);
|
|
428
|
1626 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil;
|
|
|
1627 }
|
|
|
1628
|
|
|
1629 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /*
|
|
444
|
1630 Return BUFFER's current category table.
|
|
|
1631 BUFFER defaults to the current buffer.
|
|
428
|
1632 */
|
|
|
1633 (buffer))
|
|
|
1634 {
|
|
|
1635 return decode_buffer (buffer, 0)->category_table;
|
|
|
1636 }
|
|
|
1637
|
|
|
1638 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /*
|
|
|
1639 Return the standard category table.
|
|
|
1640 This is the one used for new buffers.
|
|
|
1641 */
|
|
|
1642 ())
|
|
|
1643 {
|
|
|
1644 return Vstandard_category_table;
|
|
|
1645 }
|
|
|
1646
|
|
|
1647 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /*
|
|
444
|
1648 Return a new category table which is a copy of CATEGORY-TABLE.
|
|
|
1649 CATEGORY-TABLE defaults to the standard category table.
|
|
428
|
1650 */
|
|
444
|
1651 (category_table))
|
|
428
|
1652 {
|
|
|
1653 if (NILP (Vstandard_category_table))
|
|
|
1654 return Fmake_char_table (Qcategory);
|
|
|
1655
|
|
444
|
1656 category_table =
|
|
|
1657 check_category_table (category_table, Vstandard_category_table);
|
|
|
1658 return Fcopy_char_table (category_table);
|
|
428
|
1659 }
|
|
|
1660
|
|
|
1661 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /*
|
|
444
|
1662 Select CATEGORY-TABLE as the new category table for BUFFER.
|
|
428
|
1663 BUFFER defaults to the current buffer if omitted.
|
|
|
1664 */
|
|
444
|
1665 (category_table, buffer))
|
|
428
|
1666 {
|
|
|
1667 struct buffer *buf = decode_buffer (buffer, 0);
|
|
444
|
1668 category_table = check_category_table (category_table, Qnil);
|
|
|
1669 buf->category_table = category_table;
|
|
428
|
1670 /* Indicate that this buffer now has a specified category table. */
|
|
|
1671 buf->local_var_flags |= XINT (buffer_local_flags.category_table);
|
|
444
|
1672 return category_table;
|
|
428
|
1673 }
|
|
|
1674
|
|
|
1675 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /*
|
|
444
|
1676 Return t if OBJECT is a category designator (a char in the range ' ' to '~').
|
|
428
|
1677 */
|
|
444
|
1678 (object))
|
|
428
|
1679 {
|
|
444
|
1680 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil;
|
|
428
|
1681 }
|
|
|
1682
|
|
|
1683 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /*
|
|
444
|
1684 Return t if OBJECT is a category table value.
|
|
428
|
1685 Valid values are nil or a bit vector of size 95.
|
|
|
1686 */
|
|
444
|
1687 (object))
|
|
428
|
1688 {
|
|
444
|
1689 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil;
|
|
428
|
1690 }
|
|
|
1691
|
|
|
1692
|
|
|
1693 #define CATEGORYP(x) \
|
|
|
1694 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E)
|
|
|
1695
|
|
826
|
1696 #define CATEGORY_SET(c) get_char_table (c, current_buffer->category_table)
|
|
428
|
1697
|
|
|
1698 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0.
|
|
|
1699 The faster version of `!NILP (Faref (category_set, category))'. */
|
|
|
1700 #define CATEGORY_MEMBER(category, category_set) \
|
|
|
1701 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32))
|
|
|
1702
|
|
|
1703 /* Return 1 if there is a word boundary between two word-constituent
|
|
|
1704 characters C1 and C2 if they appear in this order, else return 0.
|
|
|
1705 Use the macro WORD_BOUNDARY_P instead of calling this function
|
|
|
1706 directly. */
|
|
|
1707
|
|
|
1708 int
|
|
867
|
1709 word_boundary_p (Ichar c1, Ichar c2)
|
|
428
|
1710 {
|
|
|
1711 Lisp_Object category_set1, category_set2;
|
|
|
1712 Lisp_Object tail;
|
|
|
1713 int default_result;
|
|
|
1714
|
|
|
1715 #if 0
|
|
|
1716 if (COMPOSITE_CHAR_P (c1))
|
|
|
1717 c1 = cmpchar_component (c1, 0, 1);
|
|
|
1718 if (COMPOSITE_CHAR_P (c2))
|
|
|
1719 c2 = cmpchar_component (c2, 0, 1);
|
|
|
1720 #endif
|
|
|
1721
|
|
867
|
1722 if (EQ (ichar_charset (c1), ichar_charset (c2)))
|
|
428
|
1723 {
|
|
|
1724 tail = Vword_separating_categories;
|
|
|
1725 default_result = 0;
|
|
|
1726 }
|
|
|
1727 else
|
|
|
1728 {
|
|
|
1729 tail = Vword_combining_categories;
|
|
|
1730 default_result = 1;
|
|
|
1731 }
|
|
|
1732
|
|
|
1733 category_set1 = CATEGORY_SET (c1);
|
|
|
1734 if (NILP (category_set1))
|
|
|
1735 return default_result;
|
|
|
1736 category_set2 = CATEGORY_SET (c2);
|
|
|
1737 if (NILP (category_set2))
|
|
|
1738 return default_result;
|
|
|
1739
|
|
853
|
1740 for (; CONSP (tail); tail = XCDR (tail))
|
|
428
|
1741 {
|
|
853
|
1742 Lisp_Object elt = XCAR (tail);
|
|
428
|
1743
|
|
|
1744 if (CONSP (elt)
|
|
853
|
1745 && CATEGORYP (XCAR (elt))
|
|
|
1746 && CATEGORYP (XCDR (elt))
|
|
|
1747 && CATEGORY_MEMBER (XCHAR (XCAR (elt)), category_set1)
|
|
|
1748 && CATEGORY_MEMBER (XCHAR (XCDR (elt)), category_set2))
|
|
428
|
1749 return !default_result;
|
|
|
1750 }
|
|
|
1751 return default_result;
|
|
|
1752 }
|
|
|
1753 #endif /* MULE */
|
|
|
1754
|
|
|
1755
|
|
|
1756 void
|
|
|
1757 syms_of_chartab (void)
|
|
|
1758 {
|
|
442
|
1759 INIT_LRECORD_IMPLEMENTATION (char_table);
|
|
|
1760
|
|
428
|
1761 #ifdef MULE
|
|
442
|
1762 INIT_LRECORD_IMPLEMENTATION (char_table_entry);
|
|
|
1763
|
|
563
|
1764 DEFSYMBOL (Qcategory_table_p);
|
|
|
1765 DEFSYMBOL (Qcategory_designator_p);
|
|
|
1766 DEFSYMBOL (Qcategory_table_value_p);
|
|
428
|
1767 #endif /* MULE */
|
|
|
1768
|
|
563
|
1769 DEFSYMBOL (Qchar_table);
|
|
|
1770 DEFSYMBOL_MULTIWORD_PREDICATE (Qchar_tablep);
|
|
428
|
1771
|
|
|
1772 DEFSUBR (Fchar_table_p);
|
|
|
1773 DEFSUBR (Fchar_table_type_list);
|
|
|
1774 DEFSUBR (Fvalid_char_table_type_p);
|
|
|
1775 DEFSUBR (Fchar_table_type);
|
|
826
|
1776 DEFSUBR (Fchar_table_default);
|
|
|
1777 DEFSUBR (Fset_char_table_default);
|
|
428
|
1778 DEFSUBR (Freset_char_table);
|
|
|
1779 DEFSUBR (Fmake_char_table);
|
|
|
1780 DEFSUBR (Fcopy_char_table);
|
|
|
1781 DEFSUBR (Fget_char_table);
|
|
|
1782 DEFSUBR (Fget_range_char_table);
|
|
|
1783 DEFSUBR (Fvalid_char_table_value_p);
|
|
|
1784 DEFSUBR (Fcheck_valid_char_table_value);
|
|
|
1785 DEFSUBR (Fput_char_table);
|
|
826
|
1786 DEFSUBR (Fremove_char_table);
|
|
428
|
1787 DEFSUBR (Fmap_char_table);
|
|
|
1788
|
|
|
1789 #ifdef MULE
|
|
|
1790 DEFSUBR (Fcategory_table_p);
|
|
|
1791 DEFSUBR (Fcategory_table);
|
|
|
1792 DEFSUBR (Fstandard_category_table);
|
|
|
1793 DEFSUBR (Fcopy_category_table);
|
|
|
1794 DEFSUBR (Fset_category_table);
|
|
|
1795 DEFSUBR (Fcheck_category_at);
|
|
|
1796 DEFSUBR (Fchar_in_category_p);
|
|
|
1797 DEFSUBR (Fcategory_designator_p);
|
|
|
1798 DEFSUBR (Fcategory_table_value_p);
|
|
|
1799 #endif /* MULE */
|
|
|
1800
|
|
|
1801 }
|
|
|
1802
|
|
|
1803 void
|
|
|
1804 vars_of_chartab (void)
|
|
|
1805 {
|
|
|
1806 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */
|
|
|
1807 Vall_syntax_tables = Qnil;
|
|
452
|
1808 dump_add_weak_object_chain (&Vall_syntax_tables);
|
|
428
|
1809 }
|
|
|
1810
|
|
|
1811 void
|
|
|
1812 structure_type_create_chartab (void)
|
|
|
1813 {
|
|
|
1814 struct structure_type *st;
|
|
|
1815
|
|
|
1816 st = define_structure_type (Qchar_table, 0, chartab_instantiate);
|
|
|
1817
|
|
|
1818 define_structure_type_keyword (st, Qtype, chartab_type_validate);
|
|
|
1819 define_structure_type_keyword (st, Qdata, chartab_data_validate);
|
|
|
1820 }
|
|
|
1821
|
|
|
1822 void
|
|
|
1823 complex_vars_of_chartab (void)
|
|
|
1824 {
|
|
|
1825 #ifdef MULE
|
|
|
1826 /* Set this now, so first buffer creation can refer to it. */
|
|
|
1827 /* Make it nil before calling copy-category-table
|
|
|
1828 so that copy-category-table will know not to try to copy from garbage */
|
|
|
1829 Vstandard_category_table = Qnil;
|
|
|
1830 Vstandard_category_table = Fcopy_category_table (Qnil);
|
|
|
1831 staticpro (&Vstandard_category_table);
|
|
|
1832
|
|
|
1833 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /*
|
|
|
1834 List of pair (cons) of categories to determine word boundary.
|
|
|
1835
|
|
|
1836 Emacs treats a sequence of word constituent characters as a single
|
|
|
1837 word (i.e. finds no word boundary between them) iff they belongs to
|
|
|
1838 the same charset. But, exceptions are allowed in the following cases.
|
|
|
1839
|
|
444
|
1840 \(1) The case that characters are in different charsets is controlled
|
|
428
|
1841 by the variable `word-combining-categories'.
|
|
|
1842
|
|
|
1843 Emacs finds no word boundary between characters of different charsets
|
|
|
1844 if they have categories matching some element of this list.
|
|
|
1845
|
|
|
1846 More precisely, if an element of this list is a cons of category CAT1
|
|
|
1847 and CAT2, and a multibyte character C1 which has CAT1 is followed by
|
|
|
1848 C2 which has CAT2, there's no word boundary between C1 and C2.
|
|
|
1849
|
|
|
1850 For instance, to tell that ASCII characters and Latin-1 characters can
|
|
|
1851 form a single word, the element `(?l . ?l)' should be in this list
|
|
|
1852 because both characters have the category `l' (Latin characters).
|
|
|
1853
|
|
444
|
1854 \(2) The case that character are in the same charset is controlled by
|
|
428
|
1855 the variable `word-separating-categories'.
|
|
|
1856
|
|
|
1857 Emacs find a word boundary between characters of the same charset
|
|
|
1858 if they have categories matching some element of this list.
|
|
|
1859
|
|
|
1860 More precisely, if an element of this list is a cons of category CAT1
|
|
|
1861 and CAT2, and a multibyte character C1 which has CAT1 is followed by
|
|
|
1862 C2 which has CAT2, there's a word boundary between C1 and C2.
|
|
|
1863
|
|
|
1864 For instance, to tell that there's a word boundary between Japanese
|
|
|
1865 Hiragana and Japanese Kanji (both are in the same charset), the
|
|
|
1866 element `(?H . ?C) should be in this list.
|
|
|
1867 */ );
|
|
|
1868
|
|
|
1869 Vword_combining_categories = Qnil;
|
|
|
1870
|
|
|
1871 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /*
|
|
|
1872 List of pair (cons) of categories to determine word boundary.
|
|
|
1873 See the documentation of the variable `word-combining-categories'.
|
|
|
1874 */ );
|
|
|
1875
|
|
|
1876 Vword_separating_categories = Qnil;
|
|
|
1877 #endif /* MULE */
|
|
|
1878 }
|
