code.delx.au - gnu-emacs/blob - src/category.c

   1 /* GNU Emacs routines to deal with category tables.
   2    Ver.1.0
   3
   4    Copyright (C) 1995 Free Software Foundation, Inc.
   5    Copyright (C) 1995 Electrotechnical Laboratory, JAPAN.
   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, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  22
  23
  24 /* Here we handle three objects: category, category set, and category
  25    table.  Read comments in the file category.h to understand them.  */
  26
  27 #include <config.h>
  28 #include <ctype.h>
  29 #include "lisp.h"
  30 #include "buffer.h"
  31 #include "charset.h"
  32 #include "category.h"
  33
  34 /* The version number of the latest category table.  Each category
  35    table has a unique version number.  It is assigned a new number
  36    also when it is modified.  When a regular expression is compiled
  37    into the struct re_pattern_buffer, the version number of the
  38    category table (of the current buffer) at that moment is also
  39    embedded in the structure.
  40
  41    For the moment, we are not using this feature.  */
  42 static int category_table_version;
  43
  44 Lisp_Object Qcategory_table, Qcategoryp, Qcategorysetp, Qcategory_table_p;
  45
  46 /* Variables to determine word boundary.  */
  47 Lisp_Object Vword_combining_categories, Vword_separating_categories;
  48
  49 /* Temporary internal variable used in macro CHAR_HAS_CATEGORY.  */
  50 Lisp_Object _temp_category_set;
  51
  52 \f
  53 /* Category set staff.  */
  54
  55 DEFUN ("make-category-set", Fmake_category_set, Smake_category_set, 1, 1, 0,
  56   "Return a newly created category-set which contains CATEGORIES.\n\
  57 CATEGORIES is a string of category mnemonics.")
  58   (categories)
  59      Lisp_Object categories;
  60 {
  61   Lisp_Object val;
  62   int len;
  63
  64   CHECK_STRING (categories, 0);
  65   val = MAKE_CATEGORY_SET;
  66
  67   len = XSTRING (categories)->size;
  68   while (--len >= 0)
  69     {
  70       Lisp_Object category = make_number (XSTRING (categories)->data[len]);
  71
  72       CHECK_CATEGORY (category, 0);
  73       SET_CATEGORY_SET (val, category, Qt);
  74     }
  75   return val;
  76 }
  77
  78 \f
  79 /* Category staff.  */
  80
  81 Lisp_Object check_category_table ();
  82
  83 DEFUN ("define-category", Fdefine_category, Sdefine_category, 2, 3, 0,
  84   "Define CHAR as a category which is described by DOCSTRING.\n\
  85 CHAR should be a visible letter of ` ' thru `~'.\n\
  86 DOCSTRING is a documentation string of the category.\n\
  87 The category is defined only in category table TABLE, which defaults to\n\
  88  the current buffer's category table.")
  89   (category, docstring, table)
  90      Lisp_Object category, docstring, table;
  91 {
  92   CHECK_CATEGORY (category, 0);
  93   CHECK_STRING (docstring, 1);
  94   table = check_category_table (table);
  95
  96   if (!NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
  97     error ("Category `%c' is already defined", XFASTINT (category));
  98   CATEGORY_DOCSTRING (table, XFASTINT (category)) = docstring;
  99
 100   return Qnil;
 101 }
 102
 103 DEFUN ("category-docstring", Fcategory_docstring, Scategory_docstring, 1, 2, 0,
 104   "Return a documentation string of CATEGORY.\n\
 105 Optional second arg specifies CATEGORY-TABLE,\n\
 106  which defaults to the current buffer's category table.")
 107   (category, table)
 108      Lisp_Object category, table;
 109 {
 110   Lisp_Object doc;
 111
 112   CHECK_CATEGORY (category, 0);
 113   table = check_category_table (table);
 114
 115   return CATEGORY_DOCSTRING (table, XFASTINT (category));
 116 }
 117
 118 DEFUN ("get-unused-category", Fget_unused_category, Sget_unused_category,
 119        0, 1, 0,
 120   "Return a category which is not yet defined.\n\
 121 If total number of categories has reached the limit (95), return nil.\n\
 122 Optional argument specifies CATEGORY-TABLE,\n\
 123  which defaults to the current buffer's category table.")
 124   (table)
 125      Lisp_Object table;
 126 {
 127   int i;
 128   Lisp_Object docstring_vector;
 129
 130   table = check_category_table (table);
 131
 132   for (i = ' '; i <= '~'; i++)
 133     if (NILP (CATEGORY_DOCSTRING (table, i)))
 134       return make_number (i);
 135
 136   return Qnil;
 137 }
 138
 139 \f
 140 /* Category-table staff.  */
 141
 142 DEFUN ("category-table-p", Fcategory_table_p, Scategory_table_p, 1, 1, 0,
 143   "Return t if ARG is a category table.")
 144   (arg)
 145      Lisp_Object arg;
 146 {
 147   if (CHAR_TABLE_P (arg)
 148       && EQ (XCHAR_TABLE (arg)->purpose, Qcategory_table)
 149       && CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (arg)) == 2)
 150     return Qt;
 151   return Qnil;
 152 }
 153
 154 /* If TABLE is nil, return the current category table.  If TABLE is
 155    not nil, check the validity of TABLE as a category table.  If
 156    valid, return TABLE itself, but if not valid, signal an error of
 157    wrong-type-argument.  */
 158
 159 Lisp_Object
 160 check_category_table (table)
 161      Lisp_Object table;
 162 {
 163   register Lisp_Object tem;
 164   if (NILP (table))
 165     return current_buffer->category_table;
 166   while (tem = Fcategory_table_p (table), NILP (tem))
 167     table = wrong_type_argument (Qcategory_table_p, table);
 168   return table;
 169 }
 170
 171 DEFUN ("category-table", Fcategory_table, Scategory_table, 0, 0, 0,
 172   "Return the current category table.\n\
 173 This is the one specified by the current buffer.")
 174   ()
 175 {
 176   return current_buffer->category_table;
 177 }
 178
 179 DEFUN ("standard-category-table", Fstandard_category_table,
 180    Sstandard_category_table, 0, 0, 0,
 181   "Return the standard category table.\n\
 182 This is the one used for new buffers.")
 183   ()
 184 {
 185   return Vstandard_category_table;
 186 }
 187
 188 /* Return a copy of category table TABLE.  We can't simply use the
 189    function copy-sequence because no contents should be shared between
 190    the original and the copy.
 191
 192    If TOP is 1, we at first copy the tree structure of the table.  */
 193
 194 Lisp_Object
 195 copy_category_table (table, top)
 196      Lisp_Object table;
 197 {
 198   int i;
 199
 200   if (top)
 201     table = Fcopy_sequence (table);
 202   else if (!NILP (XCHAR_TABLE (table)->defalt))
 203     XCHAR_TABLE (table)->defalt
 204       = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
 205
 206   for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
 207     {
 208       Lisp_Object idx = make_number (i);
 209       Lisp_Object val = Faref (table, idx);
 210
 211       if (NILP (val))           /* Do nothing because we can share nil.  */
 212         ;
 213       else if (CATEGORY_SET_P (val))
 214         Faset (table, idx, Fcopy_sequence (val));
 215       else if (CHAR_TABLE_P (val))
 216         Faset (table, idx, copy_category_table (val, 0));
 217       else                      /* Invalid contents.  */
 218         Faset (table, idx, Qnil);
 219     }
 220
 221   return table;
 222 }
 223
 224 DEFUN ("copy-category-table", Fcopy_category_table, Scopy_category_table,
 225        0, 1, 0,
 226   "Construct a new category table and return it.\n\
 227 It is a copy of the TABLE, which defaults to the standard category table.")
 228   (table)
 229      Lisp_Object table;
 230 {
 231   if (!NILP (table))
 232     check_category_table (table);
 233   else
 234     table = Vstandard_category_table;
 235
 236   return copy_category_table (table, 1);
 237 }
 238
 239 DEFUN ("set-category-table", Fset_category_table, Sset_category_table, 1, 1, 0,
 240   "Select a new category table for the current buffer.\n\
 241 One argument, a category table.")
 242   (table)
 243      Lisp_Object table;
 244 {
 245   table = check_category_table (table);
 246   current_buffer->category_table = table;
 247   /* Indicate that this buffer now has a specified category table.  */
 248   current_buffer->local_var_flags
 249     |= XFASTINT (buffer_local_flags.category_table);
 250   return table;
 251 }
 252
 253 \f
 254 DEFUN ("char-category-set", Fchar_category_set, Schar_category_set, 1, 1, 0,
 255   "Return a category set of CHAR.")
 256   (ch)
 257      Lisp_Object ch;
 258 {
 259   Lisp_Object val;
 260   int charset;
 261   unsigned char c1, c2;
 262
 263   CHECK_NUMBER (ch, 0);
 264   return CATEGORY_SET (XFASTINT (ch));
 265 }
 266
 267 DEFUN ("category-set-mnemonics", Fcategory_set_mnemonics,
 268        Scategory_set_mnemonics, 1, 1, 0,
 269   "Return a string of mnemonics of all categories in CATEGORY-SET.")
 270   (category_set)
 271      Lisp_Object category_set;
 272 {
 273   int i, j;
 274   char str[96];
 275
 276   CHECK_CATEGORY_SET (category_set, 0);
 277
 278   j = 0;
 279   for (i = 32; i < 127; i++)
 280     if (CATEGORY_MEMBER (i, category_set))
 281       str[j++] = i;
 282   str[j] = '\0';
 283
 284   return build_string (str);
 285 }
 286
 287 /* Modify all category sets stored under category table TABLE so that
 288    they contain (SET_VALUE is t) or don't contain (SET_VALUE is nil)
 289    CATEGORY.  */
 290
 291 void
 292 modify_lower_category_set (table, category, set_value)
 293      Lisp_Object table, category, set_value;
 294 {
 295   Lisp_Object val;
 296   int i;
 297
 298   if (NILP (XCHAR_TABLE (table)->defalt))
 299     {
 300       val = MAKE_CATEGORY_SET;
 301       SET_CATEGORY_SET (val, category, set_value);
 302       XCHAR_TABLE (table)->defalt = val;
 303     }
 304
 305   for (i = 32; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
 306     {
 307       val = XCHAR_TABLE (table)->contents[i];
 308
 309       if (CATEGORY_SET_P (val))
 310         SET_CATEGORY_SET (val, category, set_value);
 311       else if (CHAR_TABLE_P (val))
 312         modify_lower_category_set (val, category, set_value);
 313     }
 314 }
 315
 316 void
 317 set_category_set (category_set, category, val)
 318      Lisp_Object category_set, category, val;
 319 {
 320   do {
 321     int idx = XINT (category) / 8;
 322     unsigned char bits = 1 << (XINT (category) % 8);
 323
 324     if (NILP (val))
 325       XCATEGORY_SET (category_set)->data[idx] &= ~bits;
 326     else
 327       XCATEGORY_SET (category_set)->data[idx] |= bits;
 328   } while (0);
 329 }
 330
 331 DEFUN ("modify-category-entry", Fmodify_category_entry,
 332        Smodify_category_entry, 2, 4, 0,
 333   "Modify the category set of CHAR by adding CATEGORY to it.\n\
 334 The category is changed only for table TABLE, which defaults to\n\
 335  the current buffer's category table.\n\
 336 If optional forth argument RESET is non NIL,\n\
 337  CATEGORY is deleted from the category set instead of being added.")
 338   (ch, category, table, reset)
 339      Lisp_Object ch, category, table, reset;
 340 {
 341   int c, charset, c1, c2;
 342   Lisp_Object set_value;        /* Actual value to be set in category sets.  */
 343   Lisp_Object val, category_set;
 344
 345   CHECK_NUMBER (ch, 0);
 346   c = XINT (ch);
 347   CHECK_CATEGORY (category, 1);
 348   table = check_category_table (table);
 349
 350   if (NILP (CATEGORY_DOCSTRING (table, XFASTINT (category))))
 351     error ("Undefined category: %c", XFASTINT (category));
 352
 353   set_value = NILP (reset) ? Qt : Qnil;
 354
 355   if (SINGLE_BYTE_CHAR_P (c))
 356     {
 357       val = XCHAR_TABLE (table)->contents[c];
 358       if (!CATEGORY_SET_P (val))
 359         XCHAR_TABLE (table)->contents[c] = (val = MAKE_CATEGORY_SET);
 360       SET_CATEGORY_SET (val, category, set_value);
 361       return Qnil;
 362     }
 363
 364   if (COMPOSITE_CHAR_P (c))
 365     c = cmpchar_component (c, 0);
 366   SPLIT_NON_ASCII_CHAR (c, charset, c1, c2);
 367
 368   /* The top level table.  */
 369   val = XCHAR_TABLE (table)->contents[charset];
 370   if (NILP (val))
 371     {
 372       category_set = MAKE_CATEGORY_SET;
 373       XCHAR_TABLE (table)->contents[charset] = category_set;
 374     }
 375   else if (CATEGORY_SET_P (val))
 376     category_set = val;
 377
 378   if (!c1)
 379     {
 380       /* Only a charset is specified.  */
 381       if (CHAR_TABLE_P (val))
 382         /* All characters in CHARSET should be the same as for CATEGORY.  */
 383         modify_lower_category_set (val, category, set_value);
 384       else
 385         SET_CATEGORY_SET (category_set, category, set_value);
 386       return Qnil;
 387     }
 388
 389   /* The second level table.  */
 390   if (!CHAR_TABLE_P (val))
 391     {
 392       val = Fmake_char_table (Qnil, Qnil);
 393       XCHAR_TABLE (table)->contents[charset] = val;
 394       /* We must set default category set of CHARSET in `defalt' slot.  */
 395       XCHAR_TABLE (val)->defalt = category_set;
 396     }
 397   table = val;
 398
 399   val = XCHAR_TABLE (table)->contents[c1];
 400   if (NILP (val))
 401     {
 402       category_set = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
 403       XCHAR_TABLE (table)->contents[c1] = category_set;
 404     }
 405   else if (CATEGORY_SET_P (val))
 406     category_set = val;
 407
 408   if (!c2)
 409     {
 410       if (CHAR_TABLE_P (val))
 411         /* All characters in C1 group of CHARSET should be the same as
 412            for CATEGORY.  */
 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 third (bottom) level table.  */
 420   if (!CHAR_TABLE_P (val))
 421     {
 422       val = Fmake_char_table (Qnil, Qnil);
 423       XCHAR_TABLE (table)->contents[c1] = val;
 424       /* We must set default category set of CHARSET and C1 in
 425          `defalt' slot.  */
 426       XCHAR_TABLE (val)->defalt = category_set;
 427     }
 428   table = val;
 429
 430   val = XCHAR_TABLE (table)->contents[c2];
 431   if (NILP (val))
 432     {
 433       category_set = Fcopy_sequence (XCHAR_TABLE (table)->defalt);
 434       XCHAR_TABLE (table)->contents[c2] = category_set;
 435     }
 436   else if (CATEGORY_SET_P (val))
 437     category_set = val;
 438   else
 439     /* This should never happen.  */
 440     error ("Invalid category table");
 441
 442   SET_CATEGORY_SET (category_set, category, set_value);
 443
 444   return Qnil;
 445 }
 446 \f
 447 /* Dump category table to buffer in human-readable format */
 448
 449 static void
 450 describe_category (value)
 451     Lisp_Object value;
 452 {
 453   Lisp_Object mnemonics;
 454
 455   Findent_to (make_number (16), make_number (1));
 456
 457   if (NILP (value))
 458     {
 459       insert_string ("default\n");
 460       return;
 461     }
 462
 463   if (!CATEGORY_SET_P (value))
 464     {
 465       insert_string ("invalid\n");
 466       return;
 467     }
 468
 469   mnemonics = Fcategory_set_mnemonics (value);
 470   insert_from_string (mnemonics, 0, XSTRING (mnemonics)->size, 0);
 471   insert_string ("\n");
 472   return;
 473 }
 474
 475 static Lisp_Object
 476 describe_category_1 (vector)
 477      Lisp_Object vector;
 478 {
 479   struct buffer *old = current_buffer;
 480   set_buffer_internal (XBUFFER (Vstandard_output));
 481   describe_vector (vector, Qnil, describe_category, 0, Qnil, Qnil);
 482   {
 483     int i;
 484     Lisp_Object docs = XCHAR_TABLE (vector)->extras[0];
 485     Lisp_Object elt;
 486
 487     if (!VECTORP (docs) || XVECTOR (docs)->size != 95)
 488       {
 489         insert_string ("Invalid first extra slot in this char table\n");
 490         return Qnil;
 491       }
 492
 493     insert_string ("Meanings of mnemonice characters are:\n");
 494     for (i = 0; i < 95; i++)
 495       {
 496         elt = XVECTOR (docs)->contents[i];
 497         if (NILP (elt))
 498           continue;
 499
 500         insert_char (i + 32);
 501         insert (": ", 2);
 502         insert_from_string (elt, 0, XSTRING (elt)->size, 0);
 503         insert ("\n", 1);
 504       }
 505   }
 506
 507   while (! NILP (XCHAR_TABLE (vector)->parent))
 508     {
 509       vector = XCHAR_TABLE (vector)->parent;
 510       insert_string ("\nThe parent category table is:");
 511       describe_vector (vector, Qnil, describe_category, 0, Qnil, Qnil);
 512     }
 513
 514   call0 (intern ("help-mode"));
 515   set_buffer_internal (old);
 516   return Qnil;
 517 }
 518
 519 DEFUN ("describe-category", Fdescribe_category, Sdescribe_category, 0, 0, "",
 520   "Describe the category specifications in the category table.\n\
 521 The descriptions are inserted in a buffer, which is then displayed.")
 522   ()
 523 {
 524   internal_with_output_to_temp_buffer
 525      ("*Help*", describe_category_1, current_buffer->category_table);
 526
 527   return Qnil;
 528 }
 529 \f
 530 /* Return 1 if there is a word boundary between two word-constituent
 531    characters C1 and C2 if they appear in this order, else return 0.
 532    Use the macro WORD_BOUNDARY_P instead of calling this function
 533    directly.  */
 534
 535 int
 536 word_boundary_p (c1, c2)
 537      int c1, c2;
 538 {
 539   Lisp_Object category_set1, category_set2;
 540   Lisp_Object tail;
 541   int default_result;
 542
 543   if (CHAR_CHARSET (c1) == CHAR_CHARSET (c2))
 544     {
 545       tail = Vword_separating_categories;
 546       default_result = 0;
 547     }
 548   else
 549     {
 550       tail = Vword_combining_categories;
 551       default_result = 1;
 552     }
 553
 554   category_set1 = CATEGORY_SET (c1);
 555   if (NILP (category_set1))
 556     return default_result;
 557   category_set2 = CATEGORY_SET (c2);
 558   if (NILP (category_set2))
 559     return default_result;
 560
 561   for (; CONSP (tail); tail = XCONS (tail)->cdr)
 562     {
 563       Lisp_Object elt = XCONS(tail)->car;
 564
 565       if (CONSP (elt)
 566           && CATEGORYP (XCONS (elt)->car)
 567           && CATEGORYP (XCONS (elt)->cdr)
 568           && CATEGORY_MEMBER (XCONS (elt)->car, category_set1)
 569           && CATEGORY_MEMBER (XCONS (elt)->cdr, category_set2))
 570         return !default_result;
 571     }
 572   return default_result;
 573 }
 574
 575 \f
 576 init_category_once ()
 577 {
 578   /* This has to be done here, before we call Fmake_char_table.  */
 579   Qcategory_table = intern ("category-table");
 580   staticpro (&Qcategory_table);
 581
 582   /* Intern this now in case it isn't already done.
 583      Setting this variable twice is harmless.
 584      But don't staticpro it here--that is done in alloc.c.  */
 585   Qchar_table_extra_slots = intern ("char-table-extra-slots");
 586
 587   /* Now we are ready to set up this property, so we can
 588      create category tables.  */
 589   Fput (Qcategory_table, Qchar_table_extra_slots, make_number (2));
 590
 591   Vstandard_category_table = Fmake_char_table (Qcategory_table, Qnil);
 592   /* Set a category set which contains nothing to the default.  */
 593   XCHAR_TABLE (Vstandard_category_table)->defalt = MAKE_CATEGORY_SET;
 594   Fset_char_table_extra_slot (Vstandard_category_table, 0,
 595                               Fmake_vector (make_number (95), Qnil));
 596 }
 597
 598 syms_of_category ()
 599 {
 600   Qcategoryp = intern ("categoryp");
 601   staticpro (&Qcategoryp);
 602   Qcategorysetp = intern ("categorysetp");
 603   staticpro (&Qcategorysetp);
 604   Qcategory_table_p = intern ("category-table-p");
 605   staticpro (&Qcategory_table_p);
 606
 607   DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories,
 608     "List of pair (cons) of categories to determine word boundary.\n\
 609 \n\
 610 Emacs treats a sequence of word constituent characters as a single\n\
 611 word (i.e. finds no word boundary between them) iff they belongs to\n\
 612 the same charset.  But, exceptions are allowed in the following cases.\n\
 613 \n\
 614 (1) The case that characters are in different charsets is controlled\n\
 615 by the variable `word-combining-categories'.\n\
 616 \n\
 617 Emacs finds no word boundary between characters of different charsets\n\
 618 if they have categories matching some element of this list.\n\
 619 \n\
 620 More precisely, if an element of this list is a cons of category CAT1\n\
 621 and CAT2, and a multibyte character C1 which has CAT1 is followed by\n\
 622 C2 which has CAT2, there's no word boundary between C1 and C2.\n\
 623 \n\
 624 For instance, to tell that ASCII characters and Latin-1 characters can\n\
 625 form a single word, the element `(?l . ?l)' should be in this list\n\
 626 because both characters have the category `l' (Latin characters).\n\
 627 \n\
 628 (2) The case that character are in the same charset is controlled by\n\
 629 the variable `word-separating-categories'.\n\
 630 \n\
 631 Emacs find a word boundary between characters of the same charset\n\
 632 if they have categories matching some element of this list.\n\
 633 \n\
 634 More precisely, if an element of this list is a cons of category CAT1\n\
 635 and CAT2, and a multibyte character C1 which has CAT1 is followed by\n\
 636 C2 which has CAT2, there's a word boundary between C1 and C2.\n\
 637 \n\
 638 For instance, to tell that there's a word boundary between Japanese\n\
 639 Hiragana and Japanese Kanji (both are in the same charset), the\n\
 640 element `(?H . ?C) should be in this list.");
 641
 642   Vword_combining_categories = Qnil;
 643
 644   DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories,
 645     "List of pair (cons) of categories to determine word boundary.\n\
 646 See the documentation of the variable `word-combining-categories'.");
 647
 648   Vword_separating_categories = Qnil;
 649
 650   defsubr (&Smake_category_set);
 651   defsubr (&Sdefine_category);
 652   defsubr (&Scategory_docstring);
 653   defsubr (&Sget_unused_category);
 654   defsubr (&Scategory_table_p);
 655   defsubr (&Scategory_table);
 656   defsubr (&Sstandard_category_table);
 657   defsubr (&Scopy_category_table);
 658   defsubr (&Sset_category_table);
 659   defsubr (&Schar_category_set);
 660   defsubr (&Scategory_set_mnemonics);
 661   defsubr (&Smodify_category_entry);
 662   defsubr (&Sdescribe_category);
 663
 664   category_table_version = 0;
 665 }