src/cmds.c

   1 /* Simple built-in editing commands.
   2
   3 Copyright (C) 1985, 1993-1998, 2001-2011  Free Software Foundation, Inc.
   4
   5 This file is part of GNU Emacs.
   6
   7 GNU Emacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 GNU Emacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20
  21 #include <config.h>
  22 #include <setjmp.h>
  23 #include "lisp.h"
  24 #include "commands.h"
  25 #include "buffer.h"
  26 #include "character.h"
  27 #include "syntax.h"
  28 #include "window.h"
  29 #include "keyboard.h"
  30 #include "keymap.h"
  31 #include "dispextern.h"
  32 #include "frame.h"
  33
  34 static Lisp_Object Qkill_forward_chars, Qkill_backward_chars;
  35
  36 /* A possible value for a buffer's overwrite-mode variable.  */
  37 static Lisp_Object Qoverwrite_mode_binary;
  38
  39 static int internal_self_insert (int, EMACS_INT);
  40 \f
  41 DEFUN ("forward-point", Fforward_point, Sforward_point, 1, 1, 0,
  42        doc: /* Return buffer position N characters after (before if N negative) point.  */)
  43   (Lisp_Object n)
  44 {
  45   CHECK_NUMBER (n);
  46
  47   return make_number (PT + XINT (n));
  48 }
  49
  50 DEFUN ("forward-char", Fforward_char, Sforward_char, 0, 1, "^p",
  51        doc: /* Move point N characters forward (backward if N is negative).
  52 On reaching end or beginning of buffer, stop and signal error.
  53
  54 Depending on the bidirectional context, the movement may be to the
  55 right or to the left on the screen.  This is in contrast with
  56 \\[right-char], which see.  */)
  57   (Lisp_Object n)
  58 {
  59   if (NILP (n))
  60     XSETFASTINT (n, 1);
  61   else
  62     CHECK_NUMBER (n);
  63
  64   /* This used to just set point to point + XINT (n), and then check
  65      to see if it was within boundaries.  But now that SET_PT can
  66      potentially do a lot of stuff (calling entering and exiting
  67      hooks, etcetera), that's not a good approach.  So we validate the
  68      proposed position, then set point.  */
  69   {
  70     EMACS_INT new_point = PT + XINT (n);
  71
  72     if (new_point < BEGV)
  73       {
  74         SET_PT (BEGV);
  75         xsignal0 (Qbeginning_of_buffer);
  76       }
  77     if (new_point > ZV)
  78       {
  79         SET_PT (ZV);
  80         xsignal0 (Qend_of_buffer);
  81       }
  82
  83     SET_PT (new_point);
  84   }
  85
  86   return Qnil;
  87 }
  88
  89 DEFUN ("backward-char", Fbackward_char, Sbackward_char, 0, 1, "^p",
  90        doc: /* Move point N characters backward (forward if N is negative).
  91 On attempt to pass beginning or end of buffer, stop and signal error.
  92
  93 Depending on the bidirectional context, the movement may be to the
  94 right or to the left on the screen.  This is in contrast with
  95 \\[left-char], which see.  */)
  96   (Lisp_Object n)
  97 {
  98   if (NILP (n))
  99     XSETFASTINT (n, 1);
 100   else
 101     CHECK_NUMBER (n);
 102
 103   XSETINT (n, - XINT (n));
 104   return Fforward_char (n);
 105 }
 106
 107 DEFUN ("forward-line", Fforward_line, Sforward_line, 0, 1, "^p",
 108        doc: /* Move N lines forward (backward if N is negative).
 109 Precisely, if point is on line I, move to the start of line I + N
 110 \("start of line" in the logical order).
 111 If there isn't room, go as far as possible (no error).
 112 Returns the count of lines left to move.  If moving forward,
 113 that is N - number of lines moved; if backward, N + number moved.
 114 With positive N, a non-empty line at the end counts as one line
 115 successfully moved (for the return value).  */)
 116   (Lisp_Object n)
 117 {
 118   EMACS_INT opoint = PT, opoint_byte = PT_BYTE;
 119   EMACS_INT pos, pos_byte;
 120   EMACS_INT count, shortage;
 121
 122   if (NILP (n))
 123     count = 1;
 124   else
 125     {
 126       CHECK_NUMBER (n);
 127       count = XINT (n);
 128     }
 129
 130   if (count <= 0)
 131     shortage = scan_newline (PT, PT_BYTE, BEGV, BEGV_BYTE, count - 1, 1);
 132   else
 133     shortage = scan_newline (PT, PT_BYTE, ZV, ZV_BYTE, count, 1);
 134
 135   /* Since scan_newline does TEMP_SET_PT_BOTH,
 136      and we want to set PT "for real",
 137      go back to the old point and then come back here.  */
 138   pos = PT;
 139   pos_byte = PT_BYTE;
 140   TEMP_SET_PT_BOTH (opoint, opoint_byte);
 141   SET_PT_BOTH (pos, pos_byte);
 142
 143   if (shortage > 0
 144       && (count <= 0
 145           || (ZV > BEGV
 146               && PT != opoint
 147               && (FETCH_BYTE (PT_BYTE - 1) != '\n'))))
 148     shortage--;
 149
 150   return make_number (count <= 0 ? - shortage : shortage);
 151 }
 152
 153 DEFUN ("beginning-of-line", Fbeginning_of_line, Sbeginning_of_line, 0, 1, "^p",
 154        doc: /* Move point to beginning of current line (in the logical order).
 155 With argument N not nil or 1, move forward N - 1 lines first.
 156 If point reaches the beginning or end of buffer, it stops there.
 157
 158 This function constrains point to the current field unless this moves
 159 point to a different line than the original, unconstrained result.
 160 If N is nil or 1, and a front-sticky field starts at point, the point
 161 does not move.  To ignore field boundaries bind
 162 `inhibit-field-text-motion' to t, or use the `forward-line' function
 163 instead.  For instance, `(forward-line 0)' does the same thing as
 164 `(beginning-of-line)', except that it ignores field boundaries.  */)
 165   (Lisp_Object n)
 166 {
 167   if (NILP (n))
 168     XSETFASTINT (n, 1);
 169   else
 170     CHECK_NUMBER (n);
 171
 172   SET_PT (XINT (Fline_beginning_position (n)));
 173
 174   return Qnil;
 175 }
 176
 177 DEFUN ("end-of-line", Fend_of_line, Send_of_line, 0, 1, "^p",
 178        doc: /* Move point to end of current line (in the logical order).
 179 With argument N not nil or 1, move forward N - 1 lines first.
 180 If point reaches the beginning or end of buffer, it stops there.
 181 To ignore intangibility, bind `inhibit-point-motion-hooks' to t.
 182
 183 This function constrains point to the current field unless this moves
 184 point to a different line than the original, unconstrained result.  If
 185 N is nil or 1, and a rear-sticky field ends at point, the point does
 186 not move.  To ignore field boundaries bind `inhibit-field-text-motion'
 187 to t.  */)
 188   (Lisp_Object n)
 189 {
 190   EMACS_INT newpos;
 191
 192   if (NILP (n))
 193     XSETFASTINT (n, 1);
 194   else
 195     CHECK_NUMBER (n);
 196
 197   while (1)
 198     {
 199       newpos = XINT (Fline_end_position (n));
 200       SET_PT (newpos);
 201
 202       if (PT > newpos
 203           && FETCH_CHAR (PT - 1) == '\n')
 204         {
 205           /* If we skipped over a newline that follows
 206              an invisible intangible run,
 207              move back to the last tangible position
 208              within the line.  */
 209
 210           SET_PT (PT - 1);
 211           break;
 212         }
 213       else if (PT > newpos && PT < ZV
 214                && FETCH_CHAR (PT) != '\n')
 215         /* If we skipped something intangible
 216            and now we're not really at eol,
 217            keep going.  */
 218         n = make_number (1);
 219       else
 220         break;
 221     }
 222
 223   return Qnil;
 224 }
 225
 226 DEFUN ("delete-char", Fdelete_char, Sdelete_char, 1, 2, "p\nP",
 227        doc: /* Delete the following N characters (previous if N is negative).
 228 Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).
 229 Interactively, N is the prefix arg, and KILLFLAG is set if
 230 N was explicitly specified.
 231
 232 The command `delete-forward-char' is preferable for interactive use.  */)
 233   (Lisp_Object n, Lisp_Object killflag)
 234 {
 235   EMACS_INT pos;
 236
 237   CHECK_NUMBER (n);
 238
 239   pos = PT + XINT (n);
 240   if (NILP (killflag))
 241     {
 242       if (XINT (n) < 0)
 243         {
 244           if (pos < BEGV)
 245             xsignal0 (Qbeginning_of_buffer);
 246           else
 247             del_range (pos, PT);
 248         }
 249       else
 250         {
 251           if (pos > ZV)
 252             xsignal0 (Qend_of_buffer);
 253           else
 254             del_range (PT, pos);
 255         }
 256     }
 257   else
 258     {
 259       call1 (Qkill_forward_chars, n);
 260     }
 261   return Qnil;
 262 }
 263
 264 static int nonundocount;
 265
 266 /* Note that there's code in command_loop_1 which typically avoids
 267    calling this.  */
 268 DEFUN ("self-insert-command", Fself_insert_command, Sself_insert_command, 1, 1, "p",
 269        doc: /* Insert the character you type.
 270 Whichever character you type to run this command is inserted.
 271 Before insertion, `expand-abbrev' is executed if the inserted character does
 272 not have word syntax and the previous character in the buffer does.
 273 After insertion, the value of `auto-fill-function' is called if the
 274 `auto-fill-chars' table has a non-nil value for the inserted character.  */)
 275   (Lisp_Object n)
 276 {
 277   int remove_boundary = 1;
 278   CHECK_NATNUM (n);
 279
 280   if (!EQ (Vthis_command, KVAR (current_kboard, Vlast_command)))
 281     nonundocount = 0;
 282
 283   if (NILP (Vexecuting_kbd_macro)
 284       && !EQ (minibuf_window, selected_window))
 285     {
 286       if (nonundocount <= 0 || nonundocount >= 20)
 287         {
 288           remove_boundary = 0;
 289           nonundocount = 0;
 290         }
 291       nonundocount++;
 292     }
 293
 294   if (remove_boundary
 295       && CONSP (BVAR (current_buffer, undo_list))
 296       && NILP (XCAR (BVAR (current_buffer, undo_list))))
 297     /* Remove the undo_boundary that was just pushed.  */
 298     BVAR (current_buffer, undo_list) = XCDR (BVAR (current_buffer, undo_list));
 299
 300   /* Barf if the key that invoked this was not a character.  */
 301   if (!CHARACTERP (last_command_event))
 302     bitch_at_user ();
 303   {
 304     int character = translate_char (Vtranslation_table_for_input,
 305                                     (int) XINT (last_command_event));
 306     int val = internal_self_insert (character, XFASTINT (n));
 307     if (val == 2)
 308       nonundocount = 0;
 309     frame_make_pointer_invisible ();
 310   }
 311
 312   return Qnil;
 313 }
 314
 315 /* Insert N times character C
 316
 317    If this insertion is suitable for direct output (completely simple),
 318    return 0.  A value of 1 indicates this *might* not have been simple.
 319    A value of 2 means this did things that call for an undo boundary.  */
 320
 321 static Lisp_Object Qexpand_abbrev;
 322 static Lisp_Object Qpost_self_insert_hook;
 323
 324 static int
 325 internal_self_insert (int c, EMACS_INT n)
 326 {
 327   int hairy = 0;
 328   Lisp_Object tem;
 329   register enum syntaxcode synt;
 330   Lisp_Object overwrite;
 331   /* Length of multi-byte form of C.  */
 332   int len;
 333   /* Working buffer and pointer for multi-byte form of C.  */
 334   unsigned char str[MAX_MULTIBYTE_LENGTH];
 335   EMACS_INT chars_to_delete = 0;
 336   EMACS_INT spaces_to_insert = 0;
 337
 338   overwrite = BVAR (current_buffer, overwrite_mode);
 339   if (!NILP (Vbefore_change_functions) || !NILP (Vafter_change_functions))
 340     hairy = 1;
 341
 342   /* At first, get multi-byte form of C in STR.  */
 343   if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
 344     {
 345       len = CHAR_STRING (c, str);
 346       if (len == 1)
 347         /* If C has modifier bits, this makes C an appropriate
 348            one-byte char.  */
 349         c = *str;
 350     }
 351   else
 352     {
 353       str[0] = (SINGLE_BYTE_CHAR_P (c)
 354                 ? c
 355                 : multibyte_char_to_unibyte (c));
 356       len = 1;
 357     }
 358   if (!NILP (overwrite)
 359       && PT < ZV)
 360     {
 361       /* In overwrite-mode, we substitute a character at point (C2,
 362          hereafter) by C.  For that, we delete C2 in advance.  But,
 363          just substituting C2 by C may move a remaining text in the
 364          line to the right or to the left, which is not preferable.
 365          So we insert more spaces or delete more characters in the
 366          following cases: if C is narrower than C2, after deleting C2,
 367          we fill columns with spaces, if C is wider than C2, we delete
 368          C2 and several characters following C2.  */
 369
 370       /* This is the character after point.  */
 371       int c2 = FETCH_CHAR (PT_BYTE);
 372
 373       /* Overwriting in binary-mode always replaces C2 by C.
 374          Overwriting in textual-mode doesn't always do that.
 375          It inserts newlines in the usual way,
 376          and inserts any character at end of line
 377          or before a tab if it doesn't use the whole width of the tab.  */
 378       if (EQ (overwrite, Qoverwrite_mode_binary))
 379         chars_to_delete = n;
 380       else if (c != '\n' && c2 != '\n')
 381         {
 382           EMACS_INT pos = PT;
 383           EMACS_INT pos_byte = PT_BYTE;
 384
 385           /* FIXME: Check for integer overflow when calculating
 386              target_clm and actual_clm.  */
 387
 388           /* Column the cursor should be placed at after this insertion.
 389              The correct value should be calculated only when necessary.  */
 390           EMACS_INT target_clm = (current_column ()
 391                                   + n * XINT (Fchar_width (make_number (c))));
 392
 393           /* The actual cursor position after the trial of moving
 394              to column TARGET_CLM.  It is greater than TARGET_CLM
 395              if the TARGET_CLM is middle of multi-column
 396              character.  In that case, the new point is set after
 397              that character.  */
 398           EMACS_INT actual_clm
 399             = XFASTINT (Fmove_to_column (make_number (target_clm), Qnil));
 400
 401           chars_to_delete = PT - pos;
 402
 403           if (actual_clm > target_clm)
 404             {
 405               /* We will delete too many columns.  Let's fill columns
 406                  by spaces so that the remaining text won't move.  */
 407               EMACS_INT actual = PT_BYTE;
 408               DEC_POS (actual);
 409               if (FETCH_CHAR (actual) == '\t')
 410                 /* Rather than add spaces, let's just keep the tab. */
 411                 chars_to_delete--;
 412               else
 413                 spaces_to_insert = actual_clm - target_clm;
 414             }
 415
 416           SET_PT_BOTH (pos, pos_byte);
 417         }
 418       hairy = 2;
 419     }
 420
 421   synt = SYNTAX (c);
 422
 423   if (!NILP (BVAR (current_buffer, abbrev_mode))
 424       && synt != Sword
 425       && NILP (BVAR (current_buffer, read_only))
 426       && PT > BEGV
 427       && (SYNTAX (!NILP (BVAR (current_buffer, enable_multibyte_characters))
 428                   ? XFASTINT (Fprevious_char ())
 429                   : UNIBYTE_TO_CHAR (XFASTINT (Fprevious_char ())))
 430           == Sword))
 431     {
 432       int modiff = MODIFF;
 433       Lisp_Object sym;
 434
 435       sym = call0 (Qexpand_abbrev);
 436
 437       /* If we expanded an abbrev which has a hook,
 438          and the hook has a non-nil `no-self-insert' property,
 439          return right away--don't really self-insert.  */
 440       if (SYMBOLP (sym) && ! NILP (sym) && ! NILP (XSYMBOL (sym)->function)
 441           && SYMBOLP (XSYMBOL (sym)->function))
 442         {
 443           Lisp_Object prop;
 444           prop = Fget (XSYMBOL (sym)->function, intern ("no-self-insert"));
 445           if (! NILP (prop))
 446             return 1;
 447         }
 448
 449       if (MODIFF != modiff)
 450         hairy = 2;
 451     }
 452
 453   if (chars_to_delete)
 454     {
 455       int mc = ((NILP (BVAR (current_buffer, enable_multibyte_characters))
 456                  && SINGLE_BYTE_CHAR_P (c))
 457                 ? UNIBYTE_TO_CHAR (c) : c);
 458       Lisp_Object string = Fmake_string (make_number (n), make_number (mc));
 459
 460       if (spaces_to_insert)
 461         {
 462           tem = Fmake_string (make_number (spaces_to_insert),
 463                               make_number (' '));
 464           string = concat2 (string, tem);
 465         }
 466
 467       replace_range (PT, PT + chars_to_delete, string, 1, 1, 1);
 468       Fforward_char (make_number (n + spaces_to_insert));
 469     }
 470   else if (n > 1)
 471     {
 472       USE_SAFE_ALLOCA;
 473       char *strn, *p;
 474       SAFE_ALLOCA (strn, char *, n * len);
 475       for (p = strn; n > 0; n--, p += len)
 476         memcpy (p, str, len);
 477       insert_and_inherit (strn, p - strn);
 478       SAFE_FREE ();
 479     }
 480   else if (n > 0)
 481     insert_and_inherit ((char *) str, len);
 482
 483   if ((CHAR_TABLE_P (Vauto_fill_chars)
 484        ? !NILP (CHAR_TABLE_REF (Vauto_fill_chars, c))
 485        : (c == ' ' || c == '\n'))
 486       && !NILP (BVAR (current_buffer, auto_fill_function)))
 487     {
 488       Lisp_Object auto_fill_result;
 489
 490       if (c == '\n')
 491         /* After inserting a newline, move to previous line and fill
 492            that.  Must have the newline in place already so filling and
 493            justification, if any, know where the end is going to be.  */
 494         SET_PT_BOTH (PT - 1, PT_BYTE - 1);
 495       auto_fill_result = call0 (BVAR (current_buffer, auto_fill_function));
 496       /* Test PT < ZV in case the auto-fill-function is strange.  */
 497       if (c == '\n' && PT < ZV)
 498         SET_PT_BOTH (PT + 1, PT_BYTE + 1);
 499       if (!NILP (auto_fill_result))
 500         hairy = 2;
 501     }
 502
 503   /* Run hooks for electric keys.  */
 504   Frun_hooks (1, &Qpost_self_insert_hook);
 505
 506   return hairy;
 507 }
 508 \f
 509 /* module initialization */
 510
 511 void
 512 syms_of_cmds (void)
 513 {
 514   Qkill_backward_chars = intern_c_string ("kill-backward-chars");
 515   staticpro (&Qkill_backward_chars);
 516
 517   Qkill_forward_chars = intern_c_string ("kill-forward-chars");
 518   staticpro (&Qkill_forward_chars);
 519
 520   Qoverwrite_mode_binary = intern_c_string ("overwrite-mode-binary");
 521   staticpro (&Qoverwrite_mode_binary);
 522
 523   Qexpand_abbrev = intern_c_string ("expand-abbrev");
 524   staticpro (&Qexpand_abbrev);
 525
 526   Qpost_self_insert_hook = intern_c_string ("post-self-insert-hook");
 527   staticpro (&Qpost_self_insert_hook);
 528
 529   DEFVAR_LISP ("post-self-insert-hook", Vpost_self_insert_hook,
 530                doc: /* Hook run at the end of `self-insert-command'.
 531 This is run after inserting the character.  */);
 532   Vpost_self_insert_hook = Qnil;
 533
 534   defsubr (&Sforward_point);
 535   defsubr (&Sforward_char);
 536   defsubr (&Sbackward_char);
 537   defsubr (&Sforward_line);
 538   defsubr (&Sbeginning_of_line);
 539   defsubr (&Send_of_line);
 540
 541   defsubr (&Sdelete_char);
 542   defsubr (&Sself_insert_command);
 543 }
 544
 545 void
 546 keys_of_cmds (void)
 547 {
 548   int n;
 549
 550   nonundocount = 0;
 551   initial_define_key (global_map, Ctl ('I'), "self-insert-command");
 552   for (n = 040; n < 0177; n++)
 553     initial_define_key (global_map, n, "self-insert-command");
 554 #ifdef MSDOS
 555   for (n = 0200; n < 0240; n++)
 556     initial_define_key (global_map, n, "self-insert-command");
 557 #endif
 558   for (n = 0240; n < 0400; n++)
 559     initial_define_key (global_map, n, "self-insert-command");
 560
 561   initial_define_key (global_map, Ctl ('A'), "beginning-of-line");
 562   initial_define_key (global_map, Ctl ('B'), "backward-char");
 563   initial_define_key (global_map, Ctl ('E'), "end-of-line");
 564   initial_define_key (global_map, Ctl ('F'), "forward-char");
 565 }