src/category.c

   1 /* GNU Emacs routines to deal with category tables.
   2
   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
  11
  12 This file is part of GNU Emacs.
  13
  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.
  18
  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.
  23
  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/>.  */
  26
  27
  28 /* Here we handle three objects: category, category set, and category
  29    table.  Read comments in the file category.h to understand them.  */
  30
  31 #include <config.h>
  32
  33 #include "lisp.h"
  34 #include "character.h"
  35 #include "buffer.h"
  36 #include "charset.h"
  37 #include "category.h"
  38 #include "keymap.h"
  39
  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)
  43 {
  44   b->INTERNAL_FIELD (category_table) = val;
  45 }
  46
  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.
  53
  54    For the moment, we are not using this feature.  */
  55 static int category_table_version;
  56
  57 static Lisp_Object Qcategory_table, Qcategoryp, Qcategorysetp, Qcategory_table_p;
  58 \f
  59 /* Category set staff.  */
  60
  61 static Lisp_Object
  62 hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
  63 {
  64   struct Lisp_Hash_Table *h;
  65   ptrdiff_t i;
  66   EMACS_UINT hash;
  67
  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;
  81 }
  82
  83 /* Make CATEGORY_SET include (if VAL) or exclude (if !VAL) CATEGORY.  */
  84
  85 static void
  86 set_category_set (Lisp_Object category_set, EMACS_INT category, bool val)
  87 {
  88   bool_vector_set (category_set, category, val);
  89 }
  90
  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)
  97 {
  98   Lisp_Object val;
  99   ptrdiff_t len;
 100
 101   CHECK_STRING (categories);
 102   val = MAKE_CATEGORY_SET;
 103
 104   if (STRING_MULTIBYTE (categories))
 105     error ("Multibyte string in `make-category-set'");
 106
 107   len = SCHARS (categories);
 108   while (--len >= 0)
 109     {
 110       unsigned char cat = SREF (categories, len);
 111       Lisp_Object category = make_number (cat);
 112
 113       CHECK_CATEGORY (category);
 114       set_category_set (val, cat, 1);
 115     }
 116   return val;
 117 }
 118
 119 \f
 120 /* Category staff.  */
 121
 122 static Lisp_Object check_category_table (Lisp_Object table);
 123
 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)
 133 {
 134   CHECK_CATEGORY (category);
 135   CHECK_STRING (docstring);
 136   table = check_category_table (table);
 137
 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);
 143
 144   return Qnil;
 145 }
 146
 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)
 152 {
 153   CHECK_CATEGORY (category);
 154   table = check_category_table (table);
 155
 156   return CATEGORY_DOCSTRING (table, XFASTINT (category));
 157 }
 158
 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)
 166 {
 167   int i;
 168
 169   table = check_category_table (table);
 170
 171   for (i = ' '; i <= '~'; i++)
 172     if (NILP (CATEGORY_DOCSTRING (table, i)))
 173       return make_number (i);
 174
 175   return Qnil;
 176 }
 177
 178 \f
 179 /* Category-table staff.  */
 180
 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)
 184 {
 185   if (CHAR_TABLE_P (arg)
 186       && EQ (XCHAR_TABLE (arg)->purpose, Qcategory_table))
 187     return Qt;
 188   return Qnil;
 189 }
 190
 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.  */
 195
 196 static Lisp_Object
 197 check_category_table (Lisp_Object table)
 198 {
 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;
 203 }
 204
 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)
 209 {
 210   return BVAR (current_buffer, category_table);
 211 }
 212
 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)
 218 {
 219   return Vstandard_category_table;
 220 }
 221
 222
 223 static void
 224 copy_category_entry (Lisp_Object table, Lisp_Object c, Lisp_Object val)
 225 {
 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);
 231 }
 232
 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.  */
 237
 238 static Lisp_Object
 239 copy_category_table (Lisp_Object table)
 240 {
 241   table = copy_char_table (table);
 242
 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);
 249
 250   return table;
 251 }
 252
 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)
 258 {
 259   if (!NILP (table))
 260     check_category_table (table);
 261   else
 262     table = Vstandard_category_table;
 263
 264   return copy_category_table (table);
 265 }
 266
 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)
 271 {
 272   Lisp_Object val;
 273   int i;
 274
 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;
 282 }
 283
 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)
 288 {
 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;
 296 }
 297
 298 \f
 299 Lisp_Object
 300 char_category_set (int c)
 301 {
 302   return CHAR_TABLE_REF (BVAR (current_buffer, category_table), c);
 303 }
 304
 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)
 309 {
 310   CHECK_CHARACTER (ch);
 311   return CATEGORY_SET (XFASTINT (ch));
 312 }
 313
 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)
 321 {
 322   int i, j;
 323   char str[96];
 324
 325   CHECK_CATEGORY_SET (category_set);
 326
 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';
 332
 333   return build_string (str);
 334 }
 335
 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)
 346 {
 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;
 351
 352   if (INTEGERP (character))
 353     {
 354       CHECK_CHARACTER (character);
 355       start = end = XFASTINT (character);
 356     }
 357   else
 358     {
 359       CHECK_CONS (character);
 360       CHECK_CHARACTER_CAR (character);
 361       CHECK_CHARACTER_CDR (character);
 362       start = XFASTINT (XCAR (character));
 363       end = XFASTINT (XCDR (character));
 364     }
 365
 366   CHECK_CATEGORY (category);
 367   table = check_category_table (table);
 368
 369   if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
 370     error ("Undefined category: %c", (int) XFASTINT (category));
 371
 372   set_value = NILP (reset);
 373
 374   while (start <= end)
 375     {
 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))
 379         {
 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);
 384         }
 385       start = to + 1;
 386     }
 387
 388   return Qnil;
 389 }
 390 \f
 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.  */
 395
 396 bool
 397 word_boundary_p (int c1, int c2)
 398 {
 399   Lisp_Object category_set1, category_set2;
 400   Lisp_Object tail;
 401   bool default_result;
 402
 403   if (EQ (CHAR_TABLE_REF (Vchar_script_table, c1),
 404           CHAR_TABLE_REF (Vchar_script_table, c2)))
 405     {
 406       tail = Vword_separating_categories;
 407       default_result = 0;
 408     }
 409   else
 410     {
 411       tail = Vword_combining_categories;
 412       default_result = 1;
 413     }
 414
 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;
 421
 422   for (; CONSP (tail); tail = XCDR (tail))
 423     {
 424       Lisp_Object elt = XCAR (tail);
 425
 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;
 436     }
 437   return default_result;
 438 }
 439
 440 \f
 441 void
 442 init_category_once (void)
 443 {
 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));
 447
 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));
 453 }
 454
 455 void
 456 syms_of_category (void)
 457 {
 458   DEFSYM (Qcategoryp, "categoryp");
 459   DEFSYM (Qcategorysetp, "categorysetp");
 460   DEFSYM (Qcategory_table_p, "category-table-p");
 461
 462   DEFVAR_LISP ("word-combining-categories", Vword_combining_categories,
 463                doc: /* List of pair (cons) of categories to determine word boundary.
 464
 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.
 468
 469 \(1) The case that characters are in different scripts is controlled
 470 by the variable `word-combining-categories'.
 471
 472 Emacs finds no word boundary between characters of different scripts
 473 if they have categories matching some element of this list.
 474
 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.
 478
 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.
 482
 483 \(2) The case that character are in the same script is controlled by
 484 the variable `word-separating-categories'.
 485
 486 Emacs finds a word boundary between characters of the same script
 487 if they have categories matching some element of this list.
 488
 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.
 493
 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.  */);
 497
 498   Vword_combining_categories = Qnil;
 499
 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'.  */);
 503
 504   Vword_separating_categories = Qnil;
 505
 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);
 519
 520   category_table_version = 0;
 521 }