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