src/category.c

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