1;;; simple.el --- basic editing commands for Emacs 2 3;; Copyright (C) 1985, 1986, 1987, 1993, 1994 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 2, or (at your option) 10;; 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; see the file COPYING. If not, write to 19;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 20 21;;; Commentary: 22 23;; A grab-bag of basic Emacs commands not specifically related to some 24;; major mode or to file-handling. 25 26;;; Code: 27 28(defun open-line (arg) 29 "Insert a newline and leave point before it. 30If there is a fill prefix, insert the fill prefix on the new line 31if the line would have been empty. 32With arg N, insert N newlines." 33 (interactive "*p") 34 (let* ((do-fill-prefix (and fill-prefix (bolp))) 35 (flag (and (null do-fill-prefix) (bolp) (not (bobp))))) 36 ;; If this is a simple case, and we are at the beginning of a line, 37 ;; actually insert the newline *before* the preceding newline 38 ;; instead of after. That makes better display behavior. 39 (if flag 40 (progn 41 ;; If undo is enabled, don't let this hack be visible: 42 ;; record the real value of point as the place to move back to 43 ;; if we undo this insert. 44 (if (not (eq buffer-undo-list t)) 45 (setq buffer-undo-list (cons (point) buffer-undo-list))) 46 (forward-char -1))) 47 (save-excursion 48 (while (> arg 0) 49 (if do-fill-prefix (insert fill-prefix)) 50 (insert ?\n) 51 (setq arg (1- arg)))) 52 (end-of-line) 53 (if flag (forward-char 1)))) 54 55(defun split-line () 56 "Split current line, moving portion beyond point vertically down." 57 (interactive "*") 58 (skip-chars-forward " \t") 59 (let ((col (current-column)) 60 (pos (point))) 61 (insert ?\n) 62 (indent-to col 0) 63 (goto-char pos))) 64 65(defun quoted-insert (arg) 66 "Read next input character and insert it. 67This is useful for inserting control characters. 68You may also type up to 3 octal digits, to insert a character with that code. 69 70In overwrite mode, this function inserts the character anyway, and 71does not handle octal digits specially. This means that if you use 72overwrite as your normal editing mode, you can use this function to 73insert characters when necessary. 74 75In binary overwrite mode, this function does overwrite, and octal 76digits are interpreted as a character code. This is supposed to make 77this function useful in editing binary files." 78 (interactive "*p") 79 (let ((char (if (or (not overwrite-mode) 80 (eq overwrite-mode 'overwrite-mode-binary)) 81 (read-quoted-char) 82 (read-char)))) 83 (if (eq overwrite-mode 'overwrite-mode-binary) 84 (delete-char arg)) 85 (insert-char char arg))) 86 87(defun delete-indentation (&optional arg) 88 "Join this line to previous and fix up whitespace at join. 89If there is a fill prefix, delete it from the beginning of this line. 90With argument, join this line to following line." 91 (interactive "*P") 92 (beginning-of-line) 93 (if arg (forward-line 1)) 94 (if (eq (preceding-char) ?\n) 95 (progn 96 (delete-region (point) (1- (point))) 97 ;; If the second line started with the fill prefix, 98 ;; delete the prefix. 99 (if (and fill-prefix 100 (<= (+ (point) (length fill-prefix)) (point-max)) 101 (string= fill-prefix 102 (buffer-substring (point) 103 (+ (point) (length fill-prefix))))) 104 (delete-region (point) (+ (point) (length fill-prefix)))) 105 (fixup-whitespace)))) 106 107(defun fixup-whitespace () 108 "Fixup white space between objects around point. 109Leave one space or none, according to the context." 110 (interactive "*") 111 (save-excursion 112 (delete-horizontal-space) 113 (if (or (looking-at "^\\|\\s)") 114 (save-excursion (forward-char -1) 115 (looking-at "$\\|\\s(\\|\\s'"))) 116 nil 117 (insert ?\ )))) 118 119(defun delete-horizontal-space () 120 "Delete all spaces and tabs around point." 121 (interactive "*") 122 (skip-chars-backward " \t") 123 (delete-region (point) (progn (skip-chars-forward " \t") (point)))) 124 125(defun just-one-space () 126 "Delete all spaces and tabs around point, leaving one space." 127 (interactive "*") 128 (skip-chars-backward " \t") 129 (if (= (following-char) ? ) 130 (forward-char 1) 131 (insert ? )) 132 (delete-region (point) (progn (skip-chars-forward " \t") (point)))) 133 134(defun delete-blank-lines () 135 "On blank line, delete all surrounding blank lines, leaving just one. 136On isolated blank line, delete that one. 137On nonblank line, delete all blank lines that follow it." 138 (interactive "*") 139 (let (thisblank singleblank) 140 (save-excursion 141 (beginning-of-line) 142 (setq thisblank (looking-at "[ \t]*$")) 143 ;; Set singleblank if there is just one blank line here. 144 (setq singleblank 145 (and thisblank 146 (not (looking-at "[ \t]*\n[ \t]*$")) 147 (or (bobp) 148 (progn (forward-line -1) 149 (not (looking-at "[ \t]*$"))))))) 150 ;; Delete preceding blank lines, and this one too if it's the only one. 151 (if thisblank 152 (progn 153 (beginning-of-line) 154 (if singleblank (forward-line 1)) 155 (delete-region (point) 156 (if (re-search-backward "[^ \t\n]" nil t) 157 (progn (forward-line 1) (point)) 158 (point-min))))) 159 ;; Delete following blank lines, unless the current line is blank 160 ;; and there are no following blank lines. 161 (if (not (and thisblank singleblank)) 162 (save-excursion 163 (end-of-line) 164 (forward-line 1) 165 (delete-region (point) 166 (if (re-search-forward "[^ \t\n]" nil t) 167 (progn (beginning-of-line) (point)) 168 (point-max))))) 169 ;; Handle the special case where point is followed by newline and eob. 170 ;; Delete the line, leaving point at eob. 171 (if (looking-at "^[ \t]*\n\\'") 172 (delete-region (point) (point-max))))) 173 174(defun back-to-indentation () 175 "Move point to the first non-whitespace character on this line." 176 (interactive) 177 (beginning-of-line 1) 178 (skip-chars-forward " \t")) 179 180(defun newline-and-indent () 181 "Insert a newline, then indent according to major mode. 182Indentation is done using the value of `indent-line-function'. 183In programming language modes, this is the same as TAB. 184In some text modes, where TAB inserts a tab, this command indents to the 185column specified by the variable `left-margin'." 186 (interactive "*") 187 (delete-region (point) (progn (skip-chars-backward " \t") (point))) 188 (newline) 189 (indent-according-to-mode)) 190 191(defun reindent-then-newline-and-indent () 192 "Reindent current line, insert newline, then indent the new line. 193Indentation of both lines is done according to the current major mode, 194which means calling the current value of `indent-line-function'. 195In programming language modes, this is the same as TAB. 196In some text modes, where TAB inserts a tab, this indents to the 197column specified by the variable `left-margin'." 198 (interactive "*") 199 (save-excursion 200 (delete-region (point) (progn (skip-chars-backward " \t") (point))) 201 (indent-according-to-mode)) 202 (newline) 203 (indent-according-to-mode)) 204 205;; Internal subroutine of delete-char 206(defun kill-forward-chars (arg) 207 (if (listp arg) (setq arg (car arg))) 208 (if (eq arg '-) (setq arg -1)) 209 (kill-region (point) (+ (point) arg))) 210 211;; Internal subroutine of backward-delete-char 212(defun kill-backward-chars (arg) 213 (if (listp arg) (setq arg (car arg))) 214 (if (eq arg '-) (setq arg -1)) 215 (kill-region (point) (- (point) arg))) 216 217(defun backward-delete-char-untabify (arg &optional killp) 218 "Delete characters backward, changing tabs into spaces. 219Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil. 220Interactively, ARG is the prefix arg (default 1) 221and KILLP is t if prefix arg is was specified." 222 (interactive "*p\nP") 223 (let ((count arg)) 224 (save-excursion 225 (while (and (> count 0) (not (bobp))) 226 (if (= (preceding-char) ?\t) 227 (let ((col (current-column))) 228 (forward-char -1) 229 (setq col (- col (current-column))) 230 (insert-char ?\ col) 231 (delete-char 1))) 232 (forward-char -1) 233 (setq count (1- count))))) 234 (delete-backward-char arg killp) 235 ;; In overwrite mode, back over columns while clearing them out, 236 ;; unless at end of line. 237 (and overwrite-mode (not (eolp)) 238 (save-excursion (insert-char ?\ arg)))) 239 240(defun zap-to-char (arg char) 241 "Kill up to and including ARG'th occurrence of CHAR. 242Goes backward if ARG is negative; error if CHAR not found." 243 (interactive "p\ncZap to char: ") 244 (kill-region (point) (progn 245 (search-forward (char-to-string char) nil nil arg) 246; (goto-char (if (> arg 0) (1- (point)) (1+ (point)))) 247 (point)))) 248 249(defun beginning-of-buffer (&optional arg) 250 "Move point to the beginning of the buffer; leave mark at previous position. 251With arg N, put point N/10 of the way from the true beginning. 252 253Don't use this command in Lisp programs! 254\(goto-char (point-min)) is faster and avoids clobbering the mark." 255 (interactive "P") 256 (push-mark) 257 (goto-char (if arg 258 (if (> (buffer-size) 10000) 259 ;; Avoid overflow for large buffer sizes! 260 (* (prefix-numeric-value arg) 261 (/ (buffer-size) 10)) 262 (/ (+ 10 (* (buffer-size) (prefix-numeric-value arg))) 10)) 263 (point-min))) 264 (if arg (forward-line 1))) 265 266(defun end-of-buffer (&optional arg) 267 "Move point to the end of the buffer; leave mark at previous position. 268With arg N, put point N/10 of the way from the true end. 269 270Don't use this command in Lisp programs! 271\(goto-char (point-max)) is faster and avoids clobbering the mark." 272 (interactive "P") 273 (push-mark) 274 (goto-char (if arg 275 (- (1+ (buffer-size)) 276 (if (> (buffer-size) 10000) 277 ;; Avoid overflow for large buffer sizes! 278 (* (prefix-numeric-value arg) 279 (/ (buffer-size) 10)) 280 (/ (* (buffer-size) (prefix-numeric-value arg)) 10))) 281 (point-max))) 282 ;; If we went to a place in the middle of the buffer, 283 ;; adjust it to the beginning of a line. 284 (if arg (forward-line 1) 285 ;; If the end of the buffer is not already on the screen, 286 ;; then scroll specially to put it near, but not at, the bottom. 287 (if (let ((old-point (point))) 288 (save-excursion 289 (goto-char (window-start)) 290 (vertical-motion (window-height)) 291 (< (point) old-point))) 292 (recenter -3)))) 293 294(defun mark-whole-buffer () 295 "Put point at beginning and mark at end of buffer. 296You probably should not use this function in Lisp programs; 297it is usually a mistake for a Lisp function to use any subroutine 298that uses or sets the mark." 299 (interactive) 300 (push-mark (point)) 301 (push-mark (point-max) nil t) 302 (goto-char (point-min))) 303 304(defun count-lines-region (start end) 305 "Print number of lines and characters in the region." 306 (interactive "r") 307 (message "Region has %d lines, %d characters" 308 (count-lines start end) (- end start))) 309 310(defun what-line () 311 "Print the current line number (in the buffer) of point." 312 (interactive) 313 (save-restriction 314 (widen) 315 (save-excursion 316 (beginning-of-line) 317 (message "Line %d" 318 (1+ (count-lines 1 (point))))))) 319 320(defun count-lines (start end) 321 "Return number of lines between START and END. 322This is usually the number of newlines between them, 323but can be one more if START is not equal to END 324and the greater of them is not at the start of a line." 325 (save-match-data 326 (save-excursion 327 (save-restriction 328 (narrow-to-region start end) 329 (goto-char (point-min)) 330 (if (eq selective-display t) 331 (let ((done 0)) 332 (while (re-search-forward "[\n\C-m]" nil t 40) 333 (setq done (+ 40 done))) 334 (while (re-search-forward "[\n\C-m]" nil t 1) 335 (setq done (+ 1 done))) 336 (goto-char (point-max)) 337 (if (and (/= start end) 338 (not (bolp))) 339 (1+ done) 340 done)) 341 (- (buffer-size) (forward-line (buffer-size)))))))) 342 343(defun what-cursor-position () 344 "Print info on cursor position (on screen and within buffer)." 345 (interactive) 346 (let* ((char (following-char)) 347 (beg (point-min)) 348 (end (point-max)) 349 (pos (point)) 350 (total (buffer-size)) 351 (percent (if (> total 50000) 352 ;; Avoid overflow from multiplying by 100! 353 (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1)) 354 (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1)))) 355 (hscroll (if (= (window-hscroll) 0) 356 "" 357 (format " Hscroll=%d" (window-hscroll)))) 358 (col (current-column))) 359 (if (= pos end) 360 (if (or (/= beg 1) (/= end (1+ total))) 361 (message "point=%d of %d(%d%%) <%d - %d> column %d %s" 362 pos total percent beg end col hscroll) 363 (message "point=%d of %d(%d%%) column %d %s" 364 pos total percent col hscroll)) 365 (if (or (/= beg 1) (/= end (1+ total))) 366 (message "Char: %s (0%o) point=%d of %d(%d%%) <%d - %d> column %d %s" 367 (single-key-description char) char pos total percent beg end col hscroll) 368 (message "Char: %s (0%o) point=%d of %d(%d%%) column %d %s" 369 (single-key-description char) char pos total percent col hscroll))))) 370 371(defun fundamental-mode () 372 "Major mode not specialized for anything in particular. 373Other major modes are defined by comparison with this one." 374 (interactive) 375 (kill-all-local-variables)) 376 377(defvar read-expression-map (cons 'keymap minibuffer-local-map) 378 "Minibuffer keymap used for reading Lisp expressions.") 379(define-key read-expression-map "\M-\t" 'lisp-complete-symbol) 380 381(put 'eval-expression 'disabled t) 382 383(defvar read-expression-history nil) 384 385;; We define this, rather than making `eval' interactive, 386;; for the sake of completion of names like eval-region, eval-current-buffer. 387(defun eval-expression (expression) 388 "Evaluate EXPRESSION and print value in minibuffer. 389Value is also consed on to front of the variable `values'." 390 (interactive 391 (list (read-from-minibuffer "Eval: " 392 nil read-expression-map t 393 'read-expression-history))) 394 (setq values (cons (eval expression) values)) 395 (prin1 (car values) t)) 396 397(defun edit-and-eval-command (prompt command) 398 "Prompting with PROMPT, let user edit COMMAND and eval result. 399COMMAND is a Lisp expression. Let user edit that expression in 400the minibuffer, then read and evaluate the result." 401 (let ((command (read-from-minibuffer prompt 402 (prin1-to-string command) 403 read-expression-map t 404 '(command-history . 1)))) 405 (eval command))) 406 407(defun repeat-complex-command (arg) 408 "Edit and re-evaluate last complex command, or ARGth from last. 409A complex command is one which used the minibuffer. 410The command is placed in the minibuffer as a Lisp form for editing. 411The result is executed, repeating the command as changed. 412If the command has been changed or is not the most recent previous command 413it is added to the front of the command history. 414You can use the minibuffer history commands \\<minibuffer-local-map>\\[next-history-element] and \\[previous-history-element] 415to get different commands to edit and resubmit." 416 (interactive "p") 417 (let ((elt (nth (1- arg) command-history)) 418 (minibuffer-history-position arg) 419 (minibuffer-history-sexp-flag t) 420 newcmd) 421 (if elt 422 (progn 423 (setq newcmd 424 (read-from-minibuffer 425 "Redo: " (prin1-to-string elt) read-expression-map t 426 (cons 'command-history arg))) 427 428 ;; If command was added to command-history as a string, 429 ;; get rid of that. We want only evallable expressions there. 430 (if (stringp (car command-history)) 431 (setq command-history (cdr command-history))) 432 433 ;; If command to be redone does not match front of history, 434 ;; add it to the history. 435 (or (equal newcmd (car command-history)) 436 (setq command-history (cons newcmd command-history))) 437 (eval newcmd)) 438 (ding)))) 439 440(defvar minibuffer-history nil 441 "Default minibuffer history list. 442This is used for all minibuffer input 443except when an alternate history list is specified.") 444(defvar minibuffer-history-sexp-flag nil 445 "Non-nil when doing history operations on `command-history'. 446More generally, indicates that the history list being acted on 447contains expressions rather than strings.") 448(setq minibuffer-history-variable 'minibuffer-history) 449(setq minibuffer-history-position nil) 450(defvar minibuffer-history-search-history nil) 451 452(mapcar 453 (lambda (key-and-command) 454 (mapcar 455 (lambda (keymap-and-completionp) 456 ;; Arg is (KEYMAP-SYMBOL . COMPLETION-MAP-P). 457 ;; If the cdr of KEY-AND-COMMAND (the command) is a cons, 458 ;; its car is used if COMPLETION-MAP-P is nil, its cdr if it is t. 459 (define-key (symbol-value (car keymap-and-completionp)) 460 (car key-and-command) 461 (let ((command (cdr key-and-command))) 462 (if (consp command) 463 ;; (and ... nil) => ... turns back on the completion-oriented 464 ;; history commands which rms turned off since they seem to 465 ;; do things he doesn't like. 466 (if (and (cdr keymap-and-completionp) nil) ;XXX turned off 467 (progn (error "EMACS BUG!") (cdr command)) 468 (car command)) 469 command)))) 470 '((minibuffer-local-map . nil) 471 (minibuffer-local-ns-map . nil) 472 (minibuffer-local-completion-map . t) 473 (minibuffer-local-must-match-map . t) 474 (read-expression-map . nil)))) 475 '(("\en" . (next-history-element . next-complete-history-element)) 476 ([next] . (next-history-element . next-complete-history-element)) 477 ("\ep" . (previous-history-element . previous-complete-history-element)) 478 ([prior] . (previous-history-element . previous-complete-history-element)) 479 ("\er" . previous-matching-history-element) 480 ("\es" . next-matching-history-element))) 481 482(defun previous-matching-history-element (regexp n) 483 "Find the previous history element that matches REGEXP. 484\(Previous history elements refer to earlier actions.) 485With prefix argument N, search for Nth previous match. 486If N is negative, find the next or Nth next match." 487 (interactive 488 (let* ((enable-recursive-minibuffers t) 489 (minibuffer-history-sexp-flag nil) 490 (regexp (read-from-minibuffer "Previous element matching (regexp): " 491 nil 492 minibuffer-local-map 493 nil 494 'minibuffer-history-search-history))) 495 ;; Use the last regexp specified, by default, if input is empty. 496 (list (if (string= regexp "") 497 (setcar minibuffer-history-search-history 498 (nth 1 minibuffer-history-search-history)) 499 regexp) 500 (prefix-numeric-value current-prefix-arg)))) 501 (let ((history (symbol-value minibuffer-history-variable)) 502 prevpos 503 (pos minibuffer-history-position)) 504 (while (/= n 0) 505 (setq prevpos pos) 506 (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history))) 507 (if (= pos prevpos) 508 (error (if (= pos 1) 509 "No later matching history item" 510 "No earlier matching history item"))) 511 (if (string-match regexp 512 (if minibuffer-history-sexp-flag 513 (prin1-to-string (nth (1- pos) history)) 514 (nth (1- pos) history))) 515 (setq n (+ n (if (< n 0) 1 -1))))) 516 (setq minibuffer-history-position pos) 517 (erase-buffer) 518 (let ((elt (nth (1- pos) history))) 519 (insert (if minibuffer-history-sexp-flag 520 (prin1-to-string elt) 521 elt))) 522 (goto-char (point-min))) 523 (if (or (eq (car (car command-history)) 'previous-matching-history-element) 524 (eq (car (car command-history)) 'next-matching-history-element)) 525 (setq command-history (cdr command-history)))) 526 527(defun next-matching-history-element (regexp n) 528 "Find the next history element that matches REGEXP. 529\(The next history element refers to a more recent action.) 530With prefix argument N, search for Nth next match. 531If N is negative, find the previous or Nth previous match." 532 (interactive 533 (let* ((enable-recursive-minibuffers t) 534 (minibuffer-history-sexp-flag nil) 535 (regexp (read-from-minibuffer "Next element matching (regexp): " 536 nil 537 minibuffer-local-map 538 nil 539 'minibuffer-history-search-history))) 540 ;; Use the last regexp specified, by default, if input is empty. 541 (list (if (string= regexp "") 542 (setcar minibuffer-history-search-history 543 (nth 1 minibuffer-history-search-history)) 544 regexp) 545 (prefix-numeric-value current-prefix-arg)))) 546 (previous-matching-history-element regexp (- n))) 547 548(defun next-history-element (n) 549 "Insert the next element of the minibuffer history into the minibuffer." 550 (interactive "p") 551 (let ((narg (min (max 1 (- minibuffer-history-position n)) 552 (length (symbol-value minibuffer-history-variable))))) 553 (if (= minibuffer-history-position narg) 554 (error (if (= minibuffer-history-position 1) 555 "End of history; no next item" 556 "Beginning of history; no preceding item")) 557 (erase-buffer) 558 (setq minibuffer-history-position narg) 559 (let ((elt (nth (1- minibuffer-history-position) 560 (symbol-value minibuffer-history-variable)))) 561 (insert 562 (if minibuffer-history-sexp-flag 563 (prin1-to-string elt) 564 elt))) 565 (goto-char (point-min))))) 566 567(defun previous-history-element (n) 568 "Inserts the previous element of the minibuffer history into the minibuffer." 569 (interactive "p") 570 (next-history-element (- n))) 571 572(defun next-complete-history-element (n) 573 "Get next element of history which is a completion of minibuffer contents." 574 (interactive "p") 575 (let ((point-at-start (point))) 576 (next-matching-history-element 577 (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n) 578 ;; next-matching-history-element always puts us at (point-min). 579 ;; Move to the position we were at before changing the buffer contents. 580 ;; This is still sensical, because the text before point has not changed. 581 (goto-char point-at-start))) 582 583(defun previous-complete-history-element (n) 584 "\ 585Get previous element of history which is a completion of minibuffer contents." 586 (interactive "p") 587 (next-complete-history-element (- n))) 588 589(defun goto-line (arg) 590 "Goto line ARG, counting from line 1 at beginning of buffer." 591 (interactive "NGoto line: ") 592 (save-restriction 593 (widen) 594 (goto-char 1) 595 (if (eq selective-display t) 596 (re-search-forward "[\n\C-m]" nil 'end (1- arg)) 597 (forward-line (1- arg))))) 598 599;Put this on C-x u, so we can force that rather than C-_ into startup msg 600(define-function 'advertised-undo 'undo) 601 602(defun undo (&optional arg) 603 "Undo some previous changes. 604Repeat this command to undo more changes. 605A numeric argument serves as a repeat count." 606 (interactive "*p") 607 ;; If we don't get all the way thru, make last-command indicate that 608 ;; for the following command. 609 (setq this-command t) 610 (let ((modified (buffer-modified-p)) 611 (recent-save (recent-auto-save-p))) 612 (or (eq (selected-window) (minibuffer-window)) 613 (message "Undo!")) 614 (or (eq last-command 'undo) 615 (progn (undo-start) 616 (undo-more 1))) 617 (undo-more (or arg 1)) 618 ;; Don't specify a position in the undo record for the undo command. 619 ;; Instead, undoing this should move point to where the change is. 620 (let ((tail buffer-undo-list) 621 done) 622 (while (and tail (not done) (not (null (car tail)))) 623 (if (integerp (car tail)) 624 (progn 625 (setq done t) 626 (setq buffer-undo-list (delq (car tail) buffer-undo-list)))) 627 (setq tail (cdr tail)))) 628 (and modified (not (buffer-modified-p)) 629 (delete-auto-save-file-if-necessary recent-save))) 630 ;; If we do get all the way thru, make this-command indicate that. 631 (setq this-command 'undo)) 632 633(defvar pending-undo-list nil 634 "Within a run of consecutive undo commands, list remaining to be undone.") 635 636(defun undo-start () 637 "Set `pending-undo-list' to the front of the undo list. 638The next call to `undo-more' will undo the most recently made change." 639 (if (eq buffer-undo-list t) 640 (error "No undo information in this buffer")) 641 (setq pending-undo-list buffer-undo-list)) 642 643(defun undo-more (count) 644 "Undo back N undo-boundaries beyond what was already undone recently. 645Call `undo-start' to get ready to undo recent changes, 646then call `undo-more' one or more times to undo them." 647 (or pending-undo-list 648 (error "No further undo information")) 649 (setq pending-undo-list (primitive-undo count pending-undo-list))) 650 651(defvar shell-command-history nil 652 "History list for some commands that read shell commands.") 653 654(defun shell-command (command &optional flag) 655 "Execute string COMMAND in inferior shell; display output, if any. 656If COMMAND ends in ampersand, execute it asynchronously. 657 658Optional second arg non-nil (prefix arg, if interactive) 659means insert output in current buffer after point (leave mark after it). 660This cannot be done asynchronously." 661 (interactive (list (read-from-minibuffer "Shell command: " 662 nil nil nil 'shell-command-history) 663 current-prefix-arg)) 664 (if flag 665 (progn (barf-if-buffer-read-only) 666 (push-mark) 667 ;; We do not use -f for csh; we will not support broken use of 668 ;; .cshrcs. Even the BSD csh manual says to use 669 ;; "if ($?prompt) exit" before things which are not useful 670 ;; non-interactively. Besides, if someone wants their other 671 ;; aliases for shell commands then they can still have them. 672 (call-process shell-file-name nil t nil 673 "-c" command) 674 ;; This is like exchange-point-and-mark, but doesn't activate the mark. 675 ;; It is cleaner to avoid activation, even though the command 676 ;; loop would deactivate the mark because we inserted text. 677 (goto-char (prog1 (mark t) 678 (set-marker (mark-marker) (point) 679 (current-buffer))))) 680 ;; Preserve the match data in case called from a program. 681 (let ((data (match-data))) 682 (unwind-protect 683 (if (string-match "[ \t]*&[ \t]*$" command) 684 ;; Command ending with ampersand means asynchronous. 685 (let ((buffer (get-buffer-create "*Shell-Command*")) 686 (directory default-directory) 687 proc) 688 ;; Remove the ampersand. 689 (setq command (substring command 0 (match-beginning 0))) 690 ;; If will kill a process, query first. 691 (setq proc (get-buffer-process buffer)) 692 (if proc 693 (if (yes-or-no-p "A command is running. Kill it? ") 694 (kill-process proc) 695 (error "Shell command in progress"))) 696 (save-excursion 697 (set-buffer buffer) 698 (erase-buffer) 699 (display-buffer buffer) 700 (setq default-directory directory) 701 (setq proc (start-process "Shell" buffer 702 shell-file-name "-c" command)) 703 (setq mode-line-process '(":%s")) 704 (set-process-sentinel proc 'shell-command-sentinel) 705 (set-process-filter proc 'shell-command-filter) 706 )) 707 (shell-command-on-region (point) (point) command nil)) 708 (store-match-data data))))) 709 710;; We have a sentinel to prevent insertion of a termination message 711;; in the buffer itself. 712(defun shell-command-sentinel (process signal) 713 (if (and (memq (process-status process) '(exit signal)) 714 (buffer-name (process-buffer process))) 715 (progn 716 (message "%s: %s." 717 (car (cdr (cdr (process-command process)))) 718 (substring signal 0 -1)) 719 (save-excursion 720 (set-buffer (process-buffer process)) 721 (setq mode-line-process nil)) 722 (delete-process process)))) 723 724(defun shell-command-filter (proc string) 725 ;; Do save-excursion by hand so that we can leave point numerically unchanged 726 ;; despite an insertion immediately after it. 727 (let* ((obuf (current-buffer)) 728 (buffer (process-buffer proc)) 729 opoint 730 (window (get-buffer-window buffer)) 731 (pos (window-start window))) 732 (unwind-protect 733 (progn 734 (set-buffer buffer) 735 (or (= (point) (point-max)) 736 (setq opoint (point))) 737 (goto-char (point-max)) 738 (insert-before-markers string)) 739 ;; insert-before-markers moved this marker: set it back. 740 (set-window-start window pos) 741 ;; Finish our save-excursion. 742 (if opoint 743 (goto-char opoint)) 744 (set-buffer obuf)))) 745 746(defun shell-command-on-region (start end command &optional flag interactive) 747 "Execute string COMMAND in inferior shell with region as input. 748Normally display output (if any) in temp buffer `*Shell Command Output*'; 749Prefix arg means replace the region with it. 750Noninteractive args are START, END, COMMAND, FLAG. 751Noninteractively FLAG means insert output in place of text from START to END, 752and put point at the end, but don't alter the mark. 753 754If the output is one line, it is displayed in the echo area, 755but it is nonetheless available in buffer `*Shell Command Output*' 756even though that buffer is not automatically displayed. If there is no output 757or output is inserted in the current buffer then `*Shell Command Output*' is 758deleted." 759 (interactive (list (region-beginning) (region-end) 760 (read-from-minibuffer "Shell command on region: " 761 nil nil nil 'shell-command-history) 762 current-prefix-arg 763 (prefix-numeric-value current-prefix-arg))) 764 (if flag 765 ;; Replace specified region with output from command. 766 (let ((swap (and interactive (< (point) (mark))))) 767 ;; Don't muck with mark 768 ;; unless called interactively. 769 (and interactive (push-mark)) 770 (call-process-region start end shell-file-name t t nil 771 "-c" command) 772 (if (get-buffer "*Shell Command Output*") 773 (kill-buffer "*Shell Command Output*")) 774 (and interactive swap (exchange-point-and-mark))) 775 ;; No prefix argument: put the output in a temp buffer, 776 ;; replacing its entire contents. 777 (let ((buffer (get-buffer-create "*Shell Command Output*")) 778 (success nil)) 779 (unwind-protect 780 (if (eq buffer (current-buffer)) 781 ;; If the input is the same buffer as the output, 782 ;; delete everything but the specified region, 783 ;; then replace that region with the output. 784 (progn (delete-region end (point-max)) 785 (delete-region (point-min) start) 786 (call-process-region (point-min) (point-max) 787 shell-file-name t t nil 788 "-c" command) 789 (setq success t)) 790 ;; Clear the output buffer, then run the command with output there. 791 (save-excursion 792 (set-buffer buffer) 793 (erase-buffer)) 794 (call-process-region start end shell-file-name 795 nil buffer nil 796 "-c" command) 797 (setq success t)) 798 ;; Report the amount of output. 799 (let ((lines (save-excursion 800 (set-buffer buffer) 801 (if (= (buffer-size) 0) 802 0 803 (count-lines (point-min) (point-max)))))) 804 (cond ((= lines 0) 805 (if success 806 (message "(Shell command completed with no output)")) 807 (kill-buffer buffer)) 808 ((and success (= lines 1)) 809 (message "%s" 810 (save-excursion 811 (set-buffer buffer) 812 (goto-char (point-min)) 813 (buffer-substring (point) 814 (progn (end-of-line) (point)))))) 815 (t 816 (set-window-start (display-buffer buffer) 1)))))))) 817 818(defun universal-argument () 819 "Begin a numeric argument for the following command. 820Digits or minus sign following \\[universal-argument] make up the numeric argument. 821\\[universal-argument] following the digits or minus sign ends the argument. 822\\[universal-argument] without digits or minus sign provides 4 as argument. 823Repeating \\[universal-argument] without digits or minus sign 824 multiplies the argument by 4 each time." 825 (interactive nil) 826 (let ((factor 4) 827 key) 828;; (describe-arg (list factor) 1) 829 (setq key (read-key-sequence nil t)) 830 (while (equal (key-binding key) 'universal-argument) 831 (setq factor (* 4 factor)) 832;; (describe-arg (list factor) 1) 833 (setq key (read-key-sequence nil t))) 834 (prefix-arg-internal key factor nil))) 835 836(defun prefix-arg-internal (key factor value) 837 (let ((sign 1)) 838 (if (and (numberp value) (< value 0)) 839 (setq sign -1 value (- value))) 840 (if (eq value '-) 841 (setq sign -1 value nil)) 842;; (describe-arg value sign) 843 (while (equal key "-") 844 (setq sign (- sign) factor nil) 845;; (describe-arg value sign) 846 (setq key (read-key-sequence nil t))) 847 (while (and (stringp key) 848 (= (length key) 1) 849 (not (string< key "0")) 850 (not (string< "9" key))) 851 (setq value (+ (* (if (numberp value) value 0) 10) 852 (- (aref key 0) ?0)) 853 factor nil) 854;; (describe-arg value sign) 855 (setq key (read-key-sequence nil t))) 856 (setq prefix-arg 857 (cond (factor (list factor)) 858 ((numberp value) (* value sign)) 859 ((= sign -1) '-))) 860 ;; Calling universal-argument after digits 861 ;; terminates the argument but is ignored. 862 (if (eq (key-binding key) 'universal-argument) 863 (progn 864 (describe-arg value sign) 865 (setq key (read-key-sequence nil t)))) 866 (setq unread-command-events (listify-key-sequence key)))) 867 868(defun describe-arg (value sign) 869 (cond ((numberp value) 870 (message "Arg: %d" (* value sign))) 871 ((consp value) 872 (message "Arg: [%d]" (car value))) 873 ((< sign 0) 874 (message "Arg: -")))) 875 876(defun digit-argument (arg) 877 "Part of the numeric argument for the next command. 878\\[universal-argument] following digits or minus sign ends the argument." 879 (interactive "P") 880 (prefix-arg-internal (char-to-string (logand last-command-char ?\177)) 881 nil arg)) 882 883(defun negative-argument (arg) 884 "Begin a negative numeric argument for the next command. 885\\[universal-argument] following digits or minus sign ends the argument." 886 (interactive "P") 887 (prefix-arg-internal "-" nil arg)) 888 889(defun forward-to-indentation (arg) 890 "Move forward ARG lines and position at first nonblank character." 891 (interactive "p") 892 (forward-line arg) 893 (skip-chars-forward " \t")) 894 895(defun backward-to-indentation (arg) 896 "Move backward ARG lines and position at first nonblank character." 897 (interactive "p") 898 (forward-line (- arg)) 899 (skip-chars-forward " \t")) 900 901(defvar kill-whole-line nil 902 "*If non-nil, `kill-line' with no arg at beg of line kills the whole line.") 903 904(defun kill-line (&optional arg) 905 "Kill the rest of the current line; if no nonblanks there, kill thru newline. 906With prefix argument, kill that many lines from point. 907Negative arguments kill lines backward. 908 909When calling from a program, nil means \"no arg\", 910a number counts as a prefix arg. 911 912If `kill-whole-line' is non-nil, then kill the whole line 913when given no argument at the beginning of a line." 914 (interactive "P") 915 (kill-region (point) 916 ;; It is better to move point to the other end of the kill 917 ;; before killing. That way, in a read-only buffer, point 918 ;; moves across the text that is copied to the kill ring. 919 ;; The choice has no effect on undo now that undo records 920 ;; the value of point from before the command was run. 921 (progn 922 (if arg 923 (forward-line (prefix-numeric-value arg)) 924 (if (eobp) 925 (signal 'end-of-buffer nil)) 926 (if (or (looking-at "[ \t]*$") (and kill-whole-line (bolp))) 927 (forward-line 1) 928 (end-of-line))) 929 (point)))) 930 931;;;; Window system cut and paste hooks. 932 933(defvar interprogram-cut-function nil 934 "Function to call to make a killed region available to other programs. 935 936Most window systems provide some sort of facility for cutting and 937pasting text between the windows of different programs. 938This variable holds a function that Emacs calls whenever text 939is put in the kill ring, to make the new kill available to other 940programs. 941 942The function takes one or two arguments. 943The first argument, TEXT, is a string containing 944the text which should be made available. 945The second, PUSH, if non-nil means this is a \"new\" kill; 946nil means appending to an \"old\" kill.") 947 948(defvar interprogram-paste-function nil 949 "Function to call to get text cut from other programs. 950 951Most window systems provide some sort of facility for cutting and 952pasting text between the windows of different programs. 953This variable holds a function that Emacs calls to obtain 954text that other programs have provided for pasting. 955 956The function should be called with no arguments. If the function 957returns nil, then no other program has provided such text, and the top 958of the Emacs kill ring should be used. If the function returns a 959string, that string should be put in the kill ring as the latest kill. 960 961Note that the function should return a string only if a program other 962than Emacs has provided a string for pasting; if Emacs provided the 963most recent string, the function should return nil. If it is 964difficult to tell whether Emacs or some other program provided the 965current string, it is probably good enough to return nil if the string 966is equal (according to `string=') to the last text Emacs provided.") 967 968 969 970;;;; The kill ring data structure. 971 972(defvar kill-ring nil 973 "List of killed text sequences. 974Since the kill ring is supposed to interact nicely with cut-and-paste 975facilities offered by window systems, use of this variable should 976interact nicely with `interprogram-cut-function' and 977`interprogram-paste-function'. The functions `kill-new', 978`kill-append', and `current-kill' are supposed to implement this 979interaction; you may want to use them instead of manipulating the kill 980ring directly.") 981 982(defconst kill-ring-max 30 983 "*Maximum length of kill ring before oldest elements are thrown away.") 984 985(defvar kill-ring-yank-pointer nil 986 "The tail of the kill ring whose car is the last thing yanked.") 987 988(defun kill-new (string) 989 "Make STRING the latest kill in the kill ring. 990Set the kill-ring-yank pointer to point to it. 991If `interprogram-cut-function' is non-nil, apply it to STRING." 992 (setq kill-ring (cons string kill-ring)) 993 (if (> (length kill-ring) kill-ring-max) 994 (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) 995 (setq kill-ring-yank-pointer kill-ring) 996 (if interprogram-cut-function 997 (funcall interprogram-cut-function string t))) 998 999(defun kill-append (string before-p) 1000 "Append STRING to the end of the latest kill in the kill ring. 1001If BEFORE-P is non-nil, prepend STRING to the kill. 1002If `interprogram-cut-function' is set, pass the resulting kill to 1003it." 1004 (setcar kill-ring 1005 (if before-p 1006 (concat string (car kill-ring)) 1007 (concat (car kill-ring) string))) 1008 (if interprogram-cut-function 1009 (funcall interprogram-cut-function (car kill-ring)))) 1010 1011(defun current-kill (n &optional do-not-move) 1012 "Rotate the yanking point by N places, and then return that kill. 1013If N is zero, `interprogram-paste-function' is set, and calling it 1014returns a string, then that string is added to the front of the 1015kill ring and returned as the latest kill. 1016If optional arg DO-NOT-MOVE is non-nil, then don't actually move the 1017yanking point; just return the Nth kill forward." 1018 (let ((interprogram-paste (and (= n 0) 1019 interprogram-paste-function 1020 (funcall interprogram-paste-function)))) 1021 (if interprogram-paste 1022 (progn 1023 ;; Disable the interprogram cut function when we add the new 1024 ;; text to the kill ring, so Emacs doesn't try to own the 1025 ;; selection, with identical text. 1026 (let ((interprogram-cut-function nil)) 1027 (kill-new interprogram-paste)) 1028 interprogram-paste) 1029 (or kill-ring (error "Kill ring is empty")) 1030 (let ((ARGth-kill-element 1031 (nthcdr (mod (- n (length kill-ring-yank-pointer)) 1032 (length kill-ring)) 1033 kill-ring))) 1034 (or do-not-move 1035 (setq kill-ring-yank-pointer ARGth-kill-element)) 1036 (car ARGth-kill-element))))) 1037 1038 1039 1040;;;; Commands for manipulating the kill ring. 1041 1042(defvar kill-read-only-ok nil 1043 "*Non-nil means don't signal an error for killing read-only text.") 1044 1045(defun kill-region (beg end) 1046 "Kill between point and mark. 1047The text is deleted but saved in the kill ring. 1048The command \\[yank] can retrieve it from there. 1049\(If you want to kill and then yank immediately, use \\[copy-region-as-kill].) 1050If the buffer is read-only, Emacs will beep and refrain from deleting 1051the text, but put the text in the kill ring anyway. This means that 1052you can use the killing commands to copy text from a read-only buffer. 1053 1054This is the primitive for programs to kill text (as opposed to deleting it). 1055Supply two arguments, character numbers indicating the stretch of text 1056 to be killed. 1057Any command that calls this function is a \"kill command\". 1058If the previous command was also a kill command, 1059the text killed this time appends to the text killed last time 1060to make one entry in the kill ring." 1061 (interactive "r") 1062 (cond 1063 1064 ;; If the buffer is read-only, we should beep, in case the person 1065 ;; just isn't aware of this. However, there's no harm in putting 1066 ;; the region's text in the kill ring, anyway. 1067 ((or (and buffer-read-only (not inhibit-read-only)) 1068 (text-property-not-all beg end 'read-only nil)) 1069 (copy-region-as-kill beg end) 1070 ;; This should always barf, and give us the correct error. 1071 (if kill-read-only-ok 1072 (message "Read only text copied to kill ring") 1073 (barf-if-buffer-read-only))) 1074 1075 ;; In certain cases, we can arrange for the undo list and the kill 1076 ;; ring to share the same string object. This code does that. 1077 ((not (or (eq buffer-undo-list t) 1078 (eq last-command 'kill-region) 1079 (equal beg end))) 1080 ;; Don't let the undo list be truncated before we can even access it. 1081 (let ((undo-strong-limit (+ (- (max beg end) (min beg end)) 100)) 1082 (old-list buffer-undo-list) 1083 tail) 1084 (delete-region beg end) 1085 ;; Search back in buffer-undo-list for this string, 1086 ;; in case a change hook made property changes. 1087 (setq tail buffer-undo-list) 1088 (while (not (stringp (car (car tail)))) 1089 (setq tail (cdr tail))) 1090 ;; Take the same string recorded for undo 1091 ;; and put it in the kill-ring. 1092 (kill-new (car (car tail))) 1093 (setq this-command 'kill-region))) 1094 1095 (t 1096 (copy-region-as-kill beg end) 1097 (delete-region beg end)))) 1098 1099(defun copy-region-as-kill (beg end) 1100 "Save the region as if killed, but don't kill it. 1101If `interprogram-cut-function' is non-nil, also save the text for a window 1102system cut and paste." 1103 (interactive "r") 1104 (if (eq last-command 'kill-region) 1105 (kill-append (buffer-substring beg end) (< end beg)) 1106 (kill-new (buffer-substring beg end))) 1107 (setq this-command 'kill-region) 1108 nil) 1109 1110(defun kill-ring-save (beg end) 1111 "Save the region as if killed, but don't kill it. 1112This command is similar to `copy-region-as-kill', except that it gives 1113visual feedback indicating the extent of the region being copied. 1114If `interprogram-cut-function' is non-nil, also save the text for a window 1115system cut and paste." 1116 (interactive "r") 1117 (copy-region-as-kill beg end) 1118 (if (interactive-p) 1119 (let ((other-end (if (= (point) beg) end beg)) 1120 (opoint (point)) 1121 ;; Inhibit quitting so we can make a quit here 1122 ;; look like a C-g typed as a command. 1123 (inhibit-quit t)) 1124 (if (pos-visible-in-window-p other-end (selected-window)) 1125 (progn 1126 ;; Swap point and mark. 1127 (set-marker (mark-marker) (point) (current-buffer)) 1128 (goto-char other-end) 1129 (sit-for 1) 1130 ;; Swap back. 1131 (set-marker (mark-marker) other-end (current-buffer)) 1132 (goto-char opoint) 1133 ;; If user quit, deactivate the mark 1134 ;; as C-g would as a command. 1135 (and quit-flag mark-active 1136 (deactivate-mark))) 1137 (let* ((killed-text (current-kill 0)) 1138 (message-len (min (length killed-text) 40))) 1139 (if (= (point) beg) 1140 ;; Don't say "killed"; that is misleading. 1141 (message "Saved text until \"%s\"" 1142 (substring killed-text (- message-len))) 1143 (message "Saved text from \"%s\"" 1144 (substring killed-text 0 message-len)))))))) 1145 1146(defun append-next-kill () 1147 "Cause following command, if it kills, to append to previous kill." 1148 (interactive) 1149 (if (interactive-p) 1150 (progn 1151 (setq this-command 'kill-region) 1152 (message "If the next command is a kill, it will append")) 1153 (setq last-command 'kill-region))) 1154 1155(defun yank-pop (arg) 1156 "Replace just-yanked stretch of killed text with a different stretch. 1157This command is allowed only immediately after a `yank' or a `yank-pop'. 1158At such a time, the region contains a stretch of reinserted 1159previously-killed text. `yank-pop' deletes that text and inserts in its 1160place a different stretch of killed text. 1161 1162With no argument, the previous kill is inserted. 1163With argument N, insert the Nth previous kill. 1164If N is negative, this is a more recent kill. 1165 1166The sequence of kills wraps around, so that after the oldest one 1167comes the newest one." 1168 (interactive "*p") 1169 (if (not (eq last-command 'yank)) 1170 (error "Previous command was not a yank")) 1171 (setq this-command 'yank) 1172 (let ((before (< (point) (mark t)))) 1173 (delete-region (point) (mark t)) 1174 (set-marker (mark-marker) (point) (current-buffer)) 1175 (insert (current-kill arg)) 1176 (if before 1177 ;; This is like exchange-point-and-mark, but doesn't activate the mark. 1178 ;; It is cleaner to avoid activation, even though the command 1179 ;; loop would deactivate the mark because we inserted text. 1180 (goto-char (prog1 (mark t) 1181 (set-marker (mark-marker) (point) (current-buffer)))))) 1182 nil) 1183 1184(defun yank (&optional arg) 1185 "Reinsert the last stretch of killed text. 1186More precisely, reinsert the stretch of killed text most recently 1187killed OR yanked. Put point at end, and set mark at beginning. 1188With just C-u as argument, same but put point at beginning (and mark at end). 1189With argument N, reinsert the Nth most recently killed stretch of killed 1190text. 1191See also the command \\[yank-pop]." 1192 (interactive "*P") 1193 ;; If we don't get all the way thru, make last-command indicate that 1194 ;; for the following command. 1195 (setq this-command t) 1196 (push-mark (point)) 1197 (insert (current-kill (cond 1198 ((listp arg) 0) 1199 ((eq arg '-) -1) 1200 (t (1- arg))))) 1201 (if (consp arg) 1202 ;; This is like exchange-point-and-mark, but doesn't activate the mark. 1203 ;; It is cleaner to avoid activation, even though the command 1204 ;; loop would deactivate the mark because we inserted text. 1205 (goto-char (prog1 (mark t) 1206 (set-marker (mark-marker) (point) (current-buffer))))) 1207 ;; If we do get all the way thru, make this-command indicate that. 1208 (setq this-command 'yank) 1209 nil) 1210 1211(defun rotate-yank-pointer (arg) 1212 "Rotate the yanking point in the kill ring. 1213With argument, rotate that many kills forward (or backward, if negative)." 1214 (interactive "p") 1215 (current-kill arg)) 1216 1217 1218(defun insert-buffer (buffer) 1219 "Insert after point the contents of BUFFER. 1220Puts mark after the inserted text. 1221BUFFER may be a buffer or a buffer name." 1222 (interactive (list (progn (barf-if-buffer-read-only) 1223 (read-buffer "Insert buffer: " (other-buffer) t)))) 1224 (or (bufferp buffer) 1225 (setq buffer (get-buffer buffer))) 1226 (let (start end newmark) 1227 (save-excursion 1228 (save-excursion 1229 (set-buffer buffer) 1230 (setq start (point-min) end (point-max))) 1231 (insert-buffer-substring buffer start end) 1232 (setq newmark (point))) 1233 (push-mark newmark)) 1234 nil) 1235 1236(defun append-to-buffer (buffer start end) 1237 "Append to specified buffer the text of the region. 1238It is inserted into that buffer before its point. 1239 1240When calling from a program, give three arguments: 1241BUFFER (or buffer name), START and END. 1242START and END specify the portion of the current buffer to be copied." 1243 (interactive 1244 (list (read-buffer "Append to buffer: " (other-buffer nil t)) 1245 (region-beginning) (region-end))) 1246 (let ((oldbuf (current-buffer))) 1247 (save-excursion 1248 (set-buffer (get-buffer-create buffer)) 1249 (insert-buffer-substring oldbuf start end)))) 1250 1251(defun prepend-to-buffer (buffer start end) 1252 "Prepend to specified buffer the text of the region. 1253It is inserted into that buffer after its point. 1254 1255When calling from a program, give three arguments: 1256BUFFER (or buffer name), START and END. 1257START and END specify the portion of the current buffer to be copied." 1258 (interactive "BPrepend to buffer: \nr") 1259 (let ((oldbuf (current-buffer))) 1260 (save-excursion 1261 (set-buffer (get-buffer-create buffer)) 1262 (save-excursion 1263 (insert-buffer-substring oldbuf start end))))) 1264 1265(defun copy-to-buffer (buffer start end) 1266 "Copy to specified buffer the text of the region. 1267It is inserted into that buffer, replacing existing text there. 1268 1269When calling from a program, give three arguments: 1270BUFFER (or buffer name), START and END. 1271START and END specify the portion of the current buffer to be copied." 1272 (interactive "BCopy to buffer: \nr") 1273 (let ((oldbuf (current-buffer))) 1274 (save-excursion 1275 (set-buffer (get-buffer-create buffer)) 1276 (erase-buffer) 1277 (save-excursion 1278 (insert-buffer-substring oldbuf start end))))) 1279 1280(defvar mark-even-if-inactive nil 1281 "*Non-nil means you can use the mark even when inactive. 1282This option makes a difference in Transient Mark mode. 1283When the option is non-nil, deactivation of the mark 1284turns off region highlighting, but commands that use the mark 1285behave as if the mark were still active.") 1286 1287(put 'mark-inactive 'error-conditions '(mark-inactive error)) 1288(put 'mark-inactive 'error-message "The mark is not active now") 1289 1290(defun mark (&optional force) 1291 "Return this buffer's mark value as integer; error if mark inactive. 1292If optional argument FORCE is non-nil, access the mark value 1293even if the mark is not currently active, and return nil 1294if there is no mark at all. 1295 1296If you are using this in an editing command, you are most likely making 1297a mistake; see the documentation of `set-mark'." 1298 (if (or force mark-active mark-even-if-inactive) 1299 (marker-position (mark-marker)) 1300 (signal 'mark-inactive nil))) 1301 1302;; Many places set mark-active directly, and several of them failed to also 1303;; run deactivate-mark-hook. This shorthand should simplify. 1304(defsubst deactivate-mark () 1305 "Deactivate the mark by setting `mark-active' to nil. 1306\(That makes a difference only in Transient Mark mode.) 1307Also runs the hook `deactivate-mark-hook'." 1308 (if transient-mark-mode 1309 (progn 1310 (setq mark-active nil) 1311 (run-hooks 'deactivate-mark-hook)))) 1312 1313(defun set-mark (pos) 1314 "Set this buffer's mark to POS. Don't use this function! 1315That is to say, don't use this function unless you want 1316the user to see that the mark has moved, and you want the previous 1317mark position to be lost. 1318 1319Normally, when a new mark is set, the old one should go on the stack. 1320This is why most applications should use push-mark, not set-mark. 1321 1322Novice Emacs Lisp programmers often try to use the mark for the wrong 1323purposes. The mark saves a location for the user's convenience. 1324Most editing commands should not alter the mark. 1325To remember a location for internal use in the Lisp program, 1326store it in a Lisp variable. Example: 1327 1328 (let ((beg (point))) (forward-line 1) (delete-region beg (point)))." 1329 1330 (if pos 1331 (progn 1332 (setq mark-active t) 1333 (run-hooks 'activate-mark-hook) 1334 (set-marker (mark-marker) pos (current-buffer))) 1335 (deactivate-mark) 1336 (set-marker (mark-marker) pos (current-buffer)))) 1337 1338(defvar mark-ring nil 1339 "The list of saved former marks of the current buffer, 1340most recent first.") 1341(make-variable-buffer-local 'mark-ring) 1342 1343(defconst mark-ring-max 16 1344 "*Maximum size of mark ring. Start discarding off end if gets this big.") 1345 1346(defvar global-mark-ring nil 1347 "The list of saved global marks, most recent first.") 1348 1349(defconst global-mark-ring-max 16 1350 "*Maximum size of global mark ring. \ 1351Start discarding off end if gets this big.") 1352 1353(defun set-mark-command (arg) 1354 "Set mark at where point is, or jump to mark. 1355With no prefix argument, set mark, push old mark position on local mark 1356ring, and push mark on global mark ring. 1357With argument, jump to mark, and pop a new position for mark off the ring 1358\(does not affect global mark ring\). 1359 1360Novice Emacs Lisp programmers often try to use the mark for the wrong 1361purposes. See the documentation of `set-mark' for more information." 1362 (interactive "P") 1363 (if (null arg) 1364 (progn 1365 (push-mark nil nil t)) 1366 (if (null (mark t)) 1367 (error "No mark set in this buffer") 1368 (goto-char (mark t)) 1369 (pop-mark)))) 1370 1371(defun push-mark (&optional location nomsg activate) 1372 "Set mark at LOCATION (point, by default) and push old mark on mark ring. 1373If the last global mark pushed was not in the current buffer, 1374also push LOCATION on the global mark ring. 1375Display `Mark set' unless the optional second arg NOMSG is non-nil. 1376In Transient Mark mode, activate mark if optional third arg ACTIVATE non-nil. 1377 1378Novice Emacs Lisp programmers often try to use the mark for the wrong 1379purposes. See the documentation of `set-mark' for more information. 1380 1381In Transient Mark mode, this does not activate the mark." 1382 (if (null (mark t)) 1383 nil 1384 (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring)) 1385 (if (> (length mark-ring) mark-ring-max) 1386 (progn 1387 (move-marker (car (nthcdr mark-ring-max mark-ring)) nil) 1388 (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))) 1389 (set-marker (mark-marker) (or location (point)) (current-buffer)) 1390 ;; Now push the mark on the global mark ring. 1391 (if (and global-mark-ring 1392 (eq (marker-buffer (car global-mark-ring)) (current-buffer))) 1393 ;; The last global mark pushed was in this same buffer. 1394 ;; Don't push another one. 1395 nil 1396 (setq global-mark-ring (cons (copy-marker (mark-marker)) global-mark-ring)) 1397 (if (> (length global-mark-ring) global-mark-ring-max) 1398 (progn 1399 (move-marker (car (nthcdr global-mark-ring-max global-mark-ring)) 1400 nil) 1401 (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))) 1402 (or nomsg executing-macro (> (minibuffer-depth) 0) 1403 (message "Mark set")) 1404 (if (or activate (not transient-mark-mode)) 1405 (set-mark (mark t))) 1406 nil) 1407 1408(defun pop-mark () 1409 "Pop off mark ring into the buffer's actual mark. 1410Does not set point. Does nothing if mark ring is empty." 1411 (if mark-ring 1412 (progn 1413 (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker))))) 1414 (set-marker (mark-marker) (+ 0 (car mark-ring)) (current-buffer)) 1415 (deactivate-mark) 1416 (move-marker (car mark-ring) nil) 1417 (if (null (mark t)) (ding)) 1418 (setq mark-ring (cdr mark-ring))))) 1419 1420(define-function 'exchange-dot-and-mark 'exchange-point-and-mark) 1421(defun exchange-point-and-mark () 1422 "Put the mark where point is now, and point where the mark is now. 1423This command works even when the mark is not active, 1424and it reactivates the mark." 1425 (interactive nil) 1426 (let ((omark (mark t))) 1427 (if (null omark) 1428 (error "No mark set in this buffer")) 1429 (set-mark (point)) 1430 (goto-char omark) 1431 nil)) 1432 1433(defun transient-mark-mode (arg) 1434 "Toggle Transient Mark mode. 1435With arg, turn Transient Mark mode on if arg is positive, off otherwise. 1436 1437In Transient Mark mode, when the mark is active, the region is highlighted. 1438Changing the buffer \"deactivates\" the mark. 1439So do certain other operations that set the mark 1440but whose main purpose is something else--for example, 1441incremental search, \\[beginning-of-buffer], and \\[end-of-buffer]." 1442 (interactive "P") 1443 (setq transient-mark-mode 1444 (if (null arg) 1445 (not transient-mark-mode) 1446 (> (prefix-numeric-value arg) 0)))) 1447 1448(defun pop-global-mark () 1449 "Pop off global mark ring and jump to the top location." 1450 (interactive) 1451 (or global-mark-ring 1452 (error "No global mark set")) 1453 (let* ((marker (car global-mark-ring)) 1454 (buffer (marker-buffer marker)) 1455 (position (marker-position marker))) 1456 (setq global-mark-ring (cdr global-mark-ring)) 1457 (set-buffer buffer) 1458 (or (and (>= position (point-min)) 1459 (<= position (point-max))) 1460 (widen)) 1461 (goto-char position) 1462 (switch-to-buffer buffer))) 1463 1464(defvar next-line-add-newlines t 1465 "*If non-nil, `next-line' inserts newline to avoid `end of buffer' error.") 1466 1467(defun next-line (arg) 1468 "Move cursor vertically down ARG lines. 1469If there is no character in the target line exactly under the current column, 1470the cursor is positioned after the character in that line which spans this 1471column, or at the end of the line if it is not long enough. 1472If there is no line in the buffer after this one, behavior depends on the 1473value of next-line-add-newlines. If non-nil, a newline character is inserted 1474to create a line and the cursor moves to that line, otherwise the cursor is 1475moved to the end of the buffer (if already at the end of the buffer, an error 1476is signaled). 1477 1478The command \\[set-goal-column] can be used to create 1479a semipermanent goal column to which this command always moves. 1480Then it does not try to move vertically. This goal column is stored 1481in `goal-column', which is nil when there is none. 1482 1483If you are thinking of using this in a Lisp program, consider 1484using `forward-line' instead. It is usually easier to use 1485and more reliable (no dependence on goal column, etc.)." 1486 (interactive "p") 1487 (if (and next-line-add-newlines (= arg 1)) 1488 (let ((opoint (point))) 1489 (forward-line 1) 1490 (if (or (= opoint (point)) (not (eq (preceding-char) ?\n))) 1491 (insert ?\n) 1492 (goto-char opoint) 1493 (line-move arg))) 1494 (line-move arg)) 1495 nil) 1496 1497(defun previous-line (arg) 1498 "Move cursor vertically up ARG lines. 1499If there is no character in the target line exactly over the current column, 1500the cursor is positioned after the character in that line which spans this 1501column, or at the end of the line if it is not long enough. 1502 1503The command \\[set-goal-column] can be used to create 1504a semipermanent goal column to which this command always moves. 1505Then it does not try to move vertically. 1506 1507If you are thinking of using this in a Lisp program, consider using 1508`forward-line' with a negative argument instead. It is usually easier 1509to use and more reliable (no dependence on goal column, etc.)." 1510 (interactive "p") 1511 (line-move (- arg)) 1512 nil) 1513 1514(defconst track-eol nil 1515 "*Non-nil means vertical motion starting at end of line keeps to ends of lines. 1516This means moving to the end of each line moved onto. 1517The beginning of a blank line does not count as the end of a line.") 1518 1519(defvar goal-column nil 1520 "*Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil.") 1521(make-variable-buffer-local 'goal-column) 1522 1523(defvar temporary-goal-column 0 1524 "Current goal column for vertical motion. 1525It is the column where point was 1526at the start of current run of vertical motion commands. 1527When the `track-eol' feature is doing its job, the value is 9999.") 1528 1529(defun line-move (arg) 1530 (let ((signal 1531 (catch 'exit 1532 (if (not (or (eq last-command 'next-line) 1533 (eq last-command 'previous-line))) 1534 (setq temporary-goal-column 1535 (if (and track-eol (eolp) 1536 ;; Don't count beg of empty line as end of line 1537 ;; unless we just did explicit end-of-line. 1538 (or (not (bolp)) (eq last-command 'end-of-line))) 1539 9999 1540 (current-column)))) 1541 (if (not (integerp selective-display)) 1542 (or (and (zerop (forward-line arg)) 1543 (bolp)) 1544 (throw 'exit (if (bobp) 1545 'beginning-of-buffer 1546 'end-of-buffer))) 1547 ;; Move by arg lines, but ignore invisible ones. 1548 (while (> arg 0) 1549 (end-of-line) 1550 (and (zerop (vertical-motion 1)) 1551 (throw 'exit 'end-of-buffer)) 1552 (setq arg (1- arg))) 1553 (while (< arg 0) 1554 (beginning-of-line) 1555 (and (zerop (vertical-motion -1)) 1556 (throw 'exit 'beginning-of-buffer)) 1557 (setq arg (1+ arg)))) 1558 (move-to-column (or goal-column temporary-goal-column)) 1559 nil))) 1560 (cond 1561 ((eq signal 'beginning-of-buffer) 1562 (message "Beginning of buffer") 1563 (ding)) 1564 ((eq signal 'end-of-buffer) 1565 (message "End of buffer") 1566 (ding))))) 1567 1568;;; Many people have said they rarely use this feature, and often type 1569;;; it by accident. Maybe it shouldn't even be on a key. 1570(put 'set-goal-column 'disabled t) 1571 1572(defun set-goal-column (arg) 1573 "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line]. 1574Those commands will move to this position in the line moved to 1575rather than trying to keep the same horizontal position. 1576With a non-nil argument, clears out the goal column 1577so that \\[next-line] and \\[previous-line] resume vertical motion. 1578The goal column is stored in the variable `goal-column'." 1579 (interactive "P") 1580 (if arg 1581 (progn 1582 (setq goal-column nil) 1583 (message "No goal column")) 1584 (setq goal-column (current-column)) 1585 (message (substitute-command-keys 1586 "Goal column %d (use \\[set-goal-column] with an arg to unset it)") 1587 goal-column)) 1588 nil) 1589 1590;;; Partial support for horizontal autoscrolling. Someday, this feature 1591;;; will be built into the C level and all the (hscroll-point-visible) calls 1592;;; will go away. 1593 1594(defvar hscroll-step 0 1595 "*The number of columns to try scrolling a window by when point moves out. 1596If that fails to bring point back on frame, point is centered instead. 1597If this is zero, point is always centered after it moves off frame.") 1598 1599(defun hscroll-point-visible () 1600 "Scrolls the selected window horizontally to make point visible." 1601 (save-excursion 1602 (set-buffer (window-buffer)) 1603 (if (not (or truncate-lines 1604 (> (window-hscroll) 0) 1605 (and truncate-partial-width-windows 1606 (< (window-width) (frame-width))))) 1607 ;; Point is always visible when lines are wrapped. 1608 () 1609 ;; If point is on the invisible part of the line before window-start, 1610 ;; then hscrolling can't bring it back, so reset window-start first. 1611 (and (< (point) (window-start)) 1612 (let ((ws-bol (save-excursion 1613 (goto-char (window-start)) 1614 (beginning-of-line) 1615 (point)))) 1616 (and (>= (point) ws-bol) 1617 (set-window-start nil ws-bol)))) 1618 (let* ((here (hscroll-window-column)) 1619 (left (min (window-hscroll) 1)) 1620 (right (1- (window-width)))) 1621 ;; Allow for the truncation glyph, if we're not exactly at eol. 1622 (if (not (and (= here right) 1623 (= (following-char) ?\n))) 1624 (setq right (1- right))) 1625 (cond 1626 ;; If too far away, just recenter. But don't show too much 1627 ;; white space off the end of the line. 1628 ((or (< here (- left hscroll-step)) 1629 (> here (+ right hscroll-step))) 1630 (let ((eol (save-excursion (end-of-line) (hscroll-window-column)))) 1631 (scroll-left (min (- here (/ (window-width) 2)) 1632 (- eol (window-width) -5))))) 1633 ;; Within range. Scroll by one step (or maybe not at all). 1634 ((< here left) 1635 (scroll-right hscroll-step)) 1636 ((> here right) 1637 (scroll-left hscroll-step))))))) 1638 1639;; This function returns the window's idea of the display column of point, 1640;; assuming that the window is already known to be truncated rather than 1641;; wrapped, and that we've already handled the case where point is on the 1642;; part of the line before window-start. We ignore window-width; if point 1643;; is beyond the right margin, we want to know how far. The return value 1644;; includes the effects of window-hscroll, window-start, and the prompt 1645;; string in the minibuffer. It may be negative due to hscroll. 1646(defun hscroll-window-column () 1647 (let* ((hscroll (window-hscroll)) 1648 (startpos (save-excursion 1649 (beginning-of-line) 1650 (if (= (point) (save-excursion 1651 (goto-char (window-start)) 1652 (beginning-of-line) 1653 (point))) 1654 (goto-char (window-start))) 1655 (point))) 1656 (hpos (+ (if (and (eq (selected-window) (minibuffer-window)) 1657 (= 1 (window-start)) 1658 (= startpos (point-min))) 1659 (minibuffer-prompt-width) 1660 0) 1661 (min 0 (- 1 hscroll)))) 1662 val) 1663 (car (cdr (compute-motion startpos (cons hpos 0) 1664 (point) (cons 0 1) 1665 1000000 (cons hscroll 0) nil))))) 1666 1667 1668;; rms: (1) The definitions of arrow keys should not simply restate 1669;; what keys they are. The arrow keys should run the ordinary commands. 1670;; (2) The arrow keys are just one of many common ways of moving point 1671;; within a line. Real horizontal autoscrolling would be a good feature, 1672;; but supporting it only for arrow keys is too incomplete to be desirable. 1673 1674;;;;; Make arrow keys do the right thing for improved terminal support 1675;;;;; When we implement true horizontal autoscrolling, right-arrow and 1676;;;;; left-arrow can lose the (if truncate-lines ...) clause and become 1677;;;;; aliases. These functions are bound to the corresponding keyboard 1678;;;;; events in loaddefs.el. 1679 1680;;(defun right-arrow (arg) 1681;; "Move right one character on the screen (with prefix ARG, that many chars). 1682;;Scroll right if needed to keep point horizontally onscreen." 1683;; (interactive "P") 1684;; (forward-char arg) 1685;; (hscroll-point-visible)) 1686 1687;;(defun left-arrow (arg) 1688;; "Move left one character on the screen (with prefix ARG, that many chars). 1689;;Scroll left if needed to keep point horizontally onscreen." 1690;; (interactive "P") 1691;; (backward-char arg) 1692;; (hscroll-point-visible)) 1693 1694(defun transpose-chars (arg) 1695 "Interchange characters around point, moving forward one character. 1696With prefix arg ARG, effect is to take character before point 1697and drag it forward past ARG other characters (backward if ARG negative). 1698If no argument and at end of line, the previous two chars are exchanged." 1699 (interactive "*P") 1700 (and (null arg) (eolp) (forward-char -1)) 1701 (transpose-subr 'forward-char (prefix-numeric-value arg))) 1702 1703(defun transpose-words (arg) 1704 "Interchange words around point, leaving point at end of them. 1705With prefix arg ARG, effect is to take word before or around point 1706and drag it forward past ARG other words (backward if ARG negative). 1707If ARG is zero, the words around or after point and around or after mark 1708are interchanged." 1709 (interactive "*p") 1710 (transpose-subr 'forward-word arg)) 1711 1712(defun transpose-sexps (arg) 1713 "Like \\[transpose-words] but applies to sexps. 1714Does not work on a sexp that point is in the middle of 1715if it is a list or string." 1716 (interactive "*p") 1717 (transpose-subr 'forward-sexp arg)) 1718 1719(defun transpose-lines (arg) 1720 "Exchange current line and previous line, leaving point after both. 1721With argument ARG, takes previous line and moves it past ARG lines. 1722With argument 0, interchanges line point is in with line mark is in." 1723 (interactive "*p") 1724 (transpose-subr (function 1725 (lambda (arg) 1726 (if (= arg 1) 1727 (progn 1728 ;; Move forward over a line, 1729 ;; but create a newline if none exists yet. 1730 (end-of-line) 1731 (if (eobp) 1732 (newline) 1733 (forward-char 1))) 1734 (forward-line arg)))) 1735 arg)) 1736 1737(defun transpose-subr (mover arg) 1738 (let (start1 end1 start2 end2) 1739 (if (= arg 0) 1740 (progn 1741 (save-excursion 1742 (funcall mover 1) 1743 (setq end2 (point)) 1744 (funcall mover -1) 1745 (setq start2 (point)) 1746 (goto-char (mark)) 1747 (funcall mover 1) 1748 (setq end1 (point)) 1749 (funcall mover -1) 1750 (setq start1 (point)) 1751 (transpose-subr-1)) 1752 (exchange-point-and-mark))) 1753 (while (> arg 0) 1754 (funcall mover -1) 1755 (setq start1 (point)) 1756 (funcall mover 1) 1757 (setq end1 (point)) 1758 (funcall mover 1) 1759 (setq end2 (point)) 1760 (funcall mover -1) 1761 (setq start2 (point)) 1762 (transpose-subr-1) 1763 (goto-char end2) 1764 (setq arg (1- arg))) 1765 (while (< arg 0) 1766 (funcall mover -1) 1767 (setq start2 (point)) 1768 (funcall mover -1) 1769 (setq start1 (point)) 1770 (funcall mover 1) 1771 (setq end1 (point)) 1772 (funcall mover 1) 1773 (setq end2 (point)) 1774 (transpose-subr-1) 1775 (setq arg (1+ arg))))) 1776 1777(defun transpose-subr-1 () 1778 (if (> (min end1 end2) (max start1 start2)) 1779 (error "Don't have two things to transpose")) 1780 (let ((word1 (buffer-substring start1 end1)) 1781 (word2 (buffer-substring start2 end2))) 1782 (delete-region start2 end2) 1783 (goto-char start2) 1784 (insert word1) 1785 (goto-char (if (< start1 start2) start1 1786 (+ start1 (- (length word1) (length word2))))) 1787 (delete-char (length word1)) 1788 (insert word2))) 1789 1790(defconst comment-column 32 1791 "*Column to indent right-margin comments to. 1792Setting this variable automatically makes it local to the current buffer. 1793Each mode establishes a different default value for this variable; you 1794can set the value for a particular mode using that mode's hook.") 1795(make-variable-buffer-local 'comment-column) 1796 1797(defconst comment-start nil 1798 "*String to insert to start a new comment, or nil if no comment syntax defined.") 1799 1800(defconst comment-start-skip nil 1801 "*Regexp to match the start of a comment plus everything up to its body. 1802If there are any \\(...\\) pairs, the comment delimiter text is held to begin 1803at the place matched by the close of the first pair.") 1804 1805(defconst comment-end "" 1806 "*String to insert to end a new comment. 1807Should be an empty string if comments are terminated by end-of-line.") 1808 1809(defconst comment-indent-hook nil 1810 "Obsolete variable for function to compute desired indentation for a comment. 1811This function is called with no args with point at the beginning of 1812the comment's starting delimiter.") 1813 1814(defconst comment-indent-function 1815 '(lambda () comment-column) 1816 "Function to compute desired indentation for a comment. 1817This function is called with no args with point at the beginning of 1818the comment's starting delimiter.") 1819 1820(defun indent-for-comment () 1821 "Indent this line's comment to comment column, or insert an empty comment." 1822 (interactive "*") 1823 (beginning-of-line 1) 1824 (if (null comment-start) 1825 (error "No comment syntax defined") 1826 (let* ((eolpos (save-excursion (end-of-line) (point))) 1827 cpos indent begpos) 1828 (if (re-search-forward comment-start-skip eolpos 'move) 1829 (progn (setq cpos (point-marker)) 1830 ;; Find the start of the comment delimiter. 1831 ;; If there were paren-pairs in comment-start-skip, 1832 ;; position at the end of the first pair. 1833 (if (match-end 1) 1834 (goto-char (match-end 1)) 1835 ;; If comment-start-skip matched a string with 1836 ;; internal whitespace (not final whitespace) then 1837 ;; the delimiter start at the end of that 1838 ;; whitespace. Otherwise, it starts at the 1839 ;; beginning of what was matched. 1840 (skip-syntax-backward " " (match-beginning 0)) 1841 (skip-syntax-backward "^ " (match-beginning 0))))) 1842 (setq begpos (point)) 1843 ;; Compute desired indent. 1844 (if (= (current-column) 1845 (setq indent (if comment-indent-hook 1846 (funcall comment-indent-hook) 1847 (funcall comment-indent-function)))) 1848 (goto-char begpos) 1849 ;; If that's different from current, change it. 1850 (skip-chars-backward " \t") 1851 (delete-region (point) begpos) 1852 (indent-to indent)) 1853 ;; An existing comment? 1854 (if cpos 1855 (progn (goto-char cpos) 1856 (set-marker cpos nil)) 1857 ;; No, insert one. 1858 (insert comment-start) 1859 (save-excursion 1860 (insert comment-end)))))) 1861 1862(defun set-comment-column (arg) 1863 "Set the comment column based on point. 1864With no arg, set the comment column to the current column. 1865With just minus as arg, kill any comment on this line. 1866With any other arg, set comment column to indentation of the previous comment 1867 and then align or create a comment on this line at that column." 1868 (interactive "P") 1869 (if (eq arg '-) 1870 (kill-comment nil) 1871 (if arg 1872 (progn 1873 (save-excursion 1874 (beginning-of-line) 1875 (re-search-backward comment-start-skip) 1876 (beginning-of-line) 1877 (re-search-forward comment-start-skip) 1878 (goto-char (match-beginning 0)) 1879 (setq comment-column (current-column)) 1880 (message "Comment column set to %d" comment-column)) 1881 (indent-for-comment)) 1882 (setq comment-column (current-column)) 1883 (message "Comment column set to %d" comment-column)))) 1884 1885(defun kill-comment (arg) 1886 "Kill the comment on this line, if any. 1887With argument, kill comments on that many lines starting with this one." 1888 ;; this function loses in a lot of situations. it incorrectly recognises 1889 ;; comment delimiters sometimes (ergo, inside a string), doesn't work 1890 ;; with multi-line comments, can kill extra whitespace if comment wasn't 1891 ;; through end-of-line, et cetera. 1892 (interactive "P") 1893 (or comment-start-skip (error "No comment syntax defined")) 1894 (let ((count (prefix-numeric-value arg)) endc) 1895 (while (> count 0) 1896 (save-excursion 1897 (end-of-line) 1898 (setq endc (point)) 1899 (beginning-of-line) 1900 (and (string< "" comment-end) 1901 (setq endc 1902 (progn 1903 (re-search-forward (regexp-quote comment-end) endc 'move) 1904 (skip-chars-forward " \t") 1905 (point)))) 1906 (beginning-of-line) 1907 (if (re-search-forward comment-start-skip endc t) 1908 (progn 1909 (goto-char (match-beginning 0)) 1910 (skip-chars-backward " \t") 1911 (kill-region (point) endc) 1912 ;; to catch comments a line beginnings 1913 (indent-according-to-mode)))) 1914 (if arg (forward-line 1)) 1915 (setq count (1- count))))) 1916 1917(defun comment-region (beg end &optional arg) 1918 "Comment or uncomment each line in the region. 1919With just C-u prefix arg, uncomment each line in region. 1920Numeric prefix arg ARG means use ARG comment characters. 1921If ARG is negative, delete that many comment characters instead. 1922Comments are terminated on each line, even for syntax in which newline does 1923not end the comment. Blank lines do not get comments." 1924 ;; if someone wants it to only put a comment-start at the beginning and 1925 ;; comment-end at the end then typing it, C-x C-x, closing it, C-x C-x 1926 ;; is easy enough. No option is made here for other than commenting 1927 ;; every line. 1928 (interactive "r\nP") 1929 (or comment-start (error "No comment syntax is defined")) 1930 (if (> beg end) (let (mid) (setq mid beg beg end end mid))) 1931 (save-excursion 1932 (save-restriction 1933 (let ((cs comment-start) (ce comment-end) 1934 numarg) 1935 (if (consp arg) (setq numarg t) 1936 (setq numarg (prefix-numeric-value arg)) 1937 ;; For positive arg > 1, replicate the comment delims now, 1938 ;; then insert the replicated strings just once. 1939 (while (> numarg 1) 1940 (setq cs (concat cs comment-start) 1941 ce (concat ce comment-end)) 1942 (setq numarg (1- numarg)))) 1943 ;; Loop over all lines from BEG to END. 1944 (narrow-to-region beg end) 1945 (goto-char beg) 1946 (while (not (eobp)) 1947 (if (or (eq numarg t) (< numarg 0)) 1948 (progn 1949 ;; Delete comment start from beginning of line. 1950 (if (eq numarg t) 1951 (while (looking-at (regexp-quote cs)) 1952 (delete-char (length cs))) 1953 (let ((count numarg)) 1954 (while (and (> 1 (setq count (1+ count))) 1955 (looking-at (regexp-quote cs))) 1956 (delete-char (length cs))))) 1957 ;; Delete comment end from end of line. 1958 (if (string= "" ce) 1959 nil 1960 (if (eq numarg t) 1961 (progn 1962 (end-of-line) 1963 ;; This is questionable if comment-end ends in 1964 ;; whitespace. That is pretty brain-damaged, 1965 ;; though. 1966 (skip-chars-backward " \t") 1967 (if (and (>= (- (point) (point-min)) (length ce)) 1968 (save-excursion 1969 (backward-char (length ce)) 1970 (looking-at (regexp-quote ce)))) 1971 (delete-char (- (length ce))))) 1972 (let ((count numarg)) 1973 (while (> 1 (setq count (1+ count))) 1974 (end-of-line) 1975 ;; this is questionable if comment-end ends in whitespace 1976 ;; that is pretty brain-damaged though 1977 (skip-chars-backward " \t") 1978 (save-excursion 1979 (backward-char (length ce)) 1980 (if (looking-at (regexp-quote ce)) 1981 (delete-char (length ce)))))))) 1982 (forward-line 1)) 1983 ;; Insert at beginning and at end. 1984 (if (looking-at "[ \t]*$") () 1985 (insert cs) 1986 (if (string= "" ce) () 1987 (end-of-line) 1988 (insert ce))) 1989 (search-forward "\n" nil 'move))))))) 1990 1991(defun backward-word (arg) 1992 "Move backward until encountering the end of a word. 1993With argument, do this that many times. 1994In programs, it is faster to call `forward-word' with negative arg." 1995 (interactive "p") 1996 (forward-word (- arg))) 1997 1998(defun mark-word (arg) 1999 "Set mark arg words away from point." 2000 (interactive "p") 2001 (push-mark 2002 (save-excursion 2003 (forward-word arg) 2004 (point)) 2005 nil t)) 2006 2007(defun kill-word (arg) 2008 "Kill characters forward until encountering the end of a word. 2009With argument, do this that many times." 2010 (interactive "p") 2011 (kill-region (point) (progn (forward-word arg) (point)))) 2012 2013(defun backward-kill-word (arg) 2014 "Kill characters backward until encountering the end of a word. 2015With argument, do this that many times." 2016 (interactive "p") 2017 (kill-word (- arg))) 2018 2019(defun current-word (&optional strict) 2020 "Return the word point is on (or a nearby word) as a string. 2021If optional arg STRICT is non-nil, return nil unless point is within 2022or adjacent to a word." 2023 (save-excursion 2024 (let ((oldpoint (point)) (start (point)) (end (point))) 2025 (skip-syntax-backward "w_") (setq start (point)) 2026 (goto-char oldpoint) 2027 (skip-syntax-forward "w_") (setq end (point)) 2028 (if (and (eq start oldpoint) (eq end oldpoint)) 2029 ;; Point is neither within nor adjacent to a word. 2030 (and (not strict) 2031 (progn 2032 ;; Look for preceding word in same line. 2033 (skip-syntax-backward "^w_" 2034 (save-excursion (beginning-of-line) 2035 (point))) 2036 (if (bolp) 2037 ;; No preceding word in same line. 2038 ;; Look for following word in same line. 2039 (progn 2040 (skip-syntax-forward "^w_" 2041 (save-excursion (end-of-line) 2042 (point))) 2043 (setq start (point)) 2044 (skip-syntax-forward "w_") 2045 (setq end (point))) 2046 (setq end (point)) 2047 (skip-syntax-backward "w_") 2048 (setq start (point))) 2049 (buffer-substring start end))) 2050 (buffer-substring start end))))) 2051 2052(defconst fill-prefix nil 2053 "*String for filling to insert at front of new line, or nil for none. 2054Setting this variable automatically makes it local to the current buffer.") 2055(make-variable-buffer-local 'fill-prefix) 2056 2057(defconst auto-fill-inhibit-regexp nil 2058 "*Regexp to match lines which should not be auto-filled.") 2059 2060(defun do-auto-fill () 2061 (let (give-up) 2062 (or (and auto-fill-inhibit-regexp 2063 (save-excursion (beginning-of-line) 2064 (looking-at auto-fill-inhibit-regexp))) 2065 (while (and (not give-up) (> (current-column) fill-column)) 2066 ;; Determine where to split the line. 2067 (let ((fill-point 2068 (let ((opoint (point)) 2069 bounce 2070 (first t)) 2071 (save-excursion 2072 (move-to-column (1+ fill-column)) 2073 ;; Move back to a word boundary. 2074 (while (or first 2075 ;; If this is after period and a single space, 2076 ;; move back once more--we don't want to break 2077 ;; the line there and make it look like a 2078 ;; sentence end. 2079 (and (not (bobp)) 2080 (not bounce) 2081 sentence-end-double-space 2082 (save-excursion (forward-char -1) 2083 (and (looking-at "\\. ") 2084 (not (looking-at "\\. ")))))) 2085 (setq first nil) 2086 (skip-chars-backward "^ \t\n") 2087 ;; If we find nowhere on the line to break it, 2088 ;; break after one word. Set bounce to t 2089 ;; so we will not keep going in this while loop. 2090 (if (bolp) 2091 (progn 2092 (re-search-forward "[ \t]" opoint t) 2093 (setq bounce t))) 2094 (skip-chars-backward " \t")) 2095 ;; Let fill-point be set to the place where we end up. 2096 (point))))) 2097 ;; If that place is not the beginning of the line, 2098 ;; break the line there. 2099 (if (save-excursion 2100 (goto-char fill-point) 2101 (not (bolp))) 2102 (let ((prev-column (current-column))) 2103 ;; If point is at the fill-point, do not `save-excursion'. 2104 ;; Otherwise, if a comment prefix or fill-prefix is inserted, 2105 ;; point will end up before it rather than after it. 2106 (if (save-excursion 2107 (skip-chars-backward " \t") 2108 (= (point) fill-point)) 2109 (indent-new-comment-line) 2110 (save-excursion 2111 (goto-char fill-point) 2112 (indent-new-comment-line))) 2113 ;; If making the new line didn't reduce the hpos of 2114 ;; the end of the line, then give up now; 2115 ;; trying again will not help. 2116 (if (>= (current-column) prev-column) 2117 (setq give-up t))) 2118 ;; No place to break => stop trying. 2119 (setq give-up t))))))) 2120 2121(defun auto-fill-mode (&optional arg) 2122 "Toggle auto-fill mode. 2123With arg, turn Auto-Fill mode on if and only if arg is positive. 2124In Auto-Fill mode, inserting a space at a column beyond `fill-column' 2125automatically breaks the line at a previous space." 2126 (interactive "P") 2127 (prog1 (setq auto-fill-function 2128 (if (if (null arg) 2129 (not auto-fill-function) 2130 (> (prefix-numeric-value arg) 0)) 2131 'do-auto-fill 2132 nil)) 2133 ;; update mode-line 2134 (set-buffer-modified-p (buffer-modified-p)))) 2135 2136;; This holds a document string used to document auto-fill-mode. 2137(defun auto-fill-function () 2138 "Automatically break line at a previous space, in insertion of text." 2139 nil) 2140 2141(defun turn-on-auto-fill () 2142 "Unconditionally turn on Auto Fill mode." 2143 (auto-fill-mode 1)) 2144 2145(defun set-fill-column (arg) 2146 "Set `fill-column' to current column, or to argument if given. 2147The variable `fill-column' has a separate value for each buffer." 2148 (interactive "P") 2149 (setq fill-column (if (integerp arg) arg (current-column))) 2150 (message "fill-column set to %d" fill-column)) 2151 2152(defconst comment-multi-line nil 2153 "*Non-nil means \\[indent-new-comment-line] should continue same comment 2154on new line, with no new terminator or starter. 2155This is obsolete because you might as well use \\[newline-and-indent].") 2156 2157(defun indent-new-comment-line () 2158 "Break line at point and indent, continuing comment if within one. 2159This indents the body of the continued comment 2160under the previous comment line. 2161 2162This command is intended for styles where you write a comment per line, 2163starting a new comment (and terminating it if necessary) on each line. 2164If you want to continue one comment across several lines, use \\[newline-and-indent]." 2165 (interactive "*") 2166 (let (comcol comstart) 2167 (skip-chars-backward " \t") 2168 (delete-region (point) 2169 (progn (skip-chars-forward " \t") 2170 (point))) 2171 (insert ?\n) 2172 (if (not comment-multi-line) 2173 (save-excursion 2174 (if (and comment-start-skip 2175 (let ((opoint (point))) 2176 (forward-line -1) 2177 (re-search-forward comment-start-skip opoint t))) 2178 ;; The old line is a comment. 2179 ;; Set WIN to the pos of the comment-start. 2180 ;; But if the comment is empty, look at preceding lines 2181 ;; to find one that has a nonempty comment. 2182 (let ((win (match-beginning 0))) 2183 (while (and (eolp) (not (bobp)) 2184 (let (opoint) 2185 (beginning-of-line) 2186 (setq opoint (point)) 2187 (forward-line -1) 2188 (re-search-forward comment-start-skip opoint t))) 2189 (setq win (match-beginning 0))) 2190 ;; Indent this line like what we found. 2191 (goto-char win) 2192 (setq comcol (current-column)) 2193 (setq comstart (buffer-substring (point) (match-end 0))))))) 2194 (if comcol 2195 (let ((comment-column comcol) 2196 (comment-start comstart) 2197 (comment-end comment-end)) 2198 (and comment-end (not (equal comment-end "")) 2199; (if (not comment-multi-line) 2200 (progn 2201 (forward-char -1) 2202 (insert comment-end) 2203 (forward-char 1)) 2204; (setq comment-column (+ comment-column (length comment-start)) 2205; comment-start "") 2206; ) 2207 ) 2208 (if (not (eolp)) 2209 (setq comment-end "")) 2210 (insert ?\n) 2211 (forward-char -1) 2212 (indent-for-comment) 2213 (save-excursion 2214 ;; Make sure we delete the newline inserted above. 2215 (end-of-line) 2216 (delete-char 1))) 2217 (if fill-prefix 2218 (insert fill-prefix) 2219 (indent-according-to-mode))))) 2220 2221(defun set-selective-display (arg) 2222 "Set `selective-display' to ARG; clear it if no arg. 2223When the value of `selective-display' is a number > 0, 2224lines whose indentation is >= that value are not displayed. 2225The variable `selective-display' has a separate value for each buffer." 2226 (interactive "P") 2227 (if (eq selective-display t) 2228 (error "selective-display already in use for marked lines")) 2229 (let ((current-vpos 2230 (save-restriction 2231 (narrow-to-region (point-min) (point)) 2232 (goto-char (window-start)) 2233 (vertical-motion (window-height))))) 2234 (setq selective-display 2235 (and arg (prefix-numeric-value arg))) 2236 (recenter current-vpos)) 2237 (set-window-start (selected-window) (window-start (selected-window))) 2238 (princ "selective-display set to " t) 2239 (prin1 selective-display t) 2240 (princ "." t)) 2241 2242(defconst overwrite-mode-textual " Ovwrt" 2243 "The string displayed in the mode line when in overwrite mode.") 2244(defconst overwrite-mode-binary " Bin Ovwrt" 2245 "The string displayed in the mode line when in binary overwrite mode.") 2246 2247(defun overwrite-mode (arg) 2248 "Toggle overwrite mode. 2249With arg, turn overwrite mode on iff arg is positive. 2250In overwrite mode, printing characters typed in replace existing text 2251on a one-for-one basis, rather than pushing it to the right. At the 2252end of a line, such characters extend the line. Before a tab, 2253such characters insert until the tab is filled in. 2254\\[quoted-insert] still inserts characters in overwrite mode; this 2255is supposed to make it easier to insert characters when necessary." 2256 (interactive "P") 2257 (setq overwrite-mode 2258 (if (if (null arg) (not overwrite-mode) 2259 (> (prefix-numeric-value arg) 0)) 2260 'overwrite-mode-textual)) 2261 (force-mode-line-update)) 2262 2263(defun binary-overwrite-mode (arg) 2264 "Toggle binary overwrite mode. 2265With arg, turn binary overwrite mode on iff arg is positive. 2266In binary overwrite mode, printing characters typed in replace 2267existing text. Newlines are not treated specially, so typing at the 2268end of a line joins the line to the next, with the typed character 2269between them. Typing before a tab character simply replaces the tab 2270with the character typed. 2271\\[quoted-insert] replaces the text at the cursor, just as ordinary 2272typing characters do. 2273 2274Note that binary overwrite mode is not its own minor mode; it is a 2275specialization of overwrite-mode, entered by setting the 2276`overwrite-mode' variable to `overwrite-mode-binary'." 2277 (interactive "P") 2278 (setq overwrite-mode 2279 (if (if (null arg) 2280 (not (eq overwrite-mode 'overwrite-mode-binary)) 2281 (> (prefix-numeric-value arg) 0)) 2282 'overwrite-mode-binary)) 2283 (force-mode-line-update)) 2284 2285(defvar line-number-mode nil 2286 "*Non-nil means display line number in mode line.") 2287 2288(defun line-number-mode (arg) 2289 "Toggle Line Number mode. 2290With arg, turn Line Number mode on iff arg is positive. 2291When Line Number mode is enabled, the line number appears 2292in the mode line." 2293 (interactive "P") 2294 (setq line-number-mode 2295 (if (null arg) (not line-number-mode) 2296 (> (prefix-numeric-value arg) 0))) 2297 (force-mode-line-update)) 2298 2299(defvar blink-matching-paren t 2300 "*Non-nil means show matching open-paren when close-paren is inserted.") 2301 2302(defconst blink-matching-paren-distance 12000 2303 "*If non-nil, is maximum distance to search for matching open-paren.") 2304 2305(defun blink-matching-open () 2306 "Move cursor momentarily to the beginning of the sexp before point." 2307 (interactive) 2308 (and (> (point) (1+ (point-min))) 2309 (not (memq (char-syntax (char-after (- (point) 2))) '(?/ ?\\ ))) 2310 blink-matching-paren 2311 (let* ((oldpos (point)) 2312 (blinkpos) 2313 (mismatch)) 2314 (save-excursion 2315 (save-restriction 2316 (if blink-matching-paren-distance 2317 (narrow-to-region (max (point-min) 2318 (- (point) blink-matching-paren-distance)) 2319 oldpos)) 2320 (condition-case () 2321 (setq blinkpos (scan-sexps oldpos -1)) 2322 (error nil))) 2323 (and blinkpos (/= (char-syntax (char-after blinkpos)) 2324 ?\$) 2325 (setq mismatch 2326 (/= (char-after (1- oldpos)) 2327 (logand (lsh (aref (syntax-table) 2328 (char-after blinkpos)) 2329 -8) 2330 255)))) 2331 (if mismatch (setq blinkpos nil)) 2332 (if blinkpos 2333 (progn 2334 (goto-char blinkpos) 2335 (if (pos-visible-in-window-p) 2336 (sit-for 1) 2337 (goto-char blinkpos) 2338 (message 2339 "Matches %s" 2340 ;; Show what precedes the open in its line, if anything. 2341 (if (save-excursion 2342 (skip-chars-backward " \t") 2343 (not (bolp))) 2344 (buffer-substring (progn (beginning-of-line) (point)) 2345 (1+ blinkpos)) 2346 ;; Show what follows the open in its line, if anything. 2347 (if (save-excursion 2348 (forward-char 1) 2349 (skip-chars-forward " \t") 2350 (not (eolp))) 2351 (buffer-substring blinkpos 2352 (progn (end-of-line) (point))) 2353 ;; Otherwise show the previous nonblank line. 2354 (concat 2355 (buffer-substring (progn 2356 (backward-char 1) 2357 (skip-chars-backward "\n \t") 2358 (beginning-of-line) 2359 (point)) 2360 (progn (end-of-line) 2361 (skip-chars-backward " \t") 2362 (point))) 2363 ;; Replace the newline and other whitespace with `...'. 2364 "..." 2365 (buffer-substring blinkpos (1+ blinkpos)))))))) 2366 (cond (mismatch 2367 (message "Mismatched parentheses")) 2368 ((not blink-matching-paren-distance) 2369 (message "Unmatched parenthesis")))))))) 2370 2371;Turned off because it makes dbx bomb out. 2372(setq blink-paren-function 'blink-matching-open) 2373 2374;; This executes C-g typed while Emacs is waiting for a command. 2375;; Quitting out of a program does not go through here; 2376;; that happens in the QUIT macro at the C code level. 2377(defun keyboard-quit () 2378 "Signal a quit condition. 2379During execution of Lisp code, this character causes a quit directly. 2380At top-level, as an editor command, this simply beeps." 2381 (interactive) 2382 (deactivate-mark) 2383 (signal 'quit nil)) 2384 2385(define-key global-map "\C-g" 'keyboard-quit) 2386 2387(defun set-variable (var val) 2388 "Set VARIABLE to VALUE. VALUE is a Lisp object. 2389When using this interactively, supply a Lisp expression for VALUE. 2390If you want VALUE to be a string, you must surround it with doublequotes. 2391 2392If VARIABLE has a `variable-interactive' property, that is used as if 2393it were the arg to `interactive' (which see) to interactively read the value." 2394 (interactive 2395 (let* ((var (read-variable "Set variable: ")) 2396 (minibuffer-help-form 2397 '(funcall myhelp)) 2398 (myhelp 2399 (function 2400 (lambda () 2401 (with-output-to-temp-buffer "*Help*" 2402 (prin1 var) 2403 (princ "\nDocumentation:\n") 2404 (princ (substring (documentation-property var 'variable-documentation) 2405 1)) 2406 (if (boundp var) 2407 (let ((print-length 20)) 2408 (princ "\n\nCurrent value: ") 2409 (prin1 (symbol-value var)))) 2410 nil))))) 2411 (list var 2412 (let ((prop (get var 'variable-interactive))) 2413 (if prop 2414 ;; Use VAR's `variable-interactive' property 2415 ;; as an interactive spec for prompting. 2416 (call-interactively (list 'lambda '(arg) 2417 (list 'interactive prop) 2418 'arg)) 2419 (eval-minibuffer (format "Set %s to value: " var))))))) 2420 (set var val)) 2421 2422;; Define the major mode for lists of completions. 2423 2424(defvar completion-list-mode-map nil) 2425(or completion-list-mode-map 2426 (let ((map (make-sparse-keymap))) 2427 (define-key map [mouse-2] 'mouse-choose-completion) 2428 (define-key map [down-mouse-2] nil) 2429 (define-key map "\C-m" 'choose-completion) 2430 (define-key map [return] 'choose-completion) 2431 (setq completion-list-mode-map map))) 2432 2433;; Completion mode is suitable only for specially formatted data. 2434(put 'completion-list-mode 'mode-class 'special) 2435 2436;; Record the buffer that was current when the completion list was requested. 2437(defvar completion-reference-buffer) 2438 2439(defun choose-completion () 2440 "Choose the completion that point is in or next to." 2441 (interactive) 2442 (let (beg end) 2443 (skip-chars-forward "^ \t\n") 2444 (while (looking-at " [^ \n\t]") 2445 (forward-char 1) 2446 (skip-chars-forward "^ \t\n")) 2447 (setq end (point)) 2448 (skip-chars-backward "^ \t\n") 2449 (while (and (= (preceding-char) ?\ ) 2450 (not (and (> (point) (1+ (point-min))) 2451 (= (char-after (- (point) 2)) ?\ )))) 2452 (backward-char 1) 2453 (skip-chars-backward "^ \t\n")) 2454 (setq beg (point)) 2455 (choose-completion-string (buffer-substring beg end)))) 2456 2457;; Delete the longest partial match for STRING 2458;; that can be found before POINT. 2459(defun choose-completion-delete-max-match (string) 2460 (let ((opoint (point)) 2461 (len (min (length string) 2462 (- (point) (point-min))))) 2463 (goto-char (- (point) (length string))) 2464 (if completion-ignore-case 2465 (setq string (downcase string))) 2466 (while (and (> len 0) 2467 (let ((tail (buffer-substring (point) 2468 (+ (point) len)))) 2469 (if completion-ignore-case 2470 (setq tail (downcase tail))) 2471 (not (string= tail (substring string 0 len))))) 2472 (setq len (1- len)) 2473 (forward-char 1)) 2474 (delete-char len))) 2475 2476(defun choose-completion-string (choice &optional buffer) 2477 (let ((buffer (or buffer completion-reference-buffer))) 2478 ;; If BUFFER is a minibuffer, barf unless it's the currently 2479 ;; active minibuffer. 2480 (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer)) 2481 (or (not (minibuffer-window-active-p (minibuffer-window))) 2482 (not (equal buffer (window-buffer (minibuffer-window)))))) 2483 (error "Minibuffer is not active for completion") 2484 ;; Insert the completion into the buffer where completion was requested. 2485 (set-buffer buffer) 2486 (choose-completion-delete-max-match choice) 2487 (insert choice) 2488 (remove-text-properties (- (point) (length choice)) (point) 2489 '(mouse-face nil)) 2490 ;; Update point in the window that BUFFER is showing in. 2491 (let ((window (get-buffer-window buffer t))) 2492 (set-window-point window (point))) 2493 ;; If completing for the minibuffer, exit it with this choice. 2494 (and (equal buffer (window-buffer (minibuffer-window))) 2495 (minibuffer-complete-and-exit))))) 2496 2497(defun completion-list-mode () 2498 "Major mode for buffers showing lists of possible completions. 2499Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\ 2500 to select the completion near point. 2501Use \\<completion-list-mode-map>\\[mouse-choose-completion] to select one\ 2502 with the mouse." 2503 (interactive) 2504 (kill-all-local-variables) 2505 (use-local-map completion-list-mode-map) 2506 (setq mode-name "Completion List") 2507 (setq major-mode 'completion-list-mode) 2508 (run-hooks 'completion-list-mode-hook)) 2509 2510(defun completion-setup-function () 2511 (save-excursion 2512 (let ((mainbuf (current-buffer))) 2513 (set-buffer standard-output) 2514 (completion-list-mode) 2515 (make-local-variable 'completion-reference-buffer) 2516 (setq completion-reference-buffer mainbuf) 2517 (goto-char (point-min)) 2518 (if window-system 2519 (insert (substitute-command-keys 2520 "Click \\[mouse-choose-completion] on a completion to select it.\n"))) 2521 (insert (substitute-command-keys 2522 "In this buffer, type \\[choose-completion] to \ 2523select the completion near point.\n\n")) 2524 (forward-line 1) 2525 (if window-system 2526 (while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t) 2527 (put-text-property (match-beginning 0) (point) 2528 'mouse-face 'highlight)))))) 2529 2530(add-hook 'completion-setup-hook 'completion-setup-function) 2531 2532;;;; Keypad support. 2533 2534;;; Make the keypad keys act like ordinary typing keys. If people add 2535;;; bindings for the function key symbols, then those bindings will 2536;;; override these, so this shouldn't interfere with any existing 2537;;; bindings. 2538 2539;; Also tell read-char how to handle these keys. 2540(mapcar 2541 (lambda (keypad-normal) 2542 (let ((keypad (nth 0 keypad-normal)) 2543 (normal (nth 1 keypad-normal))) 2544 (put keypad 'ascii-character normal) 2545 (define-key function-key-map (vector keypad) (vector normal)))) 2546 '((kp-0 ?0) (kp-1 ?1) (kp-2 ?2) (kp-3 ?3) (kp-4 ?4) 2547 (kp-5 ?5) (kp-6 ?6) (kp-7 ?7) (kp-8 ?8) (kp-9 ?9) 2548 (kp-space ?\ ) 2549 (kp-tab ?\t) 2550 (kp-enter ?\r) 2551 (kp-multiply ?*) 2552 (kp-add ?+) 2553 (kp-separator ?,) 2554 (kp-subtract ?-) 2555 (kp-decimal ?.) 2556 (kp-divide ?/) 2557 (kp-equal ?=))) 2558 2559;;; simple.el ends here 2560