--- /dev/null
+;;; 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
projects / emacs.git / commitdiff