lisp/emacs-lisp/lisp.el

   1 ;;; lisp.el --- Lisp editing commands for Emacs
   2
   3 ;; Copyright (C) 1985, 1986, 1994, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: lisp, languages
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Lisp editing commands to go with Lisp major mode.  More-or-less
  29 ;; applicable in other modes too.
  30
  31 ;;; Code:
  32
  33 ;; Note that this variable is used by non-lisp modes too.
  34 (defcustom defun-prompt-regexp nil
  35   "*If non-nil, a regexp to ignore before a defun.
  36 This is only necessary if the opening paren or brace is not in column 0.
  37 See function `beginning-of-defun'."
  38   :type '(choice (const nil)
  39                  regexp)
  40   :group 'lisp)
  41 (make-variable-buffer-local 'defun-prompt-regexp)
  42
  43 (defcustom parens-require-spaces t
  44   "If non-nil, add whitespace as needed when inserting parentheses.
  45 This affects `insert-parentheses' and `insert-pair'."
  46   :type 'boolean
  47   :group 'lisp)
  48
  49 (defvar forward-sexp-function nil
  50   "If non-nil, `forward-sexp' delegates to this function.
  51 Should take the same arguments and behave similarly to `forward-sexp'.")
  52
  53 (defun forward-sexp (&optional arg)
  54   "Move forward across one balanced expression (sexp).
  55 With ARG, do it that many times.  Negative arg -N means
  56 move backward across N balanced expressions."
  57   (interactive "p")
  58   (or arg (setq arg 1))
  59   (if forward-sexp-function
  60       (funcall forward-sexp-function arg)
  61     (goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
  62     (if (< arg 0) (backward-prefix-chars))))
  63
  64 (defun backward-sexp (&optional arg)
  65   "Move backward across one balanced expression (sexp).
  66 With ARG, do it that many times.  Negative arg -N means
  67 move forward across N balanced expressions."
  68   (interactive "p")
  69   (or arg (setq arg 1))
  70   (forward-sexp (- arg)))
  71
  72 (defun mark-sexp (&optional arg allow-extend)
  73   "Set mark ARG sexps from point.
  74 The place mark goes is the same place \\[forward-sexp] would
  75 move to with the same argument.
  76 Interactively, if this command is repeated
  77 or (in Transient Mark mode) if the mark is active,
  78 it marks the next ARG sexps after the ones already marked."
  79   (interactive "P\np")
  80   (cond ((and allow-extend
  81               (or (and (eq last-command this-command) (mark t))
  82                   (and transient-mark-mode mark-active)))
  83          (setq arg (if arg (prefix-numeric-value arg)
  84                      (if (< (mark) (point)) -1 1)))
  85          (set-mark
  86           (save-excursion
  87             (goto-char (mark))
  88             (forward-sexp arg)
  89             (point))))
  90         (t
  91          (push-mark
  92           (save-excursion
  93             (forward-sexp (prefix-numeric-value arg))
  94             (point))
  95           nil t))))
  96
  97 (defun forward-list (&optional arg)
  98   "Move forward across one balanced group of parentheses.
  99 With ARG, do it that many times.
 100 Negative arg -N means move backward across N groups of parentheses."
 101   (interactive "p")
 102   (or arg (setq arg 1))
 103   (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))
 104
 105 (defun backward-list (&optional arg)
 106   "Move backward across one balanced group of parentheses.
 107 With ARG, do it that many times.
 108 Negative arg -N means move forward across N groups of parentheses."
 109   (interactive "p")
 110   (or arg (setq arg 1))
 111   (forward-list (- arg)))
 112
 113 (defun down-list (&optional arg)
 114   "Move forward down one level of parentheses.
 115 With ARG, do this that many times.
 116 A negative argument means move backward but still go down a level."
 117   (interactive "p")
 118   (or arg (setq arg 1))
 119   (let ((inc (if (> arg 0) 1 -1)))
 120     (while (/= arg 0)
 121       (goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
 122       (setq arg (- arg inc)))))
 123
 124 (defun backward-up-list (&optional arg)
 125   "Move backward out of one level of parentheses.
 126 With ARG, do this that many times.
 127 A negative argument means move forward but still to a less deep spot."
 128   (interactive "p")
 129   (up-list (- (or arg 1))))
 130
 131 (defun up-list (&optional arg)
 132   "Move forward out of one level of parentheses.
 133 With ARG, do this that many times.
 134 A negative argument means move backward but still to a less deep spot."
 135   (interactive "p")
 136   (or arg (setq arg 1))
 137   (let ((inc (if (> arg 0) 1 -1)))
 138     (while (/= arg 0)
 139       (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
 140       (setq arg (- arg inc)))))
 141
 142 (defun kill-sexp (&optional arg)
 143   "Kill the sexp (balanced expression) following point.
 144 With ARG, kill that many sexps after point.
 145 Negative arg -N means kill N sexps before point."
 146   (interactive "p")
 147   (let ((opoint (point)))
 148     (forward-sexp (or arg 1))
 149     (kill-region opoint (point))))
 150
 151 (defun backward-kill-sexp (&optional arg)
 152   "Kill the sexp (balanced expression) preceding point.
 153 With ARG, kill that many sexps before point.
 154 Negative arg -N means kill N sexps after point."
 155   (interactive "p")
 156   (kill-sexp (- (or arg 1))))
 157
 158 ;; After Zmacs:
 159 (defun kill-backward-up-list (&optional arg)
 160   "Kill the form containing the current sexp, leaving the sexp itself.
 161 A prefix argument ARG causes the relevant number of surrounding
 162 forms to be removed."
 163   (interactive "*p")
 164   (let ((current-sexp (thing-at-point 'sexp)))
 165     (if current-sexp
 166         (save-excursion
 167           (backward-up-list arg)
 168           (kill-sexp)
 169           (insert current-sexp))
 170       (error "Not at a sexp"))))
 171 \f
 172 (defvar beginning-of-defun-function nil
 173   "If non-nil, function for `beginning-of-defun-raw' to call.
 174 This is used to find the beginning of the defun instead of using the
 175 normal recipe (see `beginning-of-defun').  Major modes can define this
 176 if defining `defun-prompt-regexp' is not sufficient to handle the mode's
 177 needs.
 178
 179 The function takes the same argument as `beginning-of-defun' and should
 180 behave similarly, returning non-nil if it found the beginning of a defun.
 181 Ideally it should move to a point right before an open-paren which encloses
 182 the body of the defun.")
 183
 184 (defun beginning-of-defun (&optional arg)
 185   "Move backward to the beginning of a defun.
 186 With ARG, do it that many times.  Negative arg -N
 187 means move forward to Nth following beginning of defun.
 188 Returns t unless search stops due to beginning or end of buffer.
 189
 190 If variable `beginning-of-defun-function' is non-nil, its value
 191 is called as a function to find the defun's beginning.
 192
 193 Normally a defun is assumed to start where there is a char with
 194 open-parenthesis syntax at the beginning of a line.  If
 195 `defun-prompt-regexp' is non-nil, then a string which matches
 196 that regexp may precede the open-parenthesis, and point ends up
 197 at the beginning of the line.
 198
 199 If `defun-prompt-regexp' and `open-paren-in-column-0-is-defun-start'
 200 are both nil, the function instead finds an open-paren at the
 201 outermost level."
 202   (interactive "p")
 203   (or (not (eq this-command 'beginning-of-defun))
 204       (eq last-command 'beginning-of-defun)
 205       (and transient-mark-mode mark-active)
 206       (push-mark))
 207   (and (beginning-of-defun-raw arg)
 208        (progn (beginning-of-line) t)))
 209
 210 (defun beginning-of-defun-raw (&optional arg)
 211   "Move point to the character that starts a defun.
 212 This is identical to function `beginning-of-defun', except that point
 213 does not move to the beginning of the line when `defun-prompt-regexp'
 214 is non-nil.
 215
 216 If variable `beginning-of-defun-function' is non-nil, its value
 217 is called as a function to find the defun's beginning."
 218   (interactive "p")   ; change this to "P", maybe, if we ever come to pass ARG
 219                       ; to beginning-of-defun-function.
 220   (unless arg (setq arg 1))
 221   (cond
 222    (beginning-of-defun-function
 223     (condition-case nil
 224         (funcall beginning-of-defun-function arg)
 225       ;; We used to define beginning-of-defun-function as taking no argument
 226       ;; but that makes it impossible to implement correct forward motion:
 227       ;; we used to use end-of-defun for that, but it's not supposed to do
 228       ;; the same thing (it moves to the end of a defun not to the beginning
 229       ;; of the next).
 230       ;; In case the beginning-of-defun-function uses the old calling
 231       ;; convention, fallback on the old implementation.
 232       (wrong-number-of-arguments
 233        (if (> arg 0)
 234            (dotimes (i arg)
 235              (funcall beginning-of-defun-function))
 236          ;; Better not call end-of-defun-function directly, in case
 237          ;; it's not defined.
 238          (end-of-defun (- arg))))))
 239
 240    ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start)
 241     (and (< arg 0) (not (eobp)) (forward-char 1))
 242     (and (re-search-backward (if defun-prompt-regexp
 243                                  (concat (if open-paren-in-column-0-is-defun-start
 244                                              "^\\s(\\|" "")
 245                                          "\\(?:" defun-prompt-regexp "\\)\\s(")
 246                                "^\\s(")
 247                              nil 'move arg)
 248          (progn (goto-char (1- (match-end 0)))) t))
 249
 250    ;; If open-paren-in-column-0-is-defun-start and defun-prompt-regexp
 251    ;; are both nil, column 0 has no significance - so scan forward
 252    ;; from BOB to see how nested point is, then carry on from there.
 253    ;;
 254    ;; It is generally not a good idea to land up here, because the
 255    ;; call to scan-lists below can be extremely slow.  This is because
 256    ;; back_comment in syntax.c may have to scan from bob to find the
 257    ;; beginning of each comment.  Fixing this is not trivial -- cyd.
 258
 259    ((eq arg 0))
 260    (t
 261     (let ((floor (point-min))
 262           (ceiling (point-max))
 263           (arg-+ve (> arg 0)))
 264       (save-restriction
 265         (widen)
 266         (let ((ppss (let (syntax-begin-function
 267                           font-lock-beginning-of-syntax-function)
 268                       (syntax-ppss)))
 269               ;; position of least enclosing paren, or nil.
 270               encl-pos)
 271           ;; Back out of any comment/string, so that encl-pos will always
 272           ;; become nil if we're at top-level.
 273           (when (nth 8 ppss)
 274             (goto-char (nth 8 ppss))
 275             (setq ppss (syntax-ppss)))  ; should be fast, due to cache.
 276           (setq encl-pos (syntax-ppss-toplevel-pos ppss))
 277           (if encl-pos (goto-char encl-pos))
 278
 279           (and encl-pos arg-+ve (setq arg (1- arg)))
 280           (and (not encl-pos) (not arg-+ve) (not (looking-at "\\s("))
 281                (setq arg (1+ arg)))
 282
 283           (condition-case nil   ; to catch crazy parens.
 284               (progn
 285                 (goto-char (scan-lists (point) (- arg) 0))
 286                 (if arg-+ve
 287                     (if (>= (point) floor)
 288                         t
 289                       (goto-char floor)
 290                       nil)
 291                   ;; forward to next (, or trigger the c-c
 292                   (goto-char (1- (scan-lists (point) 1 -1)))
 293                   (if (<= (point) ceiling)
 294                       t
 295                     (goto-char ceiling)
 296                     nil)))
 297             (error
 298              (goto-char (if arg-+ve floor ceiling))
 299              nil))))))))
 300
 301 (defvar end-of-defun-function #'forward-sexp
 302   "Function for `end-of-defun' to call.
 303 This is used to find the end of the defun.
 304 It is called with no argument, right after calling `beginning-of-defun-raw'.
 305 So the function can assume that point is at the beginning of the defun body.")
 306
 307 (defun buffer-end (arg)
 308   "Return the \"far end\" position of the buffer, in direction ARG.
 309 If ARG is positive, that's the end of the buffer.
 310 Otherwise, that's the beginning of the buffer."
 311   (if (> arg 0) (point-max) (point-min)))
 312
 313 (defun end-of-defun (&optional arg)
 314   "Move forward to next end of defun.
 315 With argument, do it that many times.
 316 Negative argument -N means move back to Nth preceding end of defun.
 317
 318 An end of a defun occurs right after the close-parenthesis that
 319 matches the open-parenthesis that starts a defun; see function
 320 `beginning-of-defun'.
 321
 322 If variable `end-of-defun-function' is non-nil, its value
 323 is called as a function to find the defun's end."
 324   (interactive "p")
 325   (or (not (eq this-command 'end-of-defun))
 326       (eq last-command 'end-of-defun)
 327       (and transient-mark-mode mark-active)
 328       (push-mark))
 329   (if (or (null arg) (= arg 0)) (setq arg 1))
 330   (while (> arg 0)
 331     (let ((pos (point)))
 332       (end-of-line 1)
 333       (beginning-of-defun-raw 1)
 334       (while (unless (eobp)
 335                (funcall end-of-defun-function)
 336                (skip-chars-forward " \t")
 337                (if (looking-at "\\s<\\|\n")
 338                    (forward-line 1))
 339                ;; If we started after the end of the previous function, then
 340                ;; try again with the next one.
 341                (when (<= (point) pos)
 342                  (or (bobp) (forward-char -1))
 343                  (beginning-of-defun-raw -1)
 344                  'try-again))))
 345     (setq arg (1- arg)))
 346   (while (< arg 0)
 347     (let ((pos (point)))
 348       (while (unless (bobp)
 349                (beginning-of-line 1)
 350                (beginning-of-defun-raw 1)
 351                (let ((beg (point)))
 352                  (funcall end-of-defun-function)
 353                  (skip-chars-forward " \t")
 354                  (if (looking-at "\\s<\\|\n")
 355                      (forward-line 1))
 356                  ;; If we started from within the function just found, then
 357                  ;; try again with the previous one.
 358                  (when (>= (point) pos)
 359                    (goto-char beg)
 360                    'try-again)))))
 361     (setq arg (1+ arg))))
 362
 363 (defun mark-defun (&optional allow-extend)
 364   "Put mark at end of this defun, point at beginning.
 365 The defun marked is the one that contains point or follows point.
 366
 367 Interactively, if this command is repeated
 368 or (in Transient Mark mode) if the mark is active,
 369 it marks the next defun after the ones already marked."
 370   (interactive "p")
 371   (cond ((and allow-extend
 372               (or (and (eq last-command this-command) (mark t))
 373                   (and transient-mark-mode mark-active)))
 374          (set-mark
 375           (save-excursion
 376             (goto-char (mark))
 377             (end-of-defun)
 378             (point))))
 379         (t
 380          (let ((opoint (point))
 381                beg end)
 382            (push-mark opoint)
 383            ;; Try first in this order for the sake of languages with nested
 384            ;; functions where several can end at the same place as with
 385            ;; the offside rule, e.g. Python.
 386            (beginning-of-defun)
 387            (setq beg (point))
 388            (end-of-defun)
 389            (setq end (point))
 390            (while (looking-at "^\n")
 391              (forward-line 1))
 392            (if (> (point) opoint)
 393                (progn
 394                  ;; We got the right defun.
 395                  (push-mark beg nil t)
 396                  (goto-char end)
 397                  (exchange-point-and-mark))
 398              ;; beginning-of-defun moved back one defun
 399              ;; so we got the wrong one.
 400              (goto-char opoint)
 401              (end-of-defun)
 402              (push-mark (point) nil t)
 403              (beginning-of-defun))
 404            (re-search-backward "^\n" (- (point) 1) t)))))
 405
 406 (defun narrow-to-defun (&optional arg)
 407   "Make text outside current defun invisible.
 408 The defun visible is the one that contains point or follows point.
 409 Optional ARG is ignored."
 410   (interactive)
 411   (save-excursion
 412     (widen)
 413     (let ((opoint (point))
 414           beg end)
 415       ;; Try first in this order for the sake of languages with nested
 416       ;; functions where several can end at the same place as with
 417       ;; the offside rule, e.g. Python.
 418       (beginning-of-defun)
 419       (setq beg (point))
 420       (end-of-defun)
 421       (setq end (point))
 422       (while (looking-at "^\n")
 423         (forward-line 1))
 424       (unless (> (point) opoint)
 425         ;; beginning-of-defun moved back one defun
 426         ;; so we got the wrong one.
 427         (goto-char opoint)
 428         (end-of-defun)
 429         (setq end (point))
 430         (beginning-of-defun)
 431         (setq beg (point)))
 432       (goto-char end)
 433       (re-search-backward "^\n" (- (point) 1) t)
 434       (narrow-to-region beg end))))
 435
 436 (defvar insert-pair-alist
 437   '((?\( ?\)) (?\[ ?\]) (?\{ ?\}) (?\< ?\>) (?\" ?\") (?\' ?\') (?\` ?\'))
 438   "Alist of paired characters inserted by `insert-pair'.
 439 Each element looks like (OPEN-CHAR CLOSE-CHAR) or (COMMAND-CHAR
 440 OPEN-CHAR CLOSE-CHAR).  The characters OPEN-CHAR and CLOSE-CHAR
 441 of the pair whose key is equal to the last input character with
 442 or without modifiers, are inserted by `insert-pair'.")
 443
 444 (defun insert-pair (&optional arg open close)
 445   "Enclose following ARG sexps in a pair of OPEN and CLOSE characters.
 446 Leave point after the first character.
 447 A negative ARG encloses the preceding ARG sexps instead.
 448 No argument is equivalent to zero: just insert characters
 449 and leave point between.
 450 If `parens-require-spaces' is non-nil, this command also inserts a space
 451 before and after, depending on the surrounding characters.
 452 If region is active, insert enclosing characters at region boundaries.
 453
 454 If arguments OPEN and CLOSE are nil, the character pair is found
 455 from the variable `insert-pair-alist' according to the last input
 456 character with or without modifiers.  If no character pair is
 457 found in the variable `insert-pair-alist', then the last input
 458 character is inserted ARG times."
 459   (interactive "P")
 460   (if (not (and open close))
 461       (let ((pair (or (assq last-command-char insert-pair-alist)
 462                       (assq (event-basic-type last-command-event)
 463                             insert-pair-alist))))
 464         (if pair
 465             (if (nth 2 pair)
 466                 (setq open (nth 1 pair) close (nth 2 pair))
 467               (setq open (nth 0 pair) close (nth 1 pair))))))
 468   (if (and open close)
 469       (if (and transient-mark-mode mark-active)
 470           (progn
 471             (save-excursion (goto-char (region-end))       (insert close))
 472             (save-excursion (goto-char (region-beginning)) (insert open)))
 473         (if arg (setq arg (prefix-numeric-value arg))
 474           (setq arg 0))
 475         (cond ((> arg 0) (skip-chars-forward " \t"))
 476               ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
 477         (and parens-require-spaces
 478              (not (bobp))
 479              (memq (char-syntax (preceding-char)) (list ?w ?_ (char-syntax close)))
 480              (insert " "))
 481         (insert open)
 482         (save-excursion
 483           (or (eq arg 0) (forward-sexp arg))
 484           (insert close)
 485           (and parens-require-spaces
 486                (not (eobp))
 487                (memq (char-syntax (following-char)) (list ?w ?_ (char-syntax open)))
 488                (insert " "))))
 489     (insert-char (event-basic-type last-command-event)
 490                  (prefix-numeric-value arg))))
 491
 492 (defun insert-parentheses (&optional arg)
 493   "Enclose following ARG sexps in parentheses.
 494 Leave point after open-paren.
 495 A negative ARG encloses the preceding ARG sexps instead.
 496 No argument is equivalent to zero: just insert `()' and leave point between.
 497 If `parens-require-spaces' is non-nil, this command also inserts a space
 498 before and after, depending on the surrounding characters.
 499 If region is active, insert enclosing characters at region boundaries."
 500   (interactive "P")
 501   (insert-pair arg ?\( ?\)))
 502
 503 (defun delete-pair ()
 504   "Delete a pair of characters enclosing the sexp that follows point."
 505   (interactive)
 506   (save-excursion (forward-sexp 1) (delete-char -1))
 507   (delete-char 1))
 508
 509 (defun raise-sexp (&optional arg)
 510   "Raise ARG sexps higher up the tree."
 511   (interactive "p")
 512   (let ((s (if (and transient-mark-mode mark-active)
 513                (buffer-substring (region-beginning) (region-end))
 514              (buffer-substring
 515               (point)
 516               (save-excursion (forward-sexp arg) (point))))))
 517     (backward-up-list 1)
 518     (delete-region (point) (save-excursion (forward-sexp 1) (point)))
 519     (save-excursion (insert s))))
 520
 521 (defun move-past-close-and-reindent ()
 522   "Move past next `)', delete indentation before it, then indent after it."
 523   (interactive)
 524   (up-list 1)
 525   (forward-char -1)
 526   (while (save-excursion                ; this is my contribution
 527            (let ((before-paren (point)))
 528              (back-to-indentation)
 529              (and (= (point) before-paren)
 530                   (progn
 531                     ;; Move to end of previous line.
 532                     (beginning-of-line)
 533                     (forward-char -1)
 534                     ;; Verify it doesn't end within a string or comment.
 535                     (let ((end (point))
 536                           state)
 537                       (beginning-of-line)
 538                       ;; Get state at start of line.
 539                       (setq state  (list 0 nil nil
 540                                          (null (calculate-lisp-indent))
 541                                          nil nil nil nil
 542                                          nil))
 543                       ;; Parse state across the line to get state at end.
 544                       (setq state (parse-partial-sexp (point) end nil nil
 545                                                       state))
 546                       ;; Check not in string or comment.
 547                       (and (not (elt state 3)) (not (elt state 4))))))))
 548     (delete-indentation))
 549   (forward-char 1)
 550   (newline-and-indent))
 551
 552 (defun check-parens ()                  ; lame name?
 553   "Check for unbalanced parentheses in the current buffer.
 554 More accurately, check the narrowed part of the buffer for unbalanced
 555 expressions (\"sexps\") in general.  This is done according to the
 556 current syntax table and will find unbalanced brackets or quotes as
 557 appropriate.  (See Info node `(emacs)Parentheses'.)  If imbalance is
 558 found, an error is signaled and point is left at the first unbalanced
 559 character."
 560   (interactive)
 561   (condition-case data
 562       ;; Buffer can't have more than (point-max) sexps.
 563       (scan-sexps (point-min) (point-max))
 564     (scan-error (goto-char (nth 2 data))
 565                 ;; Could print (nth 1 data), which is either
 566                 ;; "Containing expression ends prematurely" or
 567                 ;; "Unbalanced parentheses", but those may not be so
 568                 ;; accurate/helpful, e.g. quotes may actually be
 569                 ;; mismatched.
 570                 (error "Unmatched bracket or quote"))))
 571 \f
 572 (defun field-complete (table &optional predicate)
 573   (let* ((pattern (field-string-no-properties))
 574          (completion (try-completion pattern table predicate)))
 575     (cond ((eq completion t))
 576           ((null completion)
 577            (message "Can't find completion for \"%s\"" pattern)
 578            (ding))
 579           ((not (string= pattern completion))
 580            (delete-region (field-beginning) (field-end))
 581            (insert completion)
 582            ;; Don't leave around a completions buffer that's out of date.
 583            (let ((win (get-buffer-window "*Completions*" 0)))
 584              (if win (with-selected-window win (bury-buffer)))))
 585           (t
 586            (let ((minibuf-is-in-use
 587                   (eq (minibuffer-window) (selected-window))))
 588              (unless minibuf-is-in-use
 589                (message "Making completion list..."))
 590              (let ((list (all-completions pattern table predicate)))
 591                (setq list (sort list 'string<))
 592                (or (eq predicate 'fboundp)
 593                    (let (new)
 594                      (while list
 595                        (setq new (cons (if (fboundp (intern (car list)))
 596                                            (list (car list) " <f>")
 597                                          (car list))
 598                                        new))
 599                        (setq list (cdr list)))
 600                      (setq list (nreverse new))))
 601                (if (> (length list) 1)
 602                    (with-output-to-temp-buffer "*Completions*"
 603                      (display-completion-list list pattern))
 604                  ;; Don't leave around a completions buffer that's
 605                  ;; out of date.
 606                  (let ((win (get-buffer-window "*Completions*" 0)))
 607                    (if win (with-selected-window win (bury-buffer))))))
 608              (unless minibuf-is-in-use
 609                (message "Making completion list...%s" "done")))))))
 610
 611 (defun lisp-complete-symbol (&optional predicate)
 612   "Perform completion on Lisp symbol preceding point.
 613 Compare that symbol against the known Lisp symbols.
 614 If no characters can be completed, display a list of possible completions.
 615 Repeating the command at that point scrolls the list.
 616
 617 When called from a program, optional arg PREDICATE is a predicate
 618 determining which symbols are considered, e.g. `commandp'.
 619 If PREDICATE is nil, the context determines which symbols are
 620 considered.  If the symbol starts just after an open-parenthesis, only
 621 symbols with function definitions are considered.  Otherwise, all
 622 symbols with function definitions, values or properties are
 623 considered."
 624   (interactive)
 625   (let ((window (get-buffer-window "*Completions*" 0)))
 626     (if (and (eq last-command this-command)
 627              window (window-live-p window) (window-buffer window)
 628              (buffer-name (window-buffer window)))
 629         ;; If this command was repeated, and
 630         ;; there's a fresh completion window with a live buffer,
 631         ;; and this command is repeated, scroll that window.
 632         (with-current-buffer (window-buffer window)
 633           (if (pos-visible-in-window-p (point-max) window)
 634               (set-window-start window (point-min))
 635             (save-selected-window
 636               (select-window window)
 637               (scroll-up))))
 638
 639       ;; Do completion.
 640       (let* ((end (point))
 641              (beg (with-syntax-table emacs-lisp-mode-syntax-table
 642                     (save-excursion
 643                       (backward-sexp 1)
 644                       (while (= (char-syntax (following-char)) ?\')
 645                         (forward-char 1))
 646                       (point))))
 647              (pattern (buffer-substring-no-properties beg end))
 648              (predicate
 649               (or predicate
 650                   (save-excursion
 651                     (goto-char beg)
 652                     (if (not (eq (char-before) ?\())
 653                         (lambda (sym)   ;why not just nil ?   -sm
 654                           (or (boundp sym) (fboundp sym)
 655                               (symbol-plist sym)))
 656                       ;; Looks like a funcall position.  Let's double check.
 657                       (if (condition-case nil
 658                               (progn (up-list -2) (forward-char 1)
 659                                      (eq (char-after) ?\())
 660                             (error nil))
 661                           ;; If the first element of the parent list is an open
 662                           ;; parenthesis we are probably not in a funcall position.
 663                           ;; Maybe a `let' varlist or something.
 664                           nil
 665                         ;; Else, we assume that a function name is expected.
 666                         'fboundp)))))
 667              (completion (try-completion pattern obarray predicate)))
 668         (cond ((eq completion t))
 669               ((null completion)
 670                (if (window-minibuffer-p (selected-window))
 671                    (minibuffer-message (format " [No completions of \"%s\"]" pattern))
 672                  (message "Can't find completion for \"%s\"" pattern))
 673                (ding))
 674               ((not (string= pattern completion))
 675                (delete-region beg end)
 676                (insert completion)
 677                ;; Don't leave around a completions buffer that's out of date.
 678                (let ((win (get-buffer-window "*Completions*" 0)))
 679                  (if win (with-selected-window win (bury-buffer)))))
 680               (t
 681                (let ((minibuf-is-in-use
 682                       (eq (minibuffer-window) (selected-window))))
 683                  (unless minibuf-is-in-use
 684                    (message "Making completion list..."))
 685                  (let ((list (all-completions pattern obarray predicate)))
 686                    (setq list (sort list 'string<))
 687                    (or (eq predicate 'fboundp)
 688                        (let (new)
 689                          (while list
 690                            (setq new (cons (if (fboundp (intern (car list)))
 691                                                (list (car list) " <f>")
 692                                              (car list))
 693                                            new))
 694                            (setq list (cdr list)))
 695                          (setq list (nreverse new))))
 696                    (if (> (length list) 1)
 697                        (with-output-to-temp-buffer "*Completions*"
 698                          (display-completion-list list pattern))
 699                      ;; Don't leave around a completions buffer that's
 700                      ;; out of date.
 701                      (let ((win (get-buffer-window "*Completions*" 0)))
 702                        (if win (with-selected-window win (bury-buffer))))))
 703                  (unless minibuf-is-in-use
 704                    (message "Making completion list...%s" "done")))))))))
 705
 706 ;; arch-tag: aa7fa8a4-2e6f-4e9b-9cd9-fef06340e67e
 707 ;;; lisp.el ends here