emacs-lisp/package.el: Move the compatibility-table building logic.
[emacs.git] / src / category.c
blobb20493e5949ff3e5dd21bac10f2848146bd78fcd
1 /* GNU Emacs routines to deal with category tables.
3 Copyright (C) 1998, 2001-2015 Free Software Foundation, Inc.
4 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
5 2005, 2006, 2007, 2008, 2009, 2010, 2011
6 National Institute of Advanced Industrial Science and Technology (AIST)
7 Registration Number H14PRO021
8 Copyright (C) 2003
9 National Institute of Advanced Industrial Science and Technology (AIST)
10 Registration Number H13PRO009
12 This file is part of GNU Emacs.
14 GNU Emacs is free software: you can redistribute it and/or modify
15 it under the terms of the GNU General Public License as published by
16 the Free Software Foundation, either version 3 of the License, or
17 (at your option) any later version.
19 GNU Emacs is distributed in the hope that it will be useful,
20 but WITHOUT ANY WARRANTY; without even the implied warranty of
21 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 GNU General Public License for more details.
24 You should have received a copy of the GNU General Public License
25 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
28 /* Here we handle three objects: category, category set, and category
29 table. Read comments in the file category.h to understand them. */
31 #include <config.h>
33 #include "lisp.h"
34 #include "character.h"
35 #include "buffer.h"
36 #include "charset.h"
37 #include "category.h"
38 #include "keymap.h"
40 /* This setter is used only in this file, so it can be private. */
41 static void
42 bset_category_table (struct buffer *b, Lisp_Object val)
44 b->INTERNAL_FIELD (category_table) = val;
47 /* The version number of the latest category table. Each category
48 table has a unique version number. It is assigned a new number
49 also when it is modified. When a regular expression is compiled
50 into the struct re_pattern_buffer, the version number of the
51 category table (of the current buffer) at that moment is also
52 embedded in the structure.
54 For the moment, we are not using this feature. */
55 static int category_table_version;
57 /* Category set staff. */
59 static Lisp_Object
60 hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
62 struct Lisp_Hash_Table *h;
63 ptrdiff_t i;
64 EMACS_UINT hash;
66 if (NILP (XCHAR_TABLE (table)->extras[1]))
67 set_char_table_extras
68 (table, 1,
69 make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
70 make_float (DEFAULT_REHASH_SIZE),
71 make_float (DEFAULT_REHASH_THRESHOLD),
72 Qnil));
73 h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
74 i = hash_lookup (h, category_set, &hash);
75 if (i >= 0)
76 return HASH_KEY (h, i);
77 hash_put (h, category_set, Qnil, hash);
78 return category_set;
81 /* Make CATEGORY_SET include (if VAL) or exclude (if !VAL) CATEGORY. */
83 static void
84 set_category_set (Lisp_Object category_set, EMACS_INT category, bool val)
86 bool_vector_set (category_set, category, val);
89 DEFUN ("make-category-set", Fmake_category_set, Smake_category_set, 1, 1, 0,
90 doc: /* Return a newly created category-set which contains CATEGORIES.
91 CATEGORIES is a string of category mnemonics.
92 The value is a bool-vector which has t at the indices corresponding to
93 those categories. */)
94 (Lisp_Object categories)
96 Lisp_Object val;
97 ptrdiff_t len;
99 CHECK_STRING (categories);
100 val = MAKE_CATEGORY_SET;
102 if (STRING_MULTIBYTE (categories))
103 error ("Multibyte string in `make-category-set'");
105 len = SCHARS (categories);
106 while (--len >= 0)
108 unsigned char cat = SREF (categories, len);
109 Lisp_Object category = make_number (cat);
111 CHECK_CATEGORY (category);
112 set_category_set (val, cat, 1);
114 return val;
118 /* Category staff. */
120 static Lisp_Object check_category_table (Lisp_Object table);
122 DEFUN ("define-category", Fdefine_category, Sdefine_category, 2, 3, 0,
123 doc: /* Define CATEGORY as a category which is described by DOCSTRING.
124 CATEGORY should be an ASCII printing character in the range ` ' to `~'.
125 DOCSTRING is the documentation string of the category. The first line
126 should be a terse text (preferably less than 16 characters),
127 and the rest lines should be the full description.
128 The category is defined only in category table TABLE, which defaults to
129 the current buffer's category table. */)
130 (Lisp_Object category, Lisp_Object docstring, Lisp_Object table)
132 CHECK_CATEGORY (category);
133 CHECK_STRING (docstring);
134 table = check_category_table (table);
136 if (!NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
137 error ("Category `%c' is already defined", (int) XFASTINT (category));
138 if (!NILP (Vpurify_flag))
139 docstring = Fpurecopy (docstring);
140 SET_CATEGORY_DOCSTRING (table, XFASTINT (category), docstring);
142 return Qnil;
145 DEFUN ("category-docstring", Fcategory_docstring, Scategory_docstring, 1, 2, 0,
146 doc: /* Return the documentation string of CATEGORY, as defined in TABLE.
147 TABLE should be a category table and defaults to the current buffer's
148 category table. */)
149 (Lisp_Object category, Lisp_Object table)
151 CHECK_CATEGORY (category);
152 table = check_category_table (table);
154 return CATEGORY_DOCSTRING (table, XFASTINT (category));
157 DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category,
158 0, 1, 0,
159 doc: /* Return a category which is not yet defined in TABLE.
160 If no category remains available, return nil.
161 The optional argument TABLE specifies which category table to modify;
162 it defaults to the current buffer's category table. */)
163 (Lisp_Object table)
165 int i;
167 table = check_category_table (table);
169 for (i = ' '; i <= '~'; i++)
170 if (NILP (CATEGORY_DOCSTRING (table, i)))
171 return make_number (i);
173 return Qnil;
177 /* Category-table staff. */
179 DEFUN ("category-table-p", Fcategory_table_p, Scategory_table_p, 1, 1, 0,
180 doc: /* Return t if ARG is a category table. */)
181 (Lisp_Object arg)
183 if (CHAR_TABLE_P (arg)
184 && EQ (XCHAR_TABLE (arg)->purpose, Qcategory_table))
185 return Qt;
186 return Qnil;
189 /* If TABLE is nil, return the current category table. If TABLE is
190 not nil, check the validity of TABLE as a category table. If
191 valid, return TABLE itself, but if not valid, signal an error of
192 wrong-type-argument. */
194 static Lisp_Object
195 check_category_table (Lisp_Object table)
197 if (NILP (table))
198 return BVAR (current_buffer, category_table);
199 CHECK_TYPE (!NILP (Fcategory_table_p (table)), Qcategory_table_p, table);
200 return table;
203 DEFUN ("category-table", Fcategory_table, Scategory_table, 0, 0, 0,
204 doc: /* Return the current category table.
205 This is the one specified by the current buffer. */)
206 (void)
208 return BVAR (current_buffer, category_table);
211 DEFUN ("standard-category-table", Fstandard_category_table,
212 Sstandard_category_table, 0, 0, 0,
213 doc: /* Return the standard category table.
214 This is the one used for new buffers. */)
215 (void)
217 return Vstandard_category_table;
221 static void
222 copy_category_entry (Lisp_Object table, Lisp_Object c, Lisp_Object val)
224 val = Fcopy_sequence (val);
225 if (CONSP (c))
226 char_table_set_range (table, XINT (XCAR (c)), XINT (XCDR (c)), val);
227 else
228 char_table_set (table, XINT (c), val);
231 /* Return a copy of category table TABLE. We can't simply use the
232 function copy-sequence because no contents should be shared between
233 the original and the copy. This function is called recursively by
234 binding TABLE to a sub char table. */
236 static Lisp_Object
237 copy_category_table (Lisp_Object table)
239 table = copy_char_table (table);
241 if (! NILP (XCHAR_TABLE (table)->defalt))
242 set_char_table_defalt (table,
243 Fcopy_sequence (XCHAR_TABLE (table)->defalt));
244 set_char_table_extras
245 (table, 0, Fcopy_sequence (XCHAR_TABLE (table)->extras[0]));
246 map_char_table (copy_category_entry, Qnil, table, table);
248 return table;
251 DEFUN ("copy-category-table", Fcopy_category_table, Scopy_category_table,
252 0, 1, 0,
253 doc: /* Construct a new category table and return it.
254 It is a copy of the TABLE, which defaults to the standard category table. */)
255 (Lisp_Object table)
257 if (!NILP (table))
258 check_category_table (table);
259 else
260 table = Vstandard_category_table;
262 return copy_category_table (table);
265 DEFUN ("make-category-table", Fmake_category_table, Smake_category_table,
266 0, 0, 0,
267 doc: /* Construct a new and empty category table and return it. */)
268 (void)
270 Lisp_Object val;
271 int i;
273 val = Fmake_char_table (Qcategory_table, Qnil);
274 set_char_table_defalt (val, MAKE_CATEGORY_SET);
275 for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
276 set_char_table_contents (val, i, MAKE_CATEGORY_SET);
277 Fset_char_table_extra_slot (val, make_number (0),
278 Fmake_vector (make_number (95), Qnil));
279 return val;
282 DEFUN ("set-category-table", Fset_category_table, Sset_category_table, 1, 1, 0,
283 doc: /* Specify TABLE as the category table for the current buffer.
284 Return TABLE. */)
285 (Lisp_Object table)
287 int idx;
288 table = check_category_table (table);
289 bset_category_table (current_buffer, table);
290 /* Indicate that this buffer now has a specified category table. */
291 idx = PER_BUFFER_VAR_IDX (category_table);
292 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 1);
293 return table;
297 Lisp_Object
298 char_category_set (int c)
300 return CHAR_TABLE_REF (BVAR (current_buffer, category_table), c);
303 DEFUN ("char-category-set", Fchar_category_set, Schar_category_set, 1, 1, 0,
304 doc: /* Return the category set of CHAR.
305 usage: (char-category-set CHAR) */)
306 (Lisp_Object ch)
308 CHECK_CHARACTER (ch);
309 return CATEGORY_SET (XFASTINT (ch));
312 DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
313 Scategory_set_mnemonics, 1, 1, 0,
314 doc: /* Return a string containing mnemonics of the categories in CATEGORY-SET.
315 CATEGORY-SET is a bool-vector, and the categories \"in\" it are those
316 that are indexes where t occurs in the bool-vector.
317 The return value is a string containing those same categories. */)
318 (Lisp_Object category_set)
320 int i, j;
321 char str[96];
323 CHECK_CATEGORY_SET (category_set);
325 j = 0;
326 for (i = 32; i < 127; i++)
327 if (CATEGORY_MEMBER (i, category_set))
328 str[j++] = i;
329 str[j] = '\0';
331 return build_string (str);
334 DEFUN ("modify-category-entry", Fmodify_category_entry,
335 Smodify_category_entry, 2, 4, 0,
336 doc: /* Modify the category set of CHARACTER by adding CATEGORY to it.
337 The category is changed only for table TABLE, which defaults to
338 the current buffer's category table.
339 CHARACTER can be either a single character or a cons representing the
340 lower and upper ends of an inclusive character range to modify.
341 If optional fourth argument RESET is non-nil,
342 then delete CATEGORY from the category set instead of adding it. */)
343 (Lisp_Object character, Lisp_Object category, Lisp_Object table, Lisp_Object reset)
345 bool set_value; /* Actual value to be set in category sets. */
346 Lisp_Object category_set;
347 int start, end;
348 int from, to;
350 if (INTEGERP (character))
352 CHECK_CHARACTER (character);
353 start = end = XFASTINT (character);
355 else
357 CHECK_CONS (character);
358 CHECK_CHARACTER_CAR (character);
359 CHECK_CHARACTER_CDR (character);
360 start = XFASTINT (XCAR (character));
361 end = XFASTINT (XCDR (character));
364 CHECK_CATEGORY (category);
365 table = check_category_table (table);
367 if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
368 error ("Undefined category: %c", (int) XFASTINT (category));
370 set_value = NILP (reset);
372 while (start <= end)
374 from = start, to = end;
375 category_set = char_table_ref_and_range (table, start, &from, &to);
376 if (CATEGORY_MEMBER (XFASTINT (category), category_set) != NILP (reset))
378 category_set = Fcopy_sequence (category_set);
379 set_category_set (category_set, XFASTINT (category), set_value);
380 category_set = hash_get_category_set (table, category_set);
381 char_table_set_range (table, start, to, category_set);
383 start = to + 1;
386 return Qnil;
389 /* Return true if there is a word boundary between two word-constituent
390 characters C1 and C2 if they appear in this order.
391 Use the macro WORD_BOUNDARY_P instead of calling this function
392 directly. */
394 bool
395 word_boundary_p (int c1, int c2)
397 Lisp_Object category_set1, category_set2;
398 Lisp_Object tail;
399 bool default_result;
401 if (EQ (CHAR_TABLE_REF (Vchar_script_table, c1),
402 CHAR_TABLE_REF (Vchar_script_table, c2)))
404 tail = Vword_separating_categories;
405 default_result = 0;
407 else
409 tail = Vword_combining_categories;
410 default_result = 1;
413 category_set1 = CATEGORY_SET (c1);
414 if (NILP (category_set1))
415 return default_result;
416 category_set2 = CATEGORY_SET (c2);
417 if (NILP (category_set2))
418 return default_result;
420 for (; CONSP (tail); tail = XCDR (tail))
422 Lisp_Object elt = XCAR (tail);
424 if (CONSP (elt)
425 && (NILP (XCAR (elt))
426 || (CATEGORYP (XCAR (elt))
427 && CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set1)
428 && ! CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set2)))
429 && (NILP (XCDR (elt))
430 || (CATEGORYP (XCDR (elt))
431 && ! CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set1)
432 && CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set2))))
433 return !default_result;
435 return default_result;
439 void
440 init_category_once (void)
442 /* This has to be done here, before we call Fmake_char_table. */
443 DEFSYM (Qcategory_table, "category-table");
444 Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
446 Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
447 /* Set a category set which contains nothing to the default. */
448 set_char_table_defalt (Vstandard_category_table, MAKE_CATEGORY_SET);
449 Fset_char_table_extra_slot (Vstandard_category_table, make_number (0),
450 Fmake_vector (make_number (95), Qnil));
453 void
454 syms_of_category (void)
456 DEFSYM (Qcategoryp, "categoryp");
457 DEFSYM (Qcategorysetp, "categorysetp");
458 DEFSYM (Qcategory_table_p, "category-table-p");
460 DEFVAR_LISP ("word-combining-categories", Vword_combining_categories,
461 doc: /* List of pair (cons) of categories to determine word boundary.
463 Emacs treats a sequence of word constituent characters as a single
464 word (i.e. finds no word boundary between them) only if they belong to
465 the same script. But, exceptions are allowed in the following cases.
467 \(1) The case that characters are in different scripts is controlled
468 by the variable `word-combining-categories'.
470 Emacs finds no word boundary between characters of different scripts
471 if they have categories matching some element of this list.
473 More precisely, if an element of this list is a cons of category CAT1
474 and CAT2, and a multibyte character C1 which has CAT1 is followed by
475 C2 which has CAT2, there's no word boundary between C1 and C2.
477 For instance, to tell that Han characters followed by Hiragana
478 characters can form a single word, the element `(?C . ?H)' should be
479 in this list.
481 \(2) The case that character are in the same script is controlled by
482 the variable `word-separating-categories'.
484 Emacs finds a word boundary between characters of the same script
485 if they have categories matching some element of this list.
487 More precisely, if an element of this list is a cons of category CAT1
488 and CAT2, and a multibyte character C1 which has CAT1 but not CAT2 is
489 followed by C2 which has CAT2 but not CAT1, there's a word boundary
490 between C1 and C2.
492 For instance, to tell that there's a word boundary between Hiragana
493 and Katakana (both are in the same script `kana'),
494 the element `(?H . ?K) should be in this list. */);
496 Vword_combining_categories = Qnil;
498 DEFVAR_LISP ("word-separating-categories", Vword_separating_categories,
499 doc: /* List of pair (cons) of categories to determine word boundary.
500 See the documentation of the variable `word-combining-categories'. */);
502 Vword_separating_categories = Qnil;
504 defsubr (&Smake_category_set);
505 defsubr (&Sdefine_category);
506 defsubr (&Scategory_docstring);
507 defsubr (&Sget_unused_category);
508 defsubr (&Scategory_table_p);
509 defsubr (&Scategory_table);
510 defsubr (&Sstandard_category_table);
511 defsubr (&Scopy_category_table);
512 defsubr (&Smake_category_table);
513 defsubr (&Sset_category_table);
514 defsubr (&Schar_category_set);
515 defsubr (&Scategory_set_mnemonics);
516 defsubr (&Smodify_category_entry);
518 category_table_version = 0;