From f9e2d6a20813c137b12e921f5f802e8402b04413 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Mon, 20 Jan 2025 08:58:20 +0100 Subject: [PATCH] scope.el: Handle 'cl-defmethod' and 'cl-defun' --- lisp/emacs-lisp/scope.el | 240 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 240 insertions(+) diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 5ea596fbeae..17665df29c9 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -713,6 +713,242 @@ Optional argument LOCAL is a local context to extend." (bare (scope-sym-bare sym))) (funcall scope-callback 'group beg (length (symbol-name bare)) nil))) +(defun scope-defmethod-1 (local0 local args body) + (if args + (let ((arg (car args)) (bare nil)) + (cond + ((consp arg) + (let* ((var (car arg)) + (spec (cadr arg))) + (cond + ((setq bare (scope-sym-bare var)) + (when-let* ((beg (scope-sym-pos var)) + (len (length (symbol-name bare)))) + (funcall scope-callback 'variable beg len beg)) + (cond + ((consp spec) + (let ((head (car spec)) (form (cadr spec))) + (and (eq 'eql (scope-sym-bare head)) + (not (or (symbolp form) (symbol-with-pos-p form))) + (scope-1 local0 form)))) + ((symbol-with-pos-p spec) + (when-let* ((beg (symbol-with-pos-pos spec)) + (bare (bare-symbol spec)) + (len (length (symbol-name bare)))) + (funcall scope-callback 'type beg len nil)))) + (scope-defmethod-1 + local0 (scope-local-new bare (scope-sym-pos var) local) + (cdr args) body))))) + ((setq bare (scope-sym-bare arg)) + (cond + ((memq bare '(&optional &rest &body _)) + (when-let ((beg (scope-sym-pos arg))) + (funcall scope-callback 'ampersand beg (length (symbol-name bare)) nil)) + (scope-defmethod-1 local0 local (cdr args) body)) + ((eq bare '&context) + (let* ((expr-type (cadr args)) + (expr (car expr-type)) + (spec (cadr expr-type)) + (more (cddr args))) + (when-let ((beg (scope-sym-pos arg))) + (funcall scope-callback 'ampersand beg (length (symbol-name bare)) nil)) + (scope-1 local0 expr) + (cond + ((consp spec) + (let ((head (car spec)) (form (cadr spec))) + (and (eq 'eql (scope-sym-bare head)) + (not (or (symbolp form) (symbol-with-pos-p form))) + (scope-1 local0 form)))) + ((symbol-with-pos-p spec) + (when-let* ((beg (symbol-with-pos-pos spec)) + (bare (bare-symbol spec)) + (len (length (symbol-name bare)))) + (funcall scope-callback 'type beg len beg)))) + (scope-defmethod-1 local0 local more body))) + (t + (when-let* ((beg (scope-sym-pos arg)) + (len (length (symbol-name bare)))) + (funcall scope-callback 'variable beg len beg)) + (scope-defmethod-1 + local0 (scope-local-new bare (scope-sym-pos arg) local) + (cdr args) body)))))) + (scope-n local body))) + +;; (defun scope-defmethod (local name rest) +;; (when (and (symbol-with-pos-p (car rest)) +;; (eq (bare-symbol (car rest)) :extra)) +;; (setq rest (cddr rest))) +;; (when (and (symbol-with-pos-p (car rest)) +;; (memq (bare-symbol (car rest)) '(:before :after :around))) +;; (setq rest (cdr rest))) +;; (scope-defmethod-1 local local name (car rest) +;; (if (stringp (cadr rest)) (cddr rest) (cdr rest)))) + +(defun scope-defmethod (local name rest) + "Analyze method definition for NAME with args REST in LOCAL context." + (when-let* ((beg (scope-sym-pos name)) (bare (scope-sym-bare name))) + (funcall scope-callback 'defun beg (length (symbol-name bare)) nil)) + ;; [EXTRA] + (when (eq (scope-sym-bare (car rest)) :extra) + (scope-s local (car rest)) + (setq rest (cddr rest))) + ;; [QUALIFIER] + (when (keywordp (scope-sym-bare (car rest))) + (scope-s local (car rest)) + (setq rest (cdr rest))) + ;; ARGUMENTS + (scope-defmethod-1 local local (car rest) (cdr rest))) + +(defun scope-cl-defun (local name arglist body) + (when-let ((beg (scope-sym-pos name)) + (bare (scope-sym-bare name))) + (funcall scope-callback 'defun beg (length (symbol-name bare)) nil)) + (scope-cl-lambda local arglist body)) + +(defun scope-cl-lambda (local arglist body) + (scope-cl-lambda-1 local arglist nil body)) + +(defun scope-cl-lambda-1 (local arglist more body) + (cond + (arglist + (let ((head (car arglist))) + (if (consp head) + (scope-cl-lambda-1 local head (cons (cdr arglist) more) body) + (let ((bare (scope-sym-bare head))) + (if (memq bare '(&optional &rest &body &key &aux &whole)) + (progn + (when-let ((beg (scope-sym-pos head))) + (funcall scope-callback 'ampersand beg (length (symbol-name bare)) nil)) + (cl-case bare + (&optional (scope-cl-lambda-optional local (cadr arglist) (cddr arglist) more body)) + ((&rest &body) (scope-cl-lambda-rest local (cadr arglist) (cddr arglist) more body)) + (&key (scope-cl-lambda-key local (cadr arglist) (cddr arglist) more body)) + (&aux (scope-cl-lambda-aux local (cadr arglist) (cddr arglist) more body)) + (&whole (scope-cl-lambda-1 local (cdr arglist) more body)))) + (when-let ((beg (scope-sym-pos head))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) beg)) + (scope-cl-lambda-1 (scope-local-new bare (scope-sym-pos head) local) + (cdr arglist) more body)))))) + (more (scope-cl-lambda-1 local (car more) (cdr more) body)) + (t (scope-lambda local nil body)))) + +(defun scope-cl-lambda-optional (local arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l local) + (init (cadr a)) + (svar (caddr a))) + (scope-1 local init) + (if (consp var) + (scope-cl-lambda-1 l var (cons (append (when svar (list svar)) + (cons '&optional arglist)) + more) + body) + (when-let ((bare (scope-sym-bare svar))) + (when-let ((beg (scope-sym-pos svar))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) beg)) + (setq l (scope-local-new bare (scope-sym-pos svar) l))) + (when-let ((bare (scope-sym-bare var))) + (when-let ((beg (scope-sym-pos var))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) beg)) + (setq l (scope-local-new bare (scope-sym-pos var) l))) + (cond + (arglist + (let ((head (car arglist))) + (if-let ((bare (scope-sym-bare head)) + ((memq bare '(&rest &body &key &aux)))) + (progn + (when-let ((beg (scope-sym-pos head))) + (funcall scope-callback 'ampersand beg (length (symbol-name bare)) nil)) + (cl-case bare + ((&rest &body) (scope-cl-lambda-rest l (cadr arglist) (cddr arglist) more body)) + (&key (scope-cl-lambda-key l (cadr arglist) (cddr arglist) more body)) + (&aux (scope-cl-lambda-aux l (cadr arglist) (cddr arglist) more body)))) + (scope-cl-lambda-optional l head (cdr arglist) more body)))) + (more (scope-cl-lambda-1 l (car more) (cdr more) body)) + (t (scope-lambda l nil body)))))) + +(defun scope-cl-lambda-rest (local var arglist more body) + (let* ((l local)) + (if (consp var) + (scope-cl-lambda-1 l var (cons arglist more) body) + (when-let ((bare (scope-sym-bare var))) + (when-let ((beg (scope-sym-pos var))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) beg)) + (setq l (scope-local-new bare (scope-sym-pos var) l))) + (cond + (arglist + (let ((head (car arglist))) + (if-let ((bare (scope-sym-bare head)) + ((memq bare '(&key &aux)))) + (progn + (when-let ((beg (scope-sym-pos head))) + (funcall scope-callback 'ampersand beg (length (symbol-name bare)) nil)) + (cl-case bare + (&key (scope-cl-lambda-key l (cadr arglist) (cddr arglist) more body)) + (&aux (scope-cl-lambda-aux l (cadr arglist) (cddr arglist) more body)))) + (scope-cl-lambda-1 l (car more) (cdr more) body)))) + (more (scope-cl-lambda-1 l (car more) (cdr more) body)) + (t (scope-lambda l nil body)))))) + +(defun scope-cl-lambda-key (local arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l local) + (init (cadr a)) + (svar (caddr a)) + (kw (car-safe var))) + (scope-1 local init) + (and kw (or (symbolp kw) (symbol-with-pos-p kw)) + (cadr var) + (not (cddr var)) + ;; VAR is (KEYWORD VAR) + (setq var (cadr var))) + (if (consp var) + (scope-cl-lambda-1 l var (cons (append (when svar (list svar)) + (cons '&key arglist)) + more) + body) + (when-let ((bare (scope-sym-bare svar))) + (when-let ((beg (scope-sym-pos svar))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) beg)) + (setq l (scope-local-new bare (scope-sym-pos svar) l))) + (when-let ((bare (scope-sym-bare var))) + (when-let ((beg (scope-sym-pos var))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) beg)) + (setq l (scope-local-new bare (scope-sym-pos var) l))) + (cond + (arglist + (let ((head (car arglist))) + (if-let ((bare (scope-sym-bare head)) + ((memq bare '(&aux &allow-other-keys)))) + (progn + (when-let ((beg (scope-sym-pos head))) + (funcall scope-callback 'ampersand beg (length (symbol-name bare)) nil)) + (cl-case bare + (&aux (scope-cl-lambda-aux l (cadr arglist) (cddr arglist) more body)) + (&allow-other-keys (scope-cl-lambda-1 l (car more) (cdr more) body)))) + (scope-cl-lambda-key l head (cdr arglist) more body)))) + (more (scope-cl-lambda-1 l (car more) (cdr more) body)) + (t (scope-lambda l nil body)))))) + +(defun scope-cl-lambda-aux (local arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l local) + (init (cadr a))) + (scope-1 local init) + (if (consp var) + (scope-cl-lambda-1 l var (cons arglist more) body) + (when-let ((bare (scope-sym-bare var))) + (when-let ((beg (scope-sym-pos var))) + (funcall scope-callback 'variable beg (length (symbol-name bare)) beg)) + (setq l (scope-local-new bare (scope-sym-pos var) l))) + (cond + (arglist (scope-cl-lambda-aux l (car arglist) (cdr arglist) more body)) + (more (scope-cl-lambda-1 l (car more) (cdr more) body)) + (t (scope-lambda l nil body)))))) + (defvar scope-safe-macros t "Specify which macros are safe to expand. @@ -1002,6 +1238,10 @@ a (possibly empty) list of safe macros.") (scope-with-slots local (car forms) (cadr forms) (cddr forms))) ((memq bare '(ert-deftest)) (scope-defun local (car forms) (cadr forms) (cddr forms))) + ((eq bare 'cl-defmethod) + (scope-defmethod local (car forms) (cdr forms))) + ((eq bare 'cl-defun) + (scope-cl-defun local (car forms) (cadr forms) (cddr forms))) ((memq bare '(declare-function)) (scope-declare-function local (car forms) (cadr forms) (caddr forms) (cadddr forms))) -- 2.39.5