From: Eshel Yaron <me@eshelyaron.com>
Date: Sun, 26 Jan 2025 18:21:35 +0000 (+0100)
Subject: scope.el: Optimize.
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=ae2d2a5932a402247713a58f0c69faa782936c6b;p=emacs.git

scope.el: Optimize.
---

diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el
index 2615661879b..1d9b3ccf18a 100644
--- a/lisp/emacs-lisp/scope.el
+++ b/lisp/emacs-lisp/scope.el
@@ -422,7 +422,7 @@ Optional argument LOCAL is a local context to extend."
                (beg (scope-sym-pos var)))
           (when beg
             (scope-report 'variable
-                     beg (length (symbol-name bare)) beg))
+                          beg (length (symbol-name bare)) beg))
           (scope-loop (scope-local-new bare beg local) (cdr more)))
       (scope-loop local rest))))
 
@@ -601,7 +601,7 @@ Optional argument LOCAL is a local context to extend."
         (when-let ((bare (scope-sym-bare name))
                    (beg (symbol-with-pos-pos name)))
           (scope-report 'rx-construct
-                   beg (length (symbol-name bare)) beg))
+                        beg (length (symbol-name bare)) beg))
         (if (cdr rest)
             (let ((l scope-rx-alist)
                   (args (car rest))
@@ -653,13 +653,11 @@ Optional argument LOCAL is a local context to extend."
     (scope-report 'throw-tag beg (length (symbol-name bare))))
   (scope-n local body))
 
-(defun scope-face (_local face-form)
-  (when-let (((memq (scope-sym-bare (car-safe face-form)) '(quote \`)))
-             (face (cadr face-form)))
-    (if (or (scope-sym-bare face)
-            (keywordp (scope-sym-bare (car-safe face))))
-        (scope-face-1 face)
-      (mapc #'scope-face-1 face))))
+(defun scope-face (face)
+  (if (or (scope-sym-bare face)
+          (keywordp (scope-sym-bare (car-safe face))))
+      (scope-face-1 face)
+    (mapc #'scope-face-1 face)))
 
 (defun scope-face-1 (face)
   (cond
@@ -1112,358 +1110,354 @@ a (possibly empty) list of safe macros.")
 
 (defvar warning-minimum-log-level)
 
+(defmacro scope-define-analyzer (fsym args &rest body)
+  (declare (indent defun))
+  (let ((analyzer (intern (concat "scope--analyze-" (symbol-name fsym)))))
+    `(progn
+       (defun ,analyzer ,args ,@body)
+       (put ',fsym 'scope-analyzer #',analyzer))))
+
+(defmacro scope-define-function-analyzer (fsym args &rest body)
+  (declare (indent defun))
+  (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1"))))
+    `(progn
+       (defun ,helper ,args ,@body)
+       (scope-define-analyzer ,fsym (l f &rest args)
+         (scope-report-s f 'function)
+         (apply #',helper args)
+         (scope-n l args)))))
+
+(defmacro scope-define-macro-analyzer (fsym args &rest body)
+  (declare (indent defun))
+  (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1"))))
+    `(progn
+       (defun ,helper ,args ,@body)
+       (scope-define-analyzer ,fsym (l f &rest args)
+         (scope-report-s f 'macro)
+         (apply #',helper l args)))))
+
+(defmacro scope-define-special-form-analyzer (fsym args &rest body)
+  (declare (indent defun))
+  (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1"))))
+    `(progn
+       (defun ,helper ,args ,@body)
+       (scope-define-analyzer ,fsym (l f &rest args)
+         (scope-report-s f 'macro)
+         (apply #',helper l args)))))
+
+(defun scope--unqoute (form)
+  (when (memq (scope-sym-bare (car-safe form)) '(quote function \`))
+    (cadr form)))
+
+(scope-define-analyzer with-suppressed-warnings (l f warnings &rest body)
+  (scope-report-s f 'macro)
+  (dolist (warning warnings)
+    (when-let* ((wsym (car-safe warning)))
+      (scope-report-s wsym 'warning-type)))
+  (scope-n l body))
+
+(scope-define-analyzer eval (l f form &optional lexical)
+  (scope-report-s f 'function)
+  (if-let ((quoted (scope--unqoute form)))
+      (scope-1 l quoted)
+    (scope-1 l form))
+  (scope-1 l lexical))
+
+(scope-define-function-analyzer defalias (definition &optional _docstring)
+  (when-let ((quoted (scope--unqoute definition))) (scope-report-s quoted 'defun)))
+
+(scope-define-function-analyzer custom-declare-variable (sym _default _doc &rest args)
+  (when-let ((quoted (scope--unqoute sym))) (scope-report-s quoted 'defvar))
+  (while-let ((kw (car-safe args))
+              (bkw (scope-sym-bare kw))
+              ((keywordp bkw)))
+    (cl-case bkw
+      (:type
+       (when-let ((quoted (scope--unqoute (cadr args)))) (scope-widget-type-1 quoted)))
+      (:group
+       (when-let ((quoted (scope--unqoute (cadr args)))) (scope-report-s quoted 'group))))
+    (setq args (cddr args))))
+
+(scope-define-function-analyzer custom-declare-group (sym _members _doc &rest args)
+  (when-let ((quoted (scope--unqoute sym))) (scope-report-s quoted 'group))
+  (while-let ((kw (car-safe args))
+              (bkw (scope-sym-bare kw))
+              ((keywordp bkw)))
+    (cl-case bkw
+      (:group
+       (when-let ((quoted (scope--unqoute (cadr args)))) (scope-report-s quoted 'group))))
+    (setq args (cddr args))))
+
+(scope-define-function-analyzer custom-declare-face (face spec _doc &rest args)
+  (when-let ((q (scope--unqoute face))) (scope-report-s q 'defface))
+  (when-let ((q (scope--unqoute spec)))
+    (when (consp q) (dolist (s q) (scope-face (cdr s)))))
+  (while-let ((kw (car-safe args))
+              (bkw (scope-sym-bare kw))
+              ((keywordp bkw)))
+    (cl-case bkw
+      (:group
+       (when-let ((q (scope--unqoute (cadr args)))) (scope-report-s q 'group))))
+    (setq args (cddr args))))
+
+(scope-define-function-analyzer cl-typed (_val type)
+  (when-let ((q (scope--unqoute type)) ((not (booleanp q))))
+    (scope-report-s q 'type)))
+
+(scope-define-function-analyzer throw (tag _value)
+  (when-let ((q (scope--unqoute tag))) (scope-report-s q 'throw-tag)))
+
+(scope-define-function-analyzer run-hooks (&rest hooks)
+  (dolist (hook hooks)
+    (when-let ((q (scope--unqoute hook))) (scope-report-s q 'variable))))
+
+(scope-define-function-analyzer signal (error-symbol _data)
+  (when-let ((q (scope--unqoute error-symbol))) (scope-report-s q 'condition)))
+
+(scope-define-function-analyzer fboundp (symbol)
+  (when-let ((q (scope--unqoute symbol))) (scope-report-s q 'function)))
+
+(scope-define-function-analyzer overlay-put (_ov prop val)
+  (when-let ((q (scope--unqoute prop))
+             ((eq (scope-sym-bare q) 'face))
+             (face (scope--unqoute val)))
+    (scope-face face)))
+
+(scope-define-function-analyzer boundp (var &rest _)
+  (when-let ((q (scope--unqoute var))) (scope-report-s q 'variable)))
+
+(dolist (sym '( set symbol-value define-abbrev-table
+                special-variable-p local-variable-p
+                local-variable-if-set-p
+                default-value set-default make-local-variable
+                buffer-local-value add-to-list
+                add-hook remove-hook run-hook-with-args run-hook-wrapped))
+  (put sym 'scope-analyzer #'scope--analyze-boundp))
+
+(scope-define-function-analyzer defvaralias (new base &optional _docstring)
+  (when-let ((q (scope--unqoute new))) (scope-report-s q 'defvar))
+  (when-let ((q (scope--unqoute base))) (scope-report-s q 'variable)))
+
+(scope-define-function-analyzer define-error (name _message &optional parent)
+  (when-let ((q (scope--unqoute name))) (scope-report-s q 'condition))
+  (when-let ((q (scope--unqoute parent)))
+    (dolist (p (ensure-list q)) (scope-report-s p 'condition))))
+
+(scope-define-function-analyzer featurep (feature &rest _)
+  (when-let ((q (scope--unqoute feature))) (scope-report-s q 'feature)))
+
+(put 'provide 'scope-analyzer #'scope--analyze-featurep)
+(put 'require 'scope-analyzer #'scope--analyze-featurep)
+
+(scope-define-function-analyzer put-text-property (&optional _ _ prop val)
+  (when (eq 'face (scope-sym-bare (scope--unqoute prop)))
+    (when-let ((q (scope--unqoute val))) (scope-face q))))
+
+(put 'remove-overlays 'scope-analyzer #'scope--analyze-put-text-property)
+
+(scope-define-function-analyzer propertize (_string &rest props)
+  (while props
+    (cl-case (scope-sym-bare (scope--unqoute (car props)))
+      (face
+       (when-let ((q (scope--unqoute (cadr props)))) (scope-face q))))
+    (setq props (cddr props))))
+
+(scope-define-function-analyzer eieio-defclass-internal (name superclasses slots options)
+  (when-let ((q (scope--unqoute name))) (scope-report-s q 'type))
+  (when-let ((q (scope--unqoute superclasses)))
+    (dolist (sup q) (scope-report-s sup 'type))))
+
+(scope-define-function-analyzer cl-struct-define
+  (name _doc parent _type _named _slots _children _tab _print)
+  (when-let ((q (scope--unqoute name)))   (scope-report-s q 'type))
+  (when-let ((q (scope--unqoute parent))) (scope-report-s q 'type)))
+
+(scope-define-function-analyzer define-widget (name class _doc &rest args)
+  (when-let ((q (scope--unqoute name)))  (scope-report-s q 'widget-type))
+  (when-let ((q (scope--unqoute class))) (scope-report-s q 'type))
+  (while-let ((kw (car-safe args))
+              (bkw (scope-sym-bare kw))
+              ((keywordp bkw)))
+    (cl-case bkw
+      (:type
+       (when-let ((q (scope--unqoute (cadr args)))) (scope-widget-type-1 q)))
+      (:args
+       (when-let ((q (scope--unqoute (cadr args)))) (mapc #'scope-widget-type-1 q))))
+    (setq args (cddr args))))
+
+(scope-define-function-analyzer provide-theme (name &rest _)
+  (when-let ((q (scope--unqoute name)))  (scope-report-s q 'theme)))
+
+(put 'custom-declare-theme 'scope-analyzer #'scope--analyze-provide-theme)
+
+(scope-define-macro-analyzer define-globalized-minor-mode (l global mode turn-on &rest body)
+  (scope-define-global-minor-mode l global mode turn-on body))
+
+(scope-define-macro-analyzer lambda (l args &rest body)
+  (scope-lambda l args body))
+
+(scope-define-macro-analyzer cl-loop (l &rest clauses)
+  (scope-loop l clauses))
+
+(scope-define-macro-analyzer named-let (l name bindings &rest body)
+  (scope-named-let l name bindings body))
+
+(scope-define-macro-analyzer cl-flet (l bindings &rest body)
+  (scope-flet l bindings body))
+
+(scope-define-macro-analyzer cl-labels (l bindings &rest body)
+  (scope-labels l bindings body))
+
+(scope-define-macro-analyzer with-slots (l spec-list object &rest body)
+  (scope-with-slots l spec-list object body))
+
+(scope-define-macro-analyzer cl-defmethod (l name &rest rest)
+  (scope-defmethod l name rest))
+
+(scope-define-macro-analyzer cl-destructuring-bind (l args expr &rest body)
+  (scope-1 l expr)
+  (scope-cl-lambda l args body))
+
+(scope-define-macro-analyzer declare-function (l fn file &optional arglist fileonly)
+  (scope-declare-function l fn file arglist fileonly))
+
+(scope-define-macro-analyzer cl-block (l name &rest body)
+  (scope-block l name body))
+
+(scope-define-macro-analyzer cl-return-from (l name &optional result)
+  (scope-return-from l name result))
+
+(scope-define-macro-analyzer rx (l &rest regexps)
+  ;; Unsafe macro!
+  (scope-rx l regexps))
+
+(scope-define-macro-analyzer rx-define (l name &rest rest)
+  (scope-rx-define l name rest))
+
+(scope-define-macro-analyzer rx-let (l bindings &rest body)
+  (scope-rx-let l bindings body))
+
+(scope-define-macro-analyzer let-when-compile (l bindings &rest body)
+  ;; Unsafe macro!
+  (scope-let* l bindings body))
+
+(scope-define-macro-analyzer cl-eval-when (l _when &rest body)
+  ;; Unsafe macro!
+  (scope-n l body))
+
+(scope-define-macro-analyzer cl-macrolet (l bindings &rest body)
+  ;; Unsafe macro!
+  (scope-cl-macrolet l bindings body))
+
+(scope-define-macro-analyzer gv-define-expander (l name handler)
+  (scope-gv-define-expander l name handler))
+
+(scope-define-macro-analyzer gv-define-simple-setter (l name setter &rest rest)
+  (scope-gv-define-simple-setter l name setter rest))
+
+(scope-define-macro-analyzer cl-deftype (l name arglist &rest body)
+  (scope-deftype l name arglist body))
+
+(scope-define-macro-analyzer define-minor-mode (l mode doc &rest body)
+  (scope-define-minor-mode l mode doc body))
+
+(scope-define-macro-analyzer setq-local (l &rest args)
+  (scope-setq l args))
+
+(put 'setq-default 'scope-analyzer #'scope--analyze-setq-local)
+
+(scope-define-macro-analyzer cl-defun (l name arglist &rest body)
+  (scope-cl-defun l name arglist body))
+
+(put 'cl-defmacro 'scope-analyzer #'scope--analyze-cl-defun)
+
+(scope-define-macro-analyzer defun (l name arglist &rest body)
+  (scope-defun l name arglist body))
+
+(put 'defmacro 'scope-analyzer #'scope--analyze-defun)
+(put 'ert-deftest 'scope-analyzer #'scope--analyze-defun)
+
+(scope-define-macro-analyzer setf (l &rest args)
+  (scope-n l args))
+
+(dolist (sym '( pop push with-memoization cl-pushnew
+                ;; The following macros evaluate unsafe code.
+                ;; Never expand them!
+                static-if eval-when-compile eval-and-compile))
+  (put sym 'scope-analyzer #'scope--analyze-setf))
+
+(scope-define-analyzer let-alist (l f alist &rest body)
+  (scope-report-s f 'macro)
+  (scope-1 l alist)
+  (let ((scope-current-let-alist-form
+         (cons (or (scope-sym-pos f) (cons 'gen (cl-incf scope-counter)))
+               (scope-sym-pos f))))
+    (scope-n l body)))
+
+(scope-define-special-form-analyzer let (l bindings &rest body)
+  (scope-let-1 l l bindings body))
+
+(scope-define-special-form-analyzer let* (l bindings &rest body)
+  (scope-let* l bindings body))
+
+(scope-define-special-form-analyzer cond (l &rest clauses)
+  (scope-cond l clauses))
+
+(scope-define-special-form-analyzer setq (l &rest args)
+  (scope-setq l args))
+
+(scope-define-special-form-analyzer defvar (l sym &optional init _doc)
+  (scope-defvar l sym init))
+
+(put 'defconst 'scope-analyzer #'scope--analyze-defvar)
+
+(scope-define-special-form-analyzer condition-case (l var bodyform &rest handlers)
+  (scope-condition-case l var bodyform handlers))
+
+(scope-define-special-form-analyzer function (l arg)
+  (scope-sharpquote l arg))
+
+(scope-define-special-form-analyzer quote (_l _arg)) ;Do nothing.
+
+(scope-define-special-form-analyzer catch (l tag &rest body)
+  (scope-catch l tag body))
+
+(defun scope-report-s (sym type)
+  (when-let* ((beg (scope-sym-pos sym)) (bare (bare-symbol sym)))
+    (scope-report type beg (length (symbol-name bare)))))
+
 (defun scope-1 (local form)
   (cond
    ((consp form)
     (let* ((f (car form)) (bare (scope-sym-bare f))
-           (forms (cdr form)))
+           (forms (cdr form)) (this nil))
       (when bare
         (cond
-         ((assq bare scope-flet-alist)
-          (scope-report 'function
-                        (symbol-with-pos-pos f) (length (symbol-name bare))
-                        (alist-get bare scope-flet-alist))
+         ((setq this (assq bare scope-flet-alist))
+          (scope-report
+           'function (symbol-with-pos-pos f) (length (symbol-name bare)) this)
           (scope-n local forms))
-         ((assq bare scope-macrolet-alist)
-          (scope-report 'macro
-                        (symbol-with-pos-pos f) (length (symbol-name bare))
-                        (alist-get bare scope-macrolet-alist))
+         ((setq this (assq bare scope-macrolet-alist))
+          (scope-report
+           'macro (symbol-with-pos-pos f) (length (symbol-name bare)) this)
           ;; Local macros can be unsafe, so we do not expand them.
           ;; Hence we cannot interpret their arguments.
           )
-         ((get bare 'scope-function)
-          (funcall (get bare 'scope-function) local forms))
-         ((functionp bare)
-          (cl-case bare
-            (eval
-             (let ((q (scope-sym-bare (car-safe (car forms)))))
-               (cond
-                ((eq q 'quote) (scope-1 local (cadar forms)))
-                ((and (memq q '(function \`))
-                      (symbol-with-pos-p (cadar forms)))
-                 (scope-s local (cadar forms))))))
-            (defalias
-              (when-let* ((alias-form (car forms))
-                          ((eq (scope-sym-bare (car-safe alias-form)) 'quote))
-                          (alias (cadr alias-form))
-                          (beg (scope-sym-pos alias))
-                          (bare (scope-sym-bare alias)))
-                (scope-report 'defun beg (length (symbol-name bare)))))
-            (custom-declare-variable
-             (when-let* ((sym-form (car forms))
-                         ((eq (scope-sym-bare (car-safe sym-form)) 'quote))
-                         (sym (cadr sym-form))
-                         (beg (scope-sym-pos sym))
-                         (bare (scope-sym-bare sym)))
-               (scope-report 'defvar beg (length (symbol-name bare))))
-             (when-let* ((props (cdddr forms))
-                         (symbols-with-pos-enabled t))
-               (when-let ((val-form (plist-get props :type)))
-                 (scope-widget-type local val-form))
-               (when-let ((val-form (plist-get props :group)))
-                 (scope-quoted-group local val-form))))
-            (custom-declare-group
-             (scope-quoted-group local (car forms))
-             (when-let* ((props (cdddr forms))
-                         (symbols-with-pos-enabled t)
-                         (val-form (plist-get props :group)))
-               (scope-quoted-group local val-form)))
-            (custom-declare-face
-             (when-let* ((alias-form (car forms))
-                         ((eq (scope-sym-bare (car-safe alias-form)) 'quote))
-                         (alias (cadr alias-form))
-                         (beg (scope-sym-pos alias))
-                         (bare (scope-sym-bare alias)))
-               (scope-report 'defface beg (length (symbol-name bare))))
-             (when-let* ((spec-form (cadr forms))
-                         ((eq (scope-sym-bare (car-safe spec-form)) 'quote))
-                         (specs (cadr spec-form))
-                         ((consp specs)))
-               (dolist (spec specs)
-                 (scope-face local (list 'quote (cdr spec)))))
-             (when-let* ((props (cdddr forms))
-                         (symbols-with-pos-enabled t))
-               (when-let ((val-form (plist-get props :group)))
-                 (scope-quoted-group local val-form))))
-            (cl-typep
-             (when-let* ((alias-form (cadr forms))
-                         ((eq (scope-sym-bare (car-safe alias-form)) 'quote))
-                         (alias (cadr alias-form))
-                         (beg (scope-sym-pos alias))
-                         (bare (scope-sym-bare alias)))
-               (unless (booleanp bare)
-                 (scope-report 'type beg (length (symbol-name bare))))))
-            (throw
-             (when-let* ((tag-form (car forms))
-                         ((memq (scope-sym-bare (car-safe tag-form)) '(quote \`)))
-                         (tag (cadr tag-form))
-                         (beg (scope-sym-pos tag))
-                         (bare (scope-sym-bare tag)))
-               (scope-report 'throw-tag beg (length (symbol-name bare)))))
-            (( boundp set symbol-value define-abbrev-table
-               special-variable-p local-variable-p
-               local-variable-if-set-p
-               default-value set-default make-local-variable
-               buffer-local-value add-to-list
-               add-hook remove-hook run-hook-with-args run-hook-wrapped)
-             (when-let* ((var-form (car forms))
-                         ((memq (scope-sym-bare (car-safe var-form)) '(quote \`)))
-                         (var (cadr var-form))
-                         (beg (scope-sym-pos var))
-                         (bare (scope-sym-bare var)))
-               (scope-report 'variable beg (length (symbol-name bare)))))
-            ((run-hooks)
-             (dolist (var-form forms)
-               (when-let* (((memq (scope-sym-bare (car-safe var-form)) '(quote \`)))
-                           (var (cadr var-form))
-                           (beg (scope-sym-pos var))
-                           (bare (scope-sym-bare var)))
-                 (scope-report 'variable beg (length (symbol-name bare))))))
-            ((featurep provide require)
-             (when-let* ((feat-form (car forms))
-                         ((memq (scope-sym-bare (car-safe feat-form)) '(quote \`)))
-                         (feat (cadr feat-form))
-                         (beg (scope-sym-pos feat))
-                         (bare (scope-sym-bare feat)))
-               (scope-report 'feature beg (length (symbol-name bare)))))
-            ((fboundp)
-             (when-let* ((fun-form (car forms))
-                         ((memq (scope-sym-bare (car-safe fun-form)) '(quote \`)))
-                         (fun (cadr fun-form))
-                         (beg (scope-sym-pos fun))
-                         (bare (scope-sym-bare fun)))
-               (scope-report 'function beg (length (symbol-name bare)))))
-            (overlay-put
-             (when-let* ((prop (cadr forms))
-                         ((memq (scope-sym-bare (car-safe prop)) '(quote \`)))
-                         ((eq (scope-sym-bare (cadr prop)) 'face)))
-               (scope-face local (caddr forms))))
-            ((remove-overlays put-text-property)
-             (when-let* ((prop (caddr forms))
-                         ((memq (scope-sym-bare (car-safe prop)) '(quote \`)))
-                         ((eq (scope-sym-bare (cadr prop)) 'face)))
-               (scope-face local (cadddr forms))))
-            (propertize
-             (when-let* ((props (cdr forms))
-                         (symbols-with-pos-enabled t)
-                         (val-form (plist-get props ''face #'equal)))
-               (scope-face local val-form)))
-            ((eieio-defclass-internal)
-             (when-let* ((name-form (car forms))
-                         ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
-                         (name (cadr name-form))
-                         (beg (scope-sym-pos name))
-                         (bare (scope-sym-bare name)))
-               (scope-report 'type beg (length (symbol-name bare))))
-             (when-let* ((sups-form (cadr forms))
-                         ((memq (scope-sym-bare (car-safe sups-form)) '(quote \`)))
-                         (sups (cadr sups-form)))
-               (dolist (sup (cadr sups-form))
-                 (when-let* ((beg (scope-sym-pos sup)) (bare (scope-sym-bare sup)))
-                   (scope-report 'type beg (length (symbol-name bare)))))))
-            ((cl-struct-define)
-             (when-let* ((name-form (car forms))
-                         ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
-                         (name (cadr name-form))
-                         (beg (scope-sym-pos name))
-                         (bare (scope-sym-bare name)))
-               (scope-report 'type beg (length (symbol-name bare))))
-             (when-let* ((prnt-form (caddr forms))
-                         ((memq (scope-sym-bare (car-safe prnt-form)) '(quote \`)))
-                         (prnt (cadr prnt-form))
-                         (beg (scope-sym-pos prnt))
-                         (bare (scope-sym-bare prnt)))
-               (scope-report 'type beg (length (symbol-name bare)))))
-            ((define-widget)
-             (when-let* ((name-form (car forms))
-                         ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
-                         (name (cadr name-form))
-                         (beg (scope-sym-pos name))
-                         (bare (scope-sym-bare name)))
-               (scope-report 'widget-type beg (length (symbol-name bare))))
-             (when-let* ((prnt-form (cadr forms))
-                         ((memq (scope-sym-bare (car-safe prnt-form)) '(quote \`)))
-                         (prnt (cadr prnt-form))
-                         (beg (scope-sym-pos prnt))
-                         (bare (scope-sym-bare prnt)))
-               (scope-report 'widget-type beg (length (symbol-name bare))))
-             (when-let* ((props (cdddr forms))
-                         (symbols-with-pos-enabled t))
-               (when-let ((val-form (plist-get props :type)))
-                 (scope-widget-type local val-form))
-               (when-let ((val-form (plist-get props :args))
-                          ((memq (scope-sym-bare (car-safe val-form)) '(quote \`)))
-                          (val (cadr val-form))
-                          ((consp val)))
-                 (mapc #'scope-widget-type-1 val))))
-            ((define-error)
-             (when-let* ((name-form (car forms))
-                         ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
-                         (name (cadr name-form))
-                         (beg (scope-sym-pos name))
-                         (bare (scope-sym-bare name)))
-               (scope-report 'condition beg (length (symbol-name bare))))
-             (when-let* ((prnt-form (caddr forms))
-                         ((memq (scope-sym-bare (car-safe prnt-form)) '(quote \`))))
-               (dolist (prnt (ensure-list (cadr prnt-form)))
-                 (when-let* ((beg (scope-sym-pos prnt)) (bare (scope-sym-bare prnt)))
-                   (scope-report 'condition beg (length (symbol-name bare)))))))
-            ((signal)
-             (when-let* ((name-form (car forms))
-                         ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
-                         (name (cadr name-form))
-                         (beg (scope-sym-pos name))
-                         (bare (scope-sym-bare name)))
-               (scope-report 'condition beg (length (symbol-name bare)))))
-            ((provide-theme custom-declare-theme)
-             (when-let* ((name-form (car forms))
-                         ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
-                         (name (cadr name-form))
-                         (beg (scope-sym-pos name))
-                         (bare (scope-sym-bare name)))
-               (scope-report 'theme beg (length (symbol-name bare)))))
-            ((defvaralias)
-             (when-let* ((new-form (car forms))
-                         ((memq (scope-sym-bare (car-safe new-form)) '(quote \`)))
-                         (name (cadr new-form))
-                         (beg (scope-sym-pos name))
-                         (bare (scope-sym-bare name)))
-               (scope-report 'defvar beg (length (symbol-name bare))))
-             (when-let* ((base-form (cadr forms))
-                         ((memq (scope-sym-bare (car-safe base-form)) '(quote \`)))
-                         (name (cadr base-form))
-                         (beg (scope-sym-pos name))
-                         (bare (scope-sym-bare name)))
-               (scope-report 'variable beg (length (symbol-name bare))))))
-          (when (symbol-with-pos-p f)
-            (scope-report 'function
-                          (symbol-with-pos-pos f) (length (symbol-name bare))))
-          (scope-n local forms))
-         ((special-form-p bare)
-          (when (symbol-with-pos-p f)
-            (scope-report 'special-form
-                          (symbol-with-pos-pos f) (length (symbol-name bare))))
-          (cond
-           ((eq bare 'let)
-            (scope-let local (car forms) (cdr forms)))
-           ((eq bare 'let*)
-            (scope-let* local (car forms) (cdr forms)))
-           ((eq bare 'cond) (scope-cond local forms))
-           ((eq bare 'setq) (scope-setq local forms))
-           ((memq bare '( defconst defvar))
-            (scope-defvar local (car forms) (cadr forms)))
-           ((eq bare 'condition-case)
-            (scope-condition-case local (car forms) (cadr forms) (cddr forms)))
-           ((eq bare 'function)
-            (scope-sharpquote local (car forms)))
-           ((eq bare 'catch)
-            (scope-catch local (car forms) (cdr forms)))
-           ((memq bare '( if and or while
-                          save-excursion save-restriction save-current-buffer
-                          unwind-protect
-                          progn prog1))
-            (scope-n local forms))))
-         ((macrop bare)
-          (when (symbol-with-pos-p f)
-            (scope-report 'macro
-                          (symbol-with-pos-pos f) (length (symbol-name bare))))
+         ((setq this (function-get bare 'scope-analyzer)) (apply this local form))
+         ((functionp      bare) (scope-report-s f 'function)     (scope-n local forms))
+         ((special-form-p bare) (scope-report-s f 'special-form) (scope-n local forms))
+         ((macrop bare) (scope-report-s f 'macro)
           (cond
-           ((memq bare '(let-alist))
-            (scope-1 local (car forms))
-            (let ((scope-current-let-alist-form
-                   (cons (or (scope-sym-pos f)
-                             (cons 'gen (cl-incf scope-counter)))
-                         (scope-sym-pos f))))
-              (scope-n local (cdr forms))))
            ((eq (get bare 'edebug-form-spec) t) (scope-n local forms))
-           ((eq bare 'lambda) (scope-lambda local (car forms) (cdr forms)))
-           ((eq bare 'cl-loop) (scope-loop local forms))
-           ((memq bare '(named-let))
-            (scope-named-let local (car forms) (cadr forms) (cdr forms)))
-           ((memq bare '(cl-flet))
-            (scope-flet local (car forms) (cdr forms)))
-           ((memq bare '(cl-labels))
-            (scope-labels local (car forms) (cdr forms)))
-           ((memq bare '( setf pop push with-memoization cl-pushnew
-                          ;; The following macros evaluate unsafe code.
-                          ;; Never expand them!
-                          static-if eval-when-compile eval-and-compile))
-            (scope-n local forms))
-           ((memq bare '(with-suppressed-warnings))
-            (dolist (warning (car forms))
-              (when-let* ((wsym (car-safe warning))
-                          (beg (scope-sym-pos wsym))
-                          (bare (scope-sym-bare wsym)))
-                (scope-report 'warning-type beg
-                              (length (symbol-name bare)))))
-            (scope-n local (cdr forms)))
-           ((memq bare '(with-slots))
-            (scope-with-slots local (car forms) (cadr forms) (cddr forms)))
-           ((memq bare '(defun defmacro ert-deftest))
-            (scope-defun local (car forms) (cadr forms) (cddr forms)))
-           ((eq bare 'cl-defmethod)
-            (scope-defmethod local (car forms) (cdr forms)))
-           ((memq bare '(cl-defun cl-defmacro))
-            (scope-cl-defun local (car forms) (cadr forms) (cddr forms)))
-           ((memq bare '(cl-destructuring-bind))
-            (scope-1 local (cadr forms))
-            (scope-cl-lambda local (car forms) (cddr forms)))
-           ((memq bare '(declare-function))
-            (scope-declare-function local (car forms) (cadr forms)
-                                    (caddr forms) (cadddr forms)))
-           ((memq bare '(setq-local setq-default))
-            (scope-setq local forms))
-           ((memq bare '(cl-block))
-            (scope-block local (car forms) (cdr forms)))
-           ((memq bare '(cl-return-from))
-            (scope-return-from local (car forms) (cadr forms)))
-           ((memq bare '(rx))           ; `rx' is unsafe, never expand!
-            (scope-rx local forms))
-           ((memq bare '(rx-define))
-            (scope-rx-define local (car forms) (cdr forms)))
-           ((memq bare '(rx-let))
-            (scope-rx-let local (car forms) (cdr forms)))
-           ;; ((memq bare '(rx-let-eval))
-           ;;  (scope-rx-let-eval local (car forms) (cdr forms)))
-           ((memq bare '(let-when-compile)) ; `let-when-compile' too!
-            (scope-let* local (car forms) (cdr forms)))
-           ((memq bare '(cl-eval-when)) ; Likewise!
-            (scope-n local (cdr forms)))
-           ((memq bare '(cl-macrolet))  ; Also `cl-macrolet'.
-            (scope-cl-macrolet local (car forms) (cdr forms)))
-           ((memq bare '(gv-define-expander))
-            (scope-gv-define-expander local (car forms) (cadr forms)))
-           ((memq bare '(gv-define-simple-setter))
-            (scope-gv-define-simple-setter
-             local (car forms) (cadr forms) (cddr forms)))
-           ((memq bare '(cl-deftype))
-            (scope-deftype local (car forms) (cadr forms) (cddr forms)))
-           ((memq bare '(define-minor-mode))
-            (scope-define-minor-mode local (car forms) (cadr forms) (cddr forms)))
-           ((memq bare '(define-global-minor-mode define-globalized-minor-mode))
-            (scope-define-global-minor-mode
-             local (car forms) (cadr forms) (caddr forms) (cdddr forms)))
            ((scope-safe-macro-p bare)
-            (scope-1 local (let ((symbols-with-pos-enabled t))
-                             ;; Ignore errors from trying to expand
-                             ;; invalid macro calls such as (dolist).
-                             (ignore-errors
-                               (let ((macroexpand-all-environment
-                                      (append
-                                       ;; Inhibit expansion of unsafe
-                                       ;; macros during this expansion.
-                                       ;; We'll encounter them later on
-                                       ;; and handle them manually.
-                                       (mapcar #'list scope-unsafe-macros)
-                                       macroexpand-all-environment))
-                                     (macroexp-inhibit-compiler-macros t)
-                                     (warning-minimum-log-level :emergency))
-                                 (macroexpand-1 form macroexpand-all-environment))))))))
-         (scope-assume-func-p
-          (when (symbol-with-pos-p f)
-            (scope-report 'function
-                          (symbol-with-pos-pos f) (length (symbol-name bare))))
-          (scope-n local forms))))))
+            (let* ((warning-minimum-log-level :emergency)
+                   (macroexp-inhibit-compiler-macros t)
+                   (symbols-with-pos-enabled t)
+                   (macroexpand-all-environment
+                    (append (mapcar #'list scope-unsafe-macros) macroexpand-all-environment))
+                   (expanded (ignore-errors (macroexpand-1 form macroexpand-all-environment))))
+              (scope-1 local expanded)))))
+         (scope-assume-func-p (scope-report-s f 'function) (scope-n local forms))))))
    ((symbol-with-pos-p form) (scope-s local form))))
 
 (defun scope-n (local body) (dolist (form body) (scope-1 local form)))