(sgml-empty-tags): New var.
[emacs.git] / src / category.c
blob40804367528010c7a9039d86419af408f3f2e8b1
1 /* GNU Emacs routines to deal with category tables.
2 Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
3 Licensed to the Free Software Foundation.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
23 /* Here we handle three objects: category, category set, and category
24 table. Read comments in the file category.h to understand them. */
26 #include <config.h>
27 #include <ctype.h>
28 #include "lisp.h"
29 #include "buffer.h"
30 #include "charset.h"
31 #include "category.h"
32 #include "keymap.h"
34 /* The version number of the latest category table. Each category
35 table has a unique version number. It is assigned a new number
36 also when it is modified. When a regular expression is compiled
37 into the struct re_pattern_buffer, the version number of the
38 category table (of the current buffer) at that moment is also
39 embedded in the structure.
41 For the moment, we are not using this feature. */
42 static int category_table_version;
44 Lisp_Object Qcategory_table, Qcategoryp, Qcategorysetp, Qcategory_table_p;
46 /* Variables to determine word boundary. */
47 Lisp_Object Vword_combining_categories, Vword_separating_categories;
49 /* Temporary internal variable used in macro CHAR_HAS_CATEGORY. */
50 Lisp_Object _temp_category_set;
53 /* Category set staff. */
55 DEFUN ("make-category-set", Fmake_category_set, Smake_category_set, 1, 1, 0,
56 doc: /* Return a newly created category-set which contains CATEGORIES.
57 CATEGORIES is a string of category mnemonics.
58 The value is a bool-vector which has t at the indices corresponding to
59 those categories. */)
60 (categories)
61 Lisp_Object categories;
63 Lisp_Object val;
64 int len;
66 CHECK_STRING (categories, 0);
67 val = MAKE_CATEGORY_SET;
69 if (STRING_MULTIBYTE (categories))
70 error ("Multibyte string in make-category-set");
72 len = XSTRING (categories)->size;
73 while (--len >= 0)
75 Lisp_Object category;
77 XSETFASTINT (category, XSTRING (categories)->data[len]);
78 CHECK_CATEGORY (category, 0);
79 SET_CATEGORY_SET (val, category, Qt);
81 return val;
85 /* Category staff. */
87 Lisp_Object check_category_table ();
89 DEFUN ("define-category", Fdefine_category, Sdefine_category, 2, 3, 0,
90 doc: /* Define CHAR as a category which is described by DOCSTRING.
91 CHAR should be an ASCII printing character in the range ` ' to `~'.
92 DOCSTRING is a documentation string of the category.
93 The category is defined only in category table TABLE, which defaults to
94 the current buffer's category table. */)
95 (category, docstring, table)
96 Lisp_Object category, docstring, table;
98 CHECK_CATEGORY (category, 0);
99 CHECK_STRING (docstring, 1);
100 table = check_category_table (table);
102 if (!NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
103 error ("Category `%c' is already defined", XFASTINT (category));
104 CATEGORY_DOCSTRING (table, XFASTINT (category)) = docstring;
106 return Qnil;
109 DEFUN ("category-docstring", Fcategory_docstring, Scategory_docstring, 1, 2, 0,
110 doc: /* Return the documentation string of CATEGORY, as defined in CATEGORY-TABLE. */)
111 (category, table)
112 Lisp_Object category, table;
114 CHECK_CATEGORY (category, 0);
115 table = check_category_table (table);
117 return CATEGORY_DOCSTRING (table, XFASTINT (category));
120 DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category,
121 0, 1, 0,
122 doc: /* Return a category which is not yet defined in CATEGORY-TABLE. If no
123 category remains available, return nil. The optional argument CATEGORY-TABLE
124 specifies which category table to modify; it defaults to the current
125 buffer's category table. */)
126 (table)
127 Lisp_Object table;
129 int i;
131 table = check_category_table (table);
133 for (i = ' '; i <= '~'; i++)
134 if (NILP (CATEGORY_DOCSTRING (table, i)))
135 return make_number (i);
137 return Qnil;
141 /* Category-table staff. */
143 DEFUN ("category-table-p", Fcategory_table_p, Scategory_table_p, 1, 1, 0,
144 doc: /* Return t if ARG is a category table. */)
145 (arg)
146 Lisp_Object arg;
148 if (CHAR_TABLE_P (arg)
149 && EQ (XCHAR_TABLE (arg)->purpose, Qcategory_table))
150 return Qt;
151 return Qnil;
154 /* If TABLE is nil, return the current category table. If TABLE is
155 not nil, check the validity of TABLE as a category table. If
156 valid, return TABLE itself, but if not valid, signal an error of
157 wrong-type-argument. */
159 Lisp_Object
160 check_category_table (table)
161 Lisp_Object table;
163 register Lisp_Object tem;
164 if (NILP (table))
165 return current_buffer->category_table;
166 while (tem = Fcategory_table_p (table), NILP (tem))
167 table = wrong_type_argument (Qcategory_table_p, table);
168 return table;
171 DEFUN ("category-table", Fcategory_table, Scategory_table, 0, 0, 0,
172 doc: /* Return the current category table.
173 This is the one specified by the current buffer. */)
176 return current_buffer->category_table;
179 DEFUN ("standard-category-table", Fstandard_category_table,
180 Sstandard_category_table, 0, 0, 0,
181 doc: /* Return the standard category table.
182 This is the one used for new buffers. */)
185 return Vstandard_category_table;
188 /* Return a copy of category table TABLE. We can't simply use the
189 function copy-sequence because no contents should be shared between
190 the original and the copy. This function is called recursively by
191 binding TABLE to a sub char table. */
193 Lisp_Object
194 copy_category_table (table)
195 Lisp_Object table;
197 Lisp_Object tmp;
198 int i, to;
200 if (!NILP (XCHAR_TABLE (table)->top))
202 /* TABLE is a top level char table.
203 At first, make a copy of tree structure of the table. */
204 table = Fcopy_sequence (table);
206 /* Then, copy elements for single byte characters one by one. */
207 for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
208 if (!NILP (tmp = XCHAR_TABLE (table)->contents[i]))
209 XCHAR_TABLE (table)->contents[i] = Fcopy_sequence (tmp);
210 to = CHAR_TABLE_ORDINARY_SLOTS;
212 /* Also copy the first (and sole) extra slot. It is a vector
213 containing docstring of each category. */
214 Fset_char_table_extra_slot
215 (table, make_number (0),
216 Fcopy_sequence (Fchar_table_extra_slot (table, make_number (0))));
218 else
220 i = 32;
221 to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
224 /* If the table has non-nil default value, copy it. */
225 if (!NILP (tmp = XCHAR_TABLE (table)->defalt))
226 XCHAR_TABLE (table)->defalt = Fcopy_sequence (tmp);
228 /* At last, copy the remaining elements while paying attention to a
229 sub char table. */
230 for (; i < to; i++)
231 if (!NILP (tmp = XCHAR_TABLE (table)->contents[i]))
232 XCHAR_TABLE (table)->contents[i]
233 = (SUB_CHAR_TABLE_P (tmp)
234 ? copy_category_table (tmp) : Fcopy_sequence (tmp));
236 return table;
239 DEFUN ("copy-category-table", Fcopy_category_table, Scopy_category_table,
240 0, 1, 0,
241 doc: /* Construct a new category table and return it.
242 It is a copy of the TABLE, which defaults to the standard category table. */)
243 (table)
244 Lisp_Object table;
246 if (!NILP (table))
247 check_category_table (table);
248 else
249 table = Vstandard_category_table;
251 return copy_category_table (table);
254 DEFUN ("make-category-table", Fmake_category_table, Smake_category_table,
255 0, 0, 0,
256 doc: /* Construct a new and empty category table and return it. */)
259 Lisp_Object val;
261 val = Fmake_char_table (Qcategory_table, Qnil);
262 XCHAR_TABLE (val)->defalt = MAKE_CATEGORY_SET;
263 Fset_char_table_extra_slot (val, make_number (0),
264 Fmake_vector (make_number (95), Qnil));
265 return val;
268 DEFUN ("set-category-table", Fset_category_table, Sset_category_table, 1, 1, 0,
269 doc: /* Specify TABLE as the category table for the current buffer. */)
270 (table)
271 Lisp_Object table;
273 int idx;
274 table = check_category_table (table);
275 current_buffer->category_table = table;
276 /* Indicate that this buffer now has a specified category table. */
277 idx = PER_BUFFER_VAR_IDX (category_table);
278 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 1);
279 return table;
283 DEFUN ("char-category-set", Fchar_category_set, Schar_category_set, 1, 1, 0,
284 doc: /* Return the category set of CHAR. */)
285 (ch)
286 Lisp_Object ch;
288 CHECK_NUMBER (ch, 0);
289 return CATEGORY_SET (XFASTINT (ch));
292 DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
293 Scategory_set_mnemonics, 1, 1, 0,
294 doc: /* Return a string containing mnemonics of the categories in CATEGORY-SET.
295 CATEGORY-SET is a bool-vector, and the categories \"in\" it are those
296 that are indexes where t occurs the bool-vector.
297 The return value is a string containing those same categories. */)
298 (category_set)
299 Lisp_Object category_set;
301 int i, j;
302 char str[96];
304 CHECK_CATEGORY_SET (category_set, 0);
306 j = 0;
307 for (i = 32; i < 127; i++)
308 if (CATEGORY_MEMBER (i, category_set))
309 str[j++] = i;
310 str[j] = '\0';
312 return build_string (str);
315 /* Modify all category sets stored under sub char-table TABLE so that
316 they contain (SET_VALUE is t) or don't contain (SET_VALUE is nil)
317 CATEGORY. */
319 void
320 modify_lower_category_set (table, category, set_value)
321 Lisp_Object table, category, set_value;
323 Lisp_Object val;
324 int i;
326 val = XCHAR_TABLE (table)->defalt;
327 if (!CATEGORY_SET_P (val))
328 val = MAKE_CATEGORY_SET;
329 SET_CATEGORY_SET (val, category, set_value);
330 XCHAR_TABLE (table)->defalt = val;
332 for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++)
334 val = XCHAR_TABLE (table)->contents[i];
336 if (CATEGORY_SET_P (val))
337 SET_CATEGORY_SET (val, category, set_value);
338 else if (SUB_CHAR_TABLE_P (val))
339 modify_lower_category_set (val, category, set_value);
343 void
344 set_category_set (category_set, category, val)
345 Lisp_Object category_set, category, val;
347 do {
348 int idx = XINT (category) / 8;
349 unsigned char bits = 1 << (XINT (category) % 8);
351 if (NILP (val))
352 XCATEGORY_SET (category_set)->data[idx] &= ~bits;
353 else
354 XCATEGORY_SET (category_set)->data[idx] |= bits;
355 } while (0);
358 DEFUN ("modify-category-entry", Fmodify_category_entry,
359 Smodify_category_entry, 2, 4, 0,
360 doc: /* Modify the category set of CHARACTER by adding CATEGORY to it.
361 The category is changed only for table TABLE, which defaults to
362 the current buffer's category table.
363 If optional fourth argument RESET is non-nil,
364 then delete CATEGORY from the category set instead of adding it. */)
365 (character, category, table, reset)
366 Lisp_Object character, category, table, reset;
368 int c, charset, c1, c2;
369 Lisp_Object set_value; /* Actual value to be set in category sets. */
370 Lisp_Object val, category_set;
372 CHECK_NUMBER (character, 0);
373 c = XINT (character);
374 CHECK_CATEGORY (category, 1);
375 table = check_category_table (table);
377 if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
378 error ("Undefined category: %c", XFASTINT (category));
380 set_value = NILP (reset) ? Qt : Qnil;
382 if (c < CHAR_TABLE_SINGLE_BYTE_SLOTS)
384 val = XCHAR_TABLE (table)->contents[c];
385 if (!CATEGORY_SET_P (val))
386 XCHAR_TABLE (table)->contents[c] = (val = MAKE_CATEGORY_SET);
387 SET_CATEGORY_SET (val, category, set_value);
388 return Qnil;
391 SPLIT_CHAR (c, charset, c1, c2);
393 /* The top level table. */
394 val = XCHAR_TABLE (table)->contents[charset + 128];
395 if (CATEGORY_SET_P (val))
396 category_set = val;
397 else if (!SUB_CHAR_TABLE_P (val))
399 category_set = val = MAKE_CATEGORY_SET;
400 XCHAR_TABLE (table)->contents[charset + 128] = category_set;
403 if (c1 <= 0)
405 /* Only a charset is specified. */
406 if (SUB_CHAR_TABLE_P (val))
407 /* All characters in CHARSET should be the same as for having
408 CATEGORY or not. */
409 modify_lower_category_set (val, category, set_value);
410 else
411 SET_CATEGORY_SET (category_set, category, set_value);
412 return Qnil;
415 /* The second level table. */
416 if (!SUB_CHAR_TABLE_P (val))
418 val = make_sub_char_table (Qnil);
419 XCHAR_TABLE (table)->contents[charset + 128] = val;
420 /* We must set default category set of CHARSET in `defalt' slot. */
421 XCHAR_TABLE (val)->defalt = category_set;
423 table = val;
425 val = XCHAR_TABLE (table)->contents[c1];
426 if (CATEGORY_SET_P (val))
427 category_set = val;
428 else if (!SUB_CHAR_TABLE_P (val))
430 category_set = val = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
431 XCHAR_TABLE (table)->contents[c1] = category_set;
434 if (c2 <= 0)
436 if (SUB_CHAR_TABLE_P (val))
437 /* All characters in C1 group of CHARSET should be the same as
438 for CATEGORY. */
439 modify_lower_category_set (val, category, set_value);
440 else
441 SET_CATEGORY_SET (category_set, category, set_value);
442 return Qnil;
445 /* The third (bottom) level table. */
446 if (!SUB_CHAR_TABLE_P (val))
448 val = make_sub_char_table (Qnil);
449 XCHAR_TABLE (table)->contents[c1] = val;
450 /* We must set default category set of CHARSET and C1 in
451 `defalt' slot. */
452 XCHAR_TABLE (val)->defalt = category_set;
454 table = val;
456 val = XCHAR_TABLE (table)->contents[c2];
457 if (CATEGORY_SET_P (val))
458 category_set = val;
459 else if (!SUB_CHAR_TABLE_P (val))
461 category_set = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
462 XCHAR_TABLE (table)->contents[c2] = category_set;
464 else
465 /* This should never happen. */
466 error ("Invalid category table");
468 SET_CATEGORY_SET (category_set, category, set_value);
470 return Qnil;
473 /* Dump category table to buffer in human-readable format */
475 static void
476 describe_category (value)
477 Lisp_Object value;
479 Lisp_Object mnemonics;
481 Findent_to (make_number (16), make_number (1));
483 if (NILP (value))
485 insert_string ("default\n");
486 return;
489 if (CHAR_TABLE_P (value))
491 insert_string ("deeper char-table ...\n");
492 return;
495 if (!CATEGORY_SET_P (value))
497 insert_string ("invalid\n");
498 return;
501 mnemonics = Fcategory_set_mnemonics (value);
502 insert_from_string (mnemonics, 0, 0, XSTRING (mnemonics)->size,
503 STRING_BYTES (XSTRING (mnemonics)), 0);
504 insert_string ("\n");
505 return;
508 static Lisp_Object
509 describe_category_1 (vector)
510 Lisp_Object vector;
512 struct buffer *old = current_buffer;
513 set_buffer_internal (XBUFFER (Vstandard_output));
514 describe_vector (vector, Qnil, describe_category, 0, Qnil, Qnil,
515 (int *)0, 0);
517 int i;
518 Lisp_Object docs = XCHAR_TABLE (vector)->extras[0];
519 Lisp_Object elt;
521 if (!VECTORP (docs) || XVECTOR (docs)->size != 95)
523 insert_string ("Invalid first extra slot in this char table\n");
524 return Qnil;
527 insert_string ("Meanings of mnemonice characters are:\n");
528 for (i = 0; i < 95; i++)
530 elt = XVECTOR (docs)->contents[i];
531 if (NILP (elt))
532 continue;
534 insert_char (i + 32);
535 insert (": ", 2);
536 insert_from_string (elt, 0, 0, XSTRING (elt)->size,
537 STRING_BYTES (XSTRING (elt)), 0);
538 insert ("\n", 1);
542 while (! NILP (XCHAR_TABLE (vector)->parent))
544 vector = XCHAR_TABLE (vector)->parent;
545 insert_string ("\nThe parent category table is:");
546 describe_vector (vector, Qnil, describe_category, 0, Qnil, Qnil,
547 (int *) 0, 0);
550 call0 (intern ("help-mode"));
551 set_buffer_internal (old);
552 return Qnil;
555 DEFUN ("describe-categories", Fdescribe_categories, Sdescribe_categories, 0, 0, "",
556 doc: /* Describe the category specifications in the current category table.
557 The descriptions are inserted in a buffer, which is then displayed. */)
560 internal_with_output_to_temp_buffer
561 ("*Help*", describe_category_1, current_buffer->category_table);
563 return Qnil;
566 /* Return 1 if there is a word boundary between two word-constituent
567 characters C1 and C2 if they appear in this order, else return 0.
568 Use the macro WORD_BOUNDARY_P instead of calling this function
569 directly. */
572 word_boundary_p (c1, c2)
573 int c1, c2;
575 Lisp_Object category_set1, category_set2;
576 Lisp_Object tail;
577 int default_result;
579 if (CHAR_CHARSET (c1) == CHAR_CHARSET (c2))
581 tail = Vword_separating_categories;
582 default_result = 0;
584 else
586 tail = Vword_combining_categories;
587 default_result = 1;
590 category_set1 = CATEGORY_SET (c1);
591 if (NILP (category_set1))
592 return default_result;
593 category_set2 = CATEGORY_SET (c2);
594 if (NILP (category_set2))
595 return default_result;
597 for (; CONSP (tail); tail = XCDR (tail))
599 Lisp_Object elt = XCAR (tail);
601 if (CONSP (elt)
602 && CATEGORYP (XCAR (elt))
603 && CATEGORYP (XCDR (elt))
604 && CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set1)
605 && CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set2))
606 return !default_result;
608 return default_result;
612 void
613 init_category_once ()
615 /* This has to be done here, before we call Fmake_char_table. */
616 Qcategory_table = intern ("category-table");
617 staticpro (&Qcategory_table);
619 /* Intern this now in case it isn't already done.
620 Setting this variable twice is harmless.
621 But don't staticpro it here--that is done in alloc.c. */
622 Qchar_table_extra_slots = intern ("char-table-extra-slots");
624 /* Now we are ready to set up this property, so we can
625 create category tables. */
626 Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
628 Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
629 /* Set a category set which contains nothing to the default. */
630 XCHAR_TABLE (Vstandard_category_table)->defalt = MAKE_CATEGORY_SET;
631 Fset_char_table_extra_slot (Vstandard_category_table, make_number (0),
632 Fmake_vector (make_number (95), Qnil));
635 void
636 syms_of_category ()
638 Qcategoryp = intern ("categoryp");
639 staticpro (&Qcategoryp);
640 Qcategorysetp = intern ("categorysetp");
641 staticpro (&Qcategorysetp);
642 Qcategory_table_p = intern ("category-table-p");
643 staticpro (&Qcategory_table_p);
645 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories,
646 doc: /* List of pair (cons) of categories to determine word boundary.
648 Emacs treats a sequence of word constituent characters as a single
649 word (i.e. finds no word boundary between them) iff they belongs to
650 the same charset. But, exceptions are allowed in the following cases.
652 \(1) The case that characters are in different charsets is controlled
653 by the variable `word-combining-categories'.
655 Emacs finds no word boundary between characters of different charsets
656 if they have categories matching some element of this list.
658 More precisely, if an element of this list is a cons of category CAT1
659 and CAT2, and a multibyte character C1 which has CAT1 is followed by
660 C2 which has CAT2, there's no word boundary between C1 and C2.
662 For instance, to tell that ASCII characters and Latin-1 characters can
663 form a single word, the element `(?l . ?l)' should be in this list
664 because both characters have the category `l' (Latin characters).
666 \(2) The case that character are in the same charset is controlled by
667 the variable `word-separating-categories'.
669 Emacs find a word boundary between characters of the same charset
670 if they have categories matching some element of this list.
672 More precisely, if an element of this list is a cons of category CAT1
673 and CAT2, and a multibyte character C1 which has CAT1 is followed by
674 C2 which has CAT2, there's a word boundary between C1 and C2.
676 For instance, to tell that there's a word boundary between Japanese
677 Hiragana and Japanese Kanji (both are in the same charset), the
678 element `(?H . ?C) should be in this list. */);
680 Vword_combining_categories = Qnil;
682 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories,
683 doc: /* List of pair (cons) of categories to determine word boundary.
684 See the documentation of the variable `word-combining-categories'. */);
686 Vword_separating_categories = Qnil;
688 defsubr (&Smake_category_set);
689 defsubr (&Sdefine_category);
690 defsubr (&Scategory_docstring);
691 defsubr (&Sget_unused_category);
692 defsubr (&Scategory_table_p);
693 defsubr (&Scategory_table);
694 defsubr (&Sstandard_category_table);
695 defsubr (&Scopy_category_table);
696 defsubr (&Smake_category_table);
697 defsubr (&Sset_category_table);
698 defsubr (&Schar_category_set);
699 defsubr (&Scategory_set_mnemonics);
700 defsubr (&Smodify_category_entry);
701 defsubr (&Sdescribe_categories);
703 category_table_version = 0;