Add optional semantic highlighting for Emacs Lisp.

* lisp/emacs-lisp/scope.el: New file.

* lisp/progmodes/elisp-mode.el (elisp): New 'defgroup'.
(elisp-add-help-echo, elisp-fontify-semantically)
(elisp-fontify-symbol-precedence-function): New options.
(elisp-symbol-at-mouse, elisp-free-variable, elisp-condition)
(elisp-major-mode-name, elisp-face, elisp-symbol-type)
(elisp-symbol-type-definition, elisp-function-reference)
(elisp-non-local-exit, elisp-unknown-call, elisp-macro-call)
(elisp-special-form, elisp-throw-tag, elisp-feature)
(elisp-rx, elisp-theme, elisp-binding-variable)
(elisp-bound-variable, elisp-shadowing-variable)
(elisp-shadowed-variable, elisp-variable-at-point)
(elisp-warning-type, elisp-declaration, elisp-thing)
(elisp-slot, elisp-widget-type, elisp-type, elisp-group)
(elisp-nnoo-backend, elisp-ampersand, elisp-constant)
(elisp-defun, elisp-defmacro, elisp-defvar, elisp-defface)
(elisp-icon, elisp-deficon, elisp-oclosure)
(elisp-defoclosure, elisp-coding, elisp-defcoding)
(elisp-charset, elisp-defcharset, elisp-completion-category)
(elisp-completion-category-definition): New faces.
(elisp-local-references, elisp-highlight-variable)
(elisp-unhighlight-variable, elisp-cursor-sensor)
(elisp--function-help-echo, elisp--help-echo-1)
(elisp--help-echo, elisp--annotate-symbol-with-help-echo)
(elisp-extend-region-to-whole-defuns, elisp-fontify-symbol)
(elisp-fontify-region-semantically, elisp-fontify-region):
New functions.
(emacs-lisp-mode): Set 'font-lock-extra-managed-props',
'font-lock-fontify-region-function' and
'font-lock-extend-region-functions'.

* etc/NEWS: Announce new feature.

etc/NEWS

@@ -1151,6 +1151,13 @@ at run-time for the use of the associated deprecated features.
 '(setq eieio-backward-compatibility t)' can be used to recover
 the previous silence.
 
+** ELisp mode
+
+*** Semantic highlighting support for Emacs Lisp.
+'emacs-lisp-mode' can now use code analysis to highlight more symbols
+more accurately.  Customize the new user option
+'elisp-fontify-semantically' to non-nil to enable this feature.
+
 ** Text mode
 
 ---

lisp/progmodes/elisp-mode.el

@@ -278,6 +278,286 @@ Comments in the form will be lost."
             (string-to-syntax "'")))))
      start end)))
 
+(defgroup elisp nil "Emacs Lisp editing support." :group 'lisp)
+
+(defcustom elisp-fontify-semantically nil
+  "Whether to highlight symbols according to their meaning.
+
+If this is non-nil, `emacs-lisp-mode' uses code analysis to determine
+the role of each symbol and highlight it accordingly."
+  :type 'boolean)
+
+(defface elisp-symbol-at-mouse
+  '((((background light)) :background "#fff6d8")
+    (((background dark))  :background "#00422a"))
+  "Face for highlighting the symbol at mouse in Emacs Lisp code.")
+
+(defface elisp-free-variable '((t :inherit underline))
+  "Face for highlighting free variables in Emacs Lisp code.")
+
+(defface elisp-condition '((t :foreground "red"))
+  "Face for highlighting `condition-case' conditions in Emacs Lisp code.")
+
+(defface elisp-major-mode-name '((t :foreground "#006400"))
+  "Face for highlighting major mode names in Emacs Lisp code.")
+
+(defface elisp-face '((t :inherit font-lock-type-face))
+  "Face for highlighting face names in Emacs Lisp code.")
+
+(defface elisp-symbol-type '((t :foreground "#00008b" :inherit font-lock-function-call-face))
+  "Face for highlighting symbol type names in Emacs Lisp code.")
+
+(defface elisp-symbol-type-definition '((t :foreground "#00008b" :inherit font-lock-function-name-face))
+  "Face for highlighting symbol type names in Emacs Lisp code.")
+
+(defface elisp-function-reference '((t :inherit font-lock-function-call-face))
+  "Face for highlighting function calls in Emacs Lisp code.")
+
+(defface elisp-non-local-exit '((t :inherit elisp-function-reference :underline "red"))
+  "Face for highlighting function calls in Emacs Lisp code.")
+
+(defface elisp-unknown-call '((t :inherit elisp-function-reference :foreground "#2f4f4f"))
+  "Face for highlighting unknown functions/macros in Emacs Lisp code.")
+
+(defface elisp-macro-call '((t :inherit font-lock-keyword-face))
+  "Face for highlighting macro calls in Emacs Lisp code.")
+
+(defface elisp-special-form '((t :inherit elisp-macro-call))
+  "Face for highlighting special forms in Emacs Lisp code.")
+
+(defface elisp-throw-tag '((t :inherit font-lock-constant-face))
+  "Face for highlighting `catch'/`throw' tags in Emacs Lisp code.")
+
+(defface elisp-feature '((t :inherit font-lock-constant-face))
+  "Face for highlighting feature names in Emacs Lisp code.")
+
+(defface elisp-rx '((t :foreground "#00008b"))
+  "Face for highlighting `rx' constructs in Emacs Lisp code.")
+
+(defface elisp-theme '((t :inherit font-lock-constant-face))
+  "Face for highlighting custom theme names in Emacs Lisp code.")
+
+(defface elisp-binding-variable
+  '((t :slant italic :inherit font-lock-variable-name-face))
+  "Face for highlighting binding occurrences of variables in Emacs Lisp code.")
+
+(defface elisp-bound-variable '((t :slant italic))
+  "Face for highlighting bound occurrences of variables in Emacs Lisp code.")
+
+(defface elisp-shadowing-variable
+  '((t :inherit elisp-binding-variable :underline t))
+  "Face for highlighting binding occurrences of variables in Emacs Lisp code.")
+
+(defface elisp-shadowed-variable
+  '((t :inherit elisp-bound-variable :underline t))
+  "Face for highlighting bound occurrences of variables in Emacs Lisp code.")
+
+(defface elisp-variable-at-point '((t :inherit bold))
+  "Face for highlighting (all occurrences of) the variable at point.")
+
+(defface elisp-warning-type '((t :inherit font-lock-type-face))
+  "Face for highlighting byte-compilation warning type names in Emacs Lisp.")
+
+(defface elisp-declaration '((t :inherit font-lock-variable-use-face))
+  "Face for highlighting function attribute declaration type names.")
+
+(defface elisp-thing '((t :inherit font-lock-type-face))
+  "Face for highlighting `thing-at-point' \"thing\" names in Emacs Lisp.")
+
+(defface elisp-slot '((t :inherit font-lock-builtin-face))
+  "Face for highlighting EIEIO slot names.")
+
+(defface elisp-widget-type '((t :inherit font-lock-type-face))
+  "Face for highlighting widget type names in Emacs Lisp code.")
+
+(defface elisp-type '((t :inherit font-lock-type-face))
+  "Face for highlighting object type names in Emacs Lisp code.")
+
+(defface elisp-group '((t :inherit font-lock-type-face))
+  "Face for highlighting customization group names in Emacs Lisp code.")
+
+(defface elisp-nnoo-backend '((t :inherit font-lock-type-face))
+  "Face for highlighting `nnoo' backend names in Emacs Lisp code.")
+
+(defface elisp-ampersand '((t :inherit font-lock-type-face))
+  "Face for highlighting argument list markers, such as `&optional'.")
+
+(defface elisp-constant '((t :inherit font-lock-builtin-face))
+  "Face for highlighting self-evaluating symbols in Emacs Lisp code.")
+
+(defface elisp-defun '((t :inherit font-lock-function-name-face))
+  "Face for highlighting function definitions in Emacs Lisp code.")
+
+(defface elisp-defmacro '((t :inherit elisp-defun))
+  "Face for highlighting macro definitions in Emacs Lisp code.")
+
+(defface elisp-defvar '((t :inherit font-lock-variable-name-face))
+  "Face for highlighting variable definitions in Emacs Lisp code.")
+
+(defface elisp-defface '((t :inherit font-lock-variable-name-face))
+  "Face for highlighting face definitions in Emacs Lisp code.")
+
+(defface elisp-icon '((t :inherit font-lock-type-face))
+  "Face for highlighting icon name in Emacs Lisp code.")
+
+(defface elisp-deficon '((t :inherit elisp-icon))
+  "Face for highlighting icon definitions in Emacs Lisp code.")
+
+(defface elisp-oclosure '((t :inherit font-lock-type-face))
+  "Face for highlighting OClosure type names in Emacs Lisp code.")
+
+(defface elisp-defoclosure '((t :inherit elisp-oclosure))
+  "Face for highlighting OClosure type definitions in Emacs Lisp code.")
+
+(defface elisp-coding '((t :inherit font-lock-type-face))
+  "Face for highlighting coding system names in Emacs Lisp code.")
+
+(defface elisp-defcoding '((t :inherit elisp-coding))
+  "Face for highlighting coding system definitions in Emacs Lisp code.")
+
+(defface elisp-charset '((t :inherit font-lock-type-face))
+  "Face for highlighting charset names in Emacs Lisp code.")
+
+(defface elisp-defcharset '((t :inherit elisp-charset))
+  "Face for highlighting charset definitions in Emacs Lisp code.")
+
+(defface elisp-completion-category '((t :inherit font-lock-type-face))
+  "Face for highlighting completion category names in Emacs Lisp code.")
+
+(defface elisp-completion-category-definition
+  '((t :inherit elisp-completion-category))
+  "Face for highlighting completion category definitions in Emacs Lisp code.")
+
+(defun elisp-local-references (pos)
+  "Return references to local variable at POS as (BEG . LEN) cons cells."
+  (let (all cur)
+    (save-excursion
+      (goto-char pos)
+      (beginning-of-defun)
+      (scope (lambda (_type beg len id &optional _def)
+               (when (<= beg pos (+ beg len))
+                 (setq cur id))
+               (when id (setf (alist-get beg all) (list len id))))))
+    (seq-keep
+     (pcase-lambda (`(,beg ,len ,id)) (when (equal id cur) (cons beg len)))
+     all)))
+
+(defun elisp-highlight-variable (pos)
+  "Highlight variable at POS along with its co-occurrences."
+  (pcase-dolist (`(,beg . ,len) (elisp-local-references pos))
+    (let ((ov (make-overlay beg (+ beg len))))
+      (overlay-put ov 'face 'elisp-variable-at-point)
+      (overlay-put ov 'elisp-highlight-variable t))))
+
+(defun elisp-unhighlight-variable (pos)
+  "Remove variable highlighting across top-level form at POS."
+  (save-excursion
+    (goto-char pos)
+    (beginning-of-defun)
+    (remove-overlays (point) (progn (end-of-defun) (point))
+                     'elisp-highlight-variable t)))
+
+(defun elisp-cursor-sensor (pos)
+  "Return `cursor-sensor-functions' for ELisp symbol at POS."
+  (list
+   (lambda (_win old dir)
+     (cl-case dir
+       (entered (elisp-highlight-variable pos))
+       (left (elisp-unhighlight-variable old))))))
+
+(defun elisp--function-help-echo (sym &rest _)
+  (when (fboundp sym)
+    (with-temp-buffer
+      (let ((standard-output (current-buffer)))
+        (insert "`" (symbol-name sym) "' is ")
+        (describe-function-1 sym))
+      (buffer-string))))
+
+(defun elisp--help-echo-1 (str sym prop &rest _)
+  (if-let* ((doc (documentation-property sym prop t)))
+      (format "%s `%S'.\n\n%s" str sym doc)
+    str))
+
+(defun elisp--help-echo (beg end prop str)
+  (if-let* ((sym (intern-soft (buffer-substring-no-properties beg end))))
+      (apply-partially #'elisp--help-echo-1 str sym prop)
+    str))
+
+(defcustom elisp-add-help-echo t
+  "Whether to add `help-echo' property to symbols while highlighting them."
+  :type 'boolean)
+
+(defun elisp--annotate-symbol-with-help-echo (type beg end def)
+  (when elisp-add-help-echo
+    (put-text-property
+     beg end 'help-echo
+     (when-let* ((fun (scope-get-symbol-type-property type :help)))
+       (funcall fun beg end def)))))
+
+(defvar font-lock-beg)
+(defvar font-lock-end)
+
+(defun elisp-extend-region-to-whole-defuns ()
+  (when elisp-fontify-semantically
+    (let (changed)
+      (when-let* ((new-beg (syntax-ppss-toplevel-pos (syntax-ppss font-lock-beg))))
+        (setq font-lock-beg new-beg changed t))
+      (when-let* ((beg-of-end (syntax-ppss-toplevel-pos (syntax-ppss font-lock-end)))
+                  (new-end (ignore-error scan-error (scan-sexps beg-of-end 1))))
+        (setq font-lock-end new-end changed t))
+      changed)))
+
+(defcustom elisp-fontify-symbol-precedence-function #'ignore
+  "Function that determines the precedence of semantic highlighting.
+
+The function takes two arguments, BEG and END, which are the beginning
+and end positions in the current buffer of a symbol that is about to be
+fontified during semantic highlighting.  The function is called after
+`font-lock-keywords' were already applied.  If the function returns nil,
+then semantic highlighting takes precedence, otherwise the highlighting
+that `font-lock-keywords' applied takes precedence, if any."
+  :type '(choice
+          (function-item :tag "Prioritize semantic highlighting" ignore)
+          (function-item :tag "Prioritize `font-lock-keywords'" always)
+          (function :tag "Custom function")))
+
+(defun elisp-fontify-symbol (type beg len id &optional def)
+  (let ((end (+ beg len)))
+    (elisp--annotate-symbol-with-help-echo type beg end def)
+    (let ((face (scope-get-symbol-type-property type :face)))
+      (add-face-text-property
+       beg end face
+       (cl-case elisp-fontify-symbol-precedence-function
+         (ignore nil)
+         (always t)
+         (otherwise (funcall elisp-fontify-symbol-precedence-function beg end))))
+      (put-text-property beg end 'mouse-face `(,face elisp-symbol-at-mouse))
+      (when id
+        (put-text-property beg (1+ end) 'cursor-sensor-functions
+                           ;; Get a fresh list with SYM hardcoded,
+                           ;; so that the value is distinguishable
+                           ;; from the value in adjacent regions.
+                           (elisp-cursor-sensor beg))))))
+
+(defun elisp-fontify-region-semantically (beg end)
+  "Fontify symbols between BEG and END according to their semantics."
+  (save-excursion
+    (goto-char beg)
+    (while (< (point) end) (ignore-errors (scope #'elisp-fontify-symbol)))))
+
+(defun elisp-fontify-region (beg end &optional loudly)
+  "Fontify ELisp code between BEG and END.
+
+Non-nil optional argument LOUDLY permits printing status messages.
+
+This is the `font-lock-fontify-region-function' for `emacs-lisp-mode'."
+  (if (not elisp-fontify-semantically)
+      (font-lock-default-fontify-region beg end loudly)
+    (pcase (font-lock-default-fontify-region beg end loudly)
+      (`(jit-lock-bounds ,beg1 . ,end1) (setq beg beg1 end end1)))
+    (elisp-fontify-region-semantically beg end)
+    `(jit-lock-bounds ,beg . ,end)))
+
 (defun elisp-outline-search (&optional bound move backward looking-at)
   "Don't use leading parens in strings for outline headings."
   (if looking-at
@@ -375,7 +655,16 @@ be used instead.
           '(lisp-el-font-lock-keywords
             lisp-el-font-lock-keywords-1
             lisp-el-font-lock-keywords-2))
+  (dolist (prop '(cursor-sensor-functions help-echo mouse-face))
+    (cl-pushnew prop
+                (alist-get 'font-lock-extra-managed-props
+                           (nthcdr 5 font-lock-defaults))))
+  (setf (alist-get 'font-lock-fontify-region-function
+                   (nthcdr 5 font-lock-defaults))
+        #'elisp-fontify-region)
   (setf (nth 2 font-lock-defaults) nil)
+  (add-hook 'font-lock-extend-region-functions
+            #'elisp-extend-region-to-whole-defuns nil t)
   (add-hook 'after-load-functions #'elisp--font-lock-flush-elisp-buffers)
   (if (boundp 'electric-pair-text-pairs)
       (setq-local electric-pair-text-pairs