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