From b82b925335d02bc63ff25b036667915491eb8c6e Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Sun, 11 Aug 2024 20:05:43 +0200 Subject: [PATCH] Support (most of) 'cl-loop' in scope.el --- lisp/emacs-lisp/scope.el | 203 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 193 insertions(+), 10 deletions(-) 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)) -- 2.39.2