From: Eshel Yaron Date: Mon, 12 Aug 2024 17:56:12 +0000 (+0200) Subject: scope.el: Extend 'cl-loop' support X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=3cb98a99ab89c83927ec6218935e0198cb40ff5d;p=emacs.git scope.el: Extend 'cl-loop' support --- diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 41d51c86dd6..25ddef6123d 100644 --- 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))