src/category.c

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