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