From aefcb1a5bb8797969dede92c466c4cd19495f622 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Mon, 12 Aug 2024 17:15:41 +0200 Subject: [PATCH] scope.el: Support cl block name bindings. --- lisp/emacs-lisp/scope.el | 81 +++++++++++++++++++++-------- test/lisp/emacs-lisp/scope-tests.el | 19 +++++++ 2 files changed, 79 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 79968e86d53..41d51c86dd6 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -435,7 +435,7 @@ Optional argument LOCAL is a local context to extend." (defun scope-backquote (local elements &optional depth) (scope--backquote local elements (or depth 1))) -(defvar scope-flet-list nil) +(defvar scope-flet-alist nil) (defun scope-flet (local defs body) (if defs @@ -451,11 +451,10 @@ Optional argument LOCAL is a local context to extend." (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 - (scope-local-new (bare-symbol func) (symbol-with-pos-pos func) - local) - (cdr defs) body))))) + (let ((scope-flet-alist (cons (cons (bare-symbol func) + (symbol-with-pos-pos func)) + scope-flet-alist))) + (scope-flet local (cdr defs) body))))) (scope-n local body))) (defun scope-labels (local defs forms) @@ -467,17 +466,41 @@ Optional argument LOCAL is a local context to extend." (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 (scope-local-new (bare-symbol func) (symbol-with-pos-pos func) local))) + (let ((scope-flet-alist (cons (cons (bare-symbol func) + (symbol-with-pos-pos func)) + scope-flet-alist))) (nconc - (scope-defun l nil args body) - (scope-flet l (cdr defs) forms))))) + (scope-defun local nil args body) + (scope-flet local (cdr defs) forms))))) (scope-n local forms))) +(defvar scope-block-alist nil) + +(defun scope-block (local name body) + (if name + (let* ((beg (symbol-with-pos-pos name)) + (bare (bare-symbol name))) + (cons + (list beg (length (symbol-name bare)) beg) + (let ((scope-block-alist (cons (cons bare beg) scope-block-alist))) + (scope-n local body)))) + (scope-n local body))) + +(defun scope-return-from (local name result) + (if-let ((bare (and (symbol-with-pos-p name) (bare-symbol name))) + (pos (alist-get bare scope-block-alist))) + (cons + (list (symbol-with-pos-pos name) (length (symbol-name bare)) pos) + (scope-1 local result)) + (scope-1 local result))) + (defun scope-sharpquote (local arg) - (and (or (and (symbol-with-pos-p arg) (memq (bare-symbol arg) scope-flet-list)) - (consp arg)) - (scope-1 local arg))) + (when (symbol-with-pos-p arg) + (let ((bare (bare-symbol arg))) + (cond + ((functionp bare) (list (list (symbol-with-pos-pos arg) (length (symbol-name bare)) 'function))) + ((or (assq bare scope-flet-alist) (consp arg)) + (scope-1 local arg)))))) (defun scope-cl-defun-aux (local name args body) (if args @@ -794,8 +817,7 @@ Optional argument LOCAL is a local context to extend." (cond ((eq bw 'using) (scope-loop-for-being-the-hash-keys-of-using local (car more) (cdr more))) - (t - (scope-loop local more)))))))) + (t (scope-loop local rest)))))))) (defun scope-loop-for-being-the-hash-keys (local0 local word rest) (when (symbol-with-pos-p word) @@ -889,6 +911,14 @@ Optional argument LOCAL is a local context to extend." (scope-loop-do local (car rest) (cdr rest)) (scope-loop local rest)))) +(defun scope-loop-named (local name rest) + (let* ((beg (symbol-with-pos-pos name)) + (bare (bare-symbol name))) + (cons + (list beg (length (symbol-name bare)) beg) + (let ((scope-block-alist (cons (cons bare beg) scope-block-alist))) + (scope-loop local rest))))) + (defun scope-loop (local forms) (when forms (let ((kw (car forms)) @@ -908,7 +938,8 @@ Optional argument LOCAL is a local context to extend." ;; FIXME: Handle `and' clause-linking. ((memq bare '(with)) (scope-loop-with local (car rest) (cadr rest) (caddr rest) (cdddr rest))) - ((memq bare '(do)) (scope-loop-do local (car rest) (cdr rest)))))))))) + ((memq bare '(do)) (scope-loop-do local (car rest) (cdr rest))) + ((memq bare '(named)) (scope-loop-named local (car rest) (cdr rest)))))))))) (defun scope-named-let (local name bindings body) (let ((bare (bare-symbol name)) @@ -933,11 +964,11 @@ Optional argument LOCAL is a local context to extend." (len (length (symbol-name bare)))) (list (list beg len beg)))))) bindings) - (let ((l (scope-local-new bare beg local))) + (let ((l local)) (dolist (binding bindings) (when-let ((sym (if (consp binding) (car binding) binding))) (setq l (scope-local-new (bare-symbol sym) (symbol-with-pos-pos sym) l)))) - (let ((scope-flet-list (cons bare scope-flet-list))) (scope-n l body))))))) + (let ((scope-flet-alist (cons (cons bare beg) scope-flet-alist))) (scope-n l body))))))) (defvar scope-assume-func-p nil) @@ -950,7 +981,7 @@ Optional argument LOCAL is a local context to extend." ((symbol-with-pos-p f) (let ((bare (bare-symbol f))) (cond - ((functionp bare) ;; (scope-n local forms) + ((functionp bare) (cons (list (symbol-with-pos-pos f) (length (symbol-name bare)) 'function) (scope-n local forms))) @@ -1035,6 +1066,12 @@ Optional argument LOCAL is a local context to extend." (scope-let local (car forms) (cdr forms))) ((memq bare '(with-suppressed-warnings)) (scope-n local (cdr forms))) + ((memq bare '(cl-block)) + (scope-block local (car forms) (cdr forms))) + ((memq bare '(cl-return-from)) + (scope-return-from local (car forms) (cadr forms))) + ((memq bare '(cl-return)) + (scope-return-from local nil (cadr forms))) ((get bare 'scope-function) ;For custom extensions. (funcall (get bare 'scope-function) local forms)))) ((special-form-p bare) @@ -1051,8 +1088,10 @@ Optional argument LOCAL is a local context to extend." (scope-condition-case local (car forms) (cadr forms) (cddr forms))) ((get bare 'scope-function) (funcall (get bare 'scope-function) local forms)))) - ((memq bare scope-flet-list) - (nconc (scope-s local f) (scope-n local forms))) + ((assq bare scope-flet-alist) + (cons (list (symbol-with-pos-pos f) (length (symbol-name bare)) + (alist-get bare scope-flet-alist)) + (scope-n local forms))) ((get bare 'scope-function) (funcall (get bare 'scope-function) local forms)) ;; Assume nothing about unknown top-level forms. diff --git a/test/lisp/emacs-lisp/scope-tests.el b/test/lisp/emacs-lisp/scope-tests.el index d57c9821756..39b3a268b31 100644 --- a/test/lisp/emacs-lisp/scope-tests.el +++ b/test/lisp/emacs-lisp/scope-tests.el @@ -99,4 +99,23 @@ (cl-progv ,syms ,vals ,@body))))")))) +(ert-deftest scope-test-4 () + (should (equal '((8 3 8) + (29 3 29) + (34 3 34) + (40 1 function) + (42 3 34) + (46 3 8) + (67 3 67) + (85 3 29) + (89 3 8) + (110 3 67) + (115 3 29) + (119 3 8)) + (scope " +(let ((foo 1)) + (cl-flet ((foo (bar) (* bar foo))) + (cl-block foo + (while (foo foo) (cl-return-from foo (foo foo))))))")))) + ;;; scope-tests.el ends here -- 2.39.2