code.delx.au - gnu-emacs/blob - src/category.c

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