From: Eshel Yaron Date: Sun, 11 Aug 2024 09:52:31 +0000 (+0200) Subject: scope.el: Improve entry point and nested backquote handling X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=52bebce1fa8e4db0986feb161da088ca74e76f60;p=emacs.git scope.el: Improve entry point and nested backquote handling --- diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 423effea49b..680963faa37 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -26,8 +26,6 @@ (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)) @@ -375,16 +373,21 @@ fun)) (scope-n local body))) -(defun scope-backquote (local elements) +(defun scope-backquote (depth local elements) (cond + ((zerop depth) (scope-n local elements)) ((consp elements) (cond ((memq (car elements) '(\, \,@)) - (scope-1 local (cadr elements))) - (t (nconc (scope-backquote local (car elements)) - (scope-backquote local (cdr elements)))))) + (scope-backquote (1- depth) local (cdr elements))) + ((eq (car elements) '\`) + (scope-backquote (1+ depth) local (cdr elements))) + (t (nconc (scope-backquote depth local (car elements)) + (scope-backquote depth local (cdr elements)))))) ((vectorp elements) - (scope-backquote local (append elements nil))))) + (scope-backquote depth local (append elements nil))))) + +(defvar scope-flet-list nil) (defun scope-flet (local defs body) (if defs @@ -666,6 +669,20 @@ (while (keywordp (car body)) (setq body (cddr body))) (scope-n local body)) +(defun scope-letrec (local binders body) + (if binders + (let* ((binder (car binders)) + (sym (car binder)) + (bare (bare-symbol sym)) + (beg (symbol-with-pos-pos sym)) + (l (cons (cons bare beg) local)) + (form (cadr binder))) + (cons + (list beg (length (symbol-name bare)) beg) + (nconc (scope-1 l form) + (scope-letrec l (cdr binders) body)))) + (scope-n local body))) + (defun scope-f (local f) "Return function that scope-analyzes arguments of F in context LOCAL." (cond @@ -678,7 +695,12 @@ ((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)) + eval-when-compile eval-and-compile with-eval-after-load + ;; We could recognize contant symbols bindings + ;; in `cl-progv', but it is not really worth the + ;; trouble since this macro is specifically + ;; intended for computing bindings at run time. + cl-progv)) (apply-partially #'scope-n local)) ((memq bare '( defun defmacro defsubst define-inline)) (lambda (forms) (scope-defun local (car forms) (cadr forms) (cddr forms)))) @@ -719,6 +741,8 @@ (lambda (forms) (scope-push local (car forms) (cadr forms)))) ((memq bare '(pop oref)) (lambda (forms) (scope-1 local (car forms)))) + ((memq bare '(letrec)) + (lambda (forms) (scope-letrec local (car forms) (cdr forms)))) ((memq bare '(cl-flet)) (lambda (forms) (scope-flet local (car forms) (cdr forms)))) ((memq bare '(cl-labels)) @@ -735,7 +759,7 @@ ((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)))) + (lambda (forms) (scope-backquote 1 local (car forms)))) ((memq bare '(inline-letevals)) (lambda (forms) (scope-let local (car forms) (cdr forms)))) ((memq bare '(with-suppressed-warnings)) @@ -771,7 +795,7 @@ ;; 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 '\`) (lambda (forms) (scope-backquote 1 local (car forms)))) ((eq f 'function) (lambda (forms) (scope-function local (car forms)))) (t #'ignore))) (t #'ignore))) @@ -786,16 +810,16 @@ (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)) +(defun scope (&optional stream) + "Read and scope-analyze code from STREAM. + +Return a bindings graph associating symbols with their binders. It is a +list of elements (OCCURRENCE LEN BINDING) where OCCURRENCE is a buffer +position where a symbol of length LEN occurs, which is bound by another +occurrence of the same symbol that starts at position BINDING. If +OCCURRENCE is itself a binding occurrence, then BINDING and OCCURRENCE +are equal. If OCCURRENCE is not lexically bound, then BINDING is nil." + (scope-1 nil (read-positioning-symbols stream))) (provide 'scope) ;;; scope.el ends here diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index dae613426f6..1a5861d80dd 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -336,10 +336,10 @@ happens in interactive invocations." (defun elisp-highlight-variable (pos) (save-excursion (goto-char pos) - (let* ((all (scope (save-excursion - (goto-char pos) - (beginning-of-defun) - (read-positioning-symbols (current-buffer))))) + (let* ((all (save-excursion + (goto-char pos) + (beginning-of-defun) + (scope (current-buffer)))) (dec (seq-some (pcase-lambda (`(,beg ,len ,bin)) (when (<= beg pos (+ beg len)) bin)) @@ -374,7 +374,9 @@ happens in interactive invocations." (goto-char beg) (while (< (point) end) (pcase-dolist (`(,sym ,len ,bin) - (scope (read-positioning-symbols (current-buffer)))) + (condition-case nil + (scope (current-buffer)) + (end-of-file nil))) (if (null bin) (font-lock-append-text-property sym (+ sym len) 'face 'elisp-free-variable) (font-lock-append-text-property sym (+ sym len) 'face (if (= sym bin) @@ -1112,10 +1114,10 @@ namespace but with lower confidence." (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))))))) + (save-excursion + (goto-char pos) + (beginning-of-defun) + (scope (current-buffer)))))) (if dec (list (xref-make "lexical binding" (xref-make-buffer-location (current-buffer) dec))) (require 'find-func) @@ -1133,10 +1135,10 @@ namespace but with lower confidence." (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))))) + (all (save-excursion + (goto-char pos) + (beginning-of-defun) + (scope (current-buffer)))) (dec (seq-some (pcase-lambda (`(,beg ,len ,bin)) (when (<= beg pos (+ beg len)) bin)) diff --git a/lisp/progmodes/refactor-elisp.el b/lisp/progmodes/refactor-elisp.el index fb6310d2b5c..fa5756572db 100644 --- a/lisp/progmodes/refactor-elisp.el +++ b/lisp/progmodes/refactor-elisp.el @@ -30,19 +30,20 @@ (defun elisp-refactor-backend () '(elisp rename)) (cl-defmethod refactor-backend-read-scoped-identifier ((_backend (eql elisp))) - (let ((all (scope (save-excursion - (beginning-of-defun) - (read-positioning-symbols (current-buffer)))))) + (let ((all (save-excursion + (beginning-of-defun) + (scope (current-buffer))))) (seq-some (pcase-lambda (`(,beg ,len ,bin)) (and bin (<= beg (point) (+ beg len)) - (list (buffer-substring-no-properties beg (+ beg len))))) + (list (propertize (buffer-substring-no-properties beg (+ beg len)) + 'pos beg)))) all))) (cl-defmethod refactor-backend-rename-edits ((_backend (eql elisp)) _old new (_scope (eql nil))) - (let* ((all (scope (save-excursion - (beginning-of-defun) - (read-positioning-symbols (current-buffer))))) + (let* ((all (save-excursion + (beginning-of-defun) + (scope (current-buffer)))) (dec (seq-some (pcase-lambda (`(,beg ,len ,bin)) (when (<= beg (point) (+ beg len)) bin)) @@ -55,5 +56,21 @@ (list beg (+ beg len) new))) all))))) +(cl-defmethod refactor-backend-rename-highlight-regions + ((_backend (eql elisp)) old (_scope (eql nil))) + (when-let* ((pos (get-text-property 0 'pos old)) + (all (save-excursion + (goto-char pos) + (beginning-of-defun) + (scope (current-buffer)))) + (dec (seq-some + (pcase-lambda (`(,beg ,len ,bin)) + (when (<= beg pos (+ beg len)) bin)) + all))) + (mapcar (pcase-lambda (`(,beg ,len ,bin)) + (when (equal bin dec) + (cons beg (+ beg len)))) + all))) + (provide 'refactor-elisp) ;;; refactor-elisp.el ends here diff --git a/lisp/progmodes/refactor.el b/lisp/progmodes/refactor.el index 560e98feff2..e74ed16d680 100644 --- a/lisp/progmodes/refactor.el +++ b/lisp/progmodes/refactor.el @@ -159,15 +159,23 @@ is already in use, return a string to display as feedback to the user. Otherwise, if the replacement is valid, return nil." nil) -(cl-defgeneric refactor-backend-read-replacement (backend old scope) - "Read a replacement for identifier OLD across SCOPE using BACKEND." - (let ((case-fold-search nil)) +(cl-defgeneric refactor-backend-rename-highlight-regions (_backend old _scope) + "Return regions to highlight while prompting for replacement for OLD." + (let ((regions nil) + (case-fold-search nil)) (save-excursion (goto-char (point-min)) (while (search-forward old nil t) - (let ((ov (make-overlay (match-beginning 0) (match-end 0)))) - (overlay-put ov 'refactor-rename-old t) - (overlay-put ov 'face 'lazy-highlight))))) + (push (cons (match-beginning 0) (match-end 0)) regions))) + regions)) + +(cl-defgeneric refactor-backend-read-replacement (backend old scope) + "Read a replacement for identifier OLD across SCOPE using BACKEND." + (pcase-dolist (`(,beg . ,end) + (refactor-backend-rename-highlight-regions backend old scope)) + (let ((ov (make-overlay beg end))) + (overlay-put ov 'refactor-rename-old t) + (overlay-put ov 'face 'lazy-highlight))) (unwind-protect (let ((new nil) (invalid nil)) diff --git a/test/lisp/emacs-lisp/scope-tests.el b/test/lisp/emacs-lisp/scope-tests.el index c45de389af8..030e05d0335 100644 --- a/test/lisp/emacs-lisp/scope-tests.el +++ b/test/lisp/emacs-lisp/scope-tests.el @@ -23,30 +23,39 @@ (require 'ert) (ert-deftest scope-test-1 () - (let* ((str " + (should (equal '((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)) + (scope " (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)))))) + (ignore baz))")))) (ert-deftest scope-test-2 () - (let* ((str " + (should (equal '((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 " (defun refactor-backends () \"Return alist of refactor operations and backends that support them.\" (let ((op-be-alist nil)) @@ -57,19 +66,30 @@ (`(,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)))))) + op-be-alist))")))) + +(ert-deftest scope-test-3 () + (should (equal '((45 3 45) ;env + (55 4 55) ;body + (136 4 136) ;syms + (172 4 172) ;vals + (212 4 136) + (218 4 172) + (258 3 45) + (272 4 136) + (287 4 172) + (312 4 136) + (318 4 172) + (334 4 55)) + (scope " +(defmacro erc--with-entrypoint-environment (env &rest body) + \"Run BODY with bindings from ENV alist.\" + (declare (indent 1)) + (let ((syms (make-symbol \"syms\")) + (vals (make-symbol \"vals\"))) + `(let (,syms ,vals) + (pcase-dolist (`(,k . ,v) ,env) (push k ,syms) (push v ,vals)) + (cl-progv ,syms ,vals + ,@body))))")))) ;;; scope-tests.el ends here