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

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