scope.el: Handle 'cl-defmethod' and 'cl-defun'

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
index 5ea596fbeaece11cbb6f04725ceffb3077ddee67..17665df29c9da8046832b4003655cfb1cc2cb4e7 100644 (file)
--- 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)))