src/category.c

   1 /* GNU Emacs routines to deal with category tables.
   2
   3 Copyright (C) 1998, 2001-2013 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 #define CATEGORY_INLINE EXTERN_INLINE
  34
  35 #include "lisp.h"
  36 #include "character.h"
  37 #include "buffer.h"
  38 #include "charset.h"
  39 #include "category.h"
  40 #include "keymap.h"
  41
  42 /* This setter is used only in this file, so it can be private.  */
  43 static void
  44 bset_category_table (struct buffer *b, Lisp_Object val)
  45 {
  46   b->INTERNAL_FIELD (category_table) = val;
  47 }
  48
  49 /* The version number of the latest category table.  Each category
  50    table has a unique version number.  It is assigned a new number
  51    also when it is modified.  When a regular expression is compiled
  52    into the struct re_pattern_buffer, the version number of the
  53    category table (of the current buffer) at that moment is also
  54    embedded in the structure.
  55
  56    For the moment, we are not using this feature.  */
  57 static int category_table_version;
  58
  59 static Lisp_Object Qcategory_table, Qcategoryp, Qcategorysetp, Qcategory_table_p;
  60
  61 /* Make CATEGORY_SET includes (if VAL is t) or excludes (if VAL is
  62    nil) CATEGORY.  */
  63 #define SET_CATEGORY_SET(category_set, category, val) \
  64   set_category_set (category_set, category, val)
  65 static void set_category_set (Lisp_Object, Lisp_Object, Lisp_Object);
  66 \f
  67 /* Category set staff.  */
  68
  69 static Lisp_Object hash_get_category_set (Lisp_Object, Lisp_Object);
  70
  71 static Lisp_Object
  72 hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
  73 {
  74   struct Lisp_Hash_Table *h;
  75   ptrdiff_t i;
  76   EMACS_UINT hash;
  77
  78   if (NILP (XCHAR_TABLE (table)->extras[1]))
  79     set_char_table_extras
  80       (table, 1,
  81        make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
  82                         make_float (DEFAULT_REHASH_SIZE),
  83                         make_float (DEFAULT_REHASH_THRESHOLD),
  84                         Qnil));
  85   h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
  86   i = hash_lookup (h, category_set, &hash);
  87   if (i >= 0)
  88     return HASH_KEY (h, i);
  89   hash_put (h, category_set, Qnil, hash);
  90   return category_set;
  91 }
  92
  93
  94 DEFUN ("make-category-set", Fmake_category_set, Smake_category_set, 1, 1, 0,
  95        doc: /* Return a newly created category-set which contains CATEGORIES.
  96 CATEGORIES is a string of category mnemonics.
  97 The value is a bool-vector which has t at the indices corresponding to
  98 those categories.  */)
  99   (Lisp_Object categories)
 100 {
 101   Lisp_Object val;
 102   int len;
 103
 104   CHECK_STRING (categories);
 105   val = MAKE_CATEGORY_SET;
 106
 107   if (STRING_MULTIBYTE (categories))
 108     error ("Multibyte string in `make-category-set'");
 109
 110   len = SCHARS (categories);
 111   while (--len >= 0)
 112     {
 113       Lisp_Object category;
 114
 115       XSETFASTINT (category, SREF (categories, len));
 116       CHECK_CATEGORY (category);
 117       SET_CATEGORY_SET (val, category, Qt);
 118     }
 119   return val;
 120 }
 121
 122 \f
 123 /* Category staff.  */
 124
 125 static Lisp_Object check_category_table (Lisp_Object table);
 126
 127 DEFUN ("define-category", Fdefine_category, Sdefine_category, 2, 3, 0,
 128        doc: /* Define CATEGORY as a category which is described by DOCSTRING.
 129 CATEGORY should be an ASCII printing character in the range ` ' to `~'.
 130 DOCSTRING is the documentation string of the category.  The first line
 131 should be a terse text (preferably less than 16 characters),
 132 and the rest lines should be the full description.
 133 The category is defined only in category table TABLE, which defaults to
 134 the current buffer's category table.  */)
 135   (Lisp_Object category, Lisp_Object docstring, Lisp_Object table)
 136 {
 137   CHECK_CATEGORY (category);
 138   CHECK_STRING (docstring);
 139   table = check_category_table (table);
 140
 141   if (!NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
 142     error ("Category `%c' is already defined", (int) XFASTINT (category));
 143   if (!NILP (Vpurify_flag))
 144     docstring = Fpurecopy (docstring);
 145   SET_CATEGORY_DOCSTRING (table, XFASTINT (category), docstring);
 146
 147   return Qnil;
 148 }
 149
 150 DEFUN ("category-docstring", Fcategory_docstring, Scategory_docstring, 1, 2, 0,
 151        doc: /* Return the documentation string of CATEGORY, as defined in TABLE.
 152 TABLE should be a category table and defaults to the current buffer's
 153 category table.  */)
 154   (Lisp_Object category, Lisp_Object table)
 155 {
 156   CHECK_CATEGORY (category);
 157   table = check_category_table (table);
 158
 159   return CATEGORY_DOCSTRING (table, XFASTINT (category));
 160 }
 161
 162 DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category,
 163        0, 1, 0,
 164        doc: /* Return a category which is not yet defined in TABLE.
 165 If no category remains available, return nil.
 166 The optional argument TABLE specifies which category table to modify;
 167 it defaults to the current buffer's category table.  */)
 168   (Lisp_Object table)
 169 {
 170   int i;
 171
 172   table = check_category_table (table);
 173
 174   for (i = ' '; i <= '~'; i++)
 175     if (NILP (CATEGORY_DOCSTRING (table, i)))
 176       return make_number (i);
 177
 178   return Qnil;
 179 }
 180
 181 \f
 182 /* Category-table staff.  */
 183
 184 DEFUN ("category-table-p", Fcategory_table_p, Scategory_table_p, 1, 1, 0,
 185        doc: /* Return t if ARG is a category table.  */)
 186   (Lisp_Object arg)
 187 {
 188   if (CHAR_TABLE_P (arg)
 189       && EQ (XCHAR_TABLE (arg)->purpose, Qcategory_table))
 190     return Qt;
 191   return Qnil;
 192 }
 193
 194 /* If TABLE is nil, return the current category table.  If TABLE is
 195    not nil, check the validity of TABLE as a category table.  If
 196    valid, return TABLE itself, but if not valid, signal an error of
 197    wrong-type-argument.  */
 198
 199 static Lisp_Object
 200 check_category_table (Lisp_Object table)
 201 {
 202   if (NILP (table))
 203     return BVAR (current_buffer, category_table);
 204   CHECK_TYPE (!NILP (Fcategory_table_p (table)), Qcategory_table_p, table);
 205   return table;
 206 }
 207
 208 DEFUN ("category-table", Fcategory_table, Scategory_table, 0, 0, 0,
 209        doc: /* Return the current category table.
 210 This is the one specified by the current buffer.  */)
 211   (void)
 212 {
 213   return BVAR (current_buffer, category_table);
 214 }
 215
 216 DEFUN ("standard-category-table", Fstandard_category_table,
 217    Sstandard_category_table, 0, 0, 0,
 218        doc: /* Return the standard category table.
 219 This is the one used for new buffers.  */)
 220   (void)
 221 {
 222   return Vstandard_category_table;
 223 }
 224
 225
 226 static void
 227 copy_category_entry (Lisp_Object table, Lisp_Object c, Lisp_Object val)
 228 {
 229   val = Fcopy_sequence (val);
 230   if (CONSP (c))
 231     char_table_set_range (table, XINT (XCAR (c)), XINT (XCDR (c)), val);
 232   else
 233     char_table_set (table, XINT (c), val);
 234 }
 235
 236 /* Return a copy of category table TABLE.  We can't simply use the
 237    function copy-sequence because no contents should be shared between
 238    the original and the copy.  This function is called recursively by
 239    binding TABLE to a sub char table.  */
 240
 241 static Lisp_Object
 242 copy_category_table (Lisp_Object table)
 243 {
 244   table = copy_char_table (table);
 245
 246   if (! NILP (XCHAR_TABLE (table)->defalt))
 247     set_char_table_defalt (table,
 248                            Fcopy_sequence (XCHAR_TABLE (table)->defalt));
 249   set_char_table_extras
 250     (table, 0, Fcopy_sequence (XCHAR_TABLE (table)->extras[0]));
 251   map_char_table (copy_category_entry, Qnil, table, table);
 252
 253   return table;
 254 }
 255
 256 DEFUN ("copy-category-table", Fcopy_category_table, Scopy_category_table,
 257        0, 1, 0,
 258        doc: /* Construct a new category table and return it.
 259 It is a copy of the TABLE, which defaults to the standard category table.  */)
 260   (Lisp_Object table)
 261 {
 262   if (!NILP (table))
 263     check_category_table (table);
 264   else
 265     table = Vstandard_category_table;
 266
 267   return copy_category_table (table);
 268 }
 269
 270 DEFUN ("make-category-table", Fmake_category_table, Smake_category_table,
 271        0, 0, 0,
 272        doc: /* Construct a new and empty category table and return it.  */)
 273   (void)
 274 {
 275   Lisp_Object val;
 276   int i;
 277
 278   val = Fmake_char_table (Qcategory_table, Qnil);
 279   set_char_table_defalt (val, MAKE_CATEGORY_SET);
 280   for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
 281     set_char_table_contents (val, i, MAKE_CATEGORY_SET);
 282   Fset_char_table_extra_slot (val, make_number (0),
 283                               Fmake_vector (make_number (95), Qnil));
 284   return val;
 285 }
 286
 287 DEFUN ("set-category-table", Fset_category_table, Sset_category_table, 1, 1, 0,
 288        doc: /* Specify TABLE as the category table for the current buffer.
 289 Return TABLE.  */)
 290   (Lisp_Object table)
 291 {
 292   int idx;
 293   table = check_category_table (table);
 294   bset_category_table (current_buffer, table);
 295   /* Indicate that this buffer now has a specified category table.  */
 296   idx = PER_BUFFER_VAR_IDX (category_table);
 297   SET_PER_BUFFER_VALUE_P (current_buffer, idx, 1);
 298   return table;
 299 }
 300
 301 \f
 302 Lisp_Object
 303 char_category_set (int c)
 304 {
 305   return CHAR_TABLE_REF (BVAR (current_buffer, category_table), c);
 306 }
 307
 308 DEFUN ("char-category-set", Fchar_category_set, Schar_category_set, 1, 1, 0,
 309        doc: /* Return the category set of CHAR.
 310 usage: (char-category-set CHAR)  */)
 311   (Lisp_Object ch)
 312 {
 313   CHECK_CHARACTER (ch);
 314   return CATEGORY_SET (XFASTINT (ch));
 315 }
 316
 317 DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
 318        Scategory_set_mnemonics, 1, 1, 0,
 319        doc: /* Return a string containing mnemonics of the categories in CATEGORY-SET.
 320 CATEGORY-SET is a bool-vector, and the categories \"in\" it are those
 321 that are indexes where t occurs in the bool-vector.
 322 The return value is a string containing those same categories.  */)
 323   (Lisp_Object category_set)
 324 {
 325   int i, j;
 326   char str[96];
 327
 328   CHECK_CATEGORY_SET (category_set);
 329
 330   j = 0;
 331   for (i = 32; i < 127; i++)
 332     if (CATEGORY_MEMBER (i, category_set))
 333       str[j++] = i;
 334   str[j] = '\0';
 335
 336   return build_string (str);
 337 }
 338
 339 static void
 340 set_category_set (Lisp_Object category_set, Lisp_Object category, Lisp_Object val)
 341 {
 342   do {
 343     int idx = XINT (category) / 8;
 344     unsigned char bits = 1 << (XINT (category) % 8);
 345
 346     if (NILP (val))
 347       XCATEGORY_SET (category_set)->data[idx] &= ~bits;
 348     else
 349       XCATEGORY_SET (category_set)->data[idx] |= bits;
 350   } while (0);
 351 }
 352
 353 DEFUN ("modify-category-entry", Fmodify_category_entry,
 354        Smodify_category_entry, 2, 4, 0,
 355        doc: /* Modify the category set of CHARACTER by adding CATEGORY to it.
 356 The category is changed only for table TABLE, which defaults to
 357 the current buffer's category table.
 358 CHARACTER can be either a single character or a cons representing the
 359 lower and upper ends of an inclusive character range to modify.
 360 If optional fourth argument RESET is non-nil,
 361 then delete CATEGORY from the category set instead of adding it.  */)
 362   (Lisp_Object character, Lisp_Object category, Lisp_Object table, Lisp_Object reset)
 363 {
 364   Lisp_Object set_value;        /* Actual value to be set in category sets.  */
 365   Lisp_Object category_set;
 366   int start, end;
 367   int from, to;
 368
 369   if (INTEGERP (character))
 370     {
 371       CHECK_CHARACTER (character);
 372       start = end = XFASTINT (character);
 373     }
 374   else
 375     {
 376       CHECK_CONS (character);
 377       CHECK_CHARACTER_CAR (character);
 378       CHECK_CHARACTER_CDR (character);
 379       start = XFASTINT (XCAR (character));
 380       end = XFASTINT (XCDR (character));
 381     }
 382
 383   CHECK_CATEGORY (category);
 384   table = check_category_table (table);
 385
 386   if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
 387     error ("Undefined category: %c", (int) XFASTINT (category));
 388
 389   set_value = NILP (reset) ? Qt : Qnil;
 390
 391   while (start <= end)
 392     {
 393       from = start, to = end;
 394       category_set = char_table_ref_and_range (table, start, &from, &to);
 395       if (CATEGORY_MEMBER (XFASTINT (category), category_set) != NILP (reset))
 396         {
 397           category_set = Fcopy_sequence (category_set);
 398           SET_CATEGORY_SET (category_set, category, set_value);
 399           category_set = hash_get_category_set (table, category_set);
 400           char_table_set_range (table, start, to, category_set);
 401         }
 402       start = to + 1;
 403     }
 404
 405   return Qnil;
 406 }
 407 \f
 408 /* Return true if there is a word boundary between two word-constituent
 409    characters C1 and C2 if they appear in this order.
 410    Use the macro WORD_BOUNDARY_P instead of calling this function
 411    directly.  */
 412
 413 bool
 414 word_boundary_p (int c1, int c2)
 415 {
 416   Lisp_Object category_set1, category_set2;
 417   Lisp_Object tail;
 418   bool default_result;
 419
 420   if (EQ (CHAR_TABLE_REF (Vchar_script_table, c1),
 421           CHAR_TABLE_REF (Vchar_script_table, c2)))
 422     {
 423       tail = Vword_separating_categories;
 424       default_result = 0;
 425     }
 426   else
 427     {
 428       tail = Vword_combining_categories;
 429       default_result = 1;
 430     }
 431
 432   category_set1 = CATEGORY_SET (c1);
 433   if (NILP (category_set1))
 434     return default_result;
 435   category_set2 = CATEGORY_SET (c2);
 436   if (NILP (category_set2))
 437     return default_result;
 438
 439   for (; CONSP (tail); tail = XCDR (tail))
 440     {
 441       Lisp_Object elt = XCAR (tail);
 442
 443       if (CONSP (elt)
 444           && (NILP (XCAR (elt))
 445               || (CATEGORYP (XCAR (elt))
 446                   && CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set1)
 447                   && ! CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set2)))
 448           && (NILP (XCDR (elt))
 449               || (CATEGORYP (XCDR (elt))
 450                   && ! CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set1)
 451                   && CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set2))))
 452         return !default_result;
 453     }
 454   return default_result;
 455 }
 456
 457 \f
 458 void
 459 init_category_once (void)
 460 {
 461   /* This has to be done here, before we call Fmake_char_table.  */
 462   DEFSYM (Qcategory_table, "category-table");
 463
 464   /* Intern this now in case it isn't already done.
 465      Setting this variable twice is harmless.
 466      But don't staticpro it here--that is done in alloc.c.  */
 467   Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
 468
 469   /* Now we are ready to set up this property, so we can
 470      create category tables.  */
 471   Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
 472
 473   Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
 474   /* Set a category set which contains nothing to the default.  */
 475   set_char_table_defalt (Vstandard_category_table, MAKE_CATEGORY_SET);
 476   Fset_char_table_extra_slot (Vstandard_category_table, make_number (0),
 477                               Fmake_vector (make_number (95), Qnil));
 478 }
 479
 480 void
 481 syms_of_category (void)
 482 {
 483   DEFSYM (Qcategoryp, "categoryp");
 484   DEFSYM (Qcategorysetp, "categorysetp");
 485   DEFSYM (Qcategory_table_p, "category-table-p");
 486
 487   DEFVAR_LISP ("word-combining-categories", Vword_combining_categories,
 488                doc: /* List of pair (cons) of categories to determine word boundary.
 489
 490 Emacs treats a sequence of word constituent characters as a single
 491 word (i.e. finds no word boundary between them) only if they belong to
 492 the same script.  But, exceptions are allowed in the following cases.
 493
 494 \(1) The case that characters are in different scripts is controlled
 495 by the variable `word-combining-categories'.
 496
 497 Emacs finds no word boundary between characters of different scripts
 498 if they have categories matching some element of this list.
 499
 500 More precisely, if an element of this list is a cons of category CAT1
 501 and CAT2, and a multibyte character C1 which has CAT1 is followed by
 502 C2 which has CAT2, there's no word boundary between C1 and C2.
 503
 504 For instance, to tell that Han characters followed by Hiragana
 505 characters can form a single word, the element `(?C . ?H)' should be
 506 in this list.
 507
 508 \(2) The case that character are in the same script is controlled by
 509 the variable `word-separating-categories'.
 510
 511 Emacs finds a word boundary between characters of the same script
 512 if they have categories matching some element of this list.
 513
 514 More precisely, if an element of this list is a cons of category CAT1
 515 and CAT2, and a multibyte character C1 which has CAT1 but not CAT2 is
 516 followed by C2 which has CAT2 but not CAT1, there's a word boundary
 517 between C1 and C2.
 518
 519 For instance, to tell that there's a word boundary between Hiragana
 520 and Katakana (both are in the same script `kana'),
 521 the element `(?H . ?K) should be in this list.  */);
 522
 523   Vword_combining_categories = Qnil;
 524
 525   DEFVAR_LISP ("word-separating-categories", Vword_separating_categories,
 526                doc: /* List of pair (cons) of categories to determine word boundary.
 527 See the documentation of the variable `word-combining-categories'.  */);
 528
 529   Vword_separating_categories = Qnil;
 530
 531   defsubr (&Smake_category_set);
 532   defsubr (&Sdefine_category);
 533   defsubr (&Scategory_docstring);
 534   defsubr (&Sget_unused_category);
 535   defsubr (&Scategory_table_p);
 536   defsubr (&Scategory_table);
 537   defsubr (&Sstandard_category_table);
 538   defsubr (&Scopy_category_table);
 539   defsubr (&Smake_category_table);
 540   defsubr (&Sset_category_table);
 541   defsubr (&Schar_category_set);
 542   defsubr (&Scategory_set_mnemonics);
 543   defsubr (&Smodify_category_entry);
 544
 545   category_table_version = 0;
 546 }