src/category.c

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