src/category.c

   1 /* GNU Emacs routines to deal with category tables.
   2
   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
  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->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 \f
  57 /* Category set staff.  */
  58
  59 static Lisp_Object
  60 hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
  61 {
  62   struct Lisp_Hash_Table *h;
  63   ptrdiff_t i;
  64   EMACS_UINT hash;
  65
  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;
  79 }
  80
  81 /* Make CATEGORY_SET include (if VAL) or exclude (if !VAL) CATEGORY.  */
  82
  83 static void
  84 set_category_set (Lisp_Object category_set, EMACS_INT category, bool val)
  85 {
  86   bool_vector_set (category_set, category, val);
  87 }
  88
  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)
  95 {
  96   Lisp_Object val;
  97   ptrdiff_t len;
  98
  99   CHECK_STRING (categories);
 100   val = MAKE_CATEGORY_SET;
 101
 102   if (STRING_MULTIBYTE (categories))
 103     error ("Multibyte string in `make-category-set'");
 104
 105   len = SCHARS (categories);
 106   while (--len >= 0)
 107     {
 108       unsigned char cat = SREF (categories, len);
 109       Lisp_Object category = make_number (cat);
 110
 111       CHECK_CATEGORY (category);
 112       set_category_set (val, cat, 1);
 113     }
 114   return val;
 115 }
 116
 117 \f
 118 /* Category staff.  */
 119
 120 static Lisp_Object check_category_table (Lisp_Object table);
 121
 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)
 131 {
 132   CHECK_CATEGORY (category);
 133   CHECK_STRING (docstring);
 134   table = check_category_table (table);
 135
 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);
 141
 142   return Qnil;
 143 }
 144
 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)
 150 {
 151   CHECK_CATEGORY (category);
 152   table = check_category_table (table);
 153
 154   return CATEGORY_DOCSTRING (table, XFASTINT (category));
 155 }
 156
 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)
 164 {
 165   int i;
 166
 167   table = check_category_table (table);
 168
 169   for (i = ' '; i <= '~'; i++)
 170     if (NILP (CATEGORY_DOCSTRING (table, i)))
 171       return make_number (i);
 172
 173   return Qnil;
 174 }
 175
 176 \f
 177 /* Category-table staff.  */
 178
 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)
 182 {
 183   if (CHAR_TABLE_P (arg)
 184       && EQ (XCHAR_TABLE (arg)->purpose, Qcategory_table))
 185     return Qt;
 186   return Qnil;
 187 }
 188
 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.  */
 193
 194 static Lisp_Object
 195 check_category_table (Lisp_Object table)
 196 {
 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;
 201 }
 202
 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)
 207 {
 208   return BVAR (current_buffer, category_table);
 209 }
 210
 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)
 216 {
 217   return Vstandard_category_table;
 218 }
 219
 220
 221 static void
 222 copy_category_entry (Lisp_Object table, Lisp_Object c, Lisp_Object val)
 223 {
 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);
 229 }
 230
 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.  */
 235
 236 static Lisp_Object
 237 copy_category_table (Lisp_Object table)
 238 {
 239   table = copy_char_table (table);
 240
 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);
 247
 248   return table;
 249 }
 250
 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)
 256 {
 257   if (!NILP (table))
 258     check_category_table (table);
 259   else
 260     table = Vstandard_category_table;
 261
 262   return copy_category_table (table);
 263 }
 264
 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)
 269 {
 270   Lisp_Object val;
 271   int i;
 272
 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;
 280 }
 281
 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)
 286 {
 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;
 294 }
 295
 296 \f
 297 Lisp_Object
 298 char_category_set (int c)
 299 {
 300   return CHAR_TABLE_REF (BVAR (current_buffer, category_table), c);
 301 }
 302
 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)
 307 {
 308   CHECK_CHARACTER (ch);
 309   return CATEGORY_SET (XFASTINT (ch));
 310 }
 311
 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)
 319 {
 320   int i, j;
 321   char str[96];
 322
 323   CHECK_CATEGORY_SET (category_set);
 324
 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';
 330
 331   return build_string (str);
 332 }
 333
 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)
 344 {
 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;
 349
 350   if (INTEGERP (character))
 351     {
 352       CHECK_CHARACTER (character);
 353       start = end = XFASTINT (character);
 354     }
 355   else
 356     {
 357       CHECK_CONS (character);
 358       CHECK_CHARACTER_CAR (character);
 359       CHECK_CHARACTER_CDR (character);
 360       start = XFASTINT (XCAR (character));
 361       end = XFASTINT (XCDR (character));
 362     }
 363
 364   CHECK_CATEGORY (category);
 365   table = check_category_table (table);
 366
 367   if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
 368     error ("Undefined category: %c", (int) XFASTINT (category));
 369
 370   set_value = NILP (reset);
 371
 372   while (start <= end)
 373     {
 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))
 377         {
 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);
 382         }
 383       start = to + 1;
 384     }
 385
 386   return Qnil;
 387 }
 388 \f
 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.  */
 393
 394 bool
 395 word_boundary_p (int c1, int c2)
 396 {
 397   Lisp_Object category_set1, category_set2;
 398   Lisp_Object tail;
 399   bool default_result;
 400
 401   if (EQ (CHAR_TABLE_REF (Vchar_script_table, c1),
 402           CHAR_TABLE_REF (Vchar_script_table, c2)))
 403     {
 404       tail = Vword_separating_categories;
 405       default_result = 0;
 406     }
 407   else
 408     {
 409       tail = Vword_combining_categories;
 410       default_result = 1;
 411     }
 412
 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;
 419
 420   for (; CONSP (tail); tail = XCDR (tail))
 421     {
 422       Lisp_Object elt = XCAR (tail);
 423
 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;
 434     }
 435   return default_result;
 436 }
 437
 438 \f
 439 void
 440 init_category_once (void)
 441 {
 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));
 445
 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));
 451 }
 452
 453 void
 454 syms_of_category (void)
 455 {
 456   DEFSYM (Qcategoryp, "categoryp");
 457   DEFSYM (Qcategorysetp, "categorysetp");
 458   DEFSYM (Qcategory_table_p, "category-table-p");
 459
 460   DEFVAR_LISP ("word-combining-categories", Vword_combining_categories,
 461                doc: /* List of pair (cons) of categories to determine word boundary.
 462
 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.
 466
 467 \(1) The case that characters are in different scripts is controlled
 468 by the variable `word-combining-categories'.
 469
 470 Emacs finds no word boundary between characters of different scripts
 471 if they have categories matching some element of this list.
 472
 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.
 476
 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.
 480
 481 \(2) The case that character are in the same script is controlled by
 482 the variable `word-separating-categories'.
 483
 484 Emacs finds a word boundary between characters of the same script
 485 if they have categories matching some element of this list.
 486
 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.
 491
 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.  */);
 495
 496   Vword_combining_categories = Qnil;
 497
 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'.  */);
 501
 502   Vword_separating_categories = Qnil;
 503
 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);
 517
 518   category_table_version = 0;
 519 }