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