scope.el: Extend 'cl-loop' support

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
index 41d51c86dd63555d3e0a270b5afaaeeee2a946ce..25ddef6123d387b54c4700ba0b51e5332aa97e35 100644 (file)
--- a/lisp/emacs-lisp/scope.el
+++ b/lisp/emacs-lisp/scope.el
@@ -755,8 +755,14 @@ Optional argument LOCAL is a local context to extend."
                 (scope-letrec l (cdr binders) body))))
     (scope-n local body)))
 
+(defun scope-loop-for-and (local rest)
+  (if (and (symbol-with-pos-p (car rest))
+           (eq (bare-symbol (car rest)) 'and))
+      (scope-loop-for local local (cadr rest) (cddr rest))
+    (scope-loop local rest)))
+
 (defun scope-loop-for-by (local0 local expr rest)
-  (nconc (scope-1 local0 expr) (scope-loop local rest)))
+  (nconc (scope-1 local0 expr) (scope-loop-for-and local rest)))
 
 (defun scope-loop-for-to (local0 local expr rest)
   (nconc
@@ -769,7 +775,7 @@ Optional argument LOCAL is a local context to extend."
          (cond
           ((eq bw 'by)
            (scope-loop-for-by local0 local (car more) (cdr more)))
-          (t (scope-loop local rest)))))))))
+          (t (scope-loop-for-and local rest)))))))))
 
 (defun scope-loop-for-from (local0 local expr rest)
   (nconc
@@ -784,7 +790,7 @@ Optional argument LOCAL is a local context to extend."
            (scope-loop-for-to local0 local (car more) (cdr more)))
           ((eq bw 'by)
            (scope-loop-for-by local0 local (car more) (cdr more)))
-          (t (scope-loop local rest)))))))))
+          (t (scope-loop-for-and local rest)))))))))
 
 (defun scope-loop-for-= (local0 local expr rest)
   (nconc
@@ -797,15 +803,15 @@ Optional argument LOCAL is a local context to extend."
          (cond
           ((eq bw 'then)
            (scope-loop-for-by local0 local (car more) (cdr more)))
-          (t (scope-loop local rest)))))))))
+          (t (scope-loop-for-and local rest)))))))))
 
-(defun scope-loop-for-being-the-hash-keys-of-using (local form rest)
+(defun scope-loop-for-being-the-hash-keys-of-using (local0 local form rest)
   (let* ((var (cadr form))
          (bare (bare-symbol var))
          (beg (symbol-with-pos-pos var)))
     (cons
      (list beg (length (symbol-name bare)) beg)
-     (scope-loop (scope-local-new bare beg local) rest))))
+     (scope-loop-for-and (scope-local-new bare beg local) rest))))
 
 (defun scope-loop-for-being-the-hash-keys-of (local0 local expr rest)
   (nconc
@@ -816,8 +822,8 @@ Optional argument LOCAL is a local context to extend."
        (let ((bw (bare-symbol word)))
          (cond
           ((eq bw 'using)
-           (scope-loop-for-being-the-hash-keys-of-using local (car more) (cdr more)))
-          (t (scope-loop local rest))))))))
+           (scope-loop-for-being-the-hash-keys-of-using local0 local (car more) (cdr more)))
+          (t (scope-loop-for-and local rest))))))))
 
 (defun scope-loop-for-being-the-hash-keys (local0 local word rest)
   (when (symbol-with-pos-p word)
@@ -831,7 +837,7 @@ Optional argument LOCAL is a local context to extend."
     (let ((bw (bare-symbol word)))
       (cond
        ((memq bw '(buffer buffers))
-        (scope-loop local rest))
+        (scope-loop-for-and local rest))
        ((memq bw '( hash-key hash-keys
                     hash-value hash-values
                     key-code key-codes
@@ -891,18 +897,25 @@ Optional argument LOCAL is a local context to extend."
             (scope-loop (scope-local-new bare beg local) (cdr more))))
        (scope-loop local rest)))))
 
-(defun scope-loop-with (local var eql val rest)
-  (when (and (symbol-with-pos-p var)
-             (symbol-with-pos-p eql)
-             (eq (bare-symbol eql) '=))
+(defun scope-loop-with-and (local rest)
+  (if (and (symbol-with-pos-p (car rest))
+           (eq (bare-symbol (car rest)) 'and))
+      (scope-loop-with local (cadr rest) (cddr rest))
+    (scope-loop local rest)))
+
+(defun scope-loop-with (local var rest)
+  (when (symbol-with-pos-p var)
     (let* ((bare (bare-symbol var))
            (beg (symbol-with-pos-pos var))
-           (l (scope-local-new bare beg local)))
+           (l (scope-local-new bare beg local))
+           (eql (car rest)))
       (cons
        (list beg (length (symbol-name bare)) beg)
-       (nconc
-        (scope-1 local val)
-        (scope-loop l rest))))))
+       (if (and (symbol-with-pos-p eql)
+                (eq (bare-symbol eql) '=))
+           (let* ((val (cadr rest)) (more (cddr rest)))
+             (nconc (scope-1 local val) (scope-loop-with-and l more)))
+         (scope-loop-with-and l rest))))))
 
 (defun scope-loop-do (local form rest)
   (nconc
@@ -919,6 +932,41 @@ Optional argument LOCAL is a local context to extend."
      (let ((scope-block-alist (cons (cons bare beg) scope-block-alist)))
        (scope-loop local rest)))))
 
+(defun scope-loop-finally (local next rest)
+  (if (symbol-with-pos-p next)
+      (let ((bare (bare-symbol next)))
+        (cond
+         ((eq bare 'do)
+          (scope-loop-do local (car rest) (cdr rest)))
+         ((eq bare 'return)
+          (nconc (scope-1 local (car rest))
+                 (scope-loop local (cdr rest))))))
+    (scope-loop-do local next rest)))
+
+(defun scope-loop-initially (local next rest)
+  (if (and (symbol-with-pos-p next)
+           (eq (bare-symbol next) 'do))
+      (scope-loop-do local (car rest) (cdr rest))
+    (scope-loop-do local next rest)))
+
+(defvar scope-loop-if-depth 0)
+
+(defun scope-loop-if (local keyword condition rest)
+  (nconc (scope-1 local condition)
+         (let ((scope-loop-if-depth (1+ scope-loop-if-depth)))
+           (scope-loop
+            ;; `if' binds `it'.
+            (scope-local-new 'it (symbol-with-pos-pos keyword) local)
+            rest))))
+
+(defun scope-loop-end (local rest)
+  (let ((scope-loop-if-depth (1- scope-loop-if-depth)))
+    (unless (minusp scope-loop-if-depth)
+      (scope-loop local rest))))
+
+(defun scope-loop-and (local rest)
+  (when (plusp scope-loop-if-depth) (scope-loop local rest)))
+
 (defun scope-loop (local forms)
   (when forms
     (let ((kw (car forms))
@@ -927,7 +975,6 @@ Optional argument LOCAL is a local context to extend."
        ((symbol-with-pos-p kw)
         (let ((bare (bare-symbol kw)))
           (cond
-           ;; FIXME: Handle `and' clause-linking.
            ((memq bare '(for as))
             (scope-loop-for local local (car rest) (cdr rest)))
            ((memq bare '( repeat while until always never thereis iter-by
@@ -935,11 +982,15 @@ Optional argument LOCAL is a local context to extend."
             (scope-loop-repeat local (car rest) (cdr rest)))
            ((memq bare '(collect append nconc concat vconcat count sum maximize minimize))
             (scope-loop-collect local (car rest) (cdr rest)))
-           ;; FIXME: Handle `and' clause-linking.
            ((memq bare '(with))
-            (scope-loop-with local (car rest) (cadr rest) (caddr rest) (cdddr rest)))
+            (scope-loop-with 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))))))))))
+           ((memq bare '(named)) (scope-loop-named local (car rest) (cdr rest)))
+           ((memq bare '(finally)) (scope-loop-finally local (car rest) (cdr rest)))
+           ((memq bare '(initially)) (scope-loop-initially local (car rest) (cdr rest)))
+           ((memq bare '(if when unless)) (scope-loop-if local kw (car rest) (cdr rest)))
+           ((memq bare '(end)) (scope-loop-end local rest))
+           ((memq bare '(and else)) (scope-loop-and local rest)))))))))
 
 (defun scope-named-let (local name bindings body)
   (let ((bare (bare-symbol name))