git.chise.org Git - chise/xemacs-chise.git.1/blob - src/cmds.c

   1 /* Simple built-in editing commands.
   2    Copyright (C) 1985, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
   3
   4 This file is part of XEmacs.
   5
   6 XEmacs is free software; you can redistribute it and/or modify it
   7 under the terms of the GNU General Public License as published by the
   8 Free Software Foundation; either version 2, or (at your option) any
   9 later version.
  10
  11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with XEmacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Synched up with: Mule 2.0, FSF 19.30. */
  22
  23 #include <config.h>
  24 #include "lisp.h"
  25 #include "commands.h"
  26 #include "buffer.h"
  27 #include "syntax.h"
  28 #include "insdel.h"
  29
  30 Lisp_Object Qkill_forward_chars;
  31 Lisp_Object Qself_insert_command;
  32 Lisp_Object Qno_self_insert;
  33
  34 Lisp_Object Vblink_paren_function;
  35
  36 /* A possible value for a buffer's overwrite-mode variable.  */
  37 Lisp_Object Qoverwrite_mode_binary;
  38
  39 /* Non-nil means put this face on the next self-inserting character.  */
  40 Lisp_Object Vself_insert_face;
  41
  42 /* This is the command that set up Vself_insert_face.  */
  43 Lisp_Object Vself_insert_face_command;
  44
  45 /* A char-table for characters which may invoke auto-filling.  */
  46 Lisp_Object Vauto_fill_chars;
  47 \f
  48 DEFUN ("forward-char", Fforward_char, 0, 2, "_p", /*
  49 Move point right COUNT characters (left if COUNT is negative).
  50 On attempt to pass end of buffer, stop and signal `end-of-buffer'.
  51 On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'.
  52 On reaching end of buffer, stop and signal error.
  53
  54 The characters that are moved over may be added to the current selection
  55 \(i.e. active region) if the Shift key is held down, a motion key is used
  56 to invoke this command, and `shifted-motion-keys-select-region' is t; see
  57 the documentation for this variable for more details.
  58 */
  59        (count, buffer))
  60 {
  61   struct buffer *buf = decode_buffer (buffer, 1);
  62   EMACS_INT n;
  63
  64   if (NILP (count))
  65     n = 1;
  66   else
  67     {
  68       CHECK_INT (count);
  69       n = XINT (count);
  70     }
  71
  72   /* This used to just set point to point + XINT (count), and then check
  73      to see if it was within boundaries.  But now that SET_PT can
  74      potentially do a lot of stuff (calling entering and exiting
  75      hooks, etcetera), that's not a good approach.  So we validate the
  76      proposed position, then set point.  */
  77   {
  78     Bufpos new_point = BUF_PT (buf) + n;
  79
  80     if (new_point < BUF_BEGV (buf))
  81       {
  82         BUF_SET_PT (buf, BUF_BEGV (buf));
  83         Fsignal (Qbeginning_of_buffer, Qnil);
  84         return Qnil;
  85       }
  86     if (new_point > BUF_ZV (buf))
  87       {
  88         BUF_SET_PT (buf, BUF_ZV (buf));
  89         Fsignal (Qend_of_buffer, Qnil);
  90         return Qnil;
  91       }
  92
  93     BUF_SET_PT (buf, new_point);
  94   }
  95
  96   return Qnil;
  97 }
  98
  99 DEFUN ("backward-char", Fbackward_char, 0, 2, "_p", /*
 100 Move point left COUNT characters (right if COUNT is negative).
 101 On attempt to pass end of buffer, stop and signal `end-of-buffer'.
 102 On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'.
 103
 104 The characters that are moved over may be added to the current selection
 105 \(i.e. active region) if the Shift key is held down, a motion key is used
 106 to invoke this command, and `shifted-motion-keys-select-region' is t; see
 107 the documentation for this variable for more details.
 108 */
 109        (count, buffer))
 110 {
 111   if (NILP (count))
 112     count = make_int (-1);
 113   else
 114     {
 115       CHECK_INT (count);
 116       count = make_int (- XINT (count));
 117     }
 118   return Fforward_char (count, buffer);
 119 }
 120
 121 DEFUN ("forward-line", Fforward_line, 0, 2, "_p", /*
 122 Move COUNT lines forward (backward if COUNT is negative).
 123 Precisely, if point is on line I, move to the start of line I + COUNT.
 124 If there isn't room, go as far as possible (no error).
 125 Returns the count of lines left to move.  If moving forward,
 126 that is COUNT - number of lines moved; if backward, COUNT + number moved.
 127 With positive COUNT, a non-empty line at the end counts as one line
 128   successfully moved (for the return value).
 129 If BUFFER is nil, the current buffer is assumed.
 130
 131 The characters that are moved over may be added to the current selection
 132 \(i.e. active region) if the Shift key is held down, a motion key is used
 133 to invoke this command, and `shifted-motion-keys-select-region' is t; see
 134 the documentation for this variable for more details.
 135 */
 136        (count, buffer))
 137 {
 138   struct buffer *buf = decode_buffer (buffer, 1);
 139   Bufpos pos2 = BUF_PT (buf);
 140   Bufpos pos;
 141   EMACS_INT n, shortage, negp;
 142
 143   if (NILP (count))
 144     n = 1;
 145   else
 146     {
 147       CHECK_INT (count);
 148       n = XINT (count);
 149     }
 150
 151   negp = n <= 0;
 152   pos = scan_buffer (buf, '\n', pos2, 0, n - negp, &shortage, 1);
 153   if (shortage > 0
 154       && (negp
 155           || (BUF_ZV (buf) > BUF_BEGV (buf)
 156               && pos != pos2
 157               && BUF_FETCH_CHAR (buf, pos - 1) != '\n')))
 158     shortage--;
 159   BUF_SET_PT (buf, pos);
 160   return make_int (negp ? - shortage : shortage);
 161 }
 162
 163 DEFUN ("point-at-bol", Fpoint_at_bol, 0, 2, 0, /*
 164 Return the character position of the first character on the current line.
 165 With argument COUNT not nil or 1, move forward COUNT - 1 lines first.
 166 If scan reaches end of buffer, return that position.
 167 This function does not move point.
 168 */
 169        (count, buffer))
 170 {
 171   struct buffer *b = decode_buffer (buffer, 1);
 172   REGISTER int orig, end;
 173
 174   XSETBUFFER (buffer, b);
 175   if (NILP (count))
 176     count = make_int (0);
 177   else
 178     {
 179       CHECK_INT (count);
 180       count = make_int (XINT (count) - 1);
 181     }
 182
 183   orig = BUF_PT (b);
 184   Fforward_line (count, buffer);
 185   end = BUF_PT (b);
 186   BUF_SET_PT (b, orig);
 187
 188   return make_int (end);
 189 }
 190
 191 DEFUN ("beginning-of-line", Fbeginning_of_line, 0, 2, "_p", /*
 192 Move point to beginning of current line.
 193 With argument COUNT not nil or 1, move forward COUNT - 1 lines first.
 194 If scan reaches end of buffer, stop there without error.
 195 If BUFFER is nil, the current buffer is assumed.
 196
 197 The characters that are moved over may be added to the current selection
 198 \(i.e. active region) if the Shift key is held down, a motion key is used
 199 to invoke this command, and `shifted-motion-keys-select-region' is t; see
 200 the documentation for this variable for more details.
 201 */
 202        (count, buffer))
 203 {
 204   struct buffer *b = decode_buffer (buffer, 1);
 205
 206   BUF_SET_PT (b, XINT (Fpoint_at_bol (count, buffer)));
 207   return Qnil;
 208 }
 209
 210 DEFUN ("point-at-eol", Fpoint_at_eol, 0, 2, 0, /*
 211 Return the character position of the last character on the current line.
 212 With argument COUNT not nil or 1, move forward COUNT - 1 lines first.
 213 If scan reaches end of buffer, return that position.
 214 This function does not move point.
 215 */
 216        (count, buffer))
 217 {
 218   struct buffer *buf = decode_buffer (buffer, 1);
 219   EMACS_INT n;
 220
 221   if (NILP (count))
 222     n = 1;
 223   else
 224     {
 225       CHECK_INT (count);
 226       n = XINT (count);
 227     }
 228
 229   return make_int (find_before_next_newline (buf, BUF_PT (buf), 0,
 230                                              n - (n <= 0)));
 231 }
 232
 233 DEFUN ("end-of-line", Fend_of_line, 0, 2, "_p", /*
 234 Move point to end of current line.
 235 With argument COUNT not nil or 1, move forward COUNT - 1 lines first.
 236 If scan reaches end of buffer, stop there without error.
 237 If BUFFER is nil, the current buffer is assumed.
 238
 239 The characters that are moved over may be added to the current selection
 240 \(i.e. active region) if the Shift key is held down, a motion key is used
 241 to invoke this command, and `shifted-motion-keys-select-region' is t; see
 242 the documentation for this variable for more details.
 243 */
 244        (count, buffer))
 245 {
 246   struct buffer *b = decode_buffer (buffer, 1);
 247
 248   BUF_SET_PT (b, XINT (Fpoint_at_eol (count, buffer)));
 249   return Qnil;
 250 }
 251
 252 DEFUN ("delete-char", Fdelete_char, 0, 2, "*p\nP", /*
 253 Delete the following COUNT characters (previous, with negative COUNT).
 254 Optional second arg KILLP non-nil means kill instead (save in kill ring).
 255 Interactively, COUNT is the prefix arg, and KILLP is set if
 256 COUNT was explicitly specified.
 257 */
 258        (count, killp))
 259 {
 260   /* This function can GC */
 261   Bufpos pos;
 262   struct buffer *buf = current_buffer;
 263   EMACS_INT n;
 264
 265   if (NILP (count))
 266     n = 1;
 267   else
 268     {
 269       CHECK_INT (count);
 270       n = XINT (count);
 271     }
 272
 273   pos = BUF_PT (buf) + n;
 274   if (NILP (killp))
 275     {
 276       if (n < 0)
 277         {
 278           if (pos < BUF_BEGV (buf))
 279             signal_error (Qbeginning_of_buffer, Qnil);
 280           else
 281             buffer_delete_range (buf, pos, BUF_PT (buf), 0);
 282         }
 283       else
 284         {
 285           if (pos > BUF_ZV (buf))
 286             signal_error (Qend_of_buffer, Qnil);
 287           else
 288             buffer_delete_range (buf, BUF_PT (buf), pos, 0);
 289         }
 290     }
 291   else
 292     {
 293       call1 (Qkill_forward_chars, count);
 294     }
 295   return Qnil;
 296 }
 297
 298 DEFUN ("delete-backward-char", Fdelete_backward_char, 0, 2, "*p\nP", /*
 299 Delete the previous COUNT characters (following, with negative COUNT).
 300 Optional second arg KILLP non-nil means kill instead (save in kill ring).
 301 Interactively, COUNT is the prefix arg, and KILLP is set if
 302 COUNT was explicitly specified.
 303 */
 304        (count, killp))
 305 {
 306   /* This function can GC */
 307   EMACS_INT n;
 308
 309   if (NILP (count))
 310     n = 1;
 311   else
 312     {
 313       CHECK_INT (count);
 314       n = XINT (count);
 315     }
 316
 317   return Fdelete_char (make_int (- n), killp);
 318 }
 319
 320 static void internal_self_insert (Emchar ch, int noautofill);
 321
 322 DEFUN ("self-insert-command", Fself_insert_command, 1, 1, "*p", /*
 323 Insert the character you type.
 324 Whichever character you type to run this command is inserted.
 325 If a prefix arg COUNT is specified, the character is inserted COUNT times.
 326 */
 327        (count))
 328 {
 329   /* This function can GC */
 330   Emchar ch;
 331   Lisp_Object c;
 332   EMACS_INT n;
 333
 334   CHECK_NATNUM (count);
 335   n = XINT (count);
 336
 337   if (CHAR_OR_CHAR_INTP (Vlast_command_char))
 338     c = Vlast_command_char;
 339   else
 340     c = Fevent_to_character (Vlast_command_event, Qnil, Qnil, Qt);
 341
 342   if (NILP (c))
 343     signal_simple_error ("Last typed character has no ASCII equivalent",
 344                          Fcopy_event (Vlast_command_event, Qnil));
 345
 346   CHECK_CHAR_COERCE_INT (c);
 347
 348   ch = XCHAR (c);
 349
 350   while (n--)
 351     internal_self_insert (ch, (n != 0));
 352
 353   return Qnil;
 354 }
 355
 356 /* Insert character C1.  If NOAUTOFILL is nonzero, don't do autofill
 357    even if it is enabled.
 358
 359    FSF:
 360
 361    If this insertion is suitable for direct output (completely simple),
 362    return 0.  A value of 1 indicates this *might* not have been simple.
 363    A value of 2 means this did things that call for an undo boundary.  */
 364
 365 static void
 366 internal_self_insert (Emchar c1, int noautofill)
 367 {
 368   /* This function can GC */
 369   /* int hairy = 0; -- unused */
 370   REGISTER enum syntaxcode synt;
 371   REGISTER Emchar c2;
 372   Lisp_Object overwrite;
 373   Lisp_Char_Table *syntax_table;
 374   struct buffer *buf = current_buffer;
 375   int tab_width;
 376
 377   overwrite = buf->overwrite_mode;
 378   syntax_table = XCHAR_TABLE (buf->mirror_syntax_table);
 379
 380 #if 0
 381   /* No, this is very bad, it makes undo *always* undo a character at a time
 382      instead of grouping consecutive self-inserts together.  Nasty nasty.
 383    */
 384   if (!NILP (Vbefore_change_functions) || !NILP (Vafter_change_functions)
 385       || !NILP (Vbefore_change_function) || !NILP (Vafter_change_function))
 386     hairy = 1;
 387 #endif
 388
 389   if (!NILP (overwrite)
 390       && BUF_PT (buf) < BUF_ZV (buf)
 391       && (EQ (overwrite, Qoverwrite_mode_binary)
 392           || (c1 != '\n' && BUF_FETCH_CHAR (buf, BUF_PT (buf)) != '\n'))
 393       && (EQ (overwrite, Qoverwrite_mode_binary)
 394           || BUF_FETCH_CHAR (buf, BUF_PT (buf)) != '\t'
 395           || ((tab_width = XINT (buf->tab_width), tab_width <= 0)
 396           || tab_width > 20
 397           || !((current_column (buf) + 1) % tab_width))))
 398     {
 399       buffer_delete_range (buf, BUF_PT (buf), BUF_PT (buf) + 1, 0);
 400       /* hairy = 2; */
 401     }
 402
 403   if (!NILP (buf->abbrev_mode)
 404       && !WORD_SYNTAX_P (syntax_table, c1)
 405       && NILP (buf->read_only)
 406       && BUF_PT (buf) > BUF_BEGV (buf))
 407     {
 408       c2 = BUF_FETCH_CHAR (buf, BUF_PT (buf) - 1);
 409
 410       if (WORD_SYNTAX_P (syntax_table, c2))
 411         {
 412 #if 1
 413           Fexpand_abbrev ();
 414 #else  /* FSFmacs */
 415           Lisp_Object sym = Fexpand_abbrev ();
 416
 417           /* I think this is too bogus to add.  The function should
 418              have a way of examining the character to be inserted, so
 419              it can decide whether to insert it or not.  We should
 420              design it better than that.  */
 421
 422           /* Here FSFmacs remembers MODIFF, compares it after
 423              Fexpand_abbrev() finishes, and updates HAIRY.  */
 424
 425           /* NOTE: we cannot simply check for Vlast_abbrev, because
 426              Fexpand_abbrev() can bail out before setting it to
 427              anything meaningful, leaving us stuck with an old value.
 428              Thus Fexpand_abbrev() was extended to return the actual
 429              abbrev symbol.  */
 430           if (!NILP (sym)
 431               && !NILP (symbol_function (XSYMBOL (sym)))
 432               && SYMBOLP (symbol_function (XSYMBOL (sym))))
 433             {
 434               Lisp_Object prop = Fget (symbol_function (XSYMBOL (sym)),
 435                                        Qno_self_insert, Qnil);
 436               if (!NILP (prop))
 437                 return;
 438             }
 439 #endif /* FSFmacs */
 440         }
 441     }
 442   if ((CHAR_TABLEP (Vauto_fill_chars)
 443        ? !NILP (XCHAR_TABLE_VALUE_UNSAFE (Vauto_fill_chars, c1))
 444        : (c1 == ' ' || c1 == '\n'))
 445       && !noautofill
 446       && !NILP (buf->auto_fill_function))
 447     {
 448       buffer_insert_emacs_char (buf, c1);
 449       if (c1 == '\n')
 450         /* After inserting a newline, move to previous line and fill */
 451         /* that.  Must have the newline in place already so filling and */
 452         /* justification, if any, know where the end is going to be. */
 453         BUF_SET_PT (buf, BUF_PT (buf) - 1);
 454       call0 (buf->auto_fill_function);
 455       if (c1 == '\n')
 456         BUF_SET_PT (buf, BUF_PT (buf) + 1);
 457       /* hairy = 2; */
 458     }
 459   else
 460     buffer_insert_emacs_char (buf, c1);
 461
 462   /* If previous command specified a face to use, use it.  */
 463   if (!NILP (Vself_insert_face)
 464       && EQ (Vlast_command, Vself_insert_face_command))
 465     {
 466       Lisp_Object before = make_int (BUF_PT (buf) - 1);
 467       Lisp_Object after  = make_int (BUF_PT (buf));
 468       Fput_text_property (before, after, Qface, Vself_insert_face, Qnil);
 469       Fput_text_property (before, after, Qstart_open, Qt, Qnil);
 470       Fput_text_property (before, after, Qend_open, Qnil, Qnil);
 471       /* #### FSFmacs properties are normally closed ("sticky") on the
 472          end but not the beginning.  It's the opposite for us. */
 473       Vself_insert_face = Qnil;
 474     }
 475   synt = SYNTAX (syntax_table, c1);
 476   if ((synt == Sclose || synt == Smath)
 477       && !NILP (Vblink_paren_function) && INTERACTIVE
 478       && !noautofill)
 479     {
 480       call0 (Vblink_paren_function);
 481       /* hairy = 2; */
 482     }
 483
 484   /* return hairy; */
 485 }
 486
 487 /* (this comes from Mule but is a generally good idea) */
 488
 489 DEFUN ("self-insert-internal", Fself_insert_internal, 1, 1, 0, /*
 490 Invoke `self-insert-command' as if CHARACTER is entered from keyboard.
 491 */
 492        (character))
 493 {
 494   /* This function can GC */
 495   CHECK_CHAR_COERCE_INT (character);
 496   internal_self_insert (XCHAR (character), 0);
 497   return Qnil;
 498 }
 499 \f
 500 /* module initialization */
 501
 502 void
 503 syms_of_cmds (void)
 504 {
 505   defsymbol (&Qkill_forward_chars, "kill-forward-chars");
 506   defsymbol (&Qself_insert_command, "self-insert-command");
 507   defsymbol (&Qoverwrite_mode_binary, "overwrite-mode-binary");
 508   defsymbol (&Qno_self_insert, "no-self-insert");
 509
 510   DEFSUBR (Fforward_char);
 511   DEFSUBR (Fbackward_char);
 512   DEFSUBR (Fforward_line);
 513   DEFSUBR (Fbeginning_of_line);
 514   DEFSUBR (Fend_of_line);
 515
 516   DEFSUBR (Fpoint_at_bol);
 517   DEFSUBR (Fpoint_at_eol);
 518
 519   DEFSUBR (Fdelete_char);
 520   DEFSUBR (Fdelete_backward_char);
 521
 522   DEFSUBR (Fself_insert_command);
 523   DEFSUBR (Fself_insert_internal);
 524 }
 525
 526 void
 527 vars_of_cmds (void)
 528 {
 529   DEFVAR_LISP ("self-insert-face", &Vself_insert_face /*
 530 If non-nil, set the face of the next self-inserting character to this.
 531 See also `self-insert-face-command'.
 532 */ );
 533   Vself_insert_face = Qnil;
 534
 535   DEFVAR_LISP ("self-insert-face-command", &Vself_insert_face_command /*
 536 This is the command that set up `self-insert-face'.
 537 If `last-command' does not equal this value, we ignore `self-insert-face'.
 538 */ );
 539   Vself_insert_face_command = Qnil;
 540
 541   DEFVAR_LISP ("blink-paren-function", &Vblink_paren_function /*
 542 Function called, if non-nil, whenever a close parenthesis is inserted.
 543 More precisely, a char with closeparen syntax is self-inserted.
 544 */ );
 545   Vblink_paren_function = Qnil;
 546
 547   DEFVAR_LISP ("auto-fill-chars", &Vauto_fill_chars /*
 548 A char-table for characters which invoke auto-filling.
 549 Such characters have value t in this table.
 550 */);
 551   Vauto_fill_chars = Fmake_char_table (Qgeneric);
 552   XCHAR_TABLE (Vauto_fill_chars)->ascii[' '] = Qt;
 553   XCHAR_TABLE (Vauto_fill_chars)->ascii['\n'] = Qt;
 554 }