scope.el: Support cl block name bindings.

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
index 79968e86d538a2306b812c1e0582e829db6d3784..41d51c86dd63555d3e0a270b5afaaeeee2a946ce 100644 (file)
--- 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 d57c982175620d1053fa14a9c22a3641eb9d8cb7..39b3a268b310930a16bb5f271f2ff6262a19a620 100644 (file)
--- 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