lisp.el 35.1 KB
Newer Older
1
;;; lisp.el --- Lisp editing commands for Emacs  -*- lexical-binding:t -*-
Eric S. Raymond's avatar
Eric S. Raymond committed
2

3 4
;; Copyright (C) 1985-1986, 1994, 2000-2013 Free Software Foundation,
;; Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
5

Eric S. Raymond's avatar
Eric S. Raymond committed
6
;; Maintainer: FSF
Eric S. Raymond's avatar
Eric S. Raymond committed
7
;; Keywords: lisp, languages
8
;; Package: emacs
Eric S. Raymond's avatar
Eric S. Raymond committed
9

root's avatar
root committed
10 11
;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
root's avatar
root committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
root's avatar
root committed
16 17 18 19 20 21 22

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
23
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
root's avatar
root committed
24

25 26
;;; Commentary:

27 28
;; Lisp editing commands to go with Lisp major mode.  More-or-less
;; applicable in other modes too.
29

Eric S. Raymond's avatar
Eric S. Raymond committed
30
;;; Code:
root's avatar
root committed
31

Karl Heuer's avatar
Karl Heuer committed
32
;; Note that this variable is used by non-lisp modes too.
Richard M. Stallman's avatar
Richard M. Stallman committed
33
(defcustom defun-prompt-regexp nil
34
  "If non-nil, a regexp to ignore before a defun.
Karl Heuer's avatar
Karl Heuer committed
35
This is only necessary if the opening paren or brace is not in column 0.
36
See function `beginning-of-defun'."
37 38
  :type '(choice (const nil)
		 regexp)
Richard M. Stallman's avatar
Richard M. Stallman committed
39
  :group 'lisp)
40
(make-variable-buffer-local 'defun-prompt-regexp)
root's avatar
root committed
41

Richard M. Stallman's avatar
Richard M. Stallman committed
42
(defcustom parens-require-spaces t
43 44
  "If non-nil, add whitespace as needed when inserting parentheses.
This affects `insert-parentheses' and `insert-pair'."
Richard M. Stallman's avatar
Richard M. Stallman committed
45 46
  :type 'boolean
  :group 'lisp)
47

Stefan Monnier's avatar
Stefan Monnier committed
48
(defvar forward-sexp-function nil
49 50 51 52 53 54
  ;; FIXME:
  ;; - for some uses, we may want a "sexp-only" version, which only
  ;;   jumps over a well-formed sexp, rather than some dwimish thing
  ;;   like jumping from an "else" back up to its "if".
  ;; - for up-list, we could use the "sexp-only" behavior as well
  ;;   to treat the dwimish halfsexp as a form of "up-list" step.
Stefan Monnier's avatar
Stefan Monnier committed
55 56 57
  "If non-nil, `forward-sexp' delegates to this function.
Should take the same arguments and behave similarly to `forward-sexp'.")

root's avatar
root committed
58 59
(defun forward-sexp (&optional arg)
  "Move forward across one balanced expression (sexp).
60
With ARG, do it that many times.  Negative arg -N means
61
move backward across N balanced expressions.
62 63
This command assumes point is not in a string or comment.
Calls `forward-sexp-function' to do the work, if that is non-nil."
64
  (interactive "^p")
root's avatar
root committed
65
  (or arg (setq arg 1))
Stefan Monnier's avatar
Stefan Monnier committed
66 67 68 69
  (if forward-sexp-function
      (funcall forward-sexp-function arg)
    (goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
    (if (< arg 0) (backward-prefix-chars))))
root's avatar
root committed
70 71 72

(defun backward-sexp (&optional arg)
  "Move backward across one balanced expression (sexp).
73
With ARG, do it that many times.  Negative arg -N means
74
move forward across N balanced expressions.
75 76
This command assumes point is not in a string or comment.
Uses `forward-sexp' to do the work."
77
  (interactive "^p")
root's avatar
root committed
78 79 80
  (or arg (setq arg 1))
  (forward-sexp (- arg)))

81
(defun mark-sexp (&optional arg allow-extend)
root's avatar
root committed
82
  "Set mark ARG sexps from point.
Jim Blandy's avatar
Jim Blandy committed
83
The place mark goes is the same place \\[forward-sexp] would
84
move to with the same argument.
85
Interactively, if this command is repeated
86
or (in Transient Mark mode) if the mark is active,
87 88
it marks the next ARG sexps after the ones already marked.
This command assumes point is not in a string or comment."
89 90 91 92
  (interactive "P\np")
  (cond ((and allow-extend
	      (or (and (eq last-command this-command) (mark t))
		  (and transient-mark-mode mark-active)))
93
	 (setq arg (if arg (prefix-numeric-value arg)
94
		     (if (< (mark) (point)) -1 1)))
95 96
	 (set-mark
	  (save-excursion
97 98 99
	    (goto-char (mark))
	    (forward-sexp arg)
	    (point))))
100 101 102
	(t
	 (push-mark
	  (save-excursion
103
	    (forward-sexp (prefix-numeric-value arg))
104 105
	    (point))
	  nil t))))
root's avatar
root committed
106 107 108

(defun forward-list (&optional arg)
  "Move forward across one balanced group of parentheses.
109
With ARG, do it that many times.
110 111
Negative arg -N means move backward across N groups of parentheses.
This command assumes point is not in a string or comment."
112
  (interactive "^p")
root's avatar
root committed
113 114 115 116 117
  (or arg (setq arg 1))
  (goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))

(defun backward-list (&optional arg)
  "Move backward across one balanced group of parentheses.
118
With ARG, do it that many times.
119 120
Negative arg -N means move forward across N groups of parentheses.
This command assumes point is not in a string or comment."
121
  (interactive "^p")
root's avatar
root committed
122 123 124
  (or arg (setq arg 1))
  (forward-list (- arg)))

125
(defun down-list (&optional arg)
root's avatar
root committed
126
  "Move forward down one level of parentheses.
127
With ARG, do this that many times.
128 129
A negative argument means move backward but still go down a level.
This command assumes point is not in a string or comment."
130
  (interactive "^p")
131
  (or arg (setq arg 1))
root's avatar
root committed
132 133 134 135 136
  (let ((inc (if (> arg 0) 1 -1)))
    (while (/= arg 0)
      (goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
      (setq arg (- arg inc)))))

137
(defun backward-up-list (&optional arg)
root's avatar
root committed
138
  "Move backward out of one level of parentheses.
139
With ARG, do this that many times.
140 141
A negative argument means move forward but still to a less deep spot.
This command assumes point is not in a string or comment."
142
  (interactive "^p")
143
  (up-list (- (or arg 1))))
root's avatar
root committed
144

145
(defun up-list (&optional arg)
root's avatar
root committed
146
  "Move forward out of one level of parentheses.
147
With ARG, do this that many times.
148 149
A negative argument means move backward but still to a less deep spot.
This command assumes point is not in a string or comment."
150
  (interactive "^p")
151
  (or arg (setq arg 1))
152 153
  (let ((inc (if (> arg 0) 1 -1))
        pos)
root's avatar
root committed
154
    (while (/= arg 0)
155 156
      (if (null forward-sexp-function)
          (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
157 158 159 160 161 162
	(condition-case err
	    (while (progn (setq pos (point))
			  (forward-sexp inc)
			  (/= (point) pos)))
	  (scan-error (goto-char (nth (if (> arg 0) 3 2) err))))
	(if (= (point) pos)
163 164
            (signal 'scan-error
                    (list "Unbalanced parentheses" (point) (point)))))
root's avatar
root committed
165 166
      (setq arg (- arg inc)))))

167
(defun kill-sexp (&optional arg)
168 169
  "Kill the sexp (balanced expression) following point.
With ARG, kill that many sexps after point.
170 171
Negative arg -N means kill N sexps before point.
This command assumes point is not in a string or comment."
root's avatar
root committed
172 173
  (interactive "p")
  (let ((opoint (point)))
174
    (forward-sexp (or arg 1))
root's avatar
root committed
175 176
    (kill-region opoint (point))))

177
(defun backward-kill-sexp (&optional arg)
178 179
  "Kill the sexp (balanced expression) preceding point.
With ARG, kill that many sexps before point.
180 181
Negative arg -N means kill N sexps after point.
This command assumes point is not in a string or comment."
root's avatar
root committed
182
  (interactive "p")
183
  (kill-sexp (- (or arg 1))))
184 185 186 187 188

;; After Zmacs:
(defun kill-backward-up-list (&optional arg)
  "Kill the form containing the current sexp, leaving the sexp itself.
A prefix argument ARG causes the relevant number of surrounding
189 190
forms to be removed.
This command assumes point is not in a string or comment."
191 192 193 194 195 196 197 198
  (interactive "*p")
  (let ((current-sexp (thing-at-point 'sexp)))
    (if current-sexp
        (save-excursion
          (backward-up-list arg)
          (kill-sexp)
          (insert current-sexp))
      (error "Not at a sexp"))))
root's avatar
root committed
199

200
(defvar beginning-of-defun-function nil
201 202
  "If non-nil, function for `beginning-of-defun-raw' to call.
This is used to find the beginning of the defun instead of using the
203 204 205
normal recipe (see `beginning-of-defun').  Major modes can define this
if defining `defun-prompt-regexp' is not sufficient to handle the mode's
needs.
206

207 208 209 210
The function takes the same argument as `beginning-of-defun' and should
behave similarly, returning non-nil if it found the beginning of a defun.
Ideally it should move to a point right before an open-paren which encloses
the body of the defun.")
211

root's avatar
root committed
212 213
(defun beginning-of-defun (&optional arg)
  "Move backward to the beginning of a defun.
Chong Yidong's avatar
Chong Yidong committed
214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234
With ARG, do it that many times.  Negative ARG means move forward
to the ARGth following beginning of defun.

If search is successful, return t; point ends up at the beginning
of the line where the search succeeded.  Otherwise, return nil.

When `open-paren-in-column-0-is-defun-start' is non-nil, a defun
is assumed to start where there is a char with open-parenthesis
syntax at the beginning of a line.  If `defun-prompt-regexp' is
non-nil, then a string which matches that regexp may also precede
the open-parenthesis.  If `defun-prompt-regexp' and
`open-paren-in-column-0-is-defun-start' are both nil, this
function instead finds an open-paren at the outermost level.

If the variable `beginning-of-defun-function' is non-nil, its
value is called as a function, with argument ARG, to find the
defun's beginning.

Regardless of the values of `defun-prompt-regexp' and
`beginning-of-defun-function', point always moves to the
beginning of the line whenever the search is successful."
235
  (interactive "^p")
236
  (or (not (eq this-command 'beginning-of-defun))
237 238 239
      (eq last-command 'beginning-of-defun)
      (and transient-mark-mode mark-active)
      (push-mark))
240 241 242 243 244
  (and (beginning-of-defun-raw arg)
       (progn (beginning-of-line) t)))

(defun beginning-of-defun-raw (&optional arg)
  "Move point to the character that starts a defun.
245 246 247 248
This is identical to function `beginning-of-defun', except that point
does not move to the beginning of the line when `defun-prompt-regexp'
is non-nil.

249 250
If variable `beginning-of-defun-function' is non-nil, its value
is called as a function to find the defun's beginning."
251
  (interactive "^p")   ; change this to "P", maybe, if we ever come to pass ARG
252 253
                      ; to beginning-of-defun-function.
  (unless arg (setq arg 1))
254 255
  (cond
   (beginning-of-defun-function
256 257 258 259 260 261 262 263 264 265 266
    (condition-case nil
        (funcall beginning-of-defun-function arg)
      ;; We used to define beginning-of-defun-function as taking no argument
      ;; but that makes it impossible to implement correct forward motion:
      ;; we used to use end-of-defun for that, but it's not supposed to do
      ;; the same thing (it moves to the end of a defun not to the beginning
      ;; of the next).
      ;; In case the beginning-of-defun-function uses the old calling
      ;; convention, fallback on the old implementation.
      (wrong-number-of-arguments
       (if (> arg 0)
267
           (dotimes (_ arg)
268
             (funcall beginning-of-defun-function))
269
	 (dotimes (_ (- arg))
270
	   (funcall end-of-defun-function))))))
271 272 273

   ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start)
    (and (< arg 0) (not (eobp)) (forward-char 1))
274
    (and (re-search-backward (if defun-prompt-regexp
275 276
				 (concat (if open-paren-in-column-0-is-defun-start
					     "^\\s(\\|" "")
277
					 "\\(?:" defun-prompt-regexp "\\)\\s(")
278
			       "^\\s(")
279
			     nil 'move arg)
280 281
	 (progn (goto-char (1- (match-end 0)))
                t)))
282

283 284 285 286 287 288 289 290 291 292
   ;; If open-paren-in-column-0-is-defun-start and defun-prompt-regexp
   ;; are both nil, column 0 has no significance - so scan forward
   ;; from BOB to see how nested point is, then carry on from there.
   ;;
   ;; It is generally not a good idea to land up here, because the
   ;; call to scan-lists below can be extremely slow.  This is because
   ;; back_comment in syntax.c may have to scan from bob to find the
   ;; beginning of each comment.  Fixing this is not trivial -- cyd.

   ((eq arg 0))
293
   (t
294 295 296
    (let ((floor (point-min))
	  (ceiling (point-max))
	  (arg-+ve (> arg 0)))
297 298
      (save-restriction
	(widen)
299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332
	(let ((ppss (let (syntax-begin-function
			  font-lock-beginning-of-syntax-function)
		      (syntax-ppss)))
	      ;; position of least enclosing paren, or nil.
	      encl-pos)
	  ;; Back out of any comment/string, so that encl-pos will always
	  ;; become nil if we're at top-level.
	  (when (nth 8 ppss)
	    (goto-char (nth 8 ppss))
	    (setq ppss (syntax-ppss)))	; should be fast, due to cache.
	  (setq encl-pos (syntax-ppss-toplevel-pos ppss))
	  (if encl-pos (goto-char encl-pos))

	  (and encl-pos arg-+ve (setq arg (1- arg)))
	  (and (not encl-pos) (not arg-+ve) (not (looking-at "\\s("))
	       (setq arg (1+ arg)))

	  (condition-case nil   ; to catch crazy parens.
	      (progn
		(goto-char (scan-lists (point) (- arg) 0))
		(if arg-+ve
		    (if (>= (point) floor)
			t
		      (goto-char floor)
		      nil)
		  ;; forward to next (, or trigger the c-c
		  (goto-char (1- (scan-lists (point) 1 -1)))
		  (if (<= (point) ceiling)
		      t
		    (goto-char ceiling)
		    nil)))
	    (error
	     (goto-char (if arg-+ve floor ceiling))
	     nil))))))))
333

334 335
(defvar end-of-defun-function
  (lambda () (forward-sexp 1))
336
  "Function for `end-of-defun' to call.
337
This is used to find the end of the defun at point.
338
It is called with no argument, right after calling `beginning-of-defun-raw'.
339 340
So the function can assume that point is at the beginning of the defun body.
It should move point to the first position after the defun.")
root's avatar
root committed
341 342

(defun buffer-end (arg)
343
  "Return the \"far end\" position of the buffer, in direction ARG.
Richard M. Stallman's avatar
Richard M. Stallman committed
344 345
If ARG is positive, that's the end of the buffer.
Otherwise, that's the beginning of the buffer."
root's avatar
root committed
346 347 348
  (if (> arg 0) (point-max) (point-min)))

(defun end-of-defun (&optional arg)
349 350
  "Move forward to next end of defun.
With argument, do it that many times.
root's avatar
root committed
351 352
Negative argument -N means move back to Nth preceding end of defun.

353 354
An end of a defun occurs right after the close-parenthesis that
matches the open-parenthesis that starts a defun; see function
355 356 357 358
`beginning-of-defun'.

If variable `end-of-defun-function' is non-nil, its value
is called as a function to find the defun's end."
359
  (interactive "^p")
360
  (or (not (eq this-command 'end-of-defun))
361 362 363
      (eq last-command 'end-of-defun)
      (and transient-mark-mode mark-active)
      (push-mark))
364
  (if (or (null arg) (= arg 0)) (setq arg 1))
365 366 367
  (let ((pos (point))
        (beg (progn (end-of-line 1) (beginning-of-defun-raw 1) (point))))
    (funcall end-of-defun-function)
368 369 370 371 372 373 374 375
    ;; When comparing point against pos, we want to consider that if
    ;; point was right after the end of the function, it's still
    ;; considered as "in that function".
    ;; E.g. `eval-defun' from right after the last close-paren.
    (unless (bolp)
      (skip-chars-forward " \t")
      (if (looking-at "\\s<\\|\n")
          (forward-line 1)))
376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402
    (cond
     ((> arg 0)
      ;; Moving forward.
      (if (> (point) pos)
          ;; We already moved forward by one because we started from
          ;; within a function.
          (setq arg (1- arg))
        ;; We started from after the end of the previous function.
        (goto-char pos))
      (unless (zerop arg)
        (beginning-of-defun-raw (- arg))
        (funcall end-of-defun-function)))
     ((< arg 0)
      ;; Moving backward.
      (if (< (point) pos)
          ;; We already moved backward because we started from between
          ;; two functions.
          (setq arg (1+ arg))
        ;; We started from inside a function.
        (goto-char beg))
      (unless (zerop arg)
        (beginning-of-defun-raw (- arg))
        (funcall end-of-defun-function))))
    (unless (bolp)
      (skip-chars-forward " \t")
      (if (looking-at "\\s<\\|\n")
          (forward-line 1)))))
root's avatar
root committed
403

404
(defun mark-defun (&optional allow-extend)
root's avatar
root committed
405
  "Put mark at end of this defun, point at beginning.
406
The defun marked is the one that contains point or follows point.
407 408

Interactively, if this command is repeated
409
or (in Transient Mark mode) if the mark is active,
410 411 412 413 414
it marks the next defun after the ones already marked."
  (interactive "p")
  (cond ((and allow-extend
	      (or (and (eq last-command this-command) (mark t))
		  (and transient-mark-mode mark-active)))
415 416 417 418 419 420
	 (set-mark
	  (save-excursion
	    (goto-char (mark))
	    (end-of-defun)
	    (point))))
	(t
421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
	 (let ((opoint (point))
	       beg end)
	   (push-mark opoint)
	   ;; Try first in this order for the sake of languages with nested
	   ;; functions where several can end at the same place as with
	   ;; the offside rule, e.g. Python.
	   (beginning-of-defun)
	   (setq beg (point))
	   (end-of-defun)
	   (setq end (point))
	   (while (looking-at "^\n")
	     (forward-line 1))
	   (if (> (point) opoint)
	       (progn
		 ;; We got the right defun.
		 (push-mark beg nil t)
		 (goto-char end)
		 (exchange-point-and-mark))
	     ;; beginning-of-defun moved back one defun
	     ;; so we got the wrong one.
	     (goto-char opoint)
	     (end-of-defun)
	     (push-mark (point) nil t)
	     (beginning-of-defun))
	   (re-search-backward "^\n" (- (point) 1) t)))))
root's avatar
root committed
446

447
(defun narrow-to-defun (&optional _arg)
448
  "Make text outside current defun invisible.
449 450
The defun visible is the one that contains point or follows point.
Optional ARG is ignored."
451 452 453
  (interactive)
  (save-excursion
    (widen)
454 455 456 457 458
    (let ((opoint (point))
	  beg end)
      ;; Try first in this order for the sake of languages with nested
      ;; functions where several can end at the same place as with
      ;; the offside rule, e.g. Python.
Lennart Borgman's avatar
Lennart Borgman committed
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473

      ;; Finding the start of the function is a bit problematic since
      ;; `beginning-of-defun' when we are on the first character of
      ;; the function might go to the previous function.
      ;;
      ;; Therefore we first move one character forward and then call
      ;; `beginning-of-defun'.  However now we must check that we did
      ;; not move into the next function.
      (let ((here (point)))
        (unless (eolp)
	  (forward-char))
        (beginning-of-defun)
        (when (< (point) here)
          (goto-char here)
          (beginning-of-defun)))
474
      (setq beg (point))
475
      (end-of-defun)
476 477 478 479 480 481 482 483 484 485 486 487 488 489
      (setq end (point))
      (while (looking-at "^\n")
	(forward-line 1))
      (unless (> (point) opoint)
	;; beginning-of-defun moved back one defun
	;; so we got the wrong one.
	(goto-char opoint)
	(end-of-defun)
	(setq end (point))
	(beginning-of-defun)
	(setq beg (point)))
      (goto-char end)
      (re-search-backward "^\n" (- (point) 1) t)
      (narrow-to-region beg end))))
490

Juri Linkov's avatar
Juri Linkov committed
491 492 493 494 495 496 497 498 499
(defvar insert-pair-alist
  '((?\( ?\)) (?\[ ?\]) (?\{ ?\}) (?\< ?\>) (?\" ?\") (?\' ?\') (?\` ?\'))
  "Alist of paired characters inserted by `insert-pair'.
Each element looks like (OPEN-CHAR CLOSE-CHAR) or (COMMAND-CHAR
OPEN-CHAR CLOSE-CHAR).  The characters OPEN-CHAR and CLOSE-CHAR
of the pair whose key is equal to the last input character with
or without modifiers, are inserted by `insert-pair'.")

(defun insert-pair (&optional arg open close)
500 501
  "Enclose following ARG sexps in a pair of OPEN and CLOSE characters.
Leave point after the first character.
502
A negative ARG encloses the preceding ARG sexps instead.
503 504
No argument is equivalent to zero: just insert characters
and leave point between.
Karl Heuer's avatar
Karl Heuer committed
505
If `parens-require-spaces' is non-nil, this command also inserts a space
506
before and after, depending on the surrounding characters.
Juri Linkov's avatar
Juri Linkov committed
507 508 509 510 511 512
If region is active, insert enclosing characters at region boundaries.

If arguments OPEN and CLOSE are nil, the character pair is found
from the variable `insert-pair-alist' according to the last input
character with or without modifiers.  If no character pair is
found in the variable `insert-pair-alist', then the last input
513 514 515
character is inserted ARG times.

This command assumes point is not in a string or comment."
root's avatar
root committed
516
  (interactive "P")
Juri Linkov's avatar
Juri Linkov committed
517
  (if (not (and open close))
518
      (let ((pair (or (assq last-command-event insert-pair-alist)
Juri Linkov's avatar
Juri Linkov committed
519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549
                      (assq (event-basic-type last-command-event)
                            insert-pair-alist))))
        (if pair
            (if (nth 2 pair)
                (setq open (nth 1 pair) close (nth 2 pair))
              (setq open (nth 0 pair) close (nth 1 pair))))))
  (if (and open close)
      (if (and transient-mark-mode mark-active)
          (progn
            (save-excursion (goto-char (region-end))       (insert close))
            (save-excursion (goto-char (region-beginning)) (insert open)))
        (if arg (setq arg (prefix-numeric-value arg))
          (setq arg 0))
        (cond ((> arg 0) (skip-chars-forward " \t"))
              ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
        (and parens-require-spaces
             (not (bobp))
             (memq (char-syntax (preceding-char)) (list ?w ?_ (char-syntax close)))
             (insert " "))
        (insert open)
        (save-excursion
          (or (eq arg 0) (forward-sexp arg))
          (insert close)
          (and parens-require-spaces
               (not (eobp))
               (memq (char-syntax (following-char)) (list ?w ?_ (char-syntax open)))
               (insert " "))))
    (insert-char (event-basic-type last-command-event)
                 (prefix-numeric-value arg))))

(defun insert-parentheses (&optional arg)
550 551
  "Enclose following ARG sexps in parentheses.
Leave point after open-paren.
552 553 554 555
A negative ARG encloses the preceding ARG sexps instead.
No argument is equivalent to zero: just insert `()' and leave point between.
If `parens-require-spaces' is non-nil, this command also inserts a space
before and after, depending on the surrounding characters.
556 557 558
If region is active, insert enclosing characters at region boundaries.

This command assumes point is not in a string or comment."
559 560
  (interactive "P")
  (insert-pair arg ?\( ?\)))
root's avatar
root committed
561

Juri Linkov's avatar
Juri Linkov committed
562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
(defun delete-pair ()
  "Delete a pair of characters enclosing the sexp that follows point."
  (interactive)
  (save-excursion (forward-sexp 1) (delete-char -1))
  (delete-char 1))

(defun raise-sexp (&optional arg)
  "Raise ARG sexps higher up the tree."
  (interactive "p")
  (let ((s (if (and transient-mark-mode mark-active)
               (buffer-substring (region-beginning) (region-end))
             (buffer-substring
              (point)
              (save-excursion (forward-sexp arg) (point))))))
    (backward-up-list 1)
    (delete-region (point) (save-excursion (forward-sexp 1) (point)))
    (save-excursion (insert s))))

root's avatar
root committed
580 581 582 583 584 585 586 587
(defun move-past-close-and-reindent ()
  "Move past next `)', delete indentation before it, then indent after it."
  (interactive)
  (up-list 1)
  (forward-char -1)
  (while (save-excursion		; this is my contribution
	   (let ((before-paren (point)))
	     (back-to-indentation)
588 589 590 591 592 593 594 595 596 597
	     (and (= (point) before-paren)
		  (progn
		    ;; Move to end of previous line.
		    (beginning-of-line)
		    (forward-char -1)
		    ;; Verify it doesn't end within a string or comment.
		    (let ((end (point))
			  state)
		      (beginning-of-line)
		      ;; Get state at start of line.
598
		      (setq state  (list 0 nil nil
599 600 601 602 603 604 605 606
					 (null (calculate-lisp-indent))
					 nil nil nil nil
					 nil))
		      ;; Parse state across the line to get state at end.
		      (setq state (parse-partial-sexp (point) end nil nil
						      state))
		      ;; Check not in string or comment.
		      (and (not (elt state 3)) (not (elt state 4))))))))
root's avatar
root committed
607 608 609
    (delete-indentation))
  (forward-char 1)
  (newline-and-indent))
610 611 612 613 614 615

(defun check-parens ()			; lame name?
  "Check for unbalanced parentheses in the current buffer.
More accurately, check the narrowed part of the buffer for unbalanced
expressions (\"sexps\") in general.  This is done according to the
current syntax table and will find unbalanced brackets or quotes as
Lute Kamstra's avatar
Lute Kamstra committed
616
appropriate.  (See Info node `(emacs)Parentheses'.)  If imbalance is
617
found, an error is signaled and point is left at the first unbalanced
Lute Kamstra's avatar
Lute Kamstra committed
618
character."
619 620 621 622 623 624 625 626 627 628
  (interactive)
  (condition-case data
      ;; Buffer can't have more than (point-max) sexps.
      (scan-sexps (point-min) (point-max))
    (scan-error (goto-char (nth 2 data))
		;; Could print (nth 1 data), which is either
		;; "Containing expression ends prematurely" or
		;; "Unbalanced parentheses", but those may not be so
		;; accurate/helpful, e.g. quotes may actually be
		;; mismatched.
629
  		(user-error "Unmatched bracket or quote"))))
root's avatar
root committed
630

631
(defun field-complete (table &optional predicate)
632
  (declare (obsolete completion-in-region "24.4"))
633 634 635 636 637 638 639 640 641 642
  (let ((minibuffer-completion-table table)
        (minibuffer-completion-predicate predicate)
        ;; This made sense for lisp-complete-symbol, but for
        ;; field-complete, this is out of place.  --Stef
        ;; (completion-annotate-function
        ;;  (unless (eq predicate 'fboundp)
        ;;    (lambda (str)
        ;;      (if (fboundp (intern-soft str)) " <f>"))))
        )
    (call-interactively 'minibuffer-complete)))
643

644
(defun lisp-complete-symbol (&optional predicate)
645 646
  "Perform completion on Lisp symbol preceding point.
Compare that symbol against the known Lisp symbols.
647 648
If no characters can be completed, display a list of possible completions.
Repeating the command at that point scrolls the list.
649

650 651 652 653 654 655 656
When called from a program, optional arg PREDICATE is a predicate
determining which symbols are considered, e.g. `commandp'.
If PREDICATE is nil, the context determines which symbols are
considered.  If the symbol starts just after an open-parenthesis, only
symbols with function definitions are considered.  Otherwise, all
symbols with function definitions, values or properties are
considered."
657
  (declare (obsolete completion-at-point "24.4"))
root's avatar
root committed
658
  (interactive)
659 660
  (let* ((data (lisp-completion-at-point predicate))
         (plist (nthcdr 3 data)))
661 662
    (if (null data)
        (minibuffer-message "Nothing to complete")
663 664
      (let ((completion-extra-properties plist))
        (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data)
665
                              (plist-get plist :predicate))))))
666

667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754
(defun lisp--local-variables-1 (vars sexp)
  "Return the vars locally bound around the witness, or nil if not found."
  (let (res)
    (while
        (unless
            (setq res
                  (pcase sexp
                    (`(,(or `let `let*) ,bindings)
                     (let ((vars vars))
                       (when (eq 'let* (car sexp))
                         (dolist (binding (cdr (reverse bindings)))
                           (push (or (car-safe binding) binding) vars)))
                       (lisp--local-variables-1
                        vars (car (cdr-safe (car (last bindings)))))))
                    (`(,(or `let `let*) ,bindings . ,body)
                     (let ((vars vars))
                       (dolist (binding bindings)
                         (push (or (car-safe binding) binding) vars))
                       (lisp--local-variables-1 vars (car (last body)))))
                    (`(lambda ,_) (setq sexp nil))
                    (`(lambda ,args . ,body)
                     (lisp--local-variables-1
                      (append args vars) (car (last body))))
                    (`(condition-case ,_ ,e) (lisp--local-variables-1 vars e))
                    (`(condition-case ,v ,_ . ,catches)
                     (lisp--local-variables-1
                      (cons v vars) (cdr (car (last catches)))))
                    (`(,_ . ,_)
                     (lisp--local-variables-1 vars (car (last sexp))))
                    (`lisp--witness--lisp (or vars '(nil)))
                    (_ nil)))
          (setq sexp (ignore-errors (butlast sexp)))))
    res))

(defun lisp--local-variables ()
  "Return a list of locally let-bound variables at point."
  (save-excursion
    (skip-syntax-backward "w_")
    (let* ((ppss (syntax-ppss))
           (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point))
                                                (or (nth 8 ppss) (point))))
           (closer ()))
      (dolist (p (nth 9 ppss))
        (push (cdr (syntax-after p)) closer))
      (setq closer (apply #'string closer))
      (let* ((sexp (car (read-from-string
                         (concat txt "lisp--witness--lisp" closer))))
             (macroexpand-advice (lambda (expander form &rest args)
                                   (condition-case nil
                                       (apply expander form args)
                                     (error form))))
             (sexp
              (unwind-protect
                  (progn
                    (advice-add 'macroexpand :around macroexpand-advice)
                    (macroexpand-all sexp))
                (advice-remove 'macroexpand macroexpand-advice)))
             (vars (lisp--local-variables-1 nil sexp)))
        (delq nil
              (mapcar (lambda (var)
                        (and (symbolp var)
                             (not (string-match (symbol-name var) "\\`[&_]"))
                             ;; Eliminate uninterned vars.
                             (intern-soft var)
                             var))
                      vars))))))

(defvar lisp--local-variables-completion-table
  ;; Use `defvar' rather than `defconst' since defconst would purecopy this
  ;; value, which would doubly fail: it would fail because purecopy can't
  ;; handle the recursive bytecode object, and it would fail because it would
  ;; move `lastpos' and `lastvars' to pure space where they'd be immutable!
  (let ((lastpos nil) (lastvars nil))
    (letrec ((hookfun (lambda ()
                        (setq lastpos nil)
                        (remove-hook 'post-command-hook hookfun))))
      (completion-table-dynamic
       (lambda (_string)
         (save-excursion
           (skip-syntax-backward "_w")
           (let ((newpos (cons (point) (current-buffer))))
             (unless (equal lastpos newpos)
               (add-hook 'post-command-hook hookfun)
               (setq lastpos newpos)
               (setq lastvars
                     (mapcar #'symbol-name (lisp--local-variables))))))
         lastvars)))))

755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805
;; FIXME: Support for Company brings in features which straddle eldoc.
;; We should consolidate this, so that major modes can provide all that
;; data all at once:
;; - a function to extract "the reference at point" (may be more complex
;;     than a mere string, to distinguish various namespaces).
;; - a function to jump to such a reference.
;; - a function to show the signature/interface of such a reference.
;; - a function to build a help-buffer about that reference.
;; FIXME: Those functions should also be used by the normal completion code in
;; the *Completions* buffer.

(defun lisp--company-doc-buffer (str)
  (let ((symbol (intern-soft str)))
    ;; FIXME: we really don't want to "display-buffer and then undo it".
    (save-window-excursion
      ;; Make sure we don't display it in another frame, otherwise
      ;; save-window-excursion won't be able to undo it.
      (let ((display-buffer-overriding-action
             '(nil . ((inhibit-switch-frame . t)))))
        (ignore-errors
          (cond
           ((fboundp symbol) (describe-function symbol))
           ((boundp symbol) (describe-variable symbol))
           ((featurep symbol) (describe-package symbol))
           ((facep symbol) (describe-face symbol))
           (t (signal 'user-error nil)))
          (help-buffer))))))

(defun lisp--company-doc-string (str)
  (let* ((symbol (intern-soft str))
         (doc (if (fboundp symbol)
                  (documentation symbol t)
                (documentation-property symbol 'variable-documentation t))))
    (and (stringp doc)
         (string-match ".*$" doc)
         (match-string 0 doc))))

(declare-function find-library-name "find-func" (library))

(defun lisp--company-location (str)
  (let ((sym (intern-soft str)))
    (cond
     ((fboundp sym) (find-definition-noselect sym nil))
     ((boundp sym) (find-definition-noselect sym 'defvar))
     ((featurep sym)
      (require 'find-func)
      (cons (find-file-noselect (find-library-name
                                 (symbol-name sym)))
            0))
     ((facep sym) (find-definition-noselect sym 'defface)))))

806
(defun lisp-completion-at-point (&optional _predicate)
807
  "Function used for `completion-at-point-functions' in `emacs-lisp-mode'."
808
  (with-syntax-table emacs-lisp-mode-syntax-table
809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824
    (let* ((pos (point))
	   (beg (condition-case nil
		    (save-excursion
		      (backward-sexp 1)
		      (skip-syntax-forward "'")
		      (point))
		  (scan-error pos)))
	   (end
	    (unless (or (eq beg (point-max))
			(member (char-syntax (char-after beg)) '(?\" ?\( ?\))))
	      (condition-case nil
		  (save-excursion
		    (goto-char beg)
		    (forward-sexp 1)
		    (when (>= (point) pos)
		      (point)))
825 826 827 828 829 830 831 832
		(scan-error pos))))
           (funpos (eq (char-before beg) ?\()) ;t if in function position.
           (table-etc
            (if (not funpos)
                ;; FIXME: We could look at the first element of the list and
                ;; use it to provide a more specific completion table in some
                ;; cases.  E.g. filter out keywords that are not understood by
                ;; the macro/function being called.
833 834 835
                (list nil (completion-table-in-turn
                           lisp--local-variables-completion-table
                           obarray)       ;Could be anything.
836
                      :annotation-function
837 838 839 840
                      (lambda (str) (if (fboundp (intern-soft str)) " <f>"))
                      :company-doc-buffer #'lisp--company-doc-buffer
                      :company-docsig #'lisp--company-doc-string
                      :company-location #'lisp--company-location)
841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856
              ;; Looks like a funcall position.  Let's double check.
              (save-excursion
                (goto-char (1- beg))
                (let ((parent
                       (condition-case nil
                           (progn (up-list -1) (forward-char 1)
                                  (let ((c (char-after)))
                                    (if (eq c ?\() ?\(
                                      (if (memq (char-syntax c) '(?w ?_))
                                          (read (current-buffer))))))
                         (error nil))))
                  (pcase parent
                    ;; FIXME: Rather than hardcode special cases here,
                    ;; we should use something like a symbol-property.
                    (`declare
                     (list t (mapcar (lambda (x) (symbol-name (car x)))
857 858 859 860 861 862
                                     (delete-dups
                                      ;; FIXME: We should include some
                                      ;; docstring with each entry.
                                      (append
                                       macro-declarations-alist
                                       defun-declarations-alist)))))
863 864 865 866 867
                    ((and (or `condition-case `condition-case-unless-debug)
                          (guard (save-excursion
                                   (ignore-errors
                                     (forward-sexp 2)
                                     (< (point) beg)))))
868 869
                     (list t obarray
                           :predicate (lambda (sym) (get sym 'error-conditions))))
870 871 872 873 874 875 876 877 878 879 880
		    ((and ?\(
			  (guard (save-excursion
				   (goto-char (1- beg))
				   (up-list -1)
				   (forward-symbol -1)
				   (looking-at "\\_<let\\*?\\_>"))))
		     (list t obarray
			   :predicate #'boundp
			   :company-doc-buffer #'lisp--company-doc-buffer
			   :company-docsig #'lisp--company-doc-string
			   :company-location #'lisp--company-location))
881 882 883 884 885 886
                    (_ (list nil obarray
                             :predicate #'fboundp
                             :company-doc-buffer #'lisp--company-doc-buffer
                             :company-docsig #'lisp--company-doc-string
                             :company-location #'lisp--company-location
                             ))))))))
887
      (when end
888 889 890
        (let ((tail (if (null (car table-etc))
                        (cdr table-etc)
                      (cons
891
                       (if (memq (char-syntax (or (char-after end) ?\s))
892 893 894 895 896 897
                                 '(?\s ?>))
                           (cadr table-etc)
                         (apply-partially 'completion-table-with-terminator
                                          " " (cadr table-etc)))
                       (cddr table-etc)))))
          `(,beg ,end ,@tail))))))
Eric S. Raymond's avatar
Eric S. Raymond committed
898 899

;;; lisp.el ends here