src/category.c

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