code.delx.au - gnu-emacs/blob - lisp/progmodes/elisp-mode.el

   1 ;;; elisp-mode.el --- Emacs Lisp mode  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1985-1986, 1999-2016 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: emacs-devel@gnu.org
   6 ;; Keywords: lisp, languages
   7 ;; Package: emacs
   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 of the License, or
  14 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; The major mode for editing Emacs Lisp code.
  27 ;; This mode is documented in the Emacs manual.
  28
  29 ;;; Code:
  30
  31 (require 'cl-generic)
  32 (require 'lisp-mode)
  33 (eval-when-compile (require 'cl-lib))
  34
  35 (define-abbrev-table 'emacs-lisp-mode-abbrev-table ()
  36   "Abbrev table for Emacs Lisp mode.
  37 It has `lisp-mode-abbrev-table' as its parent."
  38   :parents (list lisp-mode-abbrev-table))
  39
  40 (defvar emacs-lisp-mode-syntax-table
  41   (let ((table (make-syntax-table lisp--mode-syntax-table)))
  42     (modify-syntax-entry ?\[ "(]  " table)
  43     (modify-syntax-entry ?\] ")[  " table)
  44     table)
  45   "Syntax table used in `emacs-lisp-mode'.")
  46
  47 (defvar emacs-lisp-mode-map
  48   (let ((map (make-sparse-keymap "Emacs-Lisp"))
  49         (menu-map (make-sparse-keymap "Emacs-Lisp"))
  50         (lint-map (make-sparse-keymap))
  51         (prof-map (make-sparse-keymap))
  52         (tracing-map (make-sparse-keymap)))
  53     (set-keymap-parent map lisp-mode-shared-map)
  54     (define-key map "\e\t" 'completion-at-point)
  55     (define-key map "\e\C-x" 'eval-defun)
  56     (define-key map "\e\C-q" 'indent-pp-sexp)
  57     (bindings--define-key map [menu-bar emacs-lisp]
  58       (cons "Emacs-Lisp" menu-map))
  59     (bindings--define-key menu-map [eldoc]
  60       '(menu-item "Auto-Display Documentation Strings" eldoc-mode
  61                   :button (:toggle . (bound-and-true-p eldoc-mode))
  62                   :help "Display the documentation string for the item under cursor"))
  63     (bindings--define-key menu-map [checkdoc]
  64       '(menu-item "Check Documentation Strings" checkdoc
  65                   :help "Check documentation strings for style requirements"))
  66     (bindings--define-key menu-map [re-builder]
  67       '(menu-item "Construct Regexp" re-builder
  68                   :help "Construct a regexp interactively"))
  69     (bindings--define-key menu-map [tracing] (cons "Tracing" tracing-map))
  70     (bindings--define-key tracing-map [tr-a]
  71       '(menu-item "Untrace All" untrace-all
  72                   :help "Untrace all currently traced functions"))
  73     (bindings--define-key tracing-map [tr-uf]
  74       '(menu-item "Untrace Function..." untrace-function
  75                   :help "Untrace function, and possibly activate all remaining advice"))
  76     (bindings--define-key tracing-map [tr-sep] menu-bar-separator)
  77     (bindings--define-key tracing-map [tr-q]
  78       '(menu-item "Trace Function Quietly..." trace-function-background
  79                   :help "Trace the function with trace output going quietly to a buffer"))
  80     (bindings--define-key tracing-map [tr-f]
  81       '(menu-item "Trace Function..." trace-function
  82                   :help "Trace the function given as an argument"))
  83     (bindings--define-key menu-map [profiling] (cons "Profiling" prof-map))
  84     (bindings--define-key prof-map [prof-restall]
  85       '(menu-item "Remove Instrumentation for All Functions" elp-restore-all
  86                   :help "Restore the original definitions of all functions being profiled"))
  87     (bindings--define-key prof-map [prof-restfunc]
  88       '(menu-item "Remove Instrumentation for Function..." elp-restore-function
  89                   :help "Restore an instrumented function to its original definition"))
  90
  91     (bindings--define-key prof-map [sep-rem] menu-bar-separator)
  92     (bindings--define-key prof-map [prof-resall]
  93       '(menu-item "Reset Counters for All Functions" elp-reset-all
  94                   :help "Reset the profiling information for all functions being profiled"))
  95     (bindings--define-key prof-map [prof-resfunc]
  96       '(menu-item "Reset Counters for Function..." elp-reset-function
  97                   :help "Reset the profiling information for a function"))
  98     (bindings--define-key prof-map [prof-res]
  99       '(menu-item "Show Profiling Results" elp-results
 100                   :help "Display current profiling results"))
 101     (bindings--define-key prof-map [prof-pack]
 102       '(menu-item "Instrument Package..." elp-instrument-package
 103                   :help "Instrument for profiling all function that start with a prefix"))
 104     (bindings--define-key prof-map [prof-func]
 105       '(menu-item "Instrument Function..." elp-instrument-function
 106                   :help "Instrument a function for profiling"))
 107     ;; Maybe this should be in a separate submenu from the ELP stuff?
 108     (bindings--define-key prof-map [sep-natprof] menu-bar-separator)
 109     (bindings--define-key prof-map [prof-natprof-stop]
 110       '(menu-item "Stop Native Profiler" profiler-stop
 111                   :help "Stop recording profiling information"
 112                   :enable (and (featurep 'profiler)
 113                                (profiler-running-p))))
 114     (bindings--define-key prof-map [prof-natprof-report]
 115       '(menu-item "Show Profiler Report" profiler-report
 116                   :help "Show the current profiler report"
 117                   :enable (and (featurep 'profiler)
 118                                (profiler-running-p))))
 119     (bindings--define-key prof-map [prof-natprof-start]
 120       '(menu-item "Start Native Profiler..." profiler-start
 121                   :help "Start recording profiling information"))
 122
 123     (bindings--define-key menu-map [lint] (cons "Linting" lint-map))
 124     (bindings--define-key lint-map [lint-di]
 125       '(menu-item "Lint Directory..." elint-directory
 126                   :help "Lint a directory"))
 127     (bindings--define-key lint-map [lint-f]
 128       '(menu-item "Lint File..." elint-file
 129                   :help "Lint a file"))
 130     (bindings--define-key lint-map [lint-b]
 131       '(menu-item "Lint Buffer" elint-current-buffer
 132                   :help "Lint the current buffer"))
 133     (bindings--define-key lint-map [lint-d]
 134       '(menu-item "Lint Defun" elint-defun
 135                   :help "Lint the function at point"))
 136     (bindings--define-key menu-map [edebug-defun]
 137       '(menu-item "Instrument Function for Debugging" edebug-defun
 138                   :help "Evaluate the top level form point is in, stepping through with Edebug"
 139                   :keys "C-u C-M-x"))
 140     (bindings--define-key menu-map [separator-byte] menu-bar-separator)
 141     (bindings--define-key menu-map [disas]
 142       '(menu-item "Disassemble Byte Compiled Object..." disassemble
 143                   :help "Print disassembled code for OBJECT in a buffer"))
 144     (bindings--define-key menu-map [byte-recompile]
 145       '(menu-item "Byte-recompile Directory..." byte-recompile-directory
 146                   :help "Recompile every `.el' file in DIRECTORY that needs recompilation"))
 147     (bindings--define-key menu-map [emacs-byte-compile-and-load]
 148       '(menu-item "Byte-compile and Load" emacs-lisp-byte-compile-and-load
 149                   :help "Byte-compile the current file (if it has changed), then load compiled code"))
 150     (bindings--define-key menu-map [byte-compile]
 151       '(menu-item "Byte-compile This File" emacs-lisp-byte-compile
 152                   :help "Byte compile the file containing the current buffer"))
 153     (bindings--define-key menu-map [separator-eval] menu-bar-separator)
 154     (bindings--define-key menu-map [ielm]
 155       '(menu-item "Interactive Expression Evaluation" ielm
 156                   :help "Interactively evaluate Emacs Lisp expressions"))
 157     (bindings--define-key menu-map [eval-buffer]
 158       '(menu-item "Evaluate Buffer" eval-buffer
 159                   :help "Execute the current buffer as Lisp code"))
 160     (bindings--define-key menu-map [eval-region]
 161       '(menu-item "Evaluate Region" eval-region
 162                   :help "Execute the region as Lisp code"
 163                   :enable mark-active))
 164     (bindings--define-key menu-map [eval-sexp]
 165       '(menu-item "Evaluate Last S-expression" eval-last-sexp
 166                   :help "Evaluate sexp before point; print value in echo area"))
 167     (bindings--define-key menu-map [separator-format] menu-bar-separator)
 168     (bindings--define-key menu-map [comment-region]
 169       '(menu-item "Comment Out Region" comment-region
 170                   :help "Comment or uncomment each line in the region"
 171                   :enable mark-active))
 172     (bindings--define-key menu-map [indent-region]
 173       '(menu-item "Indent Region" indent-region
 174                   :help "Indent each nonblank line in the region"
 175                   :enable mark-active))
 176     (bindings--define-key menu-map [indent-line]
 177       '(menu-item "Indent Line" lisp-indent-line))
 178     map)
 179   "Keymap for Emacs Lisp mode.
 180 All commands in `lisp-mode-shared-map' are inherited by this map.")
 181
 182 (defun emacs-lisp-byte-compile ()
 183   "Byte compile the file containing the current buffer."
 184   (interactive)
 185   (if buffer-file-name
 186       (byte-compile-file buffer-file-name)
 187     (error "The buffer must be saved in a file first")))
 188
 189 (defun emacs-lisp-byte-compile-and-load ()
 190   "Byte-compile the current file (if it has changed), then load compiled code."
 191   (interactive)
 192   (or buffer-file-name
 193       (error "The buffer must be saved in a file first"))
 194   (require 'bytecomp)
 195   ;; Recompile if file or buffer has changed since last compilation.
 196   (if (and (buffer-modified-p)
 197            (y-or-n-p (format "Save buffer %s first? " (buffer-name))))
 198       (save-buffer))
 199   (byte-recompile-file buffer-file-name nil 0 t))
 200
 201 (defun emacs-lisp-macroexpand ()
 202   "Macroexpand the form after point.
 203 Comments in the form will be lost."
 204   (interactive)
 205   (let* ((start (point))
 206          (exp (read (current-buffer)))
 207          ;; Compute it before, since it may signal errors.
 208          (new (macroexpand-1 exp)))
 209     (if (equal exp new)
 210         (message "Not a macro call, nothing to expand")
 211       (delete-region start (point))
 212       (pp new (current-buffer))
 213       (if (bolp) (delete-char -1))
 214       (indent-region start (point)))))
 215
 216 (defcustom emacs-lisp-mode-hook nil
 217   "Hook run when entering Emacs Lisp mode."
 218   :options '(eldoc-mode imenu-add-menubar-index checkdoc-minor-mode)
 219   :type 'hook
 220   :group 'lisp)
 221
 222 ;;;###autoload
 223 (define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp"
 224   "Major mode for editing Lisp code to run in Emacs.
 225 Commands:
 226 Delete converts tabs to spaces as it moves back.
 227 Blank lines separate paragraphs.  Semicolons start comments.
 228
 229 \\{emacs-lisp-mode-map}"
 230   :group 'lisp
 231   (defvar project-vc-external-roots-function)
 232   (lisp-mode-variables nil nil 'elisp)
 233   (add-hook 'after-load-functions #'elisp--font-lock-flush-elisp-buffers)
 234   (setq-local electric-pair-text-pairs
 235               (append '((?\` . ?\') (?‘ . ?’)) electric-pair-text-pairs))
 236   (setq-local electric-quote-string t)
 237   (setq imenu-case-fold-search nil)
 238   (add-function :before-until (local 'eldoc-documentation-function)
 239                 #'elisp-eldoc-documentation-function)
 240   (add-hook 'xref-backend-functions #'elisp--xref-backend nil t)
 241   (setq-local project-vc-external-roots-function #'elisp-load-path-roots)
 242   (add-hook 'completion-at-point-functions
 243             #'elisp-completion-at-point nil 'local))
 244
 245 ;; Font-locking support.
 246
 247 (defun elisp--font-lock-flush-elisp-buffers (&optional file)
 248   ;; FIXME: Aren't we only ever called from after-load-functions?
 249   ;; Don't flush during load unless called from after-load-functions.
 250   ;; In that case, FILE is non-nil.  It's somehow strange that
 251   ;; load-in-progress is t when an after-load-function is called since
 252   ;; that should run *after* the load...
 253   (when (or (not load-in-progress) file)
 254     ;; FIXME: If the loaded file did not define any macros, there shouldn't
 255     ;; be any need to font-lock-flush all the Elisp buffers.
 256     (dolist (buf (buffer-list))
 257       (with-current-buffer buf
 258         (when (derived-mode-p 'emacs-lisp-mode)
 259           ;; So as to take into account new macros that may have been defined
 260           ;; by the just-loaded file.
 261           (font-lock-flush))))))
 262
 263 ;;; Completion at point for Elisp
 264
 265 (defun elisp--local-variables-1 (vars sexp)
 266   "Return the vars locally bound around the witness, or nil if not found."
 267   (let (res)
 268     (while
 269         (unless
 270             (setq res
 271                   (pcase sexp
 272                     (`(,(or `let `let*) ,bindings)
 273                      (let ((vars vars))
 274                        (when (eq 'let* (car sexp))
 275                          (dolist (binding (cdr (reverse bindings)))
 276                            (push (or (car-safe binding) binding) vars)))
 277                        (elisp--local-variables-1
 278                         vars (car (cdr-safe (car (last bindings)))))))
 279                     (`(,(or `let `let*) ,bindings . ,body)
 280                      (let ((vars vars))
 281                        (dolist (binding bindings)
 282                          (push (or (car-safe binding) binding) vars))
 283                        (elisp--local-variables-1 vars (car (last body)))))
 284                     (`(lambda ,_args)
 285                      ;; FIXME: Look for the witness inside `args'.
 286                      (setq sexp nil))
 287                     (`(lambda ,args . ,body)
 288                      (elisp--local-variables-1
 289                       (append (remq '&optional (remq '&rest args)) vars)
 290                       (car (last body))))
 291                     (`(condition-case ,_ ,e) (elisp--local-variables-1 vars e))
 292                     (`(condition-case ,v ,_ . ,catches)
 293                      (elisp--local-variables-1
 294                       (cons v vars) (cdr (car (last catches)))))
 295                     (`(quote . ,_)
 296                      ;; FIXME: Look for the witness inside sexp.
 297                      (setq sexp nil))
 298                     ;; FIXME: Handle `cond'.
 299                     (`(,_ . ,_)
 300                      (elisp--local-variables-1 vars (car (last sexp))))
 301                     (`elisp--witness--lisp (or vars '(nil)))
 302                     (_ nil)))
 303           ;; We didn't find the witness in the last element so we try to
 304           ;; backtrack to the last-but-one.
 305           (setq sexp (ignore-errors (butlast sexp)))))
 306     res))
 307
 308 (defun elisp--local-variables ()
 309   "Return a list of locally let-bound variables at point."
 310   (save-excursion
 311     (skip-syntax-backward "w_")
 312     (let* ((ppss (syntax-ppss))
 313            (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point))
 314                                                 (or (nth 8 ppss) (point))))
 315            (closer ()))
 316       (dolist (p (nth 9 ppss))
 317         (push (cdr (syntax-after p)) closer))
 318       (setq closer (apply #'string closer))
 319       (let* ((sexp (condition-case nil
 320                        (car (read-from-string
 321                              (concat txt "elisp--witness--lisp" closer)))
 322                      ((invalid-read-syntax end-of-file) nil)))
 323              (macroexpand-advice (lambda (expander form &rest args)
 324                                    (condition-case nil
 325                                        (apply expander form args)
 326                                      (error form))))
 327              (sexp
 328               (unwind-protect
 329                   (progn
 330                     (advice-add 'macroexpand :around macroexpand-advice)
 331                     (macroexpand-all sexp))
 332                 (advice-remove 'macroexpand macroexpand-advice)))
 333              (vars (elisp--local-variables-1 nil sexp)))
 334         (delq nil
 335               (mapcar (lambda (var)
 336                         (and (symbolp var)
 337                              (not (string-match (symbol-name var) "\\`[&_]"))
 338                              ;; Eliminate uninterned vars.
 339                              (intern-soft var)
 340                              var))
 341                       vars))))))
 342
 343 (defvar elisp--local-variables-completion-table
 344   ;; Use `defvar' rather than `defconst' since defconst would purecopy this
 345   ;; value, which would doubly fail: it would fail because purecopy can't
 346   ;; handle the recursive bytecode object, and it would fail because it would
 347   ;; move `lastpos' and `lastvars' to pure space where they'd be immutable!
 348   (let ((lastpos nil) (lastvars nil))
 349     (letrec ((hookfun (lambda ()
 350                         (setq lastpos nil)
 351                         (remove-hook 'post-command-hook hookfun))))
 352       (completion-table-dynamic
 353        (lambda (_string)
 354          (save-excursion
 355            (skip-syntax-backward "_w")
 356            (let ((newpos (cons (point) (current-buffer))))
 357              (unless (equal lastpos newpos)
 358                (add-hook 'post-command-hook hookfun)
 359                (setq lastpos newpos)
 360                (setq lastvars
 361                      (mapcar #'symbol-name (elisp--local-variables))))))
 362          lastvars)))))
 363
 364 (defun elisp--expect-function-p (pos)
 365   "Return non-nil if the symbol at point is expected to be a function."
 366   (or
 367    (and (eq (char-before pos) ?')
 368         (eq (char-before (1- pos)) ?#))
 369    (save-excursion
 370      (let ((parent (nth 1 (syntax-ppss pos))))
 371        (when parent
 372          (goto-char parent)
 373          (and
 374           (looking-at (concat "(\\(cl-\\)?"
 375                               (regexp-opt '("declare-function"
 376                                             "function" "defadvice"
 377                                             "callf" "callf2"
 378                                             "defsetf"))
 379                               "[ \t\r\n]+"))
 380           (eq (match-end 0) pos)))))))
 381
 382 (defun elisp--form-quoted-p (pos)
 383   "Return non-nil if the form at POS is not evaluated.
 384 It can be quoted, or be inside a quoted form."
 385   ;; FIXME: Do some macro expansion maybe.
 386   (save-excursion
 387     (let ((state (syntax-ppss pos)))
 388       (or (nth 8 state)   ; Code inside strings usually isn't evaluated.
 389           ;; FIXME: The 9th element is undocumented.
 390           (let ((nesting (cons (point) (reverse (nth 9 state))))
 391                 res)
 392             (while (and nesting (not res))
 393               (goto-char (pop nesting))
 394               (cond
 395                ((or (eq (char-after) ?\[)
 396                     (progn
 397                       (skip-chars-backward " ")
 398                       (memq (char-before) '(?' ?` ?‘))))
 399                 (setq res t))
 400                ((eq (char-before) ?,)
 401                 (setq nesting nil))))
 402             res)))))
 403
 404 ;; FIXME: Support for Company brings in features which straddle eldoc.
 405 ;; We should consolidate this, so that major modes can provide all that
 406 ;; data all at once:
 407 ;; - a function to extract "the reference at point" (may be more complex
 408 ;;     than a mere string, to distinguish various namespaces).
 409 ;; - a function to jump to such a reference.
 410 ;; - a function to show the signature/interface of such a reference.
 411 ;; - a function to build a help-buffer about that reference.
 412 ;; FIXME: Those functions should also be used by the normal completion code in
 413 ;; the *Completions* buffer.
 414
 415 (defun elisp--company-doc-buffer (str)
 416   (let ((symbol (intern-soft str)))
 417     ;; FIXME: we really don't want to "display-buffer and then undo it".
 418     (save-window-excursion
 419       ;; Make sure we don't display it in another frame, otherwise
 420       ;; save-window-excursion won't be able to undo it.
 421       (let ((display-buffer-overriding-action
 422              '(nil . ((inhibit-switch-frame . t)))))
 423         (ignore-errors
 424           (cond
 425            ((fboundp symbol) (describe-function symbol))
 426            ((boundp symbol) (describe-variable symbol))
 427            ((featurep symbol) (describe-package symbol))
 428            ((facep symbol) (describe-face symbol))
 429            (t (signal 'user-error nil)))
 430           (help-buffer))))))
 431
 432 (defun elisp--company-doc-string (str)
 433   (let* ((symbol (intern-soft str))
 434          (doc (if (fboundp symbol)
 435                   (documentation symbol t)
 436                 (documentation-property symbol 'variable-documentation t))))
 437     (and (stringp doc)
 438          (string-match ".*$" doc)
 439          (match-string 0 doc))))
 440
 441 ;; can't (require 'find-func) in a preloaded file
 442 (declare-function find-library-name "find-func" (library))
 443 (declare-function find-function-library "find-func" (function &optional l-o v))
 444
 445 (defun elisp--company-location (str)
 446   (let ((sym (intern-soft str)))
 447     (cond
 448      ((fboundp sym) (find-definition-noselect sym nil))
 449      ((boundp sym) (find-definition-noselect sym 'defvar))
 450      ((featurep sym)
 451       (require 'find-func)
 452       (cons (find-file-noselect (find-library-name
 453                                  (symbol-name sym)))
 454             0))
 455      ((facep sym) (find-definition-noselect sym 'defface)))))
 456
 457 (defun elisp-completion-at-point ()
 458   "Function used for `completion-at-point-functions' in `emacs-lisp-mode'."
 459   (with-syntax-table emacs-lisp-mode-syntax-table
 460     (let* ((pos (point))
 461            (beg (condition-case nil
 462                     (save-excursion
 463                       (backward-sexp 1)
 464                       (skip-chars-forward "`',‘#")
 465                       (point))
 466                   (scan-error pos)))
 467            (end
 468             (unless (or (eq beg (point-max))
 469                         (member (char-syntax (char-after beg))
 470                                 '(?\s ?\" ?\( ?\))))
 471               (condition-case nil
 472                   (save-excursion
 473                     (goto-char beg)
 474                     (forward-sexp 1)
 475                     (skip-chars-backward "'’")
 476                     (when (>= (point) pos)
 477                       (point)))
 478                 (scan-error pos))))
 479            ;; t if in function position.
 480            (funpos (eq (char-before beg) ?\())
 481            (quoted (elisp--form-quoted-p beg)))
 482       (when (and end (or (not (nth 8 (syntax-ppss)))
 483                          (memq (char-before beg) '(?` ?‘))))
 484         (let ((table-etc
 485                (if (or (not funpos) quoted)
 486                    ;; FIXME: We could look at the first element of the list and
 487                    ;; use it to provide a more specific completion table in some
 488                    ;; cases.  E.g. filter out keywords that are not understood by
 489                    ;; the macro/function being called.
 490                    (cond
 491                     ((elisp--expect-function-p beg)
 492                      (list nil obarray
 493                            :predicate #'fboundp
 494                            :company-doc-buffer #'elisp--company-doc-buffer
 495                            :company-docsig #'elisp--company-doc-string
 496                            :company-location #'elisp--company-location))
 497                     (quoted
 498                      (list nil obarray
 499                            ;; Don't include all symbols (bug#16646).
 500                            :predicate (lambda (sym)
 501                                         (or (boundp sym)
 502                                             (fboundp sym)
 503                                             (featurep sym)
 504                                             (symbol-plist sym)))
 505                            :annotation-function
 506                            (lambda (str) (if (fboundp (intern-soft str)) " <f>"))
 507                            :company-doc-buffer #'elisp--company-doc-buffer
 508                            :company-docsig #'elisp--company-doc-string
 509                            :company-location #'elisp--company-location))
 510                     (t
 511                      (list nil (completion-table-merge
 512                                 elisp--local-variables-completion-table
 513                                 (apply-partially #'completion-table-with-predicate
 514                                                  obarray
 515                                                  #'boundp
 516                                                  'strict))
 517                            :company-doc-buffer #'elisp--company-doc-buffer
 518                            :company-docsig #'elisp--company-doc-string
 519                            :company-location #'elisp--company-location)))
 520                  ;; Looks like a funcall position.  Let's double check.
 521                  (save-excursion
 522                    (goto-char (1- beg))
 523                    (let ((parent
 524                           (condition-case nil
 525                               (progn (up-list -1) (forward-char 1)
 526                                      (let ((c (char-after)))
 527                                        (if (eq c ?\() ?\(
 528                                          (if (memq (char-syntax c) '(?w ?_))
 529                                              (read (current-buffer))))))
 530                             (error nil))))
 531                      (pcase parent
 532                        ;; FIXME: Rather than hardcode special cases here,
 533                        ;; we should use something like a symbol-property.
 534                        (`declare
 535                         (list t (mapcar (lambda (x) (symbol-name (car x)))
 536                                         (delete-dups
 537                                          ;; FIXME: We should include some
 538                                          ;; docstring with each entry.
 539                                          (append
 540                                           macro-declarations-alist
 541                                           defun-declarations-alist)))))
 542                        ((and (or `condition-case `condition-case-unless-debug)
 543                              (guard (save-excursion
 544                                       (ignore-errors
 545                                         (forward-sexp 2)
 546                                         (< (point) beg)))))
 547                         (list t obarray
 548                               :predicate (lambda (sym) (get sym 'error-conditions))))
 549                        ((and (or ?\( `let `let*)
 550                              (guard (save-excursion
 551                                       (goto-char (1- beg))
 552                                       (when (eq parent ?\()
 553                                         (up-list -1))
 554                                       (forward-symbol -1)
 555                                       (looking-at "\\_<let\\*?\\_>"))))
 556                         (list t obarray
 557                               :predicate #'boundp
 558                               :company-doc-buffer #'elisp--company-doc-buffer
 559                               :company-docsig #'elisp--company-doc-string
 560                               :company-location #'elisp--company-location))
 561                        (_ (list nil obarray
 562                                 :predicate #'fboundp
 563                                 :company-doc-buffer #'elisp--company-doc-buffer
 564                                 :company-docsig #'elisp--company-doc-string
 565                                 :company-location #'elisp--company-location
 566                                 ))))))))
 567           (nconc (list beg end)
 568                  (if (null (car table-etc))
 569                      (cdr table-etc)
 570                    (cons
 571                     (if (memq (char-syntax (or (char-after end) ?\s))
 572                               '(?\s ?>))
 573                         (cadr table-etc)
 574                       (apply-partially 'completion-table-with-terminator
 575                                        " " (cadr table-etc)))
 576                     (cddr table-etc)))))))))
 577
 578 (defun lisp-completion-at-point (_predicate)
 579   (declare (obsolete elisp-completion-at-point "25.1"))
 580   (elisp-completion-at-point))
 581
 582 ;;; Xref backend
 583
 584 (declare-function xref-make-bogus-location "xref" (message))
 585 (declare-function xref-make "xref" (summary location))
 586 (declare-function xref-collect-references "xref" (symbol dir))
 587
 588 (defun elisp--xref-backend () 'elisp)
 589
 590 ;; WORKAROUND: This is nominally a constant, but the text properties
 591 ;; are not preserved thru dump if use defconst.  See bug#21237.
 592 (defvar elisp--xref-format
 593   (let ((str "(%s %s)"))
 594     (put-text-property 1 3 'face 'font-lock-keyword-face str)
 595     (put-text-property 4 6 'face 'font-lock-function-name-face str)
 596     str))
 597
 598 ;; WORKAROUND: This is nominally a constant, but the text properties
 599 ;; are not preserved thru dump if use defconst.  See bug#21237.
 600 (defvar elisp--xref-format-extra
 601   (let ((str "(%s %s %s)"))
 602     (put-text-property 1 3 'face 'font-lock-keyword-face str)
 603     (put-text-property 4 6 'face 'font-lock-function-name-face str)
 604     str))
 605
 606 (defvar find-feature-regexp);; in find-func.el
 607
 608 (defun elisp--xref-make-xref (type symbol file &optional summary)
 609   "Return an xref for TYPE SYMBOL in FILE.
 610 TYPE must be a type in `find-function-regexp-alist' (use nil for
 611 'defun).  If SUMMARY is non-nil, use it for the summary;
 612 otherwise build the summary from TYPE and SYMBOL."
 613   (xref-make (or summary
 614                  (format elisp--xref-format (or type 'defun) symbol))
 615              (xref-make-elisp-location symbol type file)))
 616
 617 (defvar elisp-xref-find-def-functions nil
 618   "List of functions to be run from `elisp--xref-find-definitions' to add additional xrefs.
 619 Called with one arg; the symbol whose definition is desired.
 620 Each function should return a list of xrefs, or nil; the first
 621 non-nil result supercedes the xrefs produced by
 622 `elisp--xref-find-definitions'.")
 623
 624 (cl-defmethod xref-backend-definitions ((_backend (eql elisp)) identifier)
 625   (require 'find-func)
 626   ;; FIXME: use information in source near point to filter results:
 627   ;; (dvc-log-edit ...) - exclude 'feature
 628   ;; (require 'dvc-log-edit) - only 'feature
 629   ;; Semantic may provide additional information
 630   ;;
 631   (let ((sym (intern-soft identifier)))
 632     (when sym
 633       (elisp--xref-find-definitions sym))))
 634
 635 (defun elisp--xref-find-definitions (symbol)
 636   ;; The file name is not known when `symbol' is defined via interactive eval.
 637   (let (xrefs)
 638
 639     (let ((temp elisp-xref-find-def-functions))
 640       (while (and (null xrefs)
 641                   temp)
 642         (setq xrefs (append xrefs (funcall (pop temp) symbol)))))
 643
 644     (unless xrefs
 645       ;; alphabetical by result type symbol
 646
 647       ;; FIXME: advised function; list of advice functions
 648       ;; FIXME: aliased variable
 649
 650       ;; Coding system symbols do not appear in ‘load-history’,
 651       ;; so we can’t get a location for them.
 652
 653       (when (and (symbolp symbol)
 654                  (symbol-function symbol)
 655                  (symbolp (symbol-function symbol)))
 656         ;; aliased function
 657         (let* ((alias-symbol symbol)
 658                (alias-file (symbol-file alias-symbol))
 659                (real-symbol  (symbol-function symbol))
 660                (real-file (find-lisp-object-file-name real-symbol 'defun)))
 661
 662           (when real-file
 663             (push (elisp--xref-make-xref nil real-symbol real-file) xrefs))
 664
 665           (when alias-file
 666             (push (elisp--xref-make-xref 'defalias alias-symbol alias-file) xrefs))))
 667
 668       (when (facep symbol)
 669         (let ((file (find-lisp-object-file-name symbol 'defface)))
 670           (when file
 671             (push (elisp--xref-make-xref 'defface symbol file) xrefs))))
 672
 673       (when (fboundp symbol)
 674         (let ((file (find-lisp-object-file-name symbol (symbol-function symbol)))
 675               generic doc)
 676           (when file
 677             (cond
 678              ((eq file 'C-source)
 679               ;; First call to find-lisp-object-file-name for an object
 680               ;; defined in C; the doc strings from the C source have
 681               ;; not been loaded yet.  Second call will return "src/*.c"
 682               ;; in file; handled by 't' case below.
 683               (push (elisp--xref-make-xref nil symbol (help-C-file-name (symbol-function symbol) 'subr)) xrefs))
 684
 685              ((and (setq doc (documentation symbol t))
 686                    ;; This doc string is defined in cl-macs.el cl-defstruct
 687                    (string-match "Constructor for objects of type `\\(.*\\)'" doc))
 688               ;; `symbol' is a name for the default constructor created by
 689               ;; cl-defstruct, so return the location of the cl-defstruct.
 690               (let* ((type-name (match-string 1 doc))
 691                      (type-symbol (intern type-name))
 692                      (file (find-lisp-object-file-name type-symbol 'define-type))
 693                      (summary (format elisp--xref-format-extra
 694                                       'cl-defstruct
 695                                       (concat "(" type-name)
 696                                       (concat "(:constructor " (symbol-name symbol) "))"))))
 697                 (push (elisp--xref-make-xref 'define-type type-symbol file summary) xrefs)
 698                 ))
 699
 700              ((setq generic (cl--generic symbol))
 701               ;; FIXME: move this to elisp-xref-find-def-functions, in cl-generic.el
 702
 703               ;; A generic function. If there is a default method, it
 704               ;; will appear in the method table, with no
 705               ;; specializers.
 706               ;;
 707               ;; If the default method is declared by the cl-defgeneric
 708               ;; declaration, it will have the same location as the
 709               ;; cl-defgeneric, so we want to exclude it from the
 710               ;; result. In this case, it will have a null doc
 711               ;; string. User declarations of default methods may also
 712               ;; have null doc strings, but we hope that is
 713               ;; rare. Perhaps this heuristic will discourage that.
 714               (dolist (method (cl--generic-method-table generic))
 715                 (let* ((info (cl--generic-method-info method));; qual-string combined-args doconly
 716                        (specializers (cl--generic-method-specializers method))
 717                        (non-default nil)
 718                        (met-name (cons symbol specializers))
 719                        (file (find-lisp-object-file-name met-name 'cl-defmethod)))
 720                   (dolist (item specializers)
 721                     ;; default method has all 't' in specializers
 722                     (setq non-default (or non-default (not (equal t item)))))
 723
 724                   (when (and file
 725                              (or non-default
 726                                  (nth 2 info))) ;; assuming only co-located default has null doc string
 727                     (if specializers
 728                         (let ((summary (format elisp--xref-format-extra 'cl-defmethod symbol (nth 1 info))))
 729                           (push (elisp--xref-make-xref 'cl-defmethod met-name file summary) xrefs))
 730
 731                       (let ((summary (format elisp--xref-format-extra 'cl-defmethod symbol "()")))
 732                         (push (elisp--xref-make-xref 'cl-defmethod met-name file summary) xrefs))))
 733                   ))
 734
 735               (if (and (setq doc (documentation symbol t))
 736                        ;; This doc string is created somewhere in
 737                        ;; cl--generic-make-function for an implicit
 738                        ;; defgeneric.
 739                        (string-match "\n\n(fn ARG &rest ARGS)" doc))
 740                   ;; This symbol is an implicitly defined defgeneric, so
 741                   ;; don't return it.
 742                   nil
 743                 (push (elisp--xref-make-xref 'cl-defgeneric symbol file) xrefs))
 744               )
 745
 746              (t
 747               (push (elisp--xref-make-xref nil symbol file) xrefs))
 748              ))))
 749
 750       (when (boundp symbol)
 751         ;; A variable
 752         (let ((file (find-lisp-object-file-name symbol 'defvar)))
 753           (when file
 754             (cond
 755              ((eq file 'C-source)
 756               ;; The doc strings from the C source have not been loaded
 757               ;; yet; help-C-file-name does that.  Second call will
 758               ;; return "src/*.c" in file; handled below.
 759               (push (elisp--xref-make-xref 'defvar symbol (help-C-file-name symbol 'var)) xrefs))
 760
 761              ((string= "src/" (substring file 0 4))
 762               ;; The variable is defined in a C source file; don't check
 763               ;; for define-minor-mode.
 764               (push (elisp--xref-make-xref 'defvar symbol file) xrefs))
 765
 766              ((memq symbol minor-mode-list)
 767               ;; The symbol is a minor mode. These should be defined by
 768               ;; "define-minor-mode", which means the variable and the
 769               ;; function are declared in the same place. So we return only
 770               ;; the function, arbitrarily.
 771               ;;
 772               ;; There is an exception, when the variable is defined in C
 773               ;; code, as for abbrev-mode.
 774               ;;
 775               ;; IMPROVEME: If the user is searching for the identifier at
 776               ;; point, we can determine whether it is a variable or
 777               ;; function by looking at the source code near point.
 778               ;;
 779               ;; IMPROVEME: The user may actually be asking "do any
 780               ;; variables by this name exist"; we need a way to specify
 781               ;; that.
 782               nil)
 783
 784              (t
 785               (push (elisp--xref-make-xref 'defvar symbol file) xrefs))
 786
 787              ))))
 788
 789       (when (featurep symbol)
 790         (let ((file (ignore-errors
 791                       (find-library-name (symbol-name symbol)))))
 792           (when file
 793             (push (elisp--xref-make-xref 'feature symbol file) xrefs))))
 794       );; 'unless xrefs'
 795
 796     xrefs))
 797
 798 (declare-function project-external-roots "project")
 799
 800 (cl-defmethod xref-backend-apropos ((_backend (eql elisp)) regexp)
 801   (apply #'nconc
 802          (let (lst)
 803            (dolist (sym (apropos-internal regexp))
 804             (push (elisp--xref-find-definitions sym) lst))
 805            (nreverse lst))))
 806
 807 (defvar elisp--xref-identifier-completion-table
 808   (apply-partially #'completion-table-with-predicate
 809                    obarray
 810                    (lambda (sym)
 811                      (or (boundp sym)
 812                          (fboundp sym)
 813                          (featurep sym)
 814                          (facep sym)))
 815                    'strict))
 816
 817 (cl-defmethod xref-backend-identifier-completion-table ((_backend (eql elisp)))
 818   elisp--xref-identifier-completion-table)
 819
 820 (cl-defstruct (xref-elisp-location
 821                (:constructor xref-make-elisp-location (symbol type file)))
 822   "Location of an Emacs Lisp symbol definition."
 823   symbol type file)
 824
 825 (cl-defmethod xref-location-marker ((l xref-elisp-location))
 826   (pcase-let (((cl-struct xref-elisp-location symbol type file) l))
 827     (let ((buffer-point (find-function-search-for-symbol symbol type file)))
 828       (with-current-buffer (car buffer-point)
 829         (goto-char (or (cdr buffer-point) (point-min)))
 830         (point-marker)))))
 831
 832 (cl-defmethod xref-location-group ((l xref-elisp-location))
 833   (xref-elisp-location-file l))
 834
 835 (defun elisp-load-path-roots ()
 836   (if (boundp 'package-user-dir)
 837       (cons package-user-dir load-path)
 838     load-path))
 839
 840 ;;; Elisp Interaction mode
 841
 842 (defvar lisp-interaction-mode-map
 843   (let ((map (make-sparse-keymap))
 844         (menu-map (make-sparse-keymap "Lisp-Interaction")))
 845     (set-keymap-parent map lisp-mode-shared-map)
 846     (define-key map "\e\C-x" 'eval-defun)
 847     (define-key map "\e\C-q" 'indent-pp-sexp)
 848     (define-key map "\e\t" 'completion-at-point)
 849     (define-key map "\n" 'eval-print-last-sexp)
 850     (bindings--define-key map [menu-bar lisp-interaction]
 851       (cons "Lisp-Interaction" menu-map))
 852     (bindings--define-key menu-map [eval-defun]
 853       '(menu-item "Evaluate Defun" eval-defun
 854                   :help "Evaluate the top-level form containing point, or after point"))
 855     (bindings--define-key menu-map [eval-print-last-sexp]
 856       '(menu-item "Evaluate and Print" eval-print-last-sexp
 857                   :help "Evaluate sexp before point; print value into current buffer"))
 858     (bindings--define-key menu-map [edebug-defun-lisp-interaction]
 859       '(menu-item "Instrument Function for Debugging" edebug-defun
 860                   :help "Evaluate the top level form point is in, stepping through with Edebug"
 861                   :keys "C-u C-M-x"))
 862     (bindings--define-key menu-map [indent-pp-sexp]
 863       '(menu-item "Indent or Pretty-Print" indent-pp-sexp
 864                   :help "Indent each line of the list starting just after point, or prettyprint it"))
 865     (bindings--define-key menu-map [complete-symbol]
 866       '(menu-item "Complete Lisp Symbol" completion-at-point
 867                   :help "Perform completion on Lisp symbol preceding point"))
 868     map)
 869   "Keymap for Lisp Interaction mode.
 870 All commands in `lisp-mode-shared-map' are inherited by this map.")
 871
 872 (define-derived-mode lisp-interaction-mode emacs-lisp-mode "Lisp Interaction"
 873   "Major mode for typing and evaluating Lisp forms.
 874 Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression
 875 before point, and prints its value into the buffer, advancing point.
 876 Note that printing is controlled by `eval-expression-print-length'
 877 and `eval-expression-print-level'.
 878
 879 Commands:
 880 Delete converts tabs to spaces as it moves back.
 881 Paragraphs are separated only by blank lines.
 882 Semicolons start comments.
 883
 884 \\{lisp-interaction-mode-map}"
 885   :abbrev-table nil)
 886
 887 ;;; Emacs Lisp Byte-Code mode
 888
 889 (eval-and-compile
 890   (defconst emacs-list-byte-code-comment-re
 891     (concat "\\(#\\)@\\([0-9]+\\) "
 892             ;; Make sure it's a docstring and not a lazy-loaded byte-code.
 893             "\\(?:[^(]\\|([^\"]\\)")))
 894
 895 (defun elisp--byte-code-comment (end &optional _point)
 896   "Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files."
 897   (let ((ppss (syntax-ppss)))
 898     (when (and (nth 4 ppss)
 899                (eq (char-after (nth 8 ppss)) ?#))
 900       (let* ((n (save-excursion
 901                   (goto-char (nth 8 ppss))
 902                   (when (looking-at emacs-list-byte-code-comment-re)
 903                     (string-to-number (match-string 2)))))
 904              ;; `maxdiff' tries to make sure the loop below terminates.
 905              (maxdiff n))
 906         (when n
 907           (let* ((bchar (match-end 2))
 908                  (b (position-bytes bchar)))
 909             (goto-char (+ b n))
 910             (while (let ((diff (- (position-bytes (point)) b n)))
 911                      (unless (zerop diff)
 912                        (when (> diff maxdiff) (setq diff maxdiff))
 913                        (forward-char (- diff))
 914                        (setq maxdiff (if (> diff 0) diff
 915                                        (max (1- maxdiff) 1)))
 916                        t))))
 917           (if (<= (point) end)
 918               (put-text-property (1- (point)) (point)
 919                                  'syntax-table
 920                                  (string-to-syntax "> b"))
 921             (goto-char end)))))))
 922
 923 (defun elisp-byte-code-syntax-propertize (start end)
 924   (goto-char start)
 925   (elisp--byte-code-comment end (point))
 926   (funcall
 927    (syntax-propertize-rules
 928     (emacs-list-byte-code-comment-re
 929      (1 (prog1 "< b" (elisp--byte-code-comment end (point))))))
 930    start end))
 931
 932 ;;;###autoload
 933 (add-to-list 'auto-mode-alist '("\\.elc\\'" . elisp-byte-code-mode))
 934 ;;;###autoload
 935 (define-derived-mode elisp-byte-code-mode emacs-lisp-mode
 936   "Elisp-Byte-Code"
 937   "Major mode for *.elc files."
 938   ;; TODO: Add way to disassemble byte-code under point.
 939   (setq-local open-paren-in-column-0-is-defun-start nil)
 940   (setq-local syntax-propertize-function
 941               #'elisp-byte-code-syntax-propertize))
 942
 943
 944 ;;; Globally accessible functionality
 945
 946 (defun eval-print-last-sexp (&optional eval-last-sexp-arg-internal)
 947   "Evaluate sexp before point; print value into current buffer.
 948
 949 Normally, this function truncates long output according to the value
 950 of the variables `eval-expression-print-length' and
 951 `eval-expression-print-level'.  With a prefix argument of zero,
 952 however, there is no such truncation.  Such a prefix argument
 953 also causes integers to be printed in several additional formats
 954 \(octal, hexadecimal, and character).
 955
 956 If `eval-expression-debug-on-error' is non-nil, which is the default,
 957 this command arranges for all errors to enter the debugger."
 958   (interactive "P")
 959   (let ((standard-output (current-buffer)))
 960     (terpri)
 961     (eval-last-sexp (or eval-last-sexp-arg-internal t))
 962     (terpri)))
 963
 964
 965 (defun last-sexp-setup-props (beg end value alt1 alt2)
 966   "Set up text properties for the output of `elisp--eval-last-sexp'.
 967 BEG and END are the start and end of the output in current-buffer.
 968 VALUE is the Lisp value printed, ALT1 and ALT2 are strings for the
 969 alternative printed representations that can be displayed."
 970   (let ((map (make-sparse-keymap)))
 971     (define-key map "\C-m" 'elisp-last-sexp-toggle-display)
 972     (define-key map [down-mouse-2] 'mouse-set-point)
 973     (define-key map [mouse-2] 'elisp-last-sexp-toggle-display)
 974     (add-text-properties
 975      beg end
 976      `(printed-value (,value ,alt1 ,alt2)
 977                      mouse-face highlight
 978                      keymap ,map
 979                      help-echo "RET, mouse-2: toggle abbreviated display"
 980                      rear-nonsticky (mouse-face keymap help-echo
 981                                                 printed-value)))))
 982
 983
 984 (defun elisp-last-sexp-toggle-display (&optional _arg)
 985   "Toggle between abbreviated and unabbreviated printed representations."
 986   (interactive "P")
 987   (save-restriction
 988     (widen)
 989     (let ((value (get-text-property (point) 'printed-value)))
 990       (when value
 991         (let ((beg (or (previous-single-property-change (min (point-max) (1+ (point)))
 992                                                         'printed-value)
 993                        (point)))
 994               (end (or (next-single-char-property-change (point) 'printed-value) (point)))
 995               (standard-output (current-buffer))
 996               (point (point)))
 997           (delete-region beg end)
 998           (insert (nth 1 value))
 999           (or (= beg point)
1000               (setq point (1- (point))))
1001           (last-sexp-setup-props beg (point)
1002                                  (nth 0 value)
1003                                  (nth 2 value)
1004                                  (nth 1 value))
1005           (goto-char (min (point-max) point)))))))
1006
1007 (defun prin1-char (char)                ;FIXME: Move it, e.g. to simple.el.
1008   "Return a string representing CHAR as a character rather than as an integer.
1009 If CHAR is not a character, return nil."
1010   (and (integerp char)
1011        (eventp char)
1012        (let ((c (event-basic-type char))
1013              (mods (event-modifiers char))
1014              string)
1015          ;; Prevent ?A from turning into ?\S-a.
1016          (if (and (memq 'shift mods)
1017                   (zerop (logand char ?\S-\^@))
1018                   (not (let ((case-fold-search nil))
1019                          (char-equal c (upcase c)))))
1020              (setq c (upcase c) mods nil))
1021          ;; What string are we considering using?
1022          (condition-case nil
1023              (setq string
1024                    (concat
1025                     "?"
1026                     (mapconcat
1027                      (lambda (modif)
1028                        (cond ((eq modif 'super) "\\s-")
1029                              (t (string ?\\ (upcase (aref (symbol-name modif) 0)) ?-))))
1030                      mods "")
1031                     (cond
1032                      ((memq c '(?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\)) (string ?\\ c))
1033                      ((eq c 127) "\\C-?")
1034                      (t
1035                       (string c)))))
1036            (error nil))
1037          ;; Verify the string reads a CHAR, not to some other character.
1038          ;; If it doesn't, return nil instead.
1039          (and string
1040               (= (car (read-from-string string)) char)
1041               string))))
1042
1043 (defun elisp--preceding-sexp ()
1044   "Return sexp before the point."
1045   (let ((opoint (point))
1046         (left-quote ?‘)
1047         expr)
1048     (save-excursion
1049       (with-syntax-table emacs-lisp-mode-syntax-table
1050         ;; If this sexp appears to be enclosed in `...' or ‘...’
1051         ;; then ignore the surrounding quotes.
1052         (cond ((eq (preceding-char) ?’)
1053                (progn (forward-char -1) (setq opoint (point))))
1054               ((or (eq (following-char) ?\')
1055                    (eq (preceding-char) ?\'))
1056                (setq left-quote ?\`)))
1057         (forward-sexp -1)
1058         ;; If we were after `?\e' (or similar case),
1059         ;; use the whole thing, not just the `e'.
1060         (when (eq (preceding-char) ?\\)
1061           (forward-char -1)
1062           (when (eq (preceding-char) ??)
1063             (forward-char -1)))
1064
1065         ;; Skip over hash table read syntax.
1066         (and (> (point) (1+ (point-min)))
1067              (looking-back "#s" (- (point) 2))
1068              (forward-char -2))
1069
1070         ;; Skip over `#N='s.
1071         (when (eq (preceding-char) ?=)
1072           (let (labeled-p)
1073             (save-excursion
1074               (skip-chars-backward "0-9#=")
1075               (setq labeled-p (looking-at "\\(#[0-9]+=\\)+")))
1076             (when labeled-p
1077               (forward-sexp -1))))
1078
1079         (save-restriction
1080           (if (eq (following-char) left-quote)
1081               ;; vladimir@cs.ualberta.ca 30-Jul-1997: Skip ` in `variable' so
1082               ;; that the value is returned, not the name.
1083               (forward-char))
1084           (when (looking-at ",@?") (goto-char (match-end 0)))
1085           (narrow-to-region (point-min) opoint)
1086           (setq expr (read (current-buffer)))
1087           ;; If it's an (interactive ...) form, it's more useful to show how an
1088           ;; interactive call would use it.
1089           ;; FIXME: Is it really the right place for this?
1090           (when (eq (car-safe expr) 'interactive)
1091                (setq expr
1092                   `(call-interactively
1093                     (lambda (&rest args) ,expr args))))
1094           expr)))))
1095 (define-obsolete-function-alias 'preceding-sexp 'elisp--preceding-sexp "25.1")
1096
1097 (defun elisp--eval-last-sexp (eval-last-sexp-arg-internal)
1098   "Evaluate sexp before point; print value in the echo area.
1099 If EVAL-LAST-SEXP-ARG-INTERNAL is non-nil, print output into
1100 current buffer.  If EVAL-LAST-SEXP-ARG-INTERNAL is `0', print
1101 output with no limit on the length and level of lists, and
1102 include additional formats for integers \(octal, hexadecimal, and
1103 character)."
1104   (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)))
1105     ;; Setup the lexical environment if lexical-binding is enabled.
1106     (elisp--eval-last-sexp-print-value
1107      (eval (eval-sexp-add-defvars (elisp--preceding-sexp)) lexical-binding)
1108      eval-last-sexp-arg-internal)))
1109
1110 (defun elisp--eval-last-sexp-print-value (value &optional eval-last-sexp-arg-internal)
1111   (let ((unabbreviated (let ((print-length nil) (print-level nil))
1112                          (prin1-to-string value)))
1113         (print-length (and (not (zerop (prefix-numeric-value
1114                                         eval-last-sexp-arg-internal)))
1115                            eval-expression-print-length))
1116         (print-level (and (not (zerop (prefix-numeric-value
1117                                        eval-last-sexp-arg-internal)))
1118                           eval-expression-print-level))
1119         (beg (point))
1120         end)
1121     (prog1
1122         (prin1 value)
1123       (let ((str (eval-expression-print-format value)))
1124         (if str (princ str)))
1125       (setq end (point))
1126       (when (and (bufferp standard-output)
1127                  (or (not (null print-length))
1128                      (not (null print-level)))
1129                  (not (string= unabbreviated
1130                                (buffer-substring-no-properties beg end))))
1131         (last-sexp-setup-props beg end value
1132                                unabbreviated
1133                                (buffer-substring-no-properties beg end))
1134         ))))
1135
1136
1137 (defvar elisp--eval-last-sexp-fake-value (make-symbol "t"))
1138
1139 (defun eval-sexp-add-defvars (exp &optional pos)
1140   "Prepend EXP with all the `defvar's that precede it in the buffer.
1141 POS specifies the starting position where EXP was found and defaults to point."
1142   (setq exp (macroexpand-all exp))      ;Eager macro-expansion.
1143   (if (not lexical-binding)
1144       exp
1145     (save-excursion
1146       (unless pos (setq pos (point)))
1147       (let ((vars ()))
1148         (goto-char (point-min))
1149         (while (re-search-forward
1150                 "(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)"
1151                 pos t)
1152           (let ((var (intern (match-string 1))))
1153             (and (not (special-variable-p var))
1154                  (save-excursion
1155                    (zerop (car (syntax-ppss (match-beginning 0)))))
1156               (push var vars))))
1157         `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp)))))
1158
1159 (defun eval-last-sexp (eval-last-sexp-arg-internal)
1160   "Evaluate sexp before point; print value in the echo area.
1161 Interactively, with prefix argument, print output into current buffer.
1162
1163 Normally, this function truncates long output according to the value
1164 of the variables `eval-expression-print-length' and
1165 `eval-expression-print-level'.  With a prefix argument of zero,
1166 however, there is no such truncation.  Such a prefix argument
1167 also causes integers to be printed in several additional formats
1168 \(octal, hexadecimal, and character).
1169
1170 If `eval-expression-debug-on-error' is non-nil, which is the default,
1171 this command arranges for all errors to enter the debugger."
1172   (interactive "P")
1173   (if (null eval-expression-debug-on-error)
1174       (elisp--eval-last-sexp eval-last-sexp-arg-internal)
1175     (let ((value
1176            (let ((debug-on-error elisp--eval-last-sexp-fake-value))
1177              (cons (elisp--eval-last-sexp eval-last-sexp-arg-internal)
1178                    debug-on-error))))
1179       (unless (eq (cdr value) elisp--eval-last-sexp-fake-value)
1180         (setq debug-on-error (cdr value)))
1181       (car value))))
1182
1183 (defun elisp--eval-defun-1 (form)
1184   "Treat some expressions specially.
1185 Reset the `defvar' and `defcustom' variables to the initial value.
1186 \(For `defcustom', use the :set function if there is one.)
1187 Reinitialize the face according to the `defface' specification."
1188   ;; The code in edebug-defun should be consistent with this, but not
1189   ;; the same, since this gets a macroexpanded form.
1190   (cond ((not (listp form))
1191          form)
1192         ((and (eq (car form) 'defvar)
1193               (cdr-safe (cdr-safe form))
1194               (boundp (cadr form)))
1195          ;; Force variable to be re-set.
1196          `(progn (defvar ,(nth 1 form) nil ,@(nthcdr 3 form))
1197                  (setq-default ,(nth 1 form) ,(nth 2 form))))
1198         ;; `defcustom' is now macroexpanded to
1199         ;; `custom-declare-variable' with a quoted value arg.
1200         ((and (eq (car form) 'custom-declare-variable)
1201               (default-boundp (eval (nth 1 form) lexical-binding)))
1202          ;; Force variable to be bound, using :set function if specified.
1203          (let ((setfunc (memq :set form)))
1204            (when setfunc
1205              (setq setfunc (car-safe (cdr-safe setfunc)))
1206              (or (functionp setfunc) (setq setfunc nil)))
1207            (funcall (or setfunc 'set-default)
1208                     (eval (nth 1 form) lexical-binding)
1209                     ;; The second arg is an expression that evaluates to
1210                     ;; an expression.  The second evaluation is the one
1211                     ;; normally performed not by normal execution but by
1212                     ;; custom-initialize-set (for example), which does not
1213                     ;; use lexical-binding.
1214                     (eval (eval (nth 2 form) lexical-binding))))
1215          form)
1216         ;; `defface' is macroexpanded to `custom-declare-face'.
1217         ((eq (car form) 'custom-declare-face)
1218          ;; Reset the face.
1219          (let ((face-symbol (eval (nth 1 form) lexical-binding)))
1220            (setq face-new-frame-defaults
1221                  (assq-delete-all face-symbol face-new-frame-defaults))
1222            (put face-symbol 'face-defface-spec nil)
1223            (put face-symbol 'face-override-spec nil))
1224          form)
1225         ((eq (car form) 'progn)
1226          (cons 'progn (mapcar #'elisp--eval-defun-1 (cdr form))))
1227         (t form)))
1228
1229 (defun elisp--eval-defun ()
1230   "Evaluate defun that point is in or before.
1231 The value is displayed in the echo area.
1232 If the current defun is actually a call to `defvar',
1233 then reset the variable using the initial value expression
1234 even if the variable already has some other value.
1235 \(Normally `defvar' does not change the variable's value
1236 if it already has a value.)
1237
1238 Return the result of evaluation."
1239   ;; FIXME: the print-length/level bindings should only be applied while
1240   ;; printing, not while evaluating.
1241   (let ((debug-on-error eval-expression-debug-on-error)
1242         (print-length eval-expression-print-length)
1243         (print-level eval-expression-print-level))
1244     (save-excursion
1245       ;; Arrange for eval-region to "read" the (possibly) altered form.
1246       ;; eval-region handles recording which file defines a function or
1247       ;; variable.
1248       (let ((standard-output t)
1249             beg end form)
1250         ;; Read the form from the buffer, and record where it ends.
1251         (save-excursion
1252           (end-of-defun)
1253           (beginning-of-defun)
1254           (setq beg (point))
1255           (setq form (read (current-buffer)))
1256           (setq end (point)))
1257         ;; Alter the form if necessary.
1258         (let ((form (eval-sexp-add-defvars
1259                      (elisp--eval-defun-1 (macroexpand form)))))
1260           (eval-region beg end standard-output
1261                        (lambda (_ignore)
1262                          ;; Skipping to the end of the specified region
1263                          ;; will make eval-region return.
1264                          (goto-char end)
1265                          form))))))
1266   (let ((str (eval-expression-print-format (car values))))
1267     (if str (princ str)))
1268   ;; The result of evaluation has been put onto VALUES.  So return it.
1269   (car values))
1270
1271 (defun eval-defun (edebug-it)
1272   "Evaluate the top-level form containing point, or after point.
1273
1274 If the current defun is actually a call to `defvar' or `defcustom',
1275 evaluating it this way resets the variable using its initial value
1276 expression (using the defcustom's :set function if there is one), even
1277 if the variable already has some other value.  \(Normally `defvar' and
1278 `defcustom' do not alter the value if there already is one.)  In an
1279 analogous way, evaluating a `defface' overrides any customizations of
1280 the face, so that it becomes defined exactly as the `defface' expression
1281 says.
1282
1283 If `eval-expression-debug-on-error' is non-nil, which is the default,
1284 this command arranges for all errors to enter the debugger.
1285
1286 With a prefix argument, instrument the code for Edebug.
1287
1288 If acting on a `defun' for FUNCTION, and the function was
1289 instrumented, `Edebug: FUNCTION' is printed in the echo area.  If not
1290 instrumented, just FUNCTION is printed.
1291
1292 If not acting on a `defun', the result of evaluation is displayed in
1293 the echo area.  This display is controlled by the variables
1294 `eval-expression-print-length' and `eval-expression-print-level',
1295 which see."
1296   (interactive "P")
1297   (cond (edebug-it
1298          (require 'edebug)
1299          (eval-defun (not edebug-all-defs)))
1300         (t
1301          (if (null eval-expression-debug-on-error)
1302              (elisp--eval-defun)
1303            (let (new-value value)
1304              (let ((debug-on-error elisp--eval-last-sexp-fake-value))
1305                (setq value (elisp--eval-defun))
1306                (setq new-value debug-on-error))
1307              (unless (eq elisp--eval-last-sexp-fake-value new-value)
1308                (setq debug-on-error new-value))
1309              value)))))
1310
1311 ;;; ElDoc Support
1312
1313 (defvar elisp--eldoc-last-data (make-vector 3 nil)
1314   "Bookkeeping; elements are as follows:
1315   0 - contains the last symbol read from the buffer.
1316   1 - contains the string last displayed in the echo area for variables,
1317       or argument string for functions.
1318   2 - `function' if function args, `variable' if variable documentation.")
1319
1320 (defun elisp-eldoc-documentation-function ()
1321   "`eldoc-documentation-function' (which see) for Emacs Lisp."
1322   (let ((current-symbol (elisp--current-symbol))
1323         (current-fnsym  (elisp--fnsym-in-current-sexp)))
1324     (cond ((null current-fnsym)
1325            nil)
1326           ((eq current-symbol (car current-fnsym))
1327            (or (apply #'elisp-get-fnsym-args-string current-fnsym)
1328                (elisp-get-var-docstring current-symbol)))
1329           (t
1330            (or (elisp-get-var-docstring current-symbol)
1331                (apply #'elisp-get-fnsym-args-string current-fnsym))))))
1332
1333 (defun elisp-get-fnsym-args-string (sym &optional index prefix)
1334   "Return a string containing the parameter list of the function SYM.
1335 If SYM is a subr and no arglist is obtainable from the docstring
1336 or elsewhere, return a 1-line docstring."
1337   (let ((argstring
1338          (cond
1339           ((not (and sym (symbolp sym) (fboundp sym))) nil)
1340           ((and (eq sym (aref elisp--eldoc-last-data 0))
1341                 (eq 'function (aref elisp--eldoc-last-data 2)))
1342            (aref elisp--eldoc-last-data 1))
1343           (t
1344            (let* ((advertised (gethash (indirect-function sym)
1345                                        advertised-signature-table t))
1346                   doc
1347                   (args
1348                    (cond
1349                     ((listp advertised) advertised)
1350                     ((setq doc (help-split-fundoc
1351                                 (condition-case nil (documentation sym t)
1352                                   (invalid-function nil))
1353                                 sym))
1354                      (car doc))
1355                     (t (help-function-arglist sym)))))
1356              ;; Stringify, and store before highlighting, downcasing, etc.
1357              (elisp--last-data-store sym (elisp-function-argstring args)
1358                                     'function))))))
1359     ;; Highlight, truncate.
1360     (if argstring
1361         (elisp--highlight-function-argument
1362          sym argstring index
1363          (or prefix
1364              (concat (propertize (symbol-name sym) 'face
1365                                  (if (functionp sym)
1366                                      'font-lock-function-name-face
1367                                    'font-lock-keyword-face))
1368                      ": "))))))
1369
1370 (defun elisp--highlight-function-argument (sym args index prefix)
1371   "Highlight argument INDEX in ARGS list for function SYM.
1372 In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'."
1373   ;; FIXME: This should probably work on the list representation of `args'
1374   ;; rather than its string representation.
1375   ;; FIXME: This function is much too long, we need to split it up!
1376   (let ((start          nil)
1377         (end            0)
1378         (argument-face  'eldoc-highlight-function-argument)
1379         (args-lst (mapcar (lambda (x)
1380                             (replace-regexp-in-string
1381                              "\\`[(]\\|[)]\\'" "" x))
1382                           (split-string args))))
1383     ;; Find the current argument in the argument string.  We need to
1384     ;; handle `&rest' and informal `...' properly.
1385     ;;
1386     ;; FIXME: What to do with optional arguments, like in
1387     ;;        (defun NAME ARGLIST [DOCSTRING] BODY...) case?
1388     ;;        The problem is there is no robust way to determine if
1389     ;;        the current argument is indeed a docstring.
1390
1391     ;; When `&key' is used finding position based on `index'
1392     ;; would be wrong, so find the arg at point and determine
1393     ;; position in ARGS based on this current arg.
1394     (when (string-match "&key" args)
1395       (let* (case-fold-search
1396              key-have-value
1397              (sym-name (symbol-name sym))
1398              (cur-w (current-word))
1399              (args-lst-ak (cdr (member "&key" args-lst)))
1400              (limit (save-excursion
1401                       (when (re-search-backward sym-name nil t)
1402                         (match-end 0))))
1403              (cur-a (if (and cur-w (string-match ":\\([^ ()]*\\)" cur-w))
1404                         (substring cur-w 1)
1405                       (save-excursion
1406                         (let (split)
1407                           (when (re-search-backward ":\\([^()\n]*\\)" limit t)
1408                             (setq split (split-string (match-string 1) " " t))
1409                             (prog1 (car split)
1410                               (when (cdr split)
1411                                 (setq key-have-value t))))))))
1412              ;; If `cur-a' is not one of `args-lst-ak'
1413              ;; assume user is entering an unknown key
1414              ;; referenced in last position in signature.
1415              (other-key-arg (and (stringp cur-a)
1416                                  args-lst-ak
1417                                  (not (member (upcase cur-a) args-lst-ak))
1418                                  (upcase (car (last args-lst-ak))))))
1419         (unless (string= cur-w sym-name)
1420           ;; The last keyword have already a value
1421           ;; i.e :foo a b and cursor is at b.
1422           ;; If signature have also `&rest'
1423           ;; (assume it is after the `&key' section)
1424           ;; go to the arg after `&rest'.
1425           (if (and key-have-value
1426                    (save-excursion
1427                      (not (re-search-forward ":.*" (point-at-eol) t)))
1428                    (string-match "&rest \\([^ ()]*\\)" args))
1429               (setq index nil ; Skip next block based on positional args.
1430                     start (match-beginning 1)
1431                     end   (match-end 1))
1432             ;; If `cur-a' is nil probably cursor is on a positional arg
1433             ;; before `&key', in this case, exit this block and determine
1434             ;; position with `index'.
1435             (when (and cur-a     ; A keyword arg (dot removed) or nil.
1436                        (or (string-match
1437                             (concat "\\_<" (upcase cur-a) "\\_>") args)
1438                            (string-match
1439                             (concat "\\_<" other-key-arg "\\_>") args)))
1440               (setq index nil ; Skip next block based on positional args.
1441                     start (match-beginning 0)
1442                     end   (match-end 0)))))))
1443     ;; Handle now positional arguments.
1444     (while (and index (>= index 1))
1445       (if (string-match "[^ ()]+" args end)
1446           (progn
1447             (setq start (match-beginning 0)
1448                   end   (match-end 0))
1449             (let ((argument (match-string 0 args)))
1450               (cond ((string= argument "&rest")
1451                      ;; All the rest arguments are the same.
1452                      (setq index 1))
1453                     ((string= argument "&optional"))         ; Skip.
1454                     ((string= argument "&allow-other-keys")) ; Skip.
1455                     ;; Back to index 0 in ARG1 ARG2 ARG2 ARG3 etc...
1456                     ;; like in `setq'.
1457                     ((or (and (string-match-p "\\.\\.\\.\\'" argument)
1458                               (string= argument (car (last args-lst))))
1459                          (and (string-match-p "\\.\\.\\.\\'"
1460                                               (substring args 1 (1- (length args))))
1461                               (= (length (remove "..." args-lst)) 2)
1462                               (> index 1) (eq (logand index 1) 1)))
1463                      (setq index 0))
1464                     (t
1465                      (setq index (1- index))))))
1466         (setq end           (length args)
1467               start         (1- end)
1468               argument-face 'font-lock-warning-face
1469               index         0)))
1470     (let ((doc args))
1471       (when start
1472         (setq doc (copy-sequence args))
1473         (add-text-properties start end (list 'face argument-face) doc))
1474       (setq doc (eldoc-docstring-format-sym-doc prefix doc))
1475       doc)))
1476
1477 ;; Return a string containing a brief (one-line) documentation string for
1478 ;; the variable.
1479 (defun elisp-get-var-docstring (sym)
1480   (cond ((not sym) nil)
1481         ((and (eq sym (aref elisp--eldoc-last-data 0))
1482               (eq 'variable (aref elisp--eldoc-last-data 2)))
1483          (aref elisp--eldoc-last-data 1))
1484         (t
1485          (let ((doc (documentation-property sym 'variable-documentation t)))
1486            (when doc
1487              (let ((doc (eldoc-docstring-format-sym-doc
1488                          sym (elisp--docstring-first-line doc)
1489                          'font-lock-variable-name-face)))
1490                (elisp--last-data-store sym doc 'variable)))))))
1491
1492 (defun elisp--last-data-store (symbol doc type)
1493   (aset elisp--eldoc-last-data 0 symbol)
1494   (aset elisp--eldoc-last-data 1 doc)
1495   (aset elisp--eldoc-last-data 2 type)
1496   doc)
1497
1498 ;; Note that any leading `*' in the docstring (which indicates the variable
1499 ;; is a user option) is removed.
1500 (defun elisp--docstring-first-line (doc)
1501   (and (stringp doc)
1502        (substitute-command-keys
1503         (save-match-data
1504           ;; Don't use "^" in the regexp below since it may match
1505           ;; anywhere in the doc-string.
1506           (let ((start (if (string-match "\\`\\*" doc) (match-end 0) 0)))
1507             (cond ((string-match "\n" doc)
1508                    (substring doc start (match-beginning 0)))
1509                   ((zerop start) doc)
1510                   (t (substring doc start))))))))
1511 \f
1512 ;; Return a list of current function name and argument index.
1513 (defun elisp--fnsym-in-current-sexp ()
1514   (save-excursion
1515     (let ((argument-index (1- (elisp--beginning-of-sexp))))
1516       ;; If we are at the beginning of function name, this will be -1.
1517       (when (< argument-index 0)
1518         (setq argument-index 0))
1519       ;; Don't do anything if current word is inside a string.
1520       (if (= (or (char-after (1- (point))) 0) ?\")
1521           nil
1522         (list (elisp--current-symbol) argument-index)))))
1523
1524 ;; Move to the beginning of current sexp.  Return the number of nested
1525 ;; sexp the point was over or after.
1526 (defun elisp--beginning-of-sexp ()
1527   (let ((parse-sexp-ignore-comments t)
1528         (num-skipped-sexps 0))
1529     (condition-case _
1530         (progn
1531           ;; First account for the case the point is directly over a
1532           ;; beginning of a nested sexp.
1533           (condition-case _
1534               (let ((p (point)))
1535                 (forward-sexp -1)
1536                 (forward-sexp 1)
1537                 (when (< (point) p)
1538                   (setq num-skipped-sexps 1)))
1539             (error))
1540           (while
1541               (let ((p (point)))
1542                 (forward-sexp -1)
1543                 (when (< (point) p)
1544                   (setq num-skipped-sexps (1+ num-skipped-sexps))))))
1545       (error))
1546     num-skipped-sexps))
1547
1548 ;; returns nil unless current word is an interned symbol.
1549 (defun elisp--current-symbol ()
1550   (let ((c (char-after (point))))
1551     (and c
1552          (memq (char-syntax c) '(?w ?_))
1553          (intern-soft (current-word)))))
1554
1555 (defun elisp-function-argstring (arglist)
1556   "Return ARGLIST as a string enclosed by ().
1557 ARGLIST is either a string, or a list of strings or symbols."
1558   (let ((str (cond ((stringp arglist) arglist)
1559                    ((not (listp arglist)) nil)
1560                    (t (help--make-usage-docstring 'toto arglist)))))
1561     (if (and str (string-match "\\`([^ )]+ ?" str))
1562         (replace-match "(" t t str)
1563       str)))
1564
1565 (provide 'elisp-mode)
1566 ;;; elisp-mode.el ends here