(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))
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
(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
((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))))
(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))
((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))
;; 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)))
(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
(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))
(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)
(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)
(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))
(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))
(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
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))
(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))
(`(,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
projects / emacs.git / commitdiff