1 /* GNU Emacs routines to deal with category tables.
3 Copyright (C) 1998, 2001-2012 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
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. */
33 #define CATEGORY_INLINE EXTERN_INLINE
38 #include "character.h"
44 /* The version number of the latest category table. Each category
45 table has a unique version number. It is assigned a new number
46 also when it is modified. When a regular expression is compiled
47 into the struct re_pattern_buffer, the version number of the
48 category table (of the current buffer) at that moment is also
49 embedded in the structure.
51 For the moment, we are not using this feature. */
52 static int category_table_version
;
54 static Lisp_Object Qcategory_table
, Qcategoryp
, Qcategorysetp
, Qcategory_table_p
;
56 /* Make CATEGORY_SET includes (if VAL is t) or excludes (if VAL is
58 #define SET_CATEGORY_SET(category_set, category, val) \
59 set_category_set (category_set, category, val)
60 static void set_category_set (Lisp_Object
, Lisp_Object
, Lisp_Object
);
62 /* Category set staff. */
64 static Lisp_Object
hash_get_category_set (Lisp_Object
, Lisp_Object
);
67 hash_get_category_set (Lisp_Object table
, Lisp_Object category_set
)
69 struct Lisp_Hash_Table
*h
;
73 if (NILP (XCHAR_TABLE (table
)->extras
[1]))
76 make_hash_table (Qequal
, make_number (DEFAULT_HASH_SIZE
),
77 make_float (DEFAULT_REHASH_SIZE
),
78 make_float (DEFAULT_REHASH_THRESHOLD
),
80 h
= XHASH_TABLE (XCHAR_TABLE (table
)->extras
[1]);
81 i
= hash_lookup (h
, category_set
, &hash
);
83 return HASH_KEY (h
, i
);
84 hash_put (h
, category_set
, Qnil
, hash
);
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
94 (Lisp_Object categories
)
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
);
108 Lisp_Object category
;
110 XSETFASTINT (category
, SREF (categories
, len
));
111 CHECK_CATEGORY (category
);
112 SET_CATEGORY_SET (val
, category
, Qt
);
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 CATEGORY_DOCSTRING (table
, XFASTINT (category
)) = docstring
;
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
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
,
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. */)
167 table
= check_category_table (table
);
169 for (i
= ' '; i
<= '~'; i
++)
170 if (NILP (CATEGORY_DOCSTRING (table
, i
)))
171 return make_number (i
);
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. */)
183 if (CHAR_TABLE_P (arg
)
184 && EQ (XCHAR_TABLE (arg
)->purpose
, Qcategory_table
))
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. */
195 check_category_table (Lisp_Object table
)
198 return BVAR (current_buffer
, category_table
);
199 CHECK_TYPE (!NILP (Fcategory_table_p (table
)), Qcategory_table_p
, 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. */)
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. */)
217 return Vstandard_category_table
;
222 copy_category_entry (Lisp_Object table
, Lisp_Object c
, Lisp_Object val
)
224 val
= Fcopy_sequence (val
);
226 char_table_set_range (table
, XINT (XCAR (c
)), XINT (XCDR (c
)), val
);
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. */
237 copy_category_table (Lisp_Object table
)
239 table
= copy_char_table (table
);
241 if (! NILP (XCHAR_TABLE (table
)->defalt
))
242 CSET (XCHAR_TABLE (table
), defalt
,
243 Fcopy_sequence (XCHAR_TABLE (table
)->defalt
));
244 char_table_set_extras
245 (table
, 0, Fcopy_sequence (XCHAR_TABLE (table
)->extras
[0]));
246 map_char_table (copy_category_entry
, Qnil
, table
, table
);
251 DEFUN ("copy-category-table", Fcopy_category_table
, Scopy_category_table
,
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. */)
258 check_category_table (table
);
260 table
= Vstandard_category_table
;
262 return copy_category_table (table
);
265 DEFUN ("make-category-table", Fmake_category_table
, Smake_category_table
,
267 doc
: /* Construct a new and empty category table and return it. */)
273 val
= Fmake_char_table (Qcategory_table
, Qnil
);
274 CSET (XCHAR_TABLE (val
), defalt
, MAKE_CATEGORY_SET
);
275 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
276 char_table_set_contents (val
, i
, MAKE_CATEGORY_SET
);
277 Fset_char_table_extra_slot (val
, make_number (0),
278 Fmake_vector (make_number (95), Qnil
));
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.
288 table
= check_category_table (table
);
289 BSET (current_buffer
, category_table
, 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);
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) */)
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
)
323 CHECK_CATEGORY_SET (category_set
);
326 for (i
= 32; i
< 127; i
++)
327 if (CATEGORY_MEMBER (i
, category_set
))
331 return build_string (str
);
335 set_category_set (Lisp_Object category_set
, Lisp_Object category
, Lisp_Object val
)
338 int idx
= XINT (category
) / 8;
339 unsigned char bits
= 1 << (XINT (category
) % 8);
342 XCATEGORY_SET (category_set
)->data
[idx
] &= ~bits
;
344 XCATEGORY_SET (category_set
)->data
[idx
] |= bits
;
348 DEFUN ("modify-category-entry", Fmodify_category_entry
,
349 Smodify_category_entry
, 2, 4, 0,
350 doc
: /* Modify the category set of CHARACTER by adding CATEGORY to it.
351 The category is changed only for table TABLE, which defaults to
352 the current buffer's category table.
353 CHARACTER can be either a single character or a cons representing the
354 lower and upper ends of an inclusive character range to modify.
355 If optional fourth argument RESET is non-nil,
356 then delete CATEGORY from the category set instead of adding it. */)
357 (Lisp_Object character
, Lisp_Object category
, Lisp_Object table
, Lisp_Object reset
)
359 Lisp_Object set_value
; /* Actual value to be set in category sets. */
360 Lisp_Object category_set
;
364 if (INTEGERP (character
))
366 CHECK_CHARACTER (character
);
367 start
= end
= XFASTINT (character
);
371 CHECK_CONS (character
);
372 CHECK_CHARACTER_CAR (character
);
373 CHECK_CHARACTER_CDR (character
);
374 start
= XFASTINT (XCAR (character
));
375 end
= XFASTINT (XCDR (character
));
378 CHECK_CATEGORY (category
);
379 table
= check_category_table (table
);
381 if (NILP (CATEGORY_DOCSTRING (table
, XFASTINT (category
))))
382 error ("Undefined category: %c", (int) XFASTINT (category
));
384 set_value
= NILP (reset
) ? Qt
: Qnil
;
388 from
= start
, to
= end
;
389 category_set
= char_table_ref_and_range (table
, start
, &from
, &to
);
390 if (CATEGORY_MEMBER (XFASTINT (category
), category_set
) != NILP (reset
))
392 category_set
= Fcopy_sequence (category_set
);
393 SET_CATEGORY_SET (category_set
, category
, set_value
);
394 category_set
= hash_get_category_set (table
, category_set
);
395 char_table_set_range (table
, start
, to
, category_set
);
403 /* Return 1 if there is a word boundary between two word-constituent
404 characters C1 and C2 if they appear in this order, else return 0.
405 Use the macro WORD_BOUNDARY_P instead of calling this function
409 word_boundary_p (int c1
, int c2
)
411 Lisp_Object category_set1
, category_set2
;
415 if (EQ (CHAR_TABLE_REF (Vchar_script_table
, c1
),
416 CHAR_TABLE_REF (Vchar_script_table
, c2
)))
418 tail
= Vword_separating_categories
;
423 tail
= Vword_combining_categories
;
427 category_set1
= CATEGORY_SET (c1
);
428 if (NILP (category_set1
))
429 return default_result
;
430 category_set2
= CATEGORY_SET (c2
);
431 if (NILP (category_set2
))
432 return default_result
;
434 for (; CONSP (tail
); tail
= XCDR (tail
))
436 Lisp_Object elt
= XCAR (tail
);
439 && (NILP (XCAR (elt
))
440 || (CATEGORYP (XCAR (elt
))
441 && CATEGORY_MEMBER (XFASTINT (XCAR (elt
)), category_set1
)
442 && ! CATEGORY_MEMBER (XFASTINT (XCAR (elt
)), category_set2
)))
443 && (NILP (XCDR (elt
))
444 || (CATEGORYP (XCDR (elt
))
445 && ! CATEGORY_MEMBER (XFASTINT (XCDR (elt
)), category_set1
)
446 && CATEGORY_MEMBER (XFASTINT (XCDR (elt
)), category_set2
))))
447 return !default_result
;
449 return default_result
;
454 init_category_once (void)
456 /* This has to be done here, before we call Fmake_char_table. */
457 DEFSYM (Qcategory_table
, "category-table");
459 /* Intern this now in case it isn't already done.
460 Setting this variable twice is harmless.
461 But don't staticpro it here--that is done in alloc.c. */
462 Qchar_table_extra_slots
= intern_c_string ("char-table-extra-slots");
464 /* Now we are ready to set up this property, so we can
465 create category tables. */
466 Fput (Qcategory_table
, Qchar_table_extra_slots
, make_number (2));
468 Vstandard_category_table
= Fmake_char_table (Qcategory_table
, Qnil
);
469 /* Set a category set which contains nothing to the default. */
470 CSET (XCHAR_TABLE (Vstandard_category_table
), defalt
, MAKE_CATEGORY_SET
);
471 Fset_char_table_extra_slot (Vstandard_category_table
, make_number (0),
472 Fmake_vector (make_number (95), Qnil
));
476 syms_of_category (void)
478 DEFSYM (Qcategoryp
, "categoryp");
479 DEFSYM (Qcategorysetp
, "categorysetp");
480 DEFSYM (Qcategory_table_p
, "category-table-p");
482 DEFVAR_LISP ("word-combining-categories", Vword_combining_categories
,
483 doc
: /* List of pair (cons) of categories to determine word boundary.
485 Emacs treats a sequence of word constituent characters as a single
486 word (i.e. finds no word boundary between them) only if they belong to
487 the same script. But, exceptions are allowed in the following cases.
489 \(1) The case that characters are in different scripts is controlled
490 by the variable `word-combining-categories'.
492 Emacs finds no word boundary between characters of different scripts
493 if they have categories matching some element of this list.
495 More precisely, if an element of this list is a cons of category CAT1
496 and CAT2, and a multibyte character C1 which has CAT1 is followed by
497 C2 which has CAT2, there's no word boundary between C1 and C2.
499 For instance, to tell that Han characters followed by Hiragana
500 characters can form a single word, the element `(?C . ?H)' should be
503 \(2) The case that character are in the same script is controlled by
504 the variable `word-separating-categories'.
506 Emacs finds a word boundary between characters of the same script
507 if they have categories matching some element of this list.
509 More precisely, if an element of this list is a cons of category CAT1
510 and CAT2, and a multibyte character C1 which has CAT1 but not CAT2 is
511 followed by C2 which has CAT2 but not CAT1, there's a word boundary
514 For instance, to tell that there's a word boundary between Hiragana
515 and Katakana (both are in the same script `kana'),
516 the element `(?H . ?K) should be in this list. */);
518 Vword_combining_categories
= Qnil
;
520 DEFVAR_LISP ("word-separating-categories", Vword_separating_categories
,
521 doc
: /* List of pair (cons) of categories to determine word boundary.
522 See the documentation of the variable `word-combining-categories'. */);
524 Vword_separating_categories
= Qnil
;
526 defsubr (&Smake_category_set
);
527 defsubr (&Sdefine_category
);
528 defsubr (&Scategory_docstring
);
529 defsubr (&Sget_unused_category
);
530 defsubr (&Scategory_table_p
);
531 defsubr (&Scategory_table
);
532 defsubr (&Sstandard_category_table
);
533 defsubr (&Scopy_category_table
);
534 defsubr (&Smake_category_table
);
535 defsubr (&Sset_category_table
);
536 defsubr (&Schar_category_set
);
537 defsubr (&Scategory_set_mnemonics
);
538 defsubr (&Smodify_category_entry
);
540 category_table_version
= 0;