Merge from origin/emacs-24
[emacs.git] / src / category.c
bloba4610e4d358262fa8fbae946cf7b8f093ca0a0ec
1 /* GNU Emacs routines to deal with category tables.
3 Copyright (C) 1998, 2001-2014 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 static Lisp_Object Qcategory_table, Qcategoryp, Qcategorysetp, Qcategory_table_p;
59 /* Category set staff. */
61 static Lisp_Object
62 hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
64 struct Lisp_Hash_Table *h;
65 ptrdiff_t i;
66 EMACS_UINT hash;
68 if (NILP (XCHAR_TABLE (table)->extras[1]))
69 set_char_table_extras
70 (table, 1,
71 make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
72 make_float (DEFAULT_REHASH_SIZE),
73 make_float (DEFAULT_REHASH_THRESHOLD),
74 Qnil));
75 h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
76 i = hash_lookup (h, category_set, &hash);
77 if (i >= 0)
78 return HASH_KEY (h, i);
79 hash_put (h, category_set, Qnil, hash);
80 return category_set;
83 /* Make CATEGORY_SET include (if VAL) or exclude (if !VAL) CATEGORY. */
85 static void
86 set_category_set (Lisp_Object category_set, EMACS_INT category, bool val)
88 bool_vector_set (category_set, category, val);
91 DEFUN ("make-category-set", Fmake_category_set, Smake_category_set, 1, 1, 0,
92 doc: /* Return a newly created category-set which contains CATEGORIES.
93 CATEGORIES is a string of category mnemonics.
94 The value is a bool-vector which has t at the indices corresponding to
95 those categories. */)
96 (Lisp_Object categories)
98 Lisp_Object val;
99 ptrdiff_t len;
101 CHECK_STRING (categories);
102 val = MAKE_CATEGORY_SET;
104 if (STRING_MULTIBYTE (categories))
105 error ("Multibyte string in `make-category-set'");
107 len = SCHARS (categories);
108 while (--len >= 0)
110 unsigned char cat = SREF (categories, len);
111 Lisp_Object category = make_number (cat);
113 CHECK_CATEGORY (category);
114 set_category_set (val, cat, 1);
116 return val;
120 /* Category staff. */
122 static Lisp_Object check_category_table (Lisp_Object table);
124 DEFUN ("define-category", Fdefine_category, Sdefine_category, 2, 3, 0,
125 doc: /* Define CATEGORY as a category which is described by DOCSTRING.
126 CATEGORY should be an ASCII printing character in the range ` ' to `~'.
127 DOCSTRING is the documentation string of the category. The first line
128 should be a terse text (preferably less than 16 characters),
129 and the rest lines should be the full description.
130 The category is defined only in category table TABLE, which defaults to
131 the current buffer's category table. */)
132 (Lisp_Object category, Lisp_Object docstring, Lisp_Object table)
134 CHECK_CATEGORY (category);
135 CHECK_STRING (docstring);
136 table = check_category_table (table);
138 if (!NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
139 error ("Category `%c' is already defined", (int) XFASTINT (category));
140 if (!NILP (Vpurify_flag))
141 docstring = Fpurecopy (docstring);
142 SET_CATEGORY_DOCSTRING (table, XFASTINT (category), docstring);
144 return Qnil;
147 DEFUN ("category-docstring", Fcategory_docstring, Scategory_docstring, 1, 2, 0,
148 doc: /* Return the documentation string of CATEGORY, as defined in TABLE.
149 TABLE should be a category table and defaults to the current buffer's
150 category table. */)
151 (Lisp_Object category, Lisp_Object table)
153 CHECK_CATEGORY (category);
154 table = check_category_table (table);
156 return CATEGORY_DOCSTRING (table, XFASTINT (category));
159 DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category,
160 0, 1, 0,
161 doc: /* Return a category which is not yet defined in TABLE.
162 If no category remains available, return nil.
163 The optional argument TABLE specifies which category table to modify;
164 it defaults to the current buffer's category table. */)
165 (Lisp_Object table)
167 int i;
169 table = check_category_table (table);
171 for (i = ' '; i <= '~'; i++)
172 if (NILP (CATEGORY_DOCSTRING (table, i)))
173 return make_number (i);
175 return Qnil;
179 /* Category-table staff. */
181 DEFUN ("category-table-p", Fcategory_table_p, Scategory_table_p, 1, 1, 0,
182 doc: /* Return t if ARG is a category table. */)
183 (Lisp_Object arg)
185 if (CHAR_TABLE_P (arg)
186 && EQ (XCHAR_TABLE (arg)->purpose, Qcategory_table))
187 return Qt;
188 return Qnil;
191 /* If TABLE is nil, return the current category table. If TABLE is
192 not nil, check the validity of TABLE as a category table. If
193 valid, return TABLE itself, but if not valid, signal an error of
194 wrong-type-argument. */
196 static Lisp_Object
197 check_category_table (Lisp_Object table)
199 if (NILP (table))
200 return BVAR (current_buffer, category_table);
201 CHECK_TYPE (!NILP (Fcategory_table_p (table)), Qcategory_table_p, table);
202 return table;
205 DEFUN ("category-table", Fcategory_table, Scategory_table, 0, 0, 0,
206 doc: /* Return the current category table.
207 This is the one specified by the current buffer. */)
208 (void)
210 return BVAR (current_buffer, category_table);
213 DEFUN ("standard-category-table", Fstandard_category_table,
214 Sstandard_category_table, 0, 0, 0,
215 doc: /* Return the standard category table.
216 This is the one used for new buffers. */)
217 (void)
219 return Vstandard_category_table;
223 static void
224 copy_category_entry (Lisp_Object table, Lisp_Object c, Lisp_Object val)
226 val = Fcopy_sequence (val);
227 if (CONSP (c))
228 char_table_set_range (table, XINT (XCAR (c)), XINT (XCDR (c)), val);
229 else
230 char_table_set (table, XINT (c), val);
233 /* Return a copy of category table TABLE. We can't simply use the
234 function copy-sequence because no contents should be shared between
235 the original and the copy. This function is called recursively by
236 binding TABLE to a sub char table. */
238 static Lisp_Object
239 copy_category_table (Lisp_Object table)
241 table = copy_char_table (table);
243 if (! NILP (XCHAR_TABLE (table)->defalt))
244 set_char_table_defalt (table,
245 Fcopy_sequence (XCHAR_TABLE (table)->defalt));
246 set_char_table_extras
247 (table, 0, Fcopy_sequence (XCHAR_TABLE (table)->extras[0]));
248 map_char_table (copy_category_entry, Qnil, table, table);
250 return table;
253 DEFUN ("copy-category-table", Fcopy_category_table, Scopy_category_table,
254 0, 1, 0,
255 doc: /* Construct a new category table and return it.
256 It is a copy of the TABLE, which defaults to the standard category table. */)
257 (Lisp_Object table)
259 if (!NILP (table))
260 check_category_table (table);
261 else
262 table = Vstandard_category_table;
264 return copy_category_table (table);
267 DEFUN ("make-category-table", Fmake_category_table, Smake_category_table,
268 0, 0, 0,
269 doc: /* Construct a new and empty category table and return it. */)
270 (void)
272 Lisp_Object val;
273 int i;
275 val = Fmake_char_table (Qcategory_table, Qnil);
276 set_char_table_defalt (val, MAKE_CATEGORY_SET);
277 for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
278 set_char_table_contents (val, i, MAKE_CATEGORY_SET);
279 Fset_char_table_extra_slot (val, make_number (0),
280 Fmake_vector (make_number (95), Qnil));
281 return val;
284 DEFUN ("set-category-table", Fset_category_table, Sset_category_table, 1, 1, 0,
285 doc: /* Specify TABLE as the category table for the current buffer.
286 Return TABLE. */)
287 (Lisp_Object table)
289 int idx;
290 table = check_category_table (table);
291 bset_category_table (current_buffer, table);
292 /* Indicate that this buffer now has a specified category table. */
293 idx = PER_BUFFER_VAR_IDX (category_table);
294 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 1);
295 return table;
299 Lisp_Object
300 char_category_set (int c)
302 return CHAR_TABLE_REF (BVAR (current_buffer, category_table), c);
305 DEFUN ("char-category-set", Fchar_category_set, Schar_category_set, 1, 1, 0,
306 doc: /* Return the category set of CHAR.
307 usage: (char-category-set CHAR) */)
308 (Lisp_Object ch)
310 CHECK_CHARACTER (ch);
311 return CATEGORY_SET (XFASTINT (ch));
314 DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
315 Scategory_set_mnemonics, 1, 1, 0,
316 doc: /* Return a string containing mnemonics of the categories in CATEGORY-SET.
317 CATEGORY-SET is a bool-vector, and the categories \"in\" it are those
318 that are indexes where t occurs in the bool-vector.
319 The return value is a string containing those same categories. */)
320 (Lisp_Object category_set)
322 int i, j;
323 char str[96];
325 CHECK_CATEGORY_SET (category_set);
327 j = 0;
328 for (i = 32; i < 127; i++)
329 if (CATEGORY_MEMBER (i, category_set))
330 str[j++] = i;
331 str[j] = '\0';
333 return build_string (str);
336 DEFUN ("modify-category-entry", Fmodify_category_entry,
337 Smodify_category_entry, 2, 4, 0,
338 doc: /* Modify the category set of CHARACTER by adding CATEGORY to it.
339 The category is changed only for table TABLE, which defaults to
340 the current buffer's category table.
341 CHARACTER can be either a single character or a cons representing the
342 lower and upper ends of an inclusive character range to modify.
343 If optional fourth argument RESET is non-nil,
344 then delete CATEGORY from the category set instead of adding it. */)
345 (Lisp_Object character, Lisp_Object category, Lisp_Object table, Lisp_Object reset)
347 bool set_value; /* Actual value to be set in category sets. */
348 Lisp_Object category_set;
349 int start, end;
350 int from, to;
352 if (INTEGERP (character))
354 CHECK_CHARACTER (character);
355 start = end = XFASTINT (character);
357 else
359 CHECK_CONS (character);
360 CHECK_CHARACTER_CAR (character);
361 CHECK_CHARACTER_CDR (character);
362 start = XFASTINT (XCAR (character));
363 end = XFASTINT (XCDR (character));
366 CHECK_CATEGORY (category);
367 table = check_category_table (table);
369 if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
370 error ("Undefined category: %c", (int) XFASTINT (category));
372 set_value = NILP (reset);
374 while (start <= end)
376 from = start, to = end;
377 category_set = char_table_ref_and_range (table, start, &from, &to);
378 if (CATEGORY_MEMBER (XFASTINT (category), category_set) != NILP (reset))
380 category_set = Fcopy_sequence (category_set);
381 set_category_set (category_set, XFASTINT (category), set_value);
382 category_set = hash_get_category_set (table, category_set);
383 char_table_set_range (table, start, to, category_set);
385 start = to + 1;
388 return Qnil;
391 /* Return true if there is a word boundary between two word-constituent
392 characters C1 and C2 if they appear in this order.
393 Use the macro WORD_BOUNDARY_P instead of calling this function
394 directly. */
396 bool
397 word_boundary_p (int c1, int c2)
399 Lisp_Object category_set1, category_set2;
400 Lisp_Object tail;
401 bool default_result;
403 if (EQ (CHAR_TABLE_REF (Vchar_script_table, c1),
404 CHAR_TABLE_REF (Vchar_script_table, c2)))
406 tail = Vword_separating_categories;
407 default_result = 0;
409 else
411 tail = Vword_combining_categories;
412 default_result = 1;
415 category_set1 = CATEGORY_SET (c1);
416 if (NILP (category_set1))
417 return default_result;
418 category_set2 = CATEGORY_SET (c2);
419 if (NILP (category_set2))
420 return default_result;
422 for (; CONSP (tail); tail = XCDR (tail))
424 Lisp_Object elt = XCAR (tail);
426 if (CONSP (elt)
427 && (NILP (XCAR (elt))
428 || (CATEGORYP (XCAR (elt))
429 && CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set1)
430 && ! CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set2)))
431 && (NILP (XCDR (elt))
432 || (CATEGORYP (XCDR (elt))
433 && ! CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set1)
434 && CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set2))))
435 return !default_result;
437 return default_result;
441 void
442 init_category_once (void)
444 /* This has to be done here, before we call Fmake_char_table. */
445 DEFSYM (Qcategory_table, "category-table");
446 Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
448 Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
449 /* Set a category set which contains nothing to the default. */
450 set_char_table_defalt (Vstandard_category_table, MAKE_CATEGORY_SET);
451 Fset_char_table_extra_slot (Vstandard_category_table, make_number (0),
452 Fmake_vector (make_number (95), Qnil));
455 void
456 syms_of_category (void)
458 DEFSYM (Qcategoryp, "categoryp");
459 DEFSYM (Qcategorysetp, "categorysetp");
460 DEFSYM (Qcategory_table_p, "category-table-p");
462 DEFVAR_LISP ("word-combining-categories", Vword_combining_categories,
463 doc: /* List of pair (cons) of categories to determine word boundary.
465 Emacs treats a sequence of word constituent characters as a single
466 word (i.e. finds no word boundary between them) only if they belong to
467 the same script. But, exceptions are allowed in the following cases.
469 \(1) The case that characters are in different scripts is controlled
470 by the variable `word-combining-categories'.
472 Emacs finds no word boundary between characters of different scripts
473 if they have categories matching some element of this list.
475 More precisely, if an element of this list is a cons of category CAT1
476 and CAT2, and a multibyte character C1 which has CAT1 is followed by
477 C2 which has CAT2, there's no word boundary between C1 and C2.
479 For instance, to tell that Han characters followed by Hiragana
480 characters can form a single word, the element `(?C . ?H)' should be
481 in this list.
483 \(2) The case that character are in the same script is controlled by
484 the variable `word-separating-categories'.
486 Emacs finds a word boundary between characters of the same script
487 if they have categories matching some element of this list.
489 More precisely, if an element of this list is a cons of category CAT1
490 and CAT2, and a multibyte character C1 which has CAT1 but not CAT2 is
491 followed by C2 which has CAT2 but not CAT1, there's a word boundary
492 between C1 and C2.
494 For instance, to tell that there's a word boundary between Hiragana
495 and Katakana (both are in the same script `kana'),
496 the element `(?H . ?K) should be in this list. */);
498 Vword_combining_categories = Qnil;
500 DEFVAR_LISP ("word-separating-categories", Vword_separating_categories,
501 doc: /* List of pair (cons) of categories to determine word boundary.
502 See the documentation of the variable `word-combining-categories'. */);
504 Vword_separating_categories = Qnil;
506 defsubr (&Smake_category_set);
507 defsubr (&Sdefine_category);
508 defsubr (&Scategory_docstring);
509 defsubr (&Sget_unused_category);
510 defsubr (&Scategory_table_p);
511 defsubr (&Scategory_table);
512 defsubr (&Sstandard_category_table);
513 defsubr (&Scopy_category_table);
514 defsubr (&Smake_category_table);
515 defsubr (&Sset_category_table);
516 defsubr (&Schar_category_set);
517 defsubr (&Scategory_set_mnemonics);
518 defsubr (&Smodify_category_entry);
520 category_table_version = 0;