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   register Lisp_Object tem;
 168   if (NILP (table))
 169     return current_buffer->category_table;
 170   while (tem = Fcategory_table_p (table), NILP (tem))
 171     table = wrong_type_argument (Qcategory_table_p, table);
 172   return table;
 173 }
 174
 175 DEFUN ("category-table", Fcategory_table, Scategory_table, 0, 0, 0,
 176        doc: /* Return the current category table.
 177 This is the one specified by the current buffer.  */)
 178      ()
 179 {
 180   return current_buffer->category_table;
 181 }
 182
 183 DEFUN ("standard-category-table", Fstandard_category_table,
 184    Sstandard_category_table, 0, 0, 0,
 185        doc: /* Return the standard category table.
 186 This is the one used for new buffers.  */)
 187      ()
 188 {
 189   return Vstandard_category_table;
 190 }
 191
 192 /* Return a copy of category table TABLE.  We can't simply use the
 193    function copy-sequence because no contents should be shared between
 194    the original and the copy.  This function is called recursively by
 195    binding TABLE to a sub char table.  */
 196
 197 Lisp_Object
 198 copy_category_table (table)
 199      Lisp_Object table;
 200 {
 201   Lisp_Object tmp;
 202   int i, to;
 203
 204   if (!NILP (XCHAR_TABLE (table)->top))
 205     {
 206       /* TABLE is a top level char table.
 207          At first, make a copy of tree structure of the table.  */
 208       table = Fcopy_sequence (table);
 209
 210       /* Then, copy elements for single byte characters one by one.  */
 211       for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
 212         if (!NILP (tmp = XCHAR_TABLE (table)->contents[i]))
 213           XCHAR_TABLE (table)->contents[i] = Fcopy_sequence (tmp);
 214       to = CHAR_TABLE_ORDINARY_SLOTS;
 215
 216       /* Also copy the first (and sole) extra slot.  It is a vector
 217          containing docstring of each category.  */
 218       Fset_char_table_extra_slot
 219         (table, make_number (0),
 220          Fcopy_sequence (Fchar_table_extra_slot (table, make_number (0))));
 221     }
 222   else
 223     {
 224       i  = 32;
 225       to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
 226     }
 227
 228   /* If the table has non-nil default value, copy it.  */
 229   if (!NILP (tmp = XCHAR_TABLE (table)->defalt))
 230     XCHAR_TABLE (table)->defalt = Fcopy_sequence (tmp);
 231
 232   /* At last, copy the remaining elements while paying attention to a
 233      sub char table.  */
 234   for (; i < to; i++)
 235     if (!NILP (tmp = XCHAR_TABLE (table)->contents[i]))
 236       XCHAR_TABLE (table)->contents[i]
 237         = (SUB_CHAR_TABLE_P (tmp)
 238            ? copy_category_table (tmp) : Fcopy_sequence (tmp));
 239
 240   return table;
 241 }
 242
 243 DEFUN ("copy-category-table", Fcopy_category_table, Scopy_category_table,
 244        0, 1, 0,
 245        doc: /* Construct a new category table and return it.
 246 It is a copy of the TABLE, which defaults to the standard category table.  */)
 247      (table)
 248      Lisp_Object table;
 249 {
 250   if (!NILP (table))
 251     check_category_table (table);
 252   else
 253     table = Vstandard_category_table;
 254
 255   return copy_category_table (table);
 256 }
 257
 258 DEFUN ("make-category-table", Fmake_category_table, Smake_category_table,
 259        0, 0, 0,
 260        doc: /* Construct a new and empty category table and return it.  */)
 261      ()
 262 {
 263   Lisp_Object val;
 264
 265   val = Fmake_char_table (Qcategory_table, Qnil);
 266   XCHAR_TABLE (val)->defalt = MAKE_CATEGORY_SET;
 267   Fset_char_table_extra_slot (val, make_number (0),
 268                               Fmake_vector (make_number (95), Qnil));
 269   return val;
 270 }
 271
 272 DEFUN ("set-category-table", Fset_category_table, Sset_category_table, 1, 1, 0,
 273        doc: /* Specify TABLE as the category table for the current buffer.
 274 Return TABLE.  */)
 275      (table)
 276      Lisp_Object table;
 277 {
 278   int idx;
 279   table = check_category_table (table);
 280   current_buffer->category_table = table;
 281   /* Indicate that this buffer now has a specified category table.  */
 282   idx = PER_BUFFER_VAR_IDX (category_table);
 283   SET_PER_BUFFER_VALUE_P (current_buffer, idx, 1);
 284   return table;
 285 }
 286
 287 \f
 288 DEFUN ("char-category-set", Fchar_category_set, Schar_category_set, 1, 1, 0,
 289        doc: /* Return the category set of 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) */