diff --git a/etc/NEWS b/etc/NEWS index 320f7e40fb7..748d9c86eb9 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1151,6 +1151,13 @@ at run-time for the use of the associated deprecated features. '(setq eieio-backward-compatibility t)' can be used to recover the previous silence. +** ELisp mode + +*** Semantic highlighting support for Emacs Lisp. +'emacs-lisp-mode' can now use code analysis to highlight more symbols +more accurately. Customize the new user option +'elisp-fontify-semantically' to non-nil to enable this feature. + ** Text mode --- diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el new file mode 100644 index 00000000000..f33b5ff403c --- /dev/null +++ b/lisp/emacs-lisp/scope.el @@ -0,0 +1,2659 @@ +;;; scope.el --- Semantic analysis for ELisp symbols -*- lexical-binding: t; -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; Author: Eshel Yaron +;; Keywords: lisp, languages + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This library implements an analysis that determines the role of each +;; symbol in ELisp code. The entry point for the analysis is the +;; function `scope', see its docstring for usage information. + +;;; Code: + +(require 'cl-lib) + +(defvar scope--symbol-type-property-cache (make-hash-table)) + +(defun scope--define-symbol-type (name parents props) + (clrhash scope--symbol-type-property-cache) + (put name 'scope-parent-types parents) + (put name 'scope-type-properties props)) + +;;;###autoload +(defmacro scope-define-symbol-type (name parents &rest props) + (declare (indent defun)) + `(scope--define-symbol-type ',name ',parents ,(when props `(list ,@props)))) + +;;;###autoload +(defun scope-get-symbol-type-property (type prop) + (with-memoization (alist-get prop (gethash type scope--symbol-type-property-cache)) + (named-let loop ((current type) + (parents (get type 'scope-parent-types)) + (more nil) + (done nil)) + (or (plist-get (get current 'scope-type-properties) prop) + (when-let* ((next (car parents))) + (loop (car parents) (get next 'scope-parent-types) (append (cdr parents) more) done)) + (when-let* ((next (car more))) + (loop next (let (res) + (dolist (per (get next 'scope-parent-types)) + (unless (memq per done) + (push per res))) + (nreverse res)) + (cdr more) done)))))) + +;;;###autoload +(defun scope-set-symbol-type-property (type prop value) + (clrhash scope--symbol-type-property-cache) + (put type 'scope-type-properties + (plist-put (get type 'scope-type-properties) prop value))) + +;;;###autoload +(defun scope-symbol-type-p (sym) + (or (get sym 'scope-parent-types) (get sym 'scope-type-properties))) + +(defvar scope-read-symbol-type-history nil) + +(defun scope-read-symbol-type (prompt &optional default) + (completing-read + (format-prompt prompt default) + obarray #'scope-symbol-type-p 'confirm + nil 'scope-read-symbol-type-history default)) + +(defvar help-mode--current-data) + +;;;###autoload +(defun scope-describe-symbol-type (type) + (interactive (list (scope-read-symbol-type + "Describe symbol type" + (when-let* ((def (symbol-at-point)) + ((scope-symbol-type-p def))) + def)))) + (when (stringp type) (setq type (intern type))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'scope-describe-symbol-type type) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (insert "Symbol type " + (substitute-quotes (concat "`" (symbol-name type) "'")) + ":\n\n" + (substitute-quotes + (or (scope-get-symbol-type-property type :doc) + "Undocumented."))) + (when-let* ((parents (get type 'scope-parent-types))) + (insert "\n\nParent types: " + (mapconcat (lambda (parent) + (let ((name (symbol-name parent))) + (substitute-quotes + (concat + "`" + (buttonize + name #'scope-describe-symbol-type name + "mouse-2, RET: describe this symbol type") + "'")))) + parents ", "))) + (setq help-mode--current-data + (list :symbol type :type 'define-symbol-type + :file (find-lisp-object-file-name type 'define-symbol-type))))))) + +(scope-define-symbol-type symbol-type () + :doc "Symbol type names." + :definition 'symbol-type-definition + :face 'elisp-symbol-type + :help (cl-constantly "Symbol type") + :namespace 'symbol-type) + +(scope-define-symbol-type symbol-type-definition (symbol-type) + :doc "Symbol type name definitions." + :face 'elisp-symbol-type-definition + :help (cl-constantly "Symbol type definition") + :imenu "Symbol Type" + :namespace 'symbol-type) + +(scope-define-symbol-type variable () + :doc "Variable names." + :definition 'defvar + :face 'elisp-free-variable + :help (lambda (beg end _def) + (if-let* ((sym (intern (buffer-substring-no-properties beg end)))) + (lambda (&rest _) + (let ((val (if (boundp sym) (truncate-string-to-width (prin1-to-string (symbol-value sym)) 60 nil nil t) "#"))) + (if-let* ((doc (documentation-property sym 'variable-documentation t))) + (format "Special variable `%S'.\n\nValue: %s\n\n%s" sym val doc) + (format "Special variable `%S'.\n\nValue: %s" sym val)))) + "Special variable")) + :namespace 'variable) + +(scope-define-symbol-type bound-variable (variable) + :doc "Local variable names." + :face 'elisp-bound-variable + :help (cl-constantly "Local variable")) + +(scope-define-symbol-type binding-variable (bound-variable) + :doc "Local variable definitions." + :face 'elisp-binding-variable + :help (cl-constantly "Local variable binding")) + +(scope-define-symbol-type shadowed-variable (variable) + :doc "Locally shadowed variable names." + :face 'elisp-shadowed-variable + :help (cl-constantly "Locally shadowed variable")) + +(scope-define-symbol-type shadowing-variable (shadowed-variable) + :doc "Local variable definitions." + :face 'elisp-shadowing-variable + :help (cl-constantly "Local variable shadowing")) + +(scope-define-symbol-type face () + :doc "Face names." + :definition 'defface + :face 'elisp-face + :help (lambda (beg end _def) + (elisp--help-echo beg end 'face-documentation "Face")) + :namespace 'face) + +(scope-define-symbol-type callable () + :doc "Abstract symbol type of function-like symbols." + :namespace 'function) + +(scope-define-symbol-type function (callable) + :doc "Function names." + :definition '(defun defcmd) + :face 'elisp-function-reference + :help (lambda (beg end def) + (cond ((equal beg def) "Local function definition") + (def "Local function call") + (t (if-let* ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--function-help-echo sym) + "Function call"))))) + +(scope-define-symbol-type command (function) + :doc "Command names.") + +(scope-define-symbol-type unknown (function) + :doc "Unknown symbols at function position." + :face 'elisp-unknown-call + :help (cl-constantly "Unknown callable")) + +(scope-define-symbol-type non-local-exit (function) + :doc "Functions that do not return." + :face 'elisp-non-local-exit + :help (lambda (beg end _def) + (if-let* ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--function-help-echo sym) + "Non-local exit"))) + +(scope-define-symbol-type macro (callable) + :doc "Macro names." + :definition 'defmacro + :face 'elisp-macro-call + :help (lambda (beg end _def) + (if-let* ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--function-help-echo sym) + "Macro call"))) + +(scope-define-symbol-type undefined-macro (macro) + :doc "Known macro names whose definition is unknown." + :help (cl-constantly "Call to macro with unknown definition")) + +(scope-define-symbol-type special-form (callable) + :doc "Special form names." + :face 'elisp-special-form + :help (lambda (beg end _def) + (if-let* ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--function-help-echo sym) + "Special form"))) + +(scope-define-symbol-type throw-tag () + :doc "Symbols used as `throw'/`catch' tags." + :face 'elisp-throw-tag + :help (cl-constantly "`throw'/`catch' tag")) + +(scope-define-symbol-type warning-type () + :doc "Byte-compilation warning types." + :face 'elisp-warning-type + :help (cl-constantly "Warning type")) + +(scope-define-symbol-type feature () + :doc "Feature names." + :definition 'deffeature + :face 'elisp-feature + :help (cl-constantly "Feature") + :namespace 'feature) + +(scope-define-symbol-type deffeature (feature) + :doc "Feature definitions." + :imenu "Feature" + :help (cl-constantly "Feature definition")) + +(scope-define-symbol-type declaration () + :doc "Function attribute declaration types." + :face 'elisp-declaration + :help (cl-constantly "Declaration")) + +(scope-define-symbol-type rx-construct () + :doc "`rx' constructs." + :face 'elisp-rx + :help (cl-constantly "`rx' construct")) + +(scope-define-symbol-type theme () + :doc "Custom theme names." + :definition 'deftheme + :face 'elisp-theme + :help (cl-constantly "Theme")) + +(scope-define-symbol-type deftheme (theme) + :doc "Custom theme definitions." + :imenu "Theme" + :help (cl-constantly "Theme definition")) + +(scope-define-symbol-type thing () + :doc "`thing-at-point' \"thing\" identifiers." + :face 'elisp-thing + :help (cl-constantly "Thing (text object)")) + +(scope-define-symbol-type slot () + :doc "EIEIO slots." + :face 'elisp-slot + :help (cl-constantly "Slot")) + +(scope-define-symbol-type widget-type () + :doc "Widget types." + :definition 'widget-type-definition + :face 'elisp-widget-type + :help (cl-constantly "Widget type") + :namespace 'widget-type) + +(scope-define-symbol-type widget-type-definition (widget-type) + :doc "Widget type definitions." + :imenu "Widget" + :help (cl-constantly "Widget type definition")) + +(scope-define-symbol-type type () + :doc "ELisp object type names." + :face 'elisp-type + :help (cl-constantly "Type")) + +(scope-define-symbol-type deftype (type) + :doc "ELisp object type definitions." + :imenu "Type" + :help (cl-constantly "Type definition")) + +(scope-define-symbol-type group () + :doc "Customization groups." + :definition 'defgroup + :face 'elisp-group + :help (cl-constantly "Customization group")) + +(scope-define-symbol-type defgroup (group) + :doc "Customization group definitions." + :imenu "Group" + :help (cl-constantly "Customization group definition")) + +(scope-define-symbol-type nnoo-backend () + :doc "`nnoo' backend names." + :face 'elisp-nnoo-backend + :help (cl-constantly "`nnoo' backend")) + +(scope-define-symbol-type condition () + :doc "`condition-case' conditions." + :definition 'defcondition + :face 'elisp-condition + :help (lambda (beg end _def) + (if-let* ((sym (intern (buffer-substring-no-properties beg end)))) + (lambda (&rest _) + (let ((msg (get sym 'error-message))) + (apply #'concat + "`condition-case' condition" + (when (and msg (not (string-empty-p msg))) + `(": " ,msg))))) + "`condition-case' condition")) + :namespace 'condition) + +(scope-define-symbol-type defcondition (condition) + :doc "`condition-case' condition definitions." + :definition 'defcondition + :help (cl-constantly "`condition-case' condition definition")) + +(scope-define-symbol-type ampersand () + :doc "Argument list markers, such as `&optional' and `&rest'." + :face 'elisp-ampersand + :help (cl-constantly "Arguments separator")) + +(scope-define-symbol-type constant () + :doc "Self-evaluating symbols." + :face 'elisp-constant + :help (cl-constantly "Constant")) + +(scope-define-symbol-type defun () + :doc "Function definitions." + :definition 'defun + :face 'elisp-defun + :help (cl-constantly "Function definition") + :imenu "Function" + :namespace 'function) + +(scope-define-symbol-type defmacro () + :doc "Macro definitions." + :definition 'defmacro + :face 'elisp-defmacro + :help (cl-constantly "Macro definition") + :imenu "Macro" + :namespace 'function) + +(scope-define-symbol-type defcmd (defun) + :doc "Command definitions." + :definition 'defcmd + :help (cl-constantly "Command definition") + :imenu "Command") + +(scope-define-symbol-type defvar () + :doc "Variable definitions." + :definition 'defvar + :face 'elisp-defvar + :help (cl-constantly "Special variable definition") + :imenu "Variable" + :namespace 'variable) + +(scope-define-symbol-type defface () + :doc "Face definitions." + :definition 'defface + :face 'elisp-defface + :help (cl-constantly "Face definition") + :imenu "Face" + :namespace 'face) + +(scope-define-symbol-type major-mode () + :doc "Major mode names." + :definition 'major-mode-definition + :face 'elisp-major-mode-name + :help (lambda (beg end _def) + (if-let* ((sym (intern (buffer-substring-no-properties beg end)))) + (lambda (&rest _) + (if-let* ((doc (documentation sym))) + (format "Major mode `%S'.\n\n%s" sym doc) + "Major mode")) + "Major mode")) + :namespace 'function) + +(scope-define-symbol-type major-mode-definition (major-mode) + :doc "Major mode definitions." + :help (cl-constantly "Major mode definition") + :imenu "Major Mode") + +(scope-define-symbol-type block () + :doc "`cl-block' block names." + :help (lambda (beg _end def) + (if (equal beg def) "Block definition" "Block"))) + +(scope-define-symbol-type icon () + :doc "Icon names." + :definition 'deficon + :face 'elisp-icon + :help (cl-constantly "Icon") + :namespace 'icon) + +(scope-define-symbol-type deficon () + :doc "Icon definitions." + :definition 'deficon + :face 'elisp-deficon + :help (cl-constantly "Icon definition") + :imenu "Icon" + :namespace 'icon) + +(scope-define-symbol-type oclosure () + :doc "OClosure type names." + :definition 'defoclosure + :face 'elisp-oclosure + :help (lambda (beg end _def) + (if-let* ((sym (intern (buffer-substring-no-properties beg end)))) + (lambda (&rest _) + (if-let* ((doc (oclosure--class-docstring (get sym 'cl--class)))) + (format "OClosure type `%S'.\n\n%s" sym doc) + "OClosure type")) + "OClosure type")) + :namespace 'oclosure) + +(scope-define-symbol-type defoclosure () + :doc "OClosure type definitions." + :definition 'defoclosure + :face 'elisp-defoclosure + :help (cl-constantly "OClosure type definition") + :imenu "OClosure type" + :namespace 'oclosure) + +(scope-define-symbol-type coding () + :doc "Coding system names." + :definition 'defcoding + :face 'elisp-coding + :help (lambda (beg end _def) + (if-let* ((sym (intern (buffer-substring-no-properties beg end)))) + (lambda (&rest _) + (if-let* ((doc (coding-system-doc-string sym))) + (format "Coding system `%S'.\n\n%s" sym doc) + "Coding system")) + "Coding system")) + :namespace 'coding) + +(scope-define-symbol-type defcoding () + :doc "Coding system definitions." + :definition 'defcoding + :face 'elisp-defcoding + :help (cl-constantly "Coding system definition") + :imenu "Coding system" + :namespace 'coding) + +(scope-define-symbol-type charset () + :doc "Charset names." + :definition 'defcharset + :face 'elisp-charset + :help (lambda (beg end _def) + (if-let* ((sym (intern (buffer-substring-no-properties beg end)))) + (lambda (&rest _) + (if-let* ((doc (charset-description sym))) + (format "Charset `%S'.\n\n%s" sym doc) + "Charset")) + "Charset")) + :namespace 'charset) + +(scope-define-symbol-type defcharset () + :doc "Charset definitions." + :definition 'defcharset + :face 'elisp-defcharset + :help (cl-constantly "Charset definition") + :imenu "Charset" + :namespace 'charset) + +(scope-define-symbol-type completion-category () + :doc "Completion categories." + :definition 'completion-category-definition + :face 'elisp-completion-category + :help (lambda (beg end _def) + (if-let* ((sym (intern (buffer-substring-no-properties beg end)))) + (lambda (&rest _) + (if-let* ((doc (get sym 'completion-category-documentation))) + (format "Completion category `%S'.\n\n%s" sym doc) + "Completion category")) + "Completion category")) + :namespace 'completion-category) + +(scope-define-symbol-type completion-category-definition () + :doc "Completion category definitions." + :definition 'completion-category-definition + :face 'elisp-completion-category-definition + :help (cl-constantly "Completion category definition") + :imenu "Completion category" + :namespace 'completion-category) + +(defvar scope-counter nil) + +(defvar scope-local-functions nil) + +(defvar scope--local nil) + +(defvar scope--output-type nil) + +(defvar scope-callback #'ignore) + +(defvar scope-current-let-alist-form nil) + +(defvar scope-gen-id-alist nil) + +(defsubst scope-local-new (sym pos &optional local) + "Return new local context with SYM bound at POS. + +Optional argument LOCAL is a local context to extend." + (cons (cons sym (or pos (cons 'gen (incf scope-counter)))) local)) + +(defsubst scope-sym-pos (sym) + (when (symbol-with-pos-p sym) (symbol-with-pos-pos sym))) + +(defsubst scope-sym-bare (sym) + (cond + ((symbolp sym) sym) + ((symbol-with-pos-p sym) (bare-symbol sym)))) + +(defvar scope--quoted nil) + +(defsubst scope-report (type beg len &optional id def) + (funcall scope-callback type beg len id (or def (and (numberp id) id)))) + +(defvar scope-special-variables nil) + +(defun scope-special-variable-p (sym) + (or (memq sym scope-special-variables) (special-variable-p sym))) + +(defun scope-variable (sym beg len id) + (scope-report + (if id (if (scope-special-variable-p sym) 'shadowed-variable 'bound-variable) 'variable) + beg len id)) + +(defun scope-binding (sym beg len) + (scope-report + (if (scope-special-variable-p sym) 'shadowing-variable 'binding-variable) + beg len beg)) + +(defun scope-s (sym) + (let* ((beg (scope-sym-pos sym)) + (bare (scope-sym-bare sym)) + (name (symbol-name bare)) + (len (length name))) + (when (and beg (not (booleanp bare))) + (cond + ((keywordp bare) (scope-report 'constant beg len)) + ((and scope-current-let-alist-form (= (aref name 0) ?.)) + (if (and (length> name 1) (= (aref name 1) ?.)) + ;; Double dot escapes `let-alist'. + (let* ((unescaped (intern (substring name 1)))) + (scope-variable unescaped beg len (alist-get unescaped scope--local))) + (scope-report 'bound-variable beg len + (list 'let-alist (car scope-current-let-alist-form) bare) + (cdr scope-current-let-alist-form)))) + (t (scope-variable bare beg len (alist-get bare scope--local))))))) + +(defun scope-let-1 (local bindings body) + (if bindings + (let* ((binding (ensure-list (car bindings))) + (sym (car binding)) + (bare (scope-sym-bare sym)) + (len (length (symbol-name bare))) + (beg (scope-sym-pos sym))) + (when beg (scope-binding bare beg len)) + (scope-1 (cadr binding)) + (scope-let-1 (if bare (scope-local-new bare beg local) local) + (cdr bindings) body)) + (let ((scope--local local)) + (scope-n body scope--output-type)))) + +(defun scope-let (bindings body) + (scope-let-1 scope--local bindings body)) + +(defun scope-let* (bindings body) + (if bindings + (let* ((binding (ensure-list (car bindings))) + (sym (car binding)) + (bare (bare-symbol sym)) + (len (length (symbol-name bare))) + (beg (scope-sym-pos sym))) + (when beg (scope-binding bare beg len)) + (scope-1 (cadr binding)) + (let ((scope--local (scope-local-new bare beg scope--local))) + (scope-let* (cdr bindings) body))) + (scope-n body scope--output-type))) + +(defun scope-interactive (intr spec modes) + (when (symbol-with-pos-p intr) + (scope-report 'special-form + (symbol-with-pos-pos intr) + (length (symbol-name (scope-sym-bare intr))))) + (scope-1 spec) + (mapc #'scope-major-mode-name modes)) + +(defun scope-lambda (args body &optional outtype) + (let ((l scope--local)) + (when (listp args) + (dolist (arg args) + (when-let* ((bare (bare-symbol arg)) + (beg (scope-sym-pos arg))) + (unless (memq bare '(&optional &rest)) + (setq l (scope-local-new bare beg l)))))) + ;; Handle docstring. + (cond + ((and (consp (car body)) + (or (symbol-with-pos-p (caar body)) + (symbolp (caar body))) + (eq (bare-symbol (caar body)) :documentation)) + (scope-s (caar body)) + (scope-1 (cadar body)) + (setq body (cdr body))) + ((stringp (car body)) (setq body (cdr body)))) + ;; Handle `declare'. + (when-let* ((form (car body)) + (decl (car-safe form)) + ((or (symbol-with-pos-p decl) + (symbolp decl))) + ((eq (bare-symbol decl) 'declare))) + (when (symbol-with-pos-p decl) + (scope-report 'macro + (symbol-with-pos-pos decl) + (length (symbol-name (bare-symbol decl))))) + (dolist (spec (cdr form)) + (when-let* ((head (car-safe spec)) + (bare (scope-sym-bare head))) + (when (symbol-with-pos-p head) + (scope-report 'declaration + (symbol-with-pos-pos head) + (length (symbol-name bare)))) + (cl-case bare + (completion (scope-sharpquote (cadr spec))) + (interactive-only + (when-let* ((bare (scope-sym-bare (cadr spec))) + ((not (eq bare t)))) + (scope-sharpquote (cadr spec)))) + (obsolete + (when-let* ((bare (scope-sym-bare (cadr spec)))) + (scope-sharpquote (cadr spec)))) + ((compiler-macro gv-expander gv-setter) + ;; Use the extended lexical environment `l'. + (let ((scope--local l)) + (scope-sharpquote (cadr spec)))) + (modes (mapc #'scope-major-mode-name (cdr spec))) + (interactive-args + (dolist (arg-form (cdr spec)) + (when-let* ((arg (car-safe arg-form))) + (let ((scope--local l)) (scope-s arg)) + (when (consp (cdr arg-form)) + (scope-1 (cadr arg-form))))))))) + (setq body (cdr body))) + ;; Handle `interactive'. + (when-let* ((form (car body)) + (intr (car-safe form)) + ((or (symbol-with-pos-p intr) + (symbolp intr))) + ((eq (bare-symbol intr) 'interactive))) + (scope-interactive intr (cadar body) (cddar body)) + (setq body (cdr body))) + ;; Handle ARGS. + (when (listp args) + (dolist (arg args) + (and (symbol-with-pos-p arg) + (let* ((beg (symbol-with-pos-pos arg)) + (bare (bare-symbol arg)) + (len (length (symbol-name bare)))) + (when (and beg (not (eq bare '_))) + (if (memq bare '(&optional &rest)) + (scope-report 'ampersand beg len) + (scope-report 'binding-variable beg len beg))))))) + ;; Handle BODY. + (let ((scope--local l)) (scope-n body outtype)))) + +(defun scope-defun (name args body) + (when-let* ((beg (scope-sym-pos name)) + (bare (scope-sym-bare name))) + (scope-report + (let ((tmp body)) + (when (stringp (car-safe tmp)) (pop tmp)) + (when (eq 'declare (scope-sym-bare (car-safe (car-safe tmp)))) (pop tmp)) + (if (eq 'interactive (scope-sym-bare (car-safe (car-safe tmp)))) + 'defcmd + 'defun)) + beg (length (symbol-name bare)))) + (scope-lambda args body)) + +(defun scope-setq (args) (scope-n args scope--output-type)) + +(defvar scope-flet-alist nil) + +(defun scope-flet (defs body) + (if defs + (let* ((def (car defs)) + (func (car def)) + (exps (cdr def)) + (beg (scope-sym-pos func)) + (bare (bare-symbol func))) + (when beg + (scope-report 'function beg (length (symbol-name bare)) beg)) + (if (cdr exps) + ;; def is (FUNC ARGLIST BODY...) + (scope-cl-lambda (car exps) (cdr exps)) + ;; def is (FUNC EXP) + (scope-1 (car exps))) + (let ((scope-flet-alist (scope-local-new bare beg scope-flet-alist))) + (scope-flet (cdr defs) body))) + (scope-n body))) + +(defun scope-labels (defs forms) + (if defs + (let* ((def (car defs)) + (func (car def)) + (args (cadr def)) + (body (cddr def)) + (beg (scope-sym-pos func)) + (bare (bare-symbol func))) + (when beg + (scope-report 'function beg (length (symbol-name bare)) beg)) + (let ((scope-flet-alist (scope-local-new bare beg scope-flet-alist))) + (scope-lambda args body) + (scope-flet (cdr defs) forms))) + (scope-n forms))) + +(defvar scope-block-alist nil) + +(defun scope-block (name body) + (if name + (let* ((beg (scope-sym-pos name)) + (bare (bare-symbol name))) + (when beg + (scope-report 'block beg (length (symbol-name bare)) beg)) + (let ((scope-block-alist (scope-local-new bare beg scope-block-alist))) + (scope-n body))) + (scope-n body))) + +(defun scope-return-from (name result) + (when-let* ((bare (and (symbol-with-pos-p name) (bare-symbol name))) + (pos (alist-get bare scope-block-alist))) + (scope-report 'block + (symbol-with-pos-pos name) (length (symbol-name bare)) pos)) + (scope-1 result)) + +(defvar scope-assume-func nil) + +(defun scope-sharpquote (arg) + (cond + ((or (symbol-with-pos-p arg) (symbolp arg)) + (let ((bare (bare-symbol arg))) + (cond + ((or (functionp bare) (memq bare scope-local-functions) (assq bare scope-flet-alist) scope-assume-func) + (scope-report-s arg 'function)) + (t (scope-report-s arg 'unknown))))) + ((consp arg) (scope-1 arg)))) + +(defun scope-loop-for-and (rest) + (if (eq (scope-sym-bare (car rest)) 'and) + (scope-loop-for scope--local (cadr rest) (cddr rest)) + (scope-loop rest))) + +(defun scope-loop-for-by (local expr rest) + (scope-1 expr) + (let ((scope--local local)) + (scope-loop-for-and rest))) + +(defun scope-loop-for-to (local expr rest) + (scope-1 expr) + (when-let* ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((eq bare 'by) + (scope-loop-for-by local (car more) (cdr more))) + (t (let ((scope--local local)) + (scope-loop-for-and rest)))))) + +(defun scope-loop-for-from (local expr rest) + (scope-1 expr) + (when-let* ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((memq bare '(to upto downto below above)) + (scope-loop-for-to local (car more) (cdr more))) + ((eq bare 'by) + (scope-loop-for-by local (car more) (cdr more))) + (t (let ((scope--local local)) + (scope-loop-for-and rest)))))) + +(defun scope-loop-for-= (local expr rest) + (scope-1 expr) + (when-let* ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((eq bare 'then) + (scope-loop-for-by local (car more) (cdr more))) + (t (let ((scope--local local)) + (scope-loop-for-and rest)))))) + +(defun scope-loop-for-being-the-hash-keys-of-using (form rest) + (let* ((var (cadr form)) + (bare (scope-sym-bare var)) + (beg (scope-sym-pos var))) + (when beg (scope-binding bare beg (length (symbol-name bare)))) + (let ((scope--local (scope-local-new bare beg scope--local))) + (scope-loop-for-and rest)))) + +(defun scope-loop-for-being-the-hash-keys-of (local expr rest) + (scope-1 expr) + (when-let* ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) + (let ((scope--local local)) + (cond + ((eq bare 'using) + (scope-loop-for-being-the-hash-keys-of-using (car more) (cdr more))) + (t (scope-loop-for-and rest)))))) + +(defun scope-loop-for-being-the-hash-keys (local word rest) + (when-let* ((bare (scope-sym-bare word))) + (cond + ((eq bare 'of) + (scope-loop-for-being-the-hash-keys-of local (car rest) (cdr rest)))))) + +(defun scope-loop-for-being-the (local word rest) + (when-let* ((bare (scope-sym-bare word))) + (cond + ((memq bare '(buffer buffers)) + (let ((scope--local local)) + (scope-loop-for-and rest))) + ((memq bare '( hash-key hash-keys + hash-value hash-values + key-code key-codes + key-binding key-bindings)) + (scope-loop-for-being-the-hash-keys local (car rest) (cdr rest)))))) + +(defun scope-loop-for-being (local next rest) + (scope-loop-for-being-the + local (car rest) + (if (memq (scope-sym-bare next) '(the each)) (cdr rest) rest))) + +(defun scope-loop-for (local vars rest) + (if vars + ;; FIXME: var need not be a symbol, see + ;; `cl-macs-loop-destructure-cons' test in cl-macs-tests.el. + (let* ((var (car (ensure-list vars))) + (bare (bare-symbol var)) + (beg (scope-sym-pos var))) + (when beg (scope-binding bare beg (length (symbol-name bare)))) + (scope-loop-for (scope-local-new bare beg local) (cdr-safe vars) rest)) + (when-let* ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((memq bare '(from upfrom downfrom)) + (scope-loop-for-from local (car more) (cdr more))) + ((memq bare '( to upto downto below above + in on in-ref)) + (scope-loop-for-to local (car more) (cdr more))) + ((memq bare '(by + across across-ref)) + (scope-loop-for-by local (car more) (cdr more))) + ((eq bare '=) + (scope-loop-for-= local (car more) (cdr more))) + ((eq bare 'being) + (scope-loop-for-being local (car more) (cdr more))))))) + +(defun scope-loop-repeat (form rest) + (scope-1 form) + (scope-loop rest)) + +(defvar scope-loop-into-vars nil) + +(defun scope-loop-collect (expr rest) + (scope-1 expr) + (let ((bw (scope-sym-bare (car rest))) + (more (cdr rest))) + (if (eq bw 'into) + (let* ((var (car more)) + (bare (scope-sym-bare var)) + (beg (scope-sym-pos var))) + (if (memq bare scope-loop-into-vars) + (progn + (scope-s var) + (scope-loop (cdr more))) + (when beg (scope-binding bare beg (length (symbol-name bare)))) + (let ((scope-loop-into-vars (cons bare scope-loop-into-vars)) + (scope--local (scope-local-new bare beg scope--local))) + (scope-loop (cdr more))))) + (scope-loop rest)))) + +(defun scope-loop-with-and (rest) + (if (eq (scope-sym-bare (car rest)) 'and) + (scope-loop-with (cadr rest) (cddr rest)) + (scope-loop rest))) + +(defun scope-loop-with (var rest) + (let* ((bare (scope-sym-bare var)) + (beg (symbol-with-pos-pos var)) + (l (scope-local-new bare beg scope--local)) + (eql (car rest))) + (when beg (scope-binding bare beg (length (symbol-name bare)))) + (if (eq (scope-sym-bare eql) '=) + (let* ((val (cadr rest)) (more (cddr rest))) + (scope-1 val) + (let ((scope--local l)) + (scope-loop-with-and more))) + (let ((scope--local l)) + (scope-loop-with-and rest))))) + +(defun scope-loop-do (form rest) + (scope-1 form) + (if (consp (car rest)) + (scope-loop-do (car rest) (cdr rest)) + (scope-loop rest))) + +(defun scope-loop-named (name rest) + (let* ((beg (scope-sym-pos name)) + (bare (scope-sym-bare name))) + (when beg + (scope-report 'block beg (length (symbol-name bare)) beg)) + (let ((scope-block-alist (scope-local-new bare beg scope-block-alist))) + (scope-loop rest)))) + +(defun scope-loop-finally (next rest) + (if-let* ((bare (scope-sym-bare next))) + (cond + ((eq bare 'do) + (scope-loop-do (car rest) (cdr rest))) + ((eq bare 'return) + (scope-1 (car rest)) + (scope-loop (cdr rest)))) + (if (eq (scope-sym-bare (car-safe next)) 'return) + (progn + (scope-1 (cadr next)) + (scope-loop (cdr rest))) + (scope-loop-do next rest)))) + +(defun scope-loop-initially (next rest) + (if (eq (scope-sym-bare next) 'do) + (scope-loop-do (car rest) (cdr rest)) + (scope-loop-do next rest))) + +(defvar scope-loop-if-depth 0) + +(defun scope-loop-if (keyword condition rest) + (scope-1 condition) + (let ((scope-loop-if-depth (1+ scope-loop-if-depth)) + (scope--local + ;; `if' binds `it'. + (scope-local-new 'it (scope-sym-pos keyword) scope--local))) + (scope-loop rest))) + +(defun scope-loop-end (rest) + (let ((scope-loop-if-depth (1- scope-loop-if-depth))) + (unless (minusp scope-loop-if-depth) + (scope-loop rest)))) + +(defun scope-loop-and (rest) + (when (plusp scope-loop-if-depth) (scope-loop rest))) + +(defun scope-loop (forms) + (when forms + (let* ((kw (car forms)) + (bare (scope-sym-bare kw)) + (rest (cdr forms))) + (cond + ((memq bare '(for as)) + (scope-loop-for scope--local (car rest) (cdr rest))) + ((memq bare '( repeat while until always never thereis iter-by + return)) + (scope-loop-repeat (car rest) (cdr rest))) + ((memq bare '(collect append nconc concat vconcat count sum maximize minimize)) + (scope-loop-collect (car rest) (cdr rest))) + ((memq bare '(with)) + (scope-loop-with (car rest) (cdr rest))) + ((memq bare '(do)) (scope-loop-do (car rest) (cdr rest))) + ((memq bare '(named)) (scope-loop-named (car rest) (cdr rest))) + ((memq bare '(finally)) (scope-loop-finally (car rest) (cdr rest))) + ((memq bare '(initially)) (scope-loop-initially (car rest) (cdr rest))) + ((memq bare '(if when unless)) (scope-loop-if kw (car rest) (cdr rest))) + ((memq bare '(end)) (scope-loop-end rest)) + ((memq bare '(and else)) (scope-loop-and rest)))))) + +(defun scope-named-let (name bindings body &optional outtype) + (let ((bare (scope-sym-bare name)) + (beg (scope-sym-pos name))) + (when beg + (scope-report 'function beg (length (symbol-name bare)) beg)) + (dolist (binding bindings) + (let* ((sym (car (ensure-list binding))) + (beg (symbol-with-pos-pos sym)) + (bare (bare-symbol sym))) + (when beg (scope-binding bare beg (length (symbol-name bare)))) + (scope-1 (cadr binding)))) + (let ((l scope--local)) + (dolist (binding bindings) + (when-let* ((sym (car (ensure-list binding))) + (bare (scope-sym-bare sym))) + (setq l (scope-local-new bare (scope-sym-pos sym) l)))) + (let ((scope-flet-alist (scope-local-new bare beg scope-flet-alist)) + (scope--local l)) + (scope-n body outtype))))) + +(defun scope-with-slots (spec-list object body) + (scope-1 object) + (scope-let spec-list body)) + +(defun scope-rx (regexps) + (dolist (regexp regexps) (scope-rx-1 regexp))) + +(defvar scope-rx-alist nil) + +(defun scope-rx-1 (regexp) + (if (consp regexp) + (let* ((head (car regexp)) + (bare (scope-sym-bare head))) + (when (and bare (symbol-with-pos-p head)) + (scope-report 'rx-construct + (symbol-with-pos-pos head) (length (symbol-name bare)) + (alist-get bare scope-rx-alist))) + (cond + ((memq bare '(literal regex regexp eval)) + (scope-1 (cadr regexp))) + ((memq bare '( seq sequence and : + or | + zero-or-more 0+ * *? + one-or-more 1+ + +? + zero-or-one optional opt \? \?? + = >= ** repeat + minimal-match maximal-match + group submatch + group-n submatch-n)) + (scope-rx (cdr regexp))))) + (when-let* (((symbol-with-pos-p regexp)) + (bare (scope-sym-bare regexp))) + (scope-report 'rx-construct + (symbol-with-pos-pos regexp) (length (symbol-name bare)) + (alist-get bare scope-rx-alist))))) + +(defun scope-rx-define (name rest) + (when-let* ((bare (scope-sym-bare name))) + (scope-report 'rx-construct + (symbol-with-pos-pos name) (length (symbol-name bare)) nil)) + (if (not (cdr rest)) + (scope-rx-1 (car rest)) + (let ((l scope-rx-alist) + (args (car rest)) + (rx (cadr rest))) + (dolist (arg args) + (and (symbol-with-pos-p arg) + (let* ((beg (symbol-with-pos-pos arg)) + (bare (bare-symbol arg)) + (len (length (symbol-name bare)))) + (when beg + (if (memq (bare-symbol arg) '(&optional &rest _)) + (scope-report 'ampersand beg len) + (scope-report 'rx-construct beg len beg)))))) + (dolist (arg args) + (when-let* ((bare (bare-symbol arg)) + (beg (scope-sym-pos arg))) + (unless (memq bare '(&optional &rest)) + (setq l (scope-local-new bare beg l))))) + (let ((scope-rx-alist l)) + (scope-rx-1 rx))))) + +(defun scope-rx-let (bindings body) + (if-let* ((binding (car bindings))) + (let ((name (car binding)) (rest (cdr binding))) + (when-let* ((bare (scope-sym-bare name)) + (beg (symbol-with-pos-pos name))) + (scope-report 'rx-construct + beg (length (symbol-name bare)) beg)) + (if (cdr rest) + (let ((l scope-rx-alist) + (args (car rest)) + (rx (cadr rest))) + (dolist (arg args) + (and (symbol-with-pos-p arg) + (let* ((beg (symbol-with-pos-pos arg)) + (bare (bare-symbol arg)) + (len (length (symbol-name bare)))) + (when beg + (if (memq (bare-symbol arg) '(&optional &rest _)) + (scope-report 'ampersand beg len) + (scope-report 'rx-construct beg len beg)))))) + (dolist (arg args) + (when-let* ((bare (bare-symbol arg)) + (beg (scope-sym-pos arg))) + (unless (memq bare '(&optional &rest)) + (setq l (scope-local-new bare beg l))))) + (let ((scope-rx-alist l)) + (scope-rx-1 rx)) + (let ((scope-rx-alist (scope-local-new (scope-sym-bare name) + (scope-sym-pos name) + scope-rx-alist))) + (scope-rx-let (cdr bindings) body))) + (scope-rx-1 (car rest)) + (let ((scope-rx-alist (scope-local-new (scope-sym-bare name) + (scope-sym-pos name) + scope-rx-alist))) + (scope-rx-let (cdr bindings) body)))) + (scope-n body))) + +(defun scope-gv-define-expander (name handler) + (when-let* ((beg (scope-sym-pos name)) (bare (scope-sym-bare name))) + (scope-report 'defun beg (length (symbol-name bare)))) + (scope-1 handler)) + +(defun scope-gv-define-simple-setter (name setter rest) + (when-let* ((beg (scope-sym-pos name)) (bare (scope-sym-bare name))) + (scope-report 'defun beg (length (symbol-name bare)))) + (when-let* ((beg (scope-sym-pos setter)) (bare (scope-sym-bare setter))) + (scope-report 'function beg (length (symbol-name bare)))) + (scope-n rest)) + +(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 + ((symbol-with-pos-p face) + (when-let* ((beg (scope-sym-pos face)) (bare (scope-sym-bare face))) + (scope-report 'face beg (length (symbol-name bare))))) + ((keywordp (scope-sym-bare (car-safe face))) + (let ((l face)) + (while l + (let ((kw (car l)) + (vl (cadr l))) + (setq l (cddr l)) + (when-let* ((bare (scope-sym-bare kw)) + ((keywordp bare))) + (when-let* ((beg (scope-sym-pos kw)) + (len (length (symbol-name bare)))) + (scope-report 'constant beg len)) + (when (eq bare :inherit) + (when-let* ((beg (scope-sym-pos vl)) (fbare (scope-sym-bare vl))) + (scope-report 'face beg (length (symbol-name fbare)))))))))))) + +(defun scope-deftype (name args body) + (when-let* ((beg (scope-sym-pos name)) (bare (scope-sym-bare name))) + (scope-report 'deftype beg (length (symbol-name bare)))) + (scope-lambda args body)) + +(defun scope-widget-type (form) + (when-let* (((memq (scope-sym-bare (car-safe form)) '(quote \`))) + (type (cadr form))) + (scope-widget-type-1 type))) + +(defun scope-widget-type-1 (type) + (cond + ((symbol-with-pos-p type) + (when-let* ((beg (scope-sym-pos type)) (bare (scope-sym-bare type))) + (scope-report 'widget-type + (symbol-with-pos-pos type) + (length (symbol-name (bare-symbol type)))))) + ((consp type) + (let ((head (car type))) + (when-let* ((beg (scope-sym-pos head)) (bare (scope-sym-bare head))) + (scope-report 'widget-type beg (length (symbol-name bare)))) + (when-let* ((bare (scope-sym-bare head))) + (scope-widget-type-arguments bare (cdr type))))))) + +(defun scope-widget-type-keyword-arguments (head kw args) + (when-let* ((beg (scope-sym-pos kw)) + (len (length (symbol-name (bare-symbol kw))))) + (scope-report 'constant beg len)) + (cond + ((and (memq head '(plist alist)) + (memq kw '(:key-type :value-type))) + (scope-widget-type-1 (car args))) + ((memq kw '(:action :match :match-inline :validate)) + (when-let* ((fun (car args)) + (beg (scope-sym-pos fun)) + (bare (scope-sym-bare fun))) + (scope-report 'function beg (length (symbol-name bare))))) + ((memq kw '(:args)) + (mapc #'scope-widget-type-1 (car args)))) + ;; TODO: (restricted-sexp :match-alternatives CRITERIA) + (scope-widget-type-arguments head (cdr args))) + +(defun scope-widget-type-arguments (head args) + (let* ((arg (car args)) + (bare (scope-sym-bare arg))) + (if (keywordp bare) + (scope-widget-type-keyword-arguments head bare (cdr args)) + (scope-widget-type-arguments-1 head args)))) + +(defun scope-widget-type-arguments-1 (head args) + (cl-case head + ((list cons group vector choice radio set repeat checklist) + (mapc #'scope-widget-type-1 args)) + ((function-item) + (when-let* ((fun (car args)) + (beg (scope-sym-pos fun)) + (bare (scope-sym-bare fun))) + (scope-report 'function beg (length (symbol-name bare))))) + ((variable-item) + (when-let* ((var (car args)) + (beg (scope-sym-pos var)) + (bare (scope-sym-bare var))) + (scope-report 'variable beg (length (symbol-name bare))))))) + +(defun scope-quoted-group (sym-form) + (when-let* (((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 'group beg (length (symbol-name bare))))) + +(defun scope-defmethod-1 (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)))) + (scope-binding bare beg len)) + (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 form)))) + ((symbol-with-pos-p spec) + (when-let* ((beg (symbol-with-pos-pos spec)) + (bare (bare-symbol spec)) + (len (length (symbol-name bare)))) + (scope-report 'type beg len)))) + (scope-defmethod-1 (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))) + (scope-report 'ampersand beg (length (symbol-name bare)))) + (scope-defmethod-1 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))) + (scope-report 'ampersand beg (length (symbol-name bare)))) + (scope-1 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 form)))) + ((symbol-with-pos-p spec) + (when-let* ((beg (symbol-with-pos-pos spec)) + (bare (bare-symbol spec)) + (len (length (symbol-name bare)))) + (scope-report 'type beg len beg)))) + (scope-defmethod-1 local more body))) + (t + (when-let* ((beg (scope-sym-pos arg)) + (len (length (symbol-name bare)))) + (scope-binding bare beg len)) + (scope-defmethod-1 (scope-local-new bare (scope-sym-pos arg) local) + (cdr args) body)))))) + (let ((scope--local local)) + (scope-n 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 (name rest) + (when-let* ((beg (scope-sym-pos name)) (bare (scope-sym-bare name))) + (scope-report 'defun beg (length (symbol-name bare)))) + ;; [EXTRA] + (when (eq (scope-sym-bare (car rest)) :extra) + (scope-s (car rest)) + (setq rest (cddr rest))) + ;; [QUALIFIER] + (when (keywordp (scope-sym-bare (car rest))) + (scope-s (car rest)) + (setq rest (cdr rest))) + ;; ARGUMENTS + (scope-defmethod-1 scope--local (car rest) (cdr rest))) + +(defun scope-cl-defun (name arglist body) + (let ((beg (scope-sym-pos name)) + (bare (scope-sym-bare name))) + (when beg (scope-report 'defun beg (length (symbol-name bare)))) + (let ((scope-block-alist (scope-local-new bare beg scope-block-alist))) + (scope-cl-lambda arglist body)))) + +(defun scope-cl-lambda (arglist body) + (scope-cl-lambda-1 arglist nil body)) + +(defun scope-cl-lambda-1 (arglist more body) + (cond + (arglist + (if (consp arglist) + (let ((head (car arglist))) + (if (consp head) + (scope-cl-lambda-1 head (cons (cdr arglist) more) body) + (let ((bare (scope-sym-bare head))) + (if (memq bare '(&optional &rest &body &key &aux &whole &cl-defs &cl-quote)) + (progn + (when-let* ((beg (scope-sym-pos head))) + (scope-report 'ampersand beg (length (symbol-name bare)))) + (cl-case bare + (&optional (scope-cl-lambda-optional (cadr arglist) (cddr arglist) more body)) + (&cl-defs (scope-cl-lambda-defs (cadr arglist) (cddr arglist) more body)) + ((&rest &body) (scope-cl-lambda-rest (cadr arglist) (cddr arglist) more body)) + (&key (scope-cl-lambda-key (cadr arglist) (cddr arglist) more body)) + (&aux (scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body)) + (&whole (scope-cl-lambda-1 (cdr arglist) more body)))) + (when-let* ((beg (scope-sym-pos head))) + (scope-binding bare beg (length (symbol-name bare)))) + (let ((scope--local (scope-local-new bare (scope-sym-pos head) scope--local))) + (scope-cl-lambda-1 (cdr arglist) more body)))))) + (scope-cl-lambda-1 (list '&rest arglist) more body))) + (more (scope-cl-lambda-1 (car more) (cdr more) body)) + (t (scope-lambda nil body)))) + +(defun scope-cl-lambda-defs (arg arglist more body) + (when (consp arg) + (let ((def (car arg)) + (defs (cdr arg))) + (scope-1 def) + (dolist (d defs) (scope-n (cdr-safe d))))) + (scope-cl-lambda-1 arglist more body)) + +(defun scope-cl-lambda-optional (arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l scope--local) + (init (cadr a)) + (svar (caddr a))) + (scope-1 init) + (if (consp var) + (let ((scope--local l)) + (scope-cl-lambda-1 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))) + (scope-binding bare beg (length (symbol-name bare)))) + (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))) + (scope-binding bare beg (length (symbol-name bare)))) + (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))) + (scope-report 'ampersand beg (length (symbol-name bare)))) + (cl-case bare + ((&rest &body) + (let ((scope--local l)) + (scope-cl-lambda-rest (cadr arglist) (cddr arglist) more body))) + (&key (let ((scope--local l)) + (scope-cl-lambda-key (cadr arglist) (cddr arglist) more body))) + (&aux (let ((scope--local l)) + (scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))))) + (let ((scope--local l)) + (scope-cl-lambda-optional head (cdr arglist) more body))))) + (more + (let ((scope--local l)) + (scope-cl-lambda-1 (car more) (cdr more) body))) + (t (let ((scope--local l)) (scope-lambda nil body))))))) + +(defun scope-cl-lambda-rest (var arglist more body) + (let* ((l scope--local)) + (if (consp var) + (scope-cl-lambda-1 var (cons arglist more) body) + (when-let* ((bare (scope-sym-bare var))) + (when-let* ((beg (scope-sym-pos var))) + (scope-binding bare beg (length (symbol-name bare)))) + (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))) + (scope-report 'ampersand beg (length (symbol-name bare)))) + (cl-case bare + (&key + (let ((scope--local l)) + (scope-cl-lambda-key (cadr arglist) (cddr arglist) more body))) + (&aux + (let ((scope--local l)) + (scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))))) + (let ((scope--local l)) + (scope-cl-lambda-1 (car more) (cdr more) body))))) + (more (let ((scope--local l)) + (scope-cl-lambda-1 (car more) (cdr more) body))) + (t (let ((scope--local l)) + (scope-lambda nil body))))))) + +(defun scope-cl-lambda-key (arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l scope--local) + (init (cadr a)) + (svar (caddr a)) + (kw (car-safe var))) + (scope-1 init) + (and kw (or (symbolp kw) (symbol-with-pos-p kw)) + (cadr var) + (not (cddr var)) + ;; VAR is (KEYWORD VAR) + (setq var (cadr var))) + (when-let* ((bare (scope-sym-bare kw)) + ((keywordp bare))) + (when-let* ((beg (scope-sym-pos kw))) + (scope-report 'constant beg (length (symbol-name bare)))) + (setq l (scope-local-new bare (scope-sym-pos svar) l))) + (if (consp var) + (let ((scope--local l)) + (scope-cl-lambda-1 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))) + (scope-binding bare beg (length (symbol-name bare)))) + (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))) + (scope-binding bare beg (length (symbol-name bare)))) + (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))) + (scope-report 'ampersand beg (length (symbol-name bare)))) + (cl-case bare + (&aux + (let ((scope--local l)) + (scope-cl-lambda-aux (cadr arglist) (cddr arglist) more body))) + (&allow-other-keys + (let ((scope--local l)) + (scope-cl-lambda-1 (car more) (cdr more) body))))) + (let ((scope--local l)) + (scope-cl-lambda-key head (cdr arglist) more body))))) + (more (let ((scope--local l)) + (scope-cl-lambda-1 (car more) (cdr more) body))) + (t (let ((scope--local l)) + (scope-lambda nil body))))))) + +(defun scope-cl-lambda-aux (arg arglist more body) + (let* ((a (ensure-list arg)) + (var (car a)) + (l scope--local) + (init (cadr a))) + (scope-1 init) + (if (consp var) + (let ((scope--local l)) + (scope-cl-lambda-1 var (cons arglist more) body)) + (when-let* ((bare (scope-sym-bare var))) + (when-let* ((beg (scope-sym-pos var))) + (scope-binding bare beg (length (symbol-name bare)))) + (setq l (scope-local-new bare (scope-sym-pos var) l))) + (let ((scope--local l)) + (cond + (arglist (scope-cl-lambda-aux (car arglist) (cdr arglist) more body)) + (more (scope-cl-lambda-1 (car more) (cdr more) body)) + (t (scope-lambda nil body))))))) + +(defvar scope-macrolet-alist nil) + +(defun scope-cl-macrolet (bindings body) + (if-let* ((b (car bindings))) + (let ((name (car b)) + (arglist (cadr b)) + (mbody (cddr b))) + (scope-cl-lambda arglist mbody) + (when-let* ((bare (scope-sym-bare name))) + (when-let* ((beg (scope-sym-pos name))) + (scope-report 'macro beg (length (symbol-name bare)) beg)) + (let ((scope-macrolet-alist (scope-local-new bare (scope-sym-pos name) scope-macrolet-alist))) + (scope-cl-macrolet (cdr bindings) body)))) + (scope-n body))) + +(defun scope-define-minor-mode (mode _doc body) + (let ((explicit-var nil) (command t)) + (while-let ((kw (car-safe body)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (when-let* ((beg (scope-sym-pos kw))) + (scope-report 'constant beg (length (symbol-name bkw)))) + (cl-case bkw + ((:init-value :keymap :after-hook :initialize) + (scope-1 (cadr body))) + (:lighter (scope-mode-line-construct (cadr body))) + ((:interactive) + (let ((val (cadr body))) + (when (consp val) (mapc #'scope-major-mode-name val)) + (setq command val))) + ((:variable) + (let* ((place (cadr body)) + (tail (cdr-safe place))) + (if (and tail (let ((symbols-with-pos-enabled t)) + (or (symbolp tail) (functionp tail)))) + (progn + (scope-1 (car place)) + (scope-sharpquote tail)) + (scope-1 place))) + (setq explicit-var t)) + ((:group) + (scope-quoted-group (cadr body))) + ((:predicate) ;For globalized minor modes. + (scope-global-minor-mode-predicate (cadr body))) + ((:on :off) + (let ((obod (cdr body))) + (while (and obod (not (keywordp (scope-sym-bare (car obod))))) + (scope-1 (pop obod))) + (setq body (cons bkw (cons nil obod)))))) + (setq body (cddr body))) + (when-let* ((bare (scope-sym-bare mode)) (beg (scope-sym-pos mode)) + (typ (if command 'defcmd 'defun))) + (scope-report typ beg (length (symbol-name bare))) + (unless explicit-var + (scope-report 'defvar beg (length (symbol-name bare))))) + (scope-n body))) + +(defun scope-global-minor-mode-predicate (pred) + (if (consp pred) + (if (eq 'not (scope-sym-bare (car pred))) + (mapc #'scope-global-minor-mode-predicate (cdr pred)) + (mapc #'scope-global-minor-mode-predicate pred)) + (scope-major-mode-name pred))) + +(defun scope-major-mode-name (mode) + (when-let* ((beg (scope-sym-pos mode)) + (bare (bare-symbol mode)) + ((not (booleanp bare))) + (len (length (symbol-name bare)))) + (scope-report 'major-mode beg len))) + +(defun scope-mode-line-construct (format) + (scope-mode-line-construct-1 format)) + +(defun scope-mode-line-construct-1 (format) + (cond + ((symbol-with-pos-p format) + (scope-report 'variable + (symbol-with-pos-pos format) + (length (symbol-name (bare-symbol format))))) + ((consp format) + (let ((head (car format))) + (cond + ((or (stringp head) (consp head) (integerp head)) + (mapc #'scope-mode-line-construct-1 format)) + ((or (symbolp head) (symbol-with-pos-p head)) + (scope-s head) + (cl-case (bare-symbol head) + (:eval + (scope-1 (cadr format))) + (:propertize + (scope-mode-line-construct-1 (cadr format)) + (when-let* ((props (cdr format)) + (symbols-with-pos-enabled t) + (val-form (plist-get props 'face))) + (scope-face-1 val-form))) + (otherwise + (scope-mode-line-construct-1 (cadr format)) + (scope-mode-line-construct-1 (caddr format)))))))))) + +(defcustom scope-safe-macros nil + "Specify which macros are safe to expand during code analysis. + +If this is t, macros are considered safe by default. Otherwise, this is +a (possibly empty) list of safe macros. + +Note that this option only affects analysis of untrusted code, for +trusted code macro expansion is always safe." + :type '(choice (const :tag "Trust all macros" t) + (repeat :tag "Trust these macros" symbol)) + :group 'lisp) + +(defvar scope-unsafe-macros + '( static-if cl-eval-when eval-when-compile eval-and-compile let-when-compile + rx cl-macrolet nnoo-define-basics)) + +(defun scope-safe-macro-p (macro) + (and (not (memq macro scope-unsafe-macros)) + (or (eq scope-safe-macros t) + (memq macro scope-safe-macros) + (get macro 'safe-macro) + (trusted-content-p)))) + +(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 type &rest body) + (declare (indent defun)) + (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1")))) + `(progn + (defun ,helper ,args ,@body) + (scope-define-analyzer ,fsym (f &rest args) + (scope-report-s f ',type) + (apply #',helper args) + (scope-n args))))) + +(defmacro scope-define-function-analyzer (fsym args &rest body) + (declare (indent defun)) + `(scope--define-function-analyzer ,fsym ,args function ,@body) + ;; (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-func-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 (f &rest args) + (scope-report-s f 'function) + (apply #',helper 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 (f &rest args) + (scope-report-s f 'macro) + (apply #',helper 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 (f &rest args) + (scope-report-s f 'macro) + (apply #',helper args))))) + +(defun scope--unquote (form) + (when (memq (scope-sym-bare (car-safe form)) '(quote function \`)) + (cadr form))) + +(scope-define-analyzer with-suppressed-warnings (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 body)) + +(scope-define-analyzer eval (f form &optional lexical) + (scope-report-s f 'function) + (if-let* ((quoted (scope--unquote form))) + (scope-1 quoted) + (scope-1 form)) + (scope-1 lexical)) + +(scope-define-func-analyzer funcall (&optional f &rest args) + (scope-1 f '(symbol . function)) + (dolist (arg args) (scope-1 arg))) + +(put 'apply 'scope-analyzer #'scope--analyze-funcall) + +(scope-define-func-analyzer defalias (&optional sym def docstring) + (scope-1 sym '(symbol . defun)) + (scope-1 def '(symbol . defun)) + (scope-1 docstring)) + +(scope-define-function-analyzer oclosure--define + (&optional name _docstring parent-names _slots &rest props) + (when-let* ((quoted (scope--unquote name))) (scope-report-s quoted 'defoclosure)) + (when-let* ((qs (scope--unquote parent-names))) + (dolist (q qs) + (scope-report-s q 'oclosure))) + (while-let ((kw (car-safe props)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (scope-report-s kw 'constant) + (cl-case bkw + (:predicate + (when-let* ((q (scope--unquote (cadr props)))) (scope-report-s q 'defun)))) + (setq props (cddr props)))) + +(scope-define-function-analyzer define-charset + (&optional name _docstring &rest _props) + (when-let* ((quoted (scope--unquote name))) (scope-report-s quoted 'defcharset))) + +(scope-define-function-analyzer define-charset-alias + (&optional alias charset) + (when-let* ((quoted (scope--unquote alias))) (scope-report-s quoted 'defcharset)) + (when-let* ((quoted (scope--unquote charset))) (scope-report-s quoted 'charset))) + +(scope-define-func-analyzer charset-chars + (&optional charset &rest rest) + (scope-1 charset '(symbol . charset)) + (mapc #'scope-1 rest)) + +(dolist (sym '(charset-description charset-info charset-iso-final-char + charset-long-name charset-plist + charset-short-name + get-charset-property put-charset-property + list-charset-chars + set-charset-plist + set-charset-priority + unify-charset + locale-charset-to-coding-system)) + (put sym 'scope-analyzer #'scope--analyze-charset-chars)) + +(scope-define-func-analyzer define-coding-system + (&optional name &rest rest) + (scope-1 name '(symbol . defcoding)) + (mapc #'scope-1 rest)) + +(scope-define-func-analyzer define-coding-system-alias + (&optional alias coding-system) + (scope-1 alias '(symbol . defcoding)) + (scope-1 coding-system '(symbol . coding))) + +(scope-define-function-analyzer decode-coding-region + (&optional _start _end coding-system &rest _) + (when-let* ((quoted (scope--unquote coding-system))) (scope-report-s quoted 'coding))) + +(put 'encode-coding-region 'scope-analyzer #'scope--analyze-decode-coding-region) + +(scope-define-function-analyzer decode-coding-string + (&optional _string coding-system &rest _) + (when-let* ((quoted (scope--unquote coding-system))) (scope-report-s quoted 'coding))) + +(dolist (sym '(encode-coding-char encode-coding-string)) + (put sym 'scope-analyzer #'scope--analyze-decode-coding-string)) + +(scope-define-function-analyzer coding-system-mnemonic + (&optional coding-system &rest _) + (when-let* ((quoted (scope--unquote coding-system))) (scope-report-s quoted 'coding))) + +(dolist (sym '(add-to-coding-system-list + check-coding-system + coding-system-aliases + coding-system-base + coding-system-category + coding-system-change-eol-conversion + coding-system-change-text-conversion + coding-system-charset-list + coding-system-doc-string + coding-system-eol-type + coding-system-eol-type-mnemonic + coding-system-get + coding-system-plist + coding-system-post-read-conversion + coding-system-pre-write-conversion + coding-system-put + coding-system-translation-table-for-decode + coding-system-translation-table-for-encode + coding-system-type + describe-coding-system + prefer-coding-system + print-coding-system + print-coding-system-briefly + revert-buffer-with-coding-system + set-buffer-file-coding-system + set-clipboard-coding-system + set-coding-system-priority + set-default-coding-systems + set-file-name-coding-system + set-keyboard-coding-system + set-next-selection-coding-system + set-selection-coding-system + set-terminal-coding-system + universal-coding-system-argument)) + (put sym 'scope-analyzer #'scope--analyze-coding-system-mnemonic)) + +(scope-define-func-analyzer thing-at-point (&optional thing no-props) + (scope-1 thing '(symbol . thing)) + (scope-1 no-props)) + +(dolist (sym '( forward-thing + beginning-of-thing + end-of-thing + bounds-of-thing-at-point)) + (put sym 'scope-analyzer #'scope--analyze-thing-at-point)) + +(scope-define-func-analyzer bounds-of-thing-at-mouse (&optional event thing) + (scope-1 event) + (scope-1 thing '(symbol . thing))) + +(scope-define-func-analyzer thing-at-mouse (&optional event thing no-props) + (scope-1 event) + (scope-1 thing '(symbol . thing)) + (scope-1 no-props)) + +(scope-define-function-analyzer custom-declare-variable (sym _default _doc &rest args) + (when-let* ((quoted (scope--unquote 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--unquote (cadr args)))) (scope-widget-type-1 quoted))) + (:group + (when-let* ((quoted (scope--unquote (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--unquote sym))) (scope-report-s quoted 'defgroup)) + (while-let ((kw (car-safe args)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (cl-case bkw + (:group + (when-let* ((quoted (scope--unquote (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--unquote face))) (scope-report-s q 'defface)) + (when-let* ((q (scope--unquote 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--unquote (cadr args)))) (scope-report-s q 'group)))) + (setq args (cddr args)))) + +(defun scope-typep (type) + (cond + ((or (symbolp type) (symbol-with-pos-p type)) + (unless (booleanp (scope-sym-bare type)) + (scope-report-s type 'type))) + ((consp type) + (cond + ((memq (scope-sym-bare (car type)) '(and or not)) + (mapc #'scope-typep (cdr type))) + ((eq (scope-sym-bare (car type)) 'satisfies) + (scope-report-s (cadr type) 'function)))))) + +(scope-define-function-analyzer cl-typep (_val type) + (when-let* ((q (scope--unquote type))) + (scope-typep q))) + +(scope-define-function-analyzer pulse-momentary-highlight-region (_start _end &optional face) + (when-let* ((q (scope--unquote face))) (scope-face q))) + +(scope--define-function-analyzer throw (tag _value) non-local-exit + (when-let* ((q (scope--unquote tag))) (scope-report-s q 'throw-tag))) + +(scope--define-function-analyzer signal (error-symbol &optional _data) non-local-exit + (when-let* ((q (scope--unquote error-symbol))) (scope-report-s q 'condition))) + +(scope--define-function-analyzer kill-emacs (&rest _) non-local-exit) +(scope--define-function-analyzer abort-recursive-edit (&rest _) non-local-exit) +(scope--define-function-analyzer top-level (&rest _) non-local-exit) +(scope--define-function-analyzer exit-recursive-edit (&rest _) non-local-exit) +(scope--define-function-analyzer tty-frame-restack (&rest _) non-local-exit) +(scope--define-function-analyzer error (&rest _) non-local-exit) +(scope--define-function-analyzer user-error (&rest _) non-local-exit) +(scope--define-function-analyzer minibuffer-quit-recursive-edit (&rest _) non-local-exit) +(scope--define-function-analyzer exit-minibuffer (&rest _) non-local-exit) + +(scope-define-func-analyzer run-hooks (&rest hooks) + (dolist (hook hooks) (scope-1 hook '(symbol . variable)))) + +(scope-define-func-analyzer fboundp (&optional symbol) + (scope-1 symbol '(symbol . function))) + +(scope-define-function-analyzer overlay-put (&optional _ov prop val) + (when-let* ((q (scope--unquote prop)) + ((eq (scope-sym-bare q) 'face)) + (face (scope--unquote val))) + (scope-face face))) + +(scope-define-function-analyzer add-face-text-property (&optional _start _end face &rest _) + (when-let* ((q (scope--unquote face))) (scope-face q))) + +(scope-define-function-analyzer facep (&optional face &rest _) + (when-let* ((q (scope--unquote face))) (scope-report-s q 'face))) + +(dolist (sym '( check-face face-id face-differs-from-default-p + face-name face-all-attributes face-attribute + face-foreground face-background face-stipple + face-underline-p face-inverse-video-p face-bold-p + face-italic-p face-extend-p face-documentation + set-face-documentation set-face-attribute + set-face-font set-face-background set-face-foreground + set-face-stipple set-face-underline set-face-inverse-video + set-face-bold set-face-italic set-face-extend)) + (put sym 'scope-analyzer #'scope--analyze-facep)) + +(scope-define-func-analyzer boundp (&optional var &rest rest) + (scope-1 var '(symbol . variable)) + (mapc #'scope-1 rest)) + +(dolist (sym '( set symbol-value define-abbrev-table + special-variable-p local-variable-p + local-variable-if-set-p add-variable-watcher + get-variable-watchers remove-variable-watcher + default-value set-default make-local-variable + buffer-local-value add-to-list add-to-history find-buffer + customize-set-variable set-variable + 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--unquote new))) (scope-report-s q 'defvar)) + (when-let* ((q (scope--unquote base))) (scope-report-s q 'variable))) + +(scope-define-func-analyzer define-error (&optional name message parent) + (scope-1 name '(symbol . defcondition)) + (scope-1 message) + (scope-1 parent '(or (symbol . condition) + (repeat . (symbol . condition))))) + +(scope-define-function-analyzer featurep (feature &rest _) + (when-let* ((q (scope--unquote feature))) (scope-report-s q 'feature))) + +(put 'require 'scope-analyzer #'scope--analyze-featurep) + +(scope-define-function-analyzer provide (feature &rest _) + (when-let* ((q (scope--unquote feature))) (scope-report-s q 'deffeature))) + +(scope-define-function-analyzer put-text-property (&optional _ _ prop val _) + (when (memq (scope-sym-bare (scope--unquote prop)) '(mouse-face face)) + (when-let* ((q (scope--unquote 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--unquote (car props))) + ((face mouse-face) + (when-let* ((q (scope--unquote (cadr props)))) (scope-face q)))) + (setq props (cddr props)))) + +(scope-define-function-analyzer eieio-defclass-internal (name superclasses _ _) + (when-let* ((q (scope--unquote name))) (scope-report-s q 'deftype)) + (when-let* ((q (scope--unquote 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--unquote name))) (scope-report-s q 'deftype)) + (when-let* ((q (scope--unquote parent))) (scope-report-s q 'type))) + +(scope-define-function-analyzer define-widget (name class _doc &rest args) + (when-let* ((q (scope--unquote name))) (scope-report-s q 'widget-type)) + (when-let* ((q (scope--unquote class))) (scope-report-s q 'widget-type)) + (while-let ((kw (car-safe args)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (cl-case bkw + (:type + (when-let* ((q (scope--unquote (cadr args)))) (scope-widget-type-1 q))) + (:args + (when-let* ((q (scope--unquote (cadr args)))) (mapc #'scope-widget-type-1 q)))) + (setq args (cddr args)))) + +(scope-define-function-analyzer provide-theme (name &rest _) + (when-let* ((q (scope--unquote name))) (scope-report-s q 'theme))) + +(dolist (sym '(enable-theme disable-theme load-theme custom-theme-p)) + (put sym 'scope-analyzer #'scope--analyze-provide-theme)) + +(scope-define-function-analyzer custom-theme-set-variables (theme &rest args) + (when-let* ((q (scope--unquote theme))) (scope-report-s q 'theme)) + (dolist (arg args) + (when-let* ((q (scope--unquote arg))) + (when (consp q) + (scope-report-s (pop q) 'variable) + (when (consp q) + (scope-1 (pop q)) + (dolist (request (car (cdr-safe q))) + (scope-report-s request 'feature))))))) + +(scope-define-function-analyzer custom-declare-theme (name &rest _) + (when-let* ((q (scope--unquote name))) (scope-report-s q 'deftheme))) + +(scope-define-function-analyzer eieio-oref (_obj slot) + (when-let* ((q (scope--unquote slot))) (scope-report-s q 'slot))) + +(dolist (fun '(slot-boundp slot-makeunbound slot-exists-p eieio-oref-default)) + (put fun 'scope-analyzer #'scope--analyze-eieio-oref)) + +(scope-define-function-analyzer eieio-oset (_obj slot _value) + (when-let* ((q (scope--unquote slot))) (scope-report-s q 'slot))) + +(put 'eieio-oset-default 'scope-analyzer #'scope--analyze-eieio-oset) + +(scope-define-function-analyzer derived-mode-p (modes &rest _obsolete) + (when-let* ((q (scope--unquote modes))) (scope-report-s q 'major-mode))) + +(scope-define-func-analyzer derived-mode-set-parent (&optional mode parent) + (scope-1 mode '(symbol . major-mode)) + (scope-1 parent '(symbol . major-mode))) + +(scope-define-func-analyzer scope-report (type &rest args) + (scope-1 type '(symbol . symbol-type)) + (mapc #'scope-1 args)) + +(scope-define-func-analyzer scope-report-s (&optional sym type) + (scope-1 sym) + (scope-1 type '(symbol . symbol-type))) + +(scope-define-func-analyzer scope-1 (&optional form outtype) + (scope-1 form) + (scope-1 outtype 'type)) + +(scope-define-function-analyzer icons--register (&optional name parent _spec _doc kws) + (when-let* ((q (scope--unquote name))) (scope-report-s q 'deficon)) + (when-let* ((q (scope--unquote parent))) (scope-report-s q 'icon)) + (when-let* ((q (scope--unquote kws))) + (while-let ((kw (car-safe q)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (scope-report-s kw 'constant) + (cl-case bkw + (:group (scope-report-s (cadr q) 'group))) + (setq q (cddr q))))) + +(scope-define-function-analyzer setopt--set (&optional var _val) + (when-let* ((q (scope--unquote var))) (scope-report-s q 'variable))) + +(scope-define-function-analyzer autoload (&optional func _file _doc int &rest _) + (when-let* ((q (scope--unquote func))) (scope-report-s q 'function)) + (when-let* ((q (scope--unquote int)) ((listp q))) + (dolist (mode q) (scope-report-s mode 'major-mode)))) + +(scope-define-function-analyzer minibuffer--define-completion-category (&optional name parents &rest _) + (when-let* ((q (scope--unquote name))) (scope-report-s q 'completion-category-definition)) + (when-let* ((q (scope--unquote parents))) + (dolist (p (ensure-list q)) (scope-report-s p 'completion-category)))) + +;; (scope-define-macro-analyzer define-completion-category (l &optional name parent &rest rest) +;; (scope-report-s name 'completion-category-definition) +;; (scope-report-s parent 'completion-category) +;; (scope-n l rest)) + +(scope-define-func-analyzer completion-table-with-category (&optional category table) + (scope-1 category '(symbol . completion-category)) + (scope-1 table)) + +(defun scope--easy-menu-do-define-menu (menu) + (let ((items (cdr menu))) + (while-let ((kw (car-safe items)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (scope-report-s kw 'constant) + (cl-case bkw + ((:active :label :visible) (scope-1 (cadr items))) + ((:filter) (scope-sharpquote (cadr items)))) + (setq items (cddr items))) + (dolist (item items) + (cond + ((vectorp item) + (when (length> item 2) + (scope-sharpquote (aref item 1)) + (let ((it (cddr (append item nil)))) + (scope-1 (car it)) + (while-let ((kw (car-safe it)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (scope-report-s kw 'constant) + (cl-case bkw + ((:active :enable :label :visible :suffix :selected) (scope-1 (cadr it)))) + (setq it (cddr it)))))) + ((consp item) (scope--easy-menu-do-define-menu item)))))) + +(scope-define-function-analyzer easy-menu-do-define (&optional _symbol _maps _doc menu) + (when-let* ((q (scope--unquote menu))) + (scope--easy-menu-do-define-menu q))) + +(scope-define-function-analyzer define-key (&optional _keymaps _key def _remove) + (when-let* ((q (scope--unquote def))) + (cond + ((eq (scope-sym-bare (car-safe q)) 'menu-item) + (let ((fn (caddr q)) (it (cdddr q))) + (scope-sharpquote fn) + (while-let ((kw (car-safe it)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (scope-report-s kw 'constant) + (cl-case bkw + ((:active :enable :label :visible :suffix :selected) (scope-1 (cadr it))) + ((:filter) (scope-sharpquote (cadr it)))) + (setq it (cddr it))))) + ((or (symbolp q) (symbol-with-pos-p q)) + (scope-report-s q 'function))))) + +(scope-define-function-analyzer eval-after-load (&optional file form) + (when-let* ((q (scope--unquote file))) (scope-report-s q 'feature)) + (when-let* ((q (scope--unquote form))) (scope-1 q))) + +(scope-define-macro-analyzer define-globalized-minor-mode (global mode turn-on &rest body) + (scope-report-s mode 'function) + (scope-report-s turn-on 'function) + (scope-define-minor-mode global nil body)) + +(scope-define-macro-analyzer define-derived-mode (&optional child parent name &rest body) + (scope-report-s child 'major-mode-definition) + (scope-report-s parent 'major-mode) + (scope-mode-line-construct name) + (when (stringp (car body)) (pop body)) + (while-let ((kw (car-safe body)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (scope-report-s kw 'constant) + (cl-case bkw + (:group (scope-quoted-group (cadr body))) + ((:syntax-table :abbrev-table :after-hook) (scope-1 (cadr body)))) + (setq body (cddr body))) + (scope-n body)) + +(scope-define-macro-analyzer lambda (args &rest body) + (scope-lambda args body)) + +(defun scope-oclosure-lambda-1 (local bindings args body) + (if bindings + (let* ((binding (ensure-list (car bindings))) + (sym (car binding)) + (bare (scope-sym-bare sym)) + (len (length (symbol-name bare))) + (beg (scope-sym-pos sym))) + (when beg (scope-binding bare beg len)) + (scope-1 (cadr binding)) + (scope-oclosure-lambda-1 + (if bare (scope-local-new bare beg local) local) + (cdr bindings) args body)) + (let ((scope--local local)) + (scope-lambda args body)))) + +(defun scope-oclosure-lambda (spec args body) + (let ((type (car-safe spec))) + (scope-report-s type 'oclosure)) + (scope-oclosure-lambda-1 scope--local (cdr-safe spec) args body)) + +(scope-define-macro-analyzer oclosure-lambda (&optional spec args &rest body) + (scope-oclosure-lambda spec args body)) + +(scope-define-macro-analyzer cl-loop (&rest clauses) + (scope-loop clauses)) + +(scope-define-macro-analyzer named-let (name bindings &rest body) + (scope-named-let name bindings body scope--output-type)) + +(scope-define-macro-analyzer cl-flet (bindings &rest body) + (scope-flet bindings body)) + +(scope-define-macro-analyzer cl-labels (bindings &rest body) + (scope-labels bindings body)) + +(scope-define-macro-analyzer with-slots (spec-list object &rest body) + (scope-with-slots spec-list object body)) + +(scope-define-macro-analyzer cl-defmethod (name &rest rest) + (scope-defmethod name rest)) + +(scope-define-macro-analyzer cl-destructuring-bind (args expr &rest body) + (scope-1 expr) + (scope-cl-lambda args body)) + +(scope-define-macro-analyzer declare-function (&optional fn _file arglist _fileonly) + (scope-report-s fn 'function) + (scope-lambda (and (listp arglist) arglist) nil)) + +(scope-define-macro-analyzer cl-block (name &rest body) + (scope-block name body)) + +(scope-define-macro-analyzer cl-return-from (name &optional result) + (scope-return-from name result)) + +(scope-define-macro-analyzer rx (&rest regexps) + ;; Unsafe macro! + (scope-rx regexps)) + +(scope-define-macro-analyzer cl-tagbody (&rest body) + (let (labels statements) + (while body + (let ((head (pop body))) + (if (consp head) + (push head statements) + (push head labels)))) + (scope-cl-tagbody (nreverse labels) (nreverse statements)))) + +(defvar scope-label-alist nil) + +(defun scope-cl-tagbody (labels statements) + (if labels + (let* ((label (car labels)) + (bare (scope-sym-bare label))) + (when-let* ((beg (scope-sym-pos label))) + (scope-report 'label beg (length (symbol-name bare)) beg)) + (let ((scope-label-alist + (if bare + (scope-local-new bare (scope-sym-pos label) scope-label-alist) + scope-label-alist))) + (scope-cl-tagbody (cdr labels) statements))) + (scope-n statements))) + +(scope-define-macro-analyzer go (label) + ;; TODO: Change to a local macro defintion induced by `cl-tagbody'. + (when-let* ((bare (scope-sym-bare label)) + (pos (alist-get bare scope-label-alist)) + (beg (scope-sym-pos label))) + (scope-report 'label beg (length (symbol-name bare)) pos))) + +(scope-define-macro-analyzer rx-define (name &rest rest) + (scope-rx-define name rest)) + +(scope-define-macro-analyzer rx-let (bindings &rest body) + (scope-rx-let bindings body)) + +(scope-define-macro-analyzer let-when-compile (bindings &rest body) + ;; Unsafe macro! + (scope-let* bindings body)) + +(scope-define-macro-analyzer cl-eval-when (_when &rest body) + ;; Unsafe macro! + (scope-n body)) + +(scope-define-macro-analyzer cl-macrolet (bindings &rest body) + ;; Unsafe macro! + (scope-cl-macrolet bindings body)) + +(scope-define-macro-analyzer cl-symbol-macrolet (bindings &rest body) + ;; Unsafe macro! + (scope-let* bindings body)) + +(scope-define-macro-analyzer nnoo-define-basics (&optional backend) + ;; Unsafe macro! + (let* ((bare (bare-symbol backend)) + (len (length (symbol-name bare))) + (beg (scope-sym-pos backend))) + (when beg (scope-report 'nnoo-backend beg len)))) + +(scope-define-macro-analyzer gv-define-expander (name handler) + (scope-gv-define-expander name handler)) + +(scope-define-macro-analyzer gv-define-simple-setter (name setter &rest rest) + (scope-gv-define-simple-setter name setter rest)) + +(scope-define-macro-analyzer cl-deftype (name arglist &rest body) + (scope-deftype name arglist body)) + +(scope-define-macro-analyzer define-minor-mode (&optional mode doc &rest body) + (when mode (scope-define-minor-mode mode doc body))) + +(scope-define-macro-analyzer setq-local (&rest args) + (scope-setq args)) + +(put 'setq-default 'scope-analyzer #'scope--analyze-setq-local) + +(scope-define-macro-analyzer cl-defun (name arglist &rest body) + (scope-cl-defun name arglist body)) + +(put 'cl-defmacro 'scope-analyzer #'scope--analyze-cl-defun) + +(scope-define-macro-analyzer defun (&optional name arglist &rest body) + (when name (scope-defun name arglist body))) + +(scope-define-macro-analyzer defmacro (&optional name arglist &rest body) + (scope-report-s name 'defmacro) + (scope-lambda arglist body)) + +(put 'ert-deftest 'scope-analyzer #'scope--analyze-defun) + +(scope-define-macro-analyzer scope-define-symbol-type (&optional name parents &rest props) + (scope-report-s name 'symbol-type-definition) + (dolist (parent parents) (scope-report-s parent 'symbol-type)) + (while-let ((kw (car-safe props)) + (bkw (scope-sym-bare kw)) + ((keywordp bkw))) + (scope-report-s kw 'constant) + (cl-case bkw + (:face + (if-let* ((q (scope--unquote (cadr props)))) (scope-face-1 q) + (scope-1 (cadr props)))) + (:definition + (if-let* ((q (scope--unquote (cadr props)))) + (dolist (st (ensure-list q)) (scope-report-s st 'symbol-type)) + (scope-1 (cadr props)))) + (otherwise (scope-1 (cadr props)))) + (setq props (cddr props)))) + +(scope-define-macro-analyzer cl-letf (bindings &rest body) + (let ((l scope--local)) + (dolist (binding bindings) + (let ((place (car binding))) + (if (or (symbol-with-pos-p place) (symbolp place)) + (let* ((bare (bare-symbol place)) + (len (length (symbol-name bare))) + (beg (scope-sym-pos place))) + (when beg (scope-binding bare beg len)) + (setq l (scope-local-new bare beg l))) + (scope-1 place)) + (scope-1 (cadr binding)))) + (let ((scope--local l)) (scope-n body scope--output-type)))) + +(scope-define-macro-analyzer setf (&rest args) (scope-setq args)) + +(scope-define-macro-analyzer pop (&optional place) (scope-1 place)) + +(scope-define-macro-analyzer push (&optional newelt place) + (scope-1 newelt) + (scope-1 place)) + +(scope-define-macro-analyzer with-memoization (&optional place &rest body) + (scope-1 place) + (scope-n body scope--output-type)) + +(scope-define-macro-analyzer cl-pushnew (&rest args) + (mapc #'scope-1 args)) + +(dolist (sym '(incf decf)) + (put sym 'scope-analyzer #'scope--analyze-cl-pushnew)) + +(scope-define-macro-analyzer static-if (&optional test then &rest else) + (scope-1 test) + (scope-1 then scope--output-type) + (scope-n else scope--output-type)) + +(scope-define-macro-analyzer eval-when-compile (&rest body) + (scope-n body scope--output-type)) + +(put 'eval-and-compile 'scope-analyzer #'scope--analyze-eval-when-compile) + +(scope-define-macro-analyzer cl-callf (&rest args) + (scope-sharpquote (car args)) + (scope-n (cdr args))) + +(put 'cl-callf2 'scope-analyzer #'scope--analyze-cl-callf) + +(scope-define-macro-analyzer seq-let (args sequence &rest body) + (scope-1 sequence) + (let ((l scope--local)) + (dolist (arg args) + (let* ((bare (scope-sym-bare arg)) + (len (length (symbol-name bare))) + (beg (scope-sym-pos arg))) + (if (eq bare '&rest) + (scope-report 'ampersand beg len) + (when beg (scope-binding bare beg len)) + (setq l (scope-local-new bare beg l))))) + (let ((scope--local l)) (scope-n body)))) + +(scope-define-analyzer let-alist (f alist &rest body) + (scope-report-s f 'macro) + (scope-1 alist) + (let ((scope-current-let-alist-form + (cons (or (scope-sym-pos f) (cons 'gen (incf scope-counter))) + (scope-sym-pos f)))) + (scope-n body))) + +(scope-define-macro-analyzer define-obsolete-face-alias (&optional obs cur when) + (when-let* ((q (scope--unquote obs))) (scope-report-s q 'defface)) + (when-let* ((q (scope--unquote cur))) (scope-report-s q 'face)) + (scope-1 when)) + +(scope-define-macro-analyzer backquote (&optional structure) + (scope-backquote structure scope--output-type)) + +(defvar scope-backquote-depth 0) + +(defun scope-backquote (structure &optional outtype) + (let ((scope-backquote-depth (1+ scope-backquote-depth))) + (scope-backquote-1 structure outtype))) + +(defun scope-backquote-1 (structure &optional outtype) + (cond + ((vectorp structure) + (dotimes (i (length structure)) + (scope-backquote-1 (aref structure i)))) + ((atom structure) (scope-quote structure outtype)) + ((or (eq (car structure) backquote-unquote-symbol) + (eq (car structure) backquote-splice-symbol)) + (if (= scope-backquote-depth 1) + (scope-1 (cadr structure) outtype) + (let ((scope-backquote-depth (1- scope-backquote-depth))) + (scope-backquote-1 (cadr structure))))) + (t + (while (consp structure) (scope-backquote-1 (pop structure))) + (when structure (scope-backquote-1 structure))))) + +(scope-define-special-form-analyzer let (bindings &rest body) + (scope-let bindings body)) + +(scope-define-special-form-analyzer let* (bindings &rest body) + (scope-let* bindings body)) + +(scope-define-special-form-analyzer cond (&rest clauses) + (dolist (clause clauses) (scope-n clause scope--output-type))) + +(scope-define-special-form-analyzer setq (&rest args) + (scope-setq args)) + +(scope-define-special-form-analyzer defvar (&optional sym init _doc) + (scope-report-s sym 'defvar) + (scope-1 init)) + +(put 'defconst 'scope-analyzer #'scope--analyze-defvar) + +(defun scope-condition-case (var bodyform handlers) + (let* ((bare (bare-symbol var)) + (beg (when (symbol-with-pos-p var) (symbol-with-pos-pos var))) + (l (scope-local-new bare beg scope--local))) + (when beg (scope-binding bare beg (length (symbol-name bare)))) + (scope-1 bodyform scope--output-type) + (dolist (handler handlers) + (dolist (cond-name (ensure-list (car-safe handler))) + (when-let* ((cbeg (scope-sym-pos cond-name)) + (cbare (scope-sym-bare cond-name)) + (clen (length (symbol-name cbare)))) + (cond + ((booleanp cbare)) + ((keywordp cbare) (scope-report 'constant cbeg clen)) + (t (scope-report 'condition cbeg clen))))) + (let ((scope--local l)) + (scope-n (cdr handler) scope--output-type))))) + +(scope-define-special-form-analyzer condition-case (var bodyform &rest handlers) + (scope-condition-case var bodyform handlers)) + +(scope-define-macro-analyzer condition-case-unless-debug (var bodyform &rest handlers) + (scope-condition-case var bodyform handlers)) + +(scope-define-special-form-analyzer function (&optional arg) + (when arg (scope-sharpquote arg))) + +(scope-define-special-form-analyzer quote (arg) + (scope-quote arg scope--output-type)) + +(scope-define-special-form-analyzer if (&optional test then &rest else) + (scope-1 test) + (scope-1 then scope--output-type) + (scope-n else scope--output-type)) + +(scope-define-special-form-analyzer and (&rest forms) + (scope-n forms scope--output-type)) + +(scope-define-special-form-analyzer or (&rest forms) + (dolist (form forms) (scope-1 form scope--output-type))) + +(defun scope-quote (arg &optional outtype) + (when outtype + (when-let* ((type (scope--match-type-to-arg outtype arg))) + (scope--handle-quoted type arg)))) + +(cl-defgeneric scope--handle-quoted (type arg)) + +(cl-defmethod scope--handle-quoted ((_type (eql t)) _arg) + ;; Do nothing. + ) + +(cl-defmethod scope--handle-quoted ((_type (eql 'code)) arg) + (let ((scope--local nil) + (scope-current-let-alist-form nil) + (scope-flet-alist nil) + (scope-block-alist nil) + (scope-macrolet-alist nil) + (scope-label-alist nil) + (scope-rx-alist nil) + (scope--quoted t)) + (scope-1 arg))) + +(cl-defmethod scope--handle-quoted ((type (head symbol)) arg) + (scope-report-s arg (cdr type))) + +(cl-defmethod scope--handle-quoted ((type (head list)) arg) + (let ((types (cdr type))) + (while types (scope--handle-quoted (pop types) (pop arg))))) + +(cl-defmethod scope--handle-quoted ((type (head cons)) arg) + (scope--handle-quoted (cadr type) (car arg)) + (scope--handle-quoted (cddr type) (cdr arg))) + +(cl-defgeneric scope--match-type-to-arg (type arg)) + +(cl-defmethod scope--match-type-to-arg ((type (eql 'code)) _arg) type) + +(cl-defmethod scope--match-type-to-arg ((_type (eql 'type)) arg) + (scope--match-type-to-arg + ;; Unfold `type'. + '(or (equal . code) + (equal . type) + (cons (equal . symbol) . (symbol . symbol-type)) + (cons (equal . repeat) . type) + (cons (equal . or) . (repeat . type)) + (cons (equal . cons) . (cons type . type)) + (cons (equal . equal) . t)) + arg)) + +(cl-defmethod scope--match-type-to-arg ((type (head symbol)) arg) + (when (or (symbolp arg) (symbol-with-pos-p arg)) type)) + +(cl-defmethod scope--match-type-to-arg ((type (head repeat)) arg) + (when (listp arg) + (named-let loop ((args arg) (acc nil)) + (if args + (when-let* ((res (scope--match-type-to-arg (cdr type) (car args)))) + (loop (cdr args) (cons res acc))) + (cons 'list (nreverse acc)))))) + +(cl-defmethod scope--match-type-to-arg ((type (head or)) arg) + (named-let loop ((types (cdr type))) + (when types + (if-let* ((res (scope--match-type-to-arg (car types) arg))) res + (loop (cdr types)))))) + +(cl-defmethod scope--match-type-to-arg ((type (head cons)) arg) + (when (consp arg) + (let ((car-type (cadr type)) + (cdr-type (cddr type))) + (when-let* ((car-res (scope--match-type-to-arg car-type (car arg))) + (cdr-res (scope--match-type-to-arg cdr-type (cdr arg)))) + (cons 'cons (cons car-res cdr-res)))))) + +(cl-defmethod scope--match-type-to-arg ((type (head equal)) arg) + (equal (cdr type) arg)) + +(scope--match-type-to-arg '(repeat . + (or (cons (equal . foo) . (symbol footype)) + (cons (equal . bar) . (symbol bartype)))) + '((bar . spambar) (foo . spamfoo))) + +(scope-define-special-form-analyzer catch (&optional tag &rest body) + (scope-1 tag '(symbol . throw-tag)) + (scope-n body scope--output-type)) + +(scope-define-special-form-analyzer progn (&rest body) + (scope-n body scope--output-type)) + +(put 'inline 'scope-analyzer #'scope--analyze-progn) +(put 'save-current-buffer 'scope-analyzer #'scope--analyze-progn) +(put 'save-excursion 'scope-analyzer #'scope--analyze-progn) +(put 'save-restriction 'scope-analyzer #'scope--analyze-progn) + +(scope-define-special-form-analyzer while (&rest rest) + (mapc #'scope-1 rest)) + +(scope-define-special-form-analyzer prog1 (&rest body) + (when (consp body) (scope-1 (pop body) scope--output-type)) + (scope-n body)) + +(put 'unwind-protect 'scope-analyzer #'scope--analyze-prog1) + +(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))))) + +(defvar-local scope-buffer-file-name nil) + +(defun scope-1 (form &optional outtype) + (cond + ((consp form) + (let* ((f (car form)) (bare (scope-sym-bare f)) + (forms (cdr form)) (this nil)) + (when bare + (cond + ((setq this (assq bare scope-flet-alist)) + (scope-report + 'function (symbol-with-pos-pos f) (length (symbol-name bare)) (cdr this)) + (scope-n forms)) + ((setq this (assq bare scope-macrolet-alist)) + (when (symbol-with-pos-p f) + (scope-report + 'macro (symbol-with-pos-pos f) (length (symbol-name bare)) (cdr this))) + ;; Local macros can be unsafe, so we do not expand them. + ;; Hence we cannot interpret their arguments. + ) + ((setq this (function-get bare 'scope-analyzer)) + (let ((scope--output-type outtype)) (apply this form))) + ((special-form-p bare) (scope-report-s f 'special-form) (scope-n forms)) + ((macrop bare) (scope-report-s f 'macro) + (cond + ((eq (get bare 'edebug-form-spec) t) (scope-n forms)) + ((scope-safe-macro-p bare) + (let* ((warning-minimum-log-level :emergency) + (macroexp-inhibit-compiler-macros t) + (symbols-with-pos-enabled t) + (message-log-max nil) + (inhibit-message t) + (macroexpand-all-environment + (append (mapcar #'list scope-unsafe-macros) macroexpand-all-environment)) + (expanded (ignore-errors (macroexpand-1 form macroexpand-all-environment)))) + (scope-1 expanded))))) + ((or (functionp bare) (memq bare scope-local-functions)) + (scope-report-s f 'function) (scope-n forms)) + (t + (scope-report-s f 'unknown) + (when scope-assume-func (scope-n forms))))))) + ((symbol-with-pos-p form) (scope-s form)))) + +(defun scope-n (body &optional outtype) + (while (cdr-safe body) (scope-1 (pop body))) + (when-let* ((form (car-safe body))) (scope-1 form outtype))) + +;;;###autoload +(defun scope (callback &optional stream) + "Read and analyze code from STREAM, reporting findings via CALLBACK. + +Call CALLBACK for each analyzed symbol SYM with arguments TYPE, POS, +LEN, ID and DEF, where TYPE is a symbol that specifies the semantics of +SYM; POS is the position of SYM in STREAM; LEN is SYM's length; ID is an +object that uniquely identifies (co-)occurrences of SYM in the current +defun; and DEF is the position in which SYM is locally defined, or nil. +If SYM is itself a binding occurrence, then POS and BINDER are equal. +If SYM is not lexically bound, then BINDER is nil. This function +ignores `read-symbol-shorthands', so SYM and LEN always correspond to +the symbol as it appears in STREAM. + +If STREAM is nil, it defaults to the current buffer. + +This function recursively analyzes Lisp forms (HEAD . TAIL), usually +starting with a top-level form, by inspecting HEAD at each level." + (let ((scope-counter 0) + (scope-callback callback) + (read-symbol-shorthands nil) + (max-lisp-eval-depth 32768)) + (scope-1 (read-positioning-symbols (or stream (current-buffer)))))) + +(provide 'scope) +;;; scope.el ends here diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 42653069feb..cca9a4aef73 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -278,6 +278,286 @@ Comments in the form will be lost." (string-to-syntax "'"))))) start end))) +(defgroup elisp nil "Emacs Lisp editing support." :group 'lisp) + +(defcustom elisp-fontify-semantically nil + "Whether to highlight symbols according to their meaning. + +If this is non-nil, `emacs-lisp-mode' uses code analysis to determine +the role of each symbol and highlight it accordingly." + :type 'boolean) + +(defface elisp-symbol-at-mouse + '((((background light)) :background "#fff6d8") + (((background dark)) :background "#00422a")) + "Face for highlighting the symbol at mouse in Emacs Lisp code.") + +(defface elisp-free-variable '((t :inherit underline)) + "Face for highlighting free variables in Emacs Lisp code.") + +(defface elisp-condition '((t :foreground "red")) + "Face for highlighting `condition-case' conditions in Emacs Lisp code.") + +(defface elisp-major-mode-name '((t :foreground "#006400")) + "Face for highlighting major mode names in Emacs Lisp code.") + +(defface elisp-face '((t :inherit font-lock-type-face)) + "Face for highlighting face names in Emacs Lisp code.") + +(defface elisp-symbol-type '((t :foreground "#00008b" :inherit font-lock-function-call-face)) + "Face for highlighting symbol type names in Emacs Lisp code.") + +(defface elisp-symbol-type-definition '((t :foreground "#00008b" :inherit font-lock-function-name-face)) + "Face for highlighting symbol type names in Emacs Lisp code.") + +(defface elisp-function-reference '((t :inherit font-lock-function-call-face)) + "Face for highlighting function calls in Emacs Lisp code.") + +(defface elisp-non-local-exit '((t :inherit elisp-function-reference :underline "red")) + "Face for highlighting function calls in Emacs Lisp code.") + +(defface elisp-unknown-call '((t :inherit elisp-function-reference :foreground "#2f4f4f")) + "Face for highlighting unknown functions/macros in Emacs Lisp code.") + +(defface elisp-macro-call '((t :inherit font-lock-keyword-face)) + "Face for highlighting macro calls in Emacs Lisp code.") + +(defface elisp-special-form '((t :inherit elisp-macro-call)) + "Face for highlighting special forms in Emacs Lisp code.") + +(defface elisp-throw-tag '((t :inherit font-lock-constant-face)) + "Face for highlighting `catch'/`throw' tags in Emacs Lisp code.") + +(defface elisp-feature '((t :inherit font-lock-constant-face)) + "Face for highlighting feature names in Emacs Lisp code.") + +(defface elisp-rx '((t :foreground "#00008b")) + "Face for highlighting `rx' constructs in Emacs Lisp code.") + +(defface elisp-theme '((t :inherit font-lock-constant-face)) + "Face for highlighting custom theme names in Emacs Lisp code.") + +(defface elisp-binding-variable + '((t :slant italic :inherit font-lock-variable-name-face)) + "Face for highlighting binding occurrences of variables in Emacs Lisp code.") + +(defface elisp-bound-variable '((t :slant italic)) + "Face for highlighting bound occurrences of variables in Emacs Lisp code.") + +(defface elisp-shadowing-variable + '((t :inherit elisp-binding-variable :underline t)) + "Face for highlighting binding occurrences of variables in Emacs Lisp code.") + +(defface elisp-shadowed-variable + '((t :inherit elisp-bound-variable :underline t)) + "Face for highlighting bound occurrences of variables in Emacs Lisp code.") + +(defface elisp-variable-at-point '((t :inherit bold)) + "Face for highlighting (all occurrences of) the variable at point.") + +(defface elisp-warning-type '((t :inherit font-lock-type-face)) + "Face for highlighting byte-compilation warning type names in Emacs Lisp.") + +(defface elisp-declaration '((t :inherit font-lock-variable-use-face)) + "Face for highlighting function attribute declaration type names.") + +(defface elisp-thing '((t :inherit font-lock-type-face)) + "Face for highlighting `thing-at-point' \"thing\" names in Emacs Lisp.") + +(defface elisp-slot '((t :inherit font-lock-builtin-face)) + "Face for highlighting EIEIO slot names.") + +(defface elisp-widget-type '((t :inherit font-lock-type-face)) + "Face for highlighting widget type names in Emacs Lisp code.") + +(defface elisp-type '((t :inherit font-lock-type-face)) + "Face for highlighting object type names in Emacs Lisp code.") + +(defface elisp-group '((t :inherit font-lock-type-face)) + "Face for highlighting customization group names in Emacs Lisp code.") + +(defface elisp-nnoo-backend '((t :inherit font-lock-type-face)) + "Face for highlighting `nnoo' backend names in Emacs Lisp code.") + +(defface elisp-ampersand '((t :inherit font-lock-type-face)) + "Face for highlighting argument list markers, such as `&optional'.") + +(defface elisp-constant '((t :inherit font-lock-builtin-face)) + "Face for highlighting self-evaluating symbols in Emacs Lisp code.") + +(defface elisp-defun '((t :inherit font-lock-function-name-face)) + "Face for highlighting function definitions in Emacs Lisp code.") + +(defface elisp-defmacro '((t :inherit elisp-defun)) + "Face for highlighting macro definitions in Emacs Lisp code.") + +(defface elisp-defvar '((t :inherit font-lock-variable-name-face)) + "Face for highlighting variable definitions in Emacs Lisp code.") + +(defface elisp-defface '((t :inherit font-lock-variable-name-face)) + "Face for highlighting face definitions in Emacs Lisp code.") + +(defface elisp-icon '((t :inherit font-lock-type-face)) + "Face for highlighting icon name in Emacs Lisp code.") + +(defface elisp-deficon '((t :inherit elisp-icon)) + "Face for highlighting icon definitions in Emacs Lisp code.") + +(defface elisp-oclosure '((t :inherit font-lock-type-face)) + "Face for highlighting OClosure type names in Emacs Lisp code.") + +(defface elisp-defoclosure '((t :inherit elisp-oclosure)) + "Face for highlighting OClosure type definitions in Emacs Lisp code.") + +(defface elisp-coding '((t :inherit font-lock-type-face)) + "Face for highlighting coding system names in Emacs Lisp code.") + +(defface elisp-defcoding '((t :inherit elisp-coding)) + "Face for highlighting coding system definitions in Emacs Lisp code.") + +(defface elisp-charset '((t :inherit font-lock-type-face)) + "Face for highlighting charset names in Emacs Lisp code.") + +(defface elisp-defcharset '((t :inherit elisp-charset)) + "Face for highlighting charset definitions in Emacs Lisp code.") + +(defface elisp-completion-category '((t :inherit font-lock-type-face)) + "Face for highlighting completion category names in Emacs Lisp code.") + +(defface elisp-completion-category-definition + '((t :inherit elisp-completion-category)) + "Face for highlighting completion category definitions in Emacs Lisp code.") + +(defun elisp-local-references (pos) + "Return references to local variable at POS as (BEG . LEN) cons cells." + (let (all cur) + (save-excursion + (goto-char pos) + (beginning-of-defun) + (scope (lambda (_type beg len id &optional _def) + (when (<= beg pos (+ beg len)) + (setq cur id)) + (when id (setf (alist-get beg all) (list len id)))))) + (seq-keep + (pcase-lambda (`(,beg ,len ,id)) (when (equal id cur) (cons beg len))) + all))) + +(defun elisp-highlight-variable (pos) + "Highlight variable at POS along with its co-occurrences." + (pcase-dolist (`(,beg . ,len) (elisp-local-references pos)) + (let ((ov (make-overlay beg (+ beg len)))) + (overlay-put ov 'face 'elisp-variable-at-point) + (overlay-put ov 'elisp-highlight-variable t)))) + +(defun elisp-unhighlight-variable (pos) + "Remove variable highlighting across top-level form at POS." + (save-excursion + (goto-char pos) + (beginning-of-defun) + (remove-overlays (point) (progn (end-of-defun) (point)) + 'elisp-highlight-variable t))) + +(defun elisp-cursor-sensor (pos) + "Return `cursor-sensor-functions' for ELisp symbol at POS." + (list + (lambda (_win old dir) + (cl-case dir + (entered (elisp-highlight-variable pos)) + (left (elisp-unhighlight-variable old)))))) + +(defun elisp--function-help-echo (sym &rest _) + (when (fboundp sym) + (with-temp-buffer + (let ((standard-output (current-buffer))) + (insert "`" (symbol-name sym) "' is ") + (describe-function-1 sym)) + (buffer-string)))) + +(defun elisp--help-echo-1 (str sym prop &rest _) + (if-let* ((doc (documentation-property sym prop t))) + (format "%s `%S'.\n\n%s" str sym doc) + str)) + +(defun elisp--help-echo (beg end prop str) + (if-let* ((sym (intern-soft (buffer-substring-no-properties beg end)))) + (apply-partially #'elisp--help-echo-1 str sym prop) + str)) + +(defcustom elisp-add-help-echo t + "Whether to add `help-echo' property to symbols while highlighting them." + :type 'boolean) + +(defun elisp--annotate-symbol-with-help-echo (type beg end def) + (when elisp-add-help-echo + (put-text-property + beg end 'help-echo + (when-let* ((fun (scope-get-symbol-type-property type :help))) + (funcall fun beg end def))))) + +(defvar font-lock-beg) +(defvar font-lock-end) + +(defun elisp-extend-region-to-whole-defuns () + (when elisp-fontify-semantically + (let (changed) + (when-let* ((new-beg (syntax-ppss-toplevel-pos (syntax-ppss font-lock-beg)))) + (setq font-lock-beg new-beg changed t)) + (when-let* ((beg-of-end (syntax-ppss-toplevel-pos (syntax-ppss font-lock-end))) + (new-end (ignore-error scan-error (scan-sexps beg-of-end 1)))) + (setq font-lock-end new-end changed t)) + changed))) + +(defcustom elisp-fontify-symbol-precedence-function #'ignore + "Function that determines the precedence of semantic highlighting. + +The function takes two arguments, BEG and END, which are the beginning +and end positions in the current buffer of a symbol that is about to be +fontified during semantic highlighting. The function is called after +`font-lock-keywords' were already applied. If the function returns nil, +then semantic highlighting takes precedence, otherwise the highlighting +that `font-lock-keywords' applied takes precedence, if any." + :type '(choice + (function-item :tag "Prioritize semantic highlighting" ignore) + (function-item :tag "Prioritize `font-lock-keywords'" always) + (function :tag "Custom function"))) + +(defun elisp-fontify-symbol (type beg len id &optional def) + (let ((end (+ beg len))) + (elisp--annotate-symbol-with-help-echo type beg end def) + (let ((face (scope-get-symbol-type-property type :face))) + (add-face-text-property + beg end face + (cl-case elisp-fontify-symbol-precedence-function + (ignore nil) + (always t) + (otherwise (funcall elisp-fontify-symbol-precedence-function beg end)))) + (put-text-property beg end 'mouse-face `(,face elisp-symbol-at-mouse)) + (when id + (put-text-property beg (1+ end) 'cursor-sensor-functions + ;; Get a fresh list with SYM hardcoded, + ;; so that the value is distinguishable + ;; from the value in adjacent regions. + (elisp-cursor-sensor beg)))))) + +(defun elisp-fontify-region-semantically (beg end) + "Fontify symbols between BEG and END according to their semantics." + (save-excursion + (goto-char beg) + (while (< (point) end) (ignore-errors (scope #'elisp-fontify-symbol))))) + +(defun elisp-fontify-region (beg end &optional loudly) + "Fontify ELisp code between BEG and END. + +Non-nil optional argument LOUDLY permits printing status messages. + +This is the `font-lock-fontify-region-function' for `emacs-lisp-mode'." + (if (not elisp-fontify-semantically) + (font-lock-default-fontify-region beg end loudly) + (pcase (font-lock-default-fontify-region beg end loudly) + (`(jit-lock-bounds ,beg1 . ,end1) (setq beg beg1 end end1))) + (elisp-fontify-region-semantically beg end) + `(jit-lock-bounds ,beg . ,end))) + (defun elisp-outline-search (&optional bound move backward looking-at) "Don't use leading parens in strings for outline headings." (if looking-at @@ -375,7 +655,16 @@ be used instead. '(lisp-el-font-lock-keywords lisp-el-font-lock-keywords-1 lisp-el-font-lock-keywords-2)) + (dolist (prop '(cursor-sensor-functions help-echo mouse-face)) + (cl-pushnew prop + (alist-get 'font-lock-extra-managed-props + (nthcdr 5 font-lock-defaults)))) + (setf (alist-get 'font-lock-fontify-region-function + (nthcdr 5 font-lock-defaults)) + #'elisp-fontify-region) (setf (nth 2 font-lock-defaults) nil) + (add-hook 'font-lock-extend-region-functions + #'elisp-extend-region-to-whole-defuns nil t) (add-hook 'after-load-functions #'elisp--font-lock-flush-elisp-buffers) (if (boundp 'electric-pair-text-pairs) (setq-local electric-pair-text-pairs