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 usage: (char-category-set CHAR)  */)
 289      (ch)
 290      Lisp_Object ch;
 291 {
 292   CHECK_NUMBER (ch);
 293   return CATEGORY_SET (XFASTINT (ch));
 294 }
 295
 296 DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
 297        Scategory_set_mnemonics, 1, 1, 0,
 298        doc: /* Return a string containing mnemonics of the categories in CATEGORY-SET.
 299 CATEGORY-SET is a bool-vector, and the categories \"in\" it are those
 300 that are indexes where t occurs in the bool-vector.
 301 The return value is a string containing those same categories.  */)
 302      (category_set)
 303      Lisp_Object category_set;
 304 {
 305   int i, j;
 306   char str[96];
 307
 308   CHECK_CATEGORY_SET (category_set);
 309
 310   j = 0;
 311   for (i = 32; i < 127; i++)
 312     if (CATEGORY_MEMBER (i, category_set))
 313       str[j++] = i;
 314   str[j] = '\0';
 315
 316   return build_string (str);
 317 }
 318
 319 /* Modify all category sets stored under sub char-table TABLE so that
 320    they contain (SET_VALUE is t) or don't contain (SET_VALUE is nil)
 321    CATEGORY.  */
 322
 323 void
 324 modify_lower_category_set (table, category, set_value)
 325      Lisp_Object table, category, set_value;
 326 {
 327   Lisp_Object val;
 328   int i;
 329
 330   val = XCHAR_TABLE (table)->defalt;
 331   if (!CATEGORY_SET_P (val))
 332     val = MAKE_CATEGORY_SET;
 333   SET_CATEGORY_SET (val, category, set_value);
 334   XCHAR_TABLE (table)->defalt = val;
 335
 336   for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++)
 337     {
 338       val = XCHAR_TABLE (table)->contents[i];
 339
 340       if (CATEGORY_SET_P (val))
 341         SET_CATEGORY_SET (val, category, set_value);
 342       else if (SUB_CHAR_TABLE_P (val))
 343         modify_lower_category_set (val, category, set_value);
 344     }
 345 }
 346
 347 void
 348 set_category_set (category_set, category, val)
 349      Lisp_Object category_set, category, val;
 350 {
 351   do {
 352     int idx = XINT (category) / 8;
 353     unsigned char bits = 1 << (XINT (category) % 8);
 354
 355     if (NILP (val))
 356       XCATEGORY_SET (category_set)->data[idx] &= ~bits;
 357     else
 358       XCATEGORY_SET (category_set)->data[idx] |= bits;
 359   } while (0);
 360 }
 361
 362 DEFUN ("modify-category-entry", Fmodify_category_entry,
 363        Smodify_category_entry, 2, 4, 0,
 364        doc: /* Modify the category set of CHARACTER by adding CATEGORY to it.
 365 The category is changed only for table TABLE, which defaults to
 366  the current buffer's category table.
 367 If optional fourth argument RESET is non-nil,
 368 then delete CATEGORY from the category set instead of adding it.  */)
 369      (character, category, table, reset)
 370      Lisp_Object character, category, table, reset;
 371 {
 372   int c, charset, c1, c2;
 373   Lisp_Object set_value;        /* Actual value to be set in category sets.  */
 374   Lisp_Object val, category_set;
 375
 376   CHECK_NUMBER (character);
 377   c = XINT (character);
 378   CHECK_CATEGORY (category);
 379   table = check_category_table (table);
 380
 381   if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
 382     error ("Undefined category: %c", XFASTINT (category));
 383
 384   set_value = NILP (reset) ? Qt : Qnil;
 385
 386   if (c < CHAR_TABLE_SINGLE_BYTE_SLOTS)
 387     {
 388       val = XCHAR_TABLE (table)->contents[c];
 389       if (!CATEGORY_SET_P (val))
 390         XCHAR_TABLE (table)->contents[c] = (val = MAKE_CATEGORY_SET);
 391       SET_CATEGORY_SET (val, category, set_value);
 392       return Qnil;
 393     }
 394
 395   SPLIT_CHAR (c, charset, c1, c2);
 396
 397   /* The top level table.  */
 398   val = XCHAR_TABLE (table)->contents[charset + 128];
 399   if (CATEGORY_SET_P (val))
 400     category_set = val;
 401   else if (!SUB_CHAR_TABLE_P (val))
 402     {
 403       category_set = val = MAKE_CATEGORY_SET;
 404       XCHAR_TABLE (table)->contents[charset + 128] = category_set;
 405     }
 406
 407   if (c1 <= 0)
 408     {
 409       /* Only a charset is specified.  */
 410       if (SUB_CHAR_TABLE_P (val))
 411         /* All characters in CHARSET should be the same as for having
 412            CATEGORY or not.  */
 413         modify_lower_category_set (val, category, set_value);
 414       else
 415         SET_CATEGORY_SET (category_set, category, set_value);
 416       return Qnil;
 417     }
 418
 419   /* The second level table.  */
 420   if (!SUB_CHAR_TABLE_P (val))
 421     {
 422       val = make_sub_char_table (Qnil);
 423       XCHAR_TABLE (table)->contents[charset + 128] = val;
 424       /* We must set default category set of CHARSET in `defalt' slot.  */
 425       XCHAR_TABLE (val)->defalt = category_set;
 426     }
 427   table = val;
 428
 429   val = XCHAR_TABLE (table)->contents[c1];
 430   if (CATEGORY_SET_P (val))
 431     category_set = val;
 432   else if (!SUB_CHAR_TABLE_P (val))
 433     {
 434       category_set = val = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
 435       XCHAR_TABLE (table)->contents[c1] = category_set;
 436     }
 437
 438   if (c2 <= 0)
 439     {
 440       if (SUB_CHAR_TABLE_P (val))
 441         /* All characters in C1 group of CHARSET should be the same as
 442            for CATEGORY.  */
 443         modify_lower_category_set (val, category, set_value);
 444       else
 445         SET_CATEGORY_SET (category_set, category, set_value);
 446       return Qnil;
 447     }
 448
 449   /* The third (bottom) level table.  */
 450   if (!SUB_CHAR_TABLE_P (val))
 451     {
 452       val = make_sub_char_table (Qnil);
 453       XCHAR_TABLE (table)->contents[c1] = val;
 454       /* We must set default category set of CHARSET and C1 in
 455          `defalt' slot.  */
 456       XCHAR_TABLE (val)->defalt = category_set;
 457     }
 458   table = val;
 459
 460   val = XCHAR_TABLE (table)->contents[c2];
 461   if (CATEGORY_SET_P (val))
 462     category_set = val;
 463   else if (!SUB_CHAR_TABLE_P (val))
 464     {
 465       category_set = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
 466       XCHAR_TABLE (table)->contents[c2] = category_set;
 467     }
 468   else
 469     /* This should never happen.  */
 470     error ("Invalid category table");
 471
 472   SET_CATEGORY_SET (category_set, category, set_value);
 473
 474   return Qnil;
 475 }
 476 \f
 477 /* Return 1 if there is a word boundary between two word-constituent
 478    characters C1 and C2 if they appear in this order, else return 0.
 479    Use the macro WORD_BOUNDARY_P instead of calling this function
 480    directly.  */
 481
 482 int
 483 word_boundary_p (c1, c2)
 484      int c1, c2;
 485 {
 486   Lisp_Object category_set1, category_set2;
 487   Lisp_Object tail;
 488   int default_result;
 489
 490   if (CHAR_CHARSET (c1) == CHAR_CHARSET (c2))
 491     {
 492       tail = Vword_separating_categories;
 493       default_result = 0;
 494     }
 495   else
 496     {
 497       tail = Vword_combining_categories;
 498       default_result = 1;
 499     }
 500
 501   category_set1 = CATEGORY_SET (c1);
 502   if (NILP (category_set1))
 503     return default_result;
 504   category_set2 = CATEGORY_SET (c2);
 505   if (NILP (category_set2))
 506     return default_result;
 507
 508   for (; CONSP (tail); tail = XCDR (tail))
 509     {
 510       Lisp_Object elt = XCAR (tail);
 511
 512       if (CONSP (elt)
 513           && CATEGORYP (XCAR (elt))
 514           && CATEGORYP (XCDR (elt))
 515           && CATEGORY_MEMBER (XFASTINT (XCAR (elt)), category_set1)
 516           && CATEGORY_MEMBER (XFASTINT (XCDR (elt)), category_set2))
 517         return !default_result;
 518     }
 519   return default_result;
 520 }
 521
 522 \f
 523 void
 524 init_category_once ()
 525 {
 526   /* This has to be done here, before we call Fmake_char_table.  */
 527   Qcategory_table = intern ("category-table");
 528   staticpro (&Qcategory_table);
 529
 530   /* Intern this now in case it isn't already done.
 531      Setting this variable twice is harmless.
 532      But don't staticpro it here--that is done in alloc.c.  */
 533   Qchar_table_extra_slots = intern ("char-table-extra-slots");
 534
 535   /* Now we are ready to set up this property, so we can
 536      create category tables.  */
 537   Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
 538
 539   Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
 540   /* Set a category set which contains nothing to the default.  */
 541   XCHAR_TABLE (Vstandard_category_table)->defalt = MAKE_CATEGORY_SET;
 542   Fset_char_table_extra_slot (Vstandard_category_table, make_number (0),
 543                               Fmake_vector (make_number (95), Qnil));
 544 }
 545
 546 void
 547 syms_of_category ()
 548 {
 549   Qcategoryp = intern ("categoryp");
 550   staticpro (&Qcategoryp);
 551   Qcategorysetp = intern ("categorysetp");
 552   staticpro (&Qcategorysetp);
 553   Qcategory_table_p = intern ("category-table-p");
 554   staticpro (&Qcategory_table_p);
 555
 556   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories,
 557                doc: /* List of pair (cons) of categories to determine word boundary.
 558
 559 Emacs treats a sequence of word constituent characters as a single
 560 word (i.e. finds no word boundary between them) iff they belongs to
 561 the same charset.  But, exceptions are allowed in the following cases.
 562
 563 \(1) The case that characters are in different charsets is controlled
 564 by the variable `word-combining-categories'.
 565
 566 Emacs finds no word boundary between characters of different charsets
 567 if they have categories matching some element of this list.
 568
 569 More precisely, if an element of this list is a cons of category CAT1
 570 and CAT2, and a multibyte character C1 which has CAT1 is followed by
 571 C2 which has CAT2, there's no word boundary between C1 and C2.
 572
 573 For instance, to tell that ASCII characters and Latin-1 characters can
 574 form a single word, the element `(?l . ?l)' should be in this list
 575 because both characters have the category `l' (Latin characters).
 576
 577 \(2) The case that character are in the same charset is controlled by
 578 the variable `word-separating-categories'.
 579
 580 Emacs find a word boundary between characters of the same charset
 581 if they have categories matching some element of this list.
 582
 583 More precisely, if an element of this list is a cons of category CAT1
 584 and CAT2, and a multibyte character C1 which has CAT1 is followed by
 585 C2 which has CAT2, there's a word boundary between C1 and C2.
 586
 587 For instance, to tell that there's a word boundary between Japanese
 588 Hiragana and Japanese Kanji (both are in the same charset), the
 589 element `(?H . ?C) should be in this list.  */);
 590
 591   Vword_combining_categories = Qnil;
 592
 593   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories,
 594                doc: /* List of pair (cons) of categories to determine word boundary.
 595 See the documentation of the variable `word-combining-categories'.  */);
 596
 597   Vword_separating_categories = Qnil;
 598
 599   defsubr (&Smake_category_set);
 600   defsubr (&Sdefine_category);
 601   defsubr (&Scategory_docstring);
 602   defsubr (&Sget_unused_category);
 603   defsubr (&Scategory_table_p);
 604   defsubr (&Scategory_table);
 605   defsubr (&Sstandard_category_table);
 606   defsubr (&Scopy_category_table);
 607   defsubr (&Smake_category_table);
 608   defsubr (&Sset_category_table);
 609   defsubr (&Schar_category_set);
 610   defsubr (&Scategory_set_mnemonics);
 611   defsubr (&Smodify_category_entry);
 612
 613   category_table_version = 0;
 614 }
 615
 616 /* arch-tag: 74ebf524-121b-4d9c-bd68-07f8d708b211
 617    (do not change this comment) */