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