From: Eshel Yaron <me@eshelyaron.com>
Date: Sun, 11 Aug 2024 18:05:43 +0000 (+0200)
Subject: Support (most of) 'cl-loop' in scope.el
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=b82b925335d02bc63ff25b036667915491eb8c6e;p=emacs.git

Support (most of) 'cl-loop' in scope.el
---

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
index af468369205..52dc261bffb 100644
--- a/lisp/emacs-lisp/scope.el
+++ b/lisp/emacs-lisp/scope.el
@@ -46,24 +46,27 @@ Optional argument LOCAL is a local context to extend."
 (defun scope-let (local bindings body)
   (nconc
    (mapcan (lambda (binding)
-             (if (consp binding)
-                 (cons
-                  (let* ((sym (car binding))
-                         (beg (symbol-with-pos-pos sym))
-                         (bare (bare-symbol sym))
-                         (len (length (symbol-name bare))))
-                    (list beg len beg))
-                  (scope-1 local (cadr binding)))
+             (cond
+              ((consp binding)
+               (cons
+                (let* ((sym (car binding))
+                       (beg (symbol-with-pos-pos sym))
+                       (bare (bare-symbol sym))
+                       (len (length (symbol-name bare))))
+                  (list beg len beg))
+                (scope-1 local (cadr binding))))
+              (binding
                (let* ((sym binding)
                       (beg (symbol-with-pos-pos sym))
                       (bare (bare-symbol sym))
                       (len (length (symbol-name bare))))
-                 (list (list beg len beg)))))
+                 (list (list beg len beg))))))
            bindings)
    (let ((l local))
      (dolist (binding bindings)
        (let ((sym (if (consp binding) (car binding) binding)))
-         (setq l (scope-local-new (bare-symbol sym) (symbol-with-pos-pos sym) l))))
+         (when binding
+           (setq l (scope-local-new (bare-symbol sym) (symbol-with-pos-pos sym) l)))))
      (scope-n l body))))
 
 (defun scope-let* (local bindings body)
@@ -692,6 +695,184 @@ Optional argument LOCAL is a local context to extend."
                 (scope-letrec l (cdr binders) body))))
     (scope-n local body)))
 
+(defun scope-loop-for-by (local0 local expr rest)
+  (nconc (scope-1 local0 expr) (scope-loop local rest)))
+
+(defun scope-loop-for-to (local0 local expr rest)
+  (nconc
+   (scope-1 local0 expr)
+   (let ((word (car rest))
+         (more (cdr rest)))
+     (cond
+      ((symbol-with-pos-pos word)
+       (let ((bw (bare-symbol word)))
+         (cond
+          ((eq bw 'by)
+           (scope-loop-for-by local0 local (car more) (cdr more)))
+          (t (scope-loop local rest)))))))))
+
+(defun scope-loop-for-from (local0 local expr rest)
+  (nconc
+   (scope-1 local0 expr)
+   (let ((word (car rest))
+         (more (cdr rest)))
+     (cond
+      ((symbol-with-pos-pos word)
+       (let ((bw (bare-symbol word)))
+         (cond
+          ((memq bw '(to upto downto below above))
+           (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)))))))))
+
+(defun scope-loop-for-= (local0 local expr rest)
+  (nconc
+   (scope-1 local0 expr)
+   (let ((word (car rest))
+         (more (cdr rest)))
+     (cond
+      ((symbol-with-pos-pos word)
+       (let ((bw (bare-symbol word)))
+         (cond
+          ((eq bw 'then)
+           (scope-loop-for-by local0 local (car more) (cdr more)))
+          (t (scope-loop local rest)))))))))
+
+(defun scope-loop-for-being-the-hash-keys-of-using (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))))
+
+(defun scope-loop-for-being-the-hash-keys-of (local0 local expr rest)
+  (nconc
+   (scope-1 local0 expr)
+   (let ((word (car rest))
+         (more (cdr rest)))
+     (when (symbol-with-pos-p word)
+       (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 more))))))))
+
+(defun scope-loop-for-being-the-hash-keys (local0 local word rest)
+  (when (symbol-with-pos-p word)
+    (let ((bw (bare-symbol word)))
+      (cond
+       ((eq bw 'of)
+        (scope-loop-for-being-the-hash-keys-of local0 local (car rest) (cdr rest)))))))
+
+(defun scope-loop-for-being-the (local0 local word rest)
+  (when (symbol-with-pos-p word)
+    (let ((bw (bare-symbol word)))
+      (cond
+       ((memq bw '(buffer buffers))
+        (scope-loop local rest))
+       ((memq bw '( hash-key hash-keys
+                    hash-value hash-values
+                    key-code key-codes
+                    key-binding key-bindings))
+        (scope-loop-for-being-the-hash-keys local0 local (car rest) (cdr rest)))))))
+
+(defun scope-loop-for-being (local0 local next rest)
+  (scope-loop-for-being-the
+   local0 local (car rest)
+   (if (and (symbol-with-pos-p next)
+            (memq (bare-symbol next) '(the each)))
+       (cdr rest)
+     rest)))
+
+(defun scope-loop-for (local0 local vars rest)
+  (if vars
+      (let* ((var (car (ensure-list vars)))
+             (bare (bare-symbol var))
+             (beg (symbol-with-pos-pos var)))
+        (cons
+         (list beg (length (symbol-name bare)) beg)
+         (scope-loop-for local0 (scope-local-new bare beg local) (cdr-safe vars) rest)))
+    (let ((word (car rest))
+          (more (cdr rest)))
+      (cond
+       ((symbol-with-pos-p word)
+        (let ((bw (bare-symbol word)))
+          (cond
+           ((memq bw '(from upfrom downfrom))
+            (scope-loop-for-from local0 local (car more) (cdr more)))
+           ((memq bw '( to upto downto below above
+                        in on in-ref))
+            (scope-loop-for-to local0 local (car more) (cdr more)))
+           ((memq bw '(by
+                       across across-ref))
+            (scope-loop-for-by local0 local (car more) (cdr more)))
+           ((eq bw '=)
+            (scope-loop-for-= local0 local (car more) (cdr more)))
+           ((memq bw '(being))
+            (scope-loop-for-being local0 local (car more) (cdr more))))))))))
+
+(defun scope-loop-repeat (local form rest)
+  (nconc (scope-1 local form) (scope-loop local rest)))
+
+(defun scope-loop-collect (local expr rest)
+  (nconc
+   (scope-1 local expr)
+   (let ((word (car rest))
+         (more (cdr rest)))
+     (if (and (symbol-with-pos-p word)
+              (eq (bare-symbol word) 'into))
+         (let* ((var (car more))
+                (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) (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) '=))
+    (let* ((bare (bare-symbol var))
+           (beg (symbol-with-pos-pos var))
+           (l (scope-local-new bare beg local)))
+      (cons
+       (list beg (length (symbol-name bare)) beg)
+       (nconc
+        (scope-1 local val)
+        (scope-loop l rest))))))
+
+(defun scope-loop-do (local form rest)
+  (nconc
+   (scope-1 local form)
+   (if (consp (car rest))
+       (scope-loop-do local (car rest) (cdr rest))
+     (scope-loop local rest))))
+
+(defun scope-loop (local forms)
+  (when forms
+    (let ((kw (car forms))
+          (rest (cdr forms)))
+      (cond
+       ((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
+                          return))
+            (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)))
+           ((memq bare '(do)) (scope-loop-do local (car rest) (cdr rest))))))))))
+
 (defvar scope-assume-func-p nil)
 
 (defun scope-1 (local form &optional top-level)
@@ -751,6 +932,8 @@ Optional argument LOCAL is a local context to extend."
               (scope-pcase-let local (car forms) (cdr forms)))
              ((memq bare '(pcase-let*))
               (scope-pcase-let* local (car forms) (cdr forms)))
+             ((memq bare '(cl-loop))
+              (scope-loop local forms))
              ((memq bare '(setq-local setq-default))
               (scope-setq local forms))
              ((memq bare '(push))