From 7fe833498bfd14c6a8c38d60381c1fc6b2cae834 Mon Sep 17 00:00:00 2001
From: Eshel Yaron <me@eshelyaron.com>
Date: Thu, 8 Aug 2024 13:55:34 +0200
Subject: [PATCH] Xref: support lexical variables in Emacs Lisp

* lisp/emacs-lisp/scope.el
* test/lisp/emacs-lisp/scope-tests.el: New files.
* lisp/progmodes/elisp-mode.el (xref-backend-definitions)
Use new 'scope' function to find bindings of lexical vars.
(xref-backend-references): Implement method.
* lisp/progmodes/xref.el (xref-location-line): Implement for
'xref-buffer-location' locations.
---
 lisp/emacs-lisp/scope.el            | 802 ++++++++++++++++++++++++++++
 lisp/progmodes/elisp-mode.el        |  61 ++-
 lisp/progmodes/xref.el              |   5 +
 test/lisp/emacs-lisp/scope-tests.el |  75 +++
 4 files changed, 931 insertions(+), 12 deletions(-)
 create mode 100644 lisp/emacs-lisp/scope.el
 create mode 100644 test/lisp/emacs-lisp/scope-tests.el

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
new file mode 100644
index 00000000000..e006948d3cd
--- /dev/null
+++ b/lisp/emacs-lisp/scope.el
@@ -0,0 +1,802 @@
+;;; scope.el --- Scope analysis for Emacs Lisp  -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2024  Eshel Yaron
+
+;; Author: Eshel Yaron <me@eshelyaron.com>
+;; Keywords: lisp, languages
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Scope analysis for Emacs Lisp.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+
+(defvar scope-flet-list nil)
+
+(defun scope-s (local sym)
+  (let* ((beg (symbol-with-pos-pos sym))
+         (bare (bare-symbol sym))
+         (len (length (symbol-name bare))))
+    (unless (or (booleanp bare) (keywordp bare))
+      (list (list beg len (alist-get bare local))))))
+
+(defun scope-let (local bindings body)
+  (append
+   (mapcan (lambda (binding)
+             (if (consp binding)
+                 (cons
+                  (let* ((sym (car binding))
+                         (beg (symbol-with-pos-pos sym))
+                         (bare (bare-symbol sym))
+                         (len (length (symbol-name bare))))
+                    (list beg len beg))
+                  (scope-1 local (cadr binding)))
+               (let* ((sym binding)
+                      (beg (symbol-with-pos-pos sym))
+                      (bare (bare-symbol sym))
+                      (len (length (symbol-name bare))))
+                 (list (list beg len beg)))))
+           bindings)
+   (scope-n
+    (append (mapcar
+             (lambda (binding)
+               (let ((sym (if (consp binding) (car binding) binding)))
+                 (cons (bare-symbol sym) (symbol-with-pos-pos sym))))
+             bindings)
+            local)
+    body)))
+
+(defun scope-let* (local bindings body)
+  (if bindings
+      (let ((binding (car bindings)))
+        (append
+         (if (consp binding)
+             (cons
+              (let* ((sym (car binding))
+                     (beg (symbol-with-pos-pos sym))
+                     (bare (bare-symbol sym)))
+                (list beg (length (symbol-name bare)) beg))
+              (scope-1 local (cadr binding)))
+           (let* ((sym binding)
+                  (beg (symbol-with-pos-pos sym))
+                  (bare (bare-symbol sym)))
+             (list (list beg (length (symbol-name bare)) beg))))
+         (scope-let*
+          (cons (let ((sym (if (consp binding) (car binding) binding)))
+                  (cons (bare-symbol sym) (symbol-with-pos-pos sym)))
+                local)
+          (cdr bindings)
+          body)))
+    (scope-n local body)))
+
+(defun scope-if-let* (local bindings body)
+  (if bindings
+      (let ((binding (car bindings)))
+        (if (consp binding)
+            (if (cdr binding)
+                ;; BINDING is (SYMBOL VALUEFORM).
+                (let* ((sym (car binding))
+                       (beg (symbol-with-pos-pos sym))
+                       (bare (bare-symbol sym)))
+                  (cons
+                   (list beg (length (symbol-name bare)) beg)
+                   (nconc (scope-1 local (cadr binding))
+                          (scope-if-let* (cons (cons bare beg) local)
+                                         (cdr bindings) body))))
+              ;; BINDING is (VALUEFORM).
+              (nconc (scope-1 local (car binding))
+                     (scope-if-let* local (cdr bindings) body)))
+          ;; BINDING is just SYMBOL.
+          (let* ((sym binding)
+                 (beg (symbol-with-pos-pos sym))
+                 (bare (bare-symbol sym)))
+            (cons
+             (list beg (length (symbol-name bare)) beg)
+             (scope-if-let* (cons (cons bare beg) local)
+                            (cdr bindings) body)))))
+    (scope-n local body)))
+
+(defun scope-if-let (local bindings body)
+  (scope-if-let* local
+                 (if (and (consp bindings) (symbol-with-pos-p (car bindings)))
+                     (list bindings)
+                   bindings)
+                 body))
+
+(defun scope-defun (local _name args body)
+  (let ((int-spec nil)
+        (doc-form nil))
+    (cond
+     ((and (consp (car body)) (symbol-with-pos-p (caar body))
+           (eq (bare-symbol (caar body)) :documentation))
+      (setq doc-form (cadar body))
+      (setq body (cdr body)))
+     ((stringp (car body)) (setq body (cdr body))))
+    (when (and (consp (car body)) (symbol-with-pos-p (caar body))
+               (eq (bare-symbol (caar body)) 'declare))
+      (setq body (cdr body)))
+    (when (and (consp (car body)) (symbol-with-pos-p (caar body))
+               (eq (bare-symbol (caar body)) 'interactive))
+      (setq int-spec (cadar body))
+      (setq body (cdr body)))
+    (append
+     (seq-keep (lambda (arg)
+                 (and (symbol-with-pos-p arg)
+                      (not (memq (bare-symbol arg) '(&optional &rest _)))
+                      (let* ((beg (symbol-with-pos-pos arg))
+                             (bare (bare-symbol arg))
+                             (len (length (symbol-name bare))))
+                        (list beg len beg))))
+               args)
+     (scope-1 local doc-form)
+     (scope-1 local int-spec)
+     (scope-n (append
+               (seq-keep (lambda (arg)
+                           (and (symbol-with-pos-p arg)
+                                (not (memq (bare-symbol arg) '(&optional &rest)))
+                                (cons (bare-symbol arg) (symbol-with-pos-pos arg))))
+                         args)
+               local)
+              body))))
+
+(defun scope-defmethod-1 (local0 local name args body)
+  (if args
+      (let ((arg (car args)))
+        (cond
+         ((consp arg)
+          (let ((var (car arg))
+                (spec (cadr arg)))
+            (cond
+             ((symbol-with-pos-p var)
+              (let* ((beg (symbol-with-pos-pos var))
+                     (bare (bare-symbol var))
+                     (len (length (symbol-name bare))))
+                (cons
+                 (list beg len beg)
+                 (append
+                  (cond
+                   ((consp spec)
+                    (let ((head (car spec))
+                          (form (cadr spec)))
+                      (and (symbol-with-pos-p head)
+                           (eq 'eql (bare-symbol head))
+                           (not (or (symbolp form) (symbol-with-pos-p form)))
+                           (scope-1 local0 form)))))
+                  (scope-defmethod-1 local0 (cons (cons bare beg) local) name (cdr args) body)))))
+             ((consp var)
+              ;; VAR is (&key (VAR INIT SVAR)) or (&key VAR).
+              (let ((var (cadr var)))
+                (cond
+                 ((symbol-with-pos-p var)
+                  (let* ((beg (symbol-with-pos-pos var))
+                         (bare (bare-symbol var))
+                         (len (length (symbol-name bare))))
+                    (cons
+                     (list beg len beg)
+                     (append
+                      (cond
+                       ((consp spec)
+                        (let ((head (car spec))
+                              (form (cadr spec)))
+                          (and (symbol-with-pos-p head)
+                               (eq 'eql (bare-symbol head))
+                               (not (or (symbolp form) (symbol-with-pos-p form)))
+                               (scope-1 local0 form)))))
+                      (scope-defmethod-1 local0 (cons (cons bare beg) local) name (cdr args) body)))))
+                 ((consp var)
+                  (let* ((init (cadr var))
+                         (svar (caddr var))
+                         (var (car var))
+                         (beg (symbol-with-pos-pos var))
+                         (bare (bare-symbol var))
+                         (len (length (symbol-name bare))))
+                    (cons
+                     (list beg len beg)
+                     (append
+                      (scope-1 local0 init)
+                      (when svar
+                        (let ((sbeg (symbol-with-pos-pos svar)))
+                          (list (list sbeg (length (symbol-name (bare-symbol svar)))
+                                      sbeg))))
+                      (scope-defmethod-1 local0 (cons (cons bare beg)
+                                                      (append
+                                                       (when svar
+                                                         (list (cons (bare-symbol svar)
+                                                                     (symbol-with-pos-pos svar))))
+                                                       local))
+                                         name (cdr args) body)))))))))))
+         ((symbol-with-pos-p arg)
+          (cond
+           ((memq (bare-symbol arg) '(&optional &rest &body _))
+            (scope-defmethod-1 local0 local name (cdr args) body))
+           ((eq (bare-symbol arg) '&context)
+            (let* ((expr-type (cadr args))
+                   (expr (car expr-type))
+                   (type (cadr expr-type))
+                   (more (cddr args)))
+              (append
+               (scope-1 local0 expr)
+               (cond
+                ((consp type)
+                 (let ((head (car type))
+                       (form (cadr type)))
+                   (and (symbol-with-pos-p head)
+                        (eq 'eql (bare-symbol head))
+                        (not (or (symbolp form) (symbol-with-pos-p form)))
+                        (scope-1 local0 form)))))
+               (scope-defmethod-1 local0 local name more body))))
+           (t
+            (let* ((beg (symbol-with-pos-pos arg))
+                   (bare (bare-symbol arg))
+                   (len (length (symbol-name bare))))
+              (cons
+               (list beg len beg)
+               (scope-defmethod-1 local0 (cons (cons bare beg) local)
+                                  name (cdr args) body))))))))
+    (scope-n local body)))
+
+(defun scope-defmethod (local name rest)
+  (when (and (symbol-with-pos-p (car rest))
+             (eq (bare-symbol (car rest)) :extra))
+    (setq rest (cddr rest)))
+  (when (and (symbol-with-pos-p (car rest))
+             (memq (bare-symbol (car rest)) '(:before :after :around)))
+    (setq rest (cdr rest)))
+  (scope-defmethod-1 local local name (car rest)
+                     (if (stringp (cadr rest)) (cddr rest) (cdr rest))))
+
+(defun scope-defgeneric-2 (local name args body)
+  (cond
+   ((and (consp (car body)) (symbol-with-pos-p (caar body))
+         (memq (bare-symbol (caar body))
+               '(declare :documentation :argument-precedence-order)))
+    (scope-defgeneric-1 local name args (cdr body)))
+   ((and (consp (car body)) (symbol-with-pos-p (caar body))
+         (eq (bare-symbol (caar body)) :method))
+    (append
+     (scope-defmethod local nil (cdar body))
+     (scope-defgeneric-1 local name args (cdr body))))
+   ;; FIXME: `args' may include `&key', so defun is not a perfect match.
+   (t (scope-defun local name args body))))
+
+(defun scope-defgeneric-1 (local name args body)
+  (cond
+   ((and (consp (car body)) (symbol-with-pos-p (caar body))
+         (memq (bare-symbol (caar body))
+               '(declare :documentation :argument-precedence-order)))
+    (scope-defgeneric-1 local name args (cdr body)))
+   ((and (consp (car body)) (symbol-with-pos-p (caar body))
+         (eq (bare-symbol (caar body)) :method))
+    (append
+     (scope-defmethod local nil (cdar body))
+     (scope-defgeneric-1 local name args (cdr body))))
+   (t (scope-defgeneric-2 local name args body))))
+
+(defun scope-defgeneric (local name args body)
+  (when (stringp (car body)) (setq body (cdr body)))
+  (scope-defgeneric-1 local name args body))
+
+(defun scope-cond (local clauses)
+  (mapcan (apply-partially #'scope-n local) clauses))
+
+(defun scope-setq (local args)
+  (cl-loop for (var val) on args by #'cddr
+           nconc (nconc (scope-s local var) (scope-1 local val))))
+
+(defun scope-defvar (local _sym init) (scope-1 local init))
+
+(defun scope-condition-case (local var bodyform handlers)
+  (append
+   (when var
+     (let* ((beg (symbol-with-pos-pos var))
+            (bare (bare-symbol var)))
+       (list (list beg (length (symbol-name bare)) beg))))
+   (scope-1 local bodyform)
+   (mapcan
+    (let ((l (if var (cons (cons (bare-symbol var) (symbol-with-pos-pos var)) local) local)))
+      (lambda (handler) (scope-n l (cdr handler))))
+    handlers)))
+
+(defun scope-dotimes (local var lst res body)
+  (cons
+   (let* ((beg (symbol-with-pos-pos var))
+          (bare (bare-symbol var)))
+     (list beg (length (symbol-name bare)) beg))
+   (append
+    (scope-1 local lst)
+    (scope-1 local res)
+    (let ((l (cons (cons (bare-symbol var) (symbol-with-pos-pos var)) local)))
+      (scope-n l body)))))
+
+(defun scope-pcase-qpat (local qpat)
+  (cond
+   ((consp qpat)
+    (if (eq (car qpat) '\,) (scope-pcase-pattern local (cadr qpat))
+      (let* ((l-r0 (scope-pcase-qpat local (car qpat)))
+             (l (car l-r0))
+             (r0 (cdr l-r0))
+             (l-r (scope-pcase-qpat l (cdr qpat))))
+        (cons (car l-r) (append r0 (cdr l-r))))))
+   ;; FIXME: Support vector qpats.
+   (t (list local))))
+
+(defun scope-pcase-pattern (local pattern)
+  (cond
+   ((symbol-with-pos-p pattern)
+    (let ((bare (bare-symbol pattern)))
+      (if (eq bare '_) (list local)
+        (let* ((beg (symbol-with-pos-pos pattern)))
+          (cons (cons (cons bare beg) local)
+                (list (list beg (length (symbol-name bare)) beg)))))))
+   ((consp pattern)
+    (cond
+     ((eq (car pattern) '\`)
+      (scope-pcase-qpat local (cadr pattern)))
+     ;; FIXME: Refine.
+     (t (list local))))))
+
+(defun scope-pcase-1 (local pattern body)
+  (let* ((l-r (scope-pcase-pattern local pattern))
+         (l (car l-r))
+         (r (cdr l-r)))
+    (when l (append r (scope-n l body)))))
+
+(defun scope-pcase (local exp cases)
+  (append
+   (scope-1 local exp)
+   (mapcan
+    (lambda (case)
+      (scope-pcase-1 local (car case) (cdr case)))
+    cases)))
+
+(defun scope-push (local new place)
+  (append (scope-1 local new) (scope-1 local place)))
+
+(defun scope-minibuffer-with-setup-hook (local fun body)
+  (append
+   (scope-1 local (if (and (symbol-with-pos-p (car-safe fun))
+                           (eq :append (bare-symbol (car-safe fun))))
+                      (cadr fun)
+                    fun))
+   (scope-n local body)))
+
+(defun scope-backquote (local elements)
+  (cond
+   ((consp elements)
+    (cond
+     ((memq (car elements) '(\, \,@))
+      (scope-1 local (cadr elements)))
+     (t (nconc (scope-backquote local (car elements))
+               (scope-backquote local (cdr elements))))))
+   ((vectorp elements)
+    (scope-backquote local (append elements nil)))))
+
+(defun scope-flet (local defs body)
+  (if defs
+      (let* ((def (car defs))
+             (func (car def))
+             (exps (cdr def)))
+        (cons
+         (list (symbol-with-pos-pos func) (length (symbol-name (bare-symbol func)))
+               (symbol-with-pos-pos func))
+         (append
+          (if (cdr exps)
+              ;; def is (FUNC ARGLIST BODY...)
+              (scope-defun local nil (car exps) (cdr exps))
+            ;; def is (FUNC EXP)
+            (scope-1 local (car exps)))
+          (let ((scope-flet-list (cons (bare-symbol func) scope-flet-list)))
+            (scope-flet
+             (cons (cons (bare-symbol func) (symbol-with-pos-pos func))
+                   local)
+             (cdr defs) body)))))
+    (scope-n local body)))
+
+(defun scope-labels (local defs forms)
+  (if defs
+      (let* ((def (car defs))
+             (func (car def))
+             (args (cadr def))
+             (body (cddr def)))
+        (cons
+         (list (symbol-with-pos-pos func) (length (symbol-name (bare-symbol func)))
+               (symbol-with-pos-pos func))
+         (let ((scope-flet-list (cons (bare-symbol func) scope-flet-list))
+               (l (cons (cons (bare-symbol func) (symbol-with-pos-pos func)) local)))
+           (append
+            (scope-defun l nil args body)
+            (scope-flet l (cdr defs) forms)))))
+    (scope-n local forms)))
+
+(defun scope-function (local arg)
+  (and (or (and (symbol-with-pos-p arg) (memq (bare-symbol arg) scope-flet-list))
+           (consp arg))
+       (scope-1 local arg)))
+
+(defun scope-cl-defun-aux (local name args body)
+  (if args
+      (let ((arg (car args)))
+        (cond
+         ((symbol-with-pos-p arg)
+          (let* ((beg (symbol-with-pos-pos arg))
+                 (bare (bare-symbol arg))
+                 (len (length (symbol-name bare))))
+            (cons
+             (list beg len beg)
+             (scope-cl-defun-aux (cons (cons bare beg) local)
+                                 name (cdr args) body))))
+         ((consp arg)
+          (let* ((var (car arg))
+                 (init (cadr arg))
+                 (beg (symbol-with-pos-pos var))
+                 (bare (bare-symbol var))
+                 (len (length (symbol-name bare))))
+            (cons
+             (list beg len beg)
+             (append
+              (scope-1 local init)
+              (scope-cl-defun-aux (cons (cons bare beg) local)
+                                  name (cdr args) body)))))))
+    (scope-n local body)))
+
+(defun scope-cl-defun-key (local name args body)
+  (if args
+      (let ((arg (car args)))
+        (cond
+         ((symbol-with-pos-p arg)
+          (cond
+           ((eq (bare-symbol arg) '&allow-other-keys)
+            (if (cdr args)
+                (scope-cl-defun-aux local name (cddr args) body)
+              (scope-n local body)))
+           ((eq (bare-symbol arg) '&aux)
+            (scope-cl-defun-aux local name (cdr args) body))
+           (t (let* ((beg (symbol-with-pos-pos arg))
+                     (bare (bare-symbol arg))
+                     (len (length (symbol-name bare))))
+                (cons
+                 (list beg len beg)
+                 (scope-cl-defun-key (cons (cons bare beg) local)
+                                     name (cdr args) body))))))
+         ((consp arg)
+          (let* ((var (car arg))
+                 (var (if (consp var) (cadr var) var))
+                 (init (cadr arg))
+                 (svar (caddr arg))
+                 (beg (symbol-with-pos-pos var))
+                 (bare (bare-symbol var))
+                 (len (length (symbol-name bare))))
+            (cons
+             (list beg len beg)
+             (append
+              (scope-1 local init)
+              (when svar
+                (let ((sbeg (symbol-with-pos-pos svar)))
+                  (list (list sbeg (length (symbol-name (bare-symbol svar)))
+                              sbeg))))
+              (scope-cl-defun-key (cons (cons bare beg)
+                                        (append
+                                         (when svar
+                                           (list (cons (bare-symbol svar)
+                                                       (symbol-with-pos-pos svar))))
+                                         local))
+                                  name (cdr args) body)))))))
+    (scope-n local body)))
+
+(defun scope-cl-defun-rest (local name args body)
+  (let* ((var (car args))
+         (beg (symbol-with-pos-pos var))
+         (bare (bare-symbol var))
+         (len (length (symbol-name bare)))
+         (l (cons (cons bare beg) local)))
+    (cons
+     (list beg len beg)
+     (if (cdr args)
+         (let ((next (cadr args))
+               (more (cddr args)))
+           (cond
+            ((eq (bare-symbol next) '&key)
+             (scope-cl-defun-key l name more body))
+            ((eq (bare-symbol next) '&aux)
+             (scope-cl-defun-aux l name more body))))
+       (scope-n l body)))))
+
+(defun scope-cl-defun-optional (local name args body)
+  (if args
+      (let ((arg (car args)))
+        (cond
+         ((symbol-with-pos-p arg)
+          (cond
+           ((memq (bare-symbol arg) '(&rest &body))
+            (scope-cl-defun-rest local name (cdr args) body))
+           ((eq (bare-symbol arg) '&key)
+            (scope-cl-defun-key local name (cdr args) body))
+           ((eq (bare-symbol arg) '&aux)
+            (scope-cl-defun-aux local name (cdr args) body))
+           (t (let* ((beg (symbol-with-pos-pos arg))
+                     (bare (bare-symbol arg))
+                     (len (length (symbol-name bare))))
+                (cons
+                 (list beg len beg)
+                 (scope-cl-defun-optional (cons (cons bare beg) local)
+                                          name (cdr args) body))))))
+         ((consp arg)
+          (let* ((var (car arg))
+                 (init (cadr arg))
+                 (svar (caddr arg))
+                 (beg (symbol-with-pos-pos var))
+                 (bare (bare-symbol var))
+                 (len (length (symbol-name bare))))
+            (cons
+             (list beg len beg)
+             (append
+              (scope-1 local init)
+              (when svar
+                (let ((sbeg (symbol-with-pos-pos svar)))
+                  (list (list sbeg (length (symbol-name (bare-symbol svar)))
+                              sbeg))))
+              (scope-cl-defun-optional (cons (cons bare beg)
+                                             (append
+                                              (when svar
+                                                (list (cons (bare-symbol svar)
+                                                            (symbol-with-pos-pos svar))))
+                                              local))
+                                       name (cdr args) body)))))))
+    (scope-n local body)))
+
+(defun scope-cl-defun-1 (local name args body)
+  (if args
+      (let ((arg (car args)))
+        (cond
+         ((eq (bare-symbol arg) '&optional)
+          (scope-cl-defun-optional local name (cdr args) body))
+         ((memq (bare-symbol arg) '(&rest &body))
+          (scope-cl-defun-rest local name (cdr args) body))
+         ((eq (bare-symbol arg) '&key)
+          (scope-cl-defun-key local name (cdr args) body))
+         ((eq (bare-symbol arg) '&aux)
+          (scope-cl-defun-aux local name (cdr args) body))
+         (t (let* ((beg (symbol-with-pos-pos arg))
+                   (bare (bare-symbol arg))
+                   (len (length (symbol-name bare))))
+              (cons
+               (list beg len beg)
+               (scope-cl-defun-1 (cons (cons (bare-symbol arg)
+                                             (symbol-with-pos-pos arg))
+                                       local)
+                                 name (cdr args) body))))))
+    (scope-n local body)))
+
+(defun scope-cl-defun (local name args body)
+  (scope-cl-defun-1 local name args (if (stringp (car body)) (cdr body) body)))
+
+(defun scope-seq-let (local args sequence body)
+  (nconc
+   (scope-1 local sequence)
+   (append
+    (mapcar (lambda (arg)
+              (let* ((beg (symbol-with-pos-pos arg))
+                     (bare (bare-symbol arg))
+                     (len (length (symbol-name bare))))
+                (list beg len beg)))
+            args)
+    (scope-n (append
+              (mapcar (lambda (arg)
+                        (cons (bare-symbol arg) (symbol-with-pos-pos arg)))
+                      args)
+              local)
+             body))))
+
+(defun scope-pcase-lambda (local lambda-list body)
+  (if lambda-list
+      (let* ((l-r (scope-pcase-pattern local (car lambda-list)))
+             (l (car l-r))
+             (r (cdr l-r)))
+        (when l (append r (scope-pcase-lambda l (cdr lambda-list) body))))
+    (scope-n local body)))
+
+(defun scope-pcase-dolist (local pattern lst body)
+  (nconc
+   (scope-1 local lst)
+   (scope-pcase-1 local pattern body)))
+
+(defun scope-pcase-let-1 (local0 local bindings body)
+  (if bindings
+      (let* ((binding (car bindings))
+             (pat (car binding))
+             (exp (cadr binding)))
+        (nconc
+         (scope-1 local0 exp)
+         (let* ((l-r (scope-pcase-pattern local pat))
+                (l (car l-r))
+                (r (cdr l-r)))
+           (when l (nconc r (scope-pcase-let-1 local0 l (cdr bindings) body))))))
+    (scope-n local body)))
+
+(defun scope-pcase-let (local bindings body)
+  (scope-pcase-let-1 local local bindings body))
+
+(defun scope-pcase-let* (local bindings body)
+  (if bindings
+      (let* ((binding (car bindings))
+             (pat (car binding))
+             (exp (cadr binding)))
+        (nconc
+         (scope-1 local exp)
+         (let* ((l-r (scope-pcase-pattern local pat))
+                (l (car l-r))
+                (r (cdr l-r)))
+           (when l (nconc r (scope-pcase-let* l (cdr bindings) body))))))
+    (scope-n local body)))
+
+(defun scope-declare-function (_local _fn _file arglist _fileonly)
+  (seq-keep (lambda (arg)
+              (and (symbol-with-pos-p arg)
+                   (not (memq (bare-symbol arg) '(&optional &rest _)))
+                   (let* ((beg (symbol-with-pos-pos arg))
+                          (bare (bare-symbol arg))
+                          (len (length (symbol-name bare))))
+                     (list beg len beg))))
+            arglist))
+
+(defun scope-case (local expr clauses)
+  (nconc (scope-1 local expr)
+         (mapcan (lambda (clause) (scope-n local (cdr clause))) clauses)))
+
+(defun scope-define-derived (local _child _parent _name body)
+  (when (stringp (car body)) (setq body (cdr body)))
+  (while (keywordp (car body)) (setq body (cddr body)))
+  (scope-n local body))
+
+(defun scope-define-minor (local _mode _doc body)
+  (while (keywordp (car body)) (setq body (cddr body)))
+  (scope-n local body))
+
+(defun scope-f (local f)
+  "Return function that scope-analyzes arguments of F in context LOCAL."
+  (cond
+   ((symbol-with-pos-p f)
+    (let ((bare (bare-symbol f)))
+      (cond
+       ((functionp bare) (apply-partially #'scope-n local))
+       ((macrop bare)
+        (cond
+         ((eq (get bare 'edebug-form-spec) t)
+          (apply-partially #'scope-n local))
+         ((memq bare '( setf with-memoization cl-assert cl-incf cl-decf
+                        eval-when-compile eval-and-compile with-eval-after-load))
+          (apply-partially #'scope-n local))
+         ((memq bare '( defun defmacro defsubst define-inline))
+          (lambda (forms) (scope-defun local (car forms) (cadr forms) (cddr forms))))
+         ((memq bare '( cl-defgeneric))
+          (lambda (forms) (scope-defgeneric local (car forms) (cadr forms) (cddr forms))))
+         ((memq bare '(cl-case))
+          (lambda (forms) (scope-case local (car forms) (cdr forms))))
+         ((memq bare '( cl-defun))
+          (lambda (forms) (scope-cl-defun local (car forms) (cadr forms) (cddr forms))))
+         ((memq bare '( cl-defmethod))
+          (lambda (forms) (scope-defmethod local (car forms) (cdr forms))))
+         ((memq bare '(lambda))
+          (lambda (forms) (scope-defun local nil (car forms) (cdr forms))))
+         ((memq bare '(declare-function))
+          (lambda (forms) (scope-declare-function local (car forms) (cadr forms)
+                                                  (caddr forms) (cadddr forms))))
+         ((memq bare '(if-let when-let and-let))
+          (lambda (forms) (scope-if-let local (car forms) (cdr forms))))
+         ((memq bare '(if-let* when-let* and-let* while-let))
+          (lambda (forms) (scope-if-let* local (car forms) (cdr forms))))
+         ((memq bare '( defvar-local defcustom))
+          (lambda (forms) (scope-defvar local (car forms) (cadr forms))))
+         ((memq bare '(dolist dotimes))
+          (lambda (forms) (scope-dotimes local (caar forms) (cadar forms) (caddar forms) (cdr forms))))
+         ((memq bare '(pcase pcase-exhaustive))
+          (lambda (forms) (scope-pcase local (car forms) (cdr forms))))
+         ((memq bare '(pcase-lambda))
+          (lambda (forms) (scope-pcase-lambda local (car forms) (cdr forms))))
+         ((memq bare '(pcase-dolist))
+          (lambda (forms) (scope-pcase-dolist local (caar forms) (cadar forms) (cdr forms))))
+         ((memq bare '(pcase-let))
+          (lambda (forms) (scope-pcase-let local (car forms) (cdr forms))))
+         ((memq bare '(pcase-let*))
+          (lambda (forms) (scope-pcase-let* local (car forms) (cdr forms))))
+         ((memq bare '(setq-local setq-default))
+          (apply-partially #'scope-setq local))
+         ((memq bare '(push))
+          (lambda (forms) (scope-push local (car forms) (cadr forms))))
+         ((memq bare '(pop oref))
+          (lambda (forms) (scope-1 local (car forms))))
+         ((memq bare '(cl-flet))
+          (lambda (forms) (scope-flet local (car forms) (cdr forms))))
+         ((memq bare '(cl-labels))
+          (lambda (forms) (scope-labels local (car forms) (cdr forms))))
+         ((memq bare '(minibuffer-with-setup-hook))
+          (lambda (forms) (scope-minibuffer-with-setup-hook local (car forms) (cdr forms))))
+         ((memq bare '(condition-case-unless-debug))
+          (lambda (forms) (scope-condition-case local (car forms) (cadr forms) (cddr forms))))
+         ((memq bare '(seq-let))
+          (lambda (forms) (scope-seq-let local (car forms) (cadr forms) (cddr forms))))
+         ((memq bare '( define-derived-mode))
+          (lambda (forms)
+            (scope-define-derived local (car forms) (cadr forms) (caddr forms) (cdddr forms))))
+         ((memq bare '( define-minor-mode))
+          (lambda (forms) (scope-define-minor local (car forms) (cadr forms) (cddr forms))))
+         ((memq bare '(inline-quote))
+          (lambda (forms) (scope-backquote local (car forms))))
+         ((memq bare '(inline-letevals))
+          (lambda (forms) (scope-let local (car forms) (cdr forms))))
+         ((memq bare '(with-suppressed-warnings))
+          (lambda (forms) (scope-n local (cdr forms))))
+         ((get bare 'scope-function)    ;For custom extensions.
+          (apply-partially (get bare 'scope-function) local))
+         (t #'ignore)))
+       ((special-form-p bare)
+        (cond
+         ((memq bare '( if and or while
+                        save-excursion save-restriction save-current-buffer
+                        catch unwind-protect
+                        progn prog1))
+          (apply-partially #'scope-n local))
+         ((eq bare 'let)
+          (lambda (forms) (scope-let local (car forms) (cdr forms))))
+         ((eq bare 'let*)
+          (lambda (forms) (scope-let* local (car forms) (cdr forms))))
+         ((eq bare 'cond) (apply-partially #'scope-cond local))
+         ((eq bare 'setq) (apply-partially #'scope-setq local))
+         ((memq bare '( defconst defvar))
+          (lambda (forms) (scope-defvar local (car forms) (cadr forms))))
+         ((eq bare 'condition-case)
+          (lambda (forms) (scope-condition-case local (car forms) (cadr forms) (cddr forms))))
+         (t #'ignore)))
+       ((memq bare scope-flet-list)
+        (lambda (forms) (append (scope-s local f)
+                                (scope-n local forms))))
+       ;; FIXME: Assume unknown symbols refer to functions, unless at
+       ;; top level.
+       (t #'ignore))))
+   ;; Symbol without position, a quotation marker that the reader
+   ;; expands into a symbol but does not annotate with a position.
+   ((symbolp f)
+    (cond
+     ((eq f '\`) (lambda (forms) (scope-backquote local (car forms))))
+     ((eq f 'function) (lambda (forms) (scope-function local (car forms))))
+     (t #'ignore)))
+   (t #'ignore)))
+
+(defun scope-1 (local form)
+  (cond
+   ((consp form)
+    (funcall (scope-f local (car form)) (cdr form)))
+   ((symbol-with-pos-p form)
+    (scope-s local form))))
+
+(defun scope-n (local body) (mapcan (apply-partially #'scope-1 local) body))
+
+;;;###autoload
+(defun scope (form)
+  "Return bindings graph in FORM.
+
+FORM should contain positioned symbols, see `read-positioning-symbols'.
+
+The graph is a list of elements (OCCURENCE LEN BINDING): OCCURENCE is a
+buffer position where a symbol of length LEN occurs, which is bound by
+another occurence of the same symbol that starts at position BINDING.
+If the symbol at OCCURENCE is not lexically bound, then BINDING is nil."
+  (scope-1 nil form))
+
+(provide 'scope)
+;;; scope.el ends here
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index 2fe4135ffad..95633bd248f 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -840,6 +840,7 @@ functions are annotated with \"<f>\" via the
 
 (declare-function xref-make "progmodes/xref" (summary location))
 (declare-function xref-item-location "progmodes/xref" (this))
+(declare-function xref-make-buffer-location "progmodes/xref" (buffer position))
 
 (defun elisp--xref-backend () 'elisp)
 
@@ -1040,18 +1041,54 @@ namespace but with lower confidence."
            (propertize ident 'pos (car bounds))))))
 
 (cl-defmethod xref-backend-definitions ((_backend (eql 'elisp)) identifier)
-  (require 'find-func)
-  (let ((sym (intern-soft identifier)))
-    (when sym
-      (let* ((pos (get-text-property 0 'pos identifier))
-             (namespace (if pos
-                            (elisp--xref-infer-namespace pos)
-                          'any))
-             (defs (elisp--xref-find-definitions sym)))
-        (if (eq namespace 'maybe-variable)
-            (or (elisp--xref-filter-definitions defs 'variable sym)
-                (elisp--xref-filter-definitions defs 'any sym))
-          (elisp--xref-filter-definitions defs namespace sym))))))
+  (let* ((pos (get-text-property 0 'pos identifier))
+         (dec (seq-some
+               (pcase-lambda (`(,beg ,len ,dec))
+                 (when (<= beg pos (+ beg len)) dec))
+               (scope (save-excursion
+                        (goto-char pos)
+                        (beginning-of-defun)
+                        (read-positioning-symbols (current-buffer)))))))
+    (if dec (list (xref-make "lexical binding"
+                             (xref-make-buffer-location (current-buffer) dec)))
+      (require 'find-func)
+      (let ((sym (intern-soft identifier)))
+        (when sym
+          (let* ((pos (get-text-property 0 'pos identifier))
+                 (namespace (if pos
+                                (elisp--xref-infer-namespace pos)
+                              'any))
+                 (defs (elisp--xref-find-definitions sym)))
+            (if (eq namespace 'maybe-variable)
+                (or (elisp--xref-filter-definitions defs 'variable sym)
+                    (elisp--xref-filter-definitions defs 'any sym))
+              (elisp--xref-filter-definitions defs namespace sym))))))))
+
+(cl-defmethod xref-backend-references :around ((backend (eql 'elisp)) identifier)
+  (let* ((pos (get-text-property 0 'pos identifier))
+         (all (scope (save-excursion
+                       (goto-char pos)
+                       (beginning-of-defun)
+                       (read-positioning-symbols (current-buffer)))))
+         (dec (seq-some
+               (pcase-lambda (`(,beg ,len ,bin))
+                 (when (<= beg pos (+ beg len)) bin))
+               all)))
+    (if dec (seq-keep (pcase-lambda (`(,sym ,len ,bin))
+                        (when (equal bin dec)
+                          (let* ((beg-end (save-excursion
+                                            (goto-char sym)
+                                            (cons (pos-bol) (pos-eol))))
+                                 (beg (car beg-end))
+                                 (end (cdr beg-end))
+                                 (line (buffer-substring-no-properties beg end))
+                                 (cur (- sym beg)))
+                            (add-face-text-property cur (+ len cur)
+                                                    'xref-match t line)
+                            (xref-make line (xref-make-buffer-location
+                                             (current-buffer) sym)))))
+                      all)
+      (cl-call-next-method backend identifier))))
 
 (defun elisp--xref-filter-definitions (definitions namespace symbol)
   (if (eq namespace 'any)
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el
index 11540fd0797..a049c98e5ce 100644
--- a/lisp/progmodes/xref.el
+++ b/lisp/progmodes/xref.el
@@ -180,6 +180,11 @@ Line numbers start from 1 and columns from 0."
     (or (buffer-file-name buffer)
         (format "(buffer %s)" (buffer-name buffer)))))
 
+(cl-defmethod xref-location-line ((l xref-buffer-location))
+  (pcase-let (((cl-struct xref-buffer-location buffer position) l))
+    (with-current-buffer buffer
+      (line-number-at-pos position))))
+
 (cl-defstruct (xref-bogus-location
                (:constructor xref-make-bogus-location (message)))
   "Bogus locations are sometimes useful to indicate errors,
diff --git a/test/lisp/emacs-lisp/scope-tests.el b/test/lisp/emacs-lisp/scope-tests.el
new file mode 100644
index 00000000000..c45de389af8
--- /dev/null
+++ b/test/lisp/emacs-lisp/scope-tests.el
@@ -0,0 +1,75 @@
+;;; scope-tests.el --- Tests for scope.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 Eshel Yaron
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'scope)
+(require 'ert)
+
+(ert-deftest scope-test-1 ()
+  (let* ((str "
+(defun foo (bar baz)
+  (let* ((baz baz)
+         (baz baz))
+    (when (and bar spam baz)
+      (ignore bar baz)))
+  (ignore baz))")
+         (form (read-positioning-symbols str)))
+    (should (equal (scope form)
+                   '((13 3 13)
+                     (17 3 17)
+                     (32 3 32)
+                     (36 3 17)
+                     (51 3 51)
+                     (55 3 32)
+                     (76 3 13)
+                     (80 4 nil)
+                     (85 3 51)
+                     (104 3 13)
+                     (108 3 51)
+                     (125 3 17))))))
+
+(ert-deftest scope-test-2 ()
+  (let* ((str "
+(defun refactor-backends ()
+  \"Return alist of refactor operations and backends that support them.\"
+  (let ((op-be-alist nil))
+    (run-hook-wrapped
+     'refactor-backend-functions
+     (lambda (be-fun &rest _)
+       (pcase (funcall be-fun)
+         (`(,be . ,ops)
+          (dolist (op ops)
+            (push be (alist-get op op-be-alist)))))))
+    op-be-alist))")
+         (form (read-positioning-symbols str)))
+    (should (equal (scope form)
+                   '((110 11 110)
+                     (197 6 197)
+                     (236 6 197)
+                     (257 2 257)
+                     (263 3 263)
+                     (287 2 287)
+                     (290 3 263)
+                     (313 2 257)
+                     (327 2 287)
+                     (330 11 110)
+                     (353 11 110))))))
+
+;;; scope-tests.el ends here
-- 
2.39.2