src/category.c

   1 /* GNU Emacs routines to deal with category tables.
   2    Copyright (C) 1998, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   3      Free Software Foundation, Inc.
   4    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   5      2005, 2006, 2007, 2008, 2009, 2010
   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 /* Variables to determine word boundary.  */
  54 Lisp_Object Vword_combining_categories, Vword_separating_categories;
  55
  56 /* Temporary internal variable used in macro CHAR_HAS_CATEGORY.  */
  57 Lisp_Object _temp_category_set;
  58
  59 \f
  60 /* Category set staff.  */
  61
  62 static Lisp_Object hash_get_category_set (Lisp_Object, Lisp_Object);
  63
  64 static Lisp_Object
  65 hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
  66 {
  67   Lisp_Object val;
  68   struct Lisp_Hash_Table *h;
  69   int i;
  70   unsigned hash;
  71
  72   if (NILP (XCHAR_TABLE (table)->extras[1]))
  73     XCHAR_TABLE (table)->extras[1]
  74       = make_hash_table (Qequal, make_number (DEFAULT_HASH_SIZE),
  75                          make_float (DEFAULT_REHASH_SIZE),
  76                          make_float (DEFAULT_REHASH_THRESHOLD),
  77                          Qnil, Qnil, Qnil);
  78   h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
  79   i = hash_lookup (h, category_set, &hash);
  80   if (i >= 0)
  81     return HASH_KEY (h, i);
  82   hash_put (h, category_set, Qnil, hash);
  83   return category_set;
  84 }
  85
  86
  87 DEFUN ("make-category-set", Fmake_category_set, Smake_category_set, 1, 1, 0,
  88        doc: /* Return a newly created category-set which contains CATEGORIES.
  89 CATEGORIES is a string of category mnemonics.
  90 The value is a bool-vector which has t at the indices corresponding to
  91 those categories.  */)
  92      (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 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      (category, docstring, table)
 130      Lisp_Object category, docstring, 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", XFASTINT (category));
 138   if (!NILP (Vpurify_flag))
 139     docstring = Fpurecopy (docstring);
 140   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      (category, table)
 150      Lisp_Object category, table;
 151 {
 152   CHECK_CATEGORY (category);
 153   table = check_category_table (table);
 154
 155   return CATEGORY_DOCSTRING (table, XFASTINT (category));
 156 }
 157
 158 DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category,
 159        0, 1, 0,
 160        doc: /* Return a category which is not yet defined in TABLE.
 161 If no category remains available, return nil.
 162 The optional argument TABLE specifies which category table to modify;
 163 it defaults to the current buffer's category table.  */)
 164      (table)
 165      Lisp_Object table;
 166 {
 167   int i;
 168
 169   table = check_category_table (table);
 170
 171   for (i = ' '; i <= '~'; i++)
 172     if (NILP (CATEGORY_DOCSTRING (table, i)))
 173       return make_number (i);
 174
 175   return Qnil;
 176 }
 177
 178 \f
 179 /* Category-table staff.  */
 180
 181 DEFUN ("category-table-p", Fcategory_table_p, Scategory_table_p, 1, 1, 0,
 182        doc: /* Return t if ARG is a category table.  */)
 183      (arg)
 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 Lisp_Object
 198 check_category_table (Lisp_Object table)
 199 {
 200   if (NILP (table))
 201     return 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      ()
 210 {
 211   return 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      ()
 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 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     XCHAR_TABLE (table)->defalt
 246       = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
 247   XCHAR_TABLE (table)->extras[0]
 248     = 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      (table)
 259      Lisp_Object table;
 260 {
 261   if (!NILP (table))
 262     check_category_table (table);
 263   else
 264     table = Vstandard_category_table;
 265
 266   return copy_category_table (table);
 267 }
 268
 269 DEFUN ("make-category-table", Fmake_category_table, Smake_category_table,
 270        0, 0, 0,
 271        doc: /* Construct a new and empty category table and return it.  */)
 272      ()
 273 {
 274   Lisp_Object val;
 275   int i;
 276
 277   val = Fmake_char_table (Qcategory_table, Qnil);
 278   XCHAR_TABLE (val)->defalt = MAKE_CATEGORY_SET;
 279   for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
 280     XCHAR_TABLE (val)->contents[i] = MAKE_CATEGORY_SET;
 281   Fset_char_table_extra_slot (val, make_number (0),
 282                               Fmake_vector (make_number (95), Qnil));
 283   return val;
 284 }
 285
 286 DEFUN ("set-category-table", Fset_category_table, Sset_category_table, 1, 1, 0,
 287        doc: /* Specify TABLE as the category table for the current buffer.
 288 Return TABLE.  */)
 289      (table)
 290      Lisp_Object table;
 291 {
 292   int idx;
 293   table = check_category_table (table);
 294   current_buffer->category_table = 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 (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      (ch)
 312      Lisp_Object ch;
 313 {
 314   CHECK_NUMBER (ch);
 315   return CATEGORY_SET (XFASTINT (ch));
 316 }
 317
 318 DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
 319        Scategory_set_mnemonics, 1, 1, 0,
 320        doc: /* Return a string containing mnemonics of the categories in CATEGORY-SET.
 321 CATEGORY-SET is a bool-vector, and the categories \"in\" it are those
 322 that are indexes where t occurs in the bool-vector.
 323 The return value is a string containing those same categories.  */)
 324      (category_set)
 325      Lisp_Object category_set;
 326 {
 327   int i, j;
 328   char str[96];
 329
 330   CHECK_CATEGORY_SET (category_set);
 331
 332   j = 0;
 333   for (i = 32; i < 127; i++)
 334     if (CATEGORY_MEMBER (i, category_set))
 335       str[j++] = i;
 336   str[j] = '\0';
 337
 338   return build_string (str);
 339 }
 340
 341 void
 342 set_category_set (Lisp_Object category_set, Lisp_Object category, Lisp_Object val)
 343 {
 344   do {
 345     int idx = XINT (category) / 8;
 346     unsigned char bits = 1 << (XINT (category) % 8);
 347
 348     if (NILP (val))
 349       XCATEGORY_SET (category_set)->data[idx] &= ~bits;
 350     else
 351       XCATEGORY_SET (category_set)->data[idx] |= bits;
 352   } while (0);
 353 }
 354
 355 DEFUN ("modify-category-entry", Fmodify_category_entry,
 356        Smodify_category_entry, 2, 4, 0,
 357        doc: /* Modify the category set of CHARACTER by adding CATEGORY to it.
 358 The category is changed only for table TABLE, which defaults to
 359 the current buffer's category table.
 360 CHARACTER can be either a single character or a cons representing the
 361 lower and upper ends of an inclusive character range to modify.
 362 If optional fourth argument RESET is non-nil,
 363 then delete CATEGORY from the category set instead of adding it.  */)
 364      (character, category, table, reset)
 365      Lisp_Object character, category, table, reset;
 366 {
 367   Lisp_Object set_value;        /* Actual value to be set in category sets.  */
 368   Lisp_Object category_set;
 369   int start, end;
 370   int from, to;
 371
 372   if (INTEGERP (character))
 373     {
 374       CHECK_CHARACTER (character);
 375       start = end = XFASTINT (character);
 376     }
 377   else
 378     {
 379       CHECK_CONS (character);
 380       CHECK_CHARACTER_CAR (character);
 381       CHECK_CHARACTER_CDR (character);
 382       start = XFASTINT (XCAR (character));
 383       end = XFASTINT (XCDR (character));
 384     }
 385
 386   CHECK_CATEGORY (category);
 387   table = check_category_table (table);
 388
 389   if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
 390     error ("Undefined category: %c", XFASTINT (category));
 391
 392   set_value = NILP (reset) ? Qt : Qnil;
 393
 394   while (start <= end)
 395     {
 396       from = start, to = end;
 397       category_set = char_table_ref_and_range (table, start, &from, &to);
 398       if (CATEGORY_MEMBER (XFASTINT (category), category_set) != NILP (reset))
 399         {
 400           category_set = Fcopy_sequence (category_set);
 401           SET_CATEGORY_SET (category_set, category, set_value);
 402           category_set = hash_get_category_set (table, category_set);
 403           char_table_set_range (table, start, to, category_set);
 404         }
 405       start = to + 1;
 406     }
 407
 408   return Qnil;
 409 }
 410 \f
 411 /* Return 1 if there is a word boundary between two word-constituent
 412    characters C1 and C2 if they appear in this order, else return 0.
 413    Use the macro WORD_BOUNDARY_P instead of calling this function
 414    directly.  */
 415
 416 int
 417 word_boundary_p (int c1, int c2)
 418 {
 419   Lisp_Object category_set1, category_set2;
 420   Lisp_Object tail;
 421   int default_result;
 422
 423   if (EQ (CHAR_TABLE_REF (Vchar_script_table, c1),
 424           CHAR_TABLE_REF (Vchar_script_table, c2)))
 425     {
 426       tail = Vword_separating_categories;
 427       default_result = 0;
 428     }
 429   else
 430     {
 431       tail = Vword_combining_categories;
 432       default_result = 1;
 433     }
 434
 435   category_set1 = CATEGORY_SET (c1);
 436   if (NILP (category_set1))
 437     return default_result;
 438   category_set2 = CATEGORY_SET (c2);
 439   if (NILP (category_set2))
 440     return default_result;
 441
 442   for (; CONSP (tail); tail = XCDR (tail))
 443     {
 444       Lisp_Object elt = XCAR (tail);
 445
 446       if (CONSP (elt)
 447           && (NILP (XCAR (elt))
 448               || (CATEGORYP (XCAR (elt))
 449                   && CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set1)
 450                   && ! CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set2)))
 451           && (NILP (XCDR (elt))
 452               || (CATEGORYP (XCDR (elt))
 453                   && ! CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set1)
 454                   && CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set2))))
 455         return !default_result;
 456     }
 457   return default_result;
 458 }
 459
 460 \f
 461 void
 462 init_category_once (void)
 463 {
 464   /* This has to be done here, before we call Fmake_char_table.  */
 465   Qcategory_table = intern_c_string ("category-table");
 466   staticpro (&Qcategory_table);
 467
 468   /* Intern this now in case it isn't already done.
 469      Setting this variable twice is harmless.
 470      But don't staticpro it here--that is done in alloc.c.  */
 471   Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
 472
 473   /* Now we are ready to set up this property, so we can
 474      create category tables.  */
 475   Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
 476
 477   Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
 478   /* Set a category set which contains nothing to the default.  */
 479   XCHAR_TABLE (Vstandard_category_table)->defalt = MAKE_CATEGORY_SET;
 480   Fset_char_table_extra_slot (Vstandard_category_table, make_number (0),
 481                               Fmake_vector (make_number (95), Qnil));
 482 }
 483
 484 void
 485 syms_of_category (void)
 486 {
 487   Qcategoryp = intern_c_string ("categoryp");
 488   staticpro (&Qcategoryp);
 489   Qcategorysetp = intern_c_string ("categorysetp");
 490   staticpro (&Qcategorysetp);
 491   Qcategory_table_p = intern_c_string ("category-table-p");
 492   staticpro (&Qcategory_table_p);
 493
 494   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories,
 495                doc: /* List of pair (cons) of categories to determine word boundary.
 496
 497 Emacs treats a sequence of word constituent characters as a single
 498 word (i.e. finds no word boundary between them) only if they belong to
 499 the same script.  But, exceptions are allowed in the following cases.
 500
 501 \(1) The case that characters are in different scripts is controlled
 502 by the variable `word-combining-categories'.
 503
 504 Emacs finds no word boundary between characters of different scripts
 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 is followed by
 509 C2 which has CAT2, there's no word boundary between C1 and C2.
 510
 511 For instance, to tell that Han characters followed by Hiragana
 512 characters can form a single word, the element `(?C . ?H)' should be
 513 in this list.
 514
 515 \(2) The case that character are in the same script is controlled by
 516 the variable `word-separating-categories'.
 517
 518 Emacs finds a word boundary between characters of the same script
 519 if they have categories matching some element of this list.
 520
 521 More precisely, if an element of this list is a cons of category CAT1
 522 and CAT2, and a multibyte character C1 which has CAT1 but not CAT2 is
 523 followed by C2 which has CAT2 but not CAT1, there's a word boundary
 524 between C1 and C2.
 525
 526 For instance, to tell that there's a word boundary between Hiragana
 527 and Katakana (both are in the same script `kana'),
 528 the element `(?H . ?K) should be in this list.  */);
 529
 530   Vword_combining_categories = Qnil;
 531
 532   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories,
 533                doc: /* List of pair (cons) of categories to determine word boundary.
 534 See the documentation of the variable `word-combining-categories'.  */);
 535
 536   Vword_separating_categories = Qnil;
 537
 538   defsubr (&Smake_category_set);
 539   defsubr (&Sdefine_category);
 540   defsubr (&Scategory_docstring);
 541   defsubr (&Sget_unused_category);
 542   defsubr (&Scategory_table_p);
 543   defsubr (&Scategory_table);
 544   defsubr (&Sstandard_category_table);
 545   defsubr (&Scopy_category_table);
 546   defsubr (&Smake_category_table);
 547   defsubr (&Sset_category_table);
 548   defsubr (&Schar_category_set);
 549   defsubr (&Scategory_set_mnemonics);
 550   defsubr (&Smodify_category_entry);
 551
 552   category_table_version = 0;
 553 }
 554
 555 /* arch-tag: 74ebf524-121b-4d9c-bd68-07f8d708b211
 556    (do not change this comment) */