lisp/progmodes/elisp-mode.el

   1 ;;; elisp-mode.el --- Emacs Lisp mode  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1985-1986, 1999-2018 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 <https://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   (unless noninteractive
 235     (require 'elec-pair)
 236     (defvar electric-pair-text-pairs)
 237     (setq-local electric-pair-text-pairs
 238                 (append '((?\` . ?\') (?‘ . ?’)) electric-pair-text-pairs))
 239     (setq-local electric-quote-string t))
 240   (setq imenu-case-fold-search nil)
 241   (add-function :before-until (local 'eldoc-documentation-function)
 242                 #'elisp-eldoc-documentation-function)
 243   (add-hook 'xref-backend-functions #'elisp--xref-backend nil t)
 244   (setq-local project-vc-external-roots-function #'elisp-load-path-roots)
 245   (add-hook 'completion-at-point-functions
 246             #'elisp-completion-at-point nil 'local)
 247   (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t)
 248   (add-hook 'flymake-diagnostic-functions #'elisp-flymake-byte-compile nil t))
 249
 250 ;; Font-locking support.
 251
 252 (defun elisp--font-lock-flush-elisp-buffers (&optional file)
 253   ;; We're only ever called from after-load-functions, load-in-progress can
 254   ;; still be t in case of nested loads.
 255   (when (or (not load-in-progress) file)
 256     ;; FIXME: If the loaded file did not define any macros, there shouldn't
 257     ;; be any need to font-lock-flush all the Elisp buffers.
 258     (dolist (buf (buffer-list))
 259       (with-current-buffer buf
 260         (when (derived-mode-p 'emacs-lisp-mode)
 261           ;; So as to take into account new macros that may have been defined
 262           ;; by the just-loaded file.
 263           (font-lock-flush))))))
 264
 265 ;;; Completion at point for Elisp
 266
 267 (defun elisp--local-variables-1 (vars sexp)
 268   "Return the vars locally bound around the witness, or nil if not found."
 269   (let (res)
 270     (while
 271         (unless
 272             (setq res
 273                   (pcase sexp
 274                     (`(,(or `let `let*) ,bindings)
 275                      (let ((vars vars))
 276                        (when (eq 'let* (car sexp))
 277                          (dolist (binding (cdr (reverse bindings)))
 278                            (push (or (car-safe binding) binding) vars)))
 279                        (elisp--local-variables-1
 280                         vars (car (cdr-safe (car (last bindings)))))))
 281                     (`(,(or `let `let*) ,bindings . ,body)
 282                      (let ((vars vars))
 283                        (dolist (binding bindings)
 284                          (push (or (car-safe binding) binding) vars))
 285                        (elisp--local-variables-1 vars (car (last body)))))
 286                     (`(lambda ,_args)
 287                      ;; FIXME: Look for the witness inside `args'.
 288                      (setq sexp nil))
 289                     (`(lambda ,args . ,body)
 290                      (elisp--local-variables-1
 291                       (append (remq '&optional (remq '&rest args)) vars)
 292                       (car (last body))))
 293                     (`(condition-case ,_ ,e) (elisp--local-variables-1 vars e))
 294                     (`(condition-case ,v ,_ . ,catches)
 295                      (elisp--local-variables-1
 296                       (cons v vars) (cdr (car (last catches)))))
 297                     (`(quote . ,_)
 298                      ;; FIXME: Look for the witness inside sexp.
 299                      (setq sexp nil))
 300                     ;; FIXME: Handle `cond'.
 301                     (`(,_ . ,_)
 302                      (elisp--local-variables-1 vars (car (last sexp))))
 303                     (`elisp--witness--lisp (or vars '(nil)))
 304                     (_ nil)))
 305           ;; We didn't find the witness in the last element so we try to
 306           ;; backtrack to the last-but-one.
 307           (setq sexp (ignore-errors (butlast sexp)))))
 308     res))
 309
 310 (defvar warning-minimum-log-level)
 311
 312 (defun elisp--local-variables ()
 313   "Return a list of locally let-bound variables at point."
 314   (save-excursion
 315     (skip-syntax-backward "w_")
 316     (let* ((ppss (syntax-ppss))
 317            (txt (buffer-substring-no-properties (or (car (nth 9 ppss)) (point))
 318                                                 (or (nth 8 ppss) (point))))
 319            (closer ()))
 320       (dolist (p (nth 9 ppss))
 321         (push (cdr (syntax-after p)) closer))
 322       (setq closer (apply #'string closer))
 323       (let* ((sexp (condition-case nil
 324                        (car (read-from-string
 325                              (concat txt "elisp--witness--lisp" closer)))
 326                      ((invalid-read-syntax end-of-file) nil)))
 327              (macroexpand-advice (lambda (expander form &rest args)
 328                                    (condition-case nil
 329                                        (apply expander form args)
 330                                      (error form))))
 331              (sexp
 332               (unwind-protect
 333                   (let ((warning-minimum-log-level :emergency))
 334                     (advice-add 'macroexpand :around macroexpand-advice)
 335                     (macroexpand-all sexp))
 336                 (advice-remove 'macroexpand macroexpand-advice)))
 337              (vars (elisp--local-variables-1 nil sexp)))
 338         (delq nil
 339               (mapcar (lambda (var)
 340                         (and (symbolp var)
 341                              (not (string-match (symbol-name var) "\\`[&_]"))
 342                              ;; Eliminate uninterned vars.
 343                              (intern-soft var)
 344                              var))
 345                       vars))))))
 346
 347 (defvar elisp--local-variables-completion-table
 348   ;; Use `defvar' rather than `defconst' since defconst would purecopy this
 349   ;; value, which would doubly fail: it would fail because purecopy can't
 350   ;; handle the recursive bytecode object, and it would fail because it would
 351   ;; move `lastpos' and `lastvars' to pure space where they'd be immutable!
 352   (let ((lastpos nil) (lastvars nil))
 353     (letrec ((hookfun (lambda ()
 354                         (setq lastpos nil)
 355                         (remove-hook 'post-command-hook hookfun))))
 356       (completion-table-dynamic
 357        (lambda (_string)
 358          (save-excursion
 359            (skip-syntax-backward "_w")
 360            (let ((newpos (cons (point) (current-buffer))))
 361              (unless (equal lastpos newpos)
 362                (add-hook 'post-command-hook hookfun)
 363                (setq lastpos newpos)
 364                (setq lastvars
 365                      (mapcar #'symbol-name (elisp--local-variables))))))
 366          lastvars)))))
 367
 368 (defun elisp--expect-function-p (pos)
 369   "Return non-nil if the symbol at point is expected to be a function."
 370   (or
 371    (and (eq (char-before pos) ?')
 372         (eq (char-before (1- pos)) ?#))
 373    (save-excursion
 374      (let ((parent (nth 1 (syntax-ppss pos))))
 375        (when parent
 376          (goto-char parent)
 377          (and
 378           (looking-at (concat "(\\(cl-\\)?"
 379                               (regexp-opt '("declare-function"
 380                                             "function" "defadvice"
 381                                             "callf" "callf2"
 382                                             "defsetf"))
 383                               "[ \t\r\n]+"))
 384           (eq (match-end 0) pos)))))))
 385
 386 (defun elisp--form-quoted-p (pos)
 387   "Return non-nil if the form at POS is not evaluated.
 388 It can be quoted, or be inside a quoted form."
 389   ;; FIXME: Do some macro expansion maybe.
 390   (save-excursion
 391     (let ((state (syntax-ppss pos)))
 392       (or (nth 8 state)   ; Code inside strings usually isn't evaluated.
 393           ;; FIXME: The 9th element is undocumented.
 394           (let ((nesting (cons (point) (reverse (nth 9 state))))
 395                 res)
 396             (while (and nesting (not res))
 397               (goto-char (pop nesting))
 398               (cond
 399                ((or (eq (char-after) ?\[)
 400                     (progn
 401                       (skip-chars-backward " ")
 402                       (memq (char-before) '(?' ?` ?‘))))
 403                 (setq res t))
 404                ((eq (char-before) ?,)
 405                 (setq nesting nil))))
 406             res)))))
 407
 408 ;; FIXME: Support for Company brings in features which straddle eldoc.
 409 ;; We should consolidate this, so that major modes can provide all that
 410 ;; data all at once:
 411 ;; - a function to extract "the reference at point" (may be more complex
 412 ;;     than a mere string, to distinguish various namespaces).
 413 ;; - a function to jump to such a reference.
 414 ;; - a function to show the signature/interface of such a reference.
 415 ;; - a function to build a help-buffer about that reference.
 416 ;; FIXME: Those functions should also be used by the normal completion code in
 417 ;; the *Completions* buffer.
 418
 419 (defun elisp--company-doc-buffer (str)
 420   (let ((symbol (intern-soft str)))
 421     ;; FIXME: we really don't want to "display-buffer and then undo it".
 422     (save-window-excursion
 423       ;; Make sure we don't display it in another frame, otherwise
 424       ;; save-window-excursion won't be able to undo it.
 425       (let ((display-buffer-overriding-action
 426              '(nil . ((inhibit-switch-frame . t)))))
 427         (ignore-errors
 428           (cond
 429            ((fboundp symbol) (describe-function symbol))
 430            ((boundp symbol) (describe-variable symbol))
 431            ((featurep symbol) (describe-package symbol))
 432            ((facep symbol) (describe-face symbol))
 433            (t (signal 'user-error nil)))
 434           (help-buffer))))))
 435
 436 (defun elisp--company-doc-string (str)
 437   (let* ((symbol (intern-soft str))
 438          (doc (if (fboundp symbol)
 439                   (documentation symbol t)
 440                 (documentation-property symbol 'variable-documentation t))))
 441     (and (stringp doc)
 442          (string-match ".*$" doc)
 443          (match-string 0 doc))))
 444
 445 ;; can't (require 'find-func) in a preloaded file
 446 (declare-function find-library-name "find-func" (library))
 447 (declare-function find-function-library "find-func" (function &optional l-o v))
 448
 449 (defun elisp--company-location (str)
 450   (let ((sym (intern-soft str)))
 451     (cond
 452      ((fboundp sym) (find-definition-noselect sym nil))
 453      ((boundp sym) (find-definition-noselect sym 'defvar))
 454      ((featurep sym)
 455       (require 'find-func)
 456       (cons (find-file-noselect (find-library-name
 457                                  (symbol-name sym)))
 458             0))
 459      ((facep sym) (find-definition-noselect sym 'defface)))))
 460
 461 (defun elisp-completion-at-point ()
 462   "Function used for `completion-at-point-functions' in `emacs-lisp-mode'.
 463 If the context at point allows only a certain category of
 464 symbols (e.g. functions, or variables) then the returned
 465 completions are restricted to that category.  In contexts where
 466 any symbol is possible (following a quote, for example),
 467 functions are annotated with \"<f>\" via the
 468 `:annotation-function' property."
 469   (with-syntax-table emacs-lisp-mode-syntax-table
 470     (let* ((pos (point))
 471            (beg (condition-case nil
 472                     (save-excursion
 473                       (backward-sexp 1)
 474                       (skip-chars-forward "`',‘#")
 475                       (point))
 476                   (scan-error pos)))
 477            (end
 478             (unless (or (eq beg (point-max))
 479                         (member (char-syntax (char-after beg))
 480                                 '(?\s ?\" ?\( ?\))))
 481               (condition-case nil
 482                   (save-excursion
 483                     (goto-char beg)
 484                     (forward-sexp 1)
 485                     (skip-chars-backward "'’")
 486                     (when (>= (point) pos)
 487                       (point)))
 488                 (scan-error pos))))
 489            ;; t if in function position.
 490            (funpos (eq (char-before beg) ?\())
 491            (quoted (elisp--form-quoted-p beg)))
 492       (when (and end (or (not (nth 8 (syntax-ppss)))
 493                          (memq (char-before beg) '(?` ?‘))))
 494         (let ((table-etc
 495                (if (or (not funpos) quoted)
 496                    ;; FIXME: We could look at the first element of the list and
 497                    ;; use it to provide a more specific completion table in some
 498                    ;; cases.  E.g. filter out keywords that are not understood by
 499                    ;; the macro/function being called.
 500                    (cond
 501                     ((elisp--expect-function-p beg)
 502                      (list nil obarray
 503                            :predicate #'fboundp
 504                            :company-doc-buffer #'elisp--company-doc-buffer
 505                            :company-docsig #'elisp--company-doc-string
 506                            :company-location #'elisp--company-location))
 507                     (quoted
 508                      (list nil obarray
 509                            ;; Don't include all symbols (bug#16646).
 510                            :predicate (lambda (sym)
 511                                         (or (boundp sym)
 512                                             (fboundp sym)
 513                                             (featurep sym)
 514                                             (symbol-plist sym)))
 515                            :annotation-function
 516                            (lambda (str) (if (fboundp (intern-soft str)) " <f>"))
 517                            :company-doc-buffer #'elisp--company-doc-buffer
 518                            :company-docsig #'elisp--company-doc-string
 519                            :company-location #'elisp--company-location))
 520                     (t
 521                      (list nil (completion-table-merge
 522                                 elisp--local-variables-completion-table
 523                                 (apply-partially #'completion-table-with-predicate
 524                                                  obarray
 525                                                  #'boundp
 526                                                  'strict))
 527                            :company-doc-buffer #'elisp--company-doc-buffer
 528                            :company-docsig #'elisp--company-doc-string
 529                            :company-location #'elisp--company-location)))
 530                  ;; Looks like a funcall position.  Let's double check.
 531                  (save-excursion
 532                    (goto-char (1- beg))
 533                    (let ((parent
 534                           (condition-case nil
 535                               (progn (up-list -1) (forward-char 1)
 536                                      (let ((c (char-after)))
 537                                        (if (eq c ?\() ?\(
 538                                          (if (memq (char-syntax c) '(?w ?_))
 539                                              (read (current-buffer))))))
 540                             (error nil))))
 541                      (pcase parent
 542                        ;; FIXME: Rather than hardcode special cases here,
 543                        ;; we should use something like a symbol-property.
 544                        (`declare
 545                         (list t (mapcar (lambda (x) (symbol-name (car x)))
 546                                         (delete-dups
 547                                          ;; FIXME: We should include some
 548                                          ;; docstring with each entry.
 549                                          (append macro-declarations-alist
 550                                                  defun-declarations-alist
 551                                                  nil))))) ; Copy both alists.
 552                        ((and (or `condition-case `condition-case-unless-debug)
 553                              (guard (save-excursion
 554                                       (ignore-errors
 555                                         (forward-sexp 2)
 556                                         (< (point) beg)))))
 557                         (list t obarray
 558                               :predicate (lambda (sym) (get sym 'error-conditions))))
 559                        ((and (or ?\( `let `let*)
 560                              (guard (save-excursion
 561                                       (goto-char (1- beg))
 562                                       (when (eq parent ?\()
 563                                         (up-list -1))
 564                                       (forward-symbol -1)
 565                                       (looking-at "\\_<let\\*?\\_>"))))
 566                         (list t obarray
 567                               :predicate #'boundp
 568                               :company-doc-buffer #'elisp--company-doc-buffer
 569                               :company-docsig #'elisp--company-doc-string
 570                               :company-location #'elisp--company-location))
 571                        (_ (list nil obarray
 572                                 :predicate #'fboundp
 573                                 :company-doc-buffer #'elisp--company-doc-buffer
 574                                 :company-docsig #'elisp--company-doc-string
 575                                 :company-location #'elisp--company-location
 576                                 ))))))))
 577           (nconc (list beg end)
 578                  (if (null (car table-etc))
 579                      (cdr table-etc)
 580                    (cons
 581                     (if (memq (char-syntax (or (char-after end) ?\s))
 582                               '(?\s ?>))
 583                         (cadr table-etc)
 584                       (apply-partially 'completion-table-with-terminator
 585                                        " " (cadr table-etc)))
 586                     (cddr table-etc)))))))))
 587
 588 (defun lisp-completion-at-point (&optional _predicate)
 589   (declare (obsolete elisp-completion-at-point "25.1"))
 590   (elisp-completion-at-point))
 591
 592 ;;; Xref backend
 593
 594 (declare-function xref-make-bogus-location "xref" (message))
 595 (declare-function xref-make "xref" (summary location))
 596 (declare-function xref-collect-references "xref" (symbol dir))
 597
 598 (defun elisp--xref-backend () 'elisp)
 599
 600 ;; WORKAROUND: This is nominally a constant, but the text properties
 601 ;; are not preserved thru dump if use defconst.  See bug#21237.
 602 (defvar elisp--xref-format
 603   (let ((str "(%s %s)"))
 604     (put-text-property 1 3 'face 'font-lock-keyword-face str)
 605     (put-text-property 4 6 'face 'font-lock-function-name-face str)
 606     str))
 607
 608 ;; WORKAROUND: This is nominally a constant, but the text properties
 609 ;; are not preserved thru dump if use defconst.  See bug#21237.
 610 (defvar elisp--xref-format-extra
 611   (let ((str "(%s %s %s)"))
 612     (put-text-property 1 3 'face 'font-lock-keyword-face str)
 613     (put-text-property 4 6 'face 'font-lock-function-name-face str)
 614     str))
 615
 616 (defvar find-feature-regexp);; in find-func.el
 617
 618 (defun elisp--xref-make-xref (type symbol file &optional summary)
 619   "Return an xref for TYPE SYMBOL in FILE.
 620 TYPE must be a type in `find-function-regexp-alist' (use nil for
 621 'defun).  If SUMMARY is non-nil, use it for the summary;
 622 otherwise build the summary from TYPE and SYMBOL."
 623   (xref-make (or summary
 624                  (format elisp--xref-format (or type 'defun) symbol))
 625              (xref-make-elisp-location symbol type file)))
 626
 627 (defvar elisp-xref-find-def-functions nil
 628   "List of functions to be run from `elisp--xref-find-definitions' to add additional xrefs.
 629 Called with one arg; the symbol whose definition is desired.
 630 Each function should return a list of xrefs, or nil; the first
 631 non-nil result supercedes the xrefs produced by
 632 `elisp--xref-find-definitions'.")
 633
 634 (cl-defmethod xref-backend-definitions ((_backend (eql elisp)) identifier)
 635   (require 'find-func)
 636   ;; FIXME: use information in source near point to filter results:
 637   ;; (dvc-log-edit ...) - exclude 'feature
 638   ;; (require 'dvc-log-edit) - only 'feature
 639   ;; Semantic may provide additional information
 640   ;;
 641   (let ((sym (intern-soft identifier)))
 642     (when sym
 643       (elisp--xref-find-definitions sym))))
 644
 645 (defun elisp--xref-find-definitions (symbol)
 646   ;; The file name is not known when `symbol' is defined via interactive eval.
 647   (let (xrefs)
 648
 649     (let ((temp elisp-xref-find-def-functions))
 650       (while (and (null xrefs)
 651                   temp)
 652         (setq xrefs (append xrefs (funcall (pop temp) symbol)))))
 653
 654     (unless xrefs
 655       ;; alphabetical by result type symbol
 656
 657       ;; FIXME: advised function; list of advice functions
 658       ;; FIXME: aliased variable
 659
 660       ;; Coding system symbols do not appear in ‘load-history’,
 661       ;; so we can’t get a location for them.
 662
 663       (when (and (symbolp symbol)
 664                  (symbol-function symbol)
 665                  (symbolp (symbol-function symbol)))
 666         ;; aliased function
 667         (let* ((alias-symbol symbol)
 668                (alias-file (symbol-file alias-symbol))
 669                (real-symbol  (symbol-function symbol))
 670                (real-file (find-lisp-object-file-name real-symbol 'defun)))
 671
 672           (when real-file
 673             (push (elisp--xref-make-xref nil real-symbol real-file) xrefs))
 674
 675           (when alias-file
 676             (push (elisp--xref-make-xref 'defalias alias-symbol alias-file) xrefs))))
 677
 678       (when (facep symbol)
 679         (let ((file (find-lisp-object-file-name symbol 'defface)))
 680           (when file
 681             (push (elisp--xref-make-xref 'defface symbol file) xrefs))))
 682
 683       (when (fboundp symbol)
 684         (let ((file (find-lisp-object-file-name symbol (symbol-function symbol)))
 685               generic doc)
 686           (when file
 687             (cond
 688              ((eq file 'C-source)
 689               ;; First call to find-lisp-object-file-name for an object
 690               ;; defined in C; the doc strings from the C source have
 691               ;; not been loaded yet.  Second call will return "src/*.c"
 692               ;; in file; handled by 't' case below.
 693               (push (elisp--xref-make-xref nil symbol (help-C-file-name (symbol-function symbol) 'subr)) xrefs))
 694
 695              ((and (setq doc (documentation symbol t))
 696                    ;; This doc string is defined in cl-macs.el cl-defstruct
 697                    (string-match "Constructor for objects of type `\\(.*\\)'" doc))
 698               ;; `symbol' is a name for the default constructor created by
 699               ;; cl-defstruct, so return the location of the cl-defstruct.
 700               (let* ((type-name (match-string 1 doc))
 701                      (type-symbol (intern type-name))
 702                      (file (find-lisp-object-file-name type-symbol 'define-type))
 703                      (summary (format elisp--xref-format-extra
 704                                       'cl-defstruct
 705                                       (concat "(" type-name)
 706                                       (concat "(:constructor " (symbol-name symbol) "))"))))
 707                 (push (elisp--xref-make-xref 'define-type type-symbol file summary) xrefs)
 708                 ))
 709
 710              ((setq generic (cl--generic symbol))
 711               ;; FIXME: move this to elisp-xref-find-def-functions, in cl-generic.el
 712
 713               ;; A generic function. If there is a default method, it
 714               ;; will appear in the method table, with no
 715               ;; specializers.
 716               ;;
 717               ;; If the default method is declared by the cl-defgeneric
 718               ;; declaration, it will have the same location as the
 719               ;; cl-defgeneric, so we want to exclude it from the
 720               ;; result. In this case, it will have a null doc
 721               ;; string. User declarations of default methods may also
 722               ;; have null doc strings, but we hope that is
 723               ;; rare. Perhaps this heuristic will discourage that.
 724               (dolist (method (cl--generic-method-table generic))
 725                 (let* ((info (cl--generic-method-info method));; qual-string combined-args doconly
 726                        (specializers (cl--generic-method-specializers method))
 727                        (non-default nil)
 728                        (met-name (cl--generic-load-hist-format
 729                                   symbol
 730                                   (cl--generic-method-qualifiers method)
 731                                   specializers))
 732                        (file (find-lisp-object-file-name met-name 'cl-defmethod)))
 733                   (dolist (item specializers)
 734                     ;; default method has all 't' in specializers
 735                     (setq non-default (or non-default (not (equal t item)))))
 736
 737                   (when (and file
 738                              (or non-default
 739                                  (nth 2 info))) ;; assuming only co-located default has null doc string
 740                     (if specializers
 741                         (let ((summary (format elisp--xref-format-extra 'cl-defmethod symbol (nth 1 info))))
 742                           (push (elisp--xref-make-xref 'cl-defmethod met-name file summary) xrefs))
 743
 744                       (let ((summary (format elisp--xref-format-extra 'cl-defmethod symbol "()")))
 745                         (push (elisp--xref-make-xref 'cl-defmethod met-name file summary) xrefs))))
 746                   ))
 747
 748               (if (and (setq doc (documentation symbol t))
 749                        ;; This doc string is created somewhere in
 750                        ;; cl--generic-make-function for an implicit
 751                        ;; defgeneric.
 752                        (string-match "\n\n(fn ARG &rest ARGS)" doc))
 753                   ;; This symbol is an implicitly defined defgeneric, so
 754                   ;; don't return it.
 755                   nil
 756                 (push (elisp--xref-make-xref 'cl-defgeneric symbol file) xrefs))
 757               )
 758
 759              (t
 760               (push (elisp--xref-make-xref nil symbol file) xrefs))
 761              ))))
 762
 763       (when (boundp symbol)
 764         ;; A variable
 765         (let ((file (find-lisp-object-file-name symbol 'defvar)))
 766           (when file
 767             (cond
 768              ((eq file 'C-source)
 769               ;; The doc strings from the C source have not been loaded
 770               ;; yet; help-C-file-name does that.  Second call will
 771               ;; return "src/*.c" in file; handled below.
 772               (push (elisp--xref-make-xref 'defvar symbol (help-C-file-name symbol 'var)) xrefs))
 773
 774              ((string= "src/" (substring file 0 4))
 775               ;; The variable is defined in a C source file; don't check
 776               ;; for define-minor-mode.
 777               (push (elisp--xref-make-xref 'defvar symbol file) xrefs))
 778
 779              ((memq symbol minor-mode-list)
 780               ;; The symbol is a minor mode. These should be defined by
 781               ;; "define-minor-mode", which means the variable and the
 782               ;; function are declared in the same place. So we return only
 783               ;; the function, arbitrarily.
 784               ;;
 785               ;; There is an exception, when the variable is defined in C
 786               ;; code, as for abbrev-mode.
 787               ;;
 788               ;; IMPROVEME: If the user is searching for the identifier at
 789               ;; point, we can determine whether it is a variable or
 790               ;; function by looking at the source code near point.
 791               ;;
 792               ;; IMPROVEME: The user may actually be asking "do any
 793               ;; variables by this name exist"; we need a way to specify
 794               ;; that.
 795               nil)
 796
 797              (t
 798               (push (elisp--xref-make-xref 'defvar symbol file) xrefs))
 799
 800              ))))
 801
 802       (when (featurep symbol)
 803         (let ((file (ignore-errors
 804                       (find-library-name (symbol-name symbol)))))
 805           (when file
 806             (push (elisp--xref-make-xref 'feature symbol file) xrefs))))
 807       );; 'unless xrefs'
 808
 809     xrefs))
 810
 811 (declare-function project-external-roots "project")
 812
 813 (cl-defmethod xref-backend-apropos ((_backend (eql elisp)) regexp)
 814   (apply #'nconc
 815          (let (lst)
 816            (dolist (sym (apropos-internal regexp))
 817              (push (elisp--xref-find-definitions sym) lst))
 818            (nreverse lst))))
 819
 820 (defvar elisp--xref-identifier-completion-table
 821   (apply-partially #'completion-table-with-predicate
 822                    obarray
 823                    (lambda (sym)
 824                      (or (boundp sym)
 825                          (fboundp sym)
 826                          (featurep sym)
 827                          (facep sym)))
 828                    'strict))
 829
 830 (cl-defmethod xref-backend-identifier-completion-table ((_backend (eql elisp)))
 831   elisp--xref-identifier-completion-table)
 832
 833 (cl-defstruct (xref-elisp-location
 834                (:constructor xref-make-elisp-location (symbol type file)))
 835   "Location of an Emacs Lisp symbol definition."
 836   symbol type file)
 837
 838 (cl-defmethod xref-location-marker ((l xref-elisp-location))
 839   (pcase-let (((cl-struct xref-elisp-location symbol type file) l))
 840     (let ((buffer-point (find-function-search-for-symbol symbol type file)))
 841       (with-current-buffer (car buffer-point)
 842         (save-excursion
 843           (goto-char (or (cdr buffer-point) (point-min)))
 844           (point-marker))))))
 845
 846 (cl-defmethod xref-location-group ((l xref-elisp-location))
 847   (xref-elisp-location-file l))
 848
 849 (defun elisp-load-path-roots ()
 850   (if (boundp 'package-user-dir)
 851       (cons package-user-dir load-path)
 852     load-path))
 853
 854 ;;; Elisp Interaction mode
 855
 856 (defvar lisp-interaction-mode-map
 857   (let ((map (make-sparse-keymap))
 858         (menu-map (make-sparse-keymap "Lisp-Interaction")))
 859     (set-keymap-parent map lisp-mode-shared-map)
 860     (define-key map "\e\C-x" 'eval-defun)
 861     (define-key map "\e\C-q" 'indent-pp-sexp)
 862     (define-key map "\e\t" 'completion-at-point)
 863     (define-key map "\n" 'eval-print-last-sexp)
 864     (bindings--define-key map [menu-bar lisp-interaction]
 865       (cons "Lisp-Interaction" menu-map))
 866     (bindings--define-key menu-map [eval-defun]
 867       '(menu-item "Evaluate Defun" eval-defun
 868                   :help "Evaluate the top-level form containing point, or after point"))
 869     (bindings--define-key menu-map [eval-print-last-sexp]
 870       '(menu-item "Evaluate and Print" eval-print-last-sexp
 871                   :help "Evaluate sexp before point; print value into current buffer"))
 872     (bindings--define-key menu-map [edebug-defun-lisp-interaction]
 873       '(menu-item "Instrument Function for Debugging" edebug-defun
 874                   :help "Evaluate the top level form point is in, stepping through with Edebug"
 875                   :keys "C-u C-M-x"))
 876     (bindings--define-key menu-map [indent-pp-sexp]
 877       '(menu-item "Indent or Pretty-Print" indent-pp-sexp
 878                   :help "Indent each line of the list starting just after point, or prettyprint it"))
 879     (bindings--define-key menu-map [complete-symbol]
 880       '(menu-item "Complete Lisp Symbol" completion-at-point
 881                   :help "Perform completion on Lisp symbol preceding point"))
 882     map)
 883   "Keymap for Lisp Interaction mode.
 884 All commands in `lisp-mode-shared-map' are inherited by this map.")
 885
 886 (define-derived-mode lisp-interaction-mode emacs-lisp-mode "Lisp Interaction"
 887   "Major mode for typing and evaluating Lisp forms.
 888 Like Lisp mode except that \\[eval-print-last-sexp] evals the Lisp expression
 889 before point, and prints its value into the buffer, advancing point.
 890 Note that printing is controlled by `eval-expression-print-length'
 891 and `eval-expression-print-level'.
 892
 893 Commands:
 894 Delete converts tabs to spaces as it moves back.
 895 Paragraphs are separated only by blank lines.
 896 Semicolons start comments.
 897
 898 \\{lisp-interaction-mode-map}"
 899   :abbrev-table nil)
 900
 901 ;;; Emacs Lisp Byte-Code mode
 902
 903 (eval-and-compile
 904   (defconst emacs-list-byte-code-comment-re
 905     (concat "\\(#\\)@\\([0-9]+\\) "
 906             ;; Make sure it's a docstring and not a lazy-loaded byte-code.
 907             "\\(?:[^(]\\|([^\"]\\)")))
 908
 909 (defun elisp--byte-code-comment (end &optional _point)
 910   "Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files."
 911   (let ((ppss (syntax-ppss)))
 912     (when (and (nth 4 ppss)
 913                (eq (char-after (nth 8 ppss)) ?#))
 914       (let* ((n (save-excursion
 915                   (goto-char (nth 8 ppss))
 916                   (when (looking-at emacs-list-byte-code-comment-re)
 917                     (string-to-number (match-string 2)))))
 918              ;; `maxdiff' tries to make sure the loop below terminates.
 919              (maxdiff n))
 920         (when n
 921           (let* ((bchar (match-end 2))
 922                  (b (position-bytes bchar)))
 923             (goto-char (+ b n))
 924             (while (let ((diff (- (position-bytes (point)) b n)))
 925                      (unless (zerop diff)
 926                        (when (> diff maxdiff) (setq diff maxdiff))
 927                        (forward-char (- diff))
 928                        (setq maxdiff (if (> diff 0) diff
 929                                        (max (1- maxdiff) 1)))
 930                        t))))
 931           (if (<= (point) end)
 932               (put-text-property (1- (point)) (point)
 933                                  'syntax-table
 934                                  (string-to-syntax "> b"))
 935             (goto-char end)))))))
 936
 937 (defun elisp-byte-code-syntax-propertize (start end)
 938   (goto-char start)
 939   (elisp--byte-code-comment end (point))
 940   (funcall
 941    (syntax-propertize-rules
 942     (emacs-list-byte-code-comment-re
 943      (1 (prog1 "< b" (elisp--byte-code-comment end (point))))))
 944    start end))
 945
 946 ;;;###autoload
 947 (add-to-list 'auto-mode-alist '("\\.elc\\'" . elisp-byte-code-mode))
 948 ;;;###autoload
 949 (define-derived-mode elisp-byte-code-mode emacs-lisp-mode
 950   "Elisp-Byte-Code"
 951   "Major mode for *.elc files."
 952   ;; TODO: Add way to disassemble byte-code under point.
 953   (setq-local open-paren-in-column-0-is-defun-start nil)
 954   (setq-local syntax-propertize-function
 955               #'elisp-byte-code-syntax-propertize))
 956
 957
 958 ;;; Globally accessible functionality
 959
 960 (defun eval-print-last-sexp (&optional eval-last-sexp-arg-internal)
 961   "Evaluate sexp before point; print value into current buffer.
 962
 963 Normally, this function truncates long output according to the value
 964 of the variables `eval-expression-print-length' and
 965 `eval-expression-print-level'.  With a prefix argument of zero,
 966 however, there is no such truncation.  Such a prefix argument
 967 also causes integers to be printed in several additional formats
 968 \(octal, hexadecimal, and character).
 969
 970 If `eval-expression-debug-on-error' is non-nil, which is the default,
 971 this command arranges for all errors to enter the debugger."
 972   (interactive "P")
 973   (let ((standard-output (current-buffer)))
 974     (terpri)
 975     (eval-last-sexp (or eval-last-sexp-arg-internal t))
 976     (terpri)))
 977
 978
 979 (defun last-sexp-setup-props (beg end value alt1 alt2)
 980   "Set up text properties for the output of `elisp--eval-last-sexp'.
 981 BEG and END are the start and end of the output in current-buffer.
 982 VALUE is the Lisp value printed, ALT1 and ALT2 are strings for the
 983 alternative printed representations that can be displayed."
 984   (let ((map (make-sparse-keymap)))
 985     (define-key map "\C-m" 'elisp-last-sexp-toggle-display)
 986     (define-key map [down-mouse-2] 'mouse-set-point)
 987     (define-key map [mouse-2] 'elisp-last-sexp-toggle-display)
 988     (add-text-properties
 989      beg end
 990      `(printed-value (,value ,alt1 ,alt2)
 991                      mouse-face highlight
 992                      keymap ,map
 993                      help-echo "RET, mouse-2: toggle abbreviated display"
 994                      rear-nonsticky (mouse-face keymap help-echo
 995                                                 printed-value)))))
 996
 997
 998 (defun elisp-last-sexp-toggle-display (&optional _arg)
 999   "Toggle between abbreviated and unabbreviated printed representations."
1000   (interactive "P")
1001   (save-restriction
1002     (widen)
1003     (let ((value (get-text-property (point) 'printed-value)))
1004       (when value
1005         (let ((beg (or (previous-single-property-change (min (point-max) (1+ (point)))
1006                                                         'printed-value)
1007                        (point)))
1008               (end (or (next-single-char-property-change (point) 'printed-value) (point)))
1009               (standard-output (current-buffer))
1010               (point (point)))
1011           (delete-region beg end)
1012           (insert (nth 1 value))
1013           (or (= beg point)
1014               (setq point (1- (point))))
1015           (last-sexp-setup-props beg (point)
1016                                  (nth 0 value)
1017                                  (nth 2 value)
1018                                  (nth 1 value))
1019           (goto-char (min (point-max) point)))))))
1020
1021 (defun prin1-char (char)                ;FIXME: Move it, e.g. to simple.el.
1022   "Return a string representing CHAR as a character rather than as an integer.
1023 If CHAR is not a character, return nil."
1024   (and (integerp char)
1025        (eventp char)
1026        (let ((c (event-basic-type char))
1027              (mods (event-modifiers char))
1028              string)
1029          ;; Prevent ?A from turning into ?\S-a.
1030          (if (and (memq 'shift mods)
1031                   (zerop (logand char ?\S-\^@))
1032                   (not (let ((case-fold-search nil))
1033                          (char-equal c (upcase c)))))
1034              (setq c (upcase c) mods nil))
1035          ;; What string are we considering using?
1036          (condition-case nil
1037              (setq string
1038                    (concat
1039                     "?"
1040                     (mapconcat
1041                      (lambda (modif)
1042                        (cond ((eq modif 'super) "\\s-")
1043                              (t (string ?\\ (upcase (aref (symbol-name modif) 0)) ?-))))
1044                      mods "")
1045                     (cond
1046                      ((memq c '(?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\)) (string ?\\ c))
1047                      ((eq c 127) "\\C-?")
1048                      (t
1049                       (string c)))))
1050            (error nil))
1051          ;; Verify the string reads a CHAR, not to some other character.
1052          ;; If it doesn't, return nil instead.
1053          (and string
1054               (= (car (read-from-string string)) char)
1055               string))))
1056
1057 (defun elisp--preceding-sexp ()
1058   "Return sexp before the point."
1059   (let ((opoint (point))
1060         (left-quote ?‘)
1061         expr)
1062     (save-excursion
1063       (with-syntax-table emacs-lisp-mode-syntax-table
1064         ;; If this sexp appears to be enclosed in `...' or ‘...’
1065         ;; then ignore the surrounding quotes.
1066         (cond ((eq (preceding-char) ?’)
1067                (progn (forward-char -1) (setq opoint (point))))
1068               ((or (eq (following-char) ?\')
1069                    (eq (preceding-char) ?\'))
1070                (setq left-quote ?\`)))
1071
1072         ;; When after a named character literal, skip over the entire
1073         ;; literal, not only its last word.
1074         (when (= (preceding-char) ?})
1075           (let ((begin (save-excursion
1076                          (backward-char)
1077                          (skip-syntax-backward "w-")
1078                          (backward-char 3)
1079                          (when (looking-at-p "\\\\N{") (point)))))
1080             (when begin (goto-char begin))))
1081
1082         (forward-sexp -1)
1083         ;; If we were after `?\e' (or similar case),
1084         ;; use the whole thing, not just the `e'.
1085         (when (eq (preceding-char) ?\\)
1086           (forward-char -1)
1087           (when (eq (preceding-char) ??)
1088             (forward-char -1)))
1089
1090         ;; Skip over hash table read syntax.
1091         (and (> (point) (1+ (point-min)))
1092              (looking-back "#s" (- (point) 2))
1093              (forward-char -2))
1094
1095         ;; Skip over `#N='s.
1096         (when (eq (preceding-char) ?=)
1097           (let (labeled-p)
1098             (save-excursion
1099               (skip-chars-backward "0-9#=")
1100               (setq labeled-p (looking-at "\\(#[0-9]+=\\)+")))
1101             (when labeled-p
1102               (forward-sexp -1))))
1103
1104         (save-restriction
1105           (if (eq (following-char) left-quote)
1106               ;; vladimir@cs.ualberta.ca 30-Jul-1997: Skip ` in `variable' so
1107               ;; that the value is returned, not the name.
1108               (forward-char))
1109           (when (looking-at ",@?") (goto-char (match-end 0)))
1110           (narrow-to-region (point-min) opoint)
1111           (setq expr (read (current-buffer)))
1112           ;; If it's an (interactive ...) form, it's more useful to show how an
1113           ;; interactive call would use it.
1114           ;; FIXME: Is it really the right place for this?
1115           (when (eq (car-safe expr) 'interactive)
1116             (setq expr
1117                   `(call-interactively
1118                     (lambda (&rest args) ,expr args))))
1119           expr)))))
1120 (define-obsolete-function-alias 'preceding-sexp 'elisp--preceding-sexp "25.1")
1121
1122 (defun elisp--eval-last-sexp (eval-last-sexp-arg-internal)
1123   "Evaluate sexp before point; print value in the echo area.
1124 If EVAL-LAST-SEXP-ARG-INTERNAL is non-nil, print output into
1125 current buffer.  If EVAL-LAST-SEXP-ARG-INTERNAL is `0', print
1126 output with no limit on the length and level of lists, and
1127 include additional formats for integers \(octal, hexadecimal, and
1128 character)."
1129   (pcase-let*
1130       ((`(,insert-value ,no-truncate ,char-print-limit)
1131         (eval-expression-get-print-arguments eval-last-sexp-arg-internal)))
1132     ;; Setup the lexical environment if lexical-binding is enabled.
1133     (elisp--eval-last-sexp-print-value
1134      (eval (eval-sexp-add-defvars (elisp--preceding-sexp)) lexical-binding)
1135      (if insert-value (current-buffer) t) no-truncate char-print-limit)))
1136
1137 (defun elisp--eval-last-sexp-print-value
1138     (value output &optional no-truncate char-print-limit)
1139   (let* ((unabbreviated (let ((print-length nil) (print-level nil))
1140                           (prin1-to-string value)))
1141          (eval-expression-print-maximum-character char-print-limit)
1142          (print-length (unless no-truncate eval-expression-print-length))
1143          (print-level  (unless no-truncate eval-expression-print-level))
1144          (beg (point))
1145          end)
1146     (prog1
1147         (prin1 value output)
1148       (let ((str (and char-print-limit (eval-expression-print-format value))))
1149         (if str (princ str output)))
1150       (setq end (point))
1151       (when (and (bufferp output)
1152                  (or (not (null print-length))
1153                      (not (null print-level)))
1154                  (not (string= unabbreviated
1155                                (buffer-substring-no-properties beg end))))
1156         (last-sexp-setup-props beg end value
1157                                unabbreviated
1158                                (buffer-substring-no-properties beg end))
1159         ))))
1160
1161
1162 (defvar elisp--eval-last-sexp-fake-value (make-symbol "t"))
1163
1164 (defun eval-sexp-add-defvars (exp &optional pos)
1165   "Prepend EXP with all the `defvar's that precede it in the buffer.
1166 POS specifies the starting position where EXP was found and defaults to point."
1167   (setq exp (macroexpand-all exp))      ;Eager macro-expansion.
1168   (if (not lexical-binding)
1169       exp
1170     (save-excursion
1171       (unless pos (setq pos (point)))
1172       (let ((vars ()))
1173         (goto-char (point-min))
1174         (while (re-search-forward
1175                 "(def\\(?:var\\|const\\|custom\\)[ \t\n]+\\([^; '()\n\t]+\\)"
1176                 pos t)
1177           (let ((var (intern (match-string 1))))
1178             (and (not (special-variable-p var))
1179                  (save-excursion
1180                    (zerop (car (syntax-ppss (match-beginning 0)))))
1181                  (push var vars))))
1182         `(progn ,@(mapcar (lambda (v) `(defvar ,v)) vars) ,exp)))))
1183
1184 (defun eval-last-sexp (eval-last-sexp-arg-internal)
1185   "Evaluate sexp before point; print value in the echo area.
1186 Interactively, with a non `-' prefix argument, print output into
1187 current buffer.
1188
1189 Normally, this function truncates long output according to the
1190 value of the variables `eval-expression-print-length' and
1191 `eval-expression-print-level'.  With a prefix argument of zero,
1192 however, there is no such truncation.  Such a prefix argument
1193 also causes integers to be printed in several additional formats
1194 \(octal, hexadecimal, and character when the prefix argument is
1195 -1 or the integer is `eval-expression-print-maximum-character' or
1196 less).
1197
1198 If `eval-expression-debug-on-error' is non-nil, which is the default,
1199 this command arranges for all errors to enter the debugger."
1200   (interactive "P")
1201   (if (null eval-expression-debug-on-error)
1202       (elisp--eval-last-sexp eval-last-sexp-arg-internal)
1203     (let ((value
1204            (let ((debug-on-error elisp--eval-last-sexp-fake-value))
1205              (cons (elisp--eval-last-sexp eval-last-sexp-arg-internal)
1206                    debug-on-error))))
1207       (unless (eq (cdr value) elisp--eval-last-sexp-fake-value)
1208         (setq debug-on-error (cdr value)))
1209       (car value))))
1210
1211 (defun elisp--eval-defun-1 (form)
1212   "Treat some expressions specially.
1213 Reset the `defvar' and `defcustom' variables to the initial value.
1214 \(For `defcustom', use the :set function if there is one.)
1215 Reinitialize the face according to the `defface' specification."
1216   ;; The code in edebug-defun should be consistent with this, but not
1217   ;; the same, since this gets a macroexpanded form.
1218   (cond ((not (listp form))
1219          form)
1220         ((and (eq (car form) 'defvar)
1221               (cdr-safe (cdr-safe form))
1222               (boundp (cadr form)))
1223          ;; Force variable to be re-set.
1224          `(progn (defvar ,(nth 1 form) nil ,@(nthcdr 3 form))
1225                  (setq-default ,(nth 1 form) ,(nth 2 form))))
1226         ;; `defcustom' is now macroexpanded to
1227         ;; `custom-declare-variable' with a quoted value arg.
1228         ((and (eq (car form) 'custom-declare-variable)
1229               (default-boundp (eval (nth 1 form) lexical-binding)))
1230          ;; Force variable to be bound, using :set function if specified.
1231          (let ((setfunc (memq :set form)))
1232            (when setfunc
1233              (setq setfunc (car-safe (cdr-safe setfunc)))
1234              (or (functionp setfunc) (setq setfunc nil)))
1235            (funcall (or setfunc 'set-default)
1236                     (eval (nth 1 form) lexical-binding)
1237                     ;; The second arg is an expression that evaluates to
1238                     ;; an expression.  The second evaluation is the one
1239                     ;; normally performed not by normal execution but by
1240                     ;; custom-initialize-set (for example), which does not
1241                     ;; use lexical-binding.
1242                     (eval (eval (nth 2 form) lexical-binding))))
1243          form)
1244         ;; `defface' is macroexpanded to `custom-declare-face'.
1245         ((eq (car form) 'custom-declare-face)
1246          ;; Reset the face.
1247          (let ((face-symbol (eval (nth 1 form) lexical-binding)))
1248            (setq face-new-frame-defaults
1249                  (assq-delete-all face-symbol face-new-frame-defaults))
1250            (put face-symbol 'face-defface-spec nil)
1251            (put face-symbol 'face-override-spec nil))
1252          form)
1253         ((eq (car form) 'progn)
1254          (cons 'progn (mapcar #'elisp--eval-defun-1 (cdr form))))
1255         (t form)))
1256
1257 (defun elisp--eval-defun ()
1258   "Evaluate defun that point is in or before.
1259 The value is displayed in the echo area.
1260 If the current defun is actually a call to `defvar',
1261 then reset the variable using the initial value expression
1262 even if the variable already has some other value.
1263 \(Normally `defvar' does not change the variable's value
1264 if it already has a value.)
1265
1266 Return the result of evaluation."
1267   ;; FIXME: the print-length/level bindings should only be applied while
1268   ;; printing, not while evaluating.
1269   (let ((debug-on-error eval-expression-debug-on-error)
1270         (print-length eval-expression-print-length)
1271         (print-level eval-expression-print-level))
1272     (save-excursion
1273       ;; Arrange for eval-region to "read" the (possibly) altered form.
1274       ;; eval-region handles recording which file defines a function or
1275       ;; variable.
1276       (let ((standard-output t)
1277             beg end form)
1278         ;; Read the form from the buffer, and record where it ends.
1279         (save-excursion
1280           (end-of-defun)
1281           (beginning-of-defun)
1282           (setq beg (point))
1283           (setq form (read (current-buffer)))
1284           (setq end (point)))
1285         ;; Alter the form if necessary.
1286         (let ((form (eval-sexp-add-defvars
1287                      (elisp--eval-defun-1 (macroexpand form)))))
1288           (eval-region beg end standard-output
1289                        (lambda (_ignore)
1290                          ;; Skipping to the end of the specified region
1291                          ;; will make eval-region return.
1292                          (goto-char end)
1293                          form))))))
1294   (let ((str (eval-expression-print-format (car values))))
1295     (if str (princ str)))
1296   ;; The result of evaluation has been put onto VALUES.  So return it.
1297   (car values))
1298
1299 (defun eval-defun (edebug-it)
1300   "Evaluate the top-level form containing point, or after point.
1301
1302 If the current defun is actually a call to `defvar' or `defcustom',
1303 evaluating it this way resets the variable using its initial value
1304 expression (using the defcustom's :set function if there is one), even
1305 if the variable already has some other value.  \(Normally `defvar' and
1306 `defcustom' do not alter the value if there already is one.)  In an
1307 analogous way, evaluating a `defface' overrides any customizations of
1308 the face, so that it becomes defined exactly as the `defface' expression
1309 says.
1310
1311 If `eval-expression-debug-on-error' is non-nil, which is the default,
1312 this command arranges for all errors to enter the debugger.
1313
1314 With a prefix argument, instrument the code for Edebug.
1315
1316 If acting on a `defun' for FUNCTION, and the function was
1317 instrumented, `Edebug: FUNCTION' is printed in the echo area.  If not
1318 instrumented, just FUNCTION is printed.
1319
1320 If not acting on a `defun', the result of evaluation is displayed in
1321 the echo area.  This display is controlled by the variables
1322 `eval-expression-print-length' and `eval-expression-print-level',
1323 which see."
1324   (interactive "P")
1325   (cond (edebug-it
1326          (require 'edebug)
1327          (eval-defun (not edebug-all-defs)))
1328         (t
1329          (if (null eval-expression-debug-on-error)
1330              (elisp--eval-defun)
1331            (let (new-value value)
1332              (let ((debug-on-error elisp--eval-last-sexp-fake-value))
1333                (setq value (elisp--eval-defun))
1334                (setq new-value debug-on-error))
1335              (unless (eq elisp--eval-last-sexp-fake-value new-value)
1336                (setq debug-on-error new-value))
1337              value)))))
1338
1339 ;;; ElDoc Support
1340
1341 (defvar elisp--eldoc-last-data (make-vector 3 nil)
1342   "Bookkeeping; elements are as follows:
1343   0 - contains the last symbol read from the buffer.
1344   1 - contains the string last displayed in the echo area for variables,
1345       or argument string for functions.
1346   2 - `function' if function args, `variable' if variable documentation.")
1347
1348 (defun elisp-eldoc-documentation-function ()
1349   "`eldoc-documentation-function' (which see) for Emacs Lisp."
1350   (let ((current-symbol (elisp--current-symbol))
1351         (current-fnsym  (elisp--fnsym-in-current-sexp)))
1352     (cond ((null current-fnsym)
1353            nil)
1354           ((eq current-symbol (car current-fnsym))
1355            (or (apply #'elisp-get-fnsym-args-string current-fnsym)
1356                (elisp-get-var-docstring current-symbol)))
1357           (t
1358            (or (elisp-get-var-docstring current-symbol)
1359                (apply #'elisp-get-fnsym-args-string current-fnsym))))))
1360
1361 (defun elisp-get-fnsym-args-string (sym &optional index prefix)
1362   "Return a string containing the parameter list of the function SYM.
1363 If SYM is a subr and no arglist is obtainable from the docstring
1364 or elsewhere, return a 1-line docstring."
1365   (let ((argstring
1366          (cond
1367           ((not (and sym (symbolp sym) (fboundp sym))) nil)
1368           ((and (eq sym (aref elisp--eldoc-last-data 0))
1369                 (eq 'function (aref elisp--eldoc-last-data 2)))
1370            (aref elisp--eldoc-last-data 1))
1371           (t
1372            (let* ((advertised (gethash (indirect-function sym)
1373                                        advertised-signature-table t))
1374                   doc
1375                   (args
1376                    (cond
1377                     ((listp advertised) advertised)
1378                     ((setq doc (help-split-fundoc
1379                                 (condition-case nil (documentation sym t)
1380                                   (invalid-function nil))
1381                                 sym))
1382                      (substitute-command-keys (car doc)))
1383                     (t (help-function-arglist sym)))))
1384              ;; Stringify, and store before highlighting, downcasing, etc.
1385              (elisp--last-data-store sym (elisp-function-argstring args)
1386                                      'function))))))
1387     ;; Highlight, truncate.
1388     (if argstring
1389         (elisp--highlight-function-argument
1390          sym argstring index
1391          (or prefix
1392              (concat (propertize (symbol-name sym) 'face
1393                                  (if (functionp sym)
1394                                      'font-lock-function-name-face
1395                                    'font-lock-keyword-face))
1396                      ": "))))))
1397
1398 (defun elisp--highlight-function-argument (sym args index prefix)
1399   "Highlight argument INDEX in ARGS list for function SYM.
1400 In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'."
1401   ;; FIXME: This should probably work on the list representation of `args'
1402   ;; rather than its string representation.
1403   ;; FIXME: This function is much too long, we need to split it up!
1404   (let* ((start          nil)
1405          (end            0)
1406          (argument-face  'eldoc-highlight-function-argument)
1407          (args-lst (mapcar (lambda (x)
1408                              (replace-regexp-in-string
1409                               "\\`[(]\\|[)]\\'" "" x))
1410                            (split-string args)))
1411          (args-lst-ak (cdr (member "&key" args-lst))))
1412     ;; Find the current argument in the argument string.  We need to
1413     ;; handle `&rest' and informal `...' properly.
1414     ;;
1415     ;; FIXME: What to do with optional arguments, like in
1416     ;;        (defun NAME ARGLIST [DOCSTRING] BODY...) case?
1417     ;;        The problem is there is no robust way to determine if
1418     ;;        the current argument is indeed a docstring.
1419
1420     ;; When `&key' is used finding position based on `index'
1421     ;; would be wrong, so find the arg at point and determine
1422     ;; position in ARGS based on this current arg.
1423     (when (and args-lst-ak
1424                (>= index (- (length args-lst) (length args-lst-ak))))
1425       (let* (case-fold-search
1426              key-have-value
1427              (sym-name (symbol-name sym))
1428              (cur-w (current-word t))
1429              (limit (save-excursion
1430                       (when (re-search-backward sym-name nil t)
1431                         (match-end 0))))
1432              (cur-a (if (and cur-w (string-match ":\\([^ ()]*\\)" cur-w))
1433                         (substring cur-w 1)
1434                       (save-excursion
1435                         (let (split)
1436                           (when (re-search-backward ":\\([^ ()\n]*\\)" limit t)
1437                             (setq split (split-string (match-string 1) " " t))
1438                             (prog1 (car split)
1439                               (when (cdr split)
1440                                 (setq key-have-value t))))))))
1441              ;; If `cur-a' is not one of `args-lst-ak'
1442              ;; assume user is entering an unknown key
1443              ;; referenced in last position in signature.
1444              (other-key-arg (and (stringp cur-a)
1445                                  args-lst-ak
1446                                  (not (member (upcase cur-a) args-lst-ak))
1447                                  (upcase (car (last args-lst-ak))))))
1448         (unless (or (null cur-w) (string= cur-w sym-name))
1449           ;; The last keyword have already a value
1450           ;; i.e :foo a b and cursor is at b.
1451           ;; If signature have also `&rest'
1452           ;; (assume it is after the `&key' section)
1453           ;; go to the arg after `&rest'.
1454           (if (and key-have-value
1455                    (save-excursion
1456                      (not (re-search-forward ":.*" (point-at-eol) t)))
1457                    (string-match "&rest \\([^ ()]*\\)" args))
1458               (setq index nil ; Skip next block based on positional args.
1459                     start (match-beginning 1)
1460                     end   (match-end 1))
1461             ;; If `cur-a' is nil probably cursor is on a positional arg
1462             ;; before `&key', in this case, exit this block and determine
1463             ;; position with `index'.
1464             (when (and cur-a     ; A keyword arg (dot removed) or nil.
1465                        (or (string-match
1466                             (concat "\\_<" (upcase cur-a) "\\_>") args)
1467                            (string-match
1468                             (concat "\\_<" other-key-arg "\\_>") args)))
1469               (setq index nil ; Skip next block based on positional args.
1470                     start (match-beginning 0)
1471                     end   (match-end 0)))))))
1472     ;; Handle now positional arguments.
1473     (while (and index (>= index 1))
1474       (if (string-match "[^ ()]+" args end)
1475           (progn
1476             (setq start (match-beginning 0)
1477                   end   (match-end 0))
1478             (let ((argument (match-string 0 args)))
1479               (cond ((string= argument "&rest")
1480                      ;; All the rest arguments are the same.
1481                      (setq index 1))
1482                     ((string= argument "&optional"))         ; Skip.
1483                     ((string= argument "&allow-other-keys")) ; Skip.
1484                     ;; Back to index 0 in ARG1 ARG2 ARG2 ARG3 etc...
1485                     ;; like in `setq'.
1486                     ((or (and (string-match-p "\\.\\.\\.\\'" argument)
1487                               (string= argument (car (last args-lst))))
1488                          (and (string-match-p "\\.\\.\\.\\'"
1489                                               (substring args 1 (1- (length args))))
1490                               (= (length (remove "..." args-lst)) 2)
1491                               (> index 1) (eq (logand index 1) 1)))
1492                      (setq index 0))
1493                     (t
1494                      (setq index (1- index))))))
1495         (setq end           (length args)
1496               start         (1- end)
1497               argument-face 'font-lock-warning-face
1498               index         0)))
1499     (let ((doc args))
1500       (when start
1501         (setq doc (copy-sequence args))
1502         (add-text-properties start end (list 'face argument-face) doc))
1503       (setq doc (eldoc-docstring-format-sym-doc prefix doc))
1504       doc)))
1505
1506 ;; Return a string containing a brief (one-line) documentation string for
1507 ;; the variable.
1508 (defun elisp-get-var-docstring (sym)
1509   (cond ((not sym) nil)
1510         ((and (eq sym (aref elisp--eldoc-last-data 0))
1511               (eq 'variable (aref elisp--eldoc-last-data 2)))
1512          (aref elisp--eldoc-last-data 1))
1513         (t
1514          (let ((doc (documentation-property sym 'variable-documentation t)))
1515            (when doc
1516              (let ((doc (eldoc-docstring-format-sym-doc
1517                          sym (elisp--docstring-first-line doc)
1518                          'font-lock-variable-name-face)))
1519                (elisp--last-data-store sym doc 'variable)))))))
1520
1521 (defun elisp--last-data-store (symbol doc type)
1522   (aset elisp--eldoc-last-data 0 symbol)
1523   (aset elisp--eldoc-last-data 1 doc)
1524   (aset elisp--eldoc-last-data 2 type)
1525   doc)
1526
1527 ;; Note that any leading `*' in the docstring (which indicates the variable
1528 ;; is a user option) is removed.
1529 (defun elisp--docstring-first-line (doc)
1530   (and (stringp doc)
1531        (substitute-command-keys
1532         (save-match-data
1533           ;; Don't use "^" in the regexp below since it may match
1534           ;; anywhere in the doc-string.
1535           (let ((start (if (string-match "\\`\\*" doc) (match-end 0) 0)))
1536             (cond ((string-match "\n" doc)
1537                    (substring doc start (match-beginning 0)))
1538                   ((zerop start) doc)
1539                   (t (substring doc start))))))))
1540 \f
1541 ;; Return a list of current function name and argument index.
1542 (defun elisp--fnsym-in-current-sexp ()
1543   (save-excursion
1544     (let ((argument-index (1- (elisp--beginning-of-sexp))))
1545       ;; If we are at the beginning of function name, this will be -1.
1546       (when (< argument-index 0)
1547         (setq argument-index 0))
1548       ;; Don't do anything if current word is inside a string.
1549       (if (= (or (char-after (1- (point))) 0) ?\")
1550           nil
1551         (list (elisp--current-symbol) argument-index)))))
1552
1553 ;; Move to the beginning of current sexp.  Return the number of nested
1554 ;; sexp the point was over or after.
1555 (defun elisp--beginning-of-sexp ()
1556   (let ((parse-sexp-ignore-comments t)
1557         (num-skipped-sexps 0))
1558     (condition-case _
1559         (progn
1560           ;; First account for the case the point is directly over a
1561           ;; beginning of a nested sexp.
1562           (condition-case _
1563               (let ((p (point)))
1564                 (forward-sexp -1)
1565                 (forward-sexp 1)
1566                 (when (< (point) p)
1567                   (setq num-skipped-sexps 1)))
1568             (error))
1569           (while
1570               (let ((p (point)))
1571                 (forward-sexp -1)
1572                 (when (< (point) p)
1573                   (setq num-skipped-sexps (1+ num-skipped-sexps))))))
1574       (error))
1575     num-skipped-sexps))
1576
1577 ;; returns nil unless current word is an interned symbol.
1578 (defun elisp--current-symbol ()
1579   (let ((c (char-after (point))))
1580     (and c
1581          (memq (char-syntax c) '(?w ?_))
1582          (intern-soft (current-word)))))
1583
1584 (defun elisp-function-argstring (arglist)
1585   "Return ARGLIST as a string enclosed by ().
1586 ARGLIST is either a string, or a list of strings or symbols."
1587   (let ((str (cond ((stringp arglist) arglist)
1588                    ((not (listp arglist)) nil)
1589                    (t (substitute-command-keys
1590                        (help--make-usage-docstring 'toto arglist))))))
1591     (if (and str (string-match "\\`([^ )]+ ?" str))
1592         (replace-match "(" t t str)
1593       str)))
1594
1595 ;;; Flymake support
1596
1597 ;; Don't require checkdoc, but forward declare these checkdoc special
1598 ;; variables. Autoloading them on `checkdoc-current-buffer' is too
1599 ;; late, they won't be bound dynamically.
1600 (defvar checkdoc-create-error-function)
1601 (defvar checkdoc-autofix-flag)
1602 (defvar checkdoc-generate-compile-warnings-flag)
1603 (defvar checkdoc-diagnostic-buffer)
1604
1605 ;;;###autoload
1606 (defun elisp-flymake-checkdoc (report-fn &rest _args)
1607   "A Flymake backend for `checkdoc'.
1608 Calls REPORT-FN directly."
1609   (let (collected)
1610     (let* ((checkdoc-create-error-function
1611             (lambda (text start end &optional unfixable)
1612               (push (list text start end unfixable) collected)
1613               nil))
1614            (checkdoc-autofix-flag nil)
1615            (checkdoc-generate-compile-warnings-flag nil)
1616            (checkdoc-diagnostic-buffer
1617             (generate-new-buffer " *checkdoc-temp*")))
1618       (unwind-protect
1619           (save-excursion
1620             ;; checkdoc-current-buffer can error if there are
1621             ;; unbalanced parens, for example, but this shouldn't
1622             ;; disable the backend (bug#29176).
1623             (ignore-errors
1624               (checkdoc-current-buffer t)))
1625         (kill-buffer checkdoc-diagnostic-buffer)))
1626     (funcall report-fn
1627              (cl-loop for (text start end _unfixable) in
1628                       collected
1629                       collect
1630                       (flymake-make-diagnostic
1631                        (current-buffer)
1632                        start end :note text)))
1633     collected))
1634
1635 (defun elisp-flymake--byte-compile-done (report-fn
1636                                          source-buffer
1637                                          output-buffer)
1638   (with-current-buffer
1639       source-buffer
1640     (save-excursion
1641       (save-restriction
1642         (widen)
1643         (funcall
1644          report-fn
1645          (cl-loop with data =
1646                   (with-current-buffer output-buffer
1647                     (goto-char (point-min))
1648                     (search-forward ":elisp-flymake-output-start")
1649                     (read (point-marker)))
1650                   for (string pos _fill level) in data
1651                   do (goto-char pos)
1652                   for beg = (if (< (point) (point-max))
1653                                 (point)
1654                               (line-beginning-position))
1655                   for end = (min
1656                              (line-end-position)
1657                              (or (cdr
1658                                   (bounds-of-thing-at-point 'sexp))
1659                                  (point-max)))
1660                   collect (flymake-make-diagnostic
1661                            (current-buffer)
1662                            (if (= beg end) (1- beg) beg)
1663                            end
1664                            level
1665                            string)))))))
1666
1667 (defvar-local elisp-flymake--byte-compile-process nil
1668   "Buffer-local process started for byte-compiling the buffer.")
1669
1670 ;;;###autoload
1671 (defun elisp-flymake-byte-compile (report-fn &rest _args)
1672   "A Flymake backend for elisp byte compilation.
1673 Spawn an Emacs process that byte-compiles a file representing the
1674 current buffer state and calls REPORT-FN when done."
1675   (when elisp-flymake--byte-compile-process
1676     (when (process-live-p elisp-flymake--byte-compile-process)
1677       (kill-process elisp-flymake--byte-compile-process)))
1678   (let ((temp-file (make-temp-file "elisp-flymake-byte-compile"))
1679         (source-buffer (current-buffer)))
1680     (save-restriction
1681       (widen)
1682       (write-region (point-min) (point-max) temp-file nil 'nomessage))
1683     (let* ((output-buffer (generate-new-buffer " *elisp-flymake-byte-compile*")))
1684       (setq
1685        elisp-flymake--byte-compile-process
1686        (make-process
1687         :name "elisp-flymake-byte-compile"
1688         :buffer output-buffer
1689         :command (list (expand-file-name invocation-name invocation-directory)
1690                        "-Q"
1691                        "--batch"
1692                        ;; "--eval" "(setq load-prefer-newer t)" ; for testing
1693                        "-L" default-directory
1694                        "-f" "elisp-flymake--batch-compile-for-flymake"
1695                        temp-file)
1696         :connection-type 'pipe
1697         :sentinel
1698         (lambda (proc _event)
1699           (when (eq (process-status proc) 'exit)
1700             (unwind-protect
1701                 (cond
1702                  ((not (and (buffer-live-p source-buffer)
1703                             (eq proc (with-current-buffer source-buffer
1704                                        elisp-flymake--byte-compile-process))))
1705                   (flymake-log :warning
1706                                "byte-compile process %s obsolete" proc))
1707                  ((zerop (process-exit-status proc))
1708                   (elisp-flymake--byte-compile-done report-fn
1709                                                     source-buffer
1710                                                     output-buffer))
1711                  (t
1712                   (funcall report-fn
1713                            :panic
1714                            :explanation
1715                            (format "byte-compile process %s died" proc))))
1716               (ignore-errors (delete-file temp-file))
1717               (kill-buffer output-buffer))))))
1718       :stderr null-device
1719       :noquery t)))
1720
1721 (defun elisp-flymake--batch-compile-for-flymake (&optional file)
1722   "Helper for `elisp-flymake-byte-compile'.
1723 Runs in a batch-mode Emacs.  Interactively use variable
1724 `buffer-file-name' for FILE."
1725   (interactive (list buffer-file-name))
1726   (let* ((file (or file
1727                    (car command-line-args-left)))
1728          (dummy-elc-file)
1729          (byte-compile-log-buffer
1730           (generate-new-buffer " *dummy-byte-compile-log-buffer*"))
1731          (byte-compile-dest-file-function
1732           (lambda (source)
1733             (setq dummy-elc-file (make-temp-file (file-name-nondirectory source)))))
1734          (collected)
1735          (byte-compile-log-warning-function
1736           (lambda (string &optional position fill level)
1737             (push (list string position fill level)
1738                   collected)
1739             t)))
1740     (unwind-protect
1741         (byte-compile-file file)
1742       (ignore-errors
1743         (delete-file dummy-elc-file)
1744         (kill-buffer byte-compile-log-buffer)))
1745     (prin1 :elisp-flymake-output-start)
1746     (terpri)
1747     (pp collected)))
1748
1749 (provide 'elisp-mode)
1750 ;;; elisp-mode.el ends here